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
   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 (require 'product)
  35 (product-provide (provide 'wl-refile) (require 'wl-version))
  36
  37 (defvar wl-refile-alist nil)
  38 (defvar wl-refile-alist-file-name "refile-alist")
  39 ;; should be renamed to "refile-from-alist"
  40 (defvar wl-refile-msgid-alist nil)
  41 (defvar wl-refile-msgid-alist-file-name "refile-msgid-alist")
  42 (defvar wl-refile-subject-alist nil)
  43 (defvar wl-refile-subject-alist-file-name "refile-subject-alist")
  44
  45 (defvar wl-refile-alist-max-length 1000)
  46
  47 (defun wl-refile-alist-setup ()
  48   (let ((flist wl-refile-guess-func-list))
  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-dir) 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-dir) 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-dir) 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-dir)
  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 (function
  90                    (lambda (entity)
  91                      (downcase (wl-address-header-extract-address entity))))
  92                   (wl-parse-addresses
  93                    (concat
  94                     (elmo-msgdb-overview-entity-get-to entity) ","
  95                     (elmo-msgdb-overview-entity-get-cc entity)))))
  96     (while tocc-list
  97       (if (wl-string-member
  98            (car tocc-list)
  99            (mapcar (function downcase) wl-subscribed-mailing-list))
 100           (setq ml (car tocc-list)
 101                 tocc-list nil)
 102         (setq tocc-list (cdr tocc-list))))
 103     (if ml
 104         (setq key ml) ; subscribed entity!!
 105       (or (wl-address-user-mail-address-p
 106            (setq from
 107                  (downcase
 108                   (wl-address-header-extract-address
 109                    (elmo-msgdb-overview-entity-get-from
 110                     entity)))))
 111           (setq key from))
 112       (if (or wl-refile-msgid-alist
 113               (memq 'wl-refile-guess-by-msgid
 114                     wl-refile-guess-func-list))
 115           (wl-refile-msgid-learn entity dst))
 116       (if (or wl-refile-subject-alist
 117               (memq 'wl-refile-guess-by-subject
 118                     wl-refile-guess-func-list))
 119           (wl-refile-subject-learn entity dst)))
 120     (when key
 121       (if (setq hit (assoc key wl-refile-alist))
 122           (setq wl-refile-alist (delq hit wl-refile-alist)))
 123       (setq wl-refile-alist (cons (cons key dst)
 124                                   wl-refile-alist)))))
 125
 126 (defun wl-refile-msgid-learn (entity dst)
 127   (let ((key (elmo-msgdb-overview-entity-get-id entity))
 128         hit)
 129     (setq dst (elmo-string dst))
 130     (if key
 131         (if (setq hit (assoc key wl-refile-msgid-alist))
 132             (setcdr hit dst)
 133           (setq wl-refile-msgid-alist (cons (cons key dst)
 134                                             wl-refile-msgid-alist))))))
 135
 136 (defun wl-refile-subject-learn (entity dst)
 137   (let ((subject (wl-summary-subject-filter-func-internal
 138                   (elmo-msgdb-overview-entity-get-subject entity)))
 139         hit)
 140     (setq dst (elmo-string dst))
 141     (if (and subject (not (string= subject "")))
 142         (if (setq hit (assoc subject wl-refile-subject-alist))
 143             (setcdr hit dst)
 144           (setq wl-refile-subject-alist (cons (cons subject dst)
 145                                             wl-refile-subject-alist))))))
 146
 147 ;;
 148 ;; refile guess
 149 ;;
 150 (defvar wl-refile-guess-func-list
 151   '(wl-refile-guess-by-rule
 152     wl-refile-guess-by-msgid
 153     wl-refile-guess-by-subject
 154     wl-refile-guess-by-history)
 155   "*Functions in this list are used for guessing refile destination folder.")
 156
 157 (defun wl-refile-guess (entity)
 158   (let ((flist wl-refile-guess-func-list) guess)
 159     (while flist
 160       (if (setq guess (funcall (car flist) entity))
 161           (setq flist nil)
 162         (setq flist (cdr flist))))
 163     guess))
 164
 165 (defun wl-refile-evaluate-rule (rule entity)
 166   "Return folder string if RULE is matched to ENTITY.
 167 If RULE does not match ENTITY, returns nil."
 168   (let ((case-fold-search t)
 169         fields guess pairs value)
 170     (cond
 171      ((stringp rule) rule)
 172      ((listp (car rule))
 173       (setq fields (car rule))
 174       (while fields
 175         (if (setq guess (wl-refile-evaluate-rule (append (list (car fields))
 176                                                          (cdr rule))
 177                                                  entity))
 178             (setq fields nil)
 179           (setq fields (cdr fields))))
 180       guess)
 181      ((stringp (car rule))
 182       (setq pairs (cdr rule))
 183       (setq value (wl-refile-get-field-value entity (car rule)))
 184       (while pairs
 185         (if (and (stringp value)
 186                  (string-match
 187                   (car (car pairs))
 188                   value)
 189                  (setq guess (wl-refile-expand-newtext
 190                               (wl-refile-evaluate-rule (cdr (car pairs))
 191                                                        entity)
 192                               value)))
 193             (setq pairs nil)
 194           (setq pairs (cdr pairs))))
 195       guess)
 196      (t (error "Invalid structure for wl-refile-rule-alist")))))
 197
 198 (defun wl-refile-get-field-value (entity field)
 199   "Get FIELD value from ENTITY."
 200   (let ((field (downcase field))
 201         (fixed-fields '("from" "subject" "to" "cc")))
 202     (if (member field fixed-fields)
 203         (funcall (symbol-function
 204                   (intern (concat
 205                            "elmo-msgdb-overview-entity-get-"
 206                            field)))
 207                  entity)
 208       (elmo-msgdb-overview-entity-get-extra-field entity field))))
 209
 210 (defun wl-refile-expand-newtext (newtext original)
 211   (let ((len (length newtext))
 212         (pos 0)
 213         c expanded beg N did-expand)
 214     (while (< pos len)
 215       (setq beg pos)
 216       (while (and (< pos len)
 217                   (not (= (aref newtext pos) ?\\)))
 218         (setq pos (1+ pos)))
 219       (unless (= beg pos)
 220         (push (substring newtext beg pos) expanded))
 221       (when (< pos len)
 222         ;; We hit a \; expand it.
 223         (setq did-expand t
 224               pos (1+ pos)
 225               c (aref newtext pos))
 226         (if (not (or (= c ?\&)
 227                      (and (>= c ?1)
 228                           (<= c ?9))))
 229             ;; \ followed by some character we don't expand.
 230             (push (char-to-string c) expanded)
 231           ;; \& or \N
 232           (if (= c ?\&)
 233               (setq N 0)
 234             (setq N (- c ?0)))
 235           (when (match-beginning N)
 236             (push (substring original (match-beginning N) (match-end N))
 237                   expanded))))
 238       (setq pos (1+ pos)))
 239     (if did-expand
 240         (apply (function concat) (nreverse expanded))
 241       newtext)))
 242
 243 (defun wl-refile-guess-by-rule (entity)
 244   (let ((rules wl-refile-rule-alist)
 245         guess)
 246     (while rules
 247       (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
 248           (setq rules nil)
 249         (setq rules (cdr rules))))
 250     guess))
 251
 252 (defun wl-refile-guess-by-history (entity)
 253   (let ((tocc-list
 254          (mapcar (function
 255                   (lambda (entity)
 256                     (downcase (wl-address-header-extract-address entity))))
 257                  (wl-parse-addresses
 258                   (concat
 259                    (elmo-msgdb-overview-entity-get-to entity) ","
 260                    (elmo-msgdb-overview-entity-get-cc entity)))))
 261         ret-val)
 262     (setq tocc-list (elmo-list-delete
 263                      (or wl-user-mail-address-list
 264                          (list (wl-address-header-extract-address wl-from)))
 265                      tocc-list))
 266     (while tocc-list
 267       (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
 268           (setq tocc-list nil)
 269         (setq tocc-list (cdr tocc-list))))
 270     (or ret-val
 271         (wl-refile-guess-by-from entity))))
 272
 273 (defun wl-refile-get-account-part-from-address (address)
 274   (if (string-match "\\([^@]+\\)@[^@]+" address)
 275       (wl-match-string 1 address)
 276     address))
 277
 278 (defun wl-refile-guess-by-from (entity)
 279   (let ((from
 280          (downcase (wl-address-header-extract-address
 281                     (elmo-msgdb-overview-entity-get-from entity)))))
 282     ;; search from alist
 283     (or (cdr (assoc from wl-refile-alist))
 284         (format "%s/%s" wl-refile-default-from-folder
 285                 (wl-refile-get-account-part-from-address from)))))
 286
 287 (defun wl-refile-guess-by-msgid (entity)
 288   (cdr (assoc (elmo-msgdb-overview-entity-get-references entity)
 289               wl-refile-msgid-alist)))
 290
 291 (defun wl-refile-guess-by-subject (entity)
 292   (cdr (assoc (wl-summary-subject-filter-func-internal
 293                (elmo-msgdb-overview-entity-get-subject entity))
 294               wl-refile-subject-alist)))
 295
 296 ;;; wl-refile.el ends here