elmo/elmo-split.el

   1 ;;; elmo-split.el --- Split messages according to the user defined rules.
   2
   3 ;; Copyright (C) 2002 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 ELMO (Elisp Library for Message Orchestration).
   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 ;; Put following lines on your .emacs.
  29 ;;
  30 ;; (autoload 'elmo-split "elmo-split" "Split messages on the folder." t)
  31 ;;
  32 ;; A command elmo-split is provided.  If you enter:
  33 ;;
  34 ;; M-x elmo-split
  35 ;;
  36 ;; Messages in the `elmo-split-folder' are splitted to the folders
  37 ;; according to the definition of `elmo-split-rule'.
  38 ;;
  39
  40 (require 'elmo)
  41
  42 ;;; Code:
  43 (defcustom elmo-split-rule nil
  44   "Split rule for the command `elmo-split'.
  45 The format of this variable is a list of RULEs which has form like:
  46 \(CONDITION FOLDER [continue]\)
  47
  48 The 1st element CONDITION is a sexp which consists of following.
  49
  50 1. Functions which accept argument FIELD-NAME and VALUE.
  51 FIELD-NAME is a symbol of the field name.
  52
  53 `equal'             ... True if the field value equals to VALUE.
  54                         Case of the letters are ignored.
  55 `match'             ... True if the field value matches to VALUE.
  56                         VALUE can contain \\& and \\N which will substitute
  57                         from matching \\(\\) patterns in the previous VALUE.
  58 `address-equal'     ... True if one of the addresses in the field equals to
  59                         VALUE. Case of the letters are ignored.
  60 `address-match'     ... True if one of the addresses in the field matches to
  61                         VALUE.
  62                         VALUE can contain \\& and \\N which will substitute
  63                         from matching \\(\\) patterns in the previous VALUE.
  64
  65 2. Functions which accept any number of arguments.
  66
  67 `or'                ... True if one of the argument returns true.
  68 `and'               ... True if all of the arguments return true.
  69
  70 3. A symbol.
  71
  72 When a symbol is specified, it is evaluated.
  73
  74 The 2nd element FOLDER is the name of the folder to split messages into.
  75
  76 When the 3rd element `continue' is specified as symbol, evaluating rules is
  77 not stopped even when the condition is satisfied.
  78
  79 Example:
  80
  81 \(setq elmo-split-rule
  82       ;; Messages from spammers are stored in `+junk'
  83       '(((or (address-equal from \"i.am@spammer\")
  84              (address-equal from \"dull-work@dull-boy\")
  85              (address-equal from \"death-march@software\")
  86              (address-equal from \"ares@aon.at\")
  87              (address-equal from \"get-money@richman\"))
  88          \"+junk\")
  89         ;; Messages from mule mailing list are stored in `%mule'
  90         ((equal x-ml-name \"mule\") \"%mule\")
  91         ;; Messages from wanderlust mailing list are stored in `%wanderlust'
  92         ;; and continue evaluating following rules.
  93         ((equal x-ml-name \"wanderlust\") \"%wanderlust\" continue)
  94         ;; Messages from DoCoMo user are stored in `+docomo-{username}'.
  95         ((match from \"\\\\(.*\\\\)@docomo\\\\.ne\\\\.jp\")
  96          \"+docomo-\\\\1\")
  97         ;; Unmatched mails go to `+inbox'.
  98         (t \"+inbox\")))"
  99   :group 'elmo
 100   :type 'sexp)
 101
 102 (defcustom elmo-split-folder "%inbox"
 103   "Target folder or list of folders for splitting."
 104   :type '(choice (string :tag "folder name")
 105                  (repeat (string :tag "folder name")))
 106   :group 'elmo)
 107
 108 (defcustom elmo-split-log-coding-system 'x-ctext
 109   "A coding-system for writing log file."
 110   :type 'coding-system
 111   :group 'elmo)
 112
 113 (defcustom elmo-split-log-file "~/.elmo/split-log"
 114   "The file name of the split log."
 115   :type 'file
 116   :group 'elmo)
 117
 118 ;;;
 119 (defvar elmo-split-match-string-internal nil
 120   "Internal variable for string matching.  Don't touch this variable by hand.")
 121
 122 (defvar elmo-split-message-entity nil
 123   "Buffer local variable to store mime-entity.")
 124 (make-variable-buffer-local 'elmo-split-message-entity)
 125
 126 ;;;
 127 (defun elmo-split-or (buffer &rest args)
 128   (catch 'done
 129     (dolist (arg args)
 130       (if (elmo-split-eval buffer arg)
 131           (throw 'done t)))
 132     nil))
 133
 134 (defun elmo-split-and (buffer &rest args)
 135   (catch 'done
 136     (dolist (arg args)
 137       (unless (elmo-split-eval buffer arg)
 138         (throw 'done nil)))
 139     t))
 140
 141 (defun elmo-split-address-equal (buffer field value)
 142   (with-current-buffer buffer
 143     (let ((addrs (mapcar
 144                   'std11-address-string
 145                   (std11-parse-addresses-string
 146                    (std11-field-body (symbol-name field)))))
 147           (case-fold-search t)
 148           result)
 149       (while addrs
 150         (when (string-match (concat "^"
 151                                     (regexp-quote value)
 152                                     "$") (car addrs))
 153           (setq addrs nil
 154                 result t))
 155         (setq addrs (cdr addrs)))
 156       result)))
 157
 158 (defun elmo-split-address-match (buffer field value)
 159   (with-current-buffer buffer
 160     (let ((addrs (mapcar
 161                   'std11-address-string
 162                   (std11-parse-addresses-string
 163                    (std11-field-body (symbol-name field)))))
 164           result)
 165       (while addrs
 166         (when (string-match value (car addrs))
 167           (setq elmo-split-match-string-internal (car addrs)
 168                 addrs nil
 169                 result t))
 170         (setq addrs (cdr addrs)))
 171       result)))
 172
 173 (defun elmo-split-fetch-decoded-field (entity field-name)
 174   (let ((sym (intern (capitalize field-name)))
 175         (field-body (mime-entity-fetch-field entity field-name)))
 176     (when field-body
 177       (mime-decode-field-body field-body sym 'plain))))
 178
 179 (defun elmo-split-equal (buffer field value)
 180   (with-current-buffer buffer
 181     (let ((field-value (and
 182                         elmo-split-message-entity
 183                         (elmo-split-fetch-decoded-field
 184                          elmo-split-message-entity
 185                          (symbol-name field)))))
 186       (equal field-value value))))
 187
 188 (defun elmo-split-match (buffer field value)
 189   (with-current-buffer buffer
 190     (let ((field-value (and elmo-split-message-entity
 191                             (elmo-split-fetch-decoded-field
 192                              elmo-split-message-entity
 193                              (symbol-name field)))))
 194       (and field-value
 195            (when (string-match value field-value)
 196              (setq elmo-split-match-string-internal field-value))))))
 197
 198 (defun elmo-split-eval (buffer sexp)
 199   (cond
 200    ((consp sexp)
 201     (apply (intern (concat "elmo-split-" (symbol-name (car sexp))))
 202            buffer
 203            (cdr sexp)))
 204    ((stringp sexp)
 205     (std11-field-body sexp))
 206    (t (eval sexp))))
 207
 208 (defun elmo-split-log (message reharsal)
 209   (with-current-buffer (get-buffer-create "*elmo-split*")
 210     (goto-char (point-max))
 211     (let ((start (point))
 212           (coding-system-for-write elmo-split-log-coding-system))
 213       (insert message)
 214       (if reharsal
 215           (progn
 216             (pop-to-buffer (current-buffer))
 217             (sit-for 0))
 218         (write-region start (point) elmo-split-log-file t 'no-msg)))))
 219
 220 ;;;###autoload
 221 (defun elmo-split (&optional arg)
 222   "Split messages in the `elmo-split-folder' according to `elmo-split-rule'.
 223 If prefix argument ARG is specified, do a reharsal (no harm)."
 224   (interactive "P")
 225   (unless elmo-split-rule
 226     (error "Split rule does not exist.  Set `elmo-split-rule' first"))
 227   (let ((folders (if (listp elmo-split-folder)
 228                      elmo-split-folder
 229                    (list elmo-split-folder)))
 230         (count 0)
 231         (fcount 0)
 232         ret)
 233     (dolist (folder folders)
 234       (setq ret (elmo-split-subr (elmo-make-folder folder) arg)
 235             count (+ count (car ret))
 236             fcount (+ fcount (cdr ret))))
 237     (run-hooks 'elmo-split-hook)
 238     (message
 239      (concat
 240       (cond
 241        ((eq count 0)
 242         "No message is splitted")
 243        ((eq count 1)
 244         "1 message is splitted")
 245        (t
 246         (format "%d messages are splitted" count)))
 247       (if (eq fcount 0)
 248           "."
 249         (format " (%d failure)." fcount))))))
 250
 251 (defun elmo-split-subr (folder &optional reharsal)
 252   (let ((elmo-inhibit-display-retrieval-progress t)
 253         (count 0)
 254         (fcount 0)
 255         msgs fname target-folder failure)
 256     (message "Splitting...")
 257     (elmo-folder-open-internal folder)
 258     (setq msgs (elmo-folder-list-messages folder))
 259     (elmo-progress-set 'elmo-split (length msgs) "Splitting...")
 260     (unwind-protect
 261         (progn
 262           (with-temp-buffer
 263             (dolist (msg msgs)
 264               (erase-buffer)
 265               (when (ignore-errors
 266                       (elmo-message-fetch folder msg
 267                                           (elmo-make-fetch-strategy 'entire)
 268                                           nil (current-buffer) 'unread))
 269                 (setq elmo-split-message-entity (mime-parse-buffer))
 270                 (catch 'terminate
 271                   (dolist (rule elmo-split-rule)
 272                     (setq elmo-split-match-string-internal nil)
 273                     (when (elmo-split-eval (current-buffer) (car rule))
 274                       (if elmo-split-match-string-internal
 275                           (setq fname (elmo-expand-newtext
 276                                        (nth 1 rule)
 277                                        elmo-split-match-string-internal))
 278                         (setq fname (nth 1 rule)))
 279                       (unless reharsal
 280                         (setq failure nil)
 281                         (condition-case nil
 282                             (progn
 283                               (setq target-folder (elmo-make-folder fname))
 284                               (unless (elmo-folder-exists-p target-folder)
 285                                 (when
 286                                     (and
 287                                      (elmo-folder-creatable-p
 288                                       target-folder)
 289                                      (y-or-n-p
 290                                       (format
 291                                        "Folder %s does not exist, Create it? "
 292                                        fname)))
 293                                   (elmo-folder-create target-folder)))
 294                               (elmo-folder-open-internal target-folder)
 295                               (elmo-folder-append-buffer target-folder 'unread)
 296                               (elmo-folder-close-internal target-folder))
 297                           (error (setq failure t)
 298                                  (incf fcount)))
 299                         (unless failure
 300                           (ignore-errors
 301                             (elmo-folder-delete-messages folder (list msg))))
 302                         (incf count))
 303                       (elmo-split-log
 304                        (concat "From "
 305                                (nth 1 (std11-extract-address-components
 306                                        (or (std11-field-body "from") "")))
 307                                "  " (or (std11-field-body "date") "") "\n"
 308                                " Subject: "
 309                                (eword-decode-string (or (std11-field-body
 310                                                          "subject") ""))
 311                                "\n"
 312                                (if reharsal
 313                                    "  Test: "
 314                                  "  Folder: ")
 315                                fname "/0" "\n")
 316                        reharsal)
 317                       (unless (eq (nth 2 rule) 'continue)
 318                         (throw 'terminate nil))))))
 319               (elmo-progress-notify 'elmo-split)))
 320           (elmo-folder-close-internal folder))
 321       (elmo-progress-clear 'elmo-split))
 322     (cons count fcount)))
 323
 324 (require 'product)
 325 (product-provide (provide 'elmo-split) (require 'elmo-version))
 326
 327 ;;; elmo-split.el ends here