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