X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-highlight.el;h=2c2dba4d613498629542d72fa5a0449438d2a2f7;hb=17d892dc665511c9c8fe2c9cd16a7d1c1d087c8c;hp=ff027e0ab42082cf84ea8b309a0538fdba46892c;hpb=f2d9989e641d5bd8349a35bac0786d798cf626ba;p=elisp%2Fwanderlust.git diff --git a/wl/wl-highlight.el b/wl/wl-highlight.el index ff027e0..2c2dba4 100644 --- a/wl/wl-highlight.el +++ b/wl/wl-highlight.el @@ -1,6 +1,6 @@ ;;; 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 ;; Author: Yuuichi Teranishi @@ -189,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) @@ -200,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) @@ -219,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))) @@ -340,7 +352,7 @@ :group 'wl-summary-faces :group 'wl-faces) -;; answered +;; answered (wl-defface wl-highlight-summary-answered-face '((((type tty) (background dark)) @@ -353,7 +365,35 @@ (: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 @@ -594,30 +634,27 @@ :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) @@ -748,6 +785,16 @@ :group 'wl-message-faces :group 'wl-faces) +(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 "[ ]*\\([-%\\+]\\)\\(.*\\):.*$") @@ -820,84 +867,130 @@ (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. @@ -967,11 +1060,11 @@ Variables used: "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) @@ -1048,17 +1141,25 @@ Returns start point of signature." (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) @@ -1075,23 +1176,23 @@ Returns start point of signature." 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 @@ -1124,7 +1225,7 @@ interpreted as cited text.)" ;; 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))) @@ -1134,7 +1235,7 @@ interpreted as cited text.)" (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) @@ -1158,7 +1259,7 @@ interpreted as cited text.)" (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))) @@ -1217,6 +1318,7 @@ 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))