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