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: <00/04/05 01:20:16 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 (stringp value)
 156                  (string-match
 157                   (car (car pairs))
 158                   value)
 159                  (setq guess (wl-refile-expand-newtext
 160                               (wl-refile-evaluate-rule (cdr (car pairs))
 161                                                        entity)
 162                               value)))
 163             (setq pairs nil)
 164           (setq pairs (cdr pairs))))
 165       guess)
 166      (t (error "Invalid structure for wl-refile-rule-alist")))))
 167
 168 (defun wl-refile-get-field-value (entity field)
 169   "Get FIELD value from ENTITY."
 170   (let ((field (downcase field))
 171         (fixed-fields '("from" "subject" "to" "cc")))
 172     (if (member field fixed-fields)
 173         (funcall (symbol-function
 174                   (intern (concat
 175                            "elmo-msgdb-overview-entity-get-"
 176                            field)))
 177                  entity)
 178       (elmo-msgdb-overview-entity-get-extra-field entity field))))
 179
 180 (defun wl-refile-expand-newtext (newtext original)
 181   (let ((len (length newtext))
 182         (pos 0)
 183         c expanded beg N did-expand)
 184     (while (< pos len)
 185       (setq beg pos)
 186       (while (and (< pos len)
 187                   (not (= (aref newtext pos) ?\\)))
 188         (setq pos (1+ pos)))
 189       (unless (= beg pos)
 190         (push (substring newtext beg pos) expanded))
 191       (when (< pos len)
 192         ;; We hit a \; expand it.
 193         (setq did-expand t
 194               pos (1+ pos)
 195               c (aref newtext pos))
 196         (if (not (or (= c ?\&)
 197                      (and (>= c ?1)
 198                           (<= c ?9))))
 199             ;; \ followed by some character we don't expand.
 200             (push (char-to-string c) expanded)
 201           ;; \& or \N
 202           (if (= c ?\&)
 203               (setq N 0)
 204             (setq N (- c ?0)))
 205           (when (match-beginning N)
 206             (push (substring original (match-beginning N) (match-end N))
 207                   expanded))))
 208       (setq pos (1+ pos)))
 209     (if did-expand
 210         (apply (function concat) (nreverse expanded))
 211       newtext)))
 212
 213 (defun wl-refile-guess-by-rule (entity)
 214   (let ((rules wl-refile-rule-alist)
 215         guess)
 216     (while rules
 217       (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
 218           (setq rules nil)
 219         (setq rules (cdr rules))))
 220     guess))
 221
 222 (defun wl-refile-guess-by-history (entity)
 223   (let ((tocc-list
 224          (mapcar (function
 225                   (lambda (entity)
 226                     (downcase (wl-address-header-extract-address entity))))
 227                  (wl-parse-addresses
 228                   (concat
 229                    (elmo-msgdb-overview-entity-get-to entity) ","
 230                    (elmo-msgdb-overview-entity-get-cc entity)))))
 231         ret-val)
 232     (setq tocc-list (elmo-list-delete
 233                      (or wl-user-mail-address-list
 234                          (list (wl-address-header-extract-address wl-from)))
 235                      tocc-list))
 236     (while tocc-list
 237       (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
 238           (setq tocc-list nil)
 239         (setq tocc-list (cdr tocc-list))))
 240     (or ret-val
 241         (wl-refile-guess-by-from entity))))
 242
 243 (defun wl-refile-get-account-part-from-address (address)
 244   (if (string-match "\\([^@]+\\)@[^@]+" address)
 245       (wl-match-string 1 address)
 246     address))
 247
 248 (defun wl-refile-guess-by-from (entity)
 249   (let ((from
 250          (downcase (wl-address-header-extract-address
 251                     (elmo-msgdb-overview-entity-get-from entity)))))
 252     ;; search from alist
 253     (or (cdr (assoc from wl-refile-alist))
 254         (format "%s/%s" wl-refile-default-from-folder
 255                 (wl-refile-get-account-part-from-address from)))))
 256
 257 (defun wl-refile-guess-by-msgid (entity)
 258   (cdr (assoc (elmo-msgdb-overview-entity-get-references entity)
 259               wl-refile-msgid-alist)))
 260
 261 ;;; wl-refile.el ends here