home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / epoch / tek-highlight-2.0 / tek-dired-highlight.el < prev    next >
Encoding:
Text File  |  1992-08-20  |  37.8 KB  |  1,034 lines
  1. ;; $Id: tek-dired-highlight.el,v 1.4 1992/08/18 04:13:24 rwhitby Rel $ 
  2. ;; $File: ~elib/tek/tek-dired-highlight.el $ 
  3.  
  4. ;; Copyright (C) 1992 Rod Whitby <rwhitby@research.canon.oz.au>
  5.  
  6. ;; A significantly modified version of dired-x11.el which was distributed
  7. ;; under the following copyright notice:
  8.  
  9. ;; Copyright (C) 1991 Tim Wilson and Sebastian Kremer
  10. ;; Tim.Wilson@cl.cam.ac.uk
  11. ;; Sebastian Kremer <sk@thp.uni-koeln.de>
  12.  
  13. ;; This program is free software; you can redistribute it and/or modify
  14. ;; it under the terms of the GNU General Public License as published by
  15. ;; the Free Software Foundation; either version 1, or (at your option)
  16. ;; any later version.
  17. ;;
  18. ;; This program is distributed in the hope that it will be useful,
  19. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;; GNU General Public License for more details.
  22. ;;
  23. ;; A copy of the GNU General Public License can be obtained from this
  24. ;; program's author (send electronic mail to the above address) or from
  25. ;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  26.  
  27. ;; OVERVIEW ===========================================================
  28.  
  29. ;; Alter the appearance (e.g. color) of directories, symlinks,
  30. ;; executables, sockets, setuid/setgid files, backup files,
  31. ;; auto-save files and files that match certain regexps.
  32.  
  33. ;; INSTALLATION =======================================================
  34. ;;
  35. ;; To install, add the following to your `dired-load-hook':
  36. ;;
  37. ;;       (if (boundp 'epoch::version)
  38. ;;        (load "tek-dired-highlight"))
  39. ;;
  40. ;; It is recommended to load tek-dired-highlight after dired-x because then
  41. ;; your settings for to be omitted files will be used for the set of
  42. ;; `boring' files (see below).
  43.  
  44. ;; Note that you need Epoch 3.2 or later.  These functions do not work
  45. ;; with Epoch 3.1.  They are known to work with Epoch 3.2 and 
  46. ;; Epoch 4.0 Beta patchlevel 0.
  47.  
  48. ;; This package will not work with standard (e.g. 18.57) Dired, you
  49. ;; need Sebastian Kremer's Tree Dired, available for ftp from
  50. ;;
  51. ;;     ftp.cs.buffalo.edu:pub/Emacs/diredall.tar.Z
  52. ;;
  53. ;; or
  54. ;;
  55. ;;     ftp.thp.uni-koeln.de[134.95.64.1]:/pub/gnu/emacs/diredall.tar.Z
  56.  
  57. ;; CUSTOMIZATION ======================================================
  58.  
  59. ;; Backup files, auto-save files, directories, symbolic links, executables,
  60. ;; setuid and setgid files, sockets and files that match certain regexps
  61. ;; are distinguished from other types of file (which appear in the default
  62. ;; font, color, etc).
  63.  
  64. ;; Highlighting styles may be customised by means of X11 resources.
  65. ;; The resource names to use are the elements of the list contained in the
  66. ;; variable `tek-dired-all-style-types'.
  67. ;; See the file tek-style-utils.el for details.
  68.  
  69. (if (boundp 'epoch::version)
  70.     (progn
  71.       
  72.       (require 'tek-style-utils)
  73.       (require 'unique-hooks)
  74.       
  75.       (require 'dired)
  76.  
  77.       (defvar tek-dired-re-boring (if (fboundp 'dired-omit-regexp)
  78.                       (dired-omit-regexp)
  79.                     nil) "\
  80. Regexp to match boring files.")
  81.       
  82.       (defvar tek-dired-boring-foreground "grey" "\
  83. Foreground color used to highlight \"boring\" files in dired if no value is
  84. defined in the X11 resources and the display device supports color.")
  85.       
  86.       (defvar tek-dired-boring-mono '(stipple) "\
  87. Effect used to highlight \"boring\" files in dired if no value is
  88. defined in the X11 resources and the display device does not support color.")
  89.       
  90.       (defvar tek-dired-boring-icon-pixmap nil "\
  91. Pixmap used for the icon for \"boring\" files in dired if no value is
  92. defined in the X11 resources and the display device supports color.")
  93.       
  94.       (defvar tek-dired-boring-icon-font nil "\
  95. Font used for the icon for \"boring\" files in dired if no value is
  96. defined in the X11 resources and the display device supports color.")
  97.       
  98.       (defvar tek-dired-boring-icon-bitmap nil "\
  99. Bitmap used for the icon for \"boring\" files in dired if no value is
  100. defined in the X11 resources and the display device does not support color.")
  101.       
  102.       (defvar tek-dired-auto-save-foreground "grey" "\
  103. Foreground color used to highlight auto-save files in dired if no value is
  104. defined in the X11 resources and the display device supports color.")
  105.       
  106.       (defvar tek-dired-auto-save-mono '(stipple) "\
  107. Effect used to highlight auto-save files in dired if no value is
  108. defined in the X11 resources and the display device does not support color.")
  109.       
  110.       (defvar tek-dired-auto-save-icon-pixmap nil "\
  111. Pixmap used for the icon for auto-save files in dired if no value is
  112. defined in the X11 resources and the display device supports color.")
  113.       
  114.       (defvar tek-dired-auto-save-icon-font nil "\
  115. Font used for the icon for auto-save files in dired if no value is
  116. defined in the X11 resources and the display device supports color.")
  117.       
  118.       (defvar tek-dired-auto-save-icon-bitmap nil "\
  119. Bitmap used for the icon for auto-save files in dired if no value is
  120. defined in the X11 resources and the display device does not support color.")
  121.       
  122.       (defvar tek-dired-backup-foreground "grey" "\
  123. Foreground color used to highlight backup files in dired if no value is
  124. defined in the X11 resources and the display device supports color.")
  125.       
  126.       (defvar tek-dired-backup-mono '(stipple) "\
  127. Effect used to highlight backup files in dired if no value is
  128. defined in the X11 resources and the display device does not support color.")
  129.       
  130.       (defvar tek-dired-backup-icon-pixmap nil "\
  131. Pixmap used for the icon for backup files in dired if no value is
  132. defined in the X11 resources and the display device supports color.")
  133.       
  134.       (defvar tek-dired-backup-icon-font nil "\
  135. Font used for the icon for backup files in dired if no value is
  136. defined in the X11 resources and the display device supports color.")
  137.       
  138.       (defvar tek-dired-backup-icon-bitmap nil "\
  139. Bitmap used for the icon for backup files in dired if no value is
  140. defined in the X11 resources and the display device does not support color.")
  141.       
  142.       (defvar tek-dired-directory-foreground "red3" "\
  143. Foreground color used to highlight directories in dired if no value is
  144. defined in the X11 resources and the display device supports color.")
  145.       
  146.       (defvar tek-dired-directory-mono '(underline) "\
  147. Effect used to highlight directories in dired if no value is
  148. defined in the X11 resources and the display device does not support color.")
  149.       
  150.       (defvar tek-dired-directory-icon-pixmap nil "\
  151. Pixmap used for the icon for directories in dired if no value is
  152. defined in the X11 resources and the display device supports color.")
  153.       
  154.       (defvar tek-dired-directory-icon-font nil "\
  155. Font used for the icon for directories in dired if no value is
  156. defined in the X11 resources and the display device supports color.")
  157.       
  158.       (defvar tek-dired-directory-icon-bitmap nil "\
  159. Bitmap used for the icon for directories in dired if no value is
  160. defined in the X11 resources and the display device does not support color.")
  161.       
  162.       (defvar tek-dired-executable-foreground "green3" "\
  163. Foreground color used to highlight executable files in dired if no value is
  164. defined in the X11 resources and the display device supports color.")
  165.       
  166.       (defvar tek-dired-executable-mono '(font) "\
  167. Effect used to highlight executable files in dired if no value is
  168. defined in the X11 resources and the display device does not support color.")
  169.       
  170.       (defvar tek-dired-executable-icon-pixmap nil "\
  171. Pixmap used for the icon for executable files in dired if no value is
  172. defined in the X11 resources and the display device supports color.")
  173.       
  174.       (defvar tek-dired-executable-icon-font nil "\
  175. Font used for the icon for executable files in dired if no value is
  176. defined in the X11 resources and the display device supports color.")
  177.       
  178.       (defvar tek-dired-executable-icon-bitmap nil "\
  179. Bitmap used for the icon for executable files in dired if no value is
  180. defined in the X11 resources and the display device does not support color.")
  181.       
  182.       (defvar tek-dired-setuid-foreground "red3" "\
  183. Foreground color used to highlight setuid files in dired if no value is
  184. defined in the X11 resources and the display device supports color.")
  185.       
  186.       (defvar tek-dired-setuid-mono nil "\
  187. Effect used to highlight setuid files in dired if no value is
  188. defined in the X11 resources and the display device does not support color.")
  189.       
  190.       (defvar tek-dired-setuid-icon-pixmap nil "\
  191. Pixmap used for the icon for setuid files in dired if no value is
  192. defined in the X11 resources and the display device supports color.")
  193.       
  194.       (defvar tek-dired-setuid-icon-font nil "\
  195. Font used for the icon for setuid files in dired if no value is
  196. defined in the X11 resources and the display device supports color.")
  197.       
  198.       (defvar tek-dired-setuid-icon-bitmap nil "\
  199. Bitmap used for the icon for setuid files in dired if no value is
  200. defined in the X11 resources and the display device does not support color.")
  201.       
  202.       (defvar tek-dired-socket-foreground "gold3" "\
  203. Foreground color used to highlight sockets in dired if no value is
  204. defined in the X11 resources and the display device supports color.")
  205.       
  206.       (defvar tek-dired-socket-mono nil "\
  207. Effect used to highlight sockets in dired if no value is
  208. defined in the X11 resources and the display device does not support color.")
  209.       
  210.       (defvar tek-dired-socket-icon-pixmap nil "\
  211. Pixmap used for the icon for sockets in dired if no value is
  212. defined in the X11 resources and the display device supports color.")
  213.       
  214.       (defvar tek-dired-socket-icon-font nil "\
  215. Font used for the icon for sockets in dired if no value is
  216. defined in the X11 resources and the display device supports color.")
  217.       
  218.       (defvar tek-dired-socket-icon-bitmap nil "\
  219. Bitmap used for the icon for sockets in dired if no value is
  220. defined in the X11 resources and the display device does not support color.")
  221.       
  222.       (defvar tek-dired-symlink-foreground "blue3" "\
  223. Foreground color used to highlight symbolic links in dired if no value is
  224. defined in the X11 resources and the display device supports color.")
  225.       
  226.       (defvar tek-dired-symlink-mono '(font) "\
  227. Effect used to highlight symbolic links in dired if no value is
  228. defined in the X11 resources and the display device does not support color.")
  229.       
  230.       (defvar tek-dired-symlink-icon-pixmap nil "\
  231. Pixmap used for the icon for symbolic links in dired if no value is
  232. defined in the X11 resources and the display device supports color.")
  233.       
  234.       (defvar tek-dired-symlink-icon-font nil "\
  235. Font used for the icon for symbolic links in dired if no value is
  236. defined in the X11 resources and the display device supports color.")
  237.       
  238.       (defvar tek-dired-symlink-icon-bitmap nil "\
  239. Bitmap used for the icon for symbolic links in dired if no value is
  240. defined in the X11 resources and the display device does not support color.")
  241.       
  242.       ;; If you need more elaborate customization, use function
  243.       ;; tek-dired-edit-file-type-style and save the setting afterwards.
  244.       
  245.       (defvar tek-dired-highlight-threshold (* 100 1024) "\
  246. If non-nil, a buffer size threshold (in bytes) above which
  247. highlighting will not take place (because it would be too slow).")
  248.       
  249. ;;; End of customization
  250.       
  251. ;;; Install ourselves in the right hooks:
  252.       
  253.       ;; If dired-x.el is also loaded, arrange it so that highlighting will
  254.       ;; be done after omitting uninteresting files, thus saving time:
  255.       
  256.       (postpend-unique-hook 'dired-after-readin-hook 'tek-dired-highlight)
  257.       
  258.       
  259. ;;; Handling the gory X11 details
  260.       
  261.       (defvar tek-dired-color (> (number-of-colors) 2) "\
  262. Whether we have a color display.")
  263.       
  264. ;;; File attribute types
  265.  
  266.       (defconst tek-dired-attribute-types
  267.     '(auto-save backup directory executable setuid socket symlink) "\
  268. List of all types of files that Dired will highlight according to the file
  269. attributes.
  270.  
  271. The attribute types are represented by the following symbols:
  272.  
  273.     auto-save   - auto-save files
  274.     backup      - backup files
  275.     directory    - directories
  276.     executable    - executable plain files
  277.     setuid    - setuid or setgid plain files
  278.     socket    - sockets in the file system
  279.     symlink    - symbolic links
  280. ")
  281.       
  282. ;;; File regexp types
  283.  
  284.       (defvar tek-dired-regexp-types
  285.     '(boring) "\
  286. List of all types of files that Dired will highlight according to the file
  287. name.
  288.  
  289. The regexp types are represented by the following symbols:
  290.  
  291.     boring    - boring files (those that match `tek-dired-re-boring')
  292. ")
  293.       
  294.       (defvar tek-dired-regexp-alist
  295.     (list
  296.      (cons 'boring tek-dired-re-boring)
  297.      ) "\
  298. Alist describing file regexp types and their regexps in Dired.
  299. Each element looks like
  300.  
  301.    \(REGEXP-TYPE REGEXP\)
  302.  
  303. REGEXP-TYPE is one of the symbols in the variable
  304. `tek-dired-file-regexp-types', e.g. `boring'.
  305.  
  306. See also function `tek-dired-edit-regexp' for advanced customization.
  307. ")
  308.   
  309.       ;; Access functions
  310.  
  311.       (defun tek-dired-get-regexp-elt (regexp-type)
  312.     ;; Get the element whose car is REGEXP-TYPE
  313.     ;; (e.g. `boring').
  314.     ;; Its second element (`cdr') is REGEXP-TYPE's regexp.
  315.     (assq regexp-type tek-dired-regexp-alist))
  316.       
  317.       (defun tek-dired-get-regexp (regexp-type)
  318.     ;; Get the regexp for the regexp type REGEXP-TYPE
  319.     ;; (e.g. `boring').
  320.     (cdr (tek-dired-get-regexp-elt regexp-type)))
  321.       
  322.       
  323. ;;; All file types
  324.  
  325.       (defconst tek-dired-all-types
  326.     (append tek-dired-attribute-types
  327.         tek-dired-regexp-types) "\
  328. List of all types of files that Dired will highlight.
  329. See `tek-dired-attribute-types' and `tek-dired-regexp-types'.
  330. ")
  331.       
  332. ;;; Highlight style types
  333.  
  334.       (defun tek-dired-highlight-type (file-type)
  335.     ;; Convert a file type into a highlight style.
  336.     (intern (concat (symbol-name file-type) "-highlight")))
  337.       
  338.       (defconst tek-dired-all-highlight-types
  339.     (mapcar 'tek-dired-highlight-type tek-dired-all-types) "\
  340. List of all style types that Dired will use to highlight files.")
  341.       
  342. ;;; Icon style types
  343.  
  344.       (defun tek-dired-icon-type (file-type)
  345.     ;; Convert a file type into an icon style type.
  346.     (intern (concat (symbol-name file-type) "-icon")))
  347.       
  348.       (defconst tek-dired-all-icon-types
  349.     (mapcar 'tek-dired-icon-type tek-dired-all-types) "\
  350. List of all style types that Dired will use to display icons for files.")
  351.       
  352. ;;; All style types
  353.  
  354.       (defconst tek-dired-all-style-types
  355.     (append tek-dired-all-highlight-types
  356.         tek-dired-all-icon-types) "\
  357. List of all style types that Dired will use to highlight files and
  358. display icons.")
  359.       
  360. ;;; There's no reason why these effects shouldn't be used for
  361. ;;; color too -- but with all those lovely colors, who would want
  362. ;;; to stipple or underline?
  363.       
  364.       (defconst tek-dired-mono-effects-alist
  365.     (list (cons 'underline "foreground")
  366.           (cons 'stipple tek-stipple)
  367.           (cons 'font  (or tek-italic-bold-fixed-font
  368.                    tek-bold-fixed-font
  369.                    tek-italic-fixed-font))
  370.           ) "\
  371. Effects which may be selected by the tek-dired-*-mono-effect variables")
  372.       
  373.       (defun tek-dired-mono-effects (effects)
  374.     ;; Return an alist of style fields according the the elements of
  375.     ;; EFFECTS.  If any styles are selected (ie the result is not nil)
  376.     ;; the list also includes foreground and background colors.
  377.     ;; (This doesn't work properly if an element of EFFECTS is not
  378.     ;; a proper value.)
  379.     (let ((style-fields
  380.            (mapcar
  381.         (function
  382.          (lambda (x) (assq x tek-dired-mono-effects-alist)))
  383.         effects)))
  384.       (if style-fields
  385.           (append '((foreground . "foreground")
  386.             (background . "background"))
  387.               style-fields)
  388.         nil)))
  389.       
  390.       (defvar tek-dired-style-alist
  391.     ;; Rather than complicating the code later we always explicitly set
  392.     ;; the foreground and background here (the defaults are not usually
  393.     ;; suitable).
  394.     
  395.     ;; By allowing the special ``colors'' "background" and "foreground"
  396.     ;; we achieve that tek-dired-style-alist can be set in ~/.emacs as a
  397.     ;; _constant_ list (without having to splice in the value of
  398.     ;; function foreground etc.), possibly with the help of
  399.     ;; tek-dired-edit-*-style.
  400.     
  401.     ;; Thus, the user in his ~./emacs doesn't need to do what we do
  402.     ;; here: splicing in the values of the color customization
  403.     ;; variables.
  404.     
  405.     (list
  406.      (list 'auto-save-highlight
  407.            (list 'color
  408.              (list (cons 'foreground tek-dired-auto-save-foreground)
  409.                (cons 'background "background")))
  410.            (list 'mono
  411.              (tek-dired-mono-effects tek-dired-auto-save-mono)))
  412.      (list 'auto-save-icon
  413.            (list 'color
  414.              (list (cons 'foreground "foreground")
  415.                (cons 'background "background")
  416.                (cons 'pixmap tek-dired-auto-save-icon-pixmap)
  417.                (cons 'font tek-dired-auto-save-icon-font)
  418.                ))
  419.            (list 'mono
  420.              (list (cons 'foreground "foreground")
  421.                (cons 'background "background")
  422.                (cons 'stipple tek-dired-auto-save-icon-bitmap))))
  423.      (list 'backup-highlight
  424.            (list 'color
  425.              (list (cons 'foreground tek-dired-backup-foreground)
  426.                (cons 'background "background")))
  427.            (list 'mono
  428.              (tek-dired-mono-effects tek-dired-backup-mono)))
  429.      (list 'backup-icon
  430.            (list 'color
  431.              (list (cons 'foreground "foreground")
  432.                (cons 'background "background")
  433.                (cons 'pixmap tek-dired-backup-icon-pixmap)
  434.                (cons 'font tek-dired-backup-icon-font)
  435.                ))
  436.            (list 'mono
  437.              (list (cons 'foreground "foreground")
  438.                (cons 'background "background")
  439.                (cons 'stipple tek-dired-backup-icon-bitmap))))
  440.      (list 'directory-highlight
  441.            (list 'color
  442.              (list (cons 'foreground tek-dired-directory-foreground)
  443.                (cons 'background "background")))
  444.            (list 'mono
  445.              (tek-dired-mono-effects tek-dired-directory-mono)))
  446.      (list 'directory-icon
  447.            (list 'color
  448.              (list (cons 'foreground "foreground")
  449.                (cons 'background "background")
  450.                (cons 'pixmap tek-dired-directory-icon-pixmap)
  451.                (cons 'font tek-dired-directory-icon-font)
  452.                ))
  453.            (list 'mono
  454.              (list (cons 'foreground "foreground")
  455.                (cons 'background "background")
  456.                (cons 'stipple tek-dired-directory-icon-bitmap))))
  457.      (list 'executable-highlight
  458.            (list 'color
  459.              (list (cons 'foreground tek-dired-executable-foreground)
  460.                (cons 'background "background")))
  461.            (list 'mono
  462.              (tek-dired-mono-effects tek-dired-executable-mono)))
  463.      (list 'executable-icon
  464.            (list 'color
  465.              (list (cons 'foreground "foreground")
  466.                (cons 'background "background")
  467.                (cons 'pixmap tek-dired-executable-icon-pixmap)
  468.                (cons 'font tek-dired-executable-icon-font)
  469.                ))
  470.            (list 'mono
  471.              (list (cons 'foreground "foreground")
  472.                (cons 'background "background")
  473.                (cons 'stipple tek-dired-executable-icon-bitmap))))
  474.      (list 'setuid-highlight
  475.            (list 'color
  476.              (list (cons 'foreground tek-dired-setuid-foreground)
  477.                (cons 'background "background")))
  478.            (list 'mono
  479.              (tek-dired-mono-effects tek-dired-setuid-mono)))
  480.      (list 'setuid-icon
  481.            (list 'color
  482.              (list (cons 'foreground "foreground")
  483.                (cons 'background "background")
  484.                (cons 'pixmap tek-dired-setuid-icon-pixmap)
  485.                (cons 'font tek-dired-setuid-icon-font)
  486.                ))
  487.            (list 'mono
  488.              (list (cons 'foreground "foreground")
  489.                (cons 'background "background")
  490.                (cons 'stipple tek-dired-setuid-icon-bitmap))))
  491.      (list 'socket-highlight
  492.            (list 'color
  493.              (list (cons 'foreground tek-dired-socket-foreground)
  494.                (cons 'background "background")))
  495.            (list 'mono
  496.              (tek-dired-mono-effects tek-dired-setuid-mono)))
  497.      (list 'socket-icon
  498.            (list 'color
  499.              (list (cons 'foreground "foreground")
  500.                (cons 'background "background")
  501.                (cons 'pixmap tek-dired-socket-icon-pixmap)
  502.                (cons 'font tek-dired-socket-icon-font)
  503.                ))
  504.            (list 'mono
  505.              (list (cons 'foreground "foreground")
  506.                (cons 'background "background")
  507.                (cons 'stipple tek-dired-socket-icon-bitmap))))
  508.      (list 'symlink-highlight
  509.            (list 'color
  510.              (list (cons 'foreground tek-dired-symlink-foreground)
  511.                (cons 'background "background")))
  512.            (list 'mono
  513.              (tek-dired-mono-effects tek-dired-symlink-mono)))
  514.      (list 'symlink-icon
  515.            (list 'color
  516.              (list (cons 'foreground "foreground")
  517.                (cons 'background "background")
  518.                (cons 'pixmap tek-dired-symlink-icon-pixmap)
  519.                (cons 'font tek-dired-symlink-icon-font)
  520.                ))
  521.            (list 'mono
  522.              (list (cons 'foreground "foreground")
  523.                (cons 'background "background")
  524.                (cons 'stipple tek-dired-symlink-icon-bitmap))))
  525.      (list 'boring-highlight
  526.            (list 'color
  527.              (list (cons 'foreground tek-dired-boring-foreground)
  528.                (cons 'background "background")))
  529.            (list 'mono
  530.              (tek-dired-mono-effects tek-dired-boring-mono)))
  531.      (list 'boring-icon
  532.            (list 'color
  533.              (list (cons 'foreground "foreground")
  534.                (cons 'background "background")
  535.                (cons 'pixmap tek-dired-boring-icon-pixmap)
  536.                (cons 'font tek-dired-boring-icon-font)
  537.                ))
  538.            (list 'mono
  539.              (list (cons 'foreground "foreground")
  540.                (cons 'background "background")
  541.                (cons 'stipple tek-dired-boring-icon-bitmap))))
  542.      ) "\
  543. Alist describing style types and their styles in Dired.
  544. Each element looks like
  545.  
  546.    \(STYLE-TYPE (color ((STYLE-FIELD1 . VALUE1)
  547.                         (STYLE-FIELD2 . VALUE2)
  548.                          ...))
  549.             (mono  ((STYLE-FIELD1 . VALUE1)
  550.                          (STYLE-FIELD2 . VALUE2)
  551.                          ...))\)
  552.  
  553. STYLE-TYPE is one of the symbols in the variable `tek-dired-all-style-types',
  554. e.g. `directory-highlight'.
  555.  
  556. The `color' alist describes attributes used on a color display, the
  557. optional `mono' alist those used on a monochrome display.
  558.  
  559. The possible STYLE-FIELDs (symbols, cf. function `make-style') and
  560. VALUEs (names of colors (as string), stipple patterns etc.) are
  561. described in `tek-dired-all-style-fields'.
  562.  
  563. See also functions `tek-dired-edit-*-style' for advanced customization.
  564. ")
  565.       
  566.       ;; Access functions.
  567.       
  568.       (defun tek-dired-get-style-alist-elt (style-type)
  569.     ;; Get the element whose car is STYLE-TYPE
  570.     ;; (e.g. `directory-highlight').
  571.     ;; Its second element (`cadr', or `nth 1') is STYLE-TYPE's style alist.
  572.     (assq (if tek-dired-color
  573.           'color
  574.         'mono)
  575.           (assq style-type tek-dired-style-alist)))
  576.       
  577.       (defun tek-dired-get-style-alist (style-type)
  578.     ;; Get the style-alist for the style type STYLE-TYPE
  579.     ;; (e.g. `directory-highlight').
  580.     (nth 1 (tek-dired-get-style-alist-elt style-type)))
  581.       
  582.       
  583. ;;; Styles control the appearance of text.
  584. ;;;
  585. ;;; In Epoch 3.2:
  586. ;;;   Buttons are created with attributes.
  587. ;;;   An attribute is an index into a table of styles.
  588. ;;;   Buttons are placed in buffers with `add-button'.
  589. ;;;
  590. ;;; In Epoch 4:
  591. ;;;   Zones are created with styles
  592. ;;;   Zones are placed in buffers with `add-zone'.
  593.       
  594.       
  595.       (defconst tek-dired-all-style-fields
  596.     '(foreground
  597.       background
  598.       cursor-foreground
  599.       cursor-background
  600.       underline
  601.       stipple
  602.       cursor-stipple
  603.       background-stipple
  604.       font
  605.       pixmap) "\
  606. List of all style fields known to dired.
  607. The symbols and their meanings are:
  608.  
  609.     foreground
  610.       The text foreground color, as a string or X-Cardinal
  611.       representing the color.
  612.  
  613.     background
  614.       The text background color.  You almost always want to set this
  615.       to the special string `\"background\"', which is replaced by the
  616.       value of `(background)' by dired.
  617.  
  618.     cursor-foreground
  619.       The character foreground color when the text cursor is on the
  620.       character.
  621.  
  622.     cursor-background
  623.       The character background color when the text cursor is on the
  624.       character.  You almost always want to set this to the string
  625.       `\"background\"'.
  626.  
  627.     stipple
  628.       The stipple pattern to use for the text.    This is an X-Bitmap
  629.       resource or list (WIDTH HEIGHT STRING).
  630.  
  631.     cursor-stipple
  632.       The stipple to use when the cursor is on the tex.
  633.  
  634.     background-stipple
  635.       The stipple to use for the background. Bits that are set in the
  636.       stipple are displayed in the screen background color.  Cleared
  637.       bits are displayed in the style background color.     See stipple.
  638.  
  639.     underline
  640.       The color to use for underlining. The value `\"foreground\"' is
  641.       useful.
  642.  
  643.     font
  644.       The font for the text, as an X-Font resource or string.  The
  645.       display will be messy unless this is a character-cell font of
  646.       the same pixel width as the default font.
  647.  
  648.     pixmap
  649.       The pixmap to use for the icon for the text.  This is an X-Pixmap
  650.       resource or list (.. to be defined ..).
  651. ")
  652.       
  653.       
  654.       
  655.       ;; Functions for getting and setting colors, bitmaps, and fonts.
  656.       
  657.       (defun tek-dired-make-style (style-name style style-alist)
  658.     ;; Edit STYLE or make a new style, with values from alist STYLE-ALIST
  659.     ;; STYLE-ALIST is a table of style-field and value, e.g
  660.     ;; ((foreground . "Grey")
  661.     ;;  (background . #<X-Cardinal 0>))
  662.     ;; Note that the values may be raw or cooked.
  663.     
  664.     (if (string-match "^Epoch 4" epoch::version)
  665.         ;; Epoch Buttons reference styles directly in epoch 4
  666.         (setq style
  667.           (tek-build-style style-name style
  668.                    (cdr (assq 'font style-alist))
  669.                    (cdr (assq 'foreground style-alist))
  670.                    (cdr (assq 'background style-alist))
  671.                    (cdr (assq 'cursor-foreground style-alist))
  672.                    (cdr (assq 'cursor-background style-alist))
  673.                    (cdr (assq 'underline style-alist))
  674.                    (cdr (assq 'stipple style-alist))
  675.                    (cdr (assq 'cursor-stipple style-alist))
  676.                    (cdr (assq 'background-stipple style-alist))
  677.                    (cdr (assq 'pixmap style-alist))
  678.                    ))
  679.       ;; else use highlighting as per epoch version 3 with attributes.
  680.       ;; As with epoch 4 but additionally allocate and return corresponding
  681.       ;; attribute.
  682.       (let ((attr (or style
  683.               (reserve-attribute))))
  684.         (setq style
  685.           (tek-build-style style-name (attribute-style attr)
  686.                    (cdr (assq 'font style-alist))
  687.                    (cdr (assq 'foreground style-alist))
  688.                    (cdr (assq 'background style-alist))
  689.                    (cdr (assq 'cursor-foreground style-alist))
  690.                    (cdr (assq 'cursor-background style-alist))
  691.                    (cdr (assq 'underline style-alist))
  692.                    (cdr (assq 'stipple style-alist))
  693.                    (cdr (assq 'cursor-stipple style-alist))
  694.                    (cdr (assq 'background-stipple style-alist))
  695.                    ;; No pixmaps in version 3
  696.                    nil))
  697.         (set-attribute-style attr style)
  698.         attr)))
  699.       
  700.       (defconst tek-dired-highlight-alist
  701.     (mapcar
  702.      (function
  703.       ;; returns e.g. `(directory . 3)' if directories are to be
  704.       ;; highlighted with style #3.
  705.       (lambda (x)
  706.         (let* ((x-highlight (tek-dired-highlight-type x))
  707.            (style-alist (tek-dired-get-style-alist x-highlight)))
  708.           ;; This test prevents tek-dired-highlight placing a button
  709.           ;; with default attributes over non-special files -- the
  710.           ;; default attributes are not necessarily the same as no
  711.           ;; attributes, so this may lead to unintentional highlighting.
  712.           (and style-alist
  713.            (cons x
  714.              (tek-dired-make-style
  715.               (concat "dired-" (symbol-name x-highlight))
  716.               ;; Make a new style
  717.               nil
  718.               style-alist))))))
  719.      tek-dired-all-types)
  720.     "Alist with elements
  721.  
  722.     \(TYPE ATTRIBUTE)
  723.  
  724. TYPE is a symbol describing a file type, see `tek-dired-all-types'.
  725. ATTRIBUTE describes how files of type TYPE are highlighted and
  726. is computed at load time from `tek-dired-style-alist'.")
  727.       
  728.       
  729.       (defconst tek-dired-icon-alist
  730.     (mapcar 
  731.      (function
  732.       ;; returns e.g. `(directory . 3)' if directory icons are to be
  733.       ;; style #3.
  734.       (lambda (x)
  735.         (let* ((x-icon (tek-dired-icon-type x))
  736.            (style-alist (tek-dired-get-style-alist x-icon)))
  737.           ;; This test prevents tek-dired-highlight placing a button
  738.           ;; with default attributes over non-special files -- the
  739.           ;; default attributes are not necessarily the same as no
  740.           ;; attributes, so this may lead to unintentional highlighting.
  741.           (and style-alist
  742.            (cons x
  743.              (tek-dired-make-style
  744.               (concat "dired-" (symbol-name x-icon))
  745.               ;; Make a new style
  746.               nil
  747.               style-alist))))))
  748.      tek-dired-all-types)
  749.     "Alist with elements
  750.  
  751.     \(TYPE ATTRIBUTE)
  752.  
  753. TYPE is a symbol describing a file icon type, see `tek-dired-all-types'.
  754. ATTRIBUTE describes how file icons of type TYPE are displayed and
  755. is computed at load time from `tek-dired-style-alist'.")
  756.       
  757.       
  758.       ;; Interactive changing of the appearance of file types
  759.       
  760.       (defun tek-dired-edit-highlight-style (file-type) "\
  761. Edit interactively the style of highlighting for files of type FILE-TYPE.
  762. Useful to try out different colors.
  763. See variable `tek-dired-all-style-fields' for an explanation of the
  764. allowed fields and their meanings.
  765.  
  766. This function changes the value of `tek-dired-style-alist' to reflect
  767. the changes.  You may want to set this variable to its new value in your
  768. ~/.emacs for future sessions if the normal customization variables don't
  769. suffice for you."
  770.     (interactive
  771.      (list (tek-dired-read-file-type
  772.         "Change appearance of highlighting of which file type? ")))
  773.     (let* ((style (cdr (assq file-type tek-dired-highlight-alist)))
  774.            (style-alist-elt
  775.         (tek-dired-get-style-alist-elt
  776.          (tek-dired-highlight-type file-type)))
  777.            (style-alist (nth 1 style-alist-elt)))
  778.       (setq style-alist
  779.         (tek-dired-read-style-alist
  780.          (symbol-name file-type) style-alist))
  781.       ;; if the alist has been enlarged we have to store it back into
  782.       ;; tek-dired-style-alist:
  783.       (setcdr style-alist-elt (list style-alist))
  784.       ;; Send nil in for the style-name, so X11 resources are not picked up
  785.       (tek-dired-make-style nil style style-alist)))
  786.       
  787.       (defun tek-dired-edit-icon-style (file-type) "\
  788. Edit interactively the style of the icon for files of type FILE-TYPE.
  789. Useful to try out different colors.
  790. See variable `tek-dired-all-style-fields' for an explanation of the
  791. allowed fields and their meanings.
  792.  
  793. This function changes the value of `tek-dired-style-alist' to reflect
  794. the changes.  You may want to set this variable to its new value in your
  795. ~/.emacs for future sessions if the normal customization variables don't
  796. suffice for you."
  797.     (interactive
  798.      (list (tek-dired-read-file-type
  799.         "Change appearance of icon of which file type? ")))
  800.     (let* ((style (cdr (assq file-type tek-dired-icon-alist)))
  801.            (style-alist-elt
  802.         (tek-dired-get-style-alist-elt
  803.          (tek-dired-icon-type file-type)))
  804.            (style-alist (nth 1 style-alist-elt)))
  805.       (setq style-alist
  806.         (tek-dired-read-style-alist
  807.          (symbol-name file-type) style-alist))
  808.       ;; if the alist has been enlarged we have to store it back into
  809.       ;; tek-dired-style-alist:
  810.       (setcdr style-alist-elt (list style-alist))
  811.       ;; Send nil in for the style-name, so X11 resources are not picked up
  812.       (tek-dired-make-style nil style style-alist)))
  813.       
  814.       (defun tek-dired-read-style-alist (type alist)
  815.     ;; Let user edit the current fields of ALIST or add new fields.
  816.     ;; TYPE is the file-type.  It is used for prompts only.
  817.     ;; Changes ALIST destructively and returns its new value.
  818.     ;; ALIST's keys must be symbols (i.e. assq instead of assoc will be
  819.     ;; used).
  820.     (let ((key-table
  821.            (tek-dired-symbol-list-to-table tek-dired-all-style-fields))
  822.           key-str key elt value)
  823.       (while (not (equal ""
  824.                  (setq key-str
  825.                    (completing-read
  826.                     (concat "Edit which key of "
  827.                         type
  828.                         " (RET=end, ?=show): ")
  829.                     key-table nil nil))))
  830.         (if (equal "?" key-str)
  831.         (with-output-to-temp-buffer "*Dired X11 Alist*"
  832.           (princ (format
  833.               "Dired X11 appearance for files of type `%s':\n\n"
  834.               type))
  835.           (if (fboundp 'pp-to-string)    ; from pp.el by Randal Schwartz
  836.               (princ (pp-to-string alist)) ; pretty print it
  837.             (prin1 alist)))
  838.           (setq key (intern key-str))
  839.           (setq value
  840.             (read-string (format "Set %s of %s to (current is %s): "
  841.                      key type (cdr (assq key alist)))))
  842.           (if (setq elt (assq key alist))
  843.           ;; modify in place
  844.           (setcdr elt value)
  845.         ;; add a new element to alist
  846.         (setq alist (cons (cons key value) alist)))))
  847.       alist))
  848.       
  849.       (defun tek-dired-symbol-list-to-table (list)
  850.     ;; Convert a list of symbols to a table suitable for completing-read.
  851.     (mapcar (function (lambda (x) (list (symbol-name x))))
  852.         list))
  853.       
  854.       (defun tek-dired-read-file-type (prompt)
  855.     (intern (completing-read
  856.          prompt (tek-dired-symbol-list-to-table tek-dired-all-types)
  857.          nil t)))
  858.       
  859.       ;; Interactive changing of the file regexp types
  860.       
  861.       (defun tek-dired-edit-regexp (file-type) "\
  862. Edit interactively the regexp for files of type FILE-TYPE.
  863. Useful to try out different regexps.
  864.  
  865. This function changes the value of `tek-dired-regexp-alist' to reflect
  866. the changes.  You may want to set this variable to its new value in your
  867. ~/.emacs for future sessions if the normal customization variables don't
  868. suffice for you."
  869.     (interactive
  870.      (list (tek-dired-read-regexp-type
  871.         "Change regexp for which file type? ")))
  872.     (let* ((regexp-elt
  873.         (tek-dired-get-regexp-elt file-type))
  874.            (regexp (cdr regexp-elt)))
  875.       (setq regexp
  876.         (tek-dired-read-regexp
  877.          (symbol-name file-type) regexp))
  878.       ;; if the alist has been changed we have to store it back into
  879.       ;; tek-dired-regexp-alist:
  880.       (setcdr regexp-elt regexp)))
  881.       
  882.       (defun tek-dired-read-regexp (type regexp)
  883.     ;; Let user edit REGEXP.
  884.     ;; TYPE is the file-type.  It is used for prompts only.
  885.     ;; Changes REGEXP destructively and returns its new value.
  886.     (read-string (format "Set regexp of %s to (current is %s): "
  887.                  type regexp)))
  888.       
  889.       (defun tek-dired-read-regexp-type (prompt)
  890.     (intern (completing-read
  891.          prompt (tek-dired-symbol-list-to-table tek-dired-regexp-types)
  892.          nil t)))
  893.       
  894. ;;; Regexps to match file types.
  895.       
  896.       ;; Not all of them are used in highlighting.
  897.       ;; On some systems the setgid and sticky bits of directories mean
  898.       ;; something but we don't provide regexps for them.
  899.       
  900.       (defvar dired-re-socket
  901.     (concat dired-re-maybe-mark dired-re-inode-size "s"))
  902.       
  903.       (defvar dired-re-block-device
  904.     (concat dired-re-maybe-mark dired-re-inode-size "b"))
  905.       
  906.       (defvar dired-re-character-device
  907.     (concat dired-re-maybe-mark dired-re-inode-size "c"))
  908.       
  909.       (defvar dired-re-named-pipe
  910.     (concat dired-re-maybe-mark dired-re-inode-size "p"))
  911.       
  912.       (defvar dired-re-setuid;; setuid plain file (even if not executable)
  913.     (concat dired-re-maybe-mark dired-re-inode-size
  914.         "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]"))
  915.       
  916.       (defvar dired-re-setgid;; setgid plain file (even if not executable)
  917.     (concat dired-re-maybe-mark dired-re-inode-size
  918.         "-[-r][-w][-x][-r][-w][Ss][-r][-w][xst]"))
  919.       
  920.       (defvar dired-re-sticky;; sticky plain file (even if not executable)
  921.     (concat dired-re-maybe-mark dired-re-inode-size
  922.         "-[-r][-w][-x][-r][-w]s[-r][-w][Tt]"))
  923.       
  924.       (defun tek-dired-assoc-regexp (pathname) "\
  925. Find the first regexp in tek-dired-regexp-alist that matches PATHNAME and
  926. return the regexp type."
  927.     (interactive "FName of file: ")
  928.     (let ((alist tek-dired-regexp-alist)
  929.           (regexp-type nil))
  930.       (let ((case-fold-search (eq system-type 'vax-vms)))
  931.         (while (and (not regexp-type) alist)
  932.           (if (string-match (cdr (car alist)) pathname)
  933.           (setq regexp-type (car (car alist))))
  934.           (setq alist (cdr alist))))
  935.       regexp-type))
  936.  
  937. ;;; Functions to actually highlight the files
  938.       
  939.       ;; This is nice, but too slow to use it for highlighting:
  940.       ;;(defun dired-map (fun)
  941.       ;;  "Run FUN, a function of zero args,
  942.       ;;at the beginning of each dired file line."
  943.       ;;  (save-excursion
  944.       ;;    (let (file buffer-read-only)
  945.       ;;    (goto-char (point-min))
  946.       ;;    (while (not (eobp))
  947.       ;;    (save-excursion
  948.       ;;      (and (not (eolp))
  949.       ;;           (not (dired-between-files))
  950.       ;;           (progn (beginning-of-line)
  951.       ;;              (funcall fun))))
  952.       ;;    (forward-line 1)))))
  953.       
  954.       (defun tek-dired-no-highlight-p () "\
  955. Function to decide whether to highlight current dired buffer.
  956. If it returns non-nil, highlighting is suppressed."
  957.     (or
  958.      ;; we depend on the ls -l permission bit info for highlighting
  959.      (let (case-fold-search)
  960.        (not (string-match "l" dired-actual-switches)))
  961.      ;; we don't want to highlight if it would take too long
  962.      (and (integerp tek-dired-highlight-threshold)
  963.           (> (buffer-size) tek-dired-highlight-threshold))))
  964.       
  965.       (defun tek-dired-highlight ()
  966.     ;; Look at each file name and (if special) place a button over it
  967.     ;; with appropriate attribute.
  968.     (if (tek-dired-no-highlight-p)
  969.         nil                
  970.       (message "Highlighting...")
  971.       (let (buffer-read-only beg end pathname type attr)
  972.         (save-excursion
  973.           (goto-char (point-min))
  974.           (while (not (eobp))
  975.         (and (not (eolp))
  976.              ;;(not (dired-between-files)); not needed
  977.              (setq beg (dired-move-to-filename)
  978.                end (and beg (dired-move-to-end-of-filename t))
  979.                pathname (and beg end (buffer-substring beg end)))
  980.              ;; here if pathname non-nil
  981.              (progn
  982.                (beginning-of-line)    ; for the re matches below
  983.                (setq type
  984.                  (cond
  985.                   ;; -- Does it match any regexps?
  986.                   ((tek-dired-assoc-regexp pathname))
  987.                   ;; -- Is it an auto-save file?
  988.                   ((auto-save-file-name-p
  989.                 (file-name-nondirectory pathname))
  990.                    'auto-save)
  991.                   ;; -- Is it a backup file?
  992.                   ((backup-file-name-p
  993.                 (file-name-nondirectory pathname))
  994.                    'backup)
  995.                   ;; -- Is it a directory?
  996.                   ((looking-at dired-re-dir)
  997.                    'directory)
  998.                   ;; -- Is it a symbolic link?
  999.                   ((looking-at dired-re-sym)
  1000.                    'symlink)
  1001.                   ;; Is it a setuid or setgid plain file?
  1002.                   ;; Test this before the test for being executable
  1003.                   ((or (looking-at dired-re-setuid)
  1004.                    (looking-at dired-re-setgid))
  1005.                    'setuid)
  1006.                   ;; -- Is it an executable file?
  1007.                   ((looking-at dired-re-exe)
  1008.                    'executable)
  1009.                   ;; -- Is it a socket?
  1010.                   ((looking-at dired-re-socket)
  1011.                    'socket)
  1012.                   ;; -- Else leave it alone.
  1013.                   ;; Plain file, or block or character special
  1014.                   ;; file. We don't need to draw attention to
  1015.                   ;; these.
  1016.                   ))
  1017.                (setq attr
  1018.                  (cdr (assq type tek-dired-highlight-alist)))
  1019.                (setq icon
  1020.                  (cdr (assq type tek-dired-icon-alist)))
  1021.                (if attr
  1022.                (add-zone beg end attr))
  1023.                (if icon
  1024.                (add-zone (1- beg) beg icon))))
  1025.         (forward-line 1))))
  1026.       (message "Highlighting...done")))
  1027.       
  1028.       
  1029.       (run-hooks 'tek-dired-load-hook)
  1030.       
  1031.       )) ; end: running-epoch test
  1032.  
  1033. (provide 'tek-dired-highlight)
  1034.