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 It can be some ACTION as in `elmo-split-rule'."
 122   :type '(choice (const :tag "do not touch" noop)
 123                  (const :tag "delete" delete)
 124                  (string :tag "folder name")
 125                  (function :tag "function"))
 126   :group 'elmo)
 127
 128 (defcustom elmo-split-log-coding-system 'x-ctext
 129   "A coding-system for writing log file."
 130   :type 'coding-system
 131   :group 'elmo)
 132
 133 (defcustom elmo-split-log-file "~/.elmo/split-log"
 134   "The file name of the split log."
 135   :type 'file
 136   :group 'elmo)
 137
 138 ;;;
 139 (defvar elmo-split-match-string-internal nil
 140   "Internal variable for string matching.  Don't touch this variable by hand.")
 141
 142 (defvar elmo-split-message-entity nil
 143   "Buffer local variable to store mime-entity.")
 144 (make-variable-buffer-local 'elmo-split-message-entity)
 145
 146 ;;;
 147 (defun elmo-split-or (buffer &rest args)
 148   (catch 'done
 149     (dolist (arg args)
 150       (if (elmo-split-eval buffer arg)
 151           (throw 'done t)))
 152     nil))
 153
 154 (defun elmo-split-and (buffer &rest args)
 155   (catch 'done
 156     (dolist (arg args)
 157       (unless (elmo-split-eval buffer arg)
 158         (throw 'done nil)))
 159     t))
 160
 161 (defun elmo-split-> (buffer size)
 162   (> (buffer-size buffer) size))
 163
 164 (defun elmo-split-< (buffer size)
 165   (< (buffer-size buffer) size))
 166
 167 (defun elmo-split-address-equal (buffer field value)
 168   (with-current-buffer buffer
 169     (let ((addrs (mapcar
 170                   'std11-address-string
 171                   (std11-parse-addresses-string
 172                    (std11-field-body (symbol-name field)))))
 173           (case-fold-search t)
 174           result)
 175       (while addrs
 176         (when (string-match (concat "^"
 177                                     (regexp-quote value)
 178                                     "$") (car addrs))
 179           (setq addrs nil
 180                 result t))
 181         (setq addrs (cdr addrs)))
 182       result)))
 183
 184 (defun elmo-split-address-match (buffer field value)
 185   (with-current-buffer buffer
 186     (let ((addrs (mapcar
 187                   'std11-address-string
 188                   (std11-parse-addresses-string
 189                    (std11-field-body (symbol-name field)))))
 190           result)
 191       (while addrs
 192         (when (string-match value (car addrs))
 193           (setq elmo-split-match-string-internal (car addrs)
 194                 addrs nil
 195                 result t))
 196         (setq addrs (cdr addrs)))
 197       result)))
 198
 199 (defun elmo-split-fetch-decoded-field (entity field-name)
 200   (let ((sym (intern (capitalize field-name)))
 201         (field-body (mime-entity-fetch-field entity field-name)))
 202     (when field-body
 203       (mime-decode-field-body field-body sym 'plain))))
 204
 205 (defun elmo-split-equal (buffer field value)
 206   (with-current-buffer buffer
 207     (let ((field-value (and
 208                         elmo-split-message-entity
 209                         (elmo-split-fetch-decoded-field
 210                          elmo-split-message-entity
 211                          (symbol-name field)))))
 212       (equal field-value value))))
 213
 214 (defun elmo-split-match (buffer field value)
 215   (with-current-buffer buffer
 216     (let ((field-value (and elmo-split-message-entity
 217                             (elmo-split-fetch-decoded-field
 218                              elmo-split-message-entity
 219                              (symbol-name field)))))
 220       (and field-value
 221            (when (string-match value field-value)
 222              (setq elmo-split-match-string-internal field-value))))))
 223
 224 (defun elmo-split-eval (buffer sexp)
 225   (cond
 226    ((consp sexp)
 227     (apply (intern (concat "elmo-split-" (symbol-name (car sexp))))
 228            buffer
 229            (cdr sexp)))
 230    ((stringp sexp)
 231     (std11-field-body sexp))
 232    (t (eval sexp))))
 233
 234 (defun elmo-split-log (message reharsal)
 235   (with-current-buffer (get-buffer-create "*elmo-split*")
 236     (goto-char (point-max))
 237     (let ((start (point))
 238           (coding-system-for-write elmo-split-log-coding-system))
 239       (insert message)
 240       (if reharsal
 241           (progn
 242             (pop-to-buffer (current-buffer))
 243             (sit-for 0))
 244         (write-region start (point) elmo-split-log-file t 'no-msg)))))
 245
 246 ;;;###autoload
 247 (defun elmo-split (&optional arg)
 248   "Split messages in the `elmo-split-folder' according to `elmo-split-rule'.
 249 If prefix argument ARG is specified, do a reharsal (no harm)."
 250   (interactive "P")
 251   (unless elmo-split-rule
 252     (error "Split rule does not exist.  Set `elmo-split-rule' first"))
 253   (let ((folders (if (listp elmo-split-folder)
 254                      elmo-split-folder
 255                    (list elmo-split-folder)))
 256         (count 0)
 257         (fcount 0)
 258         ret)
 259     (dolist (folder folders)
 260       (setq ret (elmo-split-subr (elmo-make-folder folder) arg)
 261             count (+ count (car ret))
 262             fcount (+ fcount (cdr ret))))
 263     (run-hooks 'elmo-split-hook)
 264     (message
 265      (concat
 266       (cond
 267        ((eq count 0)
 268         "No message is splitted")
 269        ((eq count 1)
 270         "1 message is splitted")
 271        (t
 272         (format "%d messages are splitted" count)))
 273       (if (eq fcount 0)
 274           "."
 275         (format " (%d failure)." fcount))))))
 276
 277 (defun elmo-split-subr (folder &optional reharsal)
 278   (let ((elmo-inhibit-display-retrieval-progress t)
 279         (count 0)
 280         (fcount 0)
 281         (default-rule `((t ,elmo-split-default-action)))
 282         msgs action target-folder failure delete-substance
 283         record-log log-string)
 284     (message "Splitting...")
 285     (elmo-folder-open-internal folder)
 286     (setq msgs (elmo-folder-list-messages folder))
 287     (elmo-progress-set 'elmo-split (length msgs) "Splitting...")
 288     (unwind-protect
 289         (progn
 290           (with-temp-buffer
 291             (dolist (msg msgs)
 292               (erase-buffer)
 293               (when (ignore-errors
 294                       (elmo-message-fetch folder msg
 295                                           (elmo-make-fetch-strategy 'entire)
 296                                           nil (current-buffer) 'unread))
 297                 (setq elmo-split-message-entity (mime-parse-buffer))
 298                 (catch 'terminate
 299                   (dolist (rule (append elmo-split-rule default-rule))
 300                     (setq elmo-split-match-string-internal nil)
 301                     (when (elmo-split-eval (current-buffer) (car rule))
 302                       (if (and (stringp (nth 1 rule))
 303                                elmo-split-match-string-internal)
 304                           (setq action (elmo-expand-newtext
 305                                         (nth 1 rule)
 306                                         elmo-split-match-string-internal))
 307                         (setq action (nth 1 rule)))
 308                       ;; 1. ACTION & DELETION
 309                       (unless reharsal
 310                         (setq failure nil
 311                               delete-substance nil
 312                               record-log nil
 313                               log-string nil)
 314                         (cond
 315                          ((stringp action)
 316                           (condition-case nil
 317                               (progn
 318                                 (setq target-folder (elmo-make-folder action))
 319                                 (unless (elmo-folder-exists-p target-folder)
 320                                   (when
 321                                       (and
 322                                        (elmo-folder-creatable-p target-folder)
 323                                        (y-or-n-p
 324                                         (format
 325                                          "Folder %s does not exist, Create it? "
 326                                          action)))
 327                                     (elmo-folder-create target-folder)))
 328                                 (elmo-folder-open-internal target-folder)
 329                                 (elmo-folder-append-buffer target-folder 'unread)
 330                                 (elmo-folder-close-internal target-folder))
 331                             (error (setq failure t)
 332                                    (incf fcount)))
 333                           (setq record-log t
 334                                 delete-substance
 335                                 (not (or failure
 336                                          (eq (nth 2 rule) 'continue))))
 337                           (incf count))
 338                          ((eq action 'delete)
 339                           (setq record-log t
 340                                 delete-substance t))
 341                          ((eq action 'noop)
 342                           ;; do nothing
 343                           )
 344                          ((functionp action)
 345                           (funcall action))
 346                          (t
 347                           (error "Wrong action specified in elmo-split-rule")))
 348                         (when delete-substance
 349                           (ignore-errors
 350                             (elmo-folder-delete-messages folder (list msg)))))
 351                       ;; 2. RECORD LOG
 352                       (when (or record-log
 353                                 reharsal)
 354                         (elmo-split-log
 355                          (concat "From "
 356                                  (nth 1 (std11-extract-address-components
 357                                          (or (std11-field-body "from") "")))
 358                                  "  " (or (std11-field-body "date") "") "\n"
 359                                  " Subject: "
 360                                  (eword-decode-string (or (std11-field-body
 361                                                            "subject") ""))
 362                                  "\n"
 363                                  (if reharsal
 364                                      (cond
 365                                       ((stringp action)
 366                                        (concat "  Test: " action "\n"))
 367                                       ((eq action 'delete)
 368                                        "  Test: /dev/null\n")
 369                                       ((eq action 'noop)
 370                                        "  Test: do nothing\n")
 371                                       ((function action)
 372                                        (format "  Test: function:%s\n"
 373                                                (symbol-name action)))
 374                                       (t
 375                                        "  ERROR: wrong action specified\n"))
 376                                    (cond
 377                                     (failure
 378                                      (concat "  FAILED: " action "\n"))
 379                                     ((stringp action)
 380                                      (concat "  Folder: " action "\n"))
 381                                     ((eq action 'delete)
 382                                      "  Deleted\n")
 383                                     (log-string
 384                                      log-string)
 385                                     (t
 386                                      (debug)))))
 387                          reharsal))
 388                       ;; 3. CONTINUATION CHECK
 389                       (unless (eq (nth 2 rule) 'continue)
 390                         (throw 'terminate nil))))))
 391               (elmo-progress-notify 'elmo-split)))
 392           (elmo-folder-close-internal folder))
 393       (elmo-progress-clear 'elmo-split))
 394     (cons count fcount)))
 395
 396 (require 'product)
 397 (product-provide (provide 'elmo-split) (require 'elmo-version))
 398
 399 ;;; elmo-split.el ends here