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