1 ;;; wl-highlight.el -- Hilight modules for Wanderlust.
3 ;; Copyright 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)
37 (product-provide (provide 'wl-highlight) (require 'wl-version))
48 (defun-maybe extent-begin-glyph (a))
49 (defun-maybe delete-extent (a))
50 (defun-maybe make-extent (a b))
51 (defun-maybe set-extent-begin-glyph (a b))
52 (defun-maybe set-extent-end-glyph (a b))
53 (defun-maybe extent-at (a b c d e))
54 (defun-maybe wl-dnd-set-drop-target (a b))
55 (defun-maybe wl-dnd-set-drag-starter (a b)))
57 (put 'wl-defface 'lisp-indent-function 'defun)
59 (defgroup wl-faces nil
61 :prefix "wl-highlight-"
65 (defgroup wl-summary-faces nil
66 "Wanderlust, Faces of summary buffer."
67 :prefix "wl-highlight-"
71 (defgroup wl-folder-faces nil
72 "Wanderlust, Faces of folder buffer."
73 :prefix "wl-highlight-"
77 (defgroup wl-message-faces nil
78 "Wanderlust, Faces of message buffer."
79 :prefix "wl-highlight-"
82 ;; for message header and signature
84 (wl-defface wl-highlight-message-headers
91 (:foreground "gray" :bold t))
94 (:foreground "gray50" :bold t)))
95 "Face used for displaying header names."
96 :group 'wl-message-faces
99 (wl-defface wl-highlight-message-header-contents
103 (:foreground "green"))
106 (:foreground "LightSkyBlue" :bold t))
109 (:foreground "purple" :bold t)))
110 "Face used for displaying header content."
111 :group 'wl-message-faces
114 (wl-defface wl-highlight-message-important-header-contents
118 (:foreground "yellow"))
121 (:foreground "yellow" :bold t))
124 (:foreground "brown" :bold t)))
125 "Face used for displaying contents of special headers."
126 :group 'wl-message-faces
129 (wl-defface wl-highlight-message-important-header-contents2
136 (:foreground "orange" :bold t))
139 (:foreground "DarkSlateBlue" :bold t)))
140 "Face used for displaying contents of special headers."
141 :group 'wl-message-faces
144 (wl-defface wl-highlight-message-citation-header
148 (:foreground "cyan"))
151 (:foreground "SkyBlue"))
154 (:foreground "DarkGreen")))
155 "Face used for displaying header of quoted texts."
156 :group 'wl-message-faces
159 (wl-defface wl-highlight-message-unimportant-header-contents
163 (:foreground "green"))
166 (:foreground "GreenYellow" :bold t))
169 (:foreground "DarkGreen" :bold t)))
170 "Face used for displaying contents of unimportant headers."
171 :group 'wl-message-faces
174 (wl-defface wl-highlight-message-signature
177 (:foreground "khaki"))
180 (:foreground "DarkSlateBlue")))
181 "Face used for displaying signature."
182 :group 'wl-message-faces
187 (wl-defface wl-highlight-header-separator-face
191 (:foreground "black" :background "yellow"))
193 (:foreground "Black" :background "DarkKhaki")))
194 "Face used for displaying header separator."
198 ;; important messages
200 (wl-defface wl-highlight-summary-important-face
204 (:foreground "magenta"))
207 (:foreground "orange"))
210 (:foreground "purple")))
211 "Face used for displaying important messages."
212 :group 'wl-summary-faces
215 (wl-defface wl-highlight-summary-new-face
222 (:foreground "tomato"))
225 (:foreground "tomato")))
226 "Face used for displaying new messages."
227 :group 'wl-summary-faces
230 (wl-defface wl-highlight-summary-displaying-face
232 (:underline t :bold t)))
233 "Face used for displaying message."
234 :group 'wl-summary-faces
237 (wl-defface wl-highlight-thread-indent-face
239 (:foreground "gray40")))
240 "Face used for displaying indented thread."
241 :group 'wl-summary-faces
244 ;; unimportant messages
246 (wl-defface wl-highlight-summary-unread-face
250 (:foreground "cyan"))
253 (:foreground "LightSkyBlue"))
256 (:foreground "RoyalBlue")))
257 "Face used for displaying unread messages."
258 :group 'wl-summary-faces
261 (wl-defface wl-highlight-summary-deleted-face
265 (:foreground "blue"))
268 (:foreground "gray"))
271 (:foreground "DarkKhaki")))
272 "Face used for displaying messages mark as deleted."
273 :group 'wl-summary-faces
276 (wl-defface wl-highlight-summary-refiled-face
280 (:foreground "blue"))
283 (:foreground "blue"))
286 (:foreground "firebrick")))
287 "Face used for displaying messages mark as refiled."
288 :group 'wl-summary-faces
291 (wl-defface wl-highlight-summary-copied-face
295 (:foreground "blue"))
298 (:foreground "cyan"))
301 (:foreground "blue")))
302 "Face used for displaying messages mark as copied."
303 :group 'wl-summary-faces
307 (wl-defface wl-highlight-summary-temp-face
311 (:foreground "gold"))
313 (:foreground "HotPink1")))
314 "Face used for displaying messages mark as temp."
315 :group 'wl-summary-faces
318 (wl-defface wl-highlight-summary-target-face
322 (:foreground "gold"))
324 (:foreground "HotPink1")))
325 "Face used for displaying messages mark as target."
326 :group 'wl-summary-faces
329 (wl-defface wl-highlight-summary-low-read-face
333 (:foreground "yellow" :italic t))
336 (:foreground "PaleGreen" :italic t))
339 (:foreground "Green3" :italic t)))
340 "Face used for displaying low interest read messages."
341 :group 'wl-summary-faces
344 (wl-defface wl-highlight-summary-high-read-face
350 (:foreground "PaleGreen" :bold t))
353 (:foreground "SeaGreen" :bold t)))
354 "Face used for displaying high interest read messages."
355 :group 'wl-summary-faces
358 (wl-defface wl-highlight-summary-low-unread-face
362 (:foreground "cyan" :italic t))
365 (:foreground "LightSkyBlue" :italic t))
368 (:foreground "RoyalBlue" :italic t)))
369 "Face used for displaying low interest unread messages."
370 :group 'wl-summary-faces
373 (wl-defface wl-highlight-summary-high-unread-face
376 (:foreground "red" :bold t))
379 (:foreground "tomato" :bold t))
382 (:foreground "tomato" :bold t)))
383 "Face used for displaying high interest unread messages."
384 :group 'wl-summary-faces
389 (wl-defface wl-highlight-summary-thread-top-face
393 (:foreground "green"))
396 (:foreground "GreenYellow"))
399 (:foreground "green4")))
400 "Face used for displaying top thread message."
401 :group 'wl-summary-faces
404 (wl-defface wl-highlight-summary-normal-face
408 (:foreground "yellow"))
411 (:foreground "PaleGreen"))
414 (:foreground "SeaGreen")))
415 "Face used for displaying normal message."
416 :group 'wl-summary-faces
421 (wl-defface wl-highlight-folder-unknown-face
425 (:foreground "cyan"))
428 (:foreground "pink"))
431 (:foreground "RoyalBlue")))
432 "Face used for displaying unread folder."
433 :group 'wl-folder-faces
436 (wl-defface wl-highlight-folder-killed-face
440 (:foreground "gray"))
442 (:foreground "gray50")))
443 "Face used for displaying killed folder."
444 :group 'wl-folder-faces
447 (wl-defface wl-highlight-folder-zero-face
451 (:foreground "green"))
454 (:foreground "SkyBlue"))
457 (:foreground "BlueViolet")))
458 "Face used for displaying folder needs no sync."
459 :group 'wl-folder-faces
462 (wl-defface wl-highlight-folder-few-face
466 (:foreground "yellow"))
469 (:foreground "orange"))
472 (:foreground "OrangeRed3")))
473 "Face used for displaying folder contains few unsync messages."
474 :group 'wl-folder-faces
477 (wl-defface wl-highlight-folder-many-face
484 (:foreground "HotPink1"))
487 (:foreground "tomato")))
488 "Face used for displaying folder contains many unsync messages."
489 :group 'wl-folder-faces
492 (wl-defface wl-highlight-folder-unread-face
496 (:foreground "magenta"))
499 (:foreground "gold"))
502 (:foreground "MediumVioletRed")))
503 "Face used for displaying unread folder."
504 :group 'wl-folder-faces
507 (wl-defface wl-highlight-folder-opened-face
511 (:foreground "blue"))
514 (:foreground "PaleGreen"))
517 (:foreground "ForestGreen")))
518 "Face used for displaying opened group folder."
519 :group 'wl-folder-faces
522 (wl-defface wl-highlight-folder-closed-face
526 (:foreground "cyan"))
529 (:foreground "GreenYellow"))
532 (:foreground "DarkOliveGreen4")))
533 "Face used for displaying closed group folder."
534 :group 'wl-folder-faces
537 (wl-defface wl-highlight-folder-path-face
539 (:bold t :underline t)))
540 "Face used for displaying path."
541 :group 'wl-folder-faces
544 (wl-defface wl-highlight-demo-face
548 (:foreground "green"))
551 (:foreground "GreenYellow"))
554 (:foreground "blue2")))
555 "Face used for displaying demo."
558 (wl-defface wl-highlight-logo-face
562 (:foreground "cyan"))
565 (:foreground "SkyBlue"))
568 (:foreground "SteelBlue")))
569 "Face used for displaying demo."
572 (wl-defface wl-highlight-refile-destination-face
575 (:foreground "pink"))
578 (:foreground "red")))
579 "Face used for displaying refile destination."
580 :group 'wl-summary-faces
585 (wl-defface wl-highlight-message-cited-text-1
589 (:foreground "magenta"))
592 (:foreground "HotPink1"))
595 (:foreground "ForestGreen")))
596 "Face used for displaying quoted text from other messages."
597 :group 'wl-message-faces
600 (wl-defface wl-highlight-message-cited-text-2
604 (:foreground "blue"))
606 (:foreground "violet")))
607 "Face used for displaying quoted text from other messages."
608 :group 'wl-message-faces
611 (wl-defface wl-highlight-message-cited-text-3
615 (:foreground "cyan"))
617 (:foreground "orchid3")))
618 "Face used for displaying quoted text from other messages."
619 :group 'wl-message-faces
622 (wl-defface wl-highlight-message-cited-text-4
626 (:foreground "green"))
628 (:foreground "purple1")))
629 "Face used for displaying quoted text from other messages."
630 :group 'wl-message-faces
633 (wl-defface wl-highlight-message-cited-text-5
637 (:foreground "yellow"))
639 (:foreground "MediumPurple1")))
640 "Face used for displaying quoted text from other messages."
641 :group 'wl-message-faces
644 (wl-defface wl-highlight-message-cited-text-6
650 (:foreground "PaleVioletRed")))
651 "Face used for displaying quoted text from other messages."
652 :group 'wl-message-faces
655 (wl-defface wl-highlight-message-cited-text-7
659 (:foreground "magenta"))
661 (:foreground "LightPink")))
662 "Face used for displaying quoted text from other messages."
663 :group 'wl-message-faces
666 (wl-defface wl-highlight-message-cited-text-8
670 (:foreground "blue"))
672 (:foreground "salmon")))
673 "Face used for displaying quoted text from other messages."
674 :group 'wl-message-faces
677 (wl-defface wl-highlight-message-cited-text-9
681 (:foreground "cyan"))
683 (:foreground "SandyBrown")))
684 "Face used for displaying quoted text from other messages."
685 :group 'wl-message-faces
688 (wl-defface wl-highlight-message-cited-text-10
692 (:foreground "green"))
694 (:foreground "wheat")))
695 "Face used for displaying quoted text from other messages."
696 :group 'wl-message-faces
699 (defvar wl-highlight-folder-opened-regexp " *\\(\\[\\-\\]\\)")
700 (defvar wl-highlight-folder-closed-regexp " *\\(\\[\\+\\]\\)")
701 (defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$")
703 (defvar wl-highlight-summary-unread-regexp " *[0-9]+[^0-9]\\(!\\|U\\)")
704 (defvar wl-highlight-summary-important-regexp " *[0-9]+[^0-9]\\$")
705 (defvar wl-highlight-summary-new-regexp " *[0-9]+[^0-9]N")
706 (defvar wl-highlight-summary-deleted-regexp " *[0-9]+D")
707 (defvar wl-highlight-summary-refiled-regexp " *[0-9]+o")
708 (defvar wl-highlight-summary-copied-regexp " *[0-9]+O")
709 (defvar wl-highlight-summary-target-regexp " *[0-9]+\\*")
710 ;(defvar wl-highlight-summary-thread-top-regexp " *[0-9]+[^0-9][^0-9]../..\(.*\)..:.. \\[")
712 (defvar wl-highlight-citation-face-list
713 '(wl-highlight-message-cited-text-1
714 wl-highlight-message-cited-text-2
715 wl-highlight-message-cited-text-3
716 wl-highlight-message-cited-text-4
717 wl-highlight-message-cited-text-5
718 wl-highlight-message-cited-text-6
719 wl-highlight-message-cited-text-7
720 wl-highlight-message-cited-text-8
721 wl-highlight-message-cited-text-9
722 wl-highlight-message-cited-text-10))
724 (defmacro defun-hilit (name &rest everything-else)
725 "Define a function for highlight. Nemacs implementation is set as empty."
727 (` (defun (, name) nil nil))
728 (` (defun (, name) (,@ everything-else)))))
730 (defmacro defun-hilit2 (name &rest everything-else)
731 "Define a function for highlight w/o nemacs."
734 (` (defun (, name) (,@ everything-else)))))
736 (defmacro wl-delete-all-overlays ()
737 "Delete all momentary overlays."
740 '(let ((overlays (overlays-in (point-min) (point-max)))
742 (while (setq overlay (car overlays))
743 (if (overlay-get overlay 'wl-momentary-overlay)
744 (delete-overlay overlay))
745 (setq overlays (cdr overlays))))))
747 (defun-hilit wl-highlight-summary-displaying ()
749 (wl-delete-all-overlays)
754 (save-excursion (end-of-line) (setq eol (point)))
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 (= 0 (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)
845 (save-excursion (end-of-line) (setq eol (point)))
847 (setq status-mark smark)
848 (setq looked-at (looking-at sregexp))
849 (setq status-mark (buffer-substring (match-beginning 2)
853 (setq looked-at (looking-at sregexp)))
855 (setq temp-mark (buffer-substring (match-beginning 1)
858 ((string= temp-mark "*")
859 (setq fsymbol 'wl-highlight-summary-temp-face))
860 ((string= temp-mark "D")
861 (setq fsymbol 'wl-highlight-summary-deleted-face))
862 ((string= temp-mark "O")
863 (setq fsymbol 'wl-highlight-summary-copied-face))
864 ((string= temp-mark "o")
865 (setq fsymbol 'wl-highlight-summary-refiled-face)))))
868 ((and (string= temp-mark "+")
869 (member status-mark (list wl-summary-unread-cached-mark
870 wl-summary-unread-uncached-mark
871 wl-summary-new-mark)))
872 (setq fsymbol 'wl-highlight-summary-high-unread-face))
873 ((and (string= temp-mark "-")
874 (member status-mark (list wl-summary-unread-cached-mark
875 wl-summary-unread-uncached-mark
876 wl-summary-new-mark)))
877 (setq fsymbol 'wl-highlight-summary-low-unread-face))
878 ((string= status-mark wl-summary-new-mark)
879 (setq fsymbol 'wl-highlight-summary-new-face))
880 ((member status-mark (list wl-summary-unread-cached-mark
881 wl-summary-unread-uncached-mark))
882 (setq fsymbol 'wl-highlight-summary-unread-face))
883 ((string= status-mark wl-summary-important-mark)
884 (setq fsymbol 'wl-highlight-summary-important-face))
886 ((string= temp-mark "-")
887 (setq fsymbol 'wl-highlight-summary-low-read-face))
888 ((string= temp-mark "+")
889 (setq fsymbol 'wl-highlight-summary-high-read-face))
891 (t (if (and looked-at
892 (string= (buffer-substring
895 (setq fsymbol 'wl-highlight-summary-thread-top-face)
896 (setq fsymbol 'wl-highlight-summary-normal-face)))))
897 (put-text-property bol eol 'face fsymbol)
898 (if wl-use-highlight-mouse-line
899 (put-text-property bol;(1- (match-end 0))
900 eol 'mouse-face 'highlight))
901 ; (put-text-property (match-beginning 3) (match-end 3)
902 ; 'face 'wl-highlight-thread-indent-face)
905 (wl-dnd-set-drag-starter bol eol)))))
907 (defun-hilit2 wl-highlight-folder (start end)
908 "Highlight folder between start and end.
910 wl-highlight-folder-unknown-face unread messages
911 wl-highlight-folder-zero-face folder needs no sync
912 wl-highlight-folder-few-face folder contains few unsync messages
913 wl-highlight-folder-many-face folder contains many unsync messages
914 wl-highlight-folder-opened-face opened group folder
915 wl-highlight-folder-closed-face closed group folder
918 wl-highlight-folder-opened-regexp matches opened group folder
919 wl-highlight-folder-closed-regexp matches closed group folder
923 (let ((s start)) (setq start end end s)))
924 (let* ((lines (count-lines start end))
930 (narrow-to-region start end)
934 (wl-highlight-folder-current-line)
935 (forward-line 1)))))))
937 (defun-hilit2 wl-highlight-folder-path (folder-path)
938 "Highlight current folder path...overlay"
940 (wl-delete-all-overlays)
941 (let ((fp folder-path) ov)
942 (goto-char (point-min))
946 (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):.*\n")
947 (looking-at "^[ ]*\\([^ \\[].+\\):.*\n"))
949 (get-text-property (point) 'wl-folder-entity-id)
952 (setq ov (make-overlay
955 (setq wl-folder-buffer-cur-point (point))
956 (overlay-put ov 'face 'wl-highlight-folder-path-face)
957 (overlay-put ov 'evaporate t)
958 (overlay-put ov 'wl-momentary-overlay t))
961 (defun-hilit2 wl-highlight-refile-destination-string (string)
962 (put-text-property 0 (length string) 'face
963 'wl-highlight-refile-destination-face
966 (defun-hilit wl-highlight-summary-all ()
969 (wl-highlight-summary (point-min)(point-max)))
971 (defun-hilit2 wl-highlight-summary (start end)
972 "Highlight summary between start and end.
974 wl-highlight-summary-unread-face unread messages
975 wl-highlight-summary-important-face important messages
976 wl-highlight-summary-deleted-face messages mark as deleted
977 wl-highlight-summary-refiled-face messages mark as refiled
978 wl-highlight-summary-copied-face messages mark as copied
979 wl-highlight-summary-new-face new messages
982 wl-highlight-summary-unread-regexp matches unread messages
983 wl-highlight-summary-important-regexp matches important messages
984 wl-highlight-summary-deleted-regexp matches messages mark as deleted
985 wl-highlight-summary-refiled-regexp matches messages mark as refiled
986 wl-highlight-summary-copied-regexp matches messages mark as copied
987 wl-highlight-summary-new-regexp matches new messages
989 If HACK-SIG is true,then we search backward from END for something that
990 looks like the beginning of a signature block, and don't consider that a
991 part of the message (this is because signatures are often incorrectly
992 interpreted as cited text.)"
994 (let ((s start)) (setq start end end s)))
995 (let* ((lines (count-lines start end))
996 (too-big (and wl-highlight-max-summary-lines
997 (> lines wl-highlight-max-summary-lines)))
1004 (narrow-to-region start end)
1010 (wl-highlight-summary-current-line nil nil wl-summary-scored)
1011 (when (> lines elmo-display-progress-threshold)
1013 (setq percent (/ (* i 100) lines))
1014 (if (or (eq (% percent 5) 0) (= i lines))
1015 (elmo-display-progress
1016 'wl-highlight-summary "Highlighting..."
1019 (message "Highlighting...done")))))))
1021 (defun wl-highlight-headers (&optional for-draft)
1022 (let ((beg (point-min))
1023 (end (or (save-excursion (re-search-forward "^$" nil t)
1026 (wl-highlight-message beg end nil)
1028 (wl-highlight-message-add-buttons-to-header beg end)
1029 (and wl-highlight-x-face-func
1030 (funcall wl-highlight-x-face-func beg end)))
1031 (run-hooks 'wl-highlight-headers-hook)))
1033 (defun wl-highlight-message-add-buttons-to-header (start end)
1036 (narrow-to-region start end)
1037 (let ((case-fold-search t)
1038 (alist wl-highlight-message-header-button-alist)
1041 (setq entry (car alist)
1043 (goto-char (point-min))
1044 (while (re-search-forward (car entry) nil t)
1045 (setq start (match-beginning 0)
1046 end (if (re-search-forward "^[^ \t]" nil t)
1050 (while (re-search-forward (nth 1 entry) end t)
1051 (goto-char (match-end 0))
1052 (wl-message-add-button
1053 (match-beginning (nth 2 entry))
1054 (match-end (nth 2 entry))
1055 (nth 3 entry) (match-string (nth 4 entry))))
1056 (goto-char end)))))))
1058 (defun wl-highlight-body-all ()
1059 (wl-highlight-message (point-min) (point-max) t t))
1061 (defun-hilit wl-highlight-body ()
1062 (let ((beg (or (save-excursion (goto-char (point-min))
1063 (re-search-forward "^$" nil t))
1066 (wl-highlight-message beg end t)))
1068 (defun-hilit2 wl-highlight-body-region (beg end)
1069 (wl-highlight-message beg end t t))
1071 (defun wl-highlight-signature-search-simple (beg end)
1072 "Search signature area in the body message between beg and end.
1073 Returns start point of signature."
1076 (if (re-search-backward "\n--+ *\n" beg t)
1077 (if (eq (char-after (point)) ?\n)
1082 (defun wl-highlight-signature-search (beg end)
1083 "Search signature area in the body message between beg and end.
1084 Returns start point of signature."
1088 ;; look for legal signature separator (check at first for fasten)
1089 (re-search-backward "\n-- \n" beg t)
1091 ;; look for dual separator
1094 (re-search-backward "^[^A-Za-z0-9> \t\n]+ *$" beg t)
1095 (> (- (match-end 0) (match-beginning 0)) 10);; "10" is a magic number.
1098 (regexp-quote (buffer-substring (match-beginning 0) (match-end 0)))
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-hilit2 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 \"special\"
1118 wl-highlight-message-important-header-contents2 contents of \"special\"
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 \"special\" header
1129 wl-highlight-important-header2-regexp what makes a \"special\" header
1130 wl-highlight-unimportant-header-regexp what makes a \"special\" 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)))
1151 ;; take off signature
1152 (if (and hack-sig (not too-big))
1153 (setq end (funcall wl-highlight-signature-search-func
1154 (- end wl-max-signature-size) 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) (point)))
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)
1176 ((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)))
1183 (let ((regexp-alist wl-highlight-message-header-alist))
1185 (when (save-match-data
1186 (looking-at (caar regexp-alist)))
1187 (put-text-property p hend 'face
1188 (cdar regexp-alist))
1190 (setq regexp-alist (cdr regexp-alist)))
1191 (throw 'match nil))))
1194 p hend 'face 'wl-highlight-message-header-contents)))
1196 ((looking-at mail-header-separator)
1197 (put-text-property (match-beginning 0) (match-end 0)
1198 'face 'wl-highlight-header-separator-face)
1199 (goto-char (match-end 0)))
1200 ;; ignore non-header field name lines
1201 (t (forward-line 1))))))
1202 (let (prefix prefix-face-alist pair end)
1205 ((null wl-highlight-force-citation-header-regexp)
1207 ((looking-at wl-highlight-force-citation-header-regexp)
1208 (setq current 'wl-highlight-message-citation-header)
1209 (setq end (match-end 0)))
1210 ((null wl-highlight-citation-prefix-regexp)
1212 ((looking-at wl-highlight-citation-prefix-regexp)
1213 (setq prefix (buffer-substring (point)
1215 (setq pair (assoc prefix prefix-face-alist))
1217 (setq prefix-face-alist
1218 (append prefix-face-alist
1224 (% (length prefix-face-alist)
1226 wl-highlight-citation-face-list))
1227 wl-highlight-citation-face-list)))))))
1228 (unless wl-highlight-highlight-citation-too
1229 (goto-char (match-end 0)))
1230 (setq current (cdr pair)))
1231 ((null wl-highlight-citation-header-regexp)
1233 ((looking-at wl-highlight-citation-header-regexp)
1234 (setq current 'wl-highlight-message-citation-header)
1235 (setq end (match-end 0)))
1236 (t (setq current nil)))
1239 (forward-line 1) ; this is to put the \n in the face too
1240 (let ();(inhibit-read-only t))
1241 (put-text-property p (or end (point))
1246 (run-hooks 'wl-highlight-message-hook))))))
1248 ;; highlight-mouse-line for folder mode
1250 (defun wl-highlight-folder-mouse-line ()
1252 (let* ((end (save-excursion (end-of-line) (point)))
1254 (re-search-forward "[^ ]" end t)
1256 (inhibit-read-only t))
1257 (put-text-property beg end 'mouse-face 'highlight)))
1259 ;;; wl-highlight.el ends here