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-killed-face
224 (:foreground "blue"))
227 (:foreground "gray"))
229 (:foreground "LightSlateGray")))
230 "Face used for displaying killed messages."
231 :group 'wl-summary-faces
234 (wl-defface wl-highlight-summary-displaying-face
236 (:underline t :bold t)))
237 "Face used for displaying message."
238 :group 'wl-summary-faces
241 (wl-defface wl-highlight-thread-indent-face
243 (:foreground "gray40")))
244 "Face used for displaying indented thread."
245 :group 'wl-summary-faces
248 ;; unimportant messages
250 (wl-defface wl-highlight-summary-unread-face
254 (:foreground "cyan"))
257 (:foreground "LightSkyBlue"))
260 (:foreground "RoyalBlue")))
261 "Face used for displaying unread messages."
262 :group 'wl-summary-faces
265 (wl-defface wl-highlight-summary-disposed-face
269 (:foreground "blue"))
272 (:foreground "gray"))
275 (:foreground "DarkKhaki")))
276 "Face used for displaying messages mark as disposed."
277 :group 'wl-summary-faces
280 (wl-defface wl-highlight-summary-deleted-face
284 (:foreground "blue"))
287 (:foreground "SteelBlue"))
290 (:foreground "RoyalBlue4")))
291 "Face used for displaying messages mark as deleted."
292 :group 'wl-summary-faces
295 (wl-defface wl-highlight-summary-prefetch-face
299 (:foreground "Green"))
302 (:foreground "DeepSkyBlue"))
305 (:foreground "brown")))
306 "Face used for displaying messages mark as deleted."
307 :group 'wl-summary-faces
310 (wl-defface wl-highlight-summary-resend-face
314 (:foreground "Yellow"))
317 (:foreground "orange3"))
320 (:foreground "orange3")))
321 "Face used for displaying messages mark as resend."
322 :group 'wl-summary-faces
325 (wl-defface wl-highlight-summary-refiled-face
329 (:foreground "blue"))
332 (:foreground "blue"))
335 (:foreground "firebrick")))
336 "Face used for displaying messages mark as refiled."
337 :group 'wl-summary-faces
340 (wl-defface wl-highlight-summary-copied-face
344 (:foreground "blue"))
347 (:foreground "cyan"))
350 (:foreground "blue")))
351 "Face used for displaying messages mark as copied."
352 :group 'wl-summary-faces
356 (wl-defface wl-highlight-summary-answered-face
359 (:foreground "yellow"))
362 (:foreground "khaki"))
365 (:foreground "khaki4")))
366 "Face used for displaying answered messages."
367 :group 'wl-summary-faces
371 (wl-defface wl-highlight-summary-forwarded-face
374 (:foreground "yellow"))
377 (:foreground "DarkOliveGreen2"))
380 (:foreground "DarkOliveGreen4")))
381 "Face used for displaying forwarded messages."
382 :group 'wl-summary-faces
385 (wl-defface wl-summary-persistent-mark-face
387 (:foreground "blue"))
390 (:foreground "SeaGreen4"))
393 (:foreground "SeaGreen1")))
394 "Dafault face used for displaying messages with persistent mark."
395 :group 'wl-summary-faces
399 (wl-defface wl-highlight-summary-temp-face
403 (:foreground "gold"))
405 (:foreground "HotPink1")))
406 "Face used for displaying messages mark as temp."
407 :group 'wl-summary-faces
410 (wl-defface wl-highlight-summary-target-face
414 (:foreground "gold"))
416 (:foreground "HotPink1")))
417 "Face used for displaying messages mark as target."
418 :group 'wl-summary-faces
421 (wl-defface wl-highlight-summary-low-read-face
425 (:foreground "yellow" :italic t))
428 (:foreground "PaleGreen" :italic t))
431 (:foreground "Green3" :italic t)))
432 "Face used for displaying low interest read messages."
433 :group 'wl-summary-faces
436 (wl-defface wl-highlight-summary-high-read-face
442 (:foreground "PaleGreen" :bold t))
445 (:foreground "SeaGreen" :bold t)))
446 "Face used for displaying high interest read messages."
447 :group 'wl-summary-faces
450 (wl-defface wl-highlight-summary-low-unread-face
454 (:foreground "cyan" :italic t))
457 (:foreground "LightSkyBlue" :italic t))
460 (:foreground "RoyalBlue" :italic t)))
461 "Face used for displaying low interest unread messages."
462 :group 'wl-summary-faces
465 (wl-defface wl-highlight-summary-high-unread-face
468 (:foreground "red" :bold t))
471 (:foreground "tomato" :bold t))
474 (:foreground "tomato" :bold t)))
475 "Face used for displaying high interest unread messages."
476 :group 'wl-summary-faces
481 (wl-defface wl-highlight-summary-thread-top-face
485 (:foreground "green"))
488 (:foreground "GreenYellow"))
491 (:foreground "green4")))
492 "Face used for displaying top thread message."
493 :group 'wl-summary-faces
496 (wl-defface wl-highlight-summary-normal-face
500 (:foreground "yellow"))
503 (:foreground "PaleGreen"))
506 (:foreground "SeaGreen")))
507 "Face used for displaying normal message."
508 :group 'wl-summary-faces
513 (wl-defface wl-highlight-folder-unknown-face
517 (:foreground "cyan"))
520 (:foreground "pink"))
523 (:foreground "RoyalBlue")))
524 "Face used for displaying unread folder."
525 :group 'wl-folder-faces
528 (wl-defface wl-highlight-folder-killed-face
532 (:foreground "gray"))
534 (:foreground "gray50")))
535 "Face used for displaying killed folder."
536 :group 'wl-folder-faces
539 (wl-defface wl-highlight-folder-zero-face
543 (:foreground "green"))
546 (:foreground "SkyBlue"))
549 (:foreground "BlueViolet")))
550 "Face used for displaying folder needs no sync."
551 :group 'wl-folder-faces
554 (wl-defface wl-highlight-folder-few-face
558 (:foreground "yellow"))
561 (:foreground "orange"))
564 (:foreground "OrangeRed3")))
565 "Face used for displaying folder contains few unsync messages."
566 :group 'wl-folder-faces
569 (wl-defface wl-highlight-folder-many-face
576 (:foreground "HotPink1"))
579 (:foreground "tomato")))
580 "Face used for displaying folder contains many unsync messages."
581 :group 'wl-folder-faces
584 (wl-defface wl-highlight-folder-unread-face
588 (:foreground "magenta"))
591 (:foreground "gold"))
594 (:foreground "MediumVioletRed")))
595 "Face used for displaying unread folder."
596 :group 'wl-folder-faces
599 (wl-defface wl-highlight-folder-opened-face
603 (:foreground "blue"))
606 (:foreground "PaleGreen"))
609 (:foreground "ForestGreen")))
610 "Face used for displaying opened group folder."
611 :group 'wl-folder-faces
614 (wl-defface wl-highlight-folder-closed-face
618 (:foreground "cyan"))
621 (:foreground "GreenYellow"))
624 (:foreground "DarkOliveGreen4")))
625 "Face used for displaying closed group folder."
626 :group 'wl-folder-faces
629 (wl-defface wl-highlight-folder-path-face
631 (:bold t :underline t)))
632 "Face used for displaying path."
633 :group 'wl-folder-faces
636 (wl-defface wl-highlight-demo-face
638 (:foreground "green"))
641 (:foreground "#006600" :background "#d9ffd9"))
644 (:foreground "#d9ffd9" :background "#004400")))
645 "Face used for displaying demo."
648 (wl-defface wl-highlight-logo-face
651 (:foreground "cyan"))
654 (:foreground "SteelBlue" :background "#d9ffd9"))
657 (:foreground "SkyBlue" :background "#004400")))
658 "Face used for displaying demo."
661 (wl-defface wl-highlight-action-argument-face
664 (:foreground "pink"))
667 (:foreground "red")))
668 "Face used for displaying action argument."
669 :group 'wl-summary-faces
674 (wl-defface wl-highlight-message-cited-text-1
678 (:foreground "magenta"))
681 (:foreground "HotPink1"))
684 (:foreground "ForestGreen")))
685 "Face used for displaying quoted text from other messages."
686 :group 'wl-message-faces
689 (wl-defface wl-highlight-message-cited-text-2
693 (:foreground "blue"))
695 (:foreground "violet")))
696 "Face used for displaying quoted text from other messages."
697 :group 'wl-message-faces
700 (wl-defface wl-highlight-message-cited-text-3
704 (:foreground "cyan"))
706 (:foreground "orchid3")))
707 "Face used for displaying quoted text from other messages."
708 :group 'wl-message-faces
711 (wl-defface wl-highlight-message-cited-text-4
715 (:foreground "green"))
717 (:foreground "purple1")))
718 "Face used for displaying quoted text from other messages."
719 :group 'wl-message-faces
722 (wl-defface wl-highlight-message-cited-text-5
726 (:foreground "yellow"))
728 (:foreground "MediumPurple1")))
729 "Face used for displaying quoted text from other messages."
730 :group 'wl-message-faces
733 (wl-defface wl-highlight-message-cited-text-6
739 (:foreground "PaleVioletRed")))
740 "Face used for displaying quoted text from other messages."
741 :group 'wl-message-faces
744 (wl-defface wl-highlight-message-cited-text-7
748 (:foreground "magenta"))
750 (:foreground "LightPink")))
751 "Face used for displaying quoted text from other messages."
752 :group 'wl-message-faces
755 (wl-defface wl-highlight-message-cited-text-8
759 (:foreground "blue"))
761 (:foreground "salmon")))
762 "Face used for displaying quoted text from other messages."
763 :group 'wl-message-faces
766 (wl-defface wl-highlight-message-cited-text-9
770 (:foreground "cyan"))
772 (:foreground "SandyBrown")))
773 "Face used for displaying quoted text from other messages."
774 :group 'wl-message-faces
777 (wl-defface wl-highlight-message-cited-text-10
781 (:foreground "green"))
783 (:foreground "wheat")))
784 "Face used for displaying quoted text from other messages."
785 :group 'wl-message-faces
788 (defface wl-message-header-narrowing-face
789 '((((class color) (background light))
790 (:foreground "black" :background "dark khaki"))
791 (((class color) (background dark))
792 (:foreground "white" :background "dark goldenrod"))
794 "Face used for header narrowing for the message."
795 :group 'wl-message-faces
798 (defvar wl-highlight-folder-opened-regexp "^ *\\(\\[\\-\\]\\)")
799 (defvar wl-highlight-folder-closed-regexp "^ *\\(\\[\\+\\]\\)")
800 (defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$")
802 (defvar wl-highlight-citation-face-list
803 '(wl-highlight-message-cited-text-1
804 wl-highlight-message-cited-text-2
805 wl-highlight-message-cited-text-3
806 wl-highlight-message-cited-text-4
807 wl-highlight-message-cited-text-5
808 wl-highlight-message-cited-text-6
809 wl-highlight-message-cited-text-7
810 wl-highlight-message-cited-text-8
811 wl-highlight-message-cited-text-9
812 wl-highlight-message-cited-text-10))
814 (defmacro wl-delete-all-overlays ()
815 "Delete all momentary overlays."
816 '(let ((overlays (overlays-in (point-min) (point-max)))
818 (while (setq overlay (car overlays))
819 (if (overlay-get overlay 'wl-momentary-overlay)
820 (delete-overlay overlay))
821 (setq overlays (cdr overlays)))))
823 (defun wl-highlight-summary-displaying ()
825 (wl-delete-all-overlays)
832 (setq ov (make-overlay bol eol))
833 (overlay-put ov 'face 'wl-highlight-summary-displaying-face)
834 (overlay-put ov 'evaporate t)
835 (overlay-put ov 'wl-momentary-overlay t))))
837 (defun wl-highlight-folder-group-line (numbers)
843 (let ((text-face (cond ((looking-at wl-highlight-folder-opened-regexp)
844 'wl-highlight-folder-opened-face)
845 ((looking-at wl-highlight-folder-closed-regexp)
846 'wl-highlight-folder-closed-face))))
847 (if (and wl-highlight-folder-by-numbers
848 (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" eol t))
849 (let* ((unsync (nth 0 numbers))
850 (unread (nth 1 numbers))
851 (face (cond ((and unsync (zerop unsync))
852 (if (and unread (> unread 0))
853 'wl-highlight-folder-unread-face
854 'wl-highlight-folder-zero-face))
856 (>= unsync wl-folder-many-unsync-threshold))
857 'wl-highlight-folder-many-face)
859 'wl-highlight-folder-few-face))))
860 (if (numberp wl-highlight-folder-by-numbers)
862 (put-text-property bol (match-beginning 0) 'face text-face)
863 (put-text-property (match-beginning 0) (match-end 0)
865 ;; Remove previous face.
866 (put-text-property bol (match-end 0) 'face nil)
867 (put-text-property bol (match-end 0) 'face face)))
868 (put-text-property bol eol 'face text-face)))))
870 (defsubst wl-highlight-get-face-by-name (format &rest args)
871 (let ((face (intern (apply #'format format args))))
872 (and (find-face face)
875 (defsubst wl-highlight-summary-line-face-spec (status temp-mark indent)
876 "Return a cons cell of (face . argument)."
878 (and (setq action (assoc temp-mark wl-summary-mark-action-list))
879 (cons (nth 5 action) (nth 2 action))))
880 (let ((flags (elmo-message-status-flags status)))
882 ((and (string= temp-mark wl-summary-score-over-mark)
883 (or (memq 'new flags) (memq 'unread flags)))
884 '(wl-highlight-summary-high-unread-face))
885 ((and (string= temp-mark wl-summary-score-below-mark)
886 (or (memq 'new flags) (memq 'unread flags)))
887 '(wl-highlight-summary-low-unread-face))
888 ((let ((priorities wl-summary-persistent-mark-priority-list)
889 (fl wl-summary-flag-alist)
890 face result global-flags)
891 (while (and (null result) priorities)
893 ((eq (car priorities) 'killed)
894 (when (elmo-message-status-killed-p status)
895 (setq result '(wl-highlight-summary-killed-face))))
896 ((eq (car priorities) 'flag)
897 (when (setq global-flags
898 (elmo-get-global-flags flags 'ignore-preserved))
900 (when (memq (car (car fl)) global-flags)
902 (list (or (wl-highlight-get-face-by-name
903 "wl-highlight-summary-%s-flag-face"
905 'wl-highlight-summary-flagged-face))
909 (setq result (list 'wl-highlight-summary-flagged-face)))))
910 ((memq (car priorities) flags)
912 (list (or (wl-highlight-get-face-by-name
913 "wl-highlight-summary-%s-face"
915 'wl-summary-persistent-mark-face)))))
916 (setq priorities (cdr priorities)))
918 ((string= temp-mark wl-summary-score-below-mark)
919 '(wl-highlight-summary-low-read-face))
920 ((string= temp-mark wl-summary-score-over-mark)
921 '(wl-highlight-summary-high-read-face))
923 '(wl-highlight-summary-normal-face)
924 '(wl-highlight-summary-thread-top-face)))))))
926 (autoload 'elmo-flag-folder-referrer "elmo-flag")
927 (defun wl-highlight-flag-folder-help-echo (folder number)
928 (let ((referer (elmo-flag-folder-referrer folder number)))
929 (concat "The message exists in "
932 (concat (car pair) "/"
937 (defun wl-highlight-summary-line-help-echo (number beg end &optional string)
938 (let ((type (elmo-folder-type-internal wl-summary-buffer-elmo-folder))
940 (when (setq handler (cadr (assq type wl-highlight-summary-line-help-echo-alist)))
942 (funcall handler wl-summary-buffer-elmo-folder number))
944 (put-text-property beg end 'help-echo
948 (defun wl-highlight-summary-line-string (number line status temp-mark indent)
949 (let ((fsymbol (car (wl-highlight-summary-line-face-spec
952 (> (length indent) 0)))))
953 (put-text-property 0 (length line) 'face fsymbol line))
954 (when wl-use-highlight-mouse-line
955 (put-text-property 0 (length line) 'mouse-face 'highlight line))
956 (when wl-highlight-summary-line-help-echo-alist
957 (wl-highlight-summary-line-help-echo number 0 (length line) line)))
959 (defun wl-highlight-summary-current-line (&optional number status)
962 (let ((inhibit-read-only t)
963 (case-fold-search nil)
964 (deactivate-mark nil)
965 (number (or number (wl-summary-message-number)))
972 (setq spec (wl-highlight-summary-line-face-spec
973 (or status (wl-summary-message-status number))
974 (wl-summary-temp-mark number)
975 (wl-thread-entity-get-parent-entity
976 (wl-thread-get-entity number))))
978 (put-text-property bol eol 'face (car spec)))
980 (put-text-property (next-single-property-change
981 (next-single-property-change
982 bol 'wl-summary-action-argument
984 'wl-summary-action-argument nil eol)
987 'wl-highlight-action-argument-face))
988 (when wl-use-highlight-mouse-line
989 (put-text-property bol eol 'mouse-face 'highlight))
990 (when wl-highlight-summary-line-help-echo-alist
991 (wl-highlight-summary-line-help-echo number bol eol))
993 (wl-dnd-set-drag-starter bol eol))))))
995 (defun wl-highlight-folder (start end)
996 "Highlight folder between start and end.
998 wl-highlight-folder-unknown-face unread messages
999 wl-highlight-folder-zero-face folder needs no sync
1000 wl-highlight-folder-few-face folder contains few unsync messages
1001 wl-highlight-folder-many-face folder contains many unsync messages
1002 wl-highlight-folder-opened-face opened group folder
1003 wl-highlight-folder-closed-face closed group folder
1006 wl-highlight-folder-opened-regexp matches opened group folder
1007 wl-highlight-folder-closed-regexp matches closed group folder
1011 (let ((s start)) (setq start end end s)))
1012 (let* ((lines (count-lines start end))
1018 (narrow-to-region start end)
1022 (wl-highlight-folder-current-line)
1023 (forward-line 1)))))))
1025 (defun wl-highlight-folder-path (folder-path)
1026 "Highlight current folder path...overlay"
1028 (wl-delete-all-overlays)
1029 (let ((fp folder-path) ov)
1030 (goto-char (point-min))
1034 (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):.*\n")
1035 (looking-at "^[ ]*\\([^ \\[].+\\):.*\n"))
1037 (get-text-property (point) 'wl-folder-entity-id)
1040 (setq ov (make-overlay
1043 (setq wl-folder-buffer-cur-point (point))
1044 (overlay-put ov 'face 'wl-highlight-folder-path-face)
1045 (overlay-put ov 'evaporate t)
1046 (overlay-put ov 'wl-momentary-overlay t))
1047 (forward-line 1)))))
1049 (defun wl-highlight-action-argument-string (string)
1050 (put-text-property 0 (length string) 'face
1051 'wl-highlight-action-argument-face
1054 (defun wl-highlight-summary-all ()
1057 (wl-highlight-summary (point-min)(point-max)))
1059 (defun wl-highlight-summary (start end &optional lazy)
1060 "Highlight summary between start and end.
1062 wl-highlight-summary-unread-face unread messages
1063 wl-highlight-summary-deleted-face messages mark as deleted
1064 wl-highlight-summary-refiled-face messages mark as refiled
1065 wl-highlight-summary-copied-face messages mark as copied
1066 wl-highlight-summary-new-face new messages
1067 wl-highlight-summary-*-flag-face flagged messages"
1069 (let ((s start)) (setq start end end s)))
1070 (let (lines too-big gc-message e p hend i percent)
1072 (unless wl-summary-lazy-highlight
1073 (setq lines (count-lines start end)
1074 too-big (and wl-highlight-max-summary-lines
1075 (> lines wl-highlight-max-summary-lines))))
1078 (while (and (not (eobp))
1080 (when (or (not lazy)
1081 (null (get-text-property (point) 'face)))
1082 (wl-highlight-summary-current-line))
1084 (unless wl-summary-lazy-highlight
1085 (message "Highlighting...done")))))
1087 (defun wl-highlight-summary-window (&optional win beg)
1088 "Highlight summary window.
1089 This function is defined for `window-scroll-functions'"
1090 (when wl-summary-highlight
1091 (with-current-buffer (window-buffer win)
1092 (when (eq major-mode 'wl-summary-mode)
1093 (let ((start (window-start win))
1094 (end (condition-case nil
1095 (window-end win t) ;; old emacsen doesn't support 2nd arg.
1096 (error (window-end win)))))
1097 (wl-highlight-summary start
1100 (set-buffer-modified-p nil)))))
1102 (defun wl-highlight-headers (&optional for-draft)
1103 (let ((beg (point-min))
1104 (end (or (save-excursion (re-search-forward "^$" nil t)
1107 (wl-highlight-message beg end nil)
1109 (when wl-highlight-x-face-function
1110 (funcall wl-highlight-x-face-function)))
1111 (run-hooks 'wl-highlight-headers-hook)))
1113 (defun wl-highlight-body-all ()
1114 (wl-highlight-message (point-min) (point-max) t t))
1116 (defun wl-highlight-body ()
1117 (let ((beg (or (save-excursion (goto-char (point-min))
1118 (re-search-forward "^$" nil t))
1121 (wl-highlight-message beg end t)))
1123 (defun wl-highlight-body-region (beg end)
1124 (wl-highlight-message beg end t t))
1126 (defun wl-highlight-signature-search-simple (beg end)
1127 "Search signature area in the body message between BEG and END.
1128 Returns start point of signature."
1131 (if (re-search-backward "\n--+ *\n" beg t)
1132 (if (eq (char-after (point)) ?\n)
1137 (defun wl-highlight-signature-search (beg end)
1138 "Search signature area in the body message between BEG and END.
1139 Returns start point of signature."
1143 ;; look for legal signature separator (check at first for fasten)
1144 (search-backward "\n-- \n" beg t)
1146 ;; look for dual separator
1150 (and (re-search-backward "^[^A-Za-z0-9> \t\n]+ *$" beg t)
1151 ;; `10' is a magic number.
1152 (> (- (match-end 0) (match-beginning 0)) 10)
1153 (setq separator (buffer-substring (match-beginning 0)
1155 ;; We should not use `re-search-backward' for a long word
1156 ;; since it is possible to crash XEmacs because of a bug.
1157 (if (search-backward (concat "\n" separator "\n") beg t)
1159 (and (search-backward (concat separator "\n") beg t)
1164 ;; look for user specified signature-separator
1165 (if (stringp wl-highlight-signature-separator)
1166 (re-search-backward wl-highlight-signature-separator nil t);; case one string
1167 (let ((sep wl-highlight-signature-separator)) ;; case list
1169 (not (re-search-backward (car sep) beg t)))
1170 (setq sep (cdr sep)))
1171 (point))) ;; if no separator found, returns end.
1174 (defun wl-highlight-message (start end hack-sig &optional body-only)
1175 "Highlight message headers between start and end.
1177 wl-highlight-message-headers the part before the colon
1178 wl-highlight-message-header-contents the part after the colon
1179 wl-highlight-message-important-header-contents contents of \"important\"
1181 wl-highlight-message-important-header-contents2 contents of \"important\"
1183 wl-highlight-message-unimportant-header-contents contents of unimportant
1185 wl-highlight-message-cited-text-N quoted text from other
1187 wl-highlight-message-citation-header header of quoted texts
1188 wl-highlight-message-signature signature
1191 wl-highlight-message-header-alist alist of header regexp with
1192 face for header contents
1193 wl-highlight-citation-prefix-regexp matches lines of quoted text
1194 wl-highlight-force-citation-header-regexp matches headers for quoted text
1195 wl-highlight-citation-header-regexp matches headers for quoted text
1197 If HACK-SIG is true,then we search backward from END for something that
1198 looks like the beginning of a signature block, and don't consider that a
1199 part of the message (this is because signatures are often incorrectly
1200 interpreted as cited text.)"
1202 (let ((s start)) (setq start end end s)))
1203 (let ((too-big (and wl-highlight-max-message-size
1205 wl-highlight-max-message-size)))
1213 ;; take off signature
1214 (if (and hack-sig (not too-big))
1215 (setq end (funcall wl-highlight-signature-search-function
1216 (- end wl-max-signature-size) end)))
1218 (not (eq end real-end)))
1219 (put-text-property end (point-max)
1220 'face 'wl-highlight-message-signature))
1221 (narrow-to-region start end)
1223 ;; narrow down to just the headers...
1225 ;; If this search fails then the narrowing performed above
1227 (if (re-search-forward (format
1229 (regexp-quote mail-header-separator))
1231 (narrow-to-region (point-min) (match-beginning 0)))
1232 ;; highlight only when header is not too-big.
1233 (when (or (null wl-highlight-max-header-size)
1234 (< (point) wl-highlight-max-header-size))
1236 (while (and (not body-only)
1238 (if (looking-at "^[^ \t\n:]+[ \t]*:[ \t]*")
1240 (put-text-property (match-beginning 0) (match-end 0)
1241 'face 'wl-highlight-message-headers)
1242 (setq p (match-end 0))
1243 (setq hend (save-excursion (std11-field-end end)))
1245 (let ((regexp-alist wl-highlight-message-header-alist))
1247 (when (save-match-data
1248 (looking-at (caar regexp-alist)))
1249 (put-text-property p hend 'face
1250 (cdar regexp-alist))
1252 (setq regexp-alist (cdr regexp-alist)))
1253 (throw 'match nil)))
1255 p hend 'face 'wl-highlight-message-header-contents))
1257 ;; ignore non-header field name lines
1258 (forward-line 1)))))
1259 (let (prefix prefix-face-alist pair end)
1262 ((looking-at (concat "^" (regexp-quote mail-header-separator) "$"))
1263 (put-text-property (match-beginning 0) (match-end 0)
1264 'face 'wl-highlight-header-separator-face)
1265 (goto-char (match-end 0)))
1266 ((null wl-highlight-force-citation-header-regexp)
1268 ((looking-at wl-highlight-force-citation-header-regexp)
1269 (setq current 'wl-highlight-message-citation-header)
1270 (setq end (match-end 0)))
1271 ((null wl-highlight-citation-prefix-regexp)
1273 ((looking-at wl-highlight-citation-prefix-regexp)
1274 (setq prefix (buffer-substring (point)
1276 (setq pair (assoc prefix prefix-face-alist))
1278 (setq prefix-face-alist
1279 (append prefix-face-alist
1285 (% (length prefix-face-alist)
1287 wl-highlight-citation-face-list))
1288 wl-highlight-citation-face-list)))))))
1289 (unless wl-highlight-highlight-citation-too
1290 (goto-char (match-end 0)))
1291 (setq current (cdr pair)))
1292 ((null wl-highlight-citation-header-regexp)
1294 ((looking-at wl-highlight-citation-header-regexp)
1295 (setq current 'wl-highlight-message-citation-header)
1296 (setq end (match-end 0)))
1297 (t (setq current nil)))
1300 (forward-line 1) ; this is to put the \n in the face too
1302 ;;; ((inhibit-read-only t))
1303 (put-text-property p (or end (point))
1308 (run-hooks 'wl-highlight-message-hook))))))
1310 ;; highlight-mouse-line for folder mode
1312 (defun wl-highlight-folder-mouse-line ()
1314 (let* ((end (save-excursion (end-of-line) (point)))
1316 (re-search-forward "[^ ]" end t)
1318 (inhibit-read-only t))
1319 (put-text-property beg end 'mouse-face 'highlight)))
1323 (product-provide (provide 'wl-highlight) (require 'wl-version))
1325 ;;; wl-highlight.el ends here