-;;; 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
;;
;;; Commentary:
-;;
+;;
;;; Code:
-;;
+;;
(if (and (featurep 'xemacs)
(featurep 'dragdrop))
(require 'wl-dnd))
(require 'wl-vars)
-(provide 'wl-highlight)
+(provide 'wl-highlight) ; circular dependency
(eval-when-compile
- (if wl-on-xemacs
- (require 'wl-xmas)
- (if wl-on-nemacs
- (require 'wl-nemacs)
- (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))
+ (cond (wl-on-xemacs
+ (require 'wl-xmas))
+ (wl-on-emacs21
+ (require 'wl-e21))
+ (t
+ (require 'wl-mule)))
(defun-maybe wl-dnd-set-drop-target (a b))
(defun-maybe wl-dnd-set-drag-starter (a b)))
;; 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)
(((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)
: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)))
: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))
(((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)
: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
'(
: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)
: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
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)))))
+(defun wl-delete-all-overlays ()
+ "Delete all momentary overlays."
+ (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)))))
-(defmacro defun-hilit2 (name &rest everything-else)
- "Define a function for highlight w/o nemacs."
- (if wl-on-nemacs
- () ; noop
- (` (defun (, name) (,@ everything-else)))))
-
-(defun-hilit wl-highlight-summary-displaying ()
+(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))))
-
-(defun-hilit2 wl-highlight-folder-group-line (numbers)
- (if wl-highlight-group-folder-by-numbers
- (let (fsymbol bol eol)
- (beginning-of-line)
- (setq bol (point))
- (save-excursion (end-of-line) (setq eol (point)))
- (setq fsymbol
- (let ((unsync (nth 0 numbers))
- (unread (nth 1 numbers)))
- (cond ((and unsync (eq unsync 0))
- (if (and unread (> unread 0))
- 'wl-highlight-folder-unread-face
- 'wl-highlight-folder-zero-face))
- ((and unsync
- (>= unsync wl-folder-many-unsync-threshold))
- 'wl-highlight-folder-many-face)
- (t
- 'wl-highlight-folder-few-face))))
- (put-text-property bol eol 'face fsymbol))
- (let ((highlights (list "opened" "closed"))
- fregexp fsymbol bol eol matched type extent num type)
- (beginning-of-line)
- (setq bol (point))
- (save-excursion (end-of-line) (setq eol (point)))
- (catch 'highlighted
- (while highlights
- (setq fregexp (symbol-value
- (intern (format "wl-highlight-folder-%s-regexp"
- (car highlights)))))
- (setq fsymbol (intern (format "wl-highlight-folder-%s-face"
- (car highlights))))
- (when (looking-at fregexp)
- (put-text-property bol eol 'face fsymbol)
- (setq matched t)
- (throw 'highlighted nil))
- (setq highlights (cdr highlights)))))))
-
-(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))))
+ (overlay-put ov 'face 'wl-highlight-summary-displaying-face)
+ (overlay-put ov 'evaporate t)
+ (overlay-put ov 'wl-momentary-overlay t))))
+
+(defun wl-highlight-folder-group-line (numbers)
+ (end-of-line)
+ (let ((eol (point))
+ bol)
+ (beginning-of-line)
+ (setq bol (point))
+ (let ((text-face (cond ((looking-at wl-highlight-folder-opened-regexp)
+ 'wl-highlight-folder-opened-face)
+ ((looking-at wl-highlight-folder-closed-regexp)
+ 'wl-highlight-folder-closed-face))))
+ (if (and wl-highlight-folder-by-numbers
+ (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" eol t))
+ (let* ((unsync (nth 0 numbers))
+ (unread (nth 1 numbers))
+ (face (cond ((and unsync (zerop unsync))
+ (if (and unread (> unread 0))
+ 'wl-highlight-folder-unread-face
+ 'wl-highlight-folder-zero-face))
+ ((and unsync
+ (>= unsync wl-folder-many-unsync-threshold))
+ 'wl-highlight-folder-many-face)
+ (t
+ 'wl-highlight-folder-few-face))))
+ (if (numberp wl-highlight-folder-by-numbers)
+ (progn
+ (put-text-property bol (match-beginning 0) 'face text-face)
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'face face))
+ ;; Remove previous face.
+ (put-text-property bol (match-end 0) 'face nil)
+ (put-text-property bol (match-end 0) 'face face)))
+ (put-text-property bol eol 'face text-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)))
-
-(defun-hilit2 wl-highlight-summary-current-line (&optional smark regexp temp-too)
+ (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 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
(wl-highlight-folder-current-line)
(forward-line 1)))))))
-(if (not wl-on-nemacs)
- (defsubst wl-delete-all-overlays ()
- (mapcar (lambda (x)
- (delete-overlay x))
- (overlays-in (point-min) (point-max)))))
-
-(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)
(match-beginning 1)
(match-end 1)))
(setq wl-folder-buffer-cur-point (point))
- (overlay-put ov 'face 'wl-highlight-folder-path-face))
+ (overlay-put ov 'face 'wl-highlight-folder-path-face)
+ (overlay-put ov 'evaporate t)
+ (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)
- (setq i (+ i 1))
- (setq percent (/ (* i 100) lines))
- (if (eq (% percent 5) 0)
- (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))
+ (end (or (save-excursion (re-search-forward "^$" nil t)
+ (point))
(point-max))))
(wl-highlight-message beg end nil)
- (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-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)
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)
(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
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 ()
(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