1 ;;; wl-refile.el -- Refile modules for Wanderlust.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
35 (defvar wl-refile-alist nil)
36 (defvar wl-refile-alist-file-name "refile-alist")
37 ;; should be renamed to "refile-from-alist"
38 (defvar wl-refile-msgid-alist nil)
39 (defvar wl-refile-msgid-alist-file-name "refile-msgid-alist")
40 (defvar wl-refile-subject-alist nil)
41 (defvar wl-refile-subject-alist-file-name "refile-subject-alist")
43 (defvar wl-refile-alist-max-length 1000)
45 (defun wl-refile-alist-setup ()
46 (let ((flist wl-refile-guess-functions))
49 ((eq (car flist) 'wl-refile-guess-by-history)
52 (expand-file-name wl-refile-alist-file-name
53 elmo-msgdb-dir) elmo-mime-charset)))
54 ((eq (car flist) 'wl-refile-guess-by-msgid)
55 (setq wl-refile-msgid-alist
57 (expand-file-name wl-refile-msgid-alist-file-name
58 elmo-msgdb-dir) elmo-mime-charset)))
59 ((eq (car flist) 'wl-refile-guess-by-subject)
60 (setq wl-refile-subject-alist
62 (expand-file-name wl-refile-subject-alist-file-name
63 elmo-msgdb-dir) elmo-mime-charset))))
64 (setq flist (cdr flist)))))
66 (defun wl-refile-alist-save ()
68 (wl-refile-alist-save-file
69 wl-refile-alist-file-name wl-refile-alist))
70 (if wl-refile-msgid-alist
71 (wl-refile-alist-save-file
72 wl-refile-msgid-alist-file-name wl-refile-msgid-alist))
73 (if wl-refile-subject-alist
74 (wl-refile-alist-save-file
75 wl-refile-subject-alist-file-name wl-refile-subject-alist)))
77 (defun wl-refile-alist-save-file (file-name alist)
78 (if (> (length alist) wl-refile-alist-max-length)
79 (setcdr (nthcdr (1- wl-refile-alist-max-length) alist) nil))
80 (elmo-object-save (expand-file-name file-name elmo-msgdb-dir)
81 alist elmo-mime-charset))
83 (defun wl-refile-learn (entity dst)
84 (let (tocc-list from key hit ml)
85 (setq dst (elmo-string dst))
89 (downcase (wl-address-header-extract-address entity))))
92 (elmo-msgdb-overview-entity-get-to entity) ","
93 (elmo-msgdb-overview-entity-get-cc entity)))))
97 (mapcar (function downcase) wl-subscribed-mailing-list))
98 (setq ml (car tocc-list)
100 (setq tocc-list (cdr tocc-list))))
102 (setq key ml) ; subscribed entity!!
103 (or (wl-address-user-mail-address-p
106 (wl-address-header-extract-address
107 (elmo-msgdb-overview-entity-get-from
110 (if (or wl-refile-msgid-alist
111 (memq 'wl-refile-guess-by-msgid
112 wl-refile-guess-functions))
113 (wl-refile-msgid-learn entity dst))
114 (if (or wl-refile-subject-alist
115 (memq 'wl-refile-guess-by-subject
116 wl-refile-guess-functions))
117 (wl-refile-subject-learn entity dst)))
119 (if (setq hit (assoc key wl-refile-alist))
120 (setq wl-refile-alist (delq hit wl-refile-alist)))
121 (setq wl-refile-alist (cons (cons key dst)
124 (defun wl-refile-msgid-learn (entity dst)
125 (let ((key (elmo-msgdb-overview-entity-get-id entity))
127 (setq dst (elmo-string dst))
129 (if (setq hit (assoc key wl-refile-msgid-alist))
131 (setq wl-refile-msgid-alist (cons (cons key dst)
132 wl-refile-msgid-alist))))))
134 (defun wl-refile-subject-learn (entity dst)
135 (let ((subject (wl-summary-subject-filter-func-internal
136 (elmo-msgdb-overview-entity-get-subject entity)))
138 (setq dst (elmo-string dst))
139 (if (and subject (not (string= subject "")))
140 (if (setq hit (assoc subject wl-refile-subject-alist))
142 (setq wl-refile-subject-alist (cons (cons subject dst)
143 wl-refile-subject-alist))))))
148 (defvar wl-refile-guess-functions
149 '(wl-refile-guess-by-rule
150 wl-refile-guess-by-msgid
151 wl-refile-guess-by-subject
152 wl-refile-guess-by-history)
153 "*Functions in this list are used for guessing refile destination folder.")
155 (defvar wl-refile-guess-func-list wl-refile-guess-functions)
156 (make-obsolete-variable 'wl-refile-guess-func-list 'wl-refile-guess-functions)
158 (defun wl-refile-guess (entity)
159 (let ((flist wl-refile-guess-functions) guess)
161 (if (setq guess (funcall (car flist) entity))
163 (setq flist (cdr flist))))
166 (defun wl-refile-evaluate-rule (rule entity)
167 "Return folder string if RULE is matched to ENTITY.
168 If RULE does not match ENTITY, returns nil."
169 (let ((case-fold-search t)
170 fields guess pairs value)
172 ((stringp rule) rule)
174 (setq fields (car rule))
176 (if (setq guess (wl-refile-evaluate-rule (append (list (car fields))
180 (setq fields (cdr fields))))
182 ((stringp (car rule))
183 (setq pairs (cdr rule))
184 (setq value (wl-refile-get-field-value entity (car rule)))
186 (if (and (stringp value)
190 (setq guess (wl-refile-expand-newtext
191 (wl-refile-evaluate-rule (cdr (car pairs))
195 (setq pairs (cdr pairs))))
197 (t (error "Invalid structure for wl-refile-rule-alist")))))
199 (defun wl-refile-get-field-value (entity field)
200 "Get FIELD value from ENTITY."
201 (let ((field (downcase field))
202 (fixed-fields '("from" "subject" "to" "cc")))
203 (if (member field fixed-fields)
204 (funcall (symbol-function
206 "elmo-msgdb-overview-entity-get-"
209 (elmo-msgdb-overview-entity-get-extra-field entity field))))
211 (defun wl-refile-expand-newtext (newtext original)
212 (let ((len (length newtext))
214 c expanded beg N did-expand)
217 (while (and (< pos len)
218 (not (= (aref newtext pos) ?\\)))
221 (push (substring newtext beg pos) expanded))
223 ;; We hit a \; expand it.
226 c (aref newtext pos))
227 (if (not (or (= c ?\&)
230 ;; \ followed by some character we don't expand.
231 (push (char-to-string c) expanded)
236 (when (match-beginning N)
237 (push (substring original (match-beginning N) (match-end N))
241 (apply (function concat) (nreverse expanded))
244 (defun wl-refile-guess-by-rule (entity)
245 (let ((rules wl-refile-rule-alist)
248 (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
250 (setq rules (cdr rules))))
253 (defun wl-refile-guess-by-history (entity)
257 (downcase (wl-address-header-extract-address entity))))
260 (elmo-msgdb-overview-entity-get-to entity) ","
261 (elmo-msgdb-overview-entity-get-cc entity)))))
263 (setq tocc-list (elmo-list-delete
264 (or wl-user-mail-address-list
265 (list (wl-address-header-extract-address wl-from)))
268 (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
270 (setq tocc-list (cdr tocc-list))))
272 (wl-refile-guess-by-from entity))))
274 (defun wl-refile-get-account-part-from-address (address)
275 (if (string-match "\\([^@]+\\)@[^@]+" address)
276 (wl-match-string 1 address)
279 (defun wl-refile-guess-by-from (entity)
281 (downcase (wl-address-header-extract-address
282 (elmo-msgdb-overview-entity-get-from entity)))))
284 (or (cdr (assoc from wl-refile-alist))
285 (format "%s/%s" wl-refile-default-from-folder
286 (wl-refile-get-account-part-from-address from)))))
288 (defun wl-refile-guess-by-msgid (entity)
289 (cdr (assoc (elmo-msgdb-overview-entity-get-references entity)
290 wl-refile-msgid-alist)))
292 (defun wl-refile-guess-by-subject (entity)
293 (cdr (assoc (wl-summary-subject-filter-func-internal
294 (elmo-msgdb-overview-entity-get-subject entity))
295 wl-refile-subject-alist)))
298 (product-provide (provide 'wl-refile) (require 'wl-version))
300 ;;; wl-refile.el ends here