X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=7d80120e58dfa695e430eb6153d555548cc06d33;hb=809bf94069b502dea6253604c1987656bf64de19;hp=630b5558aa27a3d70d39fe5b6653cce56bf883fa;hpb=0b5861a4ba4284582290efbc3f09fb49dd9f754f;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index 630b555..7d80120 100644
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -33,17 +33,21 @@
 (require 'gnus-sum)
 (require 'nnmail)
 
+(defgroup gnus-registry nil
+  "The Gnus registry."
+  :group 'gnus)
+
 (defvar gnus-registry-hashtb nil
   "*The article registry by Message ID.")
-(setq gnus-registry-hashtb (make-hash-table 
-			    :size 4096
-			    :test 'equal)) ; we test message ID strings equality
 
-;; sample data-header
-;; (defvar tzz-header '(49 "Re[2]: good news" "\"Jonathan Pryor\" <offerlm@aol.com>" "Mon, 17 Feb 2003 10:41:46 +-0800" "<88288020@dytqq>" "" 896 18 "lockgroove.bwh.harvard.edu spam.asian:49" nil))
+(defvar gnus-registry-headers-hashtb nil
+  "*The article header registry by Message ID.  Unused for now.")
 
-;; (maphash (lambda (key value) (message "key: %s value: %s" key value)) gnus-registry-hashtb)
-;; (clrhash gnus-registry-hashtb)
+(defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
+  "List of groups that gnus-registry-split-fancy-with-parent won't follow.
+The group names are matched, they don't have to be fully qualified."
+  :group 'gnus-registry
+  :type '(repeat string))
 
 ;; Function(s) missing in Emacs 20
 (when (memq nil (mapcar 'fboundp '(puthash)))
@@ -75,32 +79,149 @@
     (maphash
      (lambda (key value)
        (setq list (cons (cons key value) list)))
-     hash)))
+     hash)
+    list))
 
 (defun gnus-register-action (action data-header from &optional to method)
   (let* ((id (mail-header-id data-header))
-	(hash-entry (gethash id gnus-registry-hashtb)))
+	(from (gnus-group-guess-full-name from))
+	(to (if to (gnus-group-guess-full-name to) nil))
+	(to-name (if to to "the Bit Bucket"))
+	(old-entry (gethash id gnus-registry-hashtb)))
     (gnus-message 5 "Registry: article %s %s from %s to %s"
-	     id
-	     (if method "respooling" "going")
-	     (gnus-group-guess-full-name from)
-	     (if to (gnus-group-guess-full-name to) "the Bit Bucket"))
-    (unless hash-entry 
-      (setq hash-entry (puthash id (list data-header) gnus-registry-hashtb)))
-    (puthash id (cons (list action from to method) 
-		      (gethash id gnus-registry-hashtb)) gnus-registry-hashtb)))
+		  id
+		  (if method "respooling" "going")
+		  from
+		  to)
+
+    ;; All except copy will need a delete
+    (gnus-registry-delete-group id from)
+
+    (when (equal 'copy action) 
+      (gnus-registry-add-group id from)) ; undo the delete
+
+    (gnus-registry-add-group id to)))
 
 (defun gnus-register-spool-action (id group)
+  ;; do not process the draft IDs
+;  (unless (string-match "totally-fudged-out-message-id" id)
+;    (let ((group (gnus-group-guess-full-name group)))
+  (when (string-match "\r$" id)
+    (setq id (substring id 0 -1)))
   (gnus-message 5 "Registry: article %s spooled to %s"
-	   id
-	   (gnus-group-prefixed-name 
-	    group 
-	    gnus-internal-registry-spool-current-method 
-	    t))
-  (puthash id (cons (list 'spool nil group nil) 
-		    (gethash id gnus-registry-hashtb)) gnus-registry-hashtb))
-
-(add-hook 'gnus-summary-article-move-hook 'gnus-register-action) ; also does copy, respool, and crosspost
+		id
+		group)
+  (gnus-registry-add-group id group))
+;)
+
+;; Function for nn{mail|imap}-split-fancy: look up all references in
+;; the cache and if a match is found, return that group.
+(defun gnus-registry-split-fancy-with-parent ()
+  "Split this message into the same group as its parent.  The parent
+is obtained from the registry.  This function can be used as an entry
+in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
+this: (: gnus-registry-split-fancy-with-parent) 
+
+For a message to be split, it looks for the parent message in the
+References or In-Reply-To header and then looks in the registry to
+see which group that message was put in.  This group is returned.
+
+See the Info node `(gnus)Fancy Mail Splitting' for more details."
+  (let ((refstr (or (message-fetch-field "references")
+		    (message-fetch-field "in-reply-to")))
+	(references nil)
+	(res nil))
+    (when refstr
+      (setq references (nreverse (gnus-split-references refstr)))
+      (mapcar (lambda (x)
+		(setq res (or (gnus-registry-fetch-group x) res))
+		(when (or (gnus-registry-grep-in-list 
+			   res
+			   gnus-registry-unfollowed-groups)
+			  (gnus-registry-grep-in-list 
+			   res 
+			   nnmail-split-fancy-with-parent-ignore-groups))
+		  (setq res nil)))
+	      references)
+      (gnus-message 
+       5 
+       "gnus-registry-split-fancy-with-parent traced %s to group %s"
+       refstr (if res res "nil"))
+      res)))
+
+(defun gnus-registry-register-message-ids ()
+  "Register the Message-ID of every article in the group"
+  (dolist (article gnus-newsgroup-articles)
+    (let ((id (gnus-registry-fetch-message-id-fast article)))
+      (unless (gnus-registry-fetch-group id)
+	(gnus-message 9 "Registry: Registering article %d with group %s" 
+		      article gnus-newsgroup-name)
+	(gnus-registry-add-group (gnus-registry-fetch-message-id-fast article)
+				 gnus-newsgroup-name)))))
+
+(defun gnus-registry-fetch-message-id-fast (article)
+  "Fetch the Message-ID quickly, using the internal gnus-data-list function"
+  (if (and (numberp article)
+	   (assoc article (gnus-data-list nil)))
+      (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
+    nil))
+
+(defun gnus-registry-grep-in-list (word list)
+  (when word
+    (memq nil
+	  (mapcar 'not
+		  (mapcar 
+		   (lambda (x)
+		     (string-match x word))
+		   list)))))
+
+(defun gnus-registry-fetch-group (id)
+  "Get the group of a message, based on the message ID.
+Returns the first place where the trail finds a spool action."
+  (when id
+    (let ((trail (gethash id gnus-registry-hashtb)))
+      (if trail
+	  (car trail)
+	nil))))
+
+(defun gnus-registry-delete-group (id group)
+  "Get the group of a message, based on the message ID.
+Returns the first place where the trail finds a spool action."
+  (when group
+    (when id
+      (let ((trail (gethash id gnus-registry-hashtb))
+	    (group (gnus-group-short-name group)))
+	(puthash id (if trail
+			(delete group trail)
+		      nil)
+		 gnus-registry-hashtb))
+      ;; now, clear the entry if it's empty
+      (unless (gethash id gnus-registry-hashtb)
+	(remhash id gnus-registry-hashtb)))))
+
+(defun gnus-registry-add-group (id group)
+  "Get the group of a message, based on the message ID.
+Returns the first place where the trail finds a spool action."
+  ;; make sure there are no duplicate entries
+  (when group
+    (when id
+      (let ((group (gnus-group-short-name group)))
+	(gnus-registry-delete-group id group)	
+	(let ((trail (gethash id gnus-registry-hashtb)))
+	  (puthash id (if trail
+			  (cons group trail)
+			(list group))
+		   gnus-registry-hashtb))))))
+
+(defun gnus-registry-clear ()
+  "Clear the Gnus registry."
+  (interactive)
+  (setq gnus-registry-alist nil 
+	gnus-registry-headers-alist nil)
+  (gnus-registry-translate-from-alist))
+
+; also does copy, respool, and crosspost
+(add-hook 'gnus-summary-article-move-hook 'gnus-register-action) 
 (add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
 (add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
 (add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
@@ -108,6 +229,8 @@
 (add-hook 'gnus-save-newsrc-hook 'gnus-registry-translate-to-alist)
 (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-translate-from-alist)
 
+(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
+
 ;; TODO: a lot of things
 
 (provide 'gnus-registry)