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 (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-functions))
  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-functions))
 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-functions))
 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-functions
 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 (defvar wl-refile-guess-func-list wl-refile-guess-functions)
 158 (make-obsolete-variable 'wl-refile-guess-func-list 'wl-refile-guess-functions)
 159
 160 (defun wl-refile-guess (entity)
 161   (let ((flist wl-refile-guess-functions) guess)
 162     (while flist
 163       (if (setq guess (funcall (car flist) entity))
 164           (setq flist nil)
 165         (setq flist (cdr flist))))
 166     guess))
 167
 168 (defun wl-refile-evaluate-rule (rule entity)
 169   "Return folder string if RULE is matched to ENTITY.
 170 If RULE does not match ENTITY, returns nil."
 171   (let ((case-fold-search t)
 172         fields guess pairs value)
 173     (cond
 174      ((stringp rule) rule)
 175      ((listp (car rule))
 176       (setq fields (car rule))
 177       (while fields
 178         (if (setq guess (wl-refile-evaluate-rule (append (list (car fields))
 179                                                          (cdr rule))
 180                                                  entity))
 181             (setq fields nil)
 182           (setq fields (cdr fields))))
 183       guess)
 184      ((stringp (car rule))
 185       (setq pairs (cdr rule))
 186       (setq value (wl-refile-get-field-value entity (car rule)))
 187       (while pairs
 188         (if (and (stringp value)
 189                  (string-match
 190                   (car (car pairs))
 191                   value)
 192                  (setq guess (wl-refile-expand-newtext
 193                               (wl-refile-evaluate-rule (cdr (car pairs))
 194                                                        entity)
 195                               value)))
 196             (setq pairs nil)
 197           (setq pairs (cdr pairs))))
 198       guess)
 199      (t (error "Invalid structure for wl-refile-rule-alist")))))
 200
 201 (defun wl-refile-get-field-value (entity field)
 202   "Get FIELD value from ENTITY."
 203   (let ((field (downcase field))
 204         (fixed-fields '("from" "subject" "to" "cc")))
 205     (if (member field fixed-fields)
 206         (funcall (symbol-function
 207                   (intern (concat
 208                            "elmo-msgdb-overview-entity-get-"
 209                            field)))
 210                  entity)
 211       (elmo-msgdb-overview-entity-get-extra-field entity field))))
 212
 213 (defun wl-refile-expand-newtext (newtext original)
 214   (let ((len (length newtext))
 215         (pos 0)
 216         c expanded beg N did-expand)
 217     (while (< pos len)
 218       (setq beg pos)
 219       (while (and (< pos len)
 220                   (not (= (aref newtext pos) ?\\)))
 221         (setq pos (1+ pos)))
 222       (unless (= beg pos)
 223         (push (substring newtext beg pos) expanded))
 224       (when (< pos len)
 225         ;; We hit a \; expand it.
 226         (setq did-expand t
 227               pos (1+ pos)
 228               c (aref newtext pos))
 229         (if (not (or (= c ?\&)
 230                      (and (>= c ?1)
 231                           (<= c ?9))))
 232             ;; \ followed by some character we don't expand.
 233             (push (char-to-string c) expanded)
 234           ;; \& or \N
 235           (if (= c ?\&)
 236               (setq N 0)
 237             (setq N (- c ?0)))
 238           (when (match-beginning N)
 239             (push (substring original (match-beginning N) (match-end N))
 240                   expanded))))
 241       (setq pos (1+ pos)))
 242     (if did-expand
 243         (apply (function concat) (nreverse expanded))
 244       newtext)))
 245
 246 (defun wl-refile-guess-by-rule (entity)
 247   (let ((rules wl-refile-rule-alist)
 248         guess)
 249     (while rules
 250       (if (setq guess (wl-refile-evaluate-rule (car rules) entity))
 251           (setq rules nil)
 252         (setq rules (cdr rules))))
 253     guess))
 254
 255 (defun wl-refile-guess-by-history (entity)
 256   (let ((tocc-list
 257          (mapcar (function
 258                   (lambda (entity)
 259                     (downcase (wl-address-header-extract-address entity))))
 260                  (wl-parse-addresses
 261                   (concat
 262                    (elmo-msgdb-overview-entity-get-to entity) ","
 263                    (elmo-msgdb-overview-entity-get-cc entity)))))
 264         ret-val)
 265     (setq tocc-list (elmo-list-delete
 266                      (or wl-user-mail-address-list
 267                          (list (wl-address-header-extract-address wl-from)))
 268                      tocc-list))
 269     (while tocc-list
 270       (if (setq ret-val (cdr (assoc (car tocc-list) wl-refile-alist)))
 271           (setq tocc-list nil)
 272         (setq tocc-list (cdr tocc-list))))
 273     (or ret-val
 274         (wl-refile-guess-by-from entity))))
 275
 276 (defun wl-refile-get-account-part-from-address (address)
 277   (if (string-match "\\([^@]+\\)@[^@]+" address)
 278       (wl-match-string 1 address)
 279     address))
 280
 281 (defun wl-refile-guess-by-from (entity)
 282   (let ((from
 283          (downcase (wl-address-header-extract-address
 284                     (elmo-msgdb-overview-entity-get-from entity)))))
 285     ;; search from alist
 286     (or (cdr (assoc from wl-refile-alist))
 287         (format "%s/%s" wl-refile-default-from-folder
 288                 (wl-refile-get-account-part-from-address from)))))
 289
 290 (defun wl-refile-guess-by-msgid (entity)
 291   (cdr (assoc (elmo-msgdb-overview-entity-get-references entity)
 292               wl-refile-msgid-alist)))
 293
 294 (defun wl-refile-guess-by-subject (entity)
 295   (cdr (assoc (wl-summary-subject-filter-func-internal
 296                (elmo-msgdb-overview-entity-get-subject entity))
 297               wl-refile-subject-alist)))
 298
 299 ;;; wl-refile.el ends here