wl/wl-refile.el

   1 ;;; wl-refile.el -- Refile modules for Wanderlust.
   2
   3 ;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7 ;; Time-stamp: <00/03/23 19:07:28 teranisi>
   8
   9 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31 ;;
  32
  33 (require 'wl-vars)
  34 (require 'wl-util)
  35 (provide 'wl-refile)
  36
  37
  38 (defvar wl-refile-alist nil)
  39 (defvar wl-refile-alist-file-name "refile-alist")
  40 ;; should be renamed to "refile-from-alist"
  41 (defvar wl-refile-msgid-alist nil)
  42 (defvar wl-refile-msgid-alist-file-name "refile-msgid-alist")
  43
  44 (defvar wl-refile-alist-max-length 1000)
  45
  46 (defun wl-refile-alist-setup ()
  47   (setq wl-refile-alist
  48         (elmo-object-load
  49          (expand-file-name wl-refile-alist-file-name
  50                            elmo-msgdb-dir)))
  51   (setq wl-refile-msgid-alist
  52         (elmo-object-load
  53          (expand-file-name wl-refile-msgid-alist-file-name
  54                            elmo-msgdb-dir))))
  55
  56 (defun wl-refile-alist-save (file-name alist)
  57   (save-excursion
  58     (let ((filename (expand-file-name file-name
  59                                       elmo-msgdb-dir))
  60           (tmp-buffer (get-buffer-create " *wl-refile-alist-tmp*")))
  61       (set-buffer tmp-buffer)
  62       (erase-buffer)
  63       (if (> (length alist) wl-refile-alist-max-length)
  64           (setcdr (nthcdr (1- wl-refile-alist-max-length) alist) nil))
  65       (prin1 alist tmp-buffer)
  66       (princ "\n" tmp-buffer)
  67       (if (file-writable-p filename)
  68           (write-region (point-min) (point-max)
  69                         filename nil 'no-msg)
  70         (message (format "%s is not writable." filename)))
  71       (kill-buffer tmp-buffer))))
  72
  73 (defun wl-refile-learn (entity dst)
  74   (let (tocc-list from key hit ml)
  75     (setq dst (elmo-string dst))
  76     (setq tocc-list
  77           (mapcar (function
  78                    (lambda (entity)
  79                      (downcase (wl-address-header-extract-address entity))))
  80                   (wl-parse-addresses
  81                    (concat
  82                     (elmo-msgdb-overview-entity-get-to entity) ","
  83                     (elmo-msgdb-overview-entity-get-cc entity)))))
  84     (while tocc-list
  85       (if (wl-string-member
  86            (car tocc-list)
  87            (mapcar (function downcase) wl-subscribed-mailing-list))
  88           (setq ml (car tocc-list)
  89                 tocc-list nil)
  90         (setq tocc-list (cdr tocc-list))))
  91     (if ml
  92         (setq key ml) ; subscribed entity!!
  93       (or (wl-address-user-mail-address-p
  94            (setq from
  95                  (downcase
  96                   (wl-address-header-extract-address
  97                    (elmo-msgdb-overview-entity-get-from
  98                     entity)))))
  99           (setq key from)))
 100     (if (not ml)
 101         (wl-refile-msgid-learn entity dst))
 102     (if key
 103         (if (setq hit (assoc key wl-refile-alist))
 104             (setcdr hit dst)
 105           (setq wl-refile-alist
 106                 (nconc wl-refile-alist (list (cons key dst))))))))
 107
 108 (defun wl-refile-msgid-learn (entity dst)
 109   (let ((key (elmo-msgdb-overview-entity-get-id entity))
 110         hit)
 111     (setq dst (elmo-string dst))
 112     (if key
 113         (if (setq hit (assoc key wl-refile-msgid-alist))
 114             (setcdr hit dst)
 115           (setq wl-refile-msgid-alist (cons (cons key dst)
 116                                             wl-refile-msgid-alist))))))
 117
 118 ;;
 119 ;; refile guess
 120 ;;
 121 (defvar wl-refile-guess-func-list
 122   '(wl-refile-guess-by-rule
 123     wl-refile-guess-by-msgid
 124     wl-refile-guess-by-history)
 125   "*Functions in this list are used for guessing refile destination folder.")
 126
 127 (defun wl-refile-guess (entity)
 128   (let ((flist wl-refile-guess-func-list) guess)
 129     (while flist
 130       (if (setq guess (funcall (car flist) entity))
 131           (setq flist nil)
 132         (setq flist (cdr flist))))
 133     guess))
 134
 135 (defun wl-refile-guess-by-rule (entity)
 136   (let ((rules wl-refile-rule-alist)
 137         (rule-set) (field) (field-cont))
 138     (catch 'found
 139       (while rules
 140         (setq rule-set (cdr (car rules))
 141               field (car (car rules)))
 142         (cond ((string-match field "From")
 143                (setq field-cont
 144                      (elmo-msgdb-overview-entity-get-from entity)))
 145               ((string-match field "Subject")
 146                (setq field-cont
 147                      (elmo-msgdb-overview-entity-get-subject entity)))
 148               ((string-match field "To")
 149                (setq field-cont
 150                      (elmo-msgdb-overview-entity-get-to entity)))
 151               ((string-match field "Cc")
 152                (setq field-cont
 153                      (elmo-msgdb-overview-entity-get-cc entity)))
 154               (t
 155                (setq field-cont
 156                      (elmo-msgdb-overview-entity-get-extra-field
 157                       entity (downcase field)))))
 158         (if field-cont
 159             (while rule-set
 160               (if (string-match (car (car rule-set)) field-cont)
 161                   (throw 'found (cdr (car rule-set)))
 162                 (setq rule-set (cdr rule-set)))))
 163         (setq rules (cdr rules))))))
 164
 165 (defun wl-refile-guess-by-history (entity)
 166   (let ((tocc-list
 167          (mapcar (function
 168                   (lambda (entity)
 169                     (downcase (wl-address-header-extract-address entity))))
 170                  (wl-parse-addresses
 171                   (concat
 172                    (elmo-msgdb-overview-entity-get-to entity) ","
 173                    (elmo-msgdb-overview-entity-get-cc entity)))))
 174         ret-val)
 175     (setq tocc-list (elmo-list-delete
 176                      (or wl-user-mail-address-list
 177                          (list (wl-address-header-extract-address wl-from)))
 178                      tocc-list))
 179     (while tocc-list
 180       (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
 181           (setq tocc-list nil)
 182         (setq tocc-list (cdr tocc-list))))
 183     (or ret-val
 184         (wl-refile-guess-by-from entity))))
 185
 186 (defun wl-refile-get-account-part-from-address (address)
 187   (if (string-match "\\([^@]+\\)@[^@]+" address)
 188       (wl-match-string 1 address)
 189     address))
 190
 191 (defun wl-refile-guess-by-from (entity)
 192   (let ((from
 193          (downcase (wl-address-header-extract-address
 194                     (elmo-msgdb-overview-entity-get-from entity)))))
 195     ;; search from alist
 196     (or (cdr (assoc from wl-refile-alist))
 197         (format "%s/%s" wl-refile-default-from-folder
 198                 (wl-refile-get-account-part-from-address from)))))
 199
 200 (defun wl-refile-guess-by-msgid (entity)
 201   (cdr (assoc (elmo-msgdb-overview-entity-get-references entity)
 202               wl-refile-msgid-alist)))
 203
 204 ;;; wl-refile.el ends here