wl/wl-refile.el

   1 ;;; wl-refile.el -- Refile modules for Wanderlust.
   2
   3 ;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7 ;; Time-stamp: <2000-04-04 11:38:57 teranisi>
   8
   9 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31 ;;
  32
  33 (require 'wl-vars)
  34 (require 'wl-util)
  35 (provide 'wl-refile)
  36
  37
  38 (defvar wl-refile-alist nil)
  39 (defvar wl-refile-alist-file-name "refile-alist")
  40 ;; should be renamed to "refile-from-alist"
  41 (defvar wl-refile-msgid-alist nil)
  42 (defvar wl-refile-msgid-alist-file-name "refile-msgid-alist")
  43
  44 (defvar wl-refile-alist-max-length 1000)
  45
  46 (defun wl-refile-alist-setup ()
  47   (setq wl-refile-alist
  48         (elmo-object-load
  49          (expand-file-name wl-refile-alist-file-name
  50                            elmo-msgdb-dir)))
  51   (setq wl-refile-msgid-alist
  52         (elmo-object-load
  53          (expand-file-name wl-refile-msgid-alist-file-name
  54                            elmo-msgdb-dir))))
  55
  56 (defun wl-refile-alist-save (file-name alist)
  57   (save-excursion
  58     (let ((filename (expand-file-name file-name
  59                                       elmo-msgdb-dir))
  60           (tmp-buffer (get-buffer-create " *wl-refile-alist-tmp*")))
  61       (set-buffer tmp-buffer)
  62       (erase-buffer)
  63       (if (> (length alist) wl-refile-alist-max-length)
  64           (setcdr (nthcdr (1- wl-refile-alist-max-length) alist) nil))
  65       (prin1 alist tmp-buffer)
  66       (princ "\n" tmp-buffer)
  67       (if (file-writable-p filename)
  68           (write-region (point-min) (point-max)
  69                         filename nil 'no-msg)
  70         (message (format "%s is not writable." filename)))
  71       (kill-buffer tmp-buffer))))
  72
  73 (defun wl-refile-learn (entity dst)
  74   (let (tocc-list from key hit ml)
  75     (setq dst (elmo-string dst))
  76     (setq tocc-list
  77           (mapcar (function
  78                    (lambda (entity)
  79                      (downcase (wl-address-header-extract-address entity))))
  80                   (wl-parse-addresses
  81                    (concat
  82                     (elmo-msgdb-overview-entity-get-to entity) ","
  83                     (elmo-msgdb-overview-entity-get-cc entity)))))
  84     (while tocc-list
  85       (if (wl-string-member
  86            (car tocc-list)
  87            (mapcar (function downcase) wl-subscribed-mailing-list))
  88           (setq ml (car tocc-list)
  89                 tocc-list nil)
  90         (setq tocc-list (cdr tocc-list))))
  91     (if ml
  92         (setq key ml) ; subscribed entity!!
  93       (or (wl-address-user-mail-address-p
  94            (setq from
  95                  (downcase
  96                   (wl-address-header-extract-address
  97                    (elmo-msgdb-overview-entity-get-from
  98                     entity)))))
  99           (setq key from)))
 100     (if (not ml)
 101         (wl-refile-msgid-learn entity dst))
 102     (if key
 103         (if (setq hit (assoc key wl-refile-alist))
 104             (setcdr hit dst)
 105           (setq wl-refile-alist
 106                 (nconc wl-refile-alist (list (cons key dst))))))))
 107
 108 (defun wl-refile-msgid-learn (entity dst)
 109   (let ((key (elmo-msgdb-overview-entity-get-id entity))
 110         hit)
 111     (setq dst (elmo-string dst))
 112     (if key
 113         (if (setq hit (assoc key wl-refile-msgid-alist))
 114             (setcdr hit dst)
 115           (setq wl-refile-msgid-alist (cons (cons key dst)
 116                                             wl-refile-msgid-alist))))))
 117
 118 ;;
 119 ;; refile guess
 120 ;;
 121 (defvar wl-refile-guess-func-list
 122   '(wl-refile-guess-by-rule
 123     wl-refile-guess-by-msgid
 124     wl-refile-guess-by-history)
 125   "*Functions in this list are used for guessing refile destination folder.")
 126
 127 (defun wl-refile-guess (entity)
 128   (let ((flist wl-refile-guess-func-list) guess)
 129     (while flist
 130       (if (setq guess (funcall (car flist) entity))
 131           (setq flist nil)
 132         (setq flist (cdr flist))))
 133     guess))
 134
 135 (defun wl-refile-evaluate-rule (rule entity)
 136   "Returns folder string if RULE is matched to ENTITY.
 137 If RULE does not match ENTITY, returns nil."
 138   (let ((case-fold-search t)
 139         fields guess pairs value)
 140     (cond
 141      ((stringp rule) rule)
 142      ((listp (car rule))
 143       (setq fields (car rule))
 144       (while fields
 145         (if (setq guess (wl-refile-evaluate-rule (append (list (car fields))
 146                                                          (cdr rule))
 147                                                  entity))
 148             (setq fields nil)
 149           (setq fields (cdr fields))))
 150       guess)
 151      ((stringp (car rule))
 152       (setq pairs (cdr rule))
 153       (setq value (wl-refile-get-field-value entity (car rule)))
 154       (while pairs
 155         (if (and (string-match
 156                   (car (car pairs))
 157                   value)
 158                  (setq guess (wl-refile-evaluate-rule (cdr (car pairs))
 159                                                       entity)))
 160             (setq pairs nil)
 161           (setq pairs (cdr pairs))))
 162       guess)
 163      (t (error "Invalid structure for wl-refile-rule-alist")))))
 164
 165 (defun wl-refile-get-field-value (entity field)
 166   "Get FIELD value from ENTITY."
 167   (let ((field (downcase field))
 168         (fixed-fields '("from" "subject" "to" "cc")))
 169     (if (member field fixed-fields)
 170         (funcall (symbol-function
 171                   (intern (concat
 172                            "elmo-msgdb-overview-entity-get-"
 173                            field)))
 174                  entity)
 175       (elmo-msgdb-overview-entity-get-extra-field entity field))))
 176
 177 (defun wl-refile-guess-by-rule (entity)
 178   (let ((rules wl-refile-rule-alist)
 179         guess)
 180     (while rules
 181       (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
 182           (setq rules nil)
 183         (setq rules (cdr rules))))
 184     guess))
 185
 186 (defun wl-refile-guess-by-history (entity)
 187   (let ((tocc-list
 188          (mapcar (function
 189                   (lambda (entity)
 190                     (downcase (wl-address-header-extract-address entity))))
 191                  (wl-parse-addresses
 192                   (concat
 193                    (elmo-msgdb-overview-entity-get-to entity) ","
 194                    (elmo-msgdb-overview-entity-get-cc entity)))))
 195         ret-val)
 196     (setq tocc-list (elmo-list-delete
 197                      (or wl-user-mail-address-list
 198                          (list (wl-address-header-extract-address wl-from)))
 199                      tocc-list))
 200     (while tocc-list
 201       (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
 202           (setq tocc-list nil)
 203         (setq tocc-list (cdr tocc-list))))
 204     (or ret-val
 205         (wl-refile-guess-by-from entity))))
 206
 207 (defun wl-refile-get-account-part-from-address (address)
 208   (if (string-match "\\([^@]+\\)@[^@]+" address)
 209       (wl-match-string 1 address)
 210     address))
 211
 212 (defun wl-refile-guess-by-from (entity)
 213   (let ((from
 214          (downcase (wl-address-header-extract-address
 215                     (elmo-msgdb-overview-entity-get-from entity)))))
 216     ;; search from alist
 217     (or (cdr (assoc from wl-refile-alist))
 218         (format "%s/%s" wl-refile-default-from-folder
 219                 (wl-refile-get-account-part-from-address from)))))
 220
 221 (defun wl-refile-guess-by-msgid (entity)
 222   (cdr (assoc (elmo-msgdb-overview-entity-get-references entity)
 223               wl-refile-msgid-alist)))
 224
 225 ;;; wl-refile.el ends here