cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-summary-faces.el

   1 ;;; vm-summary-faces.el --- faces support for VM summary buffers
   2 ;;
   3 ;; Copyright (C) 2001 Robert Fenk
   4 ;;
   5 ;; Author:      Robert Fenk
   6 ;; Status:      Tested with XEmacs 21.4.15 & VM 7.18
   7 ;; Keywords:    VM
   8 ;; X-URL:       http://www.robf.de/Hacking/elisp
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2 of the License, or
  13 ;; (at your option) any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License along
  21 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  22 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;;  to use this add the following line to your ~/.vm file
  27 ;;
  28 ;;  (require 'vm-summary-faces)
  29 ;;  (vm-summary-faces-mode 1)
  30 ;;
  31
  32 (defgroup vm nil
  33   "VM"
  34   :group 'mail)
  35
  36 (defgroup vm-summary-faces nil
  37   "VM additional virtual folder selectors and functions."
  38   :group 'vm)
  39
  40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41 (eval-when-compile
  42   (require 'cl))
  43
  44 (eval-and-compile
  45   (require 'advice)
  46   (require 'vm-summary)
  47   (require 'vm-virtual))
  48
  49 (eval-and-compile
  50   (if vm-xemacs-p (require 'overlay)))
  51
  52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53 (defface vm-summary-selected-face
  54   '((t (:bold on)))
  55   "The face used in VM Summary buffers for the selected message."
  56   :group 'vm-summary-faces)
  57
  58 (defface vm-summary-marked-face
  59   '((((type x)) (:foreground "red3")))
  60   "The face used in VM Summary buffers for marked messages."
  61   :group 'vm-summary-faces)
  62
  63 (defface vm-summary-deleted-face
  64   '((t (:foreground "grey50" :strikethru t)))
  65   "The face used in VM Summary buffers for deleted messages."
  66   :group 'vm-summary-faces)
  67
  68 (defface vm-summary-new-face
  69   '((t (:foreground "blue")))
  70   "The face used in VM Summary buffers for new messages."
  71   :group 'vm-summary-faces)
  72
  73 (defface vm-summary-unread-face
  74   '((t (:foreground "blue4")))
  75   "The face used in VM Summary buffers for unread messages."
  76   :group 'vm-summary-faces)
  77
  78 (defface vm-summary-filed-face
  79   '((t (:foreground "green4" :underline t)))
  80   "The face used in VM Summary buffers for filed messages."
  81   :group 'vm-summary-faces)
  82
  83 (defface vm-summary-written-face
  84   '((t (:foreground "green4" :underline t)))
  85   "The face used in VM Summary buffers for written messages."
  86   :group 'vm-summary-faces)
  87
  88 (defface vm-summary-replied-face
  89   '((t (:foreground "grey50")))
  90   "The face used in VM Summary buffers for replied messages."
  91   :group 'vm-summary-faces)
  92
  93 (defface vm-summary-forwarded-face
  94   '((t (:foreground "grey50")))
  95   "The face used in VM Summary buffers for forwarded messages."
  96   :group 'vm-summary-faces)
  97
  98 (defface vm-summary-edited-face
  99   nil
 100   "The face used in VM Summary buffers for edited messages."
 101   :group 'vm-summary-faces)
 102
 103 (defface vm-summary-redistributed-face
 104   '((t (:foreground "grey50")))
 105   "The face used in VM Summary buffers for redistributed messages."
 106   :group 'vm-summary-faces)
 107
 108 (defface vm-summary-outgoing-face
 109   '((t (:foreground "grey50")))
 110   "The face used in VM Summary buffers for outgoing messages."
 111   :group 'vm-summary-faces)
 112
 113 (defface vm-summary-high-priority-face
 114   '((t (:foreground "red")))
 115   "The face used in VM Summary buffers for high-priority messages."
 116   :group 'vm-summary-faces)
 117
 118 (defface vm-summary-default-face
 119   nil
 120   "The default face used in VM Summary buffers."
 121   :group 'vm-summary-faces)
 122
 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 124 (defcustom vm-summary-faces-alist
 125   '(
 126     ((or (header "Priority: urgent")
 127          (header "Importance: high")
 128          (header "X-Priority: 1")
 129          (label "!")
 130          (header "X-VM-postponed-data:"))
 131      vm-summary-high-priority-face)
 132     ((deleted)   vm-summary-deleted-face)
 133     ((new)       vm-summary-new-face)
 134     ((unread)    vm-summary-unread-face)
 135     ((filed)     vm-summary-filed-face)
 136     ((written)   vm-summary-written-face)
 137     ((replied)   vm-summary-replied-face)
 138     ((forwarded) vm-summary-forwarded-face)
 139     ((edited)    vm-summary-edited-face)
 140     ((redistributed) vm-summary-redistributed-face)
 141     ((marked)    vm-summary-marked-face)
 142     ((outgoing)  vm-summary-outgoing-face)
 143     ((any)       vm-summary-default-face))
 144   "Alist of virtual folder conditions and corresponding faces.
 145 Order matters. The first matching one will be used as face."
 146   :type '(repeat (cons (sexp) (face)))
 147   :group 'vm-summary-faces)
 148
 149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 150 (eval-and-compile
 151   (if (fboundp 'mapcar-extents)
 152       (defun vm-summary-faces-list-extents () (mapcar-extents 'identity))
 153     (defun vm-summary-faces-list-extents ()
 154       (let ((o (overlay-lists))) (nconc (car o) (cdr o))))))
 155
 156 (defvar vm-summary-faces-hide nil
 157   "Last face hidden by `vm-summary-faces-hide'.")
 158
 159 ;;;###autoload
 160 (defun vm-summary-faces-hide (&optional face)
 161   "Toggle visibility of messages with FACE.
 162 When called with a prefix arg prompt for the face."
 163   (interactive "P")
 164   (if (and (listp face) (numberp (car face)))
 165       (setq face (completing-read "Face name: "
 166                                   (mapcar (lambda (f)
 167                                             (list (format "%s" (caar f))))
 168                                           vm-summary-faces-alist)
 169                                   nil t "deleted")))
 170   (setq face (or face vm-summary-faces-hide "deleted"))
 171   (vm-summarize)
 172   (vm-select-folder-buffer)
 173   (set-buffer vm-summary-buffer)
 174   (let ((extents (vm-summary-faces-list-extents))
 175         (face (intern (concat "vm-summary-" face "-face")))
 176         x)
 177     (while extents
 178       (setq x (car extents))
 179       (when (equal face (vm-extent-property x 'face))
 180         (vm-set-extent-property x 'invisible (not (vm-extent-property x 'invisible))))
 181       (setq extents (cdr extents)))))
 182
 183 ;;;###autoload
 184 (defun vm-summary-faces-add (msg)
 185   "Add a face to a summary entry according to `vm-summary-faces-alist'."
 186   (let ((faces vm-summary-faces-alist)
 187         (x (or (vm-su-summary-mouse-track-overlay-of msg)
 188                (vm-extent-at (vm-su-start-of msg))
 189                (vm-extent-at (vm-su-end-of msg)))))
 190     (while faces
 191       (when (apply 'vm-vs-or msg (list (caar faces)))
 192         (vm-set-extent-property x 'face (cadar faces))
 193         (setq faces nil))
 194       (setq faces (cdr faces)))))
 195
 196 (defun vm-summary-faces-destroy ()
 197   "Removes the face from all summary entries."
 198   (let ((extents (vm-summary-faces-list-extents))
 199         x)
 200     (while extents
 201       (setq x (car extents))
 202       (vm-set-extent-property x 'face nil)
 203       (setq extents (cdr extents)))))
 204
 205 (defvar vm-summary-faces-mode nil)
 206
 207 ;;;###autoload
 208 (defun vm-summary-faces-mode (&optional arg)
 209   "Toggle `vm-summary-faces-mode'.
 210 Remove/add the `vm-summary-fontify-buffer' hook from the hook variable
 211 `vm-summary-mode-hook' and when in a summary buffer, then toggle the
 212 `font-lock-mode'."
 213   (interactive "P")
 214   (if (null arg)
 215       (setq vm-summary-faces-mode (not vm-summary-faces-mode))
 216     (if (> (prefix-numeric-value arg) 0)
 217         (setq vm-summary-faces-mode t)
 218       (setq vm-summary-faces-mode nil)))
 219
 220   (when (interactive-p)
 221     (message "VM summary faces mode is %s"
 222              (if vm-summary-faces-mode "on" "off")))
 223
 224   (if (memq major-mode '(vm-mode vm-virtual-mode vm-summary-mode
 225                                  vm-presentation-mode))
 226       (save-excursion
 227         (vm-select-folder-buffer)
 228         (vm-summarize)
 229         (set-buffer vm-summary-buffer)
 230         (if vm-summary-faces-mode
 231             (let ((mp vm-message-list))
 232               (while mp
 233                 (vm-summary-faces-add (car mp))
 234                 (setq mp (cdr mp))))
 235           (vm-summary-faces-destroy)
 236           (if vm-summary-overlay
 237               (vm-set-extent-property vm-summary-overlay 'face
 238                                       vm-summary-highlight-face))))))
 239
 240 (defadvice vm-mouse-set-mouse-track-highlight (after vm-summary-faces activate)
 241   (when (and vm-summary-faces-mode
 242              (eq major-mode 'vm-summary-mode)
 243              (boundp 'm)
 244              m)
 245     ;; FIXME there is a warning about a free variable here, sorry!
 246     (vm-summary-faces-add m)))
 247
 248 (defun vm-summary-faces-fix-pointer ()
 249   (if vm-summary-overlay
 250       (vm-set-extent-property vm-summary-overlay 'face
 251                                     (if vm-summary-faces-mode
 252                                         'vm-summary-selected-face
 253                                       vm-summary-highlight-face))))
 254
 255 (add-hook 'vm-summary-pointer-update-hook 'vm-summary-faces-fix-pointer)
 256
 257 (provide 'vm-summary-faces)