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