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-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-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 (defun wl-refile-guess-by-subject (entity)
 260   (cdr (assoc (wl-summary-subject-filter-func-internal
 261                (elmo-msgdb-overview-entity-get-subject entity))
 262               wl-refile-subject-alist)))
 263
 264 (require 'product)
 265 (product-provide (provide 'wl-refile) (require 'wl-version))
 266
 267 ;;; wl-refile.el ends here