[Mew-dist 17702] Re: mew-fancy-summary.el
Shun-ichi TAHARA ( 田原 俊一 )
jado at example.com
2001年 6月 7日 (木) 01:21:38 JST
From: Shun-ichi TAHARA (田原 俊一) <jado at example.com>
Message-Id: <20010606.134307.607963181.z1980163 at example.com>
> ちょっと気が向いたので、mew-summary-hl に手を入れてみました。
>
> 中身がまるっきり変わってしまいましたので、名前を mew-fancy-summary に
> 変えて流します。
ふと気が付いたのですが、mew-summary-hl でも mew-fancy-summary でも、
lazy-lock を有効にして使っていると、添付部分の行に色が付かないときがあ
るようです。
添付部分を展開したときとか、. や : などで再解析したときによく発生しま
す。カーソルを別の行に移動させるときちんと色が付くのですが。
代わりに lazy-shot を使えば問題は起きないのですが、ちょっと色が付くタ
イミングが遅れるのが玉に傷ですね。
XEmacsのバージョンは 21.4.3 ですが、おそらく XEmacs の不具合でしょう。
mew-fancy-summary ですが、コメントを追加したのと、色の塗り方を若干変更
しました。まるごと添付します。
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
田原 俊一 jado at example.com, shunichi_tahara at example.com
http://flowernet.gr.jp/jado/
FingerPrint: 16 9E 70 3B 05 86 5D 08 B8 4C 47 3A E7 E9 8E D9
￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣
-------------- next part --------------
;;; mew-fancy-summary.el -*- Emacs-Lisp -*-
;;;
;;; Author:
;;; Shun-ichi TAHARA <jado at example.com>
;;;
;;; Time-stamp: <01/06/07 00:59:57 jado at example.com>
;;;
;;; Commentary:
;;; Fontify Mew summary buffer.
;;; Originated from mew-summary-hl.el by Hideyuki SHIRAI <shirai at example.com>.
;;; HOW TO USE:
;;;
;;; 1. BE SURE TO USE lazy-lock or lazy-shot.
;;;
;;; ;; lazy-lock
;;; (eval-after-load "mew-fancy-summary.el"
;;; '(lambda ()
;;; (require 'font-lock)
;;; (add-hook 'font-lock-mode-hook
;;; '(lambda ()
;;; (if (or (mew-summary-p) (mew-virtual-p))
;;; (turn-on-lazy-lock))))
;;; (if mew-xemacs-p
;;; (setq lazy-lock-minimum-size 0))))
;;;
;;; ;; lazy-shot
;;; (eval-after-load "mew-fancy-summary.el"
;;; '(lambda ()
;;; (require 'font-lock)
;;; (add-hook 'font-lock-mode-hook
;;; '(lambda ()
;;; (if (or (mew-summary-p) (mew-virtual-p))
;;; (turn-on-lazy-shot))))
;;; (setq lazy-shot-verbose nil)
;;; (setq lazy-shot-stealth-verbose nil)))
;;;
;;; 2. Set some customize variables as you like.
;;;
;;; 3. Require this file in your init file of Emacsen.
;;;
;;; (add-hook 'mew-init-hook '(lambda () (require 'mew-fancy-summary)))
;;;
;;; * To change the default face, copy below to your "theme" file and
;;; edit it as you like.
;;;
;;; (custom-set-faces
;;; '(mew-fancy-summary-face-marginal
;;; ((((class color) (type tty)) nil)
;;; (((class color) (background light)) (:foreground "gray50"))
;;; (((class color) (background dark)) (:foreground "gray50"))
;;; (t nil)))
;;; '(mew-fancy-summary-face-type
;;; ((((class color) (type tty)) (:background "yellow" :inverse-video t))
;;; (((class color) (background light)) (:background "Gold"))
;;; (((class color) (background dark)) (:background "DarkOrange4"))
;;; (t nil)))
;;; '(mew-fancy-summary-face-truncated
;;; ((((class color) (type tty)) (:background "red" :inverse-video t))
;;; (((class color) (background light)) (:background "OrangeRed"))
;;; (((class color) (background dark)) (:background "Firebrick"))
;;; (t (:inverse-video t))))
;;; '(mew-fancy-summary-face-special
;;; ((((class color) (type tty)) (:foreground "cyan" :bold t))
;;; (((class color) (background light)) (:foreground "MediumBlue" :bold t))
;;; (((class color) (background dark)) (:foreground "SkyBlue" :bold t))
;;; (t (:bold t))))
;;; '(mew-fancy-summary-face-tag
;;; ((((class color) (type tty)) (:foreground "green" :bold t))
;;; (((class color) (background light)) (:foreground "ForestGreen" :bold t))
;;; (((class color) (background dark)) (:foreground "LimeGreen" :bold t))
;;; (t (:bold t)))))
;;;
;;; * You may want to specify like below in your "theme" file
;;; to make the marked lines stand out:
;;;
;;; (custom-set-faces
;;; '(mew-face-mark-review
;;; ((((class color) (type tty)) (:background "cyan" :inverse-video t))
;;; (((class color) (background light)) (:background "SkyBlue"))
;;; (((class color) (background dark)) (:background "MediumBlue"))
;;; (t (:inverse-video t))))
;;; '(mew-face-mark-multi
;;; ((((class color) (type tty)) (:background "magenta" :inverse-video t))
;;; (((class color) (background light)) (:background "violet"))
;;; (((class color) (background dark)) (:background "DarkViolet"))
;;; (t (:inverse-video t))))
;;; '(mew-face-mark-delete
;;; ((((class color) (type tty)) (:background "red" :inverse-video t))
;;; (((class color) (background light)) (:background "OrangeRed"))
;;; (((class color) (background dark)) (:background "Firebrick"))
;;; (t (:inverse-video t))))
;;; '(mew-face-mark-unlink
;;; ((((class color) (type tty)) (:background "yellow" :inverse-video t))
;;; (((class color) (background light)) (:background "Gold"))
;;; (((class color) (background dark)) (:background "DarkOrange4"))
;;; (t (:inverse-video t))))
;;; '(mew-face-mark-refile
;;; ((((class color) (type tty)) (:background "green" :inverse-video t))
;;; (((class color) (background light)) (:background "LimeGreen"))
;;; (((class color) (background dark)) (:background "ForestGreen"))
;;; (t (:inverse-video t)))))
(eval-when-compile (require 'mew))
(defconst mew-fancy-summary-version "mew-fancy-summary 0.02")
;;; User-customizable variables
(defvar mew-fancy-summary-face-spec
'((num . mew-fancy-summary-face-marginal)
(size . mew-fancy-summary-face-marginal)
(type . mew-fancy-summary-face-type)
(truncated . mew-fancy-summary-face-truncated)
(thread . mew-fancy-summary-face-marginal)
(special . mew-fancy-summary-face-special)
(ml . mew-fancy-summary-face-tag)
(attach . mew-fancy-summary-face-marginal))
"*An alist of face specs for fancy-summary mode. Each entry consists
of a pair of string or symbol and face.
If you want to highlight the raw string in 'mew-scan-form', put the
string and the corresponding face in this alist (and also define the
face if needed, see below).
Symbol is one of those: 'num' for a message number, 'size' for the
message size, 'type' for a mark of content type (except 'T' mark),
'truncated' for 'T' mark, 'thread' for a thread indent, 'special' for
the special person (see also 'mew-fancy-summary-special-*'), 'ml' for
a subject prefix of ML (see also 'mew-fancy-summary-ml-regex'), and
'attach' for a attachment line. Among them, 'num' and 'size' can be
specified in 'mew-scan-form'. And the others, which can be in it, for
example, 'date', 'subj', and so on, also can be specified to override
the default highlight configuration.
If tne entry corresponding to certain header field is not found, the
search falls back to 'mew-field-spec' with the header field name as
a default highlight configuration. So if you want not to highlight a
certain field (e.g. Date:), add an entry like below:
(date . mew-fancy-summary-face-nothing)
or if you want to make a different face from those of Message mode,
add an entry like below:
(from . mew-fancy-summary-face-from)
The symbol to set in the entry must be corresponding to the header
field (see also 'mew-fancy-summary-face-spec-key-alist'). You may have
to define the corresponding face in your 'theme' file like below:
(defface mew-fancy-summary-face-from
'((((class color) (type tty)) (:foreground \"red\" :bold t))
(((class color) (background light)) (:foreground \"Firebrick\" :bold t))
(((class color) (background dark)) (:foreground \"OrangeRed\" :bold t))
(t (:bold t)))
nil)")
(defvar mew-fancy-summary-special-persons nil
"*Specify the 'special' person.
If the From: header corresponding to 'from' part matches a member of
this list, 'special' entry of 'mew-fancy-summary-face-spec' is used
for highlighting.")
(defvar mew-fancy-summary-special-addrbook nil
"*If non-nil, nicknames in the addrbook are treated as 'special'
person.")
(defvar mew-fancy-summary-special-to t
"*If non-nil, mails sent to 'special' person are highlighted
specially.")
(defvar mew-fancy-summary-ml-regex "[\[(][^])\n\r]*[\])]"
"*Prefix of the subject of mails posted to ML.")
;;; Faces (change them in your 'theme' file)
(defface mew-fancy-summary-face-nothing nil
"*A face for the part of Summary buffer without highlight.")
(defface mew-fancy-summary-face-marginal
'((((class color) (type tty)) nil)
(((class color) (background light)) (:foreground "gray50"))
(((class color) (background dark)) (:foreground "gray50"))
(t nil))
"*A face for marginal part of Summary buffer.")
(defface mew-fancy-summary-face-type
'((((class color) (type tty)) (:background "yellow" :inverse-video t))
(((class color) (background light)) (:background "Gold"))
(((class color) (background dark)) (:background "DarkOrange4"))
(t nil))
"*A face for 'T' mark at 'type' part of Summary buffer.")
(defface mew-fancy-summary-face-truncated
'((((class color) (type tty)) (:background "red" :inverse-video t))
(((class color) (background light)) (:background "OrangeRed"))
(((class color) (background dark)) (:background "Firebrick"))
(t (:inverse-video t)))
"*A face for 'type' part of Summary buffer (except 'T' mark).")
(defface mew-fancy-summary-face-special
'((((class color) (type tty)) (:foreground "cyan" :bold t))
(((class color) (background light)) (:foreground "MediumBlue" :bold t))
(((class color) (background dark)) (:foreground "SkyBlue" :bold t))
(t (:bold t)))
"*A face for special person in the 'from' part of Summary buffer.")
(defface mew-fancy-summary-face-tag
'((((class color) (type tty)) (:foreground "green" :bold t))
(((class color) (background light)) (:foreground "ForestGreen" :bold t))
(((class color) (background dark)) (:foreground "LimeGreen" :bold t))
(t (:bold t)))
"*A face for tag part of Summary buffer.")
;;; End of user-customizable stuffs
;;; Constants
(defconst mew-fancy-summary-invisible-fake-function
'mew-fancy-summary-remove-invisible)
(defconst mew-fancy-summary-face-spec-key-alist
'((from . "From:")
(to . "To:")
(subj . "Subject:")
(date . "Date:")
(year . "Date:")
(time . "Date:")))
;;; Internal variables
(defvar mew-fancy-summary-special-list nil)
(defvar mew-fancy-summary-scan-form nil)
(make-variable-buffer-local 'mew-fancy-summary-scan-form)
(defvar mew-fancy-summary-thread-column nil)
(make-variable-buffer-local 'mew-fancy-summary-thread-column)
;;; Initialization
(add-hook 'mew-summary-mode-hook 'mew-fancy-summary-enable)
(add-hook 'mew-virtual-mode-hook 'mew-fancy-summary-enable)
(add-hook 'mew-thread-display-hook 'mew-fancy-summary-thread-enable)
(add-hook 'mew-pop-sentinel-hook 'mew-fancy-summary-block)
(add-hook 'mew-scan-sentinel-hook 'mew-fancy-summary-block)
(setq mew-use-highlight-mark nil) ;; Hilight mark by itself, not by Mew
(defalias 'mew-summary-cook-region 'mew-fancy-summary-make-invisible-region)
(defalias 'mew-highlight-mark-line 'mew-fancy-summary-mark-line)
(cond
((fboundp 'font-lock-fontify-block)
(defalias 'mew-fancy-summary-block 'font-lock-fontify-block))
(t
;; Bogus, but for XEmacs
(defun mew-fancy-summary-block ()
(font-lock-mode 1))))
;;; Setup
(defadvice mew-addrbook-setup (after hl-setup activate)
"*Setup fancy-summary when starting up Mew or executing \"Z\"."
(mew-fancy-summary-regex-setup)
(mew-fancy-summary-special-setup))
(defun mew-fancy-summary-regex-setup ()
(setq mew-fancy-summary-thread-regex
(concat "\\("
(if mew-use-fancy-thread
(mapconcat
'(lambda (indent)
(regexp-quote indent))
mew-fancy-thread-indent-strings "\\|")
mew-thread-indent-string)
"\\)+")))
(defun mew-fancy-summary-special-setup ()
(setq mew-fancy-summary-special-list mew-fancy-summary-special-persons)
(if mew-fancy-summary-special-addrbook
(let ((addrbook mew-addrbook-alist) nickname)
(while addrbook
(setq nickname (nth 2 (car addrbook)))
(if (and (stringp nickname)
(not (member nickname mew-fancy-summary-special-list)))
(setq mew-fancy-summary-special-list
(cons nickname mew-fancy-summary-special-list)))
(setq addrbook (cdr addrbook))))))
;;; Workarounds about highlighting in Mew
(defun mew-fancy-summary-remove-invisible ()
"*Remove the invisible hook in Mew."
(remove-hook 'window-scroll-functions 'mew-summary-cook-window 'local)
(remove-hook 'pre-idle-hook 'mew-summary-cook-window))
(defun mew-fancy-summary-make-invisible-region (beg end &optional interrupt)
"*Faster invisible function for summary with many text properties."
(if (and (memq major-mode
'(mew-summary-mode mew-virtual-mode mew-refile-view-mode))
mew-summary-buffer-raw)
(let ((inhibit-point-motion-hooks t) ret)
(catch 'loop
(mew-elet
(save-excursion
(goto-char beg)
(while (and (<= (point) end) ;; Emacs 21's bug?
(search-forward "\r" end t))
(if (and interrupt (input-pending-p))
(throw 'loop (setq ret t))
(unless (get-text-property (match-beginning 0) 'invisible)
(put-text-property (match-beginning 0)
(progn (end-of-line) (point))
'invisible t)))))))
(set-buffer-modified-p nil)
ret)))
(defun mew-fancy-summary-mark-line (mark)
"*Remove property so that font-lock works properly, because
highlighting mark line is done by mew-fancy-summary."
(remove-text-properties
(save-excursion (beginning-of-line) (point))
(save-excursion (end-of-line) (point))
'(lazy-lock nil lazy-lock-fontified nil fontified nil)))
;;; Activating fancy summary
(defun mew-fancy-summary-enable ()
"*Activate mew-fancy-summary in summary or virtual buffer."
(if (mew-thread-p)
(font-lock-mode -1) ;; Acceleration
(set (make-local-variable 'font-lock-fontify-buffer-function)
'mew-fancy-summary-buffer)
(set (make-local-variable 'font-lock-fontify-region-function)
'mew-fancy-summary-region)
(setq mew-fancy-summary-scan-form
(mew-summary-scan-form (substring (mew-summary-folder-name t) 1)))
(setq mew-fancy-summary-thread-column -1)
(funcall mew-fancy-summary-invisible-fake-function)
(font-lock-mode 1)))
(defun mew-fancy-summary-thread-enable ()
"*Activate mew-fancy-summary in thread buffer."
(sit-for 0) ;; Need redraw?
(set (make-local-variable 'font-lock-fontify-buffer-function)
'mew-fancy-summary-buffer)
(set (make-local-variable 'font-lock-fontify-region-function)
'mew-fancy-summary-region)
(setq mew-fancy-summary-scan-form
(mew-summary-scan-form (substring (mew-summary-folder-name t) 1)))
(setq mew-fancy-summary-thread-column
(mew-summary-scan-form
(substring (mew-summary-folder-name t) 1) 'column))
(funcall mew-fancy-summary-invisible-fake-function)
(font-lock-mode 1))
;;; Main
(defun mew-fancy-summary-buffer ()
"*Highlight summary buffer with font-lock-mode."
(interactive)
(mew-fancy-summary-region (point-min) (point-max)))
(defun mew-fancy-summary-region (beg end &optional loudly)
"*Highlight the region of summary buffer with font-lock-mode."
(interactive "r")
(let ((pos (point)) linebeg lineend col)
(when (memq major-mode
'(mew-summary-mode mew-virtual-mode mew-refile-view-mode))
(mew-elet
(goto-char beg)
(beginning-of-line)
(setq beg (point))
;; Make invisible after \r
(while (and (<= (point) end) ;; Emacs 21's bug?
(search-forward "\r" end t))
(unless (get-text-property (match-beginning 0) 'invisible)
(put-text-property (match-beginning 0)
(progn (end-of-line) (point))
'invisible t)))
(goto-char beg)
;; Highlight each line
(while (< (point) end)
(setq linebeg (point))
(setq col 0)
(cond
;; Normal line
((and (not (mew-in-decode-syntax-p))
(looking-at mew-regex-msg)
(not (looking-at mew-regex-msg-mark)))
(let ((form mew-fancy-summary-scan-form) entry)
(while form
(setq entry (car form))
(if (= col mew-fancy-summary-thread-column)
(setq col (+ col (mew-fancy-summary-do-highlight 'thread))))
(setq col (+ col (mew-fancy-summary-do-highlight entry)))
(setq form (cdr form))))
(looking-at "[^\r\n]*")
(setq lineend (match-end 0)))
;; Marked line
((and (not (mew-in-decode-syntax-p))
(looking-at mew-regex-msg-mark))
(let ((mark (string-to-char (mew-match 2))))
(looking-at "[^\r\n]*")
(setq lineend (match-end 0))
(put-text-property linebeg lineend
'face (mew-highlight-mark-get-face mark))))
;; Others (usually, expanded multi-part)
(t
(unless (and (functionp 'mew-fancy-summary-external-function)
;; Highlight thread separator or folder of refile-view
;; by your custom function
(funcall mew-fancy-summary-external-function))
(setq lineend (progn (end-of-line) (point)))
(put-text-property linebeg lineend
'face (mew-fancy-summary-get-face 'attach))
(when mew-use-highlight-mouse-line
(remove-text-properties linebeg (min (1+ lineend) (point-max))
'(mouse-face))))))
(when mew-use-highlight-mouse-line
(put-text-property linebeg lineend
'mouse-face mew-highlight-mouse-line-face))
(forward-line)))
(set-buffer-modified-p nil)
(goto-char pos))))
;;;
(defun mew-fancy-summary-do-highlight (entry)
(let ((l 0) (col (current-column))
(spec (mew-fancy-summary-get-spec entry)) sentry)
(while spec
(setq sentry (car spec))
(if (stringp (car sentry))
(when (looking-at (car sentry))
(put-text-property (match-beginning 0) (match-end 0)
'face (cdr sentry))
(goto-char (match-end 0))
(setq l (+ l (- (current-column) col)))
(setq col (current-column)))
(let ((beg (point))
(len (car sentry)))
(setq col (+ col (- len l)))
(move-to-column col)
(setq l len)
(if (cdr sentry)
(put-text-property beg (point) 'face (cdr sentry)))))
(setq spec (cdr spec)))
l))
(defun mew-fancy-summary-get-spec (entry)
(let ((len (cond
((stringp entry) (length entry))
((listp entry) (abs (car entry)))
(t 1)))
(elem (cond
((listp entry) (nth 1 entry))
(t entry)))
face)
(if (= len 0)
(setq len "[^\r\n]*[^ \r\n]")) ;; To the tail of line
(setq face (mew-fancy-summary-get-face elem))
(cond
((eq elem 'type)
(cond
((looking-at "T")
(list (cons len (mew-fancy-summary-get-face 'truncated))))
((looking-at "[^ ]")
(list (cons len face)))
(t
(list (cons len nil)))))
((eq elem 'thread)
(list (cons mew-fancy-summary-thread-regex face)))
((eq elem 'from)
(let ((entry (mew-buffer-substring
(point)
(save-excursion
(move-to-column (+ (current-column) len))
(point))))
(prelen (string-width mew-scan-form-from-me-prefix)) elen)
(if (string-match "[^\r\n]*[^ \r\n]" entry)
(setq entry (substring entry (match-beginning 0) (match-end 0)))
(setq entry ""))
(setq elen (string-width entry))
(if (not (and (> prelen 0) (>= elen prelen)
(equal (substring entry 0 prelen)
mew-scan-form-from-me-prefix)))
;; Mail to me
(if (mew-fancy-summary-special-p entry)
(list (cons elen (mew-fancy-summary-get-face 'special))
(cons len nil))
(list (cons elen face) (cons len nil)))
;; Mail from me
(setq face (mew-fancy-summary-get-face 'to))
(if (and mew-fancy-summary-special-to
(mew-fancy-summary-special-p (substring entry prelen)))
(list (cons prelen face)
(cons elen (mew-fancy-summary-get-face 'special))
(cons len nil))
(list (cons elen face) (cons len nil))))))
((eq elem 'subj)
(list (cons mew-fancy-summary-ml-regex (mew-fancy-summary-get-face 'ml))
(cons len face)))
(t
(list (cons len face))))))
(defun mew-fancy-summary-get-face (key)
(if (symbolp key)
(let ((skey (or (cdr (assoc key mew-fancy-summary-face-spec-key-alist))
key)))
(if (symbolp skey)
(cdr (assoc skey mew-fancy-summary-face-spec))
(or (cdr (assoc key mew-fancy-summary-face-spec))
(mew-nspec-valface (mew-nspec-by-key skey))
'mew-face-header-marginal)))
(cdr (assoc key mew-fancy-summary-face-spec))))
(defun mew-fancy-summary-special-p (key)
(if (> (string-width key) 0)
(let ((special mew-fancy-summary-special-list) entry)
(setq key (regexp-quote key))
(catch 'loop
(while special
(setq entry (car special))
(if (string-match key entry)
(throw 'loop t))
(setq special (cdr special)))
nil))
nil))
;;;
(provide 'mew-fancy-summary)
;;; Copyright Notice:
;; Copyright (C) 2001 Shun-ichi TAHARA <jado at example.com>
;; Copyright (C) 1999-2001 Hideyuki SHIRAI <shirai at example.com>
;; Copyright (C) 1994-2001 Mew developing team.
;; All rights reserved.
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; 3. Neither the name of the team nor the names of its contributors
;; may be used to endorse or promote products derived from this software
;; without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; mew-fancy-summary.el ends here
Mew-dist メーリングリストの案内