1 ;;; wl-highlight.el -- Hilight modules for Wanderlust.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
32 (if (and (featurep 'xemacs)
36 (provide 'wl-highlight) ; circular dependency
47 (defun-maybe extent-begin-glyph (a))
48 (defun-maybe delete-extent (a))
49 (defun-maybe make-extent (a b))
50 (defun-maybe set-extent-begin-glyph (a b))
51 (defun-maybe set-extent-end-glyph (a b))
52 (defun-maybe extent-at (a b c d e))
53 (defun-maybe wl-dnd-set-drop-target (a b))
54 (defun-maybe wl-dnd-set-drag-starter (a b)))
56 (put 'wl-defface 'lisp-indent-function 'defun)
58 (defgroup wl-faces nil
60 :prefix "wl-highlight-"
64 (defgroup wl-summary-faces nil
65 "Wanderlust, Faces of summary buffer."
66 :prefix "wl-highlight-"
70 (defgroup wl-folder-faces nil
71 "Wanderlust, Faces of folder buffer."
72 :prefix "wl-highlight-"
76 (defgroup wl-message-faces nil
77 "Wanderlust, Faces of message buffer."
78 :prefix "wl-highlight-"
81 ;; for message header and signature
83 (wl-defface wl-highlight-message-headers
90 (:foreground "gray" :bold t))
93 (:foreground "gray50" :bold t)))
94 "Face used for displaying header names."
95 :group 'wl-message-faces
98 (wl-defface wl-highlight-message-header-contents
102 (:foreground "green"))
105 (:foreground "LightSkyBlue" :bold t))
108 (:foreground "purple" :bold t)))
109 "Face used for displaying header content."
110 :group 'wl-message-faces
113 (wl-defface wl-highlight-message-important-header-contents
117 (:foreground "yellow"))
120 (:foreground "yellow" :bold t))
123 (:foreground "brown" :bold t)))
124 "Face used for displaying contents of special headers."
125 :group 'wl-message-faces
128 (wl-defface wl-highlight-message-important-header-contents2
135 (:foreground "orange" :bold t))
138 (:foreground "DarkSlateBlue" :bold t)))
139 "Face used for displaying contents of special headers."
140 :group 'wl-message-faces
143 (wl-defface wl-highlight-message-citation-header
147 (:foreground "cyan"))
150 (:foreground "SkyBlue"))
153 (:foreground "DarkGreen")))
154 "Face used for displaying header of quoted texts."
155 :group 'wl-message-faces
158 (wl-defface wl-highlight-message-unimportant-header-contents
162 (:foreground "green"))
165 (:foreground "GreenYellow" :bold t))
168 (:foreground "DarkGreen" :bold t)))
169 "Face used for displaying contents of unimportant headers."
170 :group 'wl-message-faces
173 (wl-defface wl-highlight-message-signature
176 (:foreground "khaki"))
179 (:foreground "DarkSlateBlue")))
180 "Face used for displaying signature."
181 :group 'wl-message-faces
186 (wl-defface wl-highlight-header-separator-face
190 (:foreground "black" :background "yellow"))
192 (:foreground "Black" :background "DarkKhaki")))
193 "Face used for displaying header separator."
197 ;; important messages
199 (wl-defface wl-highlight-summary-important-face
203 (:foreground "magenta"))
206 (:foreground "orange"))
209 (:foreground "purple")))
210 "Face used for displaying important messages."
211 :group 'wl-summary-faces
214 (wl-defface wl-highlight-summary-new-face
221 (:foreground "tomato"))
224 (:foreground "tomato")))
225 "Face used for displaying new messages."
226 :group 'wl-summary-faces
229 (wl-defface wl-highlight-summary-displaying-face
231 (:underline t :bold t)))
232 "Face used for displaying message."
233 :group 'wl-summary-faces
236 (wl-defface wl-highlight-thread-indent-face
238 (:foreground "gray40")))
239 "Face used for displaying indented thread."
240 :group 'wl-summary-faces
243 ;; unimportant messages
245 (wl-defface wl-highlight-summary-unread-face
249 (:foreground "cyan"))
252 (:foreground "LightSkyBlue"))
255 (:foreground "RoyalBlue")))
256 "Face used for displaying unread messages."
257 :group 'wl-summary-faces
260 (wl-defface wl-highlight-summary-deleted-face
264 (:foreground "blue"))
267 (:foreground "gray"))
270 (:foreground "DarkKhaki")))
271 "Face used for displaying messages mark as deleted."
272 :group 'wl-summary-faces
275 (wl-defface wl-highlight-summary-refiled-face
279 (:foreground "blue"))
282 (:foreground "blue"))
285 (:foreground "firebrick")))
286 "Face used for displaying messages mark as refiled."
287 :group 'wl-summary-faces
290 (wl-defface wl-highlight-summary-copied-face
294 (:foreground "blue"))
297 (:foreground "cyan"))
300 (:foreground "blue")))
301 "Face used for displaying messages mark as copied."
302 :group 'wl-summary-faces
306 (wl-defface wl-highlight-summary-temp-face
310 (:foreground "gold"))
312 (:foreground "HotPink1")))
313 "Face used for displaying messages mark as temp."
314 :group 'wl-summary-faces
317 (wl-defface wl-highlight-summary-target-face
321 (:foreground "gold"))
323 (:foreground "HotPink1")))
324 "Face used for displaying messages mark as target."
325 :group 'wl-summary-faces
328 (wl-defface wl-highlight-summary-low-read-face
332 (:foreground "yellow" :italic t))
335 (:foreground "PaleGreen" :italic t))
338 (:foreground "Green3" :italic t)))
339 "Face used for displaying low interest read messages."
340 :group 'wl-summary-faces
343 (wl-defface wl-highlight-summary-high-read-face
349 (:foreground "PaleGreen" :bold t))
352 (:foreground "SeaGreen" :bold t)))
353 "Face used for displaying high interest read messages."
354 :group 'wl-summary-faces
357 (wl-defface wl-highlight-summary-low-unread-face
361 (:foreground "cyan" :italic t))
364 (:foreground "LightSkyBlue" :italic t))
367 (:foreground "RoyalBlue" :italic t)))
368 "Face used for displaying low interest unread messages."
369 :group 'wl-summary-faces
372 (wl-defface wl-highlight-summary-high-unread-face
375 (:foreground "red" :bold t))
378 (:foreground "tomato" :bold t))
381 (:foreground "tomato" :bold t)))
382 "Face used for displaying high interest unread messages."
383 :group 'wl-summary-faces
388 (wl-defface wl-highlight-summary-thread-top-face
392 (:foreground "green"))
395 (:foreground "GreenYellow"))
398 (:foreground "green4")))
399 "Face used for displaying top thread message."
400 :group 'wl-summary-faces
403 (wl-defface wl-highlight-summary-normal-face
407 (:foreground "yellow"))
410 (:foreground "PaleGreen"))
413 (:foreground "SeaGreen")))
414 "Face used for displaying normal message."
415 :group 'wl-summary-faces
420 (wl-defface wl-highlight-folder-unknown-face
424 (:foreground "cyan"))
427 (:foreground "pink"))
430 (:foreground "RoyalBlue")))
431 "Face used for displaying unread folder."
432 :group 'wl-folder-faces
435 (wl-defface wl-highlight-folder-killed-face
439 (:foreground "gray"))
441 (:foreground "gray50")))
442 "Face used for displaying killed folder."
443 :group 'wl-folder-faces
446 (wl-defface wl-highlight-folder-zero-face
450 (:foreground "green"))
453 (:foreground "SkyBlue"))
456 (:foreground "BlueViolet")))
457 "Face used for displaying folder needs no sync."
458 :group 'wl-folder-faces
461 (wl-defface wl-highlight-folder-few-face
465 (:foreground "yellow"))
468 (:foreground "orange"))
471 (:foreground "OrangeRed3")))
472 "Face used for displaying folder contains few unsync messages."
473 :group 'wl-folder-faces
476 (wl-defface wl-highlight-folder-many-face
483 (:foreground "HotPink1"))
486 (:foreground "tomato")))
487 "Face used for displaying folder contains many unsync messages."
488 :group 'wl-folder-faces
491 (wl-defface wl-highlight-folder-unread-face
495 (:foreground "magenta"))
498 (:foreground "gold"))
501 (:foreground "MediumVioletRed")))
502 "Face used for displaying unread folder."
503 :group 'wl-folder-faces
506 (wl-defface wl-highlight-folder-opened-face
510 (:foreground "blue"))
513 (:foreground "PaleGreen"))
516 (:foreground "ForestGreen")))
517 "Face used for displaying opened group folder."
518 :group 'wl-folder-faces
521 (wl-defface wl-highlight-folder-closed-face
525 (:foreground "cyan"))
528 (:foreground "GreenYellow"))
531 (:foreground "DarkOliveGreen4")))
532 "Face used for displaying closed group folder."
533 :group 'wl-folder-faces
536 (wl-defface wl-highlight-folder-path-face
538 (:bold t :underline t)))
539 "Face used for displaying path."
540 :group 'wl-folder-faces
543 (wl-defface wl-highlight-demo-face
547 (:foreground "green"))
550 (:foreground "GreenYellow"))
553 (:foreground "blue2")))
554 "Face used for displaying demo."
557 (wl-defface wl-highlight-logo-face
561 (:foreground "cyan"))
564 (:foreground "SkyBlue"))
567 (:foreground "SteelBlue")))
568 "Face used for displaying demo."
571 (wl-defface wl-highlight-refile-destination-face
574 (:foreground "pink"))
577 (:foreground "red")))
578 "Face used for displaying refile destination."
579 :group 'wl-summary-faces
584 (wl-defface wl-highlight-message-cited-text-1
588 (:foreground "magenta"))
591 (:foreground "HotPink1"))
594 (:foreground "ForestGreen")))
595 "Face used for displaying quoted text from other messages."
596 :group 'wl-message-faces
599 (wl-defface wl-highlight-message-cited-text-2
603 (:foreground "blue"))
605 (:foreground "violet")))
606 "Face used for displaying quoted text from other messages."
607 :group 'wl-message-faces
610 (wl-defface wl-highlight-message-cited-text-3
614 (:foreground "cyan"))
616 (:foreground "orchid3")))
617 "Face used for displaying quoted text from other messages."
618 :group 'wl-message-faces
621 (wl-defface wl-highlight-message-cited-text-4
625 (:foreground "green"))
627 (:foreground "purple1")))
628 "Face used for displaying quoted text from other messages."
629 :group 'wl-message-faces
632 (wl-defface wl-highlight-message-cited-text-5
636 (:foreground "yellow"))
638 (:foreground "MediumPurple1")))
639 "Face used for displaying quoted text from other messages."
640 :group 'wl-message-faces
643 (wl-defface wl-highlight-message-cited-text-6
649 (:foreground "PaleVioletRed")))
650 "Face used for displaying quoted text from other messages."
651 :group 'wl-message-faces
654 (wl-defface wl-highlight-message-cited-text-7
658 (:foreground "magenta"))
660 (:foreground "LightPink")))
661 "Face used for displaying quoted text from other messages."
662 :group 'wl-message-faces
665 (wl-defface wl-highlight-message-cited-text-8
669 (:foreground "blue"))
671 (:foreground "salmon")))
672 "Face used for displaying quoted text from other messages."
673 :group 'wl-message-faces
676 (wl-defface wl-highlight-message-cited-text-9
680 (:foreground "cyan"))
682 (:foreground "SandyBrown")))
683 "Face used for displaying quoted text from other messages."
684 :group 'wl-message-faces
687 (wl-defface wl-highlight-message-cited-text-10
691 (:foreground "green"))
693 (:foreground "wheat")))
694 "Face used for displaying quoted text from other messages."
695 :group 'wl-message-faces
698 (defvar wl-highlight-folder-opened-regexp " *\\(\\[\\-\\]\\)")
699 (defvar wl-highlight-folder-closed-regexp " *\\(\\[\\+\\]\\)")
700 (defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$")
702 (defvar wl-highlight-summary-unread-regexp " *[0-9]+[^0-9]\\(!\\|U\\)")
703 (defvar wl-highlight-summary-important-regexp " *[0-9]+[^0-9]\\$")
704 (defvar wl-highlight-summary-new-regexp " *[0-9]+[^0-9]N")
705 (defvar wl-highlight-summary-deleted-regexp " *[0-9]+D")
706 (defvar wl-highlight-summary-refiled-regexp " *[0-9]+o")
707 (defvar wl-highlight-summary-copied-regexp " *[0-9]+O")
708 (defvar wl-highlight-summary-target-regexp " *[0-9]+\\*")
709 ;;(defvar wl-highlight-summary-thread-top-regexp " *[0-9]+[^0-9][^0-9]../..\(.*\)..:.. \\[")
711 (defvar wl-highlight-citation-face-list
712 '(wl-highlight-message-cited-text-1
713 wl-highlight-message-cited-text-2
714 wl-highlight-message-cited-text-3
715 wl-highlight-message-cited-text-4
716 wl-highlight-message-cited-text-5
717 wl-highlight-message-cited-text-6
718 wl-highlight-message-cited-text-7
719 wl-highlight-message-cited-text-8
720 wl-highlight-message-cited-text-9
721 wl-highlight-message-cited-text-10))
723 (defmacro defun-hilit (name &rest everything-else)
724 "Define a function for highlight. Nemacs implementation is set as empty."
726 (` (defun (, name) nil nil))
727 (` (defun (, name) (,@ everything-else)))))
729 (defmacro defun-hilit2 (name &rest everything-else)
730 "Define a function for highlight w/o nemacs."
733 (` (defun (, name) (,@ everything-else)))))
735 (defmacro wl-delete-all-overlays ()
736 "Delete all momentary overlays."
739 '(let ((overlays (overlays-in (point-min) (point-max)))
741 (while (setq overlay (car overlays))
742 (if (overlay-get overlay 'wl-momentary-overlay)
743 (delete-overlay overlay))
744 (setq overlays (cdr overlays))))))
746 (defun-hilit wl-highlight-summary-displaying ()
748 (wl-delete-all-overlays)
755 (setq ov (make-overlay bol eol))
756 (overlay-put ov 'face 'wl-highlight-summary-displaying-face)
757 (overlay-put ov 'evaporate t)
758 (overlay-put ov 'wl-momentary-overlay t))))
760 (defun-hilit2 wl-highlight-folder-group-line (numbers)
766 (let ((text-face (cond ((looking-at wl-highlight-folder-opened-regexp)
767 'wl-highlight-folder-opened-face)
768 ((looking-at wl-highlight-folder-closed-regexp)
769 'wl-highlight-folder-closed-face))))
770 (if (and wl-highlight-folder-by-numbers
771 (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" eol t))
772 (let* ((unsync (nth 0 numbers))
773 (unread (nth 1 numbers))
774 (face (cond ((and unsync (zerop unsync))
775 (if (and unread (> unread 0))
776 'wl-highlight-folder-unread-face
777 'wl-highlight-folder-zero-face))
779 (>= unsync wl-folder-many-unsync-threshold))
780 'wl-highlight-folder-many-face)
782 'wl-highlight-folder-few-face))))
783 (if (numberp wl-highlight-folder-by-numbers)
785 (put-text-property bol (match-beginning 0) 'face text-face)
786 (put-text-property (match-beginning 0) (match-end 0)
788 ;; Remove previous face.
789 (put-text-property bol (match-end 0) 'face nil)
790 (put-text-property bol (match-end 0) 'face face)))
791 (put-text-property bol eol 'face text-face)))))
793 (defun-hilit2 wl-highlight-summary-line-string (line mark temp-mark indent)
795 (cond ((and (string= temp-mark "+")
796 (member mark (list wl-summary-unread-cached-mark
797 wl-summary-unread-uncached-mark
798 wl-summary-new-mark)))
799 (setq fsymbol 'wl-highlight-summary-high-unread-face))
800 ((and (string= temp-mark "-")
801 (member mark (list wl-summary-unread-cached-mark
802 wl-summary-unread-uncached-mark
803 wl-summary-new-mark)))
804 (setq fsymbol 'wl-highlight-summary-low-unread-face))
805 ((string= temp-mark "o")
806 (setq fsymbol 'wl-highlight-summary-refiled-face))
807 ((string= temp-mark "O")
808 (setq fsymbol 'wl-highlight-summary-copied-face))
809 ((string= temp-mark "D")
810 (setq fsymbol 'wl-highlight-summary-deleted-face))
811 ((string= temp-mark "*")
812 (setq fsymbol 'wl-highlight-summary-temp-face))
813 ((string= mark wl-summary-new-mark)
814 (setq fsymbol 'wl-highlight-summary-new-face))
815 ((member mark (list wl-summary-unread-cached-mark
816 wl-summary-unread-uncached-mark))
817 (setq fsymbol 'wl-highlight-summary-unread-face))
818 ((or (string= mark wl-summary-important-mark))
819 (setq fsymbol 'wl-highlight-summary-important-face))
820 ((string= temp-mark "-")
821 (setq fsymbol 'wl-highlight-summary-low-read-face))
822 ((string= temp-mark "+")
823 (setq fsymbol 'wl-highlight-summary-high-read-face))
824 (t (if (zerop (length indent))
825 (setq fsymbol 'wl-highlight-summary-thread-top-face)
826 (setq fsymbol 'wl-highlight-summary-normal-face))))
827 (put-text-property 0 (length line) 'face fsymbol line))
828 (if wl-use-highlight-mouse-line
829 (put-text-property 0 (length line) 'mouse-face 'highlight line)))
831 (defun-hilit2 wl-highlight-summary-current-line (&optional smark regexp temp-too)
834 (let ((inhibit-read-only t)
835 (case-fold-search nil) temp-mark status-mark
838 wl-summary-buffer-number-regexp
839 "\\(.\\)\\(.\\)../..\(.*\)..:.. \\("
840 wl-highlight-thread-indent-string-regexp
842 fregexp fsymbol bol eol matched thread-top looked-at)
848 (setq status-mark smark)
849 (setq looked-at (looking-at sregexp))
851 (setq status-mark (buffer-substring (match-beginning 2)
855 (setq looked-at (looking-at sregexp)))
857 (setq temp-mark (buffer-substring (match-beginning 1)
860 ((string= temp-mark "*")
861 (setq fsymbol 'wl-highlight-summary-temp-face))
862 ((string= temp-mark "D")
863 (setq fsymbol 'wl-highlight-summary-deleted-face))
864 ((string= temp-mark "O")
865 (setq fsymbol 'wl-highlight-summary-copied-face))
866 ((string= temp-mark "o")
867 (setq fsymbol 'wl-highlight-summary-refiled-face)))))
870 ((and (string= temp-mark "+")
871 (member status-mark (list wl-summary-unread-cached-mark
872 wl-summary-unread-uncached-mark
873 wl-summary-new-mark)))
874 (setq fsymbol 'wl-highlight-summary-high-unread-face))
875 ((and (string= temp-mark "-")
876 (member status-mark (list wl-summary-unread-cached-mark
877 wl-summary-unread-uncached-mark
878 wl-summary-new-mark)))
879 (setq fsymbol 'wl-highlight-summary-low-unread-face))
880 ((string= status-mark wl-summary-new-mark)
881 (setq fsymbol 'wl-highlight-summary-new-face))
882 ((member status-mark (list wl-summary-unread-cached-mark
883 wl-summary-unread-uncached-mark))
884 (setq fsymbol 'wl-highlight-summary-unread-face))
885 ((string= status-mark wl-summary-important-mark)
886 (setq fsymbol 'wl-highlight-summary-important-face))
888 ((string= temp-mark "-")
889 (setq fsymbol 'wl-highlight-summary-low-read-face))
890 ((string= temp-mark "+")
891 (setq fsymbol 'wl-highlight-summary-high-read-face))
893 (t (if (and looked-at
894 (string= (buffer-substring
897 (setq fsymbol 'wl-highlight-summary-thread-top-face)
898 (setq fsymbol 'wl-highlight-summary-normal-face)))))
899 (put-text-property bol eol 'face fsymbol)
900 (if wl-use-highlight-mouse-line
901 (put-text-property bol
902 ;;; Use bol instead of (1- (match-end 0))
903 ;;; (1- (match-end 0))
904 eol 'mouse-face 'highlight))
905 ;;; (put-text-property (match-beginning 3) (match-end 3)
906 ;;; 'face 'wl-highlight-thread-indent-face)
909 (wl-dnd-set-drag-starter bol eol)))))
911 (defun-hilit2 wl-highlight-folder (start end)
912 "Highlight folder between start and end.
914 wl-highlight-folder-unknown-face unread messages
915 wl-highlight-folder-zero-face folder needs no sync
916 wl-highlight-folder-few-face folder contains few unsync messages
917 wl-highlight-folder-many-face folder contains many unsync messages
918 wl-highlight-folder-opened-face opened group folder
919 wl-highlight-folder-closed-face closed group folder
922 wl-highlight-folder-opened-regexp matches opened group folder
923 wl-highlight-folder-closed-regexp matches closed group folder
927 (let ((s start)) (setq start end end s)))
928 (let* ((lines (count-lines start end))
934 (narrow-to-region start end)
938 (wl-highlight-folder-current-line)
939 (forward-line 1)))))))
941 (defun-hilit2 wl-highlight-folder-path (folder-path)
942 "Highlight current folder path...overlay"
944 (wl-delete-all-overlays)
945 (let ((fp folder-path) ov)
946 (goto-char (point-min))
950 (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):.*\n")
951 (looking-at "^[ ]*\\([^ \\[].+\\):.*\n"))
953 (get-text-property (point) 'wl-folder-entity-id)
956 (setq ov (make-overlay
959 (setq wl-folder-buffer-cur-point (point))
960 (overlay-put ov 'face 'wl-highlight-folder-path-face)
961 (overlay-put ov 'evaporate t)
962 (overlay-put ov 'wl-momentary-overlay t))
965 (defun-hilit2 wl-highlight-refile-destination-string (string)
966 (put-text-property 0 (length string) 'face
967 'wl-highlight-refile-destination-face
970 (defun-hilit wl-highlight-summary-all ()
973 (wl-highlight-summary (point-min)(point-max)))
975 (defun-hilit2 wl-highlight-summary (start end)
976 "Highlight summary between start and end.
978 wl-highlight-summary-unread-face unread messages
979 wl-highlight-summary-important-face important messages
980 wl-highlight-summary-deleted-face messages mark as deleted
981 wl-highlight-summary-refiled-face messages mark as refiled
982 wl-highlight-summary-copied-face messages mark as copied
983 wl-highlight-summary-new-face new messages
986 wl-highlight-summary-unread-regexp matches unread messages
987 wl-highlight-summary-important-regexp matches important messages
988 wl-highlight-summary-deleted-regexp matches messages mark as deleted
989 wl-highlight-summary-refiled-regexp matches messages mark as refiled
990 wl-highlight-summary-copied-regexp matches messages mark as copied
991 wl-highlight-summary-new-regexp matches new messages
994 (let ((s start)) (setq start end end s)))
995 (let (lines too-big gc-message e p hend i percent)
998 (unless wl-summary-lazy-highlight
999 (setq lines (count-lines start end)
1000 too-big (and wl-highlight-max-summary-lines
1001 (> lines wl-highlight-max-summary-lines))))
1004 (while (and (not (eobp))
1006 (wl-highlight-summary-current-line nil nil
1007 (or wl-summary-lazy-highlight
1009 (when (and (not wl-summary-lazy-highlight)
1010 (> lines elmo-display-progress-threshold))
1012 (setq percent (/ (* i 100) lines))
1013 (if (or (zerop (% percent 5)) (= i lines))
1014 (elmo-display-progress
1015 'wl-highlight-summary "Highlighting..."
1018 (unless wl-summary-lazy-highlight
1019 (message "Highlighting...done"))))))
1021 (defun wl-highlight-summary-window (&optional win beg)
1022 "Highlight summary window.
1023 This function is defined for `window-scroll-functions'"
1024 (if wl-summary-highlight
1025 (with-current-buffer (window-buffer win)
1026 (wl-highlight-summary (window-start win)
1028 (goto-char (window-start win))
1029 (forward-line (frame-height))
1031 (set-buffer-modified-p nil))))
1033 (defun wl-highlight-headers (&optional for-draft)
1034 (let ((beg (point-min))
1035 (end (or (save-excursion (re-search-forward "^$" nil t)
1038 (wl-highlight-message beg end nil)
1040 (wl-highlight-message-add-buttons-to-header beg end)
1041 (when wl-highlight-x-face-func
1042 (funcall wl-highlight-x-face-func beg end)))
1043 (run-hooks 'wl-highlight-headers-hook)))
1045 (defun wl-highlight-message-add-buttons-to-header (start end)
1048 (narrow-to-region start end)
1049 (let ((case-fold-search t)
1050 (alist wl-highlight-message-header-button-alist)
1053 (setq entry (car alist)
1055 (goto-char (point-min))
1056 (while (re-search-forward (car entry) nil t)
1057 (setq start (match-beginning 0)
1058 end (if (re-search-forward "^[^ \t]" nil t)
1062 (while (re-search-forward (nth 1 entry) end t)
1063 (goto-char (match-end 0))
1064 (wl-message-add-button
1065 (match-beginning (nth 2 entry))
1066 (match-end (nth 2 entry))
1067 (nth 3 entry) (match-string (nth 4 entry))))
1068 (goto-char end)))))))
1070 (defun wl-highlight-body-all ()
1071 (wl-highlight-message (point-min) (point-max) t t))
1073 (defun-hilit wl-highlight-body ()
1074 (let ((beg (or (save-excursion (goto-char (point-min))
1075 (re-search-forward "^$" nil t))
1078 (wl-highlight-message beg end t)))
1080 (defun-hilit2 wl-highlight-body-region (beg end)
1081 (wl-highlight-message beg end t t))
1083 (defun wl-highlight-signature-search-simple (beg end)
1084 "Search signature area in the body message between BEG and END.
1085 Returns start point of signature."
1088 (if (re-search-backward "\n--+ *\n" beg t)
1089 (if (eq (char-after (point)) ?\n)
1094 (defun wl-highlight-signature-search (beg end)
1095 "Search signature area in the body message between BEG and END.
1096 Returns start point of signature."
1100 ;; look for legal signature separator (check at first for fasten)
1101 (re-search-backward "\n-- \n" beg t)
1103 ;; look for dual separator
1106 (re-search-backward "^[^A-Za-z0-9> \t\n]+ *$" beg t)
1107 (> (- (match-end 0) (match-beginning 0)) 10);; "10" is a magic number.
1110 (regexp-quote (buffer-substring (match-beginning 0) (match-end 0)))
1113 ;; look for user specified signature-separator
1114 (if (stringp wl-highlight-signature-separator)
1115 (re-search-backward wl-highlight-signature-separator nil t);; case one string
1116 (let ((sep wl-highlight-signature-separator)) ;; case list
1118 (not (re-search-backward (car sep) beg t)))
1119 (setq sep (cdr sep)))
1120 (point))) ;; if no separator found, returns end.
1123 (defun-hilit2 wl-highlight-message (start end hack-sig &optional body-only)
1124 "Highlight message headers between start and end.
1126 wl-highlight-message-headers the part before the colon
1127 wl-highlight-message-header-contents the part after the colon
1128 wl-highlight-message-important-header-contents contents of \"special\"
1130 wl-highlight-message-important-header-contents2 contents of \"special\"
1132 wl-highlight-message-unimportant-header-contents contents of unimportant
1134 wl-highlight-message-cited-text quoted text from other
1136 wl-highlight-message-citation-header header of quoted texts
1137 wl-highlight-message-signature signature
1140 wl-highlight-important-header-regexp what makes a \"special\" header
1141 wl-highlight-important-header2-regexp what makes a \"special\" header
1142 wl-highlight-unimportant-header-regexp what makes a \"special\" header
1143 wl-highlight-citation-prefix-regexp matches lines of quoted text
1144 wl-highlight-citation-header-regexp matches headers for quoted text
1146 If HACK-SIG is true,then we search backward from END for something that
1147 looks like the beginning of a signature block, and don't consider that a
1148 part of the message (this is because signatures are often incorrectly
1149 interpreted as cited text.)"
1151 (let ((s start)) (setq start end end s)))
1152 (let ((too-big (and wl-highlight-max-message-size
1154 wl-highlight-max-message-size)))
1163 ;; take off signature
1164 (if (and hack-sig (not too-big))
1165 (setq end (funcall wl-highlight-signature-search-func
1166 (- end wl-max-signature-size) end)))
1168 (put-text-property end (point-max)
1169 'face 'wl-highlight-message-signature))
1170 (narrow-to-region start end)
1172 ;; narrow down to just the headers...
1174 ;; If this search fails then the narrowing performed above
1176 (if (re-search-forward (format
1178 (regexp-quote mail-header-separator))
1180 (narrow-to-region (point-min) (match-beginning 0)))
1181 ;; highlight only when header is not too-big.
1182 (when (or (null wl-highlight-max-header-size)
1183 (< (point) wl-highlight-max-header-size))
1185 (while (and (not body-only)
1188 ((looking-at "^[^ \t\n:]+[ \t]*:")
1189 (put-text-property (match-beginning 0) (match-end 0)
1190 'face 'wl-highlight-message-headers)
1191 (setq p (match-end 0))
1192 (setq hend (save-excursion (std11-field-end end)))
1195 (let ((regexp-alist wl-highlight-message-header-alist))
1197 (when (save-match-data
1198 (looking-at (caar regexp-alist)))
1199 (put-text-property p hend 'face
1200 (cdar regexp-alist))
1202 (setq regexp-alist (cdr regexp-alist)))
1203 (throw 'match nil))))
1206 p hend 'face 'wl-highlight-message-header-contents)))
1208 ;; ignore non-header field name lines
1209 (t (forward-line 1))))))
1210 (let (prefix prefix-face-alist pair end)
1213 ((looking-at mail-header-separator)
1214 (put-text-property (match-beginning 0) (match-end 0)
1215 'face 'wl-highlight-header-separator-face)
1216 (goto-char (match-end 0)))
1217 ((null wl-highlight-force-citation-header-regexp)
1219 ((looking-at wl-highlight-force-citation-header-regexp)
1220 (setq current 'wl-highlight-message-citation-header)
1221 (setq end (match-end 0)))
1222 ((null wl-highlight-citation-prefix-regexp)
1224 ((looking-at wl-highlight-citation-prefix-regexp)
1225 (setq prefix (buffer-substring (point)
1227 (setq pair (assoc prefix prefix-face-alist))
1229 (setq prefix-face-alist
1230 (append prefix-face-alist
1236 (% (length prefix-face-alist)
1238 wl-highlight-citation-face-list))
1239 wl-highlight-citation-face-list)))))))
1240 (unless wl-highlight-highlight-citation-too
1241 (goto-char (match-end 0)))
1242 (setq current (cdr pair)))
1243 ((null wl-highlight-citation-header-regexp)
1245 ((looking-at wl-highlight-citation-header-regexp)
1246 (setq current 'wl-highlight-message-citation-header)
1247 (setq end (match-end 0)))
1248 (t (setq current nil)))
1251 (forward-line 1) ; this is to put the \n in the face too
1253 ;;; ((inhibit-read-only t))
1254 (put-text-property p (or end (point))
1259 (run-hooks 'wl-highlight-message-hook))))))
1261 ;; highlight-mouse-line for folder mode
1263 (defun wl-highlight-folder-mouse-line ()
1265 (let* ((end (save-excursion (end-of-line) (point)))
1267 (re-search-forward "[^ ]" end t)
1269 (inhibit-read-only t))
1270 (put-text-property beg end 'mouse-face 'highlight)))
1273 (product-provide (provide 'wl-highlight) (require 'wl-version))
1275 ;;; wl-highlight.el ends here