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