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