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