home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / dired / dired-xemacs-highlight.el < prev    next >
Encoding:
Text File  |  1995-08-08  |  6.5 KB  |  192 lines
  1. ;;; Copyright (C) 1993 Cengiz Alaettinoglu
  2. ;;; Cengiz Alaettinoglu <ca@cs.umd.edu>
  3.  
  4. ;;; Copyright (C) 1991 Tim Wilson and Sebastian Kremer
  5. ;;; Tim.Wilson@cl.cam.ac.uk
  6. ;;; Sebastian Kremer <sk@thp.uni-koeln.de>
  7. ;;; Modified to work with XEmacs
  8.  
  9. ;; Keywords: dired extensions, faces
  10.  
  11. ;; This file is part of XEmacs.
  12.  
  13. ;; XEmacs is free software; you can redistribute it and/or modify it
  14. ;; under the terms of the GNU General Public License as published by
  15. ;; the Free Software Foundation; either version 2, or (at your option)
  16. ;; any later version.
  17.  
  18. ;; XEmacs is distributed in the hope that it will be useful, but
  19. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21. ;; General Public License for more details.
  22.  
  23. ;; You should have received a copy of the GNU General Public License
  24. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26.  
  27. ;;; Synched up with: Not synched with FSF.
  28.  
  29.  
  30. ; How to install
  31. ; (add-hook 'dired-load-hook '(lambda () (require 'dired-xemacs-highlight)) t)
  32.  
  33. (require 'dired)
  34. (require 'dired-extra "dired-x")
  35. (provide 'dired-xemacs-highlight)
  36.  
  37. (or (find-face 'dired-face-marked)
  38.     (and
  39.      (make-face 'dired-face-marked)
  40.      (or (face-differs-from-default-p 'dired-face-marked)
  41.      (if (eq (device-class) 'color)
  42.          (progn
  43.            (set-face-foreground 'dired-face-marked (face-foreground 'default))
  44.            (set-face-background 'dired-face-marked "PaleVioletRed"))
  45.        (set-face-underline-p 'dired-face-marked t)))))
  46.  
  47. (or (find-face 'dired-face-deleted)
  48.     (and
  49.      (make-face 'dired-face-deleted)
  50.      (or (face-differs-from-default-p 'dired-face-deleted)
  51.      (if (eq (device-class) 'color)
  52.          (progn
  53.            (set-face-foreground 'dired-face-deleted
  54.                     (face-foreground 'default))
  55.            (set-face-background 'dired-face-deleted "LightSlateGray"))
  56.        (set-face-underline-p 'dired-face-deleted t)))))
  57.  
  58. (or (find-face 'dired-face-directory)
  59.     (and
  60.      (make-face 'dired-face-directory)
  61.      (or (face-differs-from-default-p 'dired-face-directory)
  62.      (if (eq (device-class) 'color)
  63.          (progn 
  64.            (set-face-foreground 'dired-face-directory
  65.                     (face-foreground 'default))
  66.            (make-face-bold 'dired-face-directory))
  67.        (make-face-bold-italic 'dired-face-directory)))))
  68.  
  69. (or (find-face 'dired-face-executable)
  70.     (and
  71.      (make-face 'dired-face-executable)
  72.      (or (face-differs-from-default-p 'dired-face-executable)
  73.      (if (eq (device-class) 'color)
  74.          (set-face-foreground 'dired-face-executable "SeaGreen")
  75.        (make-face-bold 'dired-face-executable)))))
  76.  
  77. (or (find-face 'dired-face-setuid)
  78.     (and
  79.      (make-face 'dired-face-setuid)
  80.      (or (face-differs-from-default-p 'dired-face-setuid)
  81.      (if (eq (device-class) 'color)
  82.          (set-face-foreground 'dired-face-setuid "Red")
  83.        (make-face-bold 'dired-face-setuid)))))
  84.  
  85. (or (find-face 'dired-face-socket)
  86.     (and
  87.      (make-face 'dired-face-socket)
  88.      (or (face-differs-from-default-p 'dired-face-socket)
  89.      (if (eq (device-class) 'color)
  90.          (set-face-foreground 'dired-face-socket "Gold")
  91.        (make-face-italic 'dired-face-socket)))))
  92.  
  93. (or (find-face 'dired-face-symlink)
  94.     (and
  95.      (make-face 'dired-face-symlink)
  96.      (or (face-differs-from-default-p 'dired-face-symlink)
  97.      (if (eq (device-class) 'color)
  98.          (progn 
  99.            (set-face-foreground 'dired-face-symlink "MediumBlue")
  100.            (make-face-bold 'dired-face-symlink))
  101.        (make-face-italic 'dired-face-symlink)))))
  102.  
  103. (or (find-face 'dired-face-boring)
  104.     (and
  105.      (make-face 'dired-face-boring)
  106.      (or (face-differs-from-default-p 'dired-face-boring)
  107.      (if (eq (device-class) 'color)
  108.          (set-face-foreground 'dired-face-boring "Grey")
  109.        (set-face-background-pixmap
  110.         'dired-face-boring 
  111.         [32 2 "\125\125\125\125\252\252\252\252"])))))
  112.  
  113. (defvar dired-do-permission-highlighting-too nil
  114.   "Set if we think we should use dired-chmod style permission highlighting.
  115. This is determined at first-pass time, to avoid filtering the buffer twice.")
  116.  
  117. (defvar dired-x11-re-boring (if (fboundp 'dired-omit-regexp)
  118.                 (dired-omit-regexp)
  119.                   "^#\\|~$")
  120.   "Regexp to match backup, autosave and otherwise boring files.
  121. Those files are displayed in a boring color such as grey (see
  122. variable `dired-x11-boring-color').")
  123.  
  124. (defvar dired-re-socket
  125.   (concat dired-re-maybe-mark dired-re-inode-size "s"))
  126.  
  127. (defvar dired-re-setuid 
  128.   (concat dired-re-maybe-mark dired-re-inode-size
  129.       "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]")
  130.   "setuid plain file (even if not executable)")
  131.  
  132. (defvar dired-re-setgid 
  133.   (concat dired-re-maybe-mark dired-re-inode-size
  134.       "-[-r][-w][-x][-r][-w][Ss][-r][-w][xst]")
  135.   "setgid plain file (even if not executable)")
  136.  
  137. (defun dired-xemacs-highlight-one (face)
  138.   (and (dired-move-to-filename t)
  139.        (set-extent-face (make-extent (dired-move-to-filename) 
  140.                      (dired-move-to-end-of-filename)) 
  141.             face)))
  142.  
  143. (defun dired-xemacs-highlight ()
  144.   (message "Highlighting... directory")
  145.   ;; Let's try to do this in one pass...
  146.   (setq dired-do-permission-highlighting-too
  147.     (or dired-do-permission-highlighting-too (featurep 'dired-chmod)))
  148.   (if (and dired-do-permission-highlighting-too
  149.        (member 'dired-permissions-highlight dired-after-readin-hook))
  150.       (remove-hook 'dired-after-readin-hook 'dired-permissions-highlight))
  151.   (save-excursion
  152.     (goto-char (point-min))
  153.     (while (not (eobp))
  154.       (and (not (eolp))
  155.        (progn
  156.          (beginning-of-line)
  157.          (cond
  158.           ((re-search-forward
  159.         dired-x11-re-boring
  160.         (save-excursion
  161.           (end-of-line)
  162.           (point))
  163.         t)
  164.            (dired-xemacs-highlight-one 'dired-face-boring))
  165.           ((looking-at dired-re-dir)
  166.            (dired-xemacs-highlight-one 'dired-face-directory))
  167.           ((looking-at dired-re-sym)
  168.            (dired-xemacs-highlight-one 'dired-face-symlink))
  169.           ((or (looking-at dired-re-setuid)
  170.            (looking-at dired-re-setgid))
  171.            (dired-xemacs-highlight-one 'dired-face-setuid))
  172.           ((looking-at dired-re-exe)
  173.            (dired-xemacs-highlight-one 'dired-face-executable))
  174.           ((looking-at dired-re-socket)
  175.            (dired-xemacs-highlight-one 'dired-face-socket)))
  176.          (if dired-do-permission-highlighting-too
  177.          (dired-make-permissions-interactive))))
  178.       (forward-line 1))
  179.     (message "Highlighting...done")
  180.     ))
  181.  
  182. (defconst font-lock-keywords-dired-mode
  183.   (list (cons "^\\*.*$" 'dired-face-marked)
  184.     (cons "^\\D.*$" 'dired-face-deleted)))
  185.  
  186. (add-hook 'dired-after-readin-hook 'dired-xemacs-highlight)
  187. (add-hook 'dired-mode-hook 
  188.       '(lambda () 
  189.          (font-lock-mode nil)
  190.          (setq font-lock-keywords font-lock-keywords-dired-mode) 
  191.          ))
  192.