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