X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-highlight.el;h=c2fd339b35192eaf7fbc86ecfe1d8b7036394580;hb=b5692b53a7ba39752935617facefa772dc003477;hp=b3e105b15b780ad71b87ef2fce8e16bc31fd6bf2;hpb=806725e3db0748ddc973ba045053a6681e840287;p=elisp%2Fwanderlust.git

diff --git a/wl/wl-highlight.el b/wl/wl-highlight.el
index b3e105b..c2fd339 100644
--- a/wl/wl-highlight.el
+++ b/wl/wl-highlight.el
@@ -1,6 +1,7 @@
-;;; wl-highlight.el -- Hilight modules for Wanderlust.
+;;; wl-highlight.el --- Hilight modules for Wanderlust.
 
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
+;;  Yuuichi Teranishi <teranisi@gohome.org>
 
 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
 ;; Keywords: mail, net news
@@ -33,24 +34,15 @@
 	 (featurep 'dragdrop))
     (require 'wl-dnd))
 (require 'wl-vars)
-(require 'product)
-(product-provide (provide 'wl-highlight) (require 'wl-version))
+(provide 'wl-highlight)			; circular dependency
 
 (eval-when-compile
   (cond (wl-on-xemacs
 	 (require 'wl-xmas))
 	(wl-on-emacs21
 	 (require 'wl-e21))
-	(wl-on-nemacs
-	 (require 'wl-nemacs))
 	(t
 	 (require 'wl-mule)))
-  (defun-maybe extent-begin-glyph (a))
-  (defun-maybe delete-extent (a))
-  (defun-maybe make-extent (a b))
-  (defun-maybe set-extent-begin-glyph (a b))
-  (defun-maybe set-extent-end-glyph (a b))
-  (defun-maybe extent-at (a b c d e))
   (defun-maybe wl-dnd-set-drop-target (a b))
   (defun-maybe wl-dnd-set-drag-starter (a b)))
 
@@ -197,9 +189,8 @@
 
 ;; important messages
 
-(wl-defface wl-highlight-summary-important-face
-  '(
-    (((type tty)
+(wl-defface wl-highlight-summary-flagged-face
+  '((((type tty)
       (background dark))
      (:foreground "magenta"))
     (((class color)
@@ -208,7 +199,7 @@
     (((class color)
       (background light))
      (:foreground "purple")))
-  "Face used for displaying important messages."
+  "Face used for displaying flagged messages."
   :group 'wl-summary-faces
   :group 'wl-faces)
 
@@ -227,6 +218,19 @@
   :group 'wl-summary-faces
   :group 'wl-faces)
 
+(wl-defface wl-highlight-summary-killed-face
+  '((((type tty)
+      (background dark))
+     (:foreground "blue"))
+    (((class color)
+      (background dark))
+     (:foreground "gray"))
+    (((class color))
+     (:foreground "LightSlateGray")))
+  "Face used for displaying killed messages."
+  :group 'wl-summary-faces
+  :group 'wl-faces)
+
 (wl-defface wl-highlight-summary-displaying-face
   '((t
      (:underline t :bold t)))
@@ -258,7 +262,7 @@
   :group 'wl-summary-faces
   :group 'wl-faces)
 
-(wl-defface wl-highlight-summary-deleted-face
+(wl-defface wl-highlight-summary-disposed-face
   '(
     (((type tty)
       (background dark))
@@ -269,10 +273,55 @@
     (((class color)
       (background light))
      (:foreground "DarkKhaki")))
+  "Face used for displaying messages mark as disposed."
+  :group 'wl-summary-faces
+  :group 'wl-faces)
+
+(wl-defface wl-highlight-summary-deleted-face
+  '(
+    (((type tty)
+      (background dark))
+     (:foreground "blue"))
+    (((class color)
+      (background dark))
+     (:foreground "SteelBlue"))
+    (((class color)
+      (background light))
+     (:foreground "RoyalBlue4")))
   "Face used for displaying messages mark as deleted."
   :group 'wl-summary-faces
   :group 'wl-faces)
 
+(wl-defface wl-highlight-summary-prefetch-face
+  '(
+    (((type tty)
+      (background dark))
+     (:foreground "Green"))
+    (((class color)
+      (background dark))
+     (:foreground "DeepSkyBlue"))
+    (((class color)
+      (background light))
+     (:foreground "brown")))
+  "Face used for displaying messages mark as deleted."
+  :group 'wl-summary-faces
+  :group 'wl-faces)
+
+(wl-defface wl-highlight-summary-resend-face
+  '(
+    (((type tty)
+      (background dark))
+     (:foreground "Yellow"))
+    (((class color)
+      (background dark))
+     (:foreground "orange3"))
+    (((class color)
+      (background light))
+     (:foreground "orange3")))
+  "Face used for displaying messages mark as resend."
+  :group 'wl-summary-faces
+  :group 'wl-faces)
+
 (wl-defface wl-highlight-summary-refiled-face
   '(
     (((type tty)
@@ -303,6 +352,49 @@
   :group 'wl-summary-faces
   :group 'wl-faces)
 
+;; answered
+(wl-defface wl-highlight-summary-answered-face
+  '((((type tty)
+      (background dark))
+     (:foreground "yellow"))
+    (((class color)
+      (background dark))
+     (:foreground "khaki"))
+    (((class color)
+      (background light))
+     (:foreground "khaki4")))
+  "Face used for displaying answered messages."
+  :group 'wl-summary-faces
+  :group 'wl-faces)
+
+;; forwarded
+(wl-defface wl-highlight-summary-forwarded-face
+  '((((type tty)
+      (background dark))
+     (:foreground "yellow"))
+    (((class color)
+      (background dark))
+     (:foreground "DarkOliveGreen2"))
+    (((class color)
+      (background light))
+     (:foreground "DarkOliveGreen4")))
+  "Face used for displaying forwarded messages."
+  :group 'wl-summary-faces
+  :group 'wl-faces)
+
+(wl-defface wl-summary-persistent-mark-face
+  '((((type tty))
+     (:foreground "blue"))
+    (((class color)
+      (background dark))
+     (:foreground "SeaGreen4"))
+    (((class color)
+      (background light))
+     (:foreground "SeaGreen1")))
+  "Dafault face used for displaying messages with persistent mark."
+  :group 'wl-summary-faces
+  :group 'wl-faces)
+
 ;; obsolete.
 (wl-defface wl-highlight-summary-temp-face
   '(
@@ -542,41 +634,38 @@
   :group 'wl-faces)
 
 (wl-defface wl-highlight-demo-face
-  '(
-    (((type tty)
-      (background dark))
+  '((((type tty))
      (:foreground "green"))
     (((class color)
-      (background dark))
-     (:foreground "GreenYellow"))
-    (((class color)
       (background light))
-     (:foreground "blue2")))
+     (:foreground "#006600" :background "#d9ffd9"))
+    (((class color)
+      (background dark))
+     (:foreground "#d9ffd9" :background "#004400")))
   "Face used for displaying demo."
   :group 'wl-faces)
 
 (wl-defface wl-highlight-logo-face
-  '(
-    (((type tty)
+  '((((type tty)
       (background dark))
      (:foreground "cyan"))
     (((class color)
-      (background dark))
-     (:foreground "SkyBlue"))
-    (((class color)
       (background light))
-     (:foreground "SteelBlue")))
+     (:foreground "SteelBlue" :background "#d9ffd9"))
+    (((class color)
+      (background dark))
+     (:foreground "SkyBlue" :background "#004400")))
   "Face used for displaying demo."
   :group 'wl-faces)
 
-(wl-defface wl-highlight-refile-destination-face
+(wl-defface wl-highlight-action-argument-face
   '((((class color)
       (background dark))
      (:foreground "pink"))
     (((class color)
       (background light))
      (:foreground "red")))
-  "Face used for displaying refile destination."
+  "Face used for displaying action argument."
   :group 'wl-summary-faces
   :group 'wl-faces)
 
@@ -696,18 +785,19 @@
   :group 'wl-message-faces
   :group 'wl-faces)
 
-(defvar wl-highlight-folder-opened-regexp " *\\(\\[\\-\\]\\)")
-(defvar wl-highlight-folder-closed-regexp " *\\(\\[\\+\\]\\)")
-(defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$")
+(defface wl-message-header-narrowing-face
+  '((((class color) (background light))
+     (:foreground "black" :background "dark khaki"))
+    (((class color) (background dark))
+     (:foreground "white" :background "dark goldenrod"))
+    (t (:bold t)))
+  "Face used for header narrowing for the message."
+  :group 'wl-message-faces
+  :group 'wl-faces)
 
-(defvar wl-highlight-summary-unread-regexp " *[0-9]+[^0-9]\\(!\\|U\\)")
-(defvar wl-highlight-summary-important-regexp " *[0-9]+[^0-9]\\$")
-(defvar wl-highlight-summary-new-regexp " *[0-9]+[^0-9]N")
-(defvar wl-highlight-summary-deleted-regexp " *[0-9]+D")
-(defvar wl-highlight-summary-refiled-regexp " *[0-9]+o")
-(defvar wl-highlight-summary-copied-regexp " *[0-9]+O")
-(defvar wl-highlight-summary-target-regexp " *[0-9]+\\*")
-;(defvar wl-highlight-summary-thread-top-regexp " *[0-9]+[^0-9][^0-9]../..\(.*\)..:.. \\[")
+(defvar wl-highlight-folder-opened-regexp "^ *\\(\\[\\-\\]\\)")
+(defvar wl-highlight-folder-closed-regexp "^ *\\(\\[\\+\\]\\)")
+(defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$")
 
 (defvar wl-highlight-citation-face-list
   '(wl-highlight-message-cited-text-1
@@ -721,43 +811,30 @@
     wl-highlight-message-cited-text-9
     wl-highlight-message-cited-text-10))
 
-(defmacro defun-hilit (name &rest everything-else)
-  "Define a function for highlight. Nemacs implementation is set as empty."
-  (if wl-on-nemacs
-      (` (defun (, name) nil nil))
-    (` (defun (, name) (,@ everything-else)))))
-
-(defmacro defun-hilit2 (name &rest everything-else)
-  "Define a function for highlight w/o nemacs."
-  (if wl-on-nemacs
-      () ; noop
-    (` (defun (, name) (,@ everything-else)))))
-
-(defmacro wl-delete-all-overlays ()
+(defun wl-delete-all-overlays ()
   "Delete all momentary overlays."
-  (if wl-on-nemacs
-      nil
-    '(let ((overlays (overlays-in (point-min) (point-max)))
-	   overlay)
-       (while (setq overlay (car overlays))
-	 (if (overlay-get overlay 'wl-momentary-overlay)
-	     (delete-overlay overlay))
-	 (setq overlays (cdr overlays))))))
-
-(defun-hilit wl-highlight-summary-displaying ()
+  (let ((overlays (overlays-in (point-min) (point-max)))
+	overlay)
+    (while (setq overlay (car overlays))
+      (if (overlay-get overlay 'wl-momentary-overlay)
+	  (delete-overlay overlay))
+      (setq overlays (cdr overlays)))))
+
+(defun wl-highlight-summary-displaying ()
   (interactive)
   (wl-delete-all-overlays)
   (let (bol eol ov)
     (save-excursion
+      (end-of-line)
+      (setq eol (point))
       (beginning-of-line)
       (setq bol (point))
-      (save-excursion (end-of-line) (setq eol (point)))
       (setq ov (make-overlay bol eol))
       (overlay-put ov 'face 'wl-highlight-summary-displaying-face)
       (overlay-put ov 'evaporate t)
       (overlay-put ov 'wl-momentary-overlay t))))
 
-(defun-hilit2 wl-highlight-folder-group-line (numbers)
+(defun wl-highlight-folder-group-line (numbers)
   (end-of-line)
   (let ((eol (point))
 	bol)
@@ -790,121 +867,132 @@
 	      (put-text-property bol (match-end 0) 'face face)))
 	(put-text-property bol eol 'face text-face)))))
 
-(defun-hilit2 wl-highlight-summary-line-string (line mark temp-mark indent)
-  (let (fsymbol)
-    (cond ((and (string= temp-mark "+")
-		(member mark (list wl-summary-unread-cached-mark
-				   wl-summary-unread-uncached-mark
-				   wl-summary-new-mark)))
-	   (setq fsymbol 'wl-highlight-summary-high-unread-face))
-	  ((and (string= temp-mark "-")
-		(member mark (list wl-summary-unread-cached-mark
-				   wl-summary-unread-uncached-mark
-				   wl-summary-new-mark)))
-	   (setq fsymbol 'wl-highlight-summary-low-unread-face))
-	  ((string= temp-mark "o")
-	   (setq fsymbol 'wl-highlight-summary-refiled-face))
-	  ((string= temp-mark "O")
-	   (setq fsymbol 'wl-highlight-summary-copied-face))
-	  ((string= temp-mark "D")
-	   (setq fsymbol 'wl-highlight-summary-deleted-face))
-	  ((string= temp-mark "*")
-	   (setq fsymbol 'wl-highlight-summary-temp-face))
-	  ((string= mark wl-summary-new-mark)
-	   (setq fsymbol 'wl-highlight-summary-new-face))
-	  ((member mark (list wl-summary-unread-cached-mark
-			      wl-summary-unread-uncached-mark))
-	   (setq fsymbol 'wl-highlight-summary-unread-face))
-	  ((or (string= mark wl-summary-important-mark))
-	   (setq fsymbol 'wl-highlight-summary-important-face))
-	  ((string= temp-mark "-")
-	   (setq fsymbol 'wl-highlight-summary-low-read-face))
-	  ((string= temp-mark "+")
-	   (setq fsymbol 'wl-highlight-summary-high-read-face))
-	  (t (if (= 0 (length indent))
-		 (setq fsymbol 'wl-highlight-summary-thread-top-face)
-	       (setq fsymbol 'wl-highlight-summary-normal-face))))
+(defsubst wl-highlight-get-face-by-name (format &rest args)
+  (let ((face (intern (apply #'format format args))))
+    (and (find-face face)
+	 face)))
+
+(defsubst wl-highlight-summary-line-face-spec (status temp-mark indent)
+  "Return a cons cell of (face . argument)."
+  (or (let (action)
+	(and (setq action (assoc temp-mark wl-summary-mark-action-list))
+	     (cons (nth 5 action) (nth 2 action))))
+      (let ((flags (elmo-message-status-flags status)))
+	(cond
+	 ((and (string= temp-mark wl-summary-score-over-mark)
+	       (or (memq 'new flags) (memq 'unread flags)))
+	  '(wl-highlight-summary-high-unread-face))
+	 ((and (string= temp-mark wl-summary-score-below-mark)
+	       (or (memq 'new flags) (memq 'unread flags)))
+	  '(wl-highlight-summary-low-unread-face))
+	 ((let ((priorities wl-summary-persistent-mark-priority-list)
+		(fl wl-summary-flag-alist)
+		face result global-flags)
+	    (while (and (null result) priorities)
+	      (cond
+	       ((eq (car priorities) 'killed)
+		(when (elmo-message-status-killed-p status)
+		  (setq result '(wl-highlight-summary-killed-face))))
+	       ((eq (car priorities) 'flag)
+		(when (setq global-flags
+			    (elmo-get-global-flags flags 'ignore-preserved))
+		  (while fl
+		    (when (memq (car (car fl)) global-flags)
+		      (setq result
+			    (list (or (wl-highlight-get-face-by-name
+				       "wl-highlight-summary-%s-flag-face"
+				       (car (car fl)))
+				      'wl-highlight-summary-flagged-face))
+			    fl nil))
+		    (setq fl (cdr fl)))
+		  (unless result
+		    (setq result (list 'wl-highlight-summary-flagged-face)))))
+	       ((memq (car priorities) flags)
+		(setq result
+		      (list (or (wl-highlight-get-face-by-name
+				 "wl-highlight-summary-%s-face"
+				 (car priorities))
+				'wl-summary-persistent-mark-face)))))
+	      (setq priorities (cdr priorities)))
+	    result))
+	 ((string= temp-mark wl-summary-score-below-mark)
+	  '(wl-highlight-summary-low-read-face))
+	 ((string= temp-mark wl-summary-score-over-mark)
+	  '(wl-highlight-summary-high-read-face))
+	 (t (if indent
+		'(wl-highlight-summary-normal-face)
+	      '(wl-highlight-summary-thread-top-face)))))))
+
+(autoload 'elmo-flag-folder-referrer "elmo-flag")
+(defun wl-highlight-flag-folder-help-echo (folder number)
+  (let ((referer (elmo-flag-folder-referrer folder number)))
+    (concat "The message exists in "
+	    (mapconcat
+	     (lambda (pair)
+		   (concat (car pair) "/"
+			   (number-to-string
+			    (cdr pair))))
+	     referer ","))))
+
+(defun wl-highlight-summary-line-help-echo (number beg end &optional string)
+  (let ((type (elmo-folder-type-internal wl-summary-buffer-elmo-folder))
+	message handler)
+    (when (setq handler (cadr (assq type wl-highlight-summary-line-help-echo-alist)))
+      (setq message
+	    (funcall handler wl-summary-buffer-elmo-folder number))
+      (if message
+	  (put-text-property beg end 'help-echo
+			     message
+			     string)))))
+
+(defun wl-highlight-summary-line-string (number line status temp-mark indent)
+  (let ((fsymbol (car (wl-highlight-summary-line-face-spec
+		       status
+		       temp-mark
+		       (> (length indent) 0)))))
     (put-text-property 0 (length line) 'face fsymbol line))
-  (if wl-use-highlight-mouse-line
-      (put-text-property 0 (length line) 'mouse-face 'highlight line)))
+  (when wl-use-highlight-mouse-line
+    (put-text-property 0 (length line) 'mouse-face 'highlight line))
+  (when wl-highlight-summary-line-help-echo-alist
+    (wl-highlight-summary-line-help-echo number 0 (length line) line)))
 
-(defun-hilit2 wl-highlight-summary-current-line (&optional smark regexp temp-too)
+(defun wl-highlight-summary-current-line (&optional number status)
   (interactive)
   (save-excursion
     (let ((inhibit-read-only t)
-	  (case-fold-search nil) temp-mark status-mark
-	  (sregexp (concat
-		    "^"
-		    wl-summary-buffer-number-regexp
-		    "\\(.\\)\\(.\\)../..\(.*\)..:.. \\("
-		    wl-highlight-thread-indent-string-regexp
-		    "\\)[[<]"))
-	  fregexp fsymbol bol eol matched thread-top looked-at)
-      (beginning-of-line)
-      (setq bol (point))
-      (save-excursion (end-of-line) (setq eol (point)))
-      (if smark
-	  (setq status-mark smark)
-	(setq looked-at (looking-at sregexp))
-	(setq status-mark (buffer-substring (match-beginning 2)
-					    (match-end 2))))
-      (when temp-too
-	(unless looked-at
-	  (setq looked-at (looking-at sregexp)))
-	(when looked-at
-	  (setq temp-mark (buffer-substring (match-beginning 1)
-					    (match-end 1)))
-	  (cond
-	   ((string= temp-mark "*")
-	    (setq fsymbol 'wl-highlight-summary-temp-face))
-	   ((string= temp-mark "D")
-	    (setq fsymbol 'wl-highlight-summary-deleted-face))
-	   ((string= temp-mark "O")
-	    (setq fsymbol 'wl-highlight-summary-copied-face))
-	   ((string= temp-mark "o")
-	    (setq fsymbol 'wl-highlight-summary-refiled-face)))))
-      (if (not fsymbol)
-	  (cond
-	   ((and (string= temp-mark "+")
-		 (member status-mark (list wl-summary-unread-cached-mark
-					   wl-summary-unread-uncached-mark
-					   wl-summary-new-mark)))
-	    (setq fsymbol 'wl-highlight-summary-high-unread-face))
-	   ((and (string= temp-mark "-")
-		 (member status-mark (list wl-summary-unread-cached-mark
-					   wl-summary-unread-uncached-mark
-					   wl-summary-new-mark)))
-	    (setq fsymbol 'wl-highlight-summary-low-unread-face))
-	   ((string= status-mark wl-summary-new-mark)
-	    (setq fsymbol 'wl-highlight-summary-new-face))
-	   ((member status-mark (list wl-summary-unread-cached-mark
-				      wl-summary-unread-uncached-mark))
-	    (setq fsymbol 'wl-highlight-summary-unread-face))
-	   ((string= status-mark wl-summary-important-mark)
-	    (setq fsymbol 'wl-highlight-summary-important-face))
-	   ;; score mark
-	   ((string= temp-mark "-")
-	    (setq fsymbol 'wl-highlight-summary-low-read-face))
-	   ((string= temp-mark "+")
-	    (setq fsymbol 'wl-highlight-summary-high-read-face))
-	   ;;
-	   (t (if (and looked-at
-		       (string= (buffer-substring
-				 (match-beginning 3)
-				 (match-end 3)) ""))
-		  (setq fsymbol 'wl-highlight-summary-thread-top-face)
-		(setq fsymbol 'wl-highlight-summary-normal-face)))))
-      (put-text-property bol eol 'face fsymbol)
-      (if wl-use-highlight-mouse-line
-	  (put-text-property bol;(1- (match-end 0))
-			     eol 'mouse-face 'highlight))
-;      (put-text-property (match-beginning 3) (match-end 3)
-;			 'face 'wl-highlight-thread-indent-face)
-      ;; Dnd stuff.
-      (if wl-use-dnd
-	  (wl-dnd-set-drag-starter bol eol)))))
-
-(defun-hilit2 wl-highlight-folder (start end)
+	  (case-fold-search nil)
+	  (deactivate-mark nil)
+	  (number (or number (wl-summary-message-number)))
+	  bol eol spec)
+      (when number
+	(end-of-line)
+	(setq eol (point))
+	(beginning-of-line)
+	(setq bol (point))
+	(setq spec (wl-highlight-summary-line-face-spec
+		    (or status (wl-summary-message-status number))
+		    (wl-summary-temp-mark number)
+		    (wl-thread-entity-get-parent-entity
+		     (wl-thread-get-entity number))))
+	(when (car spec)
+	  (put-text-property bol eol 'face (car spec)))
+	(when (cdr spec)
+	  (put-text-property (next-single-property-change
+			      (next-single-property-change
+			       bol 'wl-summary-action-argument
+			       nil eol)
+			      'wl-summary-action-argument nil eol)
+			     eol
+			     'face
+			     'wl-highlight-action-argument-face))
+	(when wl-use-highlight-mouse-line
+	  (put-text-property bol eol 'mouse-face 'highlight))
+	(when wl-highlight-summary-line-help-echo-alist
+	  (wl-highlight-summary-line-help-echo number bol eol))
+	(when wl-use-dnd
+	  (wl-dnd-set-drag-starter bol eol))))))
+
+(defun wl-highlight-folder (start end)
   "Highlight folder between start and end.
 Faces used:
   wl-highlight-folder-unknown-face      unread messages
@@ -934,7 +1022,7 @@ Variables used:
 	    (wl-highlight-folder-current-line)
 	    (forward-line 1)))))))
 
-(defun-hilit2 wl-highlight-folder-path (folder-path)
+(defun wl-highlight-folder-path (folder-path)
   "Highlight current folder path...overlay"
   (save-excursion
     (wl-delete-all-overlays)
@@ -958,117 +1046,85 @@ Variables used:
 	  (overlay-put ov 'wl-momentary-overlay t))
 	(forward-line 1)))))
 
-(defun-hilit2 wl-highlight-refile-destination-string (string)
+(defun wl-highlight-action-argument-string (string)
   (put-text-property 0 (length string) 'face
-		     'wl-highlight-refile-destination-face
+		     'wl-highlight-action-argument-face
 		     string))
 
-(defun-hilit wl-highlight-summary-all ()
+(defun wl-highlight-summary-all ()
   "For evaluation"
   (interactive)
   (wl-highlight-summary (point-min)(point-max)))
 
-(defun-hilit2 wl-highlight-summary (start end)
+(defun wl-highlight-summary (start end &optional lazy)
   "Highlight summary between start and end.
 Faces used:
   wl-highlight-summary-unread-face      unread messages
-  wl-highlight-summary-important-face   important messages
   wl-highlight-summary-deleted-face     messages mark as deleted
   wl-highlight-summary-refiled-face     messages mark as refiled
   wl-highlight-summary-copied-face      messages mark as copied
   wl-highlight-summary-new-face         new messages
-
-Variables used:
-  wl-highlight-summary-unread-regexp    matches unread messages
-  wl-highlight-summary-important-regexp matches important messages
-  wl-highlight-summary-deleted-regexp   matches messages mark as deleted
-  wl-highlight-summary-refiled-regexp   matches messages mark as refiled
-  wl-highlight-summary-copied-regexp    matches messages mark as copied
-  wl-highlight-summary-new-regexp       matches new messages
-
-If HACK-SIG is true,then we search backward from END for something that
-looks like the beginning of a signature block, and don't consider that a
-part of the message (this is because signatures are often incorrectly
-interpreted as cited text.)"
+  wl-highlight-summary-*-flag-face      flagged messages"
   (if (< end start)
       (let ((s start)) (setq start end end s)))
-  (let* ((lines (count-lines start end))
-	 (too-big (and wl-highlight-max-summary-lines
-		       (> lines wl-highlight-max-summary-lines)))
-	 (real-end end)
-	 gc-message
-	 e p hend i percent)
+  (let (lines too-big gc-message e p hend i percent)
     (save-excursion
-      (save-restriction
-	(widen)
-	(narrow-to-region start end)
-	(if (not too-big)
-	    (save-restriction
-	      (goto-char start)
-	      (setq i 0)
-	      (while (not (eobp))
-		(wl-highlight-summary-current-line nil nil wl-summary-scored)
-		(when (> lines elmo-display-progress-threshold)
-		  (setq i (+ i 1))
-		  (setq percent (/ (* i 100) lines))
-		  (if (or (eq (% percent 5) 0) (= i lines))
-		      (elmo-display-progress
-		       'wl-highlight-summary "Highlighting..."
-		       percent)))
-		(forward-line 1))
-	      (message "Highlighting...done.")))))))
-
-(defun wl-highlight-headers ()
+      (unless wl-summary-lazy-highlight
+	(setq lines (count-lines start end)
+	      too-big (and wl-highlight-max-summary-lines
+			   (> lines wl-highlight-max-summary-lines))))
+      (goto-char start)
+      (setq i 0)
+      (while (and (not (eobp))
+		  (< (point) end))
+	(when (or (not lazy)
+		  (null (get-text-property (point) 'face)))
+	  (wl-highlight-summary-current-line))
+	(forward-line 1))
+      (unless wl-summary-lazy-highlight
+	(message "Highlighting...done")))))
+
+(defun wl-highlight-summary-window (&optional win beg)
+  "Highlight summary window.
+This function is defined for `window-scroll-functions'"
+  (when wl-summary-highlight
+    (with-current-buffer (window-buffer win)
+      (when (eq major-mode 'wl-summary-mode)
+	(let ((start (window-start win))
+	      (end (condition-case nil
+		       (window-end win t) ;; old emacsen doesn't support 2nd arg.
+		     (error (window-end win)))))
+	  (wl-highlight-summary start
+				end
+				'lazy))
+	(set-buffer-modified-p nil)))))
+
+(defun wl-highlight-headers (&optional for-draft)
   (let ((beg (point-min))
 	(end (or (save-excursion (re-search-forward "^$" nil t)
 				 (point))
 		 (point-max))))
     (wl-highlight-message beg end nil)
-    (wl-highlight-message-add-buttons-to-header beg end)
-    (and wl-highlight-x-face-func
-	 (funcall wl-highlight-x-face-func beg end))
+    (unless for-draft
+      (when wl-highlight-x-face-function
+	(funcall wl-highlight-x-face-function)))
     (run-hooks 'wl-highlight-headers-hook)))
 
-(defun wl-highlight-message-add-buttons-to-header (start end)
-  (save-excursion
-    (save-restriction
-      (narrow-to-region start end)
-      (let ((case-fold-search t)
-	    (alist wl-highlight-message-header-button-alist)
-	    entry)
-	(while alist
-	  (setq entry (car alist)
-		alist (cdr alist))
-	  (goto-char (point-min))
-	  (while (re-search-forward (car entry) nil t)
-	    (setq start (match-beginning 0)
-		  end (if (re-search-forward "^[^ \t]" nil t)
-			  (match-beginning 0)
-			(point-max)))
-	    (goto-char start)
-	    (while (re-search-forward (nth 1 entry) end t)
-	      (goto-char (match-end 0))
-	      (wl-message-add-button
-	       (match-beginning (nth 2 entry))
-	       (match-end (nth 2 entry))
-	       (nth 3 entry) (match-string (nth 4 entry))))
-	    (goto-char end)))))))
-
 (defun wl-highlight-body-all ()
   (wl-highlight-message (point-min) (point-max) t t))
 
-(defun-hilit wl-highlight-body ()
+(defun wl-highlight-body ()
   (let ((beg (or (save-excursion (goto-char (point-min))
 				 (re-search-forward "^$" nil t))
 		 (point-min)))
 	(end (point-max)))
     (wl-highlight-message beg end t)))
 
-(defun-hilit2 wl-highlight-body-region (beg end)
+(defun wl-highlight-body-region (beg end)
   (wl-highlight-message beg end t t))
 
 (defun wl-highlight-signature-search-simple (beg end)
-  "Search signature area in the body message between beg and end.
+  "Search signature area in the body message between BEG and END.
 Returns start point of signature."
   (save-excursion
     (goto-char end)
@@ -1079,23 +1135,31 @@ Returns start point of signature."
       end)))
 
 (defun wl-highlight-signature-search (beg end)
-  "Search signature area in the body message between beg and end.
+  "Search signature area in the body message between BEG and END.
 Returns start point of signature."
   (save-excursion
     (goto-char end)
     (or
      ;; look for legal signature separator (check at first for fasten)
-     (re-search-backward "\n-- \n" beg t)
+     (search-backward "\n-- \n" beg t)
 
      ;; look for dual separator
-     (save-excursion
-       (and
-	(re-search-backward "^[^A-Za-z0-9> \t\n]+ *$" beg t)
-	(> (- (match-end 0) (match-beginning 0)) 10);; "10" is a magic number.
-	(re-search-backward
-	 (concat "^"
-		 (regexp-quote (buffer-substring (match-beginning 0) (match-end 0)))
-		 "$") beg t)))
+     (let ((pt (point))
+	   separator)
+       (prog1
+	   (and (re-search-backward "^[^A-Za-z0-9> \t\n]+ *$" beg t)
+		;; `10' is a magic number.
+		(> (- (match-end 0) (match-beginning 0)) 10)
+		(setq separator (buffer-substring (match-beginning 0)
+						  (match-end 0)))
+		;; We should not use `re-search-backward' for a long word
+		;; since it is possible to crash XEmacs because of a bug.
+		(if (search-backward (concat "\n" separator "\n") beg t)
+		    (1+ (point))
+		  (and (search-backward (concat separator "\n") beg t)
+		       (bolp)
+		       (point))))
+	 (goto-char pt)))
 
      ;; look for user specified signature-separator
      (if (stringp wl-highlight-signature-separator)
@@ -1107,28 +1171,28 @@ Returns start point of signature."
 	 (point)))	;; if no separator found, returns end.
      )))
 
-(defun-hilit2 wl-highlight-message (start end hack-sig &optional body-only)
+(defun wl-highlight-message (start end hack-sig &optional body-only)
   "Highlight message headers between start and end.
 Faces used:
   wl-highlight-message-headers			  the part before the colon
   wl-highlight-message-header-contents		  the part after the colon
-  wl-highlight-message-important-header-contents  contents of \"special\"
+  wl-highlight-message-important-header-contents  contents of \"important\"
                                                   headers
-  wl-highlight-message-important-header-contents2 contents of \"special\"
+  wl-highlight-message-important-header-contents2 contents of \"important\"
                                                   headers
   wl-highlight-message-unimportant-header-contents contents of unimportant
                                                    headers
-  wl-highlight-message-cited-text	           quoted text from other
+  wl-highlight-message-cited-text-N	           quoted text from other
                                                    messages
   wl-highlight-message-citation-header             header of quoted texts
   wl-highlight-message-signature                   signature
 
 Variables used:
-  wl-highlight-important-header-regexp	 what makes a \"special\" header
-  wl-highlight-important-header2-regexp	 what makes a \"special\" header
-  wl-highlight-unimportant-header-regexp what makes a \"special\" header
-  wl-highlight-citation-prefix-regexp	 matches lines of quoted text
-  wl-highlight-citation-header-regexp	 matches headers for quoted text
+  wl-highlight-message-header-alist             alist of header regexp with
+                                                face for header contents
+  wl-highlight-citation-prefix-regexp		matches lines of quoted text
+  wl-highlight-force-citation-header-regexp	matches headers for quoted text
+  wl-highlight-citation-header-regexp		matches headers for quoted text
 
 If HACK-SIG is true,then we search backward from END for something that
 looks like the beginning of a signature block, and don't consider that a
@@ -1136,116 +1200,113 @@ part of the message (this is because signatures are often incorrectly
 interpreted as cited text.)"
   (if (< end start)
       (let ((s start)) (setq start end end s)))
-  (let* ((too-big (and wl-highlight-max-message-size
-		       (> (- end start)
-			  wl-highlight-max-message-size)))
-	 (real-end end)
-	 current  beg
-	 e p hend)
-    (save-excursion
-      (save-restriction
-	(widen)
-	;; take off signature
-	(if (and hack-sig (not too-big))
-	    (setq end (funcall wl-highlight-signature-search-func
-			       (- end wl-max-signature-size) end)))
-	(if hack-sig
-	    (put-text-property end (point-max)
-			       'face 'wl-highlight-message-signature))
-	(narrow-to-region start end)
-
+  (let ((too-big (and wl-highlight-max-message-size
+		      (> (- end start)
+			 wl-highlight-max-message-size)))
+	(real-end end)
+	current  beg
+	e p hend)
+    (unless too-big
+      (save-excursion
 	(save-restriction
-	  ;; narrow down to just the headers...
-	  (goto-char start)
-	  ;; If this search fails then the narrowing performed above
-	  ;; is sufficient
-	  (if (re-search-forward (format
-				  "^$\\|%s"
-				  (regexp-quote mail-header-separator)) nil t)
-	      (narrow-to-region (point-min) (point)))
-	  (goto-char start)
-	  (while (and (not body-only)
-		      (not (eobp)))
-	    (cond
-	     ((looking-at "^\\([^ \t\n:]+[ \t]*:\\) *\\(.*\\(\n[ \t].*\\)*\n\\)")
-	      (setq hend (match-end 0))
-	      (put-text-property (match-beginning 1) (match-end 1)
-				 'face 'wl-highlight-message-headers)
-	      (setq p (match-end 1))
-	      (cond
-	       ((catch 'match
-		  (let ((regexp-alist wl-highlight-message-header-alist))
-		    (while regexp-alist
-		      (when (save-match-data
-			      (looking-at (caar regexp-alist)))
-			(put-text-property
-			 (match-beginning 2) (match-end 2)
-			 'face
-			 (cdar regexp-alist))
-			(throw 'match t))
-		      (setq regexp-alist (cdr regexp-alist)))
-		    (throw 'match nil))))
-	       (t
-		(put-text-property
-		 (match-beginning 2) (match-end 2)
-		 'face 'wl-highlight-message-header-contents)))
-	      (goto-char hend))
-	     ((looking-at mail-header-separator)
-	      (put-text-property (match-beginning 0) (match-end 0)
-				 'face 'wl-highlight-header-separator-face)
-	      (goto-char (match-end 0)))
-	     ;; ignore non-header field name lines
-	     (t (forward-line 1)))))
-	;; now do the body, unless it's too big....
-	(if too-big
-	    nil
+	  (widen)
+	  ;; take off signature
+	  (if (and hack-sig (not too-big))
+	      (setq end (funcall wl-highlight-signature-search-function
+				 (- end wl-max-signature-size) end)))
+	  (if (and hack-sig
+		   (not (eq end real-end)))
+	      (put-text-property end (point-max)
+				 'face 'wl-highlight-message-signature))
+	  (narrow-to-region start end)
+	  (save-restriction
+	    ;; narrow down to just the headers...
+	    (goto-char start)
+	    ;; If this search fails then the narrowing performed above
+	    ;; is sufficient
+	    (if (re-search-forward (format
+				    "^\\(%s\\)?$"
+				    (regexp-quote mail-header-separator))
+				   nil t)
+		(narrow-to-region (point-min) (match-beginning 0)))
+	    ;; highlight only when header is not too-big.
+	    (when (or (null wl-highlight-max-header-size)
+		      (< (point) wl-highlight-max-header-size))
+	      (goto-char start)
+	      (while (and (not body-only)
+			  (not (eobp)))
+		(if (looking-at "^[^ \t\n:]+[ \t]*:[ \t]*")
+		    (progn
+		      (put-text-property (match-beginning 0) (match-end 0)
+					 'face 'wl-highlight-message-headers)
+		      (setq p (match-end 0))
+		      (setq hend (save-excursion (std11-field-end end)))
+		      (or (catch 'match
+			    (let ((regexp-alist wl-highlight-message-header-alist))
+			      (while regexp-alist
+				(when (save-match-data
+					(looking-at (caar regexp-alist)))
+				  (put-text-property p hend 'face
+						     (cdar regexp-alist))
+				  (throw 'match t))
+				(setq regexp-alist (cdr regexp-alist)))
+			      (throw 'match nil)))
+			  (put-text-property
+			   p hend 'face 'wl-highlight-message-header-contents))
+		      (goto-char hend))
+		  ;; ignore non-header field name lines
+		  (forward-line 1)))))
 	  (let (prefix prefix-face-alist pair end)
-	  (while (not (eobp))
-	    (cond
-	     ((null wl-highlight-force-citation-header-regexp)
-	      nil)
-	     ((looking-at wl-highlight-force-citation-header-regexp)
-	      (setq current 'wl-highlight-message-citation-header)
-	      (setq end (match-end 0)))
-	     ((null wl-highlight-citation-prefix-regexp)
-	      nil)
-	     ((looking-at wl-highlight-citation-prefix-regexp)
-	      (setq prefix (buffer-substring (point)
-					     (match-end 0)))
-	      (setq pair (assoc prefix prefix-face-alist))
-	      (unless pair
-		(setq prefix-face-alist
-		      (append prefix-face-alist
-			      (list
-			       (setq pair
-				     (cons
-				      prefix
-				      (nth
-				       (% (length prefix-face-alist)
-					  (length
-					   wl-highlight-citation-face-list))
-				       wl-highlight-citation-face-list)))))))
-	      (unless wl-highlight-highlight-citation-too
+	    (while (not (eobp))
+	      (cond
+	       ((looking-at (concat "^" (regexp-quote mail-header-separator) "$"))
+		(put-text-property (match-beginning 0) (match-end 0)
+				   'face 'wl-highlight-header-separator-face)
 		(goto-char (match-end 0)))
-	      (setq current (cdr pair)))
-	     ((null wl-highlight-citation-header-regexp)
-	      nil)
-	     ((looking-at wl-highlight-citation-header-regexp)
-	      (setq current 'wl-highlight-message-citation-header)
-	      (setq end (match-end 0)))
-	     (t (setq current nil)))
-	    (cond (current
-		   (setq p (point))
-		   (forward-line 1) ; this is to put the \n in the face too
-		   (let ();(inhibit-read-only t))
-		     (put-text-property p (or end (point))
-					'face current)
-		     (setq end nil))
-		   (forward-char -1)))
-	    (forward-line 1)))
+	       ((null wl-highlight-force-citation-header-regexp)
+		nil)
+	       ((looking-at wl-highlight-force-citation-header-regexp)
+		(setq current 'wl-highlight-message-citation-header)
+		(setq end (match-end 0)))
+	       ((null wl-highlight-citation-prefix-regexp)
+		nil)
+	       ((looking-at wl-highlight-citation-prefix-regexp)
+		(setq prefix (buffer-substring (point)
+					       (match-end 0)))
+		(setq pair (assoc prefix prefix-face-alist))
+		(unless pair
+		  (setq prefix-face-alist
+			(append prefix-face-alist
+				(list
+				 (setq pair
+				       (cons
+					prefix
+					(nth
+					 (% (length prefix-face-alist)
+					    (length
+					     wl-highlight-citation-face-list))
+					 wl-highlight-citation-face-list)))))))
+		(unless wl-highlight-highlight-citation-too
+		  (goto-char (match-end 0)))
+		(setq current (cdr pair)))
+	       ((null wl-highlight-citation-header-regexp)
+		nil)
+	       ((looking-at wl-highlight-citation-header-regexp)
+		(setq current 'wl-highlight-message-citation-header)
+		(setq end (match-end 0)))
+	       (t (setq current nil)))
+	      (cond (current
+		     (setq p (point))
+		     (forward-line 1) ; this is to put the \n in the face too
+		     (let ()
+;;;		       ((inhibit-read-only t))
+		       (put-text-property p (or end (point))
+					  'face current)
+		       (setq end nil))
+		     (forward-char -1)))
+	      (forward-line 1)))
 	  (run-hooks 'wl-highlight-message-hook))))))
 
-
 ;; highlight-mouse-line for folder mode
 
 (defun wl-highlight-folder-mouse-line ()
@@ -1257,4 +1318,8 @@ interpreted as cited text.)"
 	 (inhibit-read-only t))
     (put-text-property beg end 'mouse-face 'highlight)))
 
+
+(require 'product)
+(product-provide (provide 'wl-highlight) (require 'wl-version))
+
 ;;; wl-highlight.el ends here