X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=elmo%2Felmo-split.el;h=3eafd557a3f3d11b0e54a148658f279ea26898f2;hb=57f081e684a5f0a1de02c96bc61ec175784974bb;hp=03a975e06abcdb7a58e370f0db736dd772c9bcd6;hpb=1d429b4cd9bf69afa6001cc8c985ff2b176b7faa;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-split.el b/elmo/elmo-split.el index 03a975e..3eafd55 100644 --- a/elmo/elmo-split.el +++ b/elmo/elmo-split.el @@ -37,9 +37,14 @@ ;; 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: @@ -62,6 +67,9 @@ FIELD-NAME is a symbol of the field name. 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. @@ -72,7 +80,15 @@ FIELD-NAME is a symbol of the field name. `or' ... True if one of the argument returns true. `and' ... True if all of the arguments return true. -4. 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. @@ -164,36 +180,42 @@ It can be some ACTION as in `elmo-split-rule'." (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) @@ -202,24 +224,42 @@ It can be some ACTION as in `elmo-split-rule'." (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-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 @@ -272,7 +312,8 @@ If prefix argument ARG is specified, do a reharsal (no harm)." (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) @@ -280,7 +321,7 @@ If prefix argument ARG is specified, do a reharsal (no harm)." (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)) @@ -294,7 +335,9 @@ If prefix argument ARG is specified, do a reharsal (no harm)." (elmo-message-fetch folder msg (elmo-make-fetch-strategy 'entire) nil (current-buffer) '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) @@ -326,7 +369,10 @@ If prefix argument ARG is specified, do a reharsal (no harm)." action))) (elmo-folder-create target-folder))) (elmo-folder-open-internal target-folder) - (elmo-folder-append-buffer target-folder 'unread) + (setq failure (not + (elmo-folder-append-buffer + target-folder + flags))) (elmo-folder-close-internal target-folder)) (error (setq failure t) (incf fcount))) @@ -370,7 +416,7 @@ If prefix argument ARG is specified, do a reharsal (no harm)." " Test: do nothing\n") ((function action) (format " Test: function:%s\n" - (symbol-name action))) + (prin1-to-string action))) (t " ERROR: wrong action specified\n")) (cond