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