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 ACTION [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 ACTION is the name of the destination folder or some symbol.
  75 If CONDITION is satisfied, the message is splitted according to this value.
  76
  77 If ACTION is a string, it will be considered as the name of destination folder.
  78 Symbol `delete' means that the substance of the message will be removed. On the
  79 other hand, symbol `noop' is used to do nothing and keep the substance of the
  80 message as it is. Or, if some function is specified, it will be called.
  81
  82 When the 3rd element `continue' is specified as symbol, evaluating rules is
  83 not stopped even when the condition is satisfied.
  84
  85 Example:
  86
  87 \(setq elmo-split-rule
  88       ;; Messages from spammers are stored in `+junk'
  89       '(((or (address-equal from \"i.am@spammer\")
  90              (address-equal from \"dull-work@dull-boy\")
  91              (address-equal from \"death-march@software\")
  92              (address-equal from \"ares@aon.at\")
  93              (address-equal from \"get-money@richman\"))
  94          \"+junk\")
  95         ;; Messages from mule mailing list are stored in `%mule'
  96         ((equal x-ml-name \"mule\") \"%mule\")
  97         ;; Messages from wanderlust mailing list are stored in `%wanderlust'
  98         ;; and continue evaluating following rules.
  99         ((equal x-ml-name \"wanderlust\") \"%wanderlust\" continue)
 100         ;; Messages from DoCoMo user are stored in `+docomo-{username}'.
 101         ((match from \"\\\\(.*\\\\)@docomo\\\\.ne\\\\.jp\")
 102          \"+docomo-\\\\1\")
 103         ;; Unmatched mails go to `+inbox'.
 104         (t \"+inbox\")))"
 105   :group 'elmo
 106   :type 'sexp)
 107
 108 (defcustom elmo-split-folder "%inbox"
 109   "Target folder or list of folders for splitting."
 110   :type '(choice (string :tag "folder name")
 111                  (repeat (string :tag "folder name")))
 112   :group 'elmo)
 113
 114 (defcustom elmo-split-default-action 'noop
 115   "Default action for messages which pass all rules."
 116   :type '(choice (const :tag "do not touch" noop)
 117                  (const :tag "delete" delete)
 118                  (string :tag "folder name")
 119                  (function :tag "function"))
 120   :group 'elmo)
 121
 122 (defcustom elmo-split-log-coding-system 'x-ctext
 123   "A coding-system for writing log file."
 124   :type 'coding-system
 125   :group 'elmo)
 126
 127 (defcustom elmo-split-log-file "~/.elmo/split-log"
 128   "The file name of the split log."
 129   :type 'file
 130   :group 'elmo)
 131
 132 ;;;
 133 (defvar elmo-split-match-string-internal nil
 134   "Internal variable for string matching.  Don't touch this variable by hand.")
 135
 136 (defvar elmo-split-message-entity nil
 137   "Buffer local variable to store mime-entity.")
 138 (make-variable-buffer-local 'elmo-split-message-entity)
 139
 140 ;;;
 141 (defun elmo-split-or (buffer &rest args)
 142   (catch 'done
 143     (dolist (arg args)
 144       (if (elmo-split-eval buffer arg)
 145           (throw 'done t)))
 146     nil))
 147
 148 (defun elmo-split-and (buffer &rest args)
 149   (catch 'done
 150     (dolist (arg args)
 151       (unless (elmo-split-eval buffer arg)
 152         (throw 'done nil)))
 153     t))
 154
 155 (defun elmo-split-> (buffer size)
 156   (> (buffer-size buffer) size))
 157
 158 (defun elmo-split-< (buffer size)
 159   (< (buffer-size buffer) size))
 160
 161 (defun elmo-split-address-equal (buffer field value)
 162   (with-current-buffer buffer
 163     (let ((addrs (mapcar
 164                   'std11-address-string
 165                   (std11-parse-addresses-string
 166                    (std11-field-body (symbol-name field)))))
 167           (case-fold-search t)
 168           result)
 169       (while addrs
 170         (when (string-match (concat "^"
 171                                     (regexp-quote value)
 172                                     "$") (car addrs))
 173           (setq addrs nil
 174                 result t))
 175         (setq addrs (cdr addrs)))
 176       result)))
 177
 178 (defun elmo-split-address-match (buffer field value)
 179   (with-current-buffer buffer
 180     (let ((addrs (mapcar
 181                   'std11-address-string
 182                   (std11-parse-addresses-string
 183                    (std11-field-body (symbol-name field)))))
 184           result)
 185       (while addrs
 186         (when (string-match value (car addrs))
 187           (setq elmo-split-match-string-internal (car addrs)
 188                 addrs nil
 189                 result t))
 190         (setq addrs (cdr addrs)))
 191       result)))
 192
 193 (defun elmo-split-fetch-decoded-field (entity field-name)
 194   (let ((sym (intern (capitalize field-name)))
 195         (field-body (mime-entity-fetch-field entity field-name)))
 196     (when field-body
 197       (mime-decode-field-body field-body sym 'plain))))
 198
 199 (defun elmo-split-equal (buffer field value)
 200   (with-current-buffer buffer
 201     (let ((field-value (and
 202                         elmo-split-message-entity
 203                         (elmo-split-fetch-decoded-field
 204                          elmo-split-message-entity
 205                          (symbol-name field)))))
 206       (equal field-value value))))
 207
 208 (defun elmo-split-match (buffer field value)
 209   (with-current-buffer buffer
 210     (let ((field-value (and elmo-split-message-entity
 211                             (elmo-split-fetch-decoded-field
 212                              elmo-split-message-entity
 213                              (symbol-name field)))))
 214       (and field-value
 215            (when (string-match value field-value)
 216              (setq elmo-split-match-string-internal field-value))))))
 217
 218 (defun elmo-split-eval (buffer sexp)
 219   (cond
 220    ((consp sexp)
 221     (apply (intern (concat "elmo-split-" (symbol-name (car sexp))))
 222            buffer
 223            (cdr sexp)))
 224    ((stringp sexp)
 225     (std11-field-body sexp))
 226    (t (eval sexp))))
 227
 228 (defun elmo-split-log (message reharsal)
 229   (with-current-buffer (get-buffer-create "*elmo-split*")
 230     (goto-char (point-max))
 231     (let ((start (point))
 232           (coding-system-for-write elmo-split-log-coding-system))
 233       (insert message)
 234       (if reharsal
 235           (progn
 236             (pop-to-buffer (current-buffer))
 237             (sit-for 0))
 238         (write-region start (point) elmo-split-log-file t 'no-msg)))))
 239
 240 ;;;###autoload
 241 (defun elmo-split (&optional arg)
 242   "Split messages in the `elmo-split-folder' according to `elmo-split-rule'.
 243 If prefix argument ARG is specified, do a reharsal (no harm)."
 244   (interactive "P")
 245   (unless elmo-split-rule
 246     (error "Split rule does not exist.  Set `elmo-split-rule' first"))
 247   (let ((folders (if (listp elmo-split-folder)
 248                      elmo-split-folder
 249                    (list elmo-split-folder)))
 250         (count 0)
 251         (fcount 0)
 252         ret)
 253     (dolist (folder folders)
 254       (setq ret (elmo-split-subr (elmo-make-folder folder) arg)
 255             count (+ count (car ret))
 256             fcount (+ fcount (cdr ret))))
 257     (run-hooks 'elmo-split-hook)
 258     (message
 259      (concat
 260       (cond
 261        ((eq count 0)
 262         "No message is splitted")
 263        ((eq count 1)
 264         "1 message is splitted")
 265        (t
 266         (format "%d messages are splitted" count)))
 267       (if (eq fcount 0)
 268           "."
 269         (format " (%d failure)." fcount))))))
 270
 271 (defun elmo-split-subr (folder &optional reharsal)
 272   (let ((elmo-inhibit-display-retrieval-progress t)
 273         (count 0)
 274         (fcount 0)
 275         (default-rule `((t ,elmo-split-default-action)))
 276         msgs action target-folder failure delete-substance
 277         record-log log-string)
 278     (message "Splitting...")
 279     (elmo-folder-open-internal folder)
 280     (setq msgs (elmo-folder-list-messages folder))
 281     (elmo-progress-set 'elmo-split (length msgs) "Splitting...")
 282     (unwind-protect
 283         (progn
 284           (with-temp-buffer
 285             (dolist (msg msgs)
 286               (erase-buffer)
 287               (when (ignore-errors
 288                       (elmo-message-fetch folder msg
 289                                           (elmo-make-fetch-strategy 'entire)
 290                                           nil (current-buffer) 'unread))
 291                 (setq elmo-split-message-entity (mime-parse-buffer))
 292                 (catch 'terminate
 293                   (dolist (rule (append elmo-split-rule default-rule))
 294                     (setq elmo-split-match-string-internal nil)
 295                     (when (elmo-split-eval (current-buffer) (car rule))
 296                       (if (and (stringp (nth 1 rule))
 297                                elmo-split-match-string-internal)
 298                           (setq action (elmo-expand-newtext
 299                                         (nth 1 rule)
 300                                         elmo-split-match-string-internal))
 301                         (setq action (nth 1 rule)))
 302                       ;; 1. ACTION & DELETION
 303                       (unless reharsal
 304                         (setq failure nil
 305                               delete-substance nil
 306                               record-log nil
 307                               log-string nil)
 308                         (cond
 309                          ((stringp action)
 310                           (condition-case nil
 311                               (progn
 312                                 (setq target-folder (elmo-make-folder action))
 313                                 (unless (elmo-folder-exists-p target-folder)
 314                                   (when
 315                                       (and
 316                                        (elmo-folder-creatable-p target-folder)
 317                                        (y-or-n-p
 318                                         (format
 319                                          "Folder %s does not exist, Create it? "
 320                                          action)))
 321                                     (elmo-folder-create target-folder)))
 322                                 (elmo-folder-open-internal target-folder)
 323                                 (elmo-folder-append-buffer target-folder 'unread)
 324                                 (elmo-folder-close-internal target-folder))
 325                             (error (setq failure t)
 326                                    (incf fcount)))
 327                           (setq record-log t
 328                                 delete-substance
 329                                 (not (or failure
 330                                          (eq (nth 2 rule) 'continue))))
 331                           (incf count))
 332                          ((eq action 'delete)
 333                           (setq record-log t
 334                                 delete-substance t))
 335                          ((eq action 'noop)
 336                           ;; do nothing
 337                           )
 338                          ((functionp action)
 339                           (funcall action))
 340                          (t
 341                           (error "Wrong action specified in elmo-split-rule")))
 342                         (when delete-substance
 343                           (ignore-errors
 344                             (elmo-folder-delete-messages folder (list msg)))))
 345                       ;; 2. RECORD LOG
 346                       (when (or record-log
 347                                 reharsal)
 348                         (elmo-split-log
 349                          (concat "From "
 350                                  (nth 1 (std11-extract-address-components
 351                                          (or (std11-field-body "from") "")))
 352                                  "  " (or (std11-field-body "date") "") "\n"
 353                                  " Subject: "
 354                                  (eword-decode-string (or (std11-field-body
 355                                                            "subject") ""))
 356                                  "\n"
 357                                  (if reharsal
 358                                      (cond
 359                                       ((stringp action)
 360                                        (concat "  Test: " action "\n"))
 361                                       ((eq action 'delete)
 362                                        "  Test: /dev/null\n")
 363                                       ((eq action 'noop)
 364                                        "  Test: do nothing\n")
 365                                       ((function action)
 366                                        (format "  Test: function:%s\n"
 367                                                (symbol-name action)))
 368                                       (t
 369                                        "  ERROR: wrong action specified\n"))
 370                                    (cond
 371                                     (failure
 372                                      (concat "  FAILED: " action "\n"))
 373                                     ((stringp action)
 374                                      (concat "  Folder: " action "\n"))
 375                                     ((eq action 'delete)
 376                                      "  Deleted\n")
 377                                     (log-string
 378                                      log-string)
 379                                     (t
 380                                      (debug)))))
 381                          reharsal))
 382                       ;; 3. CONTINUATION CHECK
 383                       (unless (eq (nth 2 rule) 'continue)
 384                         (throw 'terminate nil))))))
 385               (elmo-progress-notify 'elmo-split)))
 386           (elmo-folder-close-internal folder))
 387       (elmo-progress-clear 'elmo-split))
 388     (cons count fcount)))
 389
 390 (require 'product)
 391 (product-provide (provide 'elmo-split) (require 'elmo-version))
 392
 393 ;;; elmo-split.el ends here