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)))
 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)
 159   (let ((flist wl-refile-guess-functions) guess)
 160     (while flist
 161       (if (setq guess (funcall (car flist) entity))
 162           (setq flist nil)
 163         (setq flist (cdr flist))))
 164     guess))
 165
 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)
 171     (cond
 172      ((stringp rule) rule)
 173      ((listp (car rule))
 174       (setq fields (car rule))
 175       (while fields
 176         (if (setq guess (wl-refile-evaluate-rule (append (list (car fields))
 177                                                          (cdr rule))
 178                                                  entity))
 179             (setq fields nil)
 180           (setq fields (cdr fields))))
 181       guess)
 182      ((stringp (car rule))
 183       (setq pairs (cdr rule))
 184       (setq value (wl-refile-get-field-value entity (car rule)))
 185       (while pairs
 186         (if (and (stringp value)
 187                  (string-match
 188                   (car (car pairs))
 189                   value)
 190                  (setq guess (wl-expand-newtext
 191                               (wl-refile-evaluate-rule (cdr (car pairs))
 192                                                        entity)
 193                               value)))
 194             (setq pairs nil)
 195           (setq pairs (cdr pairs))))
 196       guess)
 197      (t (error "Invalid structure for wl-refile-rule-alist")))))
 198
 199 (defun wl-refile-get-field-value (entity field)
 200   "Get FIELD value from ENTITY."
 201   (elmo-message-entity-field entity (intern (downcase field))))
 202
 203 (defun wl-refile-guess-by-rule (entity)
 204   (let ((rules wl-refile-rule-alist)
 205         guess)
 206     (while rules
 207       (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
 208           (setq rules nil)
 209         (setq rules (cdr rules))))
 210     guess))
 211
 212 (defun wl-refile-guess-by-history (entity)
 213   (let ((tocc-list
 214          (mapcar (function
 215                   (lambda (entity)
 216                     (downcase (wl-address-header-extract-address entity))))
 217                  (wl-parse-addresses
 218                   (concat
 219                    (elmo-msgdb-overview-entity-get-to entity) ","
 220                    (elmo-msgdb-overview-entity-get-cc entity)))))
 221         ret-val)
 222     (setq tocc-list (elmo-list-delete
 223                      (or wl-user-mail-address-list
 224                          (list (wl-address-header-extract-address wl-from)))
 225                      tocc-list))
 226     (while tocc-list
 227       (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
 228           (setq tocc-list nil)
 229         (setq tocc-list (cdr tocc-list))))
 230     (or ret-val
 231         (wl-refile-guess-by-from entity))))
 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
 240          (downcase (wl-address-header-extract-address
 241                     (elmo-msgdb-overview-entity-get-from entity)))))
 242     ;; search from alist
 243     (or (cdr (assoc from wl-refile-alist))
 244         (format "%s/%s" wl-refile-default-from-folder
 245                 (wl-refile-get-account-part-from-address from)))))
 246
 247 (defun wl-refile-guess-by-msgid (entity)
 248   (cdr (assoc (elmo-msgdb-overview-entity-get-references entity)
 249               wl-refile-msgid-alist)))
 250
 251 (defun wl-refile-guess-by-subject (entity)
 252   (cdr (assoc (funcall wl-summary-subject-filter-function
 253                        (elmo-msgdb-overview-entity-get-subject entity))
 254               wl-refile-subject-alist)))
 255
 256 (require 'product)
 257 (product-provide (provide 'wl-refile) (require 'wl-version))
 258
 259 ;;; wl-refile.el ends here