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 (product-provide (provide 'wl-refile) (require 'wl-version))
37 (defvar wl-refile-alist nil)
38 (defvar wl-refile-alist-file-name "refile-alist")
39 ;; should be renamed to "refile-from-alist"
40 (defvar wl-refile-msgid-alist nil)
41 (defvar wl-refile-msgid-alist-file-name "refile-msgid-alist")
42 (defvar wl-refile-subject-alist nil)
43 (defvar wl-refile-subject-alist-file-name "refile-subject-alist")
45 (defvar wl-refile-alist-max-length 1000)
47 (defun wl-refile-alist-setup ()
48 (let ((flist wl-refile-guess-functions))
51 ((eq (car flist) 'wl-refile-guess-by-history)
54 (expand-file-name wl-refile-alist-file-name
55 elmo-msgdb-dir) elmo-mime-charset)))
56 ((eq (car flist) 'wl-refile-guess-by-msgid)
57 (setq wl-refile-msgid-alist
59 (expand-file-name wl-refile-msgid-alist-file-name
60 elmo-msgdb-dir) elmo-mime-charset)))
61 ((eq (car flist) 'wl-refile-guess-by-subject)
62 (setq wl-refile-subject-alist
64 (expand-file-name wl-refile-subject-alist-file-name
65 elmo-msgdb-dir) elmo-mime-charset))))
66 (setq flist (cdr flist)))))
68 (defun wl-refile-alist-save ()
70 (wl-refile-alist-save-file
71 wl-refile-alist-file-name wl-refile-alist))
72 (if wl-refile-msgid-alist
73 (wl-refile-alist-save-file
74 wl-refile-msgid-alist-file-name wl-refile-msgid-alist))
75 (if wl-refile-subject-alist
76 (wl-refile-alist-save-file
77 wl-refile-subject-alist-file-name wl-refile-subject-alist)))
79 (defun wl-refile-alist-save-file (file-name alist)
80 (if (> (length alist) wl-refile-alist-max-length)
81 (setcdr (nthcdr (1- wl-refile-alist-max-length) alist) nil))
82 (elmo-object-save (expand-file-name file-name elmo-msgdb-dir)
83 alist elmo-mime-charset))
85 (defun wl-refile-learn (entity dst)
86 (let (tocc-list from key hit ml)
87 (setq dst (elmo-string dst))
91 (downcase (wl-address-header-extract-address entity))))
94 (elmo-msgdb-overview-entity-get-to entity) ","
95 (elmo-msgdb-overview-entity-get-cc entity)))))
99 (mapcar (function downcase) wl-subscribed-mailing-list))
100 (setq ml (car tocc-list)
102 (setq tocc-list (cdr tocc-list))))
104 (setq key ml) ; subscribed entity!!
105 (or (wl-address-user-mail-address-p
108 (wl-address-header-extract-address
109 (elmo-msgdb-overview-entity-get-from
112 (if (or wl-refile-msgid-alist
113 (memq 'wl-refile-guess-by-msgid
114 wl-refile-guess-functions))
115 (wl-refile-msgid-learn entity dst))
116 (if (or wl-refile-subject-alist
117 (memq 'wl-refile-guess-by-subject
118 wl-refile-guess-functions))
119 (wl-refile-subject-learn entity dst)))
121 (if (setq hit (assoc key wl-refile-alist))
122 (setq wl-refile-alist (delq hit wl-refile-alist)))
123 (setq wl-refile-alist (cons (cons key dst)
126 (defun wl-refile-msgid-learn (entity dst)
127 (let ((key (elmo-msgdb-overview-entity-get-id entity))
129 (setq dst (elmo-string dst))
131 (if (setq hit (assoc key wl-refile-msgid-alist))
133 (setq wl-refile-msgid-alist (cons (cons key dst)
134 wl-refile-msgid-alist))))))
136 (defun wl-refile-subject-learn (entity dst)
137 (let ((subject (wl-summary-subject-filter-func-internal
138 (elmo-msgdb-overview-entity-get-subject entity)))
140 (setq dst (elmo-string dst))
141 (if (and subject (not (string= subject "")))
142 (if (setq hit (assoc subject wl-refile-subject-alist))
144 (setq wl-refile-subject-alist (cons (cons subject dst)
145 wl-refile-subject-alist))))))
150 (defvar wl-refile-guess-functions
151 '(wl-refile-guess-by-rule
152 wl-refile-guess-by-msgid
153 wl-refile-guess-by-subject
154 wl-refile-guess-by-history)
155 "*Functions in this list are used for guessing refile destination folder.")
157 (defvar wl-refile-guess-func-list wl-refile-guess-functions)
158 (make-obsolete-variable 'wl-refile-guess-func-list 'wl-refile-guess-functions)
160 (defun wl-refile-guess (entity)
161 (let ((flist wl-refile-guess-functions) guess)
163 (if (setq guess (funcall (car flist) entity))
165 (setq flist (cdr flist))))
168 (defun wl-refile-evaluate-rule (rule entity)
169 "Return folder string if RULE is matched to ENTITY.
170 If RULE does not match ENTITY, returns nil."
171 (let ((case-fold-search t)
172 fields guess pairs value)
174 ((stringp rule) rule)
176 (setq fields (car rule))
178 (if (setq guess (wl-refile-evaluate-rule (append (list (car fields))
182 (setq fields (cdr fields))))
184 ((stringp (car rule))
185 (setq pairs (cdr rule))
186 (setq value (wl-refile-get-field-value entity (car rule)))
188 (if (and (stringp value)
192 (setq guess (wl-refile-expand-newtext
193 (wl-refile-evaluate-rule (cdr (car pairs))
197 (setq pairs (cdr pairs))))
199 (t (error "Invalid structure for wl-refile-rule-alist")))))
201 (defun wl-refile-get-field-value (entity field)
202 "Get FIELD value from ENTITY."
203 (let ((field (downcase field))
204 (fixed-fields '("from" "subject" "to" "cc")))
205 (if (member field fixed-fields)
206 (funcall (symbol-function
208 "elmo-msgdb-overview-entity-get-"
211 (elmo-msgdb-overview-entity-get-extra-field entity field))))
213 (defun wl-refile-expand-newtext (newtext original)
214 (let ((len (length newtext))
216 c expanded beg N did-expand)
219 (while (and (< pos len)
220 (not (= (aref newtext pos) ?\\)))
223 (push (substring newtext beg pos) expanded))
225 ;; We hit a \; expand it.
228 c (aref newtext pos))
229 (if (not (or (= c ?\&)
232 ;; \ followed by some character we don't expand.
233 (push (char-to-string c) expanded)
238 (when (match-beginning N)
239 (push (substring original (match-beginning N) (match-end N))
243 (apply (function concat) (nreverse expanded))
246 (defun wl-refile-guess-by-rule (entity)
247 (let ((rules wl-refile-rule-alist)
250 (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
252 (setq rules (cdr rules))))
255 (defun wl-refile-guess-by-history (entity)
259 (downcase (wl-address-header-extract-address entity))))
262 (elmo-msgdb-overview-entity-get-to entity) ","
263 (elmo-msgdb-overview-entity-get-cc entity)))))
265 (setq tocc-list (elmo-list-delete
266 (or wl-user-mail-address-list
267 (list (wl-address-header-extract-address wl-from)))
270 (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
272 (setq tocc-list (cdr tocc-list))))
274 (wl-refile-guess-by-from entity))))
276 (defun wl-refile-get-account-part-from-address (address)
277 (if (string-match "\\([^@]+\\)@[^@]+" address)
278 (wl-match-string 1 address)
281 (defun wl-refile-guess-by-from (entity)
283 (downcase (wl-address-header-extract-address
284 (elmo-msgdb-overview-entity-get-from entity)))))
286 (or (cdr (assoc from wl-refile-alist))
287 (format "%s/%s" wl-refile-default-from-folder
288 (wl-refile-get-account-part-from-address from)))))
290 (defun wl-refile-guess-by-msgid (entity)
291 (cdr (assoc (elmo-msgdb-overview-entity-get-references entity)
292 wl-refile-msgid-alist)))
294 (defun wl-refile-guess-by-subject (entity)
295 (cdr (assoc (wl-summary-subject-filter-func-internal
296 (elmo-msgdb-overview-entity-get-subject entity))
297 wl-refile-subject-alist)))
299 ;;; wl-refile.el ends here