wl/wl-refile.el

   1 ;;; wl-refile.el --- Refile modules for Wanderlust.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
   9
  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)
  13 ;; any later version.
  14 ;;
  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.
  19 ;;
  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.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (require 'wl-vars)
  33 (require 'wl-util)
  34
  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")
  42
  43 (defvar wl-refile-alist-max-length 1000)
  44
  45 (defun wl-refile-alist-setup ()
  46   (let ((flist wl-refile-guess-functions))
  47     (while flist
  48       (cond
  49        ((eq (car flist) 'wl-refile-guess-by-history)
  50         (setq wl-refile-alist
  51               (elmo-object-load
  52                (expand-file-name wl-refile-alist-file-name
  53                                  elmo-msgdb-directory) elmo-mime-charset)))
  54        ((eq (car flist) 'wl-refile-guess-by-msgid)
  55         (setq wl-refile-msgid-alist
  56               (elmo-object-load
  57                (expand-file-name wl-refile-msgid-alist-file-name
  58                                  elmo-msgdb-directory) elmo-mime-charset)))
  59        ((eq (car flist) 'wl-refile-guess-by-subject)
  60         (setq wl-refile-subject-alist
  61               (elmo-object-load
  62                (expand-file-name wl-refile-subject-alist-file-name
  63                                  elmo-msgdb-directory) elmo-mime-charset))))
  64       (setq flist (cdr flist)))))
  65
  66 (defun wl-refile-alist-save ()
  67   (if wl-refile-alist
  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)))
  76
  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-directory)
  81                     alist elmo-mime-charset))
  82
  83 (defun wl-refile-learn (entity dst)
  84   (let (tocc-list from key hit ml)
  85     (setq dst (elmo-string dst))
  86     (setq tocc-list
  87           (mapcar (function
  88                    (lambda (entity)
  89                      (downcase (wl-address-header-extract-address entity))))
  90                   (wl-parse-addresses
  91                    (concat
  92                     (elmo-message-entity-field entity 'to) ","
  93                     (elmo-message-entity-field entity 'cc)))))
  94     (while tocc-list
  95       (if (wl-string-member
  96            (car tocc-list)
  97            (mapcar (function downcase) wl-subscribed-mailing-list))
  98           (setq ml (car tocc-list)
  99                 tocc-list nil)
 100         (setq tocc-list (cdr tocc-list))))
 101     (if ml
 102         (setq key ml) ; subscribed entity!!
 103       (or (wl-address-user-mail-address-p
 104            (setq from
 105                  (downcase
 106                   (wl-address-header-extract-address
 107                    (elmo-message-entity-field entity 'from)))))
 108           (setq key from))
 109       (if (or wl-refile-msgid-alist
 110               (memq 'wl-refile-guess-by-msgid
 111                     wl-refile-guess-functions))
 112           (wl-refile-msgid-learn entity dst))
 113       (if (or wl-refile-subject-alist
 114               (memq 'wl-refile-guess-by-subject
 115                     wl-refile-guess-functions))
 116           (wl-refile-subject-learn entity dst)))
 117     (when key
 118       (if (setq hit (assoc key wl-refile-alist))
 119           (setq wl-refile-alist (delq hit wl-refile-alist)))
 120       (setq wl-refile-alist (cons (cons key dst)
 121                                   wl-refile-alist)))))
 122
 123 (defun wl-refile-msgid-learn (entity dst)
 124   (let ((key (elmo-message-entity-field entity 'message-id))
 125         hit)
 126     (setq dst (elmo-string dst))
 127     (if key
 128         (if (setq hit (assoc key wl-refile-msgid-alist))
 129             (setcdr hit dst)
 130           (setq wl-refile-msgid-alist (cons (cons key dst)
 131                                             wl-refile-msgid-alist))))))
 132
 133 (defun wl-refile-subject-learn (entity dst)
 134   (let ((subject (funcall wl-summary-subject-filter-function
 135                           (elmo-message-entity-field entity 'subject 'decode)))
 136         hit)
 137     (setq dst (elmo-string dst))
 138     (if (and subject (not (string= subject "")))
 139         (if (setq hit (assoc subject wl-refile-subject-alist))
 140             (setcdr hit dst)
 141           (setq wl-refile-subject-alist (cons (cons subject dst)
 142                                             wl-refile-subject-alist))))))
 143
 144 ;;
 145 ;; refile guess
 146 ;;
 147 (defvar wl-refile-guess-functions
 148   '(wl-refile-guess-by-rule
 149     wl-refile-guess-by-msgid
 150     wl-refile-guess-by-subject
 151     wl-refile-guess-by-history)
 152   "*Functions in this list are used for guessing refile destination folder.")
 153
 154 ;; 2000-11-05: *-func-list -> *-functions
 155 (elmo-define-obsolete-variable 'wl-refile-guess-func-list
 156                                'wl-refile-guess-functions)
 157
 158 (defun wl-refile-guess (entity &optional functions)
 159   (let ((flist (or functions wl-refile-guess-functions))
 160         guess)
 161     (while flist
 162       (if (setq guess (funcall (car flist) entity))
 163           (setq flist nil)
 164         (setq flist (cdr flist))))
 165     guess))
 166
 167 (defun wl-refile-evaluate-rule (rule entity)
 168   "Return folder string if RULE is matched to ENTITY.
 169 If RULE does not match ENTITY, returns nil."
 170   (let ((case-fold-search t)
 171         fields guess pairs value)
 172     (cond
 173      ((stringp rule) rule)
 174      ((listp (car rule))
 175       (setq fields (car rule))
 176       (while fields
 177         (if (setq guess (wl-refile-evaluate-rule (append (list (car fields))
 178                                                          (cdr rule))
 179                                                  entity))
 180             (setq fields nil)
 181           (setq fields (cdr fields))))
 182       guess)
 183      ((stringp (car rule))
 184       (setq pairs (cdr rule))
 185       (setq value (wl-refile-get-field-value entity (car rule)))
 186       (while pairs
 187         (if (and (stringp value)
 188                  (string-match
 189                   (car (car pairs))
 190                   value)
 191                  (setq guess (wl-expand-newtext
 192                               (wl-refile-evaluate-rule (cdr (car pairs))
 193                                                        entity)
 194                               value)))
 195             (setq pairs nil)
 196           (setq pairs (cdr pairs))))
 197       guess)
 198      (t (error "Invalid structure for wl-refile-rule-alist")))))
 199
 200 (defun wl-refile-get-field-value (entity field)
 201   "Get FIELD value from ENTITY."
 202   (elmo-message-entity-field entity (intern (downcase field)) 'decode))
 203
 204 (defun wl-refile-guess-by-rule (entity)
 205   (let ((rules wl-refile-rule-alist)
 206         guess)
 207     (while rules
 208       (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
 209           (setq rules nil)
 210         (setq rules (cdr rules))))
 211     guess))
 212
 213 (defun wl-refile-guess-by-history (entity)
 214   (let ((tocc-list
 215          (mapcar (function
 216                   (lambda (entity)
 217                     (downcase (wl-address-header-extract-address entity))))
 218                  (wl-parse-addresses
 219                   (concat
 220                    (elmo-message-entity-field entity 'to) ","
 221                    (elmo-message-entity-field entity 'cc)))))
 222         ret-val)
 223     (setq tocc-list (elmo-list-delete
 224                      (or wl-user-mail-address-list
 225                          (list (wl-address-header-extract-address wl-from)))
 226                      tocc-list))
 227     (while tocc-list
 228       (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
 229           (setq tocc-list nil)
 230         (setq tocc-list (cdr tocc-list))))
 231     (or ret-val
 232         (wl-refile-guess-by-from entity))))
 233
 234 (defun wl-refile-get-account-part-from-address (address)
 235   (if (string-match "\\([^@]+\\)@[^@]+" address)
 236       (wl-match-string 1 address)
 237     address))
 238
 239 (defun wl-refile-guess-by-from (entity)
 240   (let ((from
 241          (downcase (wl-address-header-extract-address
 242                     (elmo-message-entity-field entity 'from)))))
 243     ;; search from alist
 244     (or (cdr (assoc from wl-refile-alist))
 245         (format "%s/%s" wl-refile-default-from-folder
 246                 (wl-refile-get-account-part-from-address from)))))
 247
 248 (defun wl-refile-guess-by-msgid (entity)
 249   (cdr (assoc (elmo-message-entity-field entity 'references)
 250               wl-refile-msgid-alist)))
 251
 252 (defun wl-refile-guess-by-subject (entity)
 253   (cdr (assoc (funcall wl-summary-subject-filter-function
 254                        (elmo-message-entity-field entity 'subject 'decode))
 255               wl-refile-subject-alist)))
 256
 257 (require 'product)
 258 (product-provide (provide 'wl-refile) (require 'wl-version))
 259
 260 ;;; wl-refile.el ends here