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