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 (lambda (entity)
  90                     (downcase (wl-address-header-extract-address entity)))
  91                   (append
  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     wl-refile-guess-by-from)
 153   "*Functions in this list are used for guessing refile destination folder.")
 154
 155 ;; 2000-11-05: *-func-list -> *-functions
 156 (elmo-define-obsolete-variable 'wl-refile-guess-func-list
 157                                'wl-refile-guess-functions)
 158
 159 (defun wl-refile-guess (entity &optional functions)
 160   (let ((flist (or functions wl-refile-guess-functions))
 161         guess)
 162     (while flist
 163       (if (setq guess (funcall (car flist) entity))
 164           (setq flist nil)
 165         (setq flist (cdr flist))))
 166     guess))
 167
 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)
 173     (cond
 174      ((stringp rule) rule)
 175      ((listp (car rule))
 176       (setq fields (car rule))
 177       (while fields
 178         (if (setq guess (wl-refile-evaluate-rule (append (list (car fields))
 179                                                          (cdr rule))
 180                                                  entity))
 181             (setq fields nil)
 182           (setq fields (cdr fields))))
 183       guess)
 184      ((stringp (car rule))
 185       (setq pairs (cdr rule))
 186       (setq value (wl-refile-get-field-value entity (car rule)))
 187       (while pairs
 188         (if (and (stringp value)
 189                  (string-match
 190                   (car (car pairs))
 191                   value)
 192                  (setq guess (wl-expand-newtext
 193                               (wl-refile-evaluate-rule (cdr (car pairs))
 194                                                        entity)
 195                               value)))
 196             (setq pairs nil)
 197           (setq pairs (cdr pairs))))
 198       guess)
 199      (t (error "Invalid structure for wl-refile-rule-alist")))))
 200
 201 (defun wl-refile-get-field-value (entity field)
 202   "Get FIELD value from ENTITY."
 203   (elmo-message-entity-field entity (intern (downcase field)) 'string))
 204
 205 (defun wl-refile-guess-by-rule (entity)
 206   (let ((rules wl-refile-rule-alist)
 207         guess)
 208     (while rules
 209       (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
 210           (setq rules nil)
 211         (setq rules (cdr rules))))
 212     guess))
 213
 214 (defun wl-refile-guess-by-history (entity)
 215   (let ((tocc-list
 216          (mapcar (lambda (entity)
 217                    (downcase (wl-address-header-extract-address entity)))
 218                  (append
 219                   (elmo-message-entity-field entity 'to)
 220                   (elmo-message-entity-field entity 'cc))))
 221         ret-val)
 222     (setq tocc-list (wl-address-delete-user-mail-addresses tocc-list))
 223     (while tocc-list
 224       (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
 225           (setq tocc-list nil)
 226         (setq tocc-list (cdr tocc-list))))
 227     ret-val))
 228
 229 (defun wl-refile-get-account-part-from-address (address)
 230   (if (string-match "\\([^@]+\\)@[^@]+" address)
 231       (wl-match-string 1 address)
 232     address))
 233
 234 (defun wl-refile-guess-by-from (entity)
 235   (let ((from (downcase (wl-address-header-extract-address
 236                          (elmo-message-entity-field entity 'from))))
 237         (folder (elmo-make-folder wl-refile-default-from-folder))
 238         (elmo-path-sep wl-refile-default-from-folder-path-separator))
 239     ;; search from alist
 240     (or (cdr (assoc from wl-refile-alist))
 241         (concat
 242          (elmo-folder-prefix-internal folder)
 243          (elmo-concat-path
 244           (substring wl-refile-default-from-folder
 245                      (length (elmo-folder-prefix-internal 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))
 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