;;; wl-highlight.el --- Hilight modules for Wanderlust.
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Yuuichi Teranishi <teranisi@gohome.org>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
;; 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)
-;; answered
+;; answered
(wl-defface wl-highlight-summary-answered-face
'((((type tty)
(background dark))
(:foreground "khaki4")))
"Face used for displaying answered messages."
:group 'wl-summary-faces
- :group 'wl-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)
:group 'wl-message-faces
:group 'wl-faces)
-(defvar wl-highlight-folder-opened-regexp " *\\(\\[\\-\\]\\)")
-(defvar wl-highlight-folder-closed-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-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-9
wl-highlight-message-cited-text-10))
-(defmacro wl-delete-all-overlays ()
+(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)))))
+ (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)
(put-text-property bol (match-end 0) 'face face)))
(put-text-property bol eol 'face text-face)))))
-(defsubst wl-highlight-summary-line-face-spec (flags temp-mark indent)
+(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)."
- (let (action)
- (if (setq action (assoc temp-mark wl-summary-mark-action-list))
- (cons (nth 5 action) (nth 2 action))
- (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-flag-priority-list)
- result)
- (while (and (null result) priorities)
- (when (memq (car priorities) flags)
- (setq result
- (case (car priorities)
- (new
- '(wl-highlight-summary-new-face))
- (important
- '(wl-highlight-summary-important-face))
- (answered
- '(wl-highlight-summary-answered-face))
- (unread
- '(wl-highlight-summary-unread-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)))))))
-
-(defun wl-highlight-summary-line-string (line flags temp-mark indent)
+ (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
- flags
+ 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 wl-highlight-summary-current-line ()
+(defun wl-highlight-summary-current-line (&optional number status)
(interactive)
(save-excursion
(let ((inhibit-read-only t)
(case-fold-search nil)
(deactivate-mark nil)
- (number (wl-summary-message-number))
+ (number (or number (wl-summary-message-number)))
bol eol spec)
- (end-of-line)
- (setq eol (point))
- (beginning-of-line)
- (setq bol (point))
- (setq spec (wl-highlight-summary-line-face-spec
- (elmo-message-flags wl-summary-buffer-elmo-folder
- number)
- (wl-summary-temp-mark)
- (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-use-dnd
- (wl-dnd-set-drag-starter bol eol)))))
+ (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.
"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"
+ wl-highlight-summary-new-face new messages
+ wl-highlight-summary-*-flag-face flagged messages"
(if (< end start)
(let ((s start)) (setq start end end s)))
(let (lines too-big gc-message e p hend i percent)
(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)
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
;; If this search fails then the narrowing performed above
;; is sufficient
(if (re-search-forward (format
- "^$\\|%s"
+ "^\\(%s\\)?$"
(regexp-quote mail-header-separator))
nil t)
(narrow-to-region (point-min) (match-beginning 0)))
(goto-char start)
(while (and (not body-only)
(not (eobp)))
- (if (looking-at "^[^ \t\n:]+[ \t]*:")
+ (if (looking-at "^[^ \t\n:]+[ \t]*:[ \t]*")
(progn
(put-text-property (match-beginning 0) (match-end 0)
'face 'wl-highlight-message-headers)
(let (prefix prefix-face-alist pair end)
(while (not (eobp))
(cond
- ((looking-at mail-header-separator)
+ ((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)))
(inhibit-read-only t))
(put-text-property beg end 'mouse-face 'highlight)))
+
(require 'product)
(product-provide (provide 'wl-highlight) (require 'wl-version))