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-dir) 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-dir) 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-dir) 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-dir)
  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-msgdb-overview-entity-get-to entity) ","
  93                     (elmo-msgdb-overview-entity-get-cc entity)))))
  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-msgdb-overview-entity-get-from
 108                     entity)))))
 109           (setq key from))
 110       (if (or wl-refile-msgid-alist
 111               (memq 'wl-refile-guess-by-msgid
 112                     wl-refile-guess-functions))
 113           (wl-refile-msgid-learn entity dst))
 114       (if (or wl-refile-subject-alist
 115               (memq 'wl-refile-guess-by-subject
 116                     wl-refile-guess-functions))
 117           (wl-refile-subject-learn entity dst)))
 118     (when key
 119       (if (setq hit (assoc key wl-refile-alist))
 120           (setq wl-refile-alist (delq hit wl-refile-alist)))
 121       (setq wl-refile-alist (cons (cons key dst)
 122                                   wl-refile-alist)))))
 123
 124 (defun wl-refile-msgid-learn (entity dst)
 125   (let ((key (elmo-msgdb-overview-entity-get-id entity))
 126         hit)
 127     (setq dst (elmo-string dst))
 128     (if key
 129         (if (setq hit (assoc key wl-refile-msgid-alist))
 130             (setcdr hit dst)
 131           (setq wl-refile-msgid-alist (cons (cons key dst)
 132                                             wl-refile-msgid-alist))))))
 133
 134 (defun wl-refile-subject-learn (entity dst)
 135   (let ((subject (wl-summary-subject-filter-func-internal
 136                   (elmo-msgdb-overview-entity-get-subject entity)))
 137         hit)
 138     (setq dst (elmo-string dst))
 139     (if (and subject (not (string= subject "")))
 140         (if (setq hit (assoc subject wl-refile-subject-alist))
 141             (setcdr hit dst)
 142           (setq wl-refile-subject-alist (cons (cons subject dst)
 143                                             wl-refile-subject-alist))))))
 144
 145 ;;
 146 ;; refile guess
 147 ;;
 148 (defvar wl-refile-guess-functions
 149   '(wl-refile-guess-by-rule
 150     wl-refile-guess-by-msgid
 151     wl-refile-guess-by-subject
 152     wl-refile-guess-by-history)
 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)
 160   (let ((flist wl-refile-guess-functions) 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   (let ((field (downcase field))
 203         (fixed-fields '("from" "subject" "to" "cc")))
 204     (if (member field fixed-fields)
 205         (funcall (symbol-function
 206                   (intern (concat
 207                            "elmo-msgdb-overview-entity-get-"
 208                            field)))
 209                  entity)
 210       (elmo-msgdb-overview-entity-get-extra-field entity field))))
 211
 212 (defun wl-refile-guess-by-rule (entity)
 213   (let ((rules wl-refile-rule-alist)
 214         guess)
 215     (while rules
 216       (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
 217           (setq rules nil)
 218         (setq rules (cdr rules))))
 219     guess))
 220
 221 (defun wl-refile-guess-by-history (entity)
 222   (let ((tocc-list
 223          (mapcar (function
 224                   (lambda (entity)
 225                     (downcase (wl-address-header-extract-address entity))))
 226                  (wl-parse-addresses
 227                   (concat
 228                    (elmo-msgdb-overview-entity-get-to entity) ","
 229                    (elmo-msgdb-overview-entity-get-cc entity)))))
 230         ret-val)
 231     (setq tocc-list (elmo-list-delete
 232                      (or wl-user-mail-address-list
 233                          (list (wl-address-header-extract-address wl-from)))
 234                      tocc-list))
 235     (while tocc-list
 236       (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
 237           (setq tocc-list nil)
 238         (setq tocc-list (cdr tocc-list))))
 239     (or ret-val
 240         (wl-refile-guess-by-from entity))))
 241
 242 (defun wl-refile-get-account-part-from-address (address)
 243   (if (string-match "\\([^@]+\\)@[^@]+" address)
 244       (wl-match-string 1 address)
 245     address))
 246
 247 (defun wl-refile-guess-by-from (entity)
 248   (let ((from
 249          (downcase (wl-address-header-extract-address
 250                     (elmo-msgdb-overview-entity-get-from entity)))))
 251     ;; search from alist
 252     (or (cdr (assoc from wl-refile-alist))
 253         (format "%s/%s" wl-refile-default-from-folder
 254                 (wl-refile-get-account-part-from-address from)))))
 255
 256 (defun wl-refile-guess-by-msgid (entity)
 257   (cdr (assoc (elmo-msgdb-overview-entity-get-references entity)
 258               wl-refile-msgid-alist)))
 259
 260 (defun wl-refile-guess-by-subject (entity)
 261   (cdr (assoc (wl-summary-subject-filter-func-internal
 262                (elmo-msgdb-overview-entity-get-subject entity))
 263               wl-refile-subject-alist)))
 264
 265 (require 'product)
 266 (product-provide (provide 'wl-refile) (require 'wl-version))
 267
 268 ;;; wl-refile.el ends here