1 ;;; wl-highlight.el --- Hilight modules for Wanderlust.
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
4 ;; Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
7 ;; Keywords: mail, net news
9 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
11 ;; This program is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; This program is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
33 (if (and (featurep 'xemacs)
37 (provide 'wl-highlight) ; circular dependency
46 (defun-maybe wl-dnd-set-drop-target (a b))
47 (defun-maybe wl-dnd-set-drag-starter (a b)))
49 (put 'wl-defface 'lisp-indent-function 'defun)
51 (defgroup wl-faces nil
53 :prefix "wl-highlight-"
57 (defgroup wl-summary-faces nil
58 "Wanderlust, Faces of summary buffer."
59 :prefix "wl-highlight-"
63 (defgroup wl-folder-faces nil
64 "Wanderlust, Faces of folder buffer."
65 :prefix "wl-highlight-"
69 (defgroup wl-message-faces nil
70 "Wanderlust, Faces of message buffer."
71 :prefix "wl-highlight-"
74 ;; for message header and signature
76 (wl-defface wl-highlight-message-headers
83 (:foreground "gray" :bold t))
86 (:foreground "gray50" :bold t)))
87 "Face used for displaying header names."
88 :group 'wl-message-faces
91 (wl-defface wl-highlight-message-header-contents
95 (:foreground "green"))
98 (:foreground "LightSkyBlue" :bold t))
101 (:foreground "purple" :bold t)))
102 "Face used for displaying header content."
103 :group 'wl-message-faces
106 (wl-defface wl-highlight-message-important-header-contents
110 (:foreground "yellow"))
113 (:foreground "yellow" :bold t))
116 (:foreground "brown" :bold t)))
117 "Face used for displaying contents of special headers."
118 :group 'wl-message-faces
121 (wl-defface wl-highlight-message-important-header-contents2
128 (:foreground "orange" :bold t))
131 (:foreground "DarkSlateBlue" :bold t)))
132 "Face used for displaying contents of special headers."
133 :group 'wl-message-faces
136 (wl-defface wl-highlight-message-citation-header
140 (:foreground "cyan"))
143 (:foreground "SkyBlue"))
146 (:foreground "DarkGreen")))
147 "Face used for displaying header of quoted texts."
148 :group 'wl-message-faces
151 (wl-defface wl-highlight-message-unimportant-header-contents
155 (:foreground "green"))
158 (:foreground "GreenYellow" :bold t))
161 (:foreground "DarkGreen" :bold t)))
162 "Face used for displaying contents of unimportant headers."
163 :group 'wl-message-faces
166 (wl-defface wl-highlight-message-signature
169 (:foreground "khaki"))
172 (:foreground "DarkSlateBlue")))
173 "Face used for displaying signature."
174 :group 'wl-message-faces
179 (wl-defface wl-highlight-header-separator-face
183 (:foreground "black" :background "yellow"))
185 (:foreground "Black" :background "DarkKhaki")))
186 "Face used for displaying header separator."
190 ;; important messages
192 (wl-defface wl-highlight-summary-flagged-face
195 (:foreground "magenta"))
198 (:foreground "orange"))
201 (:foreground "purple")))
202 "Face used for displaying flagged messages."
203 :group 'wl-summary-faces
206 (wl-defface wl-highlight-summary-new-face
213 (:foreground "tomato"))
216 (:foreground "tomato")))
217 "Face used for displaying new messages."
218 :group 'wl-summary-faces
221 (wl-defface wl-highlight-summary-displaying-face
223 (:underline t :bold t)))
224 "Face used for displaying message."
225 :group 'wl-summary-faces
228 (wl-defface wl-highlight-thread-indent-face
230 (:foreground "gray40")))
231 "Face used for displaying indented thread."
232 :group 'wl-summary-faces
235 ;; unimportant messages
237 (wl-defface wl-highlight-summary-unread-face
241 (:foreground "cyan"))
244 (:foreground "LightSkyBlue"))
247 (:foreground "RoyalBlue")))
248 "Face used for displaying unread messages."
249 :group 'wl-summary-faces
252 (wl-defface wl-highlight-summary-disposed-face
256 (:foreground "blue"))
259 (:foreground "gray"))
262 (:foreground "DarkKhaki")))
263 "Face used for displaying messages mark as disposed."
264 :group 'wl-summary-faces
267 (wl-defface wl-highlight-summary-deleted-face
271 (:foreground "blue"))
274 (:foreground "SteelBlue"))
277 (:foreground "RoyalBlue4")))
278 "Face used for displaying messages mark as deleted."
279 :group 'wl-summary-faces
282 (wl-defface wl-highlight-summary-prefetch-face
286 (:foreground "Green"))
289 (:foreground "DeepSkyBlue"))
292 (:foreground "brown")))
293 "Face used for displaying messages mark as deleted."
294 :group 'wl-summary-faces
297 (wl-defface wl-highlight-summary-resend-face
301 (:foreground "Yellow"))
304 (:foreground "orange3"))
307 (:foreground "orange3")))
308 "Face used for displaying messages mark as resend."
309 :group 'wl-summary-faces
312 (wl-defface wl-highlight-summary-refiled-face
316 (:foreground "blue"))
319 (:foreground "blue"))
322 (:foreground "firebrick")))
323 "Face used for displaying messages mark as refiled."
324 :group 'wl-summary-faces
327 (wl-defface wl-highlight-summary-copied-face
331 (:foreground "blue"))
334 (:foreground "cyan"))
337 (:foreground "blue")))
338 "Face used for displaying messages mark as copied."
339 :group 'wl-summary-faces
343 (wl-defface wl-highlight-summary-answered-face
346 (:foreground "yellow"))
349 (:foreground "khaki"))
352 (:foreground "khaki4")))
353 "Face used for displaying answered messages."
354 :group 'wl-summary-faces
358 (wl-defface wl-highlight-summary-forwarded-face
361 (:foreground "yellow"))
364 (:foreground "DarkOliveGreen2"))
367 (:foreground "DarkOliveGreen4")))
368 "Face used for displaying forwarded messages."
369 :group 'wl-summary-faces
372 (wl-defface wl-summary-persistent-mark-face
374 (:foreground "blue"))
377 (:foreground "SeaGreen4"))
380 (:foreground "SeaGreen1")))
381 "Dafault face used for displaying messages with persistent mark."
382 :group 'wl-summary-faces
386 (wl-defface wl-highlight-summary-temp-face
390 (:foreground "gold"))
392 (:foreground "HotPink1")))
393 "Face used for displaying messages mark as temp."
394 :group 'wl-summary-faces
397 (wl-defface wl-highlight-summary-target-face
401 (:foreground "gold"))
403 (:foreground "HotPink1")))
404 "Face used for displaying messages mark as target."
405 :group 'wl-summary-faces
408 (wl-defface wl-highlight-summary-low-read-face
412 (:foreground "yellow" :italic t))
415 (:foreground "PaleGreen" :italic t))
418 (:foreground "Green3" :italic t)))
419 "Face used for displaying low interest read messages."
420 :group 'wl-summary-faces
423 (wl-defface wl-highlight-summary-high-read-face
429 (:foreground "PaleGreen" :bold t))
432 (:foreground "SeaGreen" :bold t)))
433 "Face used for displaying high interest read messages."
434 :group 'wl-summary-faces
437 (wl-defface wl-highlight-summary-low-unread-face
441 (:foreground "cyan" :italic t))
444 (:foreground "LightSkyBlue" :italic t))
447 (:foreground "RoyalBlue" :italic t)))
448 "Face used for displaying low interest unread messages."
449 :group 'wl-summary-faces
452 (wl-defface wl-highlight-summary-high-unread-face
455 (:foreground "red" :bold t))
458 (:foreground "tomato" :bold t))
461 (:foreground "tomato" :bold t)))
462 "Face used for displaying high interest unread messages."
463 :group 'wl-summary-faces
468 (wl-defface wl-highlight-summary-thread-top-face
472 (:foreground "green"))
475 (:foreground "GreenYellow"))
478 (:foreground "green4")))
479 "Face used for displaying top thread message."
480 :group 'wl-summary-faces
483 (wl-defface wl-highlight-summary-normal-face
487 (:foreground "yellow"))
490 (:foreground "PaleGreen"))
493 (:foreground "SeaGreen")))
494 "Face used for displaying normal message."
495 :group 'wl-summary-faces
500 (wl-defface wl-highlight-folder-unknown-face
504 (:foreground "cyan"))
507 (:foreground "pink"))
510 (:foreground "RoyalBlue")))
511 "Face used for displaying unread folder."
512 :group 'wl-folder-faces
515 (wl-defface wl-highlight-folder-killed-face
519 (:foreground "gray"))
521 (:foreground "gray50")))
522 "Face used for displaying killed folder."
523 :group 'wl-folder-faces
526 (wl-defface wl-highlight-folder-zero-face
530 (:foreground "green"))
533 (:foreground "SkyBlue"))
536 (:foreground "BlueViolet")))
537 "Face used for displaying folder needs no sync."
538 :group 'wl-folder-faces
541 (wl-defface wl-highlight-folder-few-face
545 (:foreground "yellow"))
548 (:foreground "orange"))
551 (:foreground "OrangeRed3")))
552 "Face used for displaying folder contains few unsync messages."
553 :group 'wl-folder-faces
556 (wl-defface wl-highlight-folder-many-face
563 (:foreground "HotPink1"))
566 (:foreground "tomato")))
567 "Face used for displaying folder contains many unsync messages."
568 :group 'wl-folder-faces
571 (wl-defface wl-highlight-folder-unread-face
575 (:foreground "magenta"))
578 (:foreground "gold"))
581 (:foreground "MediumVioletRed")))
582 "Face used for displaying unread folder."
583 :group 'wl-folder-faces
586 (wl-defface wl-highlight-folder-opened-face
590 (:foreground "blue"))
593 (:foreground "PaleGreen"))
596 (:foreground "ForestGreen")))
597 "Face used for displaying opened group folder."
598 :group 'wl-folder-faces
601 (wl-defface wl-highlight-folder-closed-face
605 (:foreground "cyan"))
608 (:foreground "GreenYellow"))
611 (:foreground "DarkOliveGreen4")))
612 "Face used for displaying closed group folder."
613 :group 'wl-folder-faces
616 (wl-defface wl-highlight-folder-path-face
618 (:bold t :underline t)))
619 "Face used for displaying path."
620 :group 'wl-folder-faces
623 (wl-defface wl-highlight-demo-face
625 (:foreground "green"))
628 (:foreground "#006600" :background "#d9ffd9"))
631 (:foreground "#d9ffd9" :background "#004400")))
632 "Face used for displaying demo."
635 (wl-defface wl-highlight-logo-face
638 (:foreground "cyan"))
641 (:foreground "SteelBlue" :background "#d9ffd9"))
644 (:foreground "SkyBlue" :background "#004400")))
645 "Face used for displaying demo."
648 (wl-defface wl-highlight-action-argument-face
651 (:foreground "pink"))
654 (:foreground "red")))
655 "Face used for displaying action argument."
656 :group 'wl-summary-faces
661 (wl-defface wl-highlight-message-cited-text-1
665 (:foreground "magenta"))
668 (:foreground "HotPink1"))
671 (:foreground "ForestGreen")))
672 "Face used for displaying quoted text from other messages."
673 :group 'wl-message-faces
676 (wl-defface wl-highlight-message-cited-text-2
680 (:foreground "blue"))
682 (:foreground "violet")))
683 "Face used for displaying quoted text from other messages."
684 :group 'wl-message-faces
687 (wl-defface wl-highlight-message-cited-text-3
691 (:foreground "cyan"))
693 (:foreground "orchid3")))
694 "Face used for displaying quoted text from other messages."
695 :group 'wl-message-faces
698 (wl-defface wl-highlight-message-cited-text-4
702 (:foreground "green"))
704 (:foreground "purple1")))
705 "Face used for displaying quoted text from other messages."
706 :group 'wl-message-faces
709 (wl-defface wl-highlight-message-cited-text-5
713 (:foreground "yellow"))
715 (:foreground "MediumPurple1")))
716 "Face used for displaying quoted text from other messages."
717 :group 'wl-message-faces
720 (wl-defface wl-highlight-message-cited-text-6
726 (:foreground "PaleVioletRed")))
727 "Face used for displaying quoted text from other messages."
728 :group 'wl-message-faces
731 (wl-defface wl-highlight-message-cited-text-7
735 (:foreground "magenta"))
737 (:foreground "LightPink")))
738 "Face used for displaying quoted text from other messages."
739 :group 'wl-message-faces
742 (wl-defface wl-highlight-message-cited-text-8
746 (:foreground "blue"))
748 (:foreground "salmon")))
749 "Face used for displaying quoted text from other messages."
750 :group 'wl-message-faces
753 (wl-defface wl-highlight-message-cited-text-9
757 (:foreground "cyan"))
759 (:foreground "SandyBrown")))
760 "Face used for displaying quoted text from other messages."
761 :group 'wl-message-faces
764 (wl-defface wl-highlight-message-cited-text-10
768 (:foreground "green"))
770 (:foreground "wheat")))
771 "Face used for displaying quoted text from other messages."
772 :group 'wl-message-faces
775 (defface wl-message-header-narrowing-face
776 '((((class color) (background light))
777 (:foreground "black" :background "dark khaki"))
778 (((class color) (background dark))
779 (:foreground "white" :background "dark goldenrod"))
781 "Face used for header narrowing for the message."
782 :group 'wl-message-faces
785 (defvar wl-highlight-folder-opened-regexp " *\\(\\[\\-\\]\\)")
786 (defvar wl-highlight-folder-closed-regexp " *\\(\\[\\+\\]\\)")
787 (defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$")
789 (defvar wl-highlight-citation-face-list
790 '(wl-highlight-message-cited-text-1
791 wl-highlight-message-cited-text-2
792 wl-highlight-message-cited-text-3
793 wl-highlight-message-cited-text-4
794 wl-highlight-message-cited-text-5
795 wl-highlight-message-cited-text-6
796 wl-highlight-message-cited-text-7
797 wl-highlight-message-cited-text-8
798 wl-highlight-message-cited-text-9
799 wl-highlight-message-cited-text-10))
801 (defmacro wl-delete-all-overlays ()
802 "Delete all momentary overlays."
803 '(let ((overlays (overlays-in (point-min) (point-max)))
805 (while (setq overlay (car overlays))
806 (if (overlay-get overlay 'wl-momentary-overlay)
807 (delete-overlay overlay))
808 (setq overlays (cdr overlays)))))
810 (defun wl-highlight-summary-displaying ()
812 (wl-delete-all-overlays)
819 (setq ov (make-overlay bol eol))
820 (overlay-put ov 'face 'wl-highlight-summary-displaying-face)
821 (overlay-put ov 'evaporate t)
822 (overlay-put ov 'wl-momentary-overlay t))))
824 (defun wl-highlight-folder-group-line (numbers)
830 (let ((text-face (cond ((looking-at wl-highlight-folder-opened-regexp)
831 'wl-highlight-folder-opened-face)
832 ((looking-at wl-highlight-folder-closed-regexp)
833 'wl-highlight-folder-closed-face))))
834 (if (and wl-highlight-folder-by-numbers
835 (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" eol t))
836 (let* ((unsync (nth 0 numbers))
837 (unread (nth 1 numbers))
838 (face (cond ((and unsync (zerop unsync))
839 (if (and unread (> unread 0))
840 'wl-highlight-folder-unread-face
841 'wl-highlight-folder-zero-face))
843 (>= unsync wl-folder-many-unsync-threshold))
844 'wl-highlight-folder-many-face)
846 'wl-highlight-folder-few-face))))
847 (if (numberp wl-highlight-folder-by-numbers)
849 (put-text-property bol (match-beginning 0) 'face text-face)
850 (put-text-property (match-beginning 0) (match-end 0)
852 ;; Remove previous face.
853 (put-text-property bol (match-end 0) 'face nil)
854 (put-text-property bol (match-end 0) 'face face)))
855 (put-text-property bol eol 'face text-face)))))
857 (defsubst wl-highlight-get-face-by-name (format &rest args)
858 (let ((face (intern (apply #'format format args))))
859 (and (find-face face)
862 (defsubst wl-highlight-summary-line-face-spec (flags temp-mark indent)
863 "Return a cons cell of (face . argument)."
865 (if (setq action (assoc temp-mark wl-summary-mark-action-list))
866 (cons (nth 5 action) (nth 2 action))
868 ((and (string= temp-mark wl-summary-score-over-mark)
869 (or (memq 'new flags) (memq 'unread flags)))
870 '(wl-highlight-summary-high-unread-face))
871 ((and (string= temp-mark wl-summary-score-below-mark)
872 (or (memq 'new flags) (memq 'unread flags)))
873 '(wl-highlight-summary-low-unread-face))
874 ((let ((priorities wl-summary-persistent-mark-priority-list)
875 (fl wl-summary-flag-alist)
876 face result global-flags)
877 (while (and (null result) priorities)
878 (if (eq (car priorities) 'flag)
879 (when (setq global-flags
880 (elmo-get-global-flags flags 'ignore-preserved))
882 (when (memq (car (car fl)) global-flags)
884 (list (or (wl-highlight-get-face-by-name
885 "wl-highlight-summary-%s-flag-face"
887 'wl-highlight-summary-flagged-face))
891 (setq result (list 'wl-highlight-summary-flagged-face))))
892 (when (memq (car priorities) flags)
894 (list (or (wl-highlight-get-face-by-name
895 "wl-highlight-summary-%s-face"
897 'wl-summary-persistent-mark-face)))))
898 (setq priorities (cdr priorities)))
900 ((string= temp-mark wl-summary-score-below-mark)
901 '(wl-highlight-summary-low-read-face))
902 ((string= temp-mark wl-summary-score-over-mark)
903 '(wl-highlight-summary-high-read-face))
905 '(wl-highlight-summary-normal-face)
906 '(wl-highlight-summary-thread-top-face)))))))
908 (autoload 'elmo-flag-folder-referrer "elmo-flag")
909 (defun wl-highlight-flag-folder-help-echo (folder number)
910 (let ((referer (elmo-flag-folder-referrer folder number)))
911 (concat "The message exists in "
914 (concat (car pair) "/"
919 (defun wl-highlight-summary-line-help-echo (number beg end &optional string)
920 (let ((type (elmo-folder-type-internal wl-summary-buffer-elmo-folder))
922 (when (setq handler (cadr (assq type wl-highlight-summary-line-help-echo-alist)))
924 (funcall handler wl-summary-buffer-elmo-folder number))
926 (put-text-property beg end 'help-echo
930 (defun wl-highlight-summary-line-string (number line flags temp-mark indent)
931 (let ((fsymbol (car (wl-highlight-summary-line-face-spec
934 (> (length indent) 0)))))
935 (put-text-property 0 (length line) 'face fsymbol line))
936 (when wl-use-highlight-mouse-line
937 (put-text-property 0 (length line) 'mouse-face 'highlight line))
938 (when wl-highlight-summary-line-help-echo-alist
939 (wl-highlight-summary-line-help-echo number 0 (length line) line)))
941 (defun wl-highlight-summary-current-line (&optional number flags)
944 (let ((inhibit-read-only t)
945 (case-fold-search nil)
946 (deactivate-mark nil)
947 (number (or number (wl-summary-message-number)))
954 (setq spec (wl-highlight-summary-line-face-spec
956 (elmo-message-flags wl-summary-buffer-elmo-folder
958 (wl-summary-temp-mark number)
959 (wl-thread-entity-get-parent-entity
960 (wl-thread-get-entity number))))
962 (put-text-property bol eol 'face (car spec)))
964 (put-text-property (next-single-property-change
965 (next-single-property-change
966 bol 'wl-summary-action-argument
968 'wl-summary-action-argument nil eol)
971 'wl-highlight-action-argument-face))
972 (when wl-use-highlight-mouse-line
973 (put-text-property bol eol 'mouse-face 'highlight))
974 (when wl-highlight-summary-line-help-echo-alist
975 (wl-highlight-summary-line-help-echo number bol eol))
977 (wl-dnd-set-drag-starter bol eol))))))
979 (defun wl-highlight-folder (start end)
980 "Highlight folder between start and end.
982 wl-highlight-folder-unknown-face unread messages
983 wl-highlight-folder-zero-face folder needs no sync
984 wl-highlight-folder-few-face folder contains few unsync messages
985 wl-highlight-folder-many-face folder contains many unsync messages
986 wl-highlight-folder-opened-face opened group folder
987 wl-highlight-folder-closed-face closed group folder
990 wl-highlight-folder-opened-regexp matches opened group folder
991 wl-highlight-folder-closed-regexp matches closed group folder
995 (let ((s start)) (setq start end end s)))
996 (let* ((lines (count-lines start end))
1002 (narrow-to-region start end)
1006 (wl-highlight-folder-current-line)
1007 (forward-line 1)))))))
1009 (defun wl-highlight-folder-path (folder-path)
1010 "Highlight current folder path...overlay"
1012 (wl-delete-all-overlays)
1013 (let ((fp folder-path) ov)
1014 (goto-char (point-min))
1018 (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):.*\n")
1019 (looking-at "^[ ]*\\([^ \\[].+\\):.*\n"))
1021 (get-text-property (point) 'wl-folder-entity-id)
1024 (setq ov (make-overlay
1027 (setq wl-folder-buffer-cur-point (point))
1028 (overlay-put ov 'face 'wl-highlight-folder-path-face)
1029 (overlay-put ov 'evaporate t)
1030 (overlay-put ov 'wl-momentary-overlay t))
1031 (forward-line 1)))))
1033 (defun wl-highlight-action-argument-string (string)
1034 (put-text-property 0 (length string) 'face
1035 'wl-highlight-action-argument-face
1038 (defun wl-highlight-summary-all ()
1041 (wl-highlight-summary (point-min)(point-max)))
1043 (defun wl-highlight-summary (start end &optional lazy)
1044 "Highlight summary between start and end.
1046 wl-highlight-summary-unread-face unread messages
1047 wl-highlight-summary-deleted-face messages mark as deleted
1048 wl-highlight-summary-refiled-face messages mark as refiled
1049 wl-highlight-summary-copied-face messages mark as copied
1050 wl-highlight-summary-new-face new messages
1051 wl-highlight-summary-*-flag-face flagged messages"
1053 (let ((s start)) (setq start end end s)))
1054 (let (lines too-big gc-message e p hend i percent)
1056 (unless wl-summary-lazy-highlight
1057 (setq lines (count-lines start end)
1058 too-big (and wl-highlight-max-summary-lines
1059 (> lines wl-highlight-max-summary-lines))))
1062 (while (and (not (eobp))
1064 (when (or (not lazy)
1065 (null (get-text-property (point) 'face)))
1066 (wl-highlight-summary-current-line))
1068 (unless wl-summary-lazy-highlight
1069 (message "Highlighting...done")))))
1071 (defun wl-highlight-summary-window (&optional win beg)
1072 "Highlight summary window.
1073 This function is defined for `window-scroll-functions'"
1074 (when wl-summary-highlight
1075 (with-current-buffer (window-buffer win)
1076 (when (eq major-mode 'wl-summary-mode)
1077 (let ((start (window-start win))
1078 (end (condition-case nil
1079 (window-end win t) ;; old emacsen doesn't support 2nd arg.
1080 (error (window-end win)))))
1081 (wl-highlight-summary start
1084 (set-buffer-modified-p nil)))))
1086 (defun wl-highlight-headers (&optional for-draft)
1087 (let ((beg (point-min))
1088 (end (or (save-excursion (re-search-forward "^$" nil t)
1091 (wl-highlight-message beg end nil)
1093 (when wl-highlight-x-face-function
1094 (funcall wl-highlight-x-face-function)))
1095 (run-hooks 'wl-highlight-headers-hook)))
1097 (defun wl-highlight-body-all ()
1098 (wl-highlight-message (point-min) (point-max) t t))
1100 (defun wl-highlight-body ()
1101 (let ((beg (or (save-excursion (goto-char (point-min))
1102 (re-search-forward "^$" nil t))
1105 (wl-highlight-message beg end t)))
1107 (defun wl-highlight-body-region (beg end)
1108 (wl-highlight-message beg end t t))
1110 (defun wl-highlight-signature-search-simple (beg end)
1111 "Search signature area in the body message between BEG and END.
1112 Returns start point of signature."
1115 (if (re-search-backward "\n--+ *\n" beg t)
1116 (if (eq (char-after (point)) ?\n)
1121 (defun wl-highlight-signature-search (beg end)
1122 "Search signature area in the body message between BEG and END.
1123 Returns start point of signature."
1127 ;; look for legal signature separator (check at first for fasten)
1128 (search-backward "\n-- \n" beg t)
1130 ;; look for dual separator
1134 (and (re-search-backward "^[^A-Za-z0-9> \t\n]+ *$" beg t)
1135 ;; `10' is a magic number.
1136 (> (- (match-end 0) (match-beginning 0)) 10)
1137 (setq separator (buffer-substring (match-beginning 0)
1139 ;; We should not use `re-search-backward' for a long word
1140 ;; since it is possible to crash XEmacs because of a bug.
1141 (if (search-backward (concat "\n" separator "\n") beg t)
1143 (and (search-backward (concat separator "\n") beg t)
1148 ;; look for user specified signature-separator
1149 (if (stringp wl-highlight-signature-separator)
1150 (re-search-backward wl-highlight-signature-separator nil t);; case one string
1151 (let ((sep wl-highlight-signature-separator)) ;; case list
1153 (not (re-search-backward (car sep) beg t)))
1154 (setq sep (cdr sep)))
1155 (point))) ;; if no separator found, returns end.
1158 (defun wl-highlight-message (start end hack-sig &optional body-only)
1159 "Highlight message headers between start and end.
1161 wl-highlight-message-headers the part before the colon
1162 wl-highlight-message-header-contents the part after the colon
1163 wl-highlight-message-important-header-contents contents of \"important\"
1165 wl-highlight-message-important-header-contents2 contents of \"important\"
1167 wl-highlight-message-unimportant-header-contents contents of unimportant
1169 wl-highlight-message-cited-text-N quoted text from other
1171 wl-highlight-message-citation-header header of quoted texts
1172 wl-highlight-message-signature signature
1175 wl-highlight-message-header-alist alist of header regexp with
1176 face for header contents
1177 wl-highlight-citation-prefix-regexp matches lines of quoted text
1178 wl-highlight-force-citation-header-regexp matches headers for quoted text
1179 wl-highlight-citation-header-regexp matches headers for quoted text
1181 If HACK-SIG is true,then we search backward from END for something that
1182 looks like the beginning of a signature block, and don't consider that a
1183 part of the message (this is because signatures are often incorrectly
1184 interpreted as cited text.)"
1186 (let ((s start)) (setq start end end s)))
1187 (let ((too-big (and wl-highlight-max-message-size
1189 wl-highlight-max-message-size)))
1197 ;; take off signature
1198 (if (and hack-sig (not too-big))
1199 (setq end (funcall wl-highlight-signature-search-function
1200 (- end wl-max-signature-size) end)))
1202 (not (eq end real-end)))
1203 (put-text-property end (point-max)
1204 'face 'wl-highlight-message-signature))
1205 (narrow-to-region start end)
1207 ;; narrow down to just the headers...
1209 ;; If this search fails then the narrowing performed above
1211 (if (re-search-forward (format
1213 (regexp-quote mail-header-separator))
1215 (narrow-to-region (point-min) (match-beginning 0)))
1216 ;; highlight only when header is not too-big.
1217 (when (or (null wl-highlight-max-header-size)
1218 (< (point) wl-highlight-max-header-size))
1220 (while (and (not body-only)
1222 (if (looking-at "^[^ \t\n:]+[ \t]*:[ \t]*")
1224 (put-text-property (match-beginning 0) (match-end 0)
1225 'face 'wl-highlight-message-headers)
1226 (setq p (match-end 0))
1227 (setq hend (save-excursion (std11-field-end end)))
1229 (let ((regexp-alist wl-highlight-message-header-alist))
1231 (when (save-match-data
1232 (looking-at (caar regexp-alist)))
1233 (put-text-property p hend 'face
1234 (cdar regexp-alist))
1236 (setq regexp-alist (cdr regexp-alist)))
1237 (throw 'match nil)))
1239 p hend 'face 'wl-highlight-message-header-contents))
1241 ;; ignore non-header field name lines
1242 (forward-line 1)))))
1243 (let (prefix prefix-face-alist pair end)
1246 ((looking-at (concat "^" (regexp-quote mail-header-separator) "$"))
1247 (put-text-property (match-beginning 0) (match-end 0)
1248 'face 'wl-highlight-header-separator-face)
1249 (goto-char (match-end 0)))
1250 ((null wl-highlight-force-citation-header-regexp)
1252 ((looking-at wl-highlight-force-citation-header-regexp)
1253 (setq current 'wl-highlight-message-citation-header)
1254 (setq end (match-end 0)))
1255 ((null wl-highlight-citation-prefix-regexp)
1257 ((looking-at wl-highlight-citation-prefix-regexp)
1258 (setq prefix (buffer-substring (point)
1260 (setq pair (assoc prefix prefix-face-alist))
1262 (setq prefix-face-alist
1263 (append prefix-face-alist
1269 (% (length prefix-face-alist)
1271 wl-highlight-citation-face-list))
1272 wl-highlight-citation-face-list)))))))
1273 (unless wl-highlight-highlight-citation-too
1274 (goto-char (match-end 0)))
1275 (setq current (cdr pair)))
1276 ((null wl-highlight-citation-header-regexp)
1278 ((looking-at wl-highlight-citation-header-regexp)
1279 (setq current 'wl-highlight-message-citation-header)
1280 (setq end (match-end 0)))
1281 (t (setq current nil)))
1284 (forward-line 1) ; this is to put the \n in the face too
1286 ;;; ((inhibit-read-only t))
1287 (put-text-property p (or end (point))
1292 (run-hooks 'wl-highlight-message-hook))))))
1294 ;; highlight-mouse-line for folder mode
1296 (defun wl-highlight-folder-mouse-line ()
1298 (let* ((end (save-excursion (end-of-line) (point)))
1300 (re-search-forward "[^ ]" end t)
1302 (inhibit-read-only t))
1303 (put-text-property beg end 'mouse-face 'highlight)))
1307 (product-provide (provide 'wl-highlight) (require 'wl-version))
1309 ;;; wl-highlight.el ends here