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