1 ;;; wl-highlight.el --- Hilight modules for Wanderlust.
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
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-new-face
199 (:foreground "tomato"))
202 (:foreground "tomato")))
203 "Face used for displaying new messages."
204 :group 'wl-summary-faces
207 (wl-defface wl-highlight-summary-displaying-face
209 (:underline t :bold t)))
210 "Face used for displaying message."
211 :group 'wl-summary-faces
214 (wl-defface wl-highlight-thread-indent-face
216 (:foreground "gray40")))
217 "Face used for displaying indented thread."
218 :group 'wl-summary-faces
221 ;; unimportant messages
223 (wl-defface wl-highlight-summary-unread-face
227 (:foreground "cyan"))
230 (:foreground "LightSkyBlue"))
233 (:foreground "RoyalBlue")))
234 "Face used for displaying unread messages."
235 :group 'wl-summary-faces
238 (wl-defface wl-highlight-summary-disposed-face
242 (:foreground "blue"))
245 (:foreground "gray"))
248 (:foreground "DarkKhaki")))
249 "Face used for displaying messages mark as disposed."
250 :group 'wl-summary-faces
253 (wl-defface wl-highlight-summary-deleted-face
257 (:foreground "blue"))
260 (:foreground "SteelBlue"))
263 (:foreground "RoyalBlue4")))
264 "Face used for displaying messages mark as deleted."
265 :group 'wl-summary-faces
268 (wl-defface wl-highlight-summary-prefetch-face
272 (:foreground "Green"))
275 (:foreground "DeepSkyBlue"))
278 (:foreground "brown")))
279 "Face used for displaying messages mark as deleted."
280 :group 'wl-summary-faces
283 (wl-defface wl-highlight-summary-resend-face
287 (:foreground "Yellow"))
290 (:foreground "orange3"))
293 (:foreground "orange3")))
294 "Face used for displaying messages mark as resend."
295 :group 'wl-summary-faces
298 (wl-defface wl-highlight-summary-refiled-face
302 (:foreground "blue"))
305 (:foreground "blue"))
308 (:foreground "firebrick")))
309 "Face used for displaying messages mark as refiled."
310 :group 'wl-summary-faces
313 (wl-defface wl-highlight-summary-copied-face
317 (:foreground "blue"))
320 (:foreground "cyan"))
323 (:foreground "blue")))
324 "Face used for displaying messages mark as copied."
325 :group 'wl-summary-faces
329 (wl-defface wl-highlight-summary-answered-face
332 (:foreground "yellow"))
335 (:foreground "khaki"))
338 (:foreground "khaki4")))
339 "Face used for displaying answered messages."
340 :group 'wl-summary-faces
344 (wl-defface wl-highlight-summary-temp-face
348 (:foreground "gold"))
350 (:foreground "HotPink1")))
351 "Face used for displaying messages mark as temp."
352 :group 'wl-summary-faces
355 (wl-defface wl-highlight-summary-target-face
359 (:foreground "gold"))
361 (:foreground "HotPink1")))
362 "Face used for displaying messages mark as target."
363 :group 'wl-summary-faces
366 (wl-defface wl-highlight-summary-low-read-face
370 (:foreground "yellow" :italic t))
373 (:foreground "PaleGreen" :italic t))
376 (:foreground "Green3" :italic t)))
377 "Face used for displaying low interest read messages."
378 :group 'wl-summary-faces
381 (wl-defface wl-highlight-summary-high-read-face
387 (:foreground "PaleGreen" :bold t))
390 (:foreground "SeaGreen" :bold t)))
391 "Face used for displaying high interest read messages."
392 :group 'wl-summary-faces
395 (wl-defface wl-highlight-summary-low-unread-face
399 (:foreground "cyan" :italic t))
402 (:foreground "LightSkyBlue" :italic t))
405 (:foreground "RoyalBlue" :italic t)))
406 "Face used for displaying low interest unread messages."
407 :group 'wl-summary-faces
410 (wl-defface wl-highlight-summary-high-unread-face
413 (:foreground "red" :bold t))
416 (:foreground "tomato" :bold t))
419 (:foreground "tomato" :bold t)))
420 "Face used for displaying high interest unread messages."
421 :group 'wl-summary-faces
426 (wl-defface wl-highlight-summary-thread-top-face
430 (:foreground "green"))
433 (:foreground "GreenYellow"))
436 (:foreground "green4")))
437 "Face used for displaying top thread message."
438 :group 'wl-summary-faces
441 (wl-defface wl-highlight-summary-normal-face
445 (:foreground "yellow"))
448 (:foreground "PaleGreen"))
451 (:foreground "SeaGreen")))
452 "Face used for displaying normal message."
453 :group 'wl-summary-faces
458 (wl-defface wl-highlight-folder-unknown-face
462 (:foreground "cyan"))
465 (:foreground "pink"))
468 (:foreground "RoyalBlue")))
469 "Face used for displaying unread folder."
470 :group 'wl-folder-faces
473 (wl-defface wl-highlight-folder-killed-face
477 (:foreground "gray"))
479 (:foreground "gray50")))
480 "Face used for displaying killed folder."
481 :group 'wl-folder-faces
484 (wl-defface wl-highlight-folder-zero-face
488 (:foreground "green"))
491 (:foreground "SkyBlue"))
494 (:foreground "BlueViolet")))
495 "Face used for displaying folder needs no sync."
496 :group 'wl-folder-faces
499 (wl-defface wl-highlight-folder-few-face
503 (:foreground "yellow"))
506 (:foreground "orange"))
509 (:foreground "OrangeRed3")))
510 "Face used for displaying folder contains few unsync messages."
511 :group 'wl-folder-faces
514 (wl-defface wl-highlight-folder-many-face
521 (:foreground "HotPink1"))
524 (:foreground "tomato")))
525 "Face used for displaying folder contains many unsync messages."
526 :group 'wl-folder-faces
529 (wl-defface wl-highlight-folder-unread-face
533 (:foreground "magenta"))
536 (:foreground "gold"))
539 (:foreground "MediumVioletRed")))
540 "Face used for displaying unread folder."
541 :group 'wl-folder-faces
544 (wl-defface wl-highlight-folder-opened-face
548 (:foreground "blue"))
551 (:foreground "PaleGreen"))
554 (:foreground "ForestGreen")))
555 "Face used for displaying opened group folder."
556 :group 'wl-folder-faces
559 (wl-defface wl-highlight-folder-closed-face
563 (:foreground "cyan"))
566 (:foreground "GreenYellow"))
569 (:foreground "DarkOliveGreen4")))
570 "Face used for displaying closed group folder."
571 :group 'wl-folder-faces
574 (wl-defface wl-highlight-folder-path-face
576 (:bold t :underline t)))
577 "Face used for displaying path."
578 :group 'wl-folder-faces
581 (wl-defface wl-highlight-demo-face
583 (:foreground "green"))
586 (:foreground "#006600" :background "#d9ffd9"))
589 (:foreground "#d9ffd9" :background "#004400")))
590 "Face used for displaying demo."
593 (wl-defface wl-highlight-logo-face
596 (:foreground "cyan"))
599 (:foreground "SkyBlue"))
602 (:foreground "SteelBlue")))
603 "Face used for displaying demo."
606 (wl-defface wl-highlight-action-argument-face
609 (:foreground "pink"))
612 (:foreground "red")))
613 "Face used for displaying action argument."
614 :group 'wl-summary-faces
619 (wl-defface wl-highlight-message-cited-text-1
623 (:foreground "magenta"))
626 (:foreground "HotPink1"))
629 (:foreground "ForestGreen")))
630 "Face used for displaying quoted text from other messages."
631 :group 'wl-message-faces
634 (wl-defface wl-highlight-message-cited-text-2
638 (:foreground "blue"))
640 (:foreground "violet")))
641 "Face used for displaying quoted text from other messages."
642 :group 'wl-message-faces
645 (wl-defface wl-highlight-message-cited-text-3
649 (:foreground "cyan"))
651 (:foreground "orchid3")))
652 "Face used for displaying quoted text from other messages."
653 :group 'wl-message-faces
656 (wl-defface wl-highlight-message-cited-text-4
660 (:foreground "green"))
662 (:foreground "purple1")))
663 "Face used for displaying quoted text from other messages."
664 :group 'wl-message-faces
667 (wl-defface wl-highlight-message-cited-text-5
671 (:foreground "yellow"))
673 (:foreground "MediumPurple1")))
674 "Face used for displaying quoted text from other messages."
675 :group 'wl-message-faces
678 (wl-defface wl-highlight-message-cited-text-6
684 (:foreground "PaleVioletRed")))
685 "Face used for displaying quoted text from other messages."
686 :group 'wl-message-faces
689 (wl-defface wl-highlight-message-cited-text-7
693 (:foreground "magenta"))
695 (:foreground "LightPink")))
696 "Face used for displaying quoted text from other messages."
697 :group 'wl-message-faces
700 (wl-defface wl-highlight-message-cited-text-8
704 (:foreground "blue"))
706 (:foreground "salmon")))
707 "Face used for displaying quoted text from other messages."
708 :group 'wl-message-faces
711 (wl-defface wl-highlight-message-cited-text-9
715 (:foreground "cyan"))
717 (:foreground "SandyBrown")))
718 "Face used for displaying quoted text from other messages."
719 :group 'wl-message-faces
722 (wl-defface wl-highlight-message-cited-text-10
726 (:foreground "green"))
728 (:foreground "wheat")))
729 "Face used for displaying quoted text from other messages."
730 :group 'wl-message-faces
733 (defface wl-message-header-narrowing-face
734 '((((class color) (background light))
735 (:foreground "black" :background "dark khaki"))
736 (((class color) (background dark))
737 (:foreground "white" :background "dark goldenrod"))
739 "Face used for header narrowing for the message."
740 :group 'wl-message-faces
743 (defvar wl-highlight-folder-opened-regexp " *\\(\\[\\-\\]\\)")
744 (defvar wl-highlight-folder-closed-regexp " *\\(\\[\\+\\]\\)")
745 (defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$")
747 (defvar wl-highlight-citation-face-list
748 '(wl-highlight-message-cited-text-1
749 wl-highlight-message-cited-text-2
750 wl-highlight-message-cited-text-3
751 wl-highlight-message-cited-text-4
752 wl-highlight-message-cited-text-5
753 wl-highlight-message-cited-text-6
754 wl-highlight-message-cited-text-7
755 wl-highlight-message-cited-text-8
756 wl-highlight-message-cited-text-9
757 wl-highlight-message-cited-text-10))
759 (defmacro wl-delete-all-overlays ()
760 "Delete all momentary overlays."
761 '(let ((overlays (overlays-in (point-min) (point-max)))
763 (while (setq overlay (car overlays))
764 (if (overlay-get overlay 'wl-momentary-overlay)
765 (delete-overlay overlay))
766 (setq overlays (cdr overlays)))))
768 (defun wl-highlight-summary-displaying ()
770 (wl-delete-all-overlays)
777 (setq ov (make-overlay bol eol))
778 (overlay-put ov 'face 'wl-highlight-summary-displaying-face)
779 (overlay-put ov 'evaporate t)
780 (overlay-put ov 'wl-momentary-overlay t))))
782 (defun wl-highlight-folder-group-line (numbers)
788 (let ((text-face (cond ((looking-at wl-highlight-folder-opened-regexp)
789 'wl-highlight-folder-opened-face)
790 ((looking-at wl-highlight-folder-closed-regexp)
791 'wl-highlight-folder-closed-face))))
792 (if (and wl-highlight-folder-by-numbers
793 (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" eol t))
794 (let* ((unsync (nth 0 numbers))
795 (unread (nth 1 numbers))
796 (face (cond ((and unsync (zerop unsync))
797 (if (and unread (> unread 0))
798 'wl-highlight-folder-unread-face
799 'wl-highlight-folder-zero-face))
801 (>= unsync wl-folder-many-unsync-threshold))
802 'wl-highlight-folder-many-face)
804 'wl-highlight-folder-few-face))))
805 (if (numberp wl-highlight-folder-by-numbers)
807 (put-text-property bol (match-beginning 0) 'face text-face)
808 (put-text-property (match-beginning 0) (match-end 0)
810 ;; Remove previous face.
811 (put-text-property bol (match-end 0) 'face nil)
812 (put-text-property bol (match-end 0) 'face face)))
813 (put-text-property bol eol 'face text-face)))))
815 (defsubst wl-highlight-summary-line-face-spec (flags temp-mark indent)
816 "Return a cons cell of (face . argument)."
818 (if (setq action (assoc temp-mark wl-summary-mark-action-list))
819 (cons (nth 5 action) (nth 2 action))
821 ((and (string= temp-mark wl-summary-score-over-mark)
822 (or (memq 'new flags) (memq 'unread flags)))
823 '(wl-highlight-summary-high-unread-face))
824 ((and (string= temp-mark wl-summary-score-below-mark)
825 (or (memq 'new flags) (memq 'unread flags)))
826 '(wl-highlight-summary-low-unread-face))
827 ((let ((priorities wl-summary-persistent-mark-priority-list)
828 (fl wl-summary-flag-alist)
829 face result global-flags)
830 (while (and (null result) priorities)
831 (if (and (eq (car priorities) 'flag)
833 (elmo-get-global-flags flags 'ignore-preserved)))
835 (when (memq (car (car fl)) global-flags)
840 "wl-highlight-summary-%s-flag-face"
842 (when (find-face face)
846 (when (memq (car priorities) flags)
850 "wl-highlight-summary-%s-face"
852 (when (find-face face)
854 (setq priorities (cdr priorities)))
856 ((string= temp-mark wl-summary-score-below-mark)
857 '(wl-highlight-summary-low-read-face))
858 ((string= temp-mark wl-summary-score-over-mark)
859 '(wl-highlight-summary-high-read-face))
861 '(wl-highlight-summary-normal-face)
862 '(wl-highlight-summary-thread-top-face)))))))
864 (defun wl-highlight-summary-line-flag-folder (number beg end &optional string)
865 ;; help-echo for flag folder.
868 (when (eq (elmo-folder-type-internal wl-summary-buffer-elmo-folder)
871 (elmo-flag-folder-referrer wl-summary-buffer-elmo-folder
874 (put-text-property beg end 'help-echo
875 (concat "The message exists in "
878 (concat (car pair) "/"
884 (defun wl-highlight-summary-line-string (number line flags temp-mark indent)
885 (let ((fsymbol (car (wl-highlight-summary-line-face-spec
888 (> (length indent) 0)))))
889 (put-text-property 0 (length line) 'face fsymbol line))
890 (when wl-use-highlight-mouse-line
891 (put-text-property 0 (length line) 'mouse-face 'highlight line))
892 (when wl-use-flag-folder-help-echo
893 (wl-highlight-summary-line-flag-folder number 0 (length line) line)))
895 (defun wl-highlight-summary-current-line (&optional number flags)
898 (let ((inhibit-read-only t)
899 (case-fold-search nil)
900 (deactivate-mark nil)
901 (number (or number (wl-summary-message-number)))
907 (setq spec (wl-highlight-summary-line-face-spec
909 (elmo-message-flags wl-summary-buffer-elmo-folder
911 (wl-summary-temp-mark number)
912 (wl-thread-entity-get-parent-entity
913 (wl-thread-get-entity number))))
915 (put-text-property bol eol 'face (car spec)))
917 (put-text-property (next-single-property-change
918 (next-single-property-change
919 bol 'wl-summary-action-argument
921 'wl-summary-action-argument nil eol)
924 'wl-highlight-action-argument-face))
925 (when wl-use-highlight-mouse-line
926 (put-text-property bol eol 'mouse-face 'highlight))
927 (when wl-use-flag-folder-help-echo
928 (wl-highlight-summary-line-flag-folder number bol eol))
930 (wl-dnd-set-drag-starter bol eol)))))
932 (defun wl-highlight-folder (start end)
933 "Highlight folder between start and end.
935 wl-highlight-folder-unknown-face unread messages
936 wl-highlight-folder-zero-face folder needs no sync
937 wl-highlight-folder-few-face folder contains few unsync messages
938 wl-highlight-folder-many-face folder contains many unsync messages
939 wl-highlight-folder-opened-face opened group folder
940 wl-highlight-folder-closed-face closed group folder
943 wl-highlight-folder-opened-regexp matches opened group folder
944 wl-highlight-folder-closed-regexp matches closed group folder
948 (let ((s start)) (setq start end end s)))
949 (let* ((lines (count-lines start end))
955 (narrow-to-region start end)
959 (wl-highlight-folder-current-line)
960 (forward-line 1)))))))
962 (defun wl-highlight-folder-path (folder-path)
963 "Highlight current folder path...overlay"
965 (wl-delete-all-overlays)
966 (let ((fp folder-path) ov)
967 (goto-char (point-min))
971 (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):.*\n")
972 (looking-at "^[ ]*\\([^ \\[].+\\):.*\n"))
974 (get-text-property (point) 'wl-folder-entity-id)
977 (setq ov (make-overlay
980 (setq wl-folder-buffer-cur-point (point))
981 (overlay-put ov 'face 'wl-highlight-folder-path-face)
982 (overlay-put ov 'evaporate t)
983 (overlay-put ov 'wl-momentary-overlay t))
986 (defun wl-highlight-action-argument-string (string)
987 (put-text-property 0 (length string) 'face
988 'wl-highlight-action-argument-face
991 (defun wl-highlight-summary-all ()
994 (wl-highlight-summary (point-min)(point-max)))
996 (defun wl-highlight-summary (start end &optional lazy)
997 "Highlight summary between start and end.
999 wl-highlight-summary-unread-face unread messages
1000 wl-highlight-summary-deleted-face messages mark as deleted
1001 wl-highlight-summary-refiled-face messages mark as refiled
1002 wl-highlight-summary-copied-face messages mark as copied
1003 wl-highlight-summary-new-face new messages
1004 wl-highlight-summary-*-flag-face flagged messages"
1006 (let ((s start)) (setq start end end s)))
1007 (let (lines too-big gc-message e p hend i percent)
1009 (unless wl-summary-lazy-highlight
1010 (setq lines (count-lines start end)
1011 too-big (and wl-highlight-max-summary-lines
1012 (> lines wl-highlight-max-summary-lines))))
1015 (while (and (not (eobp))
1017 (when (or (not lazy)
1018 (null (get-text-property (point) 'face)))
1019 (wl-highlight-summary-current-line))
1021 (unless wl-summary-lazy-highlight
1022 (message "Highlighting...done")))))
1024 (defun wl-highlight-summary-window (&optional win beg)
1025 "Highlight summary window.
1026 This function is defined for `window-scroll-functions'"
1027 (when wl-summary-highlight
1028 (with-current-buffer (window-buffer win)
1029 (when (eq major-mode 'wl-summary-mode)
1030 (let ((start (window-start win))
1031 (end (condition-case nil
1032 (window-end win t) ;; old emacsen doesn't support 2nd arg.
1033 (error (window-end win)))))
1034 (wl-highlight-summary start
1037 (set-buffer-modified-p nil)))))
1039 (defun wl-highlight-headers (&optional for-draft)
1040 (let ((beg (point-min))
1041 (end (or (save-excursion (re-search-forward "^$" nil t)
1044 (wl-highlight-message beg end nil)
1046 (when wl-highlight-x-face-function
1047 (funcall wl-highlight-x-face-function)))
1048 (run-hooks 'wl-highlight-headers-hook)))
1050 (defun wl-highlight-body-all ()
1051 (wl-highlight-message (point-min) (point-max) t t))
1053 (defun wl-highlight-body ()
1054 (let ((beg (or (save-excursion (goto-char (point-min))
1055 (re-search-forward "^$" nil t))
1058 (wl-highlight-message beg end t)))
1060 (defun wl-highlight-body-region (beg end)
1061 (wl-highlight-message beg end t t))
1063 (defun wl-highlight-signature-search-simple (beg end)
1064 "Search signature area in the body message between BEG and END.
1065 Returns start point of signature."
1068 (if (re-search-backward "\n--+ *\n" beg t)
1069 (if (eq (char-after (point)) ?\n)
1074 (defun wl-highlight-signature-search (beg end)
1075 "Search signature area in the body message between BEG and END.
1076 Returns start point of signature."
1080 ;; look for legal signature separator (check at first for fasten)
1081 (search-backward "\n-- \n" beg t)
1083 ;; look for dual separator
1087 (and (re-search-backward "^[^A-Za-z0-9> \t\n]+ *$" beg t)
1088 ;; `10' is a magic number.
1089 (> (- (match-end 0) (match-beginning 0)) 10)
1090 (setq separator (buffer-substring (match-beginning 0)
1092 ;; We should not use `re-search-backward' for a long word
1093 ;; since it is possible to crash XEmacs because of a bug.
1094 (if (search-backward (concat "\n" separator "\n") beg t)
1096 (and (search-backward (concat separator "\n") beg t)
1101 ;; look for user specified signature-separator
1102 (if (stringp wl-highlight-signature-separator)
1103 (re-search-backward wl-highlight-signature-separator nil t);; case one string
1104 (let ((sep wl-highlight-signature-separator)) ;; case list
1106 (not (re-search-backward (car sep) beg t)))
1107 (setq sep (cdr sep)))
1108 (point))) ;; if no separator found, returns end.
1111 (defun wl-highlight-message (start end hack-sig &optional body-only)
1112 "Highlight message headers between start and end.
1114 wl-highlight-message-headers the part before the colon
1115 wl-highlight-message-header-contents the part after the colon
1116 wl-highlight-message-important-header-contents contents of \"important\"
1118 wl-highlight-message-important-header-contents2 contents of \"important\"
1120 wl-highlight-message-unimportant-header-contents contents of unimportant
1122 wl-highlight-message-cited-text quoted text from other
1124 wl-highlight-message-citation-header header of quoted texts
1125 wl-highlight-message-signature signature
1128 wl-highlight-important-header-regexp what makes a \"important\" header
1129 wl-highlight-important-header2-regexp what makes a \"important\" header
1130 wl-highlight-unimportant-header-regexp what makes a \"not important\" header
1131 wl-highlight-citation-prefix-regexp matches lines of quoted text
1132 wl-highlight-citation-header-regexp matches headers for quoted text
1134 If HACK-SIG is true,then we search backward from END for something that
1135 looks like the beginning of a signature block, and don't consider that a
1136 part of the message (this is because signatures are often incorrectly
1137 interpreted as cited text.)"
1139 (let ((s start)) (setq start end end s)))
1140 (let ((too-big (and wl-highlight-max-message-size
1142 wl-highlight-max-message-size)))
1150 ;; take off signature
1151 (if (and hack-sig (not too-big))
1152 (setq end (funcall wl-highlight-signature-search-function
1153 (- end wl-max-signature-size) end)))
1155 (not (eq end real-end)))
1156 (put-text-property end (point-max)
1157 'face 'wl-highlight-message-signature))
1158 (narrow-to-region start end)
1160 ;; narrow down to just the headers...
1162 ;; If this search fails then the narrowing performed above
1164 (if (re-search-forward (format
1166 (regexp-quote mail-header-separator))
1168 (narrow-to-region (point-min) (match-beginning 0)))
1169 ;; highlight only when header is not too-big.
1170 (when (or (null wl-highlight-max-header-size)
1171 (< (point) wl-highlight-max-header-size))
1173 (while (and (not body-only)
1175 (if (looking-at "^[^ \t\n:]+[ \t]*:")
1177 (put-text-property (match-beginning 0) (match-end 0)
1178 'face 'wl-highlight-message-headers)
1179 (setq p (match-end 0))
1180 (setq hend (save-excursion (std11-field-end end)))
1182 (let ((regexp-alist wl-highlight-message-header-alist))
1184 (when (save-match-data
1185 (looking-at (caar regexp-alist)))
1186 (put-text-property p hend 'face
1187 (cdar regexp-alist))
1189 (setq regexp-alist (cdr regexp-alist)))
1190 (throw 'match nil)))
1192 p hend 'face 'wl-highlight-message-header-contents))
1194 ;; ignore non-header field name lines
1195 (forward-line 1)))))
1196 (let (prefix prefix-face-alist pair end)
1199 ((looking-at (concat "^" (regexp-quote mail-header-separator) "$"))
1200 (put-text-property (match-beginning 0) (match-end 0)
1201 'face 'wl-highlight-header-separator-face)
1202 (goto-char (match-end 0)))
1203 ((null wl-highlight-force-citation-header-regexp)
1205 ((looking-at wl-highlight-force-citation-header-regexp)
1206 (setq current 'wl-highlight-message-citation-header)
1207 (setq end (match-end 0)))
1208 ((null wl-highlight-citation-prefix-regexp)
1210 ((looking-at wl-highlight-citation-prefix-regexp)
1211 (setq prefix (buffer-substring (point)
1213 (setq pair (assoc prefix prefix-face-alist))
1215 (setq prefix-face-alist
1216 (append prefix-face-alist
1222 (% (length prefix-face-alist)
1224 wl-highlight-citation-face-list))
1225 wl-highlight-citation-face-list)))))))
1226 (unless wl-highlight-highlight-citation-too
1227 (goto-char (match-end 0)))
1228 (setq current (cdr pair)))
1229 ((null wl-highlight-citation-header-regexp)
1231 ((looking-at wl-highlight-citation-header-regexp)
1232 (setq current 'wl-highlight-message-citation-header)
1233 (setq end (match-end 0)))
1234 (t (setq current nil)))
1237 (forward-line 1) ; this is to put the \n in the face too
1239 ;;; ((inhibit-read-only t))
1240 (put-text-property p (or end (point))
1245 (run-hooks 'wl-highlight-message-hook))))))
1247 ;; highlight-mouse-line for folder mode
1249 (defun wl-highlight-folder-mouse-line ()
1251 (let* ((end (save-excursion (end-of-line) (point)))
1253 (re-search-forward "[^ ]" end t)
1255 (inhibit-read-only t))
1256 (put-text-property beg end 'mouse-face 'highlight)))
1259 (autoload 'elmo-flag-folder-referrer "elmo-flag")
1262 (product-provide (provide 'wl-highlight) (require 'wl-version))
1264 ;;; wl-highlight.el ends here