;;
;; (autoload 'elmo-split "elmo-split" "Split messages on the folder." t)
;;
-;; A command elmo-split is provided. If you enter:
+;; A command elmo-split is provided. If you enter:
;;
;; M-x elmo-split
;;
;; Messages in the `elmo-split-folder' are splitted to the folders
;; according to the definition of `elmo-split-rule'.
-;;
+;;
+;;; Code:
+(eval-when-compile (require 'cl))
(require 'elmo)
-;;; Code:
+(eval-when-compile
+ ;; Avoid compile warnings
+ (require 'elmo-spam))
+
(defcustom elmo-split-rule nil
"Split rule for the command `elmo-split'.
The format of this variable is a list of RULEs which has form like:
-\(CONDITION FOLDER [continue]\)
+\(CONDITION ACTION [continue]\)
The 1st element CONDITION is a sexp which consists of following.
-1. Functions which accept argument FIELD-NAME and VALUE.
+1. Functions which accept arguments FIELD-NAME and VALUE.
FIELD-NAME is a symbol of the field name.
`equal' ... True if the field value equals to VALUE.
VALUE can contain \\& and \\N which will substitute
from matching \\(\\) patterns in the previous VALUE.
-2. Functions which accept any number of arguments.
+FIELD-NAME can be a list of field names, return true if any of the fields
+satisfy the condition.
+
+2. Functions which accept an argument SIZE, SIZE is some number.
+
+`<' ... True if the size of the message is less than SIZE.
+`>' ... True if the size of the message is greater than SIZE.
+
+3. Functions which accept any number of arguments.
`or' ... True if one of the argument returns true.
`and' ... True if all of the arguments return true.
-3. A symbol.
+`spam-p' ... True if contents of the message is guessed as spam.
+ Rest arguments are property list which consists
+ following.
+
+ `:register' ... If this value is non-nil,
+ Register according to
+ the classification.
+
+5. A symbol.
When a symbol is specified, it is evaluated.
-The 2nd element FOLDER is the name of the folder to split messages into.
+The 2nd element ACTION is the name of the destination folder or some symbol.
+If CONDITION is satisfied, the message is splitted according to this value.
+
+If ACTION is a string, it will be considered as the name of destination folder.
+Symbol `delete' means that the substance of the message will be removed. On the
+other hand, symbol `noop' is used to do nothing and keep the substance of the
+message as it is. Or, if some function is specified, it will be called.
When the 3rd element `continue' is specified as symbol, evaluating rules is
not stopped even when the condition is satisfied.
(repeat (string :tag "folder name")))
:group 'elmo)
+(defcustom elmo-split-default-action 'noop
+ "Default action for messages which pass all rules.
+It can be some ACTION as in `elmo-split-rule'."
+ :type '(choice (const :tag "do not touch" noop)
+ (const :tag "delete" delete)
+ (string :tag "folder name")
+ (function :tag "function"))
+ :group 'elmo)
+
(defcustom elmo-split-log-coding-system 'x-ctext
"A coding-system for writing log file."
:type 'coding-system
(defvar elmo-split-match-string-internal nil
"Internal variable for string matching. Don't touch this variable by hand.")
+(defvar elmo-split-message-entity nil
+ "Buffer local variable to store mime-entity.")
+(make-variable-buffer-local 'elmo-split-message-entity)
+
;;;
(defun elmo-split-or (buffer &rest args)
(catch 'done
(throw 'done nil)))
t))
-(defun elmo-split-address-equal (buffer field value)
+(defun elmo-split-> (buffer size)
+ (> (buffer-size buffer) size))
+
+(defun elmo-split-< (buffer size)
+ (< (buffer-size buffer) size))
+
+(defun elmo-split-address-equal (buffer field-or-fields value)
(with-current-buffer buffer
- (let ((addrs (mapcar
- 'std11-address-string
- (std11-parse-addresses-string
- (std11-field-body (symbol-name field)))))
- (case-fold-search t)
- result)
- (while addrs
- (when (string-match (concat "^"
- (regexp-quote value)
- "$") (car addrs))
- (setq addrs nil
- result t))
- (setq addrs (cdr addrs)))
+ (let (result)
+ (dolist (field (if (listp field-or-fields)
+ field-or-fields
+ (list field-or-fields)))
+ (let ((addrs (mapcar
+ 'std11-address-string
+ (std11-parse-addresses-string
+ (std11-field-body (symbol-name field)))))
+ (case-fold-search t))
+ (while addrs
+ (when (string-match (concat "^"
+ (regexp-quote value)
+ "$") (car addrs))
+ (setq addrs nil
+ result t))
+ (setq addrs (cdr addrs)))))
result)))
-(defun elmo-split-address-match (buffer field value)
+(defun elmo-split-address-match (buffer field-or-fields value)
(with-current-buffer buffer
- (let ((addrs (mapcar
- 'std11-address-string
- (std11-parse-addresses-string
- (std11-field-body (symbol-name field)))))
- result)
- (while addrs
- (when (string-match value (car addrs))
- (setq elmo-split-match-string-internal (car addrs)
- addrs nil
- result t))
- (setq addrs (cdr addrs)))
+ (let (result)
+ (dolist (field (if (listp field-or-fields)
+ field-or-fields
+ (list field-or-fields)))
+ (let ((addrs (mapcar
+ 'std11-address-string
+ (std11-parse-addresses-string
+ (std11-field-body (symbol-name field))))))
+ (while addrs
+ (when (string-match value (car addrs))
+ (setq elmo-split-match-string-internal (car addrs)
+ addrs nil
+ result t))
+ (setq addrs (cdr addrs)))))
result)))
-(defun elmo-split-equal (buffer field value)
+(defun elmo-split-fetch-decoded-field (entity field-name)
+ (let ((sym (intern (capitalize field-name)))
+ (field-body (mime-entity-fetch-field entity field-name)))
+ (when field-body
+ (mime-decode-field-body field-body sym 'plain))))
+
+(defun elmo-split-equal (buffer field-or-fields value)
(with-current-buffer buffer
- (let ((field-value (std11-field-body (symbol-name field))))
- (equal field-value value))))
+ (let (result)
+ (dolist (field (if (listp field-or-fields)
+ field-or-fields
+ (list field-or-fields)))
+ (let ((field-value (and
+ elmo-split-message-entity
+ (elmo-split-fetch-decoded-field
+ elmo-split-message-entity
+ (symbol-name field)))))
+ (setq result (or result
+ (equal field-value value)))))
+ result)))
+
+(defun elmo-split-spam-p (buffer &rest plist)
+ (require 'elmo-spam)
+ (elmo-spam-buffer-spam-p (elmo-spam-processor)
+ buffer
+ (plist-get plist :register)))
-(defun elmo-split-match (buffer field value)
+(defun elmo-split-match (buffer field-or-fields value)
(with-current-buffer buffer
- (let ((field-value (std11-field-body (symbol-name field))))
- (and field-value
- (when (string-match value field-value)
- (setq elmo-split-match-string-internal field-value))))))
+ (let (result)
+ (dolist (field (if (listp field-or-fields)
+ field-or-fields
+ (list field-or-fields)))
+ (let ((field-value (and elmo-split-message-entity
+ (elmo-split-fetch-decoded-field
+ elmo-split-message-entity
+ (symbol-name field)))))
+ (and field-value
+ (when (string-match value field-value)
+ (setq result t)
+ (setq elmo-split-match-string-internal field-value)))))
+ result)))
(defun elmo-split-eval (buffer sexp)
(cond
If prefix argument ARG is specified, do a reharsal (no harm)."
(interactive "P")
(unless elmo-split-rule
- (error "Split rule doest not exist. Set `elmo-split-rule' first."))
+ (error "Split rule does not exist. Set `elmo-split-rule' first"))
(let ((folders (if (listp elmo-split-folder)
elmo-split-folder
(list elmo-split-folder)))
(fcount 0)
ret)
(dolist (folder folders)
- (setq ret (elmo-split-subr (elmo-make-folder folder) arg)
+ (setq ret (elmo-split-subr (elmo-get-folder folder) arg)
count (+ count (car ret))
fcount (+ fcount (cdr ret))))
(run-hooks 'elmo-split-hook)
(format "%d messages are splitted" count)))
(if (eq fcount 0)
"."
- (format " (%d failure)." fcount))))))
+ (format " (%d failure)." fcount))))
+ count))
(defun elmo-split-subr (folder &optional reharsal)
- (let ((elmo-inhibit-display-retrieval-progress t)
- (count 0)
+ (let ((count 0)
(fcount 0)
- msgs fname target-folder failure)
+ (default-rule `((t ,elmo-split-default-action)))
+ msgs action target-folder failure delete-substance
+ record-log log-string flags)
(message "Splitting...")
(elmo-folder-open-internal folder)
(setq msgs (elmo-folder-list-messages folder))
- (elmo-progress-set 'elmo-split (length msgs) "Splitting...")
- (unwind-protect
- (progn
+ (elmo-with-progress-display (elmo-split (length msgs)) "Splitting messages"
+ (unwind-protect
(with-temp-buffer
+ (set-buffer-multibyte nil)
(dolist (msg msgs)
(erase-buffer)
(when (ignore-errors
(elmo-message-fetch folder msg
(elmo-make-fetch-strategy 'entire)
- nil (current-buffer) 'unread))
+ 'unread))
+ (run-hooks 'elmo-split-fetch-hook)
+ (setq elmo-split-message-entity (mime-parse-buffer))
+ (setq flags (elmo-message-flags-for-append folder msg))
(catch 'terminate
- (dolist (rule elmo-split-rule)
+ (dolist (rule (append elmo-split-rule default-rule))
(setq elmo-split-match-string-internal nil)
(when (elmo-split-eval (current-buffer) (car rule))
- (if elmo-split-match-string-internal
- (setq fname (elmo-expand-newtext
- (nth 1 rule)
- elmo-split-match-string-internal))
- (setq fname (nth 1 rule)))
+ (if (and (stringp (nth 1 rule))
+ elmo-split-match-string-internal)
+ (setq action (elmo-expand-newtext
+ (nth 1 rule)
+ elmo-split-match-string-internal))
+ (setq action (nth 1 rule)))
+ ;; 1. ACTION & DELETION
(unless reharsal
- (setq failure nil)
- (condition-case nil
- (progn
- (setq target-folder (elmo-make-folder fname))
- (unless (elmo-folder-exists-p target-folder)
- (when
- (and
- (elmo-folder-creatable-p
- target-folder)
- (y-or-n-p
- (format
- "Folder %s does not exist, Create it? "
- fname)))
- (elmo-folder-create target-folder)))
- (elmo-folder-open-internal target-folder)
- (elmo-folder-append-buffer target-folder 'unread)
- (elmo-folder-close-internal target-folder))
- (error (setq failure t)
- (incf fcount)))
- (unless failure
+ (setq failure nil
+ delete-substance nil
+ record-log nil
+ log-string nil)
+ (cond
+ ((stringp action)
+ (condition-case nil
+ (progn
+ (setq target-folder (elmo-get-folder action))
+ (unless (elmo-folder-exists-p target-folder)
+ (when
+ (and
+ (elmo-folder-creatable-p target-folder)
+ (y-or-n-p
+ (format
+ "Folder %s does not exist, Create it? "
+ action)))
+ (elmo-folder-create target-folder)))
+ (elmo-folder-open-internal target-folder)
+ (setq failure (not
+ (elmo-folder-append-buffer
+ target-folder
+ flags)))
+ (elmo-folder-close-internal target-folder))
+ (error (setq failure t)
+ (incf fcount)))
+ (setq record-log t
+ delete-substance
+ (not (or failure
+ (eq (nth 2 rule) 'continue))))
+ (incf count))
+ ((eq action 'delete)
+ (setq record-log t
+ delete-substance t))
+ ((eq action 'noop)
+ ;; do nothing
+ )
+ ((functionp action)
+ (funcall action))
+ (t
+ (error "Wrong action specified in elmo-split-rule")))
+ (when delete-substance
(ignore-errors
- (elmo-folder-delete-messages folder (list msg))))
- (incf count))
- (elmo-split-log
- (concat "From "
- (nth 1 (std11-extract-address-components
- (or (std11-field-body "from") "")))
- " " (or (std11-field-body "date") "") "\n"
- " Subject: "
- (eword-decode-string (or (std11-field-body
- "subject") ""))
- "\n"
- (if reharsal
- " Test: "
- " Folder: ")
- fname "/0" "\n")
- reharsal)
+ (elmo-folder-delete-messages folder (list msg)))))
+ ;; 2. RECORD LOG
+ (when (or record-log
+ reharsal)
+ (elmo-split-log
+ (concat "From "
+ (nth 1 (std11-extract-address-components
+ (or (std11-field-body "from") "")))
+ " " (or (std11-field-body "date") "") "\n"
+ " Subject: "
+ (eword-decode-string (or (std11-field-body
+ "subject") ""))
+ "\n"
+ (if reharsal
+ (cond
+ ((stringp action)
+ (concat " Test: " action "\n"))
+ ((eq action 'delete)
+ " Test: /dev/null\n")
+ ((eq action 'noop)
+ " Test: do nothing\n")
+ ((function action)
+ (format " Test: function:%s\n"
+ (prin1-to-string action)))
+ (t
+ " ERROR: wrong action specified\n"))
+ (cond
+ (failure
+ (concat " FAILED: " action "\n"))
+ ((stringp action)
+ (concat " Folder: " action "\n"))
+ ((eq action 'delete)
+ " Deleted\n")
+ (log-string
+ log-string)
+ (t
+ (debug)))))
+ reharsal))
+ ;; 3. CONTINUATION CHECK
(unless (eq (nth 2 rule) 'continue)
(throw 'terminate nil))))))
(elmo-progress-notify 'elmo-split)))
- (elmo-folder-close-internal folder))
- (elmo-progress-clear 'elmo-split))
+ (elmo-folder-close-internal folder)))
(cons count fcount)))
-(provide 'elmo-split)
+(require 'product)
+(product-provide (provide 'elmo-split) (require 'elmo-version))
;;; elmo-split.el ends here
projects / elisp / wanderlust.git / blobdiff