X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-split.el;h=0de97b02f85d58e9d1903bfab3eb2e2d9bd53c3c;hb=88d92346ec94d9f4c094659671c0c591c00d3bbd;hp=a9765a4e44790173cb4674aab10dbe38f91aff0a;hpb=6ad8542ce0dddd4b9f3201e11df26e4640dce6a1;p=elisp%2Fwanderlust.git

diff --git a/elmo/elmo-split.el b/elmo/elmo-split.el
index a9765a4..0de97b0 100644
--- a/elmo/elmo-split.el
+++ b/elmo/elmo-split.el
@@ -29,25 +29,30 @@
 ;;
 ;; (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.
@@ -62,16 +67,35 @@ FIELD-NAME is a symbol of the field name.
                         VALUE can contain \\& and \\N which will substitute
                         from matching \\(\\) patterns in the previous VALUE.
 
-2. Functions which accept any number of arguments.
+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.
@@ -105,6 +129,15 @@ Example:
 		 (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
@@ -119,6 +152,10 @@ Example:
 (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
@@ -134,6 +171,12 @@ Example:
 	(throw 'done nil)))
     t))
 
+(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 value)
   (with-current-buffer buffer
     (let ((addrs (mapcar
@@ -166,14 +209,33 @@ Example:
 	(setq addrs (cdr addrs)))
       result)))
 
+(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 value)
   (with-current-buffer buffer
-    (let ((field-value (std11-field-body (symbol-name field))))
+    (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 &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)
   (with-current-buffer buffer
-    (let ((field-value (std11-field-body (symbol-name field))))
+    (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))))))
@@ -206,18 +268,39 @@ Example:
 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))))
+		   (list elmo-split-folder)))
+	(count 0)
+	(fcount 0)
+	ret)
     (dolist (folder folders)
-      (elmo-split-subr (elmo-make-folder folder) arg))))
+      (setq ret (elmo-split-subr (elmo-make-folder folder) arg)
+	    count (+ count (car ret))
+	    fcount (+ fcount (cdr ret))))
+    (run-hooks 'elmo-split-hook)
+    (message
+     (concat
+      (cond
+       ((eq count 0)
+	"No message is splitted")
+       ((eq count 1)
+	"1 message is splitted")
+       (t
+	(format "%d messages are splitted" count)))
+      (if (eq fcount 0)
+	  "."
+	(format " (%d failure)." fcount))))
+    count))
 
 (defun elmo-split-subr (folder &optional reharsal)
   (let ((elmo-inhibit-display-retrieval-progress t)
 	(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))
@@ -231,72 +314,114 @@ 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
+			     folder
+			     msg
+			     (elmo-msgdb-get-message-id-from-buffer)))
 		(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-make-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))
-    (run-hooks 'elmo-split-hook)
-    (message
-     (concat
-      (cond
-       ((eq count 0)
-	"No message is splitted")
-       ((eq count 1)
-	"1 message is splitted")
-       (t
-	(format "%d messages are splitted" count)))
-      (if (eq fcount 0)
-	  "."
-	(format " (%d failure)." fcount))))))
+    (cons count fcount)))
 
-(provide 'elmo-split)
+(require 'product)
+(product-provide (provide 'elmo-split) (require 'elmo-version))
 
 ;;; elmo-split.el ends here