;;
;;; Code:
+(eval-when-compile (require 'cl))
(require 'elmo)
(eval-when-compile
;; Avoid compile warnings
- (defun-maybe elmo-spam-processor)
- (defun-maybe elmo-spam-buffer-spam-p (processor buffer)))
+ (require 'elmo-spam))
(defcustom elmo-split-rule nil
"Split rule for the command `elmo-split'.
VALUE can contain \\& and \\N which will substitute
from matching \\(\\) patterns in the previous VALUE.
+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.
`or' ... True if one of the argument returns true.
`and' ... True if all of the arguments return true.
-4. Functions which accept not argument.
-
`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.
(defun elmo-split-< (buffer size)
(< (buffer-size buffer) size))
-(defun elmo-split-address-equal (buffer field value)
+(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-fetch-decoded-field (entity field-name)
(when field-body
(mime-decode-field-body field-body sym 'plain))))
-(defun elmo-split-equal (buffer field value)
+(defun elmo-split-equal (buffer field-or-fields value)
(with-current-buffer buffer
- (let ((field-value (and
- elmo-split-message-entity
- (elmo-split-fetch-decoded-field
- elmo-split-message-entity
- (symbol-name field)))))
- (equal field-value value))))
-
-(defun elmo-split-spam-p (buffer)
- (require 'elmo-spam)
- (elmo-spam-buffer-spam-p (elmo-spam-processor) buffer))
-
-(defun elmo-split-match (buffer field value)
- (with-current-buffer buffer
- (let ((field-value (and elmo-split-message-entity
+ (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 elmo-split-match-string-internal field-value))))))
+ (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-or-fields value)
+ (with-current-buffer buffer
+ (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
(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)
(default-rule `((t ,elmo-split-default-action)))
msgs action target-folder failure delete-substance
- record-log log-string)
+ 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 (append elmo-split-rule default-rule))
(setq elmo-split-match-string-internal nil)
((stringp action)
(condition-case nil
(progn
- (setq target-folder (elmo-make-folder action))
+ (setq target-folder (elmo-get-folder action))
(unless (elmo-folder-exists-p target-folder)
(when
(and
action)))
(elmo-folder-create target-folder)))
(elmo-folder-open-internal target-folder)
- (elmo-folder-append-buffer target-folder)
+ (setq failure (not
+ (elmo-folder-append-buffer
+ target-folder
+ flags)))
(elmo-folder-close-internal target-folder))
(error (setq failure t)
(incf fcount)))
(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)))
(require 'product)
projects / elisp / wanderlust.git / blobdiff