[Mew-dist 15519] Re: mew-guess-template
Shun-ichi GOTO
gotoh at example.com
2000年 12月 15日 (金) 12:55:16 JST
>>>>> at Fri, 15 Dec 2000 11:52:25 +0900
>>>>> 小幡 == OBATA Noboru <obata at example.com> said,
小幡> 後藤さん、hack ありがとうございます。早速パッチを当ててみました。
小幡さん、ありがとうございます。
でも、すいません、実はあのメールの後、おおあささんとまたしばしの
やりとりがありまして、小幡さんのパッチ相当の内容以外にも問題が
あったので対処していました。
# template のところで、file の byte数をpositionとして利用している
# 辺りが、よろしくなかったという不具合です。
Emacs 20.7 (Meadow) + (Mew 1.95b89 or Mew 1.94.2) および
Emacs 19.34 (mule) + Mew 1.94.2 で
動作が確認されてる版を添付します。
codeの内容的にはもっといじりたい、というか、整理したい(名称とかも)
ので、template や guess はMewのTODOの一つではありますし、アイディアの
雛型としてcontribに入れていただくとうれしいかも。
## ちなみに現在の mew-1.95betaのcontribは白井さんがほぼ独占状態(^^;
あと、
>>>>> at Fri, 15 Dec 2000 12:28:45 +0900
>>>>> 小幡 == OBATA Noboru <obata at example.com> said,
小幡> そう言えば、[Mew-dist 15438] の mew-guess.el の part も、途中で
小幡> 切れてしまっているようですが‥？
そう、Subject: [Mew-dist 15515] bug of mewencode -g
のそれが原因です。この件も、おおあささんとのやりとりで発覚しました。
ありがたいことです。
というわけで、bugがとれるまで x-gzip64の使用は注意した方が無難でしょう。
#というわけで、今回は生のまま添付します。
--- Regards,
Shun-ichi Goto <gotoh at example.com>
R&D Group, TAIYO Corp., Tokyo, JAPAN
-------------- next part --------------
;;; mew-guess.el --- Guess header and template file in draft for Mew
;; Author: OBATA Noboru <obata at example.com>
;; Created: Mar 22, 1999
;; Revised: Dec 14, 2000
;;; Commentary:
;; Shun-ichi GOTO <gotoh at example.com> さんに感謝します。
;; このパッケージは、ドラフトモードにおいて、既存のヘッダの内容から、他
;; のヘッダの内容を推測して書き換える機能を提供します。例えば、To: ヘッ
;; ダから From: を変更したり、Config: を挿入することができます。
;;
;; また、もうひとつの機能として、文頭にテキストファイル (テンプレート)
;; を挿入することができます。挿入するファイル名も、ヘッダから推測させる
;; ことができます。
;;
;; インストールの方法。
;;
;; - このファイルを emacs が見付けられる場所に置きます。
;;
;; - .emacs に次の記述を追加します。(define-key ...) はキーバインドの例
;; です。お好みに合わせて変えて下さい。
;;
;; (add-hook 'mew-init-hook
;; (lambda ()
;; (require 'mew-guess)
;; (define-key mew-draft-header-map "\C-c\C-v" 'mew-guess-template)
;; (define-key mew-draft-header-map "\C-c\C-d" 'mew-guess-header)
;; (define-key mew-draft-body-map "\C-c\C-v" 'mew-guess-template)
;; (define-key mew-draft-body-map "\C-c\C-d" 'mew-guess-header)))
;;
;; - また、返信時に返信もとのメッセージのヘッダ情報をguess対象にしたい
;; 場合は以下の設定を追加してください。
;;
;; (add-hook 'mew-draft-mode-hook 'mew-guess-prepare-for-reply)
;;
;; これにより、返信もとのメッセージのXxx:というヘッダはOriginal-Xxx:
;; という名前で参照可能になります。
;;
;; 設定の例。
;;
;; - ヘッダ推測の例。
;;
;; (setq mew-guess-header-alist
;; '(
;; ("From:"
;; ;; From: の推測のルール
;; ("To:"
;; ;; To: の内容が、"sorry@" にマッチしたら、From: の内容を
;; ;; "小幡 昇 <obata at example.com>" に書き
;; ;; 換えます。
;; ("sorry@" "小幡 昇 <obata at example.com>")
;; ;; 同様に、To: の内容が "@linux\\.or\\.jp" にマッチした
;; ;; ら、From: を "OBATA Noboru <obata at example.com>" に
;; ;; 書き換えます。
;; ("@linux\\.or\\.jp" "OBATA Noboru <obata at example.com>")
;; )
;; ("Config:"
;; ;; Config: の内容によって書き換えたい場合。
;; ("office" "OBATA Noboru <obata at example.com>"))
;; ;; 次の特別な記法によって、デフォルト値を指定します。
;; (t "OBATA Noboru <obata at example.com>"))
;; ))
;;
;; ※ "Config:" に関して: mew-1.95betaの途中でimを使わなくなったあた
;; りで、draftでは Config: というヘッダは使われなくなりましたが、
;; config という設定要素そのものは変数mew-draft-buffer-configとい
;; う変数として残っています。これを擬似的に "Config:"というヘッダ
;; として参照できるようになっているため、最新のmew-1.95betaでも
;; "Config:"は使用可能です。
;;
;; 置換後の文字列として、値として文字列を持つ変数名や、文字列を返す関数
;; 名やラムダ式を記述できます。例えば、次のように書けば Config: に
;; mew-config-imget の値を設定できます。
;;
;; (setq mew-guess-header-alist
;; '(
;; ("Config:"
;; (t mew-config-imget)
;; )
;; ))
;;
;; - テンプレート推測の例。
;;
;; (setq mew-guess-template-alist
;; '(("To:"
;; ;; To: の内容が "foo" にマッチしたら、文頭にファイル
;; ;; "~/.ff-foo" を挿入します。
;; ("foo" "~/.ff-foo")
;; ;; 同様。
;; ("bar" "~/.ff-bar")
;; )
;; ))
;;
;; - キーワード置換の例。上の方法では、推測のルールだけファイルを作らな
;; くてはいけないので、面倒です。テンプレートファイルに |>keyword<| の
;; 書式でキーワードを埋め込み、そのキーワードの置換を指定することができ
;; ます。
;;
;; (setq mew-guess-template-alist
;; '(("To:"
;; ;; To: の内容が "foo" にマッチしたら、文頭にファイル
;; ;; "~/.ff-foo" を挿入します。そのとき、ファイル内のキーワー
;; ;; ド |>me<| を、"ふー" (ダブルクォーテーションはなし) に
;; ;; 置き換えます。
;; ("foo" "~/.ff-foo" ("me" . "ふー"))
;; ;; 同様。
;; ("bar" "~/.ff-foo" ("me" . "ばー"))
;; )
;; ;; デフォルト
;; (t "~/.ff-foo")
;; ))
;;
;; その際、キーワード置換の既定値を、次のように記述することができます。
;; 置換後の文字列として、変数名、関数名、ラムダ式を記述できます。
;;
;; (setq mew-draft-replace-alist
;; '(("me" . "小幡")
;; ("email" . mew-mail-address)
;; ("time" . (lambda () (current-time-string)))
;; ;; ("time" . current-time-string) も OK
;; ))
;;; Code:
(require 'mew)
;; User tunable variables
(defvar mew-guess-query-when-replaced nil
"*If non-nil, make query to accept result of replacement.")
(defvar mew-guess-header-alist nil
"*Alist to guess header contents.
The syntax is:
(HEADER-GUS (HEADER-CND (KEY VALUE)... )... )...
HEADER-GUS is the target header which you want to guess and modify.
HEADER-CND and KEY specify the condition to guess. If regexp KEY matches
to contents of HEADER-CND, contents are replaced with string VALUE.")
(defvar mew-guess-template-alist nil
"*Alist to guess template file.
The basic syntax is:
(HEADER (KEY TEMPLATE)... )...
If regexp KEY matches to contents of HEADER, file TEMPLATE is guessed
and guess is finished. Note that there is no dot (.) between KEY and
TEMPLATE.
You can specify alists for keyword replacement like:
(HEADER (KEY TEMPLATE (REPLACE-FROM . REPLACE-TO)... )... )...
Alists in this form take precedence over \"mew-draft-replace-alist\".
For example:
(setq mew-guess-template-alist
'((\"To:\"
(\"mew-dist at example.com\" \"~/.ff-mew-dist\"
(\"hello\" . \"Mew friends,\")))
(\"foo at example.com\" \"~/.ff-other\")
(t \"~/.ff-default\")
))
There is exceptional form as you can see in the example:
(t TEMPLATE [(REPLACE-FROM . REPLACE-TO)...])
You can specify default TEMPLATE in this form, putting it on the last.")
(defvar mew-draft-replace-alist nil
"*Alist for keyword replacement in draft.
Keywords \"|>keyword<|\" in the template file and signature file (not
yet) are replaced with it's associated value. It is possible to specify
string, function, variable and lambda expression as the associated
value, which is evaluated when replacement occurs.
You can replace keyword to the string flushed on the right. For example:
(setq mew-draft-replace-alist
'((\"name\" . \"HOGE Hoge\")
(\"email\" . \"foo at example.com\")
(\"time\" .
(lambda () (format (format \"%%%ds\" fill-column)
(current-time-string))))
))")
;; internal use variables
(defvar mew-guess-original-headers nil
"Headers in original message to reply.
This variable should be prepared by `mew-guess-prepare-to-reply'
and it's scope is buffer local.")
(make-variable-buffer-local 'mew-guess-original-headers)
(defvar mew-guess-prepare-for-reply-command-list
'(mew-summary-reply
mew-summary-reply-with-citation)
"List of interactive command allowed for `mew-guess-prepare-for-reply'.")
;; Guess
(defun mew-guess-extra-headers ()
"Return alist of psudo Config: and original headers"
(if (and (boundp 'mew-draft-buffer-config)
mew-draft-buffer-config)
(cons (cons "config:" mew-draft-buffer-config)
mew-guess-original-headers)
mew-guess-original-headers))
(defun mew-guess-by-alist (alist)
(let (name header sublist key val ent ret)
(while (and alist (not ret))
(setq name (car (car alist)))
(setq sublist (cdr (car alist)))
(cond
((eq name t)
(setq ret sublist))
;;((eq name nil)
;;(setq ret sublist))
(t
(setq header (or (mew-header-get-value name)
(cdr (assoc (downcase name)
(mew-guess-extra-headers)))))
(if header
(while (and sublist (not ret))
(setq key (car (car sublist)))
(setq val (cdr (car sublist)))
(if (and (stringp key) (string-match key header))
(cond
((stringp (car val))
(setq ent
(mew-refile-guess-by-alist2 key header (car val))))
((or (functionp (car val))
(symbolp (car val)))
(setq ent (car val)))
((listp (car val))
(setq ent (mew-guess-by-alist val)))))
(if ent (setq ret val))
(setq sublist (cdr sublist))))))
(setq alist (cdr alist)))
ret))
;; Header
(defun mew-guess-collect-header ()
"Collect headers into alist of header key and value."
(let ((case-fold-search t)
key val result)
(save-excursion
(save-restriction
(widen)
;; collect
(goto-char 1)
(while (looking-at "\\([a-z][a-z-]*:\\) *\\(.*\\)$")
(setq key (mew-match 1)
val (mew-match 2))
(forward-line 1)
(while (looking-at "[ \t].*$")
(setq val (concat val (mew-match 0)))
(forward-line 1))
(setq result (cons (cons (downcase key) val) result)))
(nreverse result)))))
(defun mew-guess-prepare-for-reply ()
"Collect header of original message to reply.
Result is list of cons: car is header key and cdr is value.
Both are string, and \"Original-\" is prepended to key string.
This functions is allowed only when called from interactive commands
listed in `mew-guess-prepare-for-reply-command-list'."
(if (and (mew-buffer-message)
(memq this-command mew-guess-prepare-for-reply-command-list))
(setq mew-guess-original-headers
(save-excursion
(set-buffer (mew-buffer-message))
(mapcar '(lambda (x) (setcar x (concat "original-" (car x))) x)
(mew-guess-collect-header))))))
(defun mew-guess-header ()
"Guess and modify header according to \"mew-guess-header-alist\"."
(interactive)
(save-excursion
(save-restriction
(let ((alist mew-guess-header-alist)
header-gus sublist header-cnd glist undo changed)
(mew-header-goto-end)
(setq undo (buffer-substring 1 (point)))
(while alist
(setq header-gus (car (car alist)))
(setq glist (mew-guess-by-alist (cdr (car alist))))
(if glist
(mew-header-replace-value header-gus (car glist)))
(setq alist (cdr alist)))
;; compare with original
(mew-header-goto-end)
(setq changed (not (string= undo (buffer-substring 1 (point)))))
(if (not changed)
(if (interactive-p)
(message "Nothing changed")) ; nothing done
;; something changed! query if need
(mew-highlight-header)
(mew-draft-header-keymap)
(if (or (not mew-guess-query-when-replaced)
(y-or-n-p "Headers are changed. Accept this? "))
(message "Some headers are changed") ; accepted
;; restore original
(kill-region 1 (point))
(insert undo)
(mew-header-goto-end)
(mew-highlight-header)
(mew-draft-header-keymap)
(message "Changes are canceled")))))))
(defun mew-header-replace-value (field value)
"Replace header contents."
(let ((newvalue (cond
((stringp value) value)
((symbolp value)
(cond
((eq value 'delete) nil) ; delete this line
((fboundp value)
(funcall value)) ; use function result
((and (boundp value)
(stringp (symbol-value value)))
(symbol-value value)) ; use value of variable
(t nil)))
((functionp value) (funcall value))
(t nil)))
orgvalue)
(if (not (and (stringp field)
(or (null newvalue) (stringp newvalue))))
(error "Invalid field pair in mew-header-replace-alist")
(setq orgvalue (mew-header-get-value field))
(if (and orgvalue
newvalue
(string= (downcase newvalue) (downcase orgvalue)))
() ; same ... don't replace
(if orgvalue
(mew-header-delete-lines (list field))
(mew-header-goto-end))
(if newvalue
(insert field " " newvalue "\n"))))))
;; Template
(defun mew-guess-template ()
"Insert template file on the top of the draft message."
(interactive)
(save-excursion
(save-restriction
(widen)
(let* ((glist (mew-guess-by-alist mew-guess-template-alist))
(file (car glist))
(kwlist (cdr glist))
pos)
(if (null file)
() ; why null? ... ignore
(setq file (expand-file-name file))
(if (not (file-exists-p file))
(message "Template file not found: %s" file)
;; goto position
(setq pos 'top) ;xxx
(cond
((eq pos 'top) ; goto top of body
(goto-char (mew-header-end))
(forward-line)
(setq pos nil))
((eq pos 'bottom) ; goto end of body
(if (null (mew-attach-p))
(goto-char (point-max))
(goto-char (mew-attach-begin))
(if (not (bolp)) ; insert new-line if need
(insert "\n")))))
(narrow-to-region (point) (point))
(insert-file-contents file)
(mew-draft-replace-by-alist
(append kwlist mew-draft-replace-alist))
(mew-fib-delete-frame)))))))
;; Misc
(defun mew-draft-replace-by-alist (alist)
"Fill |>item<| by alist."
(save-excursion
(let (str obj)
(goto-char (point-min))
(while (re-search-forward "|>\\([^<]+\\)<|" nil t)
(and (setq obj (cdr (assoc (downcase (mew-match 1)) alist)))
(setq str (if (functionp obj)
(funcall obj)
(eval obj)))
(replace-match str t t))))))
;; test
(defun test:mew-draft-replace-by-alist ()
(interactive)
(let ((test5 "TEST5")
(test6 "FAIL")
(kw '(("test1" . "TEST1") ;string
("test2" . (lambda () "TEST2")) ; lambda
("test3" . (concat "TEST3")) ; eval (new feature)
("test4" concat "TEST4") ; eval (new feature)
("test5" . test5) ; variable
("test6" . test6) ; function
("test7" . test7) ; function
))
(ok 0)
(ng 0)
(cnt 0)
str exp fail)
(defun test6 () "TEST6")
(dolist (tag '(test1 test2 test3 test4 test5 test6))
(setq cnt (1+ cnt))
(with-temp-buffer
(insert (format "|>%s<|" tag))
(mew-draft-replace-by-alist kw)
(mew-fib-delete-frame)
(setq str (buffer-string)))
;; judge
(setq exp (upcase (symbol-name tag)))
(if (string= str exp)
(setq ok (1+ ok))
(setq ng (1+ ng))
(setq fail (cons (format "\"%s\"!=\"%s\"" exp str) fail))))
(message "OK=%d/%d, NG=%d/%d >>> %s"
ok cnt ng cnt
(if (< 0 ng) (format "FAIL=%s" (nreverse fail))
"Good!"))))
(provide 'mew-guess)
;;; mew-guess.el ends here
Mew-dist メーリングリストの案内