home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / dired / dired-x11.el < prev    next >
Encoding:
Text File  |  1992-08-18  |  26.8 KB  |  777 lines
  1. ;;;; dired-x11.el - X11 support for Dired under Epoch
  2.  
  3. (defconst dired-x11-version (substring "!Revision: 1.26 !" 11 -2)
  4.   "Id: dired-x11.el,v 1.26 1992/04/22 17:36:37 sk RelBeta ")
  5.  
  6. (require 'dired)
  7.  
  8. ;;; Copyright (C) 1991 Tim Wilson and Sebastian Kremer
  9. ;;; Tim.Wilson@cl.cam.ac.uk
  10. ;;; Sebastian Kremer <sk@thp.uni-koeln.de>
  11.  
  12. ;;; This program is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 1, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; This program is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; A copy of the GNU General Public License can be obtained from this
  23. ;;; program's author (send electronic mail to the above address) or from
  24. ;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26. ;;; LISPDIR ENTRY for the Elisp Archive ===============================
  27. ;;;    LCD Archive Entry:
  28. ;;;    dired-x11|Tim Wilson and Sebastian Kremer|Tim.Wilson@cl.cam.ac.uk, sk@thp.uni-koeln.de
  29. ;;;    |X11 mouse and color support for Dired under Epoch
  30. ;;;    |Date: 1992/04/22 17:36:37 |Revision: 1.26 |
  31.  
  32. ;; OVERVIEW ===========================================================
  33.  
  34. ;; Alter the appearance (e.g. color) of directories, symlinks,
  35. ;; executables, sockets, setuid/setgid files, and boring
  36. ;; (backup/autosave) files.
  37.  
  38. ;; Clicking with the mouse:
  39. ;;   shift-left        toggle mark of file
  40. ;;   shift-middle    dired-up-directory
  41. ;;   shift-right    dired directory or find file
  42.  
  43. ;; INSTALLATION =======================================================
  44. ;;
  45. ;; To install, add the following to your `dired-load-hook':
  46. ;;
  47. ;;       (and (boundp 'epoch::version)
  48. ;;        (or (string-match "^Epoch 3.2" epoch::version)
  49. ;;            (string-match "^Epoch 4" epoch::version))
  50. ;;        (load "dired-x11"))
  51. ;;
  52. ;; It is recommended to load dired-x11 after dired-x because then your
  53. ;; settings for to be omitted files will be used for the set of
  54. ;; `boring' files (see below).
  55.  
  56. ;; Note that you need Epoch 3.2 or later.  These functions do not work
  57. ;; with Epoch 3.1.  They are known to work with Epoch 3.2 and 
  58. ;; Epoch 4.0 Beta patchlevel 0.
  59.  
  60. ;; This package will not work with standard (e.g. 18.57) Dired, you
  61. ;; need sk's Tree Dired, available for ftp from
  62. ;;
  63. ;;     ftp.cs.buffalo.edu:pub/Emacs/diredall.tar.Z
  64. ;;
  65. ;; or
  66. ;;
  67. ;;     ftp.thp.uni-koeln.de[134.95.64.1]:/pub/gnu/emacs/diredall.tar.Z
  68.  
  69. ;; TO DO ==============================================================
  70. ;;
  71. ;;  * Generalize: use a general mapping from file `type' to attribute.
  72. ;;    File type two-dimensional -- mode of file and properties of name?
  73. ;;
  74. ;;  * Add useful set of actions when button is moused.
  75. ;;
  76. ;;  * Think about deallocating and or clearing buttons.
  77. ;;
  78. ;;  * Allow button function to supply context args.
  79.  
  80. ;; CUSTOMIZATION ======================================================
  81.  
  82. ;; The default colors work well for dark text on white background.
  83. ;; Are there existing conventions for these colors?
  84.  
  85. ;; Backup/autosave files, directories, symbolic links, executables,
  86. ;; setuid and setgid files, and sockets are distinguished from other
  87. ;; types of file (which appear in the default font, color, etc).
  88.  
  89. ;; On mono displays, directories, setuid and setgid files are underlined.
  90. ;; Files may also be stippled.
  91.  
  92. ;; If you want to change the default colors, you have to set the
  93. ;; following variables in your ~/.emacs as other variables are
  94. ;; computed from them at load time.  Changing them afterwards has no
  95. ;; effect.
  96.  
  97. ;; The *-color variables should be set to the desired color for that
  98. ;; type of file.
  99.  
  100. ;; The *-mono variables may be set to a list of effects to be applied.
  101. ;; The possible effects are `underline' and `stipple'.
  102.  
  103. (defvar dired-x11-re-boring (if (fboundp 'dired-omit-regexp)
  104.                 (dired-omit-regexp)
  105.                   "^#\\|~$")
  106.   "Regexp to match backup, autosave and otherwise boring files.
  107. Those files are displayed in a boring color such as grey (see
  108. variable `dired-x11-boring-color').")
  109.  
  110. (defvar dired-x11-boring-color "Grey"
  111.   "Color used for backup, autosave and otherwise boring files.
  112. See also `dired-x11-re-boring'.")
  113.  
  114. (defvar dired-x11-boring-mono nil
  115.   ;; Depending on your font and display, you may like '(stipple)
  116.   "Effects used for backup, autosave and otherwise boring files on mono displays.
  117. See also `dired-x11-re-boring'.")
  118.  
  119. (defvar dired-x11-directory-color "Firebrick"
  120.   "Color used for directories.")
  121.  
  122. (defvar dired-x11-directory-mono '(underline)
  123.   "Effects used for directories on mono displays.")
  124.  
  125. (defvar dired-x11-executable-color "SeaGreen"
  126.   "Color used for executable plain files.")
  127.  
  128. (defvar dired-x11-executable-mono nil
  129.   "Effects used for executable plain files on mono displays.")
  130.  
  131. (defvar dired-x11-setuid-color "Red"
  132.   "Color used for setuid and setgid plain files.")
  133.  
  134. (defvar dired-x11-setuid-mono '(underline)
  135.   "Effects used for setuid and setgid plain files on mono displays.")
  136.  
  137. (defvar dired-x11-socket-color "Gold"
  138.   "Color used for sockets.")
  139.  
  140. (defvar dired-x11-socket-mono nil
  141.   "Effects used for sockets on mono displays.")
  142.  
  143. (defvar dired-x11-symlink-color     "DarkSlateBlue"
  144.   "Color used for symbolic links.")
  145.  
  146. (defvar dired-x11-symlink-mono nil
  147.   "Effects used for symbolic links on mono displays.")
  148.  
  149. (defvar dired-x11-stipple '(32 2 "\125\125\125\125\252\252\252\252")
  150.   "The stipple used for the mono effect")
  151.  
  152. ;; If you need more elaborate customization, use function
  153. ;; dired-x11-edit-file-type-style and save the setting afterwards.
  154.  
  155. (defvar dired-epoch-highlight-threshold (* 100 1024)
  156.   "If non-nil, a buffer size threshold (in bytes) above which
  157. highlighting will not take place (because it would be too slow).")
  158.  
  159. ;;; End of customization
  160.  
  161. ;;; Install ourselves in the right hooks:
  162.  
  163. (defun dired-x11-add-hook (hook-var function &optional at-end)
  164.   "Add a function to a hook if it is not already present.
  165. First argument HOOK-VAR (a symbol) is the name of a hook, second
  166. argument FUNCTION is the function to add.
  167. Optional third argument AT-END means add at end of HOOK-VAR.
  168. Returns nil if FUNCTION was already present in HOOK-VAR, else new
  169. value of HOOK-VAR."
  170.   (interactive "SAdd to hook-var (symbol): \naAdd which function to %s? ")
  171.   (if (not (boundp hook-var)) (set hook-var nil))
  172.   (if (or (not (listp (symbol-value hook-var)))
  173.       (eq (car (symbol-value hook-var)) 'lambda))
  174.       (set hook-var (list (symbol-value hook-var))))
  175.   (if (memq function (symbol-value hook-var))
  176.       nil
  177.     (set hook-var
  178.      (if at-end
  179.          (append (symbol-value hook-var) (list function))
  180.        (cons function (symbol-value hook-var))))))
  181.  
  182. ;; If dired-x.el is also loaded, arrange it so that highlighting will
  183. ;; be done after omitting uninteresting files, thus saving time:
  184.  
  185. (dired-x11-add-hook 'dired-after-readin-hook 'dired-epoch-highlight 'at-end)
  186.  
  187. (dired-x11-add-hook 'dired-mode-hook 'dired-x11-startup)
  188.  
  189.  
  190. ;;; Handling the gory X11 details
  191.  
  192. (defvar dired-x11-color (> (number-of-colors) 2)
  193.   "Whether we have a color display under X11.")
  194.  
  195. (defconst dired-x11-all-types
  196.   '(boring directory executable setuid socket symlink)
  197.   "List of all types of files that Dired will highlight under X11.
  198.  
  199. The types are represented by the following symbols:
  200.  
  201.     boring    - backup, autosave or otherwise boring files
  202.     directory    - directories
  203.     executable    - executable plain files
  204.     setuid    - setuid or setgid plain files
  205.     socket    - sockets in the file system
  206.     symlink    - symbolic links
  207. ")
  208.  
  209. ;;; There's no reason why these effects shouldn't be used for
  210. ;;; color too -- but with all those lovely colors, who would want
  211. ;;; to stipple or underline?
  212.  
  213. (defconst dired-x11-mono-effects-alist
  214.   (list '(underline . "foreground")
  215.     (cons 'stipple dired-x11-stipple))
  216.   "Effects which may be selected by the dired-x11-*-mono variables")
  217.  
  218. (defun dired-x11-mono-effects (effects)
  219.   ;; Return an alist of style fields according the the elements of
  220.   ;; EFFECTS.  If any styles are selected (ie the result is not nil)
  221.   ;; the list also includes foreground and background colors.
  222.   ;; (This doesn't work properly if an element of EFFECTS is not
  223.   ;; a proper value.)
  224.   (let ((style-fields
  225.      (mapcar (function (lambda (x) (assq x dired-x11-mono-effects-alist)))
  226.          effects)))
  227.     (if style-fields
  228.     (append '((foreground . "foreground")
  229.           (background . "background"))
  230.         style-fields)
  231.       nil)))
  232.               
  233. (defvar dired-x11-alist
  234.   ;; Rather than complicating the code later we always explicitly set
  235.   ;; the foreground and background here (the defaults are not usually
  236.   ;; suitable).
  237.  
  238.   ;; By allowing the special ``colors'' "background" and "foreground"
  239.   ;; we achieve that dired-x11-alist can be set in ~/.emacs as a
  240.   ;; _constant_ list (without having to splice in the value of
  241.   ;; function foreground etc.), possibly with the help of
  242.   ;; dired-x11-edit-file-type-style.
  243.  
  244.   ;; Thus, the user in his ~./emacs doesn't need to do what we do
  245.   ;; here: splicing in the values of the color customization
  246.   ;; variables.
  247.  
  248.   (list
  249.    (list 'boring
  250.      (list 'color
  251.            (list (cons 'foreground dired-x11-boring-color)
  252.              (cons 'background "background")))
  253.      (list 'mono
  254.            (dired-x11-mono-effects dired-x11-boring-mono)))
  255.    (list 'directory
  256.      (list 'color
  257.            (list (cons 'foreground dired-x11-directory-color)
  258.              (cons 'background "background")))
  259.      (list 'mono
  260.            (dired-x11-mono-effects dired-x11-directory-mono)))
  261.    (list 'executable
  262.      (list 'color
  263.            (list (cons 'foreground dired-x11-executable-color)
  264.              (cons 'background "background")))
  265.      (list 'mono
  266.            (dired-x11-mono-effects dired-x11-executable-mono)))
  267.    (list 'setuid
  268.      (list 'color
  269.            (list (cons 'foreground dired-x11-setuid-color)
  270.              (cons 'background "background")))
  271.      (list 'mono
  272.            (dired-x11-mono-effects dired-x11-setuid-mono)))
  273.    (list 'socket
  274.      (list 'color
  275.            (list (cons 'foreground dired-x11-socket-color)
  276.              (cons 'background "background")))
  277.      (list 'mono
  278.            (dired-x11-mono-effects dired-x11-setuid-mono)))
  279.    (list 'symlink
  280.      (list 'color
  281.            (list (cons 'foreground dired-x11-symlink-color)
  282.              (cons 'background "background")))
  283.      (list 'mono
  284.            (dired-x11-mono-effects dired-x11-symlink-mono)))
  285.    )
  286.   "Alist describing file types and their styles in Dired under X11.
  287. Each element looks like
  288.  
  289.    \(TYPE (color ((STYLE-FIELD1 . VALUE1)
  290.                   (STYLE-FIELD2 . VALUE2)
  291.                    ...))
  292.       (mono  ((STYLE-FIELD1 . VALUE1)
  293.                    (STYLE-FIELD2 . VALUE2)
  294.                    ...))\)
  295.  
  296. TYPE is one of the symbols in the variable `dired-x11-all-types', e.g.
  297. `directory'.
  298.  
  299. The `color' alist describes attributes used on a color display, the
  300. optional `mono' alist those used on a monochrome display.
  301.  
  302. The possible STYLE-FIELDs (symbols, cf. function `make-style') and
  303. VALUEs (names of colors (as string), stipple patterns etc.) are
  304. described in `dired-x11-all-style-fields'.
  305.  
  306. See also function `dired-x11-edit-file-type-style' for advanced customization.
  307. ")
  308.  
  309. ;; Access functions.
  310.  
  311. (defun dired-x11-get-style-alist-elt (type)
  312.   ;; Get the element whose car is TYPE (e.g. `directory').
  313.   ;; Its second element (`cadr', or `nth 1') is TYPE's style alist.
  314.   (assq (if dired-x11-color
  315.           'color
  316.         'mono)
  317.     (assq type dired-x11-alist)))
  318.  
  319. (defun dired-x11-get-style-alist (type)
  320.   ;; Get the style-alist for the file type TYPE (e.g. `directory').
  321.   (nth 1 (dired-x11-get-style-alist-elt type)))
  322.  
  323.  
  324. ;;; Styles control the appearance of text.
  325. ;;;
  326. ;;; In Epoch 3.2:
  327. ;;;   Buttons are created with attributes.
  328. ;;;   An attribute is an index into a table of styles.
  329. ;;;   Buttons are placed in buffers with `add-button'.
  330. ;;;
  331. ;;; In Epoch 4:
  332. ;;;   Zones are created with styles
  333. ;;;   Zones are placed in buffers with `add-zone'.
  334.  
  335.  
  336. (defconst dired-x11-style-field-function-alist
  337.   '(
  338.     (foreground         dired-x11-set-style-foreground        )
  339.     (background         dired-x11-set-style-background        )
  340.     (cursor-foreground  dired-x11-set-style-cursor-foreground )
  341.     (cursor-background  dired-x11-set-style-cursor-background )
  342.     (underline          dired-x11-set-style-underline         )
  343.     (stipple            dired-x11-set-style-stipple           )
  344.     (cursor-stipple     dired-x11-set-style-cursor-stipple    )
  345.     (background-stipple dired-x11-set-style-background-stipple)
  346.     (font               dired-x11-set-style-font              )
  347.     )
  348.   "Alist of style-fields and functions to set a style field to a value.")
  349.  
  350. (defconst dired-x11-all-style-fields
  351.   (mapcar 'car dired-x11-style-field-function-alist)
  352.   "List of all style fields known to dired.
  353. The symbols and their meanings are:
  354.  
  355.     foreground
  356.       The text foreground color, as a string or X-Cardinal
  357.       representing the color.
  358.  
  359.     background
  360.       The text background color.  You almost always want to set this
  361.       to the special string `"background"', which is replaced by the
  362.       value of `(background)' by dired.
  363.  
  364.     cursor-foreground
  365.       The character foreground color when the text cursor is on the
  366.       character.
  367.  
  368.     cursor-background
  369.       The character background color when the text cursor is on the
  370.       character.  You almost always want to set this to the string
  371.       `"background"'.
  372.  
  373.     stipple
  374.       The stipple pattern to use for the text.    This is an X-Bitmap
  375.       resource or list (WIDTH HEIGHT STRING).
  376.  
  377.     cursor-stipple
  378.       The stipple to use when the cursor is on the tex.
  379.  
  380.     background-stipple
  381.       The stipple to use for the background. Bits that are set in the
  382.       stipple are displayed in the screen background color.  Cleared
  383.       bits are displayed in the style background color.     See stipple.
  384.  
  385.     underline
  386.       The color to use for underlining. The value `"foreground"' is
  387.       useful.
  388.  
  389.     font
  390.       The font for the text, as an X-Font resource or string.  The
  391.       display will be messy unless this is a character-cell font of
  392.       the same pixel width as the default font.
  393. ")
  394.  
  395.  
  396. ;;; Select appropriate function for adding button/zone to buffer
  397.  
  398. (if (string-match "^Epoch 4" epoch::version)
  399.     (fset 'dired-x11-add-zone (function epoch::add-zone))
  400.   (fset 'dired-x11-add-zone (function epoch::add-button)))
  401.  
  402. ;; Convert color name ready for set-style-*.
  403. ;; (12 Sep 91) I don't think this is necessary.  See `Conventions'
  404. ;; section of Epoch manual.  Leave it for the moment since it works.
  405.  
  406. (defun dired-x11-get-color (color)
  407.   ;; Return X-Cardinal for COLOR, which should be an X-Cardinal or
  408.   ;; string, including the special case "foreground" or "background"
  409.   ;; for the current value of (foreground) and (background).
  410.   ;; We could check what type of resource, but don't bother since this
  411.   ;; error will be caught when we try and use the alleged color.
  412.   (cond ((resourcep color)
  413.      color)
  414.     ((and (stringp color)
  415.           (equal "foreground" (downcase color)))
  416.      (foreground))
  417.     ((and (stringp color)
  418.           (equal "background" (downcase color)))
  419.      (background))
  420.     (t
  421.      (get-color color))))
  422.  
  423. (defun dired-x11-get-bitmap (bitmap)
  424.   ;; Return X-Bitmap for BITMAP, which should be an X-Bitmap or list
  425.   ;; (WIDTH HEIGHT STRING).
  426.   (if (resourcep bitmap)
  427.       bitmap
  428.     (apply 'make-bitmap bitmap)))
  429.  
  430. (defun dired-x11-get-font (font)
  431.   ;; Return X-Font for FONT, which should be an X-Font or string.
  432.   (if (resourcep font)
  433.       font
  434.     (get-font font)))
  435.  
  436. ;; colors
  437.  
  438. (defun dired-x11-set-style-foreground (style color)
  439.   (set-style-foreground style (dired-x11-get-color color)))
  440.  
  441. (defun dired-x11-set-style-background (style color)
  442.   (set-style-background style (dired-x11-get-color color)))
  443.  
  444. (defun dired-x11-set-style-cursor-foreground(style color)
  445.   (set-style-cursor-foreground style (dired-x11-get-color color)))
  446.  
  447. (defun dired-x11-set-style-cursor-background(style color)
  448.   (set-style-cursor-background style (dired-x11-get-color color)))
  449.  
  450. (defun dired-x11-set-style-underline (style color)
  451.   (set-style-underline style  (dired-x11-get-color color)))
  452.  
  453. ;; stipples
  454.  
  455. (defun dired-x11-set-style-stipple (style stipple)
  456.   (set-style-stipple style (dired-x11-get-bitmap stipple)))
  457.  
  458. (defun dired-x11-set-style-cursor-stipple (style stipple)
  459.   (set-style-cursor-stipple style (dired-x11-get-bitmap stipple)))
  460.  
  461. (defun dired-x11-set-style-background-stipple (style stipple)
  462.   (set-style-background-stipple style (dired-x11-get-bitmap stipple)))
  463.  
  464. ;; fonts
  465.  
  466. (defun dired-x11-set-style-font (style font)
  467.   (set-style-font style (dired-x11-get-font font)))
  468.  
  469.  
  470. ;; Functions for getting and setting colors, bitmaps, and fonts.
  471.  
  472. (defun dired-x11-make-new-style (style-alist)
  473.   ;; Make new style, initialize from alist STYLE-ALIST
  474.   ;; STYLE-ALIST is a table of style-field and value, e.g
  475.   ;; ((foreground . "Grey")
  476.   ;;  (background . #<X-Cardinal 0>))
  477.   ;; Note that the values may be raw or cooked.
  478.  
  479.   (if (string-match "^Epoch 4" epoch::version)
  480.     ;; Epoch Buttons reference styles directly in epoch 4
  481.     (let ((style (make-style)))
  482.       (dired-x11-set-style style style-alist)
  483.       style)
  484.     ;; else use highlighting as per epoch version 3 with attributes.
  485.     ;; As with epoch 4 but additionally allocate and return corresponding
  486.     ;; attribute.
  487.     (let ((style (make-style))
  488.     (attr (reserve-attribute)))
  489.       (dired-x11-set-style style style-alist)
  490.       (set-attribute-style attr style)
  491.       attr)))
  492.  
  493. (defun dired-x11-set-style (style style-alist)
  494.   ;; Set style-fields for the style STYLE from the values in STYLE-ALIST.
  495.   ;; You can find the style for a given type of highlighting (e.g.
  496.   ;; `directory') with the help of var `dired-x11-attribute-alist' and
  497.   ;; function `attribute-style'.
  498.   (let* ((style-field-value nil))
  499.     (mapcar
  500.      (function
  501.       (lambda (x)
  502.     ;; Arrange for style-field X (e.g.  `foreground') to be
  503.     ;; displayed as specified in STYLE-ALIST (e.g. color #3 if
  504.     ;; `(foreground . 3)' is an element of STYLE-ALIST),
  505.     ;; e.g. (set-style-foreground style #<X-cardinal for color 3>)
  506.     (and (setq style-field-value (cdr (assq x style-alist)))
  507.          (funcall (nth 1 (assq x dired-x11-style-field-function-alist))
  508.               style style-field-value))))
  509.      dired-x11-all-style-fields)))
  510.  
  511. (defconst dired-x11-attribute-alist
  512.   (mapcar
  513.    (function;; returns e.g. `(directory . 3)' if directories are to be
  514.         ;; highlighted with color #3.
  515.     (lambda (x)
  516.       (let ((style-alist (dired-x11-get-style-alist x)))
  517.     ;; This test prevents dired-epoch-highlight placing a button
  518.     ;; with default attributes over non-special files -- the
  519.     ;; default attributes are not necessarily the same as no
  520.     ;; attributes, so this may lead to unintentional highlighting.
  521.      (and style-alist
  522.           (cons x (dired-x11-make-new-style style-alist))))))
  523.    dired-x11-all-types)
  524.   "Alist with elements
  525.  
  526.     \(TYPE ATTRIBUTE)
  527.  
  528. TYPE is a symbol describing a file type, see `dired-x11-all-types'.
  529. ATTRIBUTE describes how files of type TYPE are treated under X11 and
  530. is computed at load time from `dired-x11-alist'.")
  531.  
  532.  
  533. ;; Interactive changing of the appearance of file types
  534.  
  535. (defun dired-x11-edit-file-type-style (file-type)
  536.   "Edit interactively the style of highlighting for files of type FILE-TYPE.
  537. Useful to try out different colors.
  538. See variable `dired-x11-all-style-fields' for an explanation of the
  539. allowed fields and their meanings.
  540.  
  541. This function changes the value of `dired-x11-alist' to reflect the changes.
  542. You may want to set this variable to its new value in your ~/.emacs
  543. for future sessions if the normal customization variables don't
  544. suffice for you."
  545.   (interactive
  546.    (list (dired-x11-read-file-type "Change appearance of which file type? ")))
  547.   (let* ((style (attribute-style
  548.          (cdr (assq file-type dired-x11-attribute-alist))))
  549.      (style-alist-elt (dired-x11-get-style-alist-elt file-type))
  550.      (style-alist (nth 1 style-alist-elt)))
  551.     (setq style-alist
  552.      (dired-x11-read-style-alist (symbol-name file-type) style-alist))
  553.     ;; if the alist has been enlarged we have to store it back into
  554.     ;; dired-x11-alist:
  555.     (setcdr style-alist-elt (list style-alist))
  556.     (dired-x11-set-style style style-alist)))
  557.  
  558. (defun dired-x11-read-style-alist (type alist)
  559.   ;; Let user edit the current fields of ALIST or add new fields.
  560.   ;; TYPE is the file-type.  It is used for prompts only.
  561.   ;; Changes ALIST destructively and returns its new value.
  562.   ;; ALIST's keys must be symbols (i.e. assq instead of assoc will be used).
  563.   (let ((key-table (dired-x11-symbol-list-to-table dired-x11-all-style-fields))
  564.     key-str key elt value)
  565.     (while (not (equal ""
  566.                (setq key-str
  567.                  (completing-read
  568.                   (concat "Edit which key of "
  569.                       type
  570.                       " (RET=end, ?=show): ")
  571.                   key-table nil nil))))
  572.       (if (equal "?" key-str)
  573.       (with-output-to-temp-buffer "*Dired X11 Alist*"
  574.         (princ (format
  575.             "Dired X11 appearance for files of type `%s':\n\n" type))
  576.         (if (fboundp 'pp-to-string)    ; from pp.el by Randal Schwartz
  577.         (princ (pp-to-string alist)) ; pretty print it
  578.           (prin1 alist)))
  579.     (setq key (intern key-str))
  580.     (setq value
  581.           (read-string (format "Set %s of %s to (current is %s): "
  582.                    key type (cdr (assq key alist)))))
  583.     (if (setq elt (assq key alist))
  584.         ;; modify in place
  585.         (setcdr elt value)
  586.       ;; add a new element to alist
  587.       (setq alist (cons (cons key value) alist)))))
  588.     alist))
  589.  
  590. (defun dired-x11-symbol-list-to-table (list)
  591.   ;; Convert a list of symbols to a table suitable for completing-read.
  592.   (mapcar (function (lambda (x) (list (symbol-name x))))
  593.       list))
  594.  
  595. (defun dired-x11-read-file-type (prompt)
  596.   (intern (completing-read
  597.        prompt (dired-x11-symbol-list-to-table dired-x11-all-types) nil t)))
  598.  
  599. ;;; Regexps to match file types.
  600.  
  601. ;; Not all of them are used in highlighting.
  602. ;; On some systems the setgid and sticky bits of directories mean
  603. ;; something but we don't provide regexps for them.
  604.  
  605. (defvar dired-re-socket
  606.   (concat dired-re-maybe-mark dired-re-inode-size "s"))
  607.  
  608. (defvar dired-re-block-device
  609.   (concat dired-re-maybe-mark dired-re-inode-size "b"))
  610.  
  611. (defvar dired-re-character-device
  612.   (concat dired-re-maybe-mark dired-re-inode-size "c"))
  613.  
  614. (defvar dired-re-named-pipe
  615.   (concat dired-re-maybe-mark dired-re-inode-size "p"))
  616.  
  617. (defvar dired-re-setuid;; setuid plain file (even if not executable)
  618.   (concat dired-re-maybe-mark dired-re-inode-size
  619.       "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]"))
  620.  
  621. (defvar dired-re-setgid;; setgid plain file (even if not executable)
  622.   (concat dired-re-maybe-mark dired-re-inode-size
  623.       "-[-r][-w][-x][-r][-w][Ss][-r][-w][xst]"))
  624.  
  625. (defvar dired-re-sticky;; sticky plain file (even if not executable)
  626.   (concat dired-re-maybe-mark dired-re-inode-size
  627.                 "-[-r][-w][-x][-r][-w]s[-r][-w][Tt]"))
  628.  
  629. ;;; Functions to actually highlight the files
  630.  
  631. ;; This is nice, but too slow to use it for highlighting:
  632. ;;(defun dired-map (fun)
  633. ;;  "Run FUN, a function of zero args, at the beginning of each dired file line."
  634. ;;  (save-excursion
  635. ;;    (let (file buffer-read-only)
  636. ;;    (goto-char (point-min))
  637. ;;    (while (not (eobp))
  638. ;;    (save-excursion
  639. ;;      (and (not (eolp))
  640. ;;           (not (dired-between-files))
  641. ;;           (progn (beginning-of-line)
  642. ;;              (funcall fun))))
  643. ;;    (forward-line 1)))))
  644.  
  645. (defun dired-epoch-no-highlight-p ()
  646.   "Function to decide whether to highlight current dired buffer.
  647. If it returns non-nil, highlighting is suppressed."
  648.   (or
  649.    ;; we depend on the ls -l permission bit info for highlighting
  650.    (let (case-fold-search)
  651.      (not (string-match "l" dired-actual-switches)))
  652.    ;; we don't want to highlight if it would take too long
  653.    (and (integerp dired-epoch-highlight-threshold)
  654.     (> (buffer-size) dired-epoch-highlight-threshold))))
  655.  
  656. (defun dired-epoch-highlight ()
  657.   ;; Look at each file name and (if special) place a button over it
  658.   ;; with appropriate attribute.
  659.   (if (dired-epoch-no-highlight-p)
  660.       nil                
  661.     (message "Highlighting...")
  662.     (let (buffer-read-only beg end pathname type attr)
  663.       (save-excursion
  664.     (goto-char (point-min))
  665.     (while (not (eobp))
  666.       (and (not (eolp))
  667.            ;;(not (dired-between-files)); not needed
  668.            (setq beg (dired-move-to-filename)
  669.              end (and beg (dired-move-to-end-of-filename t))
  670.              pathname (and beg end (buffer-substring beg end)))
  671.            ;; here if pathname non-nil
  672.            (progn
  673.          (beginning-of-line)    ; for the re matches below
  674.          (setq type
  675.                (cond
  676.             ;; -- Is it a backup, autosave or otherwise boring file?
  677.             ;; Test this first because we don't want to draw
  678.             ;; attention to backup files even if they are e.g.
  679.             ;; executable.
  680.             ((or (string-match dired-x11-re-boring pathname))
  681.              ;; Here, being fast is more important than
  682.              ;; always being correct.
  683.              ;; (or (backup-file-name-p pathname)
  684.              ;;     (auto-save-file-name-p pathname))
  685.              'boring)
  686.             ;; -- Is it a directory?
  687.             ((looking-at dired-re-dir)
  688.              'directory)
  689.             ;; -- Is it a symbolic link?
  690.             ((looking-at dired-re-sym)
  691.              'symlink)
  692.             ;; Is it a setuid or setgid plain file?
  693.             ;; Test this before the test for being executable
  694.             ((or (looking-at dired-re-setuid)
  695.                  (looking-at dired-re-setgid))
  696.              'setuid)
  697.             ;; -- Is it an executable file?
  698.             ((looking-at dired-re-exe)
  699.              'executable)
  700.             ;; -- Is it a socket?
  701.             ((looking-at dired-re-socket)
  702.              'socket)
  703.             ;; -- Else leave it alone.
  704.             ;; Plain file, or block or character special file.
  705.             ;; We don't need to draw attention to these.
  706.             )
  707.                attr
  708.                (cdr (assq type dired-x11-attribute-alist)))
  709.          (if attr
  710.              (dired-x11-add-zone beg end attr))))
  711.       (forward-line 1))))
  712.     (message "Highlighting...done")))
  713.  
  714.  
  715. ;;; Mouse handling
  716.  
  717. ;;; This is only to test the concept (and code): a start, a pump-primer.
  718. ;;; Please extend!
  719.  
  720. ;;  shift-left        toggle mark of file
  721. ;;  shift-middle    dired-up-directory
  722. ;;  shift-right        visit file or directory
  723.  
  724. (defvar dired-mouse-map (create-mouse-map))
  725.  
  726. ;; The dired-PACKAGE-startup name is conventional (like in dired-x.el)
  727. (defun dired-x11-startup ()
  728.   "\
  729. Automatically put on `dired-mode-hook' to get highlighting in Dired under X11."
  730.   ;; Maybe we do more things here later.
  731.   (use-local-mouse-map dired-mouse-map))
  732.  
  733. (define-mouse dired-mouse-map
  734.   mouse-left mouse-shift-up 'dired-shift-mouse-left-handler)
  735.  
  736. (define-mouse dired-mouse-map
  737.   mouse-middle mouse-shift-up 'dired-shift-mouse-middle-handler)
  738.  
  739. (define-mouse dired-mouse-map
  740.   mouse-right mouse-shift-up 'dired-shift-mouse-right-handler)
  741.  
  742. (defun dired-shift-mouse-left-handler (mouse-data)
  743.   ;; MOUSE-DATA is '(POINT BUFFER WINDOW SCREEN),
  744.   ;; ie just right for the mouse::set-point function
  745.   (mouse::set-point mouse-data)
  746.   (dired-move-to-filename)
  747.   (save-excursion;; don't want to move to next line
  748.     (dired-toggle-file 1)))
  749.  
  750. (defun dired-shift-mouse-middle-handler (mouse-data)
  751.   (mouse::set-point mouse-data)
  752.   (dired-move-to-filename)
  753.   (dired-up-directory))
  754.  
  755. (defun dired-shift-mouse-right-handler (mouse-data)
  756.   (mouse::set-point mouse-data)
  757.   (dired-move-to-filename)
  758.   (dired-find-file))
  759.  
  760. (defun dired-toggle-file (arg)        ; bind this to `t'?
  761.   "In dired, toggle mark of the current file line.
  762. With arg, repeat over several lines."
  763.   (interactive "p")
  764.   (let (buffer-read-only char)
  765.     (dired-repeat-over-lines
  766.      arg
  767.      (function (lambda ()
  768.          (setq char (following-char))
  769.          (delete-char 1)
  770.          (insert (if (eq char ?\040)
  771.                  dired-marker-char
  772.                ?\040)))))))
  773.  
  774. (run-hooks 'dired-x11-load-hook)
  775.  
  776. ;;; End of dired-x11.el
  777.