X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=f0d955d790ccf1a47b0c29655881c882f6d5689a;hb=7a9f34c33d683889f228897bc047eebd9ddb6c95;hp=324155dd1f93be8a0b1d09715206bc0e56695cea;hpb=e6b31519e256eaa52280b45df80d5b436c1539b1;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index 324155d..f0d955d 100644
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -24,6 +24,34 @@
 
 ;;; Commentary:
 
+;; This is the gnus-registry.el package, which works with all
+;; backends, not just nnmail (e.g. NNTP).  The major issue is that it
+;; doesn't go across backends, so for instance if an article is in
+;; nnml:sys and you see a reference to it in nnimap splitting, the
+;; article will end up in nnimap:sys
+
+;; gnus-registry.el intercepts article respooling, moving, deleting,
+;; and copying for all backends.  If it doesn't work correctly for
+;; you, submit a bug report and I'll be glad to fix it.  It needs
+;; documentation in the manual (also on my to-do list).
+
+;; Put this in your startup file (~/.gnus.el for instance)
+
+;; (setq gnus-registry-max-entries 2500
+;;       gnus-registry-use-long-group-names t)
+
+;; (gnus-registry-initialize)
+
+;; Then use this in your fancy-split:
+
+;; (: gnus-registry-split-fancy-with-parent)
+
+;; TODO:
+
+;; - get the correct group on spool actions
+
+;; - articles that are spooled to a different backend should be handled
+
 ;;; Code:
 
 (eval-when-compile (require 'cl))
@@ -33,6 +61,9 @@
 (require 'gnus-sum)
 (require 'nnmail)
 
+(defvar gnus-registry-dirty t
+ "Boolean set to t when the registry is modified")
+
 (defgroup gnus-registry nil
   "The Gnus registry."
   :group 'gnus)
@@ -40,32 +71,223 @@
 (defvar gnus-registry-hashtb nil
   "*The article registry by Message ID.")
 
-(defvar gnus-registry-headers-hashtb nil
-  "*The article header registry by Message ID.  Unused for now.")
-
 (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))
 
-(defcustom gnus-registry-unregistered-group-regex "^nntp"
-  "Group name regex that gnus-registry-register-message-ids won't process."
+(defcustom gnus-registry-install nil
+  "Whether the registry should be installed."
   :group 'gnus-registry
-  :type 'regexp)
+  :type 'boolean)
 
-;; Function(s) missing in Emacs 20
-(when (memq nil (mapcar 'fboundp '(puthash)))
-  (require 'cl)
-  (unless (fboundp 'puthash)
-    ;; alias puthash is missing from Emacs 20 cl-extra.el
-    (defalias 'puthash 'cl-puthash)))
+(defcustom gnus-registry-clean-empty t
+  "Whether the empty registry entries should be deleted.
+Registry entries are considered empty when they have no groups
+and no extra data."
+  :group 'gnus-registry
+  :type 'boolean)
 
-(defun gnus-registry-translate-to-alist ()
-  (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb)))
+(defcustom gnus-registry-use-long-group-names nil
+  "Whether the registry should use long group names (BUGGY)."
+  :group 'gnus-registry
+  :type 'boolean)
 
-(defun gnus-registry-translate-from-alist ()
-  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
+(defcustom gnus-registry-track-extra nil
+  "Whether the registry should track extra data about a message.
+The Subject and Sender (From:) headers are currently tracked this
+way."
+  :group 'gnus-registry
+  :type      
+  '(set :tag "Tracking choices"
+    (const :tag "Track by subject (Subject: header)" subject)
+    (const :tag "Track by sender (From: header)"  sender)))
+
+(defcustom gnus-registry-entry-caching t
+  "Whether the registry should cache extra information."
+  :group 'gnus-registry
+  :type 'boolean)
+
+(defcustom gnus-registry-minimum-subject-length 5
+  "The minimum length of a subject before it's considered trackable."
+  :group 'gnus-registry
+  :type 'integer)
+
+(defcustom gnus-registry-trim-articles-without-groups t
+  "Whether the registry should clean out message IDs without groups."
+  :group 'gnus-registry
+  :type 'boolean)
+
+(defcustom gnus-registry-cache-file 
+  (nnheader-concat 
+   (or gnus-dribble-directory gnus-home-directory "~/") 
+   ".gnus.registry.eld")
+  "File where the Gnus registry will be stored."
+  :group 'gnus-registry
+  :type 'file)
+
+(defcustom gnus-registry-max-entries nil
+  "Maximum number of entries in the registry, nil for unlimited."
+  :group 'gnus-registry
+  :type '(radio (const :format "Unlimited " nil)
+		(integer :format "Maximum number: %v\n" :size 0)))
+
+(defun gnus-registry-track-subject-p ()
+  (memq 'subject gnus-registry-track-extra))
+
+(defun gnus-registry-track-sender-p ()
+  (memq 'sender gnus-registry-track-extra))
+
+(defun gnus-registry-cache-read ()
+  "Read the registry cache file."
+  (interactive)
+  (let ((file gnus-registry-cache-file))
+    (when (file-exists-p file)
+      (gnus-message 5 "Reading %s..." file)
+      (gnus-load file)
+      (gnus-message 5 "Reading %s...done" file))))
+
+(defun gnus-registry-cache-save ()
+  "Save the registry cache file."
+  (interactive)
+  (let ((file gnus-registry-cache-file))
+    (save-excursion
+      (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
+      (make-local-variable 'version-control)
+    (setq version-control gnus-backup-startup-file)
+    (setq buffer-file-name file)
+    (setq default-directory (file-name-directory buffer-file-name))
+    (buffer-disable-undo)
+    (erase-buffer)
+    (gnus-message 5 "Saving %s..." file)
+    (if gnus-save-startup-file-via-temp-buffer
+	(let ((coding-system-for-write gnus-ding-file-coding-system)
+	      (standard-output (current-buffer)))
+	  (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)
+	  (gnus-registry-cache-whitespace file)
+	  (save-buffer))
+      (let ((coding-system-for-write gnus-ding-file-coding-system)
+	    (version-control gnus-backup-startup-file)
+	    (startup-file file)
+	    (working-dir (file-name-directory file))
+	    working-file
+	    (i -1))
+	;; Generate the name of a non-existent file.
+	(while (progn (setq working-file
+			    (format
+			     (if (and (eq system-type 'ms-dos)
+				      (not (gnus-long-file-names)))
+				 "%s#%d.tm#" ; MSDOS limits files to 8+3
+			       (if (memq system-type '(vax-vms axp-vms))
+				   "%s$tmp$%d"
+				 "%s#tmp#%d"))
+			     working-dir (setq i (1+ i))))
+		      (file-exists-p working-file)))
+	
+	(unwind-protect
+	    (progn
+	      (gnus-with-output-to-file working-file
+		(gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
+	      
+	      ;; These bindings will mislead the current buffer
+	      ;; into thinking that it is visiting the startup
+	      ;; file.
+	      (let ((buffer-backed-up nil)
+		    (buffer-file-name startup-file)
+		    (file-precious-flag t)
+		    (setmodes (file-modes startup-file)))
+		;; Backup the current version of the startup file.
+		(backup-buffer)
+		
+		;; Replace the existing startup file with the temp file.
+		(rename-file working-file startup-file t)
+		(gnus-set-file-modes startup-file setmodes)))
+	  (condition-case nil
+	      (delete-file working-file)
+	    (file-error nil)))))
+    
+    (gnus-kill-buffer (current-buffer))
+    (gnus-message 5 "Saving %s...done" file))))
+
+;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
+;; Save the gnus-registry file with extra line breaks.
+(defun gnus-registry-cache-whitespace (filename)
+  (gnus-message 7 "Adding whitespace to %s" filename)
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward "^(\\|(\\\"" nil t)
+      (replace-match "\n\\&" t))
+    (goto-char (point-min))
+    (while (re-search-forward " $" nil t)
+      (replace-match "" t t))))
+
+(defun gnus-registry-save (&optional force)
+  (when (or gnus-registry-dirty force)
+    (let ((caching gnus-registry-entry-caching))
+      ;; turn off entry caching, so mtime doesn't get recorded
+      (setq gnus-registry-entry-caching nil)
+      ;; remove entry caches
+      (maphash
+       (lambda (key value)
+	 (if (hash-table-p value)
+	     (remhash key gnus-registry-hashtb)))
+       gnus-registry-hashtb)
+      ;; remove empty entries
+      (when gnus-registry-clean-empty 
+	(gnus-registry-clean-empty-function))
+      ;; now trim the registry appropriately
+      (setq gnus-registry-alist (gnus-registry-trim 
+				 (hashtable-to-alist gnus-registry-hashtb)))
+      ;; really save
+      (gnus-registry-cache-save)
+      (setq gnus-registry-entry-caching caching)
+      (setq gnus-registry-dirty nil))))
+
+(defun gnus-registry-clean-empty-function ()
+  "Remove all empty entries from the registry.  Returns count thereof."
+  (let ((count 0))
+    (maphash
+     (lambda (key value)
+       (unless (or
+		(gnus-registry-fetch-group key)
+		;; TODO: look for specific extra data here!
+		;; in this example, we look for 'label
+		(gnus-registry-fetch-extra key 'label)) 
+	 (incf count)
+	 (remhash key gnus-registry-hashtb)))
+     gnus-registry-hashtb)
+    count))
+
+(defun gnus-registry-read ()
+  (gnus-registry-cache-read)
+  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+  (setq gnus-registry-dirty nil))
+
+(defun gnus-registry-trim (alist)
+  "Trim alist to size, using gnus-registry-max-entries."
+  (if (null gnus-registry-max-entries)
+      alist                             ; just return the alist
+    ;; else, when given max-entries, trim the alist
+    (let* ((timehash (make-hash-table
+		      :size 4096
+		      :test 'equal))
+	   (trim-length (- (length alist) gnus-registry-max-entries))
+	   (trim-length (if (natnump trim-length) trim-length 0)))
+      (maphash
+       (lambda (key value)
+         (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
+       gnus-registry-hashtb)
+
+      ;; we use the return value of this setq, which is the trimmed alist
+      (setq alist
+	    (nthcdr
+	     trim-length
+	     (sort alist 
+		   (lambda (a b)
+		     (time-less-p 
+		      (cdr (gethash (car a) timehash))
+		      (cdr (gethash (car b) timehash))))))))))
 
 (defun alist-to-hashtable (alist)
   "Build a hashtable from the values in ALIST."
@@ -87,13 +309,16 @@ The group names are matched, they don't have to be fully qualified."
      hash)
     list))
 
-(defun gnus-register-action (action data-header from &optional to method)
+(defun gnus-registry-action (action data-header from &optional to method)
   (let* ((id (mail-header-id data-header))
-	(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"
+	 (subject (gnus-registry-simplify-subject 
+		   (mail-header-subject data-header)))
+	 (sender (mail-header-from data-header))
+	 (from (gnus-group-guess-full-name-from-command-method from))
+	 (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
+	 (to-name (if to to "the Bit Bucket"))
+	 (old-entry (gethash id gnus-registry-hashtb)))
+    (gnus-message 7 "Registry: article %s %s from %s to %s"
 		  id
 		  (if method "respooling" "going")
 		  from
@@ -103,21 +328,18 @@ The group names are matched, they don't have to be fully qualified."
     (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
-		group)
-  (gnus-registry-add-group id group))
-;)
+      (gnus-registry-add-group id from subject sender)) ; undo the delete
+
+    (gnus-registry-add-group id to subject sender)))
+
+(defun gnus-registry-spool-action (id group &optional subject sender)
+  (let ((group (gnus-group-guess-full-name-from-command-method group)))
+    (when (and (stringp id) (string-match "\r$" id))
+      (setq id (substring id 0 -1)))
+    (gnus-message 7 "Registry: article %s spooled to %s"
+		  id
+		  group)
+    (gnus-registry-add-group id group subject sender)))
 
 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 ;; the cache and if a match is found, return that group.
@@ -127,44 +349,138 @@ 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) 
 
+This function tracks ALL backends, unlike
+`nnmail-split-fancy-with-parent' which tracks only nnmail
+messages.
+
 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 
+  (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string
+	 (reply-to (message-fetch-field "in-reply-to"))	     ; grab reply-to
+	 ;; now, if reply-to is valid, append it to the References
+	 (refstr (if reply-to 
+		     (concat refstr " " reply-to)
+		   refstr))
+	(nnmail-split-fancy-with-parent-ignore-groups
+	 (if (listp nnmail-split-fancy-with-parent-ignore-groups)
+	     nnmail-split-fancy-with-parent-ignore-groups
+	   (list nnmail-split-fancy-with-parent-ignore-groups)))
+	references res)
+    (if refstr
+	(progn
+	  (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))
+
+      ;; else: there were no references, now try the extra tracking
+      (let ((sender (message-fetch-field "from"))
+	    (subject (gnus-registry-simplify-subject
+		      (message-fetch-field "subject")))
+	    (single-match t))
+	(when (and single-match
+		   (gnus-registry-track-sender-p)
+		   sender)
+	  (maphash
+	   (lambda (key value)
+	     (let ((this-sender (cdr
+				 (gnus-registry-fetch-extra key 'sender))))
+	       (when (and single-match
+			  this-sender
+			  (equal sender this-sender))
+		 ;; too many matches, bail
+		 (unless (equal res (gnus-registry-fetch-group key))
+		   (setq single-match nil))
+		 (setq res (gnus-registry-fetch-group key))
+		 (when (and sender res)
+		   (gnus-message
+		    ;; raise level of messaging if gnus-registry-track-extra
+		    (if gnus-registry-track-extra 7 9)
+		    "%s (extra tracking) traced sender %s to group %s"
+		    "gnus-registry-split-fancy-with-parent"
+		    sender
+		    res)))))
+	   gnus-registry-hashtb))
+	(when (and single-match
+		   (gnus-registry-track-subject-p)
+		   subject
+		   (< gnus-registry-minimum-subject-length (length subject)))
+	  (maphash
+	   (lambda (key value)
+	     (let ((this-subject (cdr 
+				  (gnus-registry-fetch-extra key 'subject))))
+	       (when (and single-match
+			  this-subject
+			  (equal subject this-subject))
+		 ;; too many matches, bail
+		 (unless (equal res (gnus-registry-fetch-group key))
+		   (setq single-match nil))
+		 (setq res (gnus-registry-fetch-group key))
+		 (when (and subject res)
+		   (gnus-message
+		    ;; raise level of messaging if gnus-registry-track-extra
+		    (if gnus-registry-track-extra 7 9)
+		    "%s (extra tracking) traced subject %s to group %s"
+		    "gnus-registry-split-fancy-with-parent"
+		    subject
+		    res)))))
+	   gnus-registry-hashtb))
+	(unless single-match
+	  (gnus-message
+	   3
+	   "gnus-registry-split-fancy-with-parent: too many extra matches for %s"
+	   refstr)
+	  (setq res nil))))
+    (when (and refstr res)
+      (gnus-message
+       5
        "gnus-registry-split-fancy-with-parent traced %s to group %s"
-       refstr (if res res "nil"))
-      res)))
+       refstr res))
+
+    (when (and res gnus-registry-use-long-group-names)
+      (let ((m1 (gnus-find-method-for-group res))
+	    (m2 (or gnus-command-method 
+		    (gnus-find-method-for-group gnus-newsgroup-name)))
+	    (short-res (gnus-group-short-name res)))
+      (if (gnus-methods-equal-p m1 m2)
+	  (progn
+	    (gnus-message
+	     9 
+	     "gnus-registry-split-fancy-with-parent stripped group %s to %s"
+	     res
+	     short-res)
+	    (setq res short-res))
+	;; else...
+	(gnus-message
+	 7
+	 "gnus-registry-split-fancy-with-parent ignored foreign group %s"
+	 res)
+	(setq res nil))))
+    res))
 
 (defun gnus-registry-register-message-ids ()
   "Register the Message-ID of every article in the group"
-  (unless (and gnus-registry-unregistered-group-regex
-	       (string-match gnus-registry-unregistered-group-regex gnus-newsgroup-name))
+  (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
     (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))))))
+	  (gnus-registry-add-group 
+	   (gnus-registry-fetch-message-id-fast article)
+	   gnus-newsgroup-name
+	   (gnus-registry-fetch-simplified-message-subject-fast article)
+	   (gnus-registry-fetch-sender-fast article)))))))
 
 (defun gnus-registry-fetch-message-id-fast (article)
   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
@@ -173,6 +489,28 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
     nil))
 
+(defun gnus-registry-simplify-subject (subject)
+  (if (stringp subject)
+      (gnus-simplify-subject subject)
+    nil))
+
+(defun gnus-registry-fetch-simplified-message-subject-fast (article)
+  "Fetch the Subject quickly, using the internal gnus-data-list function"
+  (if (and (numberp article)
+	   (assoc article (gnus-data-list nil)))
+      (gnus-registry-simplify-subject
+       (mail-header-subject (gnus-data-header
+			     (assoc article (gnus-data-list nil)))))
+    nil))
+
+(defun gnus-registry-fetch-sender-fast (article)
+  "Fetch the Sender quickly, using the internal gnus-data-list function"
+  (if (and (numberp article)
+	   (assoc article (gnus-data-list nil)))
+      (mail-header-from (gnus-data-header
+			 (assoc article (gnus-data-list nil))))
+    nil))
+
 (defun gnus-registry-grep-in-list (word list)
   (when word
     (memq nil
@@ -182,18 +520,91 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 		     (string-match x word))
 		   list)))))
 
+(defun gnus-registry-fetch-extra (id &optional entry)
+  "Get the extra data of a message, based on the message ID.
+Returns the first place where the trail finds a nonstring."
+  (let ((entry-cache (gethash entry gnus-registry-hashtb)))
+    (if (and entry
+	     (hash-table-p entry-cache)
+	     (gethash id entry-cache))
+	(gethash id entry-cache)
+      ;; else, if there is no caching possible...
+      (let ((trail (gethash id gnus-registry-hashtb)))
+	(when (listp trail)
+	  (dolist (crumb trail)
+	    (unless (stringp crumb)
+	      (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
+
+(defun gnus-registry-fetch-extra-entry (alist &optional entry id)
+  "Get the extra data of a message, or a specific entry in it.
+Update the entry cache if needed."
+  (if (and entry id)
+      (let ((entry-cache (gethash entry gnus-registry-hashtb))
+	    entree)
+	(when gnus-registry-entry-caching
+	  ;; create the hash table
+	  (unless (hash-table-p entry-cache)
+	    (setq entry-cache (make-hash-table
+			       :size 4096
+			       :test 'equal))
+	    (puthash entry entry-cache gnus-registry-hashtb))
+
+	  ;; get the entree from the hash table or from the alist
+	  (setq entree (gethash id entry-cache)))
+	
+	(unless entree
+	  (setq entree (assq entry alist))
+	  (when gnus-registry-entry-caching
+	    (puthash id entree entry-cache)))
+	entree)
+    alist))
+
+(defun gnus-registry-store-extra (id extra)
+  "Store the extra data of a message, based on the message ID.
+The message must have at least one group name."
+  (when (gnus-registry-group-count id)
+    ;; we now know the trail has at least 1 group name, so it's not empty
+    (let ((trail (gethash id gnus-registry-hashtb))
+	  (old-extra (gnus-registry-fetch-extra id))
+	  entry-cache)
+      (dolist (crumb trail)
+	(unless (stringp crumb)
+	  (dolist (entry crumb)
+	    (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
+	  (when entry-cache
+	    (remhash id entry-cache))))
+      (puthash id (cons extra (delete old-extra trail))
+	       gnus-registry-hashtb)
+      (setq gnus-registry-dirty t)))))
+
+(defun gnus-registry-store-extra-entry (id key value)
+  "Put a specific entry in the extras field of the registry entry for id."
+  (let* ((extra (gnus-registry-fetch-extra id))
+	 (alist (cons (cons key value)
+		 (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
+    (gnus-registry-store-extra id alist)))
+
 (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
+Returns the first place where the trail finds a group name."
+  (when (gnus-registry-group-count id)
+    ;; we now know the trail has at least 1 group name
     (let ((trail (gethash id gnus-registry-hashtb)))
-      (if trail
-	  (car trail)
-	nil))))
+      (dolist (crumb trail)
+	(when (stringp crumb)
+	  (return (if gnus-registry-use-long-group-names 
+		       crumb 
+		     (gnus-group-short-name crumb))))))))
+
+(defun gnus-registry-group-count (id)
+  "Get the number of groups of a message, based on the message ID."
+  (let ((trail (gethash id gnus-registry-hashtb)))
+    (if (and trail (listp trail))
+	(apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
+      0)))
 
 (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."
+  "Delete a group for a message, based on the message ID."
   (when group
     (when id
       (let ((trail (gethash id gnus-registry-hashtb))
@@ -202,41 +613,101 @@ Returns the first place where the trail finds a spool action."
 			(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)))))
+      ;; now, clear the entry if there are no more groups
+      (when gnus-registry-trim-articles-without-groups
+	(unless (gnus-registry-group-count id)
+	  (gnus-registry-delete-id id)))
+      (gnus-registry-store-extra-entry id 'mtime (current-time)))))
+
+(defun gnus-registry-delete-id (id)
+  "Delete a message ID from the registry."
+  (when (stringp id)
+    (remhash id gnus-registry-hashtb)
+    (maphash
+     (lambda (key value)
+       (when (hash-table-p value)
+	 (remhash id value)))
+     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
+(defun gnus-registry-add-group (id group &optional subject sender)
+  "Add a group for a message, based on the message ID."
   (when group
-    (when id
-      (let ((group (gnus-group-short-name group)))
-	(gnus-registry-delete-group id group)	
+    (when (and id
+	       (not (string-match "totally-fudged-out-message-id" id)))
+      (let ((full-group group)
+	    (group (if gnus-registry-use-long-group-names 
+		       group 
+		     (gnus-group-short-name group))))
+	(gnus-registry-delete-group id group)
+
+	(unless gnus-registry-use-long-group-names ;; unnecessary in this case
+	  (gnus-registry-delete-group id full-group))
+
 	(let ((trail (gethash id gnus-registry-hashtb)))
 	  (puthash id (if trail
 			  (cons group trail)
 			(list group))
-		   gnus-registry-hashtb))))))
+		   gnus-registry-hashtb)
+
+	  (when (and (gnus-registry-track-subject-p)
+		     subject)
+	    (gnus-registry-store-extra-entry
+	     id 
+	     'subject 
+	     (gnus-registry-simplify-subject subject)))
+	  (when (and (gnus-registry-track-sender-p)
+		     sender)
+	    (gnus-registry-store-extra-entry
+	     id 
+	     'sender
+	     sender))
+	  
+	  (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 
 (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)
+  (setq gnus-registry-alist nil)
+  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+  (setq gnus-registry-dirty t))
 
-(add-hook 'gnus-save-newsrc-hook 'gnus-registry-translate-to-alist)
-(add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-translate-from-alist)
+;;;###autoload
+(defun gnus-registry-initialize ()
+  (interactive)
+  (setq gnus-registry-install t)
+  (gnus-registry-install-hooks)
+  (gnus-registry-read))
 
-(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
+;;;###autoload
+(defun gnus-registry-install-hooks ()
+  "Install the registry hooks."
+  (interactive)
+  (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) 
+  (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
+  (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
+  (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
+  
+  (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
+  (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
+
+  (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
+
+(defun gnus-registry-unload-hook ()
+  "Uninstall the registry hooks."
+  (interactive)
+  (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) 
+  (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
+  (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
+  (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
+  
+  (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
+  (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
+
+  (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
+
+(when gnus-registry-install
+  (gnus-registry-install-hooks)
+  (gnus-registry-read))
 
 ;; TODO: a lot of things