-;;; wl-highlight.el -- Hilight modules for Wanderlust.
+;;; wl-highlight.el --- Hilight modules for Wanderlust.
-;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+;; Yuuichi Teranishi <teranisi@gohome.org>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: mail, net news
(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)))
: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)
+
;; obsolete.
(wl-defface wl-highlight-summary-temp-face
'(
"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)
(defvar wl-highlight-folder-closed-regexp " *\\(\\[\\+\\]\\)")
(defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$")
-(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-citation-face-list
'(wl-highlight-message-cited-text-1
wl-highlight-message-cited-text-2
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 ()
"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)
(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)
(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)))
+(defun wl-highlight-summary-line-string (line mark temp-mark indent)
+ (let (fsymbol action)
+ (cond ((and (string= temp-mark wl-summary-score-over-mark)
+ (member mark (list elmo-msgdb-unread-cached-mark
+ elmo-msgdb-unread-uncached-mark
+ elmo-msgdb-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)))
+ ((and (string= temp-mark wl-summary-score-below-mark)
+ (member mark (list elmo-msgdb-unread-cached-mark
+ elmo-msgdb-unread-uncached-mark
+ elmo-msgdb-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 action (assoc temp-mark wl-summary-mark-action-list))
+ (setq fsymbol (nth 5 action)))
+ ((string= mark elmo-msgdb-new-mark)
(setq fsymbol 'wl-highlight-summary-new-face))
- ((member mark (list wl-summary-unread-cached-mark
- wl-summary-unread-uncached-mark))
+ ((member mark (list elmo-msgdb-unread-cached-mark
+ elmo-msgdb-unread-uncached-mark))
(setq fsymbol 'wl-highlight-summary-unread-face))
- ((or (string= mark wl-summary-important-mark))
+ ((member mark (list elmo-msgdb-answered-cached-mark
+ elmo-msgdb-answered-uncached-mark))
+ (setq fsymbol 'wl-highlight-summary-answered-face))
+ ((or (string= mark elmo-msgdb-important-mark))
(setq fsymbol 'wl-highlight-summary-important-face))
- ((string= temp-mark "-")
+ ((string= temp-mark wl-summary-score-below-mark)
(setq fsymbol 'wl-highlight-summary-low-read-face))
- ((string= temp-mark "+")
+ ((string= temp-mark wl-summary-score-over-mark)
(setq fsymbol 'wl-highlight-summary-high-read-face))
(t (if (zerop (length indent))
(setq fsymbol 'wl-highlight-summary-thread-top-face)
(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)
+(defun wl-highlight-summary-current-line ()
(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)
+ (deactivate-mark nil)
+ fsymbol action bol eol matched thread-top looked-at dest ds)
(end-of-line)
(setq eol (point))
(beginning-of-line)
(setq bol (point))
- (if smark
- (setq status-mark smark)
- (setq looked-at (looking-at sregexp))
- (when looked-at
- (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)))))
+ (setq status-mark (wl-summary-persistent-mark))
+ (setq temp-mark (wl-summary-temp-mark))
+ (when (setq action (assoc temp-mark wl-summary-mark-action-list))
+ (setq fsymbol (nth 5 action))
+ (setq dest (nth 2 action)))
(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)))
+ ((and (string= temp-mark wl-summary-score-over-mark)
+ (member status-mark (list elmo-msgdb-unread-cached-mark
+ elmo-msgdb-unread-uncached-mark
+ elmo-msgdb-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)))
+ ((and (string= temp-mark wl-summary-score-below-mark)
+ (member status-mark (list elmo-msgdb-unread-cached-mark
+ elmo-msgdb-unread-uncached-mark
+ elmo-msgdb-new-mark)))
(setq fsymbol 'wl-highlight-summary-low-unread-face))
- ((string= status-mark wl-summary-new-mark)
+ ((string= status-mark elmo-msgdb-new-mark)
(setq fsymbol 'wl-highlight-summary-new-face))
- ((member status-mark (list wl-summary-unread-cached-mark
- wl-summary-unread-uncached-mark))
+ ((member status-mark (list elmo-msgdb-unread-cached-mark
+ elmo-msgdb-unread-uncached-mark))
(setq fsymbol 'wl-highlight-summary-unread-face))
- ((string= status-mark wl-summary-important-mark)
+ ((member status-mark (list elmo-msgdb-answered-cached-mark
+ elmo-msgdb-answered-uncached-mark))
+ (setq fsymbol 'wl-highlight-summary-answered-face))
+ ((string= status-mark elmo-msgdb-important-mark)
(setq fsymbol 'wl-highlight-summary-important-face))
;; score mark
- ((string= temp-mark "-")
+ ((string= temp-mark wl-summary-score-below-mark)
(setq fsymbol 'wl-highlight-summary-low-read-face))
- ((string= temp-mark "+")
+ ((string= temp-mark wl-summary-score-over-mark)
(setq fsymbol 'wl-highlight-summary-high-read-face))
;;
- (t (if (and looked-at
- (string= (buffer-substring
- (match-beginning 3)
- (match-end 3)) ""))
+ (t (if (null
+ (wl-thread-entity-get-parent-entity
+ (wl-thread-get-entity (wl-summary-message-number))))
(setq fsymbol 'wl-highlight-summary-thread-top-face)
(setq fsymbol 'wl-highlight-summary-normal-face)))))
(put-text-property bol eol 'face fsymbol)
+ (when dest
+ (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))
(if wl-use-highlight-mouse-line
(put-text-property bol
-;;; Use bol instead of (1- (match-end 0))
-;;; (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)
+(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)))))))
-(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)
(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-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
-"
+ wl-highlight-summary-new-face new messages"
(if (< end start)
(let ((s start)) (setq start end end s)))
(let (lines too-big gc-message e p hend i percent)
(setq i 0)
(while (and (not (eobp))
(< (point) end))
- (wl-highlight-summary-current-line nil nil
- (or wl-summary-lazy-highlight
- wl-summary-scored))
- (when (and (not wl-summary-lazy-highlight)
- (> lines elmo-display-progress-threshold))
- (setq i (+ i 1))
- (setq percent (/ (* i 100) lines))
- (if (or (zerop (% percent 5)) (= i lines))
- (elmo-display-progress
- 'wl-highlight-summary "Highlighting..."
- percent)))
+ (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'"
- (if wl-summary-highlight
- (with-current-buffer (window-buffer win)
- (wl-highlight-summary (window-start win)
- (save-excursion
- (goto-char (window-start win))
- (forward-line (frame-height))
- (point)))
- (set-buffer-modified-p nil))))
+ (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))
(point-max))))
(wl-highlight-message beg end nil)
(unless for-draft
- (wl-highlight-message-add-buttons-to-header beg end)
- (when wl-highlight-x-face-func
- (funcall wl-highlight-x-face-func beg end)))
+ (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)
(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
(real-end end)
current beg
e p hend)
- (if too-big
- nil
+ (unless too-big
(save-excursion
(save-restriction
(widen)
;; take off signature
(if (and hack-sig (not too-big))
- (setq end (funcall wl-highlight-signature-search-func
+ (setq end (funcall wl-highlight-signature-search-function
(- end wl-max-signature-size) end)))
- (if hack-sig
+ (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)
(goto-char start)
(while (and (not body-only)
(not (eobp)))
- (cond
- ((looking-at "^[^ \t\n:]+[ \t]*:")
- (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)))
- (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 p hend 'face
- (cdar regexp-alist))
- (throw 'match t))
- (setq regexp-alist (cdr regexp-alist)))
- (throw 'match nil))))
- (t
- (put-text-property
- p hend 'face 'wl-highlight-message-header-contents)))
- (goto-char hend))
- ;; ignore non-header field name lines
- (t (forward-line 1))))))
+ (if (looking-at "^[^ \t\n:]+[ \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