[Mew-dist 1651] mew-refile 0.55
Yoshinari NOMURA
nom at example.com
1997年 8月 26日 (火) 00:45:44 JST
乃村 @ 九大です。
今流すとタイミング悪そうですが、mew-refile.el 0.55 を流します。
・ mew-refile-ctrl-throw がドキュメント通りに動作していなかった
のを修正しました。
・ mew-reffile-guess-folder の副作用として、alias-alist にアドレ
スをを突っ込むようにしてみました。メーリングリストのアドレス
も勝手に補完候補に入れてくれます。
・ 要望の多かった mew-summary-auto-refile の機能を実装してみまし
た。設定の仕方は、
(defvar mew-refile-guess-control
'(
mew-refile-guess-by-alist
mew-refile-guess-by-newsgroups
mew-refile-guess-by-folder
mew-refile-ctrl-auto-boundary
mew-refile-guess-by-msgid
mew-refile-ctrl-throw
mew-refile-guess-by-from
mew-refile-guess-by-default
)
)
のように、mew-refile-ctrl-auto-boundary を入れるだけです。入
れた場所より上の guess-* が mew-summary-auto-refile のルール
として使われます。
mew-summary-auto-refile はキーやメニューにバインドしていませ
ん。
mew-summary-auto-refile は、ほとんどチェックしていません。どなた
かチェックをお願いします。スピード的にちょっと遅いような気もする
のですが、どんなもんなんでしょうか。
--
nom
-------------- next part --------------
;;; mew-refile.el
;;;
;;; Copyright (C) 1994-1997 Yoshinari NOMURA & Kazuhiko YAMAMOTO
;;;
;;; This emacs lisp library confirms
;;; GNU GENERAL PUBLIC LICENSE Version 2.
;;;
;;; Author: Yoshinari NOMURA <nom at example.com>
;;; Kazu Yamamoto <Kazu at example.com>
;;; Created: Jun 11, 1994
;;; Revised: Aug 26, 1997
;;;
(defconst mew-refile-version "mew-refile.el version 0.55")
(require 'mew)
(defvar mew-refile-msgid-alist nil)
(defvar mew-refile-msgid-file-name ".mew-refile-msgid-alist")
(defvar mew-refile-from-alist nil)
(defvar mew-refile-from-file-name ".mew-refile-from-alist")
(defvar mew-refile-alist-max-length 1000
"*Max length of mew-refile-from-alist and mew-refile-msgid-alist.")
(defvar mew-refile-last-folder nil
"Folder name previously you refiled")
(defvar mew-refile-ctrl-multi t
"*If non nil, guess functions guess multi folders.")
(defvar mew-refile-ctrl-throw nil
"If non nil, guess function doesn't guess any more if some other
functions were successful. This variable is set in guess control
functions. So this is not a user customize variable.")
(defvar mew-refile-ctrl-auto-boundary nil
"If non nil, auto refile function stops at this point. This variable
is set in guess control functions. So this is not a user customize
variable.")
(defvar mew-refile-guess-alist nil
"*If non nil, mew guesses destination folder by using this hint.
The format is like this:
(setq mew-refile-guess-alist
'((\"To:\"
(\"wide at example.com\" . \"+wide/wide\")
(\"adam\" . \"+labo/adam\"))
(\"Newsgroups:\"
(\"^nifty\\\\.\\\\([^ ]+\\\\)\" . \"+Nifty/\\\\1\"))
(\"From:\"
(\"uucp\" . \"+adm/uucp\")
(\".*\" . \"+misc\"))
))
")
(defvar mew-refile-guess-control
'(
mew-refile-guess-by-alist
mew-refile-guess-by-newsgroups
mew-refile-guess-by-folder
mew-refile-ctrl-auto-boundary
mew-refile-guess-by-msgid
mew-refile-ctrl-throw
mew-refile-guess-by-from
mew-refile-guess-by-default
)
)
;;
;; Guess functions
;;
;; XXX: We have two types of functions in mew-refile-guess-control,
;; guess function and ctrl function.
;; guess function must return a folder list or folder string or nil.
;; guess function must not have a string "ctrl" in its symbol name.
;; ctrl function must have a string "ctrl" in its symbol name.
;;
; dispatcher returns: ((guess1 guess2 ..) info1 info2 ...) multi guess mode
; ((guess1) info1 info2 ...) single guess mode
; info1: ('guess-func-name guess1 guess2 ...)
;
; that is, 'car' is a list of judged folders.
; 'cdr' is a alist of opinions by guess functions.
;
(defun mew-refile-guess (&optional auto)
(let ((funcs mew-refile-guess-control) ret guess info)
(mew-refile-ctrl-throw-off)
(mew-refile-ctrl-auto-boundary-off)
(while funcs
(if (string-match "ctrl" (symbol-name (car funcs)))
; func is control function
(funcall (car funcs))
; func is guess function
(setq ret (funcall (car funcs))
ret (or (and (listp ret) ret)
(and ret (list ret))))
(if (not (or (and guess mew-refile-ctrl-throw)
(and auto mew-refile-ctrl-auto-boundary)))
(setq guess (append guess ret)))
(setq info (append info (list (cons (car funcs) ret)))))
(setq funcs (cdr funcs)))
(if mew-refile-ctrl-multi
(cons (mew-refile-list-uniq guess) info)
(cons (list (car guess)) info))
))
;
; guess control functions
;
(defun mew-refile-ctrl-auto-boundary ()
(setq mew-refile-ctrl-auto-boundary t))
(defun mew-refile-ctrl-auto-boundary-on ()
(setq mew-refile-ctrl-auto-boundary t))
(defun mew-refile-ctrl-auto-boundary-off ()
(setq mew-refile-ctrl-auto-boundary nil))
(defun mew-refile-ctrl-throw ()
(setq mew-refile-ctrl-throw t))
(defun mew-refile-ctrl-throw-on ()
(setq mew-refile-ctrl-throw t))
(defun mew-refile-ctrl-throw-off ()
(setq mew-refile-ctrl-throw nil))
;
; by alist returns: (guess1 guess2 ...) or nil
;
(defun mew-refile-guess-by-alist ()
(mew-refile-guess-by-alist1 mew-refile-guess-alist))
(defun mew-refile-guess-by-alist1 (alist)
(let (header sublist key val ret return)
(while alist
(setq header (mew-header-get-value (car (car alist))))
(setq sublist (cdr (car alist)))
(if header
(while sublist
(setq ret nil)
(setq key (car (car sublist)))
(setq val (cdr (car sublist)))
(if (and (stringp key) (string-match key header))
(cond
((stringp val)
(setq ret (mew-refile-guess-by-alist2 key header val)))
((listp val)
(setq ret (mew-refile-guess-by-alist1 val)))))
(setq return (append return
(or (and (listp ret) ret)
(and ret (list ret)))))
(setq sublist (cdr sublist))))
(setq alist (cdr alist)))
(mew-refile-list-uniq return)
))
(defun mew-refile-guess-by-alist2 (regexp field string)
(let ((p 1) match-list b e)
(string-match regexp field)
(while (<= p 9)
(setq b (or (match-beginning p) 0))
(setq e (or (match-end p) 0))
(setq match-list (cons (substring field b e) match-list))
(setq p (1+ p)))
(setq p 1)
(while (<= p 9)
(if (string-match (concat "\\\\" (int-to-string p)) string)
(setq string
(concat (substring string 0 (match-beginning 0))
(nth (- 9 p) match-list)
(substring string (match-end 0))))
(setq p (1+ p))))
string
))
;
; by newsgroups returns (guess1 guess2 ...) or nil
;
(defun mew-refile-guess-by-newsgroups ()
(let ((newsgroups (mew-header-user-collect '("Newsgroups:")))
ret return)
(if (not newsgroups)
()
(while newsgroups
(if (setq ret (mew-assoc-case-equal
(car newsgroups) mew-folder-alist 1))
(setq return (append return (list (nth 0 ret)))))
(setq newsgroups (cdr newsgroups)))
(mew-refile-list-uniq return))
))
;
; by folder returns: (guess1 guess2 ...) or nil
;
(defun mew-refile-guess-by-folder ()
(let ((to-cc (mew-header-address-collect '("To:" "Cc:" "Apparently-To:")))
ret return ml-name)
(while to-cc
(setq ml-name (mew-header-delete-at (car to-cc)))
(if (setq ret (mew-assoc-case-equal ml-name mew-folder-alist 1))
(progn
(setq return (append return (list (nth 0 ret))))
(mew-refile-treat-alias-insert (car to-cc))
))
(setq to-cc (cdr to-cc)))
(mew-refile-list-uniq return)
))
;
; by message-id returns: guess1 or nil
;
(defun mew-refile-guess-by-msgid ()
(let ((msgid (or (mew-header-get-value "References:")
(mew-header-get-value "In-Reply-To:"))))
; load message id alist
(if (not mew-refile-msgid-alist)
(setq mew-refile-msgid-alist
(mew-refile-alist-load mew-refile-msgid-file-name)))
; search for msgid
(if (and msgid
(string-match "\\(<[^ \t\n]*>\\)[^>]*\0" (concat msgid "\0")))
(nth 1 (assoc (substring msgid
(match-beginning 1)
(match-end 1))
mew-refile-msgid-alist)))
))
;
; by from returns: guess1
;
(defun mew-refile-guess-by-from ()
(let ((from (or (mew-header-get-address "From:") "")) default)
; load alist if not
(if (not mew-refile-from-alist)
(setq mew-refile-from-alist
(mew-refile-alist-load mew-refile-from-file-name)))
; search from alist
(setq default (mew-refile-guess-by-default))
(if (file-exists-p (mew-expand-folder default))
default
(cdr (assoc from mew-refile-from-alist)))
))
;
; by default returns: guess1
;
(defun mew-refile-guess-by-default ()
(let ((from (or (mew-header-get-address "From:") "")))
(if (and mew-folders-default-folder
(not (equal "" mew-folders-default-folder)))
(concat mew-folders-default-folder
mew-path-separator
(downcase (mew-header-delete-at from)))
mew-folders-default-folder)
))
;;
;; Learning functions
;;
; dispatcher
;
; mew-refile-guess-learn (buf result)
;
; buf is message buffer.
;
; result is ((chosen1 chosen2 ...)
; (guess-func-name1 guess1 guess2...)
; (guess-func-name2 guess1 guess2...))
;
; that is, 'car' is a list of user chosen folders.
; 'cdr' is a list of opinions by guess functions.
;
(defun mew-refile-guess-learn (buf result)
(let ((chosen (car result)) ; (folder1 folder2 ...)
(info (cdr result))); (guess-func-name guess1 guess2...)
(save-excursion
(set-buffer buf)
(if (mew-member 'mew-refile-guess-by-from mew-refile-guess-control)
(mew-refile-guess-by-from-learn chosen info))
(if (mew-member 'mew-refile-guess-by-msgid mew-refile-guess-control)
(mew-refile-guess-by-msgid-learn chosen info))
(mew-refile-treat-alias-insert (mew-header-get-address "From:"))
)))
;
; learn from msgid
;
(defun mew-refile-guess-by-msgid-learn (chosen info)
(let* ((msgid (mew-header-get-value "Message-Id:"))
(folder (car chosen))
; ohter people's honest opinion and my honest opinion.
(oho (apply 'append info))
(mho (cdr (assoc 'mew-refile-guess-by-msgid info))))
(if (and msgid (string-match "<[^ \n>]*>" msgid))
(setq msgid (substring msgid (match-beginning 0) (match-end 0))))
(if (or (not msgid) (not chosen))
()
; load message id alist
(if (not mew-refile-msgid-alist)
(setq mew-refile-msgid-alist
(mew-refile-alist-load mew-refile-msgid-file-name)))
; if my opninion was right, I learn it.
; or a folder was not in other people's opinion,
; I accept it.
(catch 'match
(while chosen
(if (or (mew-member (car chosen) mho)
(not (mew-member (car chosen) oho)))
(throw 'match (setq folder (car chosen))))
(setq chosen (cdr chosen))))
(setq mew-refile-msgid-alist
(cons (list msgid folder "??")
(mew-refile-alist-purge msgid mew-refile-msgid-alist)))
)))
;
; learn from "From:" field
;
(defun mew-refile-guess-by-from-learn (chosen info)
(let ((from (mew-header-get-address "From:"))
(folder nil)
; ohter people's honest opinion and my honest opinion.
(oho (apply 'append info))
(mho (cdr (assoc 'mew-refile-guess-by-from info))))
(if (or (not from) (not chosen))
()
; if my opninion was right, I learn it.
; or a folder was not in other people's opinion,
; I accept it.
(catch 'match
(while chosen
(if (or (mew-member (car chosen) mho)
(not (mew-member (car chosen) oho)))
(throw 'match (setq folder (car chosen))))
(setq chosen (cdr chosen))))
(if folder
(progn
; load message from alist
(if (not mew-refile-from-alist)
(setq mew-refile-from-alist
(mew-refile-alist-load mew-refile-from-file-name)))
(setq mew-refile-from-alist
(cons (cons from folder)
(mew-refile-alist-purge from mew-refile-from-alist)))
))
)))
;;
;; Address completion in draft mode.
;; It should not be here...
;;
(defun mew-refile-treat-alias-insert (address)
(if (not (and (stringp address) (string-match "@" address)))
()
; load alist if not
(if (not mew-refile-from-alist)
(setq mew-refile-from-alist
(mew-refile-alist-load mew-refile-from-file-name)))
; Add empty information ("nom at example.com" . nil) if key is absent.
(if (not (assoc address mew-refile-from-alist))
(setq mew-refile-from-alist
(cons (cons address nil) mew-refile-from-alist)))
; also Add to mew-alias-alist
(if (not (assoc (mew-header-delete-at address) mew-alias-alist))
(setq mew-alias-alist
(append mew-alias-alist
(list (cons (mew-header-delete-at address)
address)))))
))
;
; append alias items made from from-alist to alias-alist
; in reverse order.
;
(defun mew-refile-alist-append-alias (alias-alist)
(let (from from-alist)
; load alist if not
(if (not mew-refile-from-alist)
(setq mew-refile-from-alist
(mew-refile-alist-load mew-refile-from-file-name)))
(setq from-alist mew-refile-from-alist)
(while from-alist
(setq from (car (car from-alist)))
(if (not (assoc (mew-header-delete-at from) alias-alist))
(setq alias-alist
(cons (cons (mew-header-delete-at from) from)
alias-alist)))
(setq from-alist (cdr from-alist)))
alias-alist
))
;;
;; common routines for (a)list
;;
(defun mew-refile-list-uniq (lst)
(let (ret)
(while lst
(if (not (mew-member (car lst) ret))
(setq ret (append ret (list (car lst)))))
(setq lst (cdr lst)))
ret))
(defun mew-refile-alist-purge (key alist)
(let ((a alist))
(delq (assoc key a) a)
))
(defun mew-refile-alist-load (filename)
(let ((alist nil)
(fullname (expand-file-name filename mew-mail-path)))
(save-excursion
(if (not (file-readable-p fullname))
()
(mew-set-buffer-tmp)
(insert-file-contents fullname)
(setq alist
(condition-case nil
(read (current-buffer)) (error nil nil)))
alist))
))
(defun mew-refile-alist-save (filename alist)
(save-excursion
(let* ((fullname (expand-file-name filename mew-mail-path))
(tmp-buf (set-buffer (create-file-buffer fullname)))
(n mew-refile-alist-max-length)
(pointer (cons nil alist)))
(while pointer
(if (> n 0)
(progn
(setq pointer (cdr pointer))
(setq n (1- n)))
(setcdr alist nil)
(setq pointer nil)))
(set-visited-file-name fullname)
(mew-erase-buffer)
(prin1 alist tmp-buf)
(princ "\n" tmp-buf)
(save-buffer 0)
(kill-buffer tmp-buf))
))
(defun mew-refile-guess-save ()
(if (and mew-refile-from-alist
(mew-member 'mew-refile-guess-by-from mew-refile-guess-control))
(mew-refile-alist-save mew-refile-from-file-name mew-refile-from-alist))
(if (and mew-refile-msgid-alist
(mew-member 'mew-refile-guess-by-msgid mew-refile-guess-control))
(mew-refile-alist-save mew-refile-msgid-file-name
mew-refile-msgid-alist))
)
;;
;; Summary mode
;;
(defun mew-refile-set (msg folder)
(let* ((msg-folders (assoc msg mew-summary-buffer-refile))
(folders (cdr msg-folders)))
(if folders
(if (mew-folder-member folder folders)
()
(setq mew-summary-buffer-refile
(cons (append (list msg) folders (list folder))
(delete msg-folders mew-summary-buffer-refile))))
(setq mew-summary-buffer-refile
(cons (list msg folder) mew-summary-buffer-refile)))
))
(defun mew-refile-reset (msg)
(setq mew-summary-buffer-refile
(delete (assoc msg mew-summary-buffer-refile)
mew-summary-buffer-refile))
)
; mew-refile-decide-folders returns: ((input1 input2...)
; (guess-func-name1 guess1 guess2...)
; (guess-func-name2 guess1 guess2...))
; that is, 'car' is a list of user chosen folders.
; 'cdr' is a alist of opinions by guess functions.
; cdr is needed for learning functions.
;
(defun mew-refile-decide-folders (buf msg mark &optional last-folder auto)
(let (learn-info folders ret)
(save-excursion
(set-buffer buf)
(setq learn-info (mew-refile-guess auto)))
(setq
folders
(cond
; if last-folder is set, simply use it.
(last-folder (list last-folder))
; if auto is set, simply use the guess.
(auto (car learn-info))
; add new folder
((equal mew-mark-refile mark)
(mew-input-folders
nil (mew-join ","
(cdr (assoc msg mew-summary-buffer-refile)))))
; multi guess
((nth 1 (car learn-info))
(mew-input-folders nil (mew-join "," (car learn-info))))
; single guess
(t
(mew-input-folders (nth 0 (car learn-info))))))
; check folder existance.
(while folders
(if (mew-folder-check (car folders))
(setq ret (append ret (list (car folders)))))
(setq folders (cdr folders)))
(cons ret (cdr learn-info)) ; return value
))
(defun mew-summary-refile (&optional last-folder auto)
(interactive)
(cond
((eobp)
(and auto (message "No message")))
((not (or (mew-summary-message-number) (mew-summary-part-number)))
(and auto (message "No message")))
(t
(let (mark-as-refile msg folder folders mark buf learn-info)
(save-excursion
;; save the cursor position anyway
(if (mew-summary-part-number)
(re-search-backward mew-summary-message-regex nil t nil))
;; on the message
;; show message if not displayed
(mew-summary-display t) ;; not force
(setq mark (mew-summary-get-mark)) ;; any mark
(setq msg (mew-summary-message-number)) ;; msg is never nil
(setq buf (or (mew-cache-hit (cons (buffer-name) msg))
;; non analysis
(mew-buffer-message)))
; if auto and msg is marked, don't touch it.
(if (and auto (or (equal mark mew-mark-refile)
(equal mark mew-mark-rmm)))
()
; decide folders
(setq learn-info
(mew-refile-decide-folders buf msg mark last-folder auto))
(setq folders (car learn-info))
; mark refile
(if folders
(progn
(mew-refile-guess-learn buf learn-info)
(mapcar (function (lambda (x) (mew-refile-set msg x))) folders)
(mew-mark-unmark)
(mew-summary-mark-as mew-mark-refile)))
; memorize last-folder
(setq mew-refile-last-folder
(nth 1 (assoc msg mew-summary-buffer-refile)))
))
(if (or mark auto)
() ;; stay here
(if (mew-summary-part-number)
(re-search-backward mew-summary-message-regex nil t nil))
;; on the message
(mew-decode-syntax-delete)
;; for C-x C-x
(beginning-of-line)
(push-mark (point) t t)
(mew-summary-display-next))
(set-buffer-modified-p nil)))
))
(defun mew-summary-refile-again ()
(interactive)
(mew-summary-refile mew-refile-last-folder)
)
(defun mew-summary-auto-refile ()
(interactive)
(let ((mew-analysis nil)
(lines (count-lines (point-min) (point-max)))
(line 1))
(message "Auto refiling ...")
(save-window-excursion
(goto-char (point-min))
(while (not (eobp))
(mew-summary-refile nil t)
(forward-line 1)
(message "Auto refiling ... %s%%"
(/ (* 100 line) lines))
(setq line (1+ line)))
(message "Auto refileing ... done"))))
;;
;; "mx" extension
;;
(defun mew-summary-mark-refile ()
(interactive)
(let ((regex (concat mew-summary-message-regex
(regexp-quote (char-to-string mew-mark-hop))))
folder buf msg tofolder)
(save-excursion
(goto-char (point-min))
(if (not (re-search-forward regex nil t))
(message "No marked messages")
(mew-summary-toggle-disp-msg)
(setq msg (mew-summary-message-number))
(setq folder (buffer-name))
(save-excursion
(mew-set-buffer-tmp)
(insert-file-contents (mew-expand-folder folder msg))
(goto-char (point-min))
(setq buf (current-buffer))
)
(setq tofolder (car (car (mew-refile-decide-folders buf msg nil))))
(if (and tofolder (mew-folder-check tofolder))
(progn
(mew-refile-set (mew-summary-message-number) tofolder)
(mew-summary-mark-as mew-mark-refile t)
(while (re-search-forward regex nil t)
(mew-refile-set (mew-summary-message-number) tofolder)
(mew-summary-mark-as mew-mark-refile t)
(forward-line)
)
))
))
))
(provide 'mew-refile)
Mew-dist メーリングリストの案内