X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=d45cc6c5d6d777144349235c17dcb40a2fdcd8d2;hp=cb48b89edfdfb84513e737faa4a6a7a8ffc09909;hb=b58d62328adf02b341b460a98819a54a0d629b60;hpb=c7b3c3d80c7a296e63180251bd7574fbaab3d12d

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index cb48b89ed..d45cc6c5d 100644
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -1,6 +1,7 @@
 ;;; gnus-registry.el --- article registry for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
-;;        Free Software Foundation, Inc.
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;;   2005, 2006, 2007 Free Software Foundation, Inc.
 
 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
 ;; Keywords: news
@@ -9,7 +10,7 @@
 
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
 ;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
@@ -19,16 +20,16 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 
-;; This is the gnus-registry.el package, works with other backends
-;; besides nnmail.  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
+;; 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
@@ -37,11 +38,10 @@
 
 ;; Put this in your startup file (~/.gnus.el for instance)
 
-;; (setq gnus-registry-install t
-;;  gnus-registry-max-entries 2500
-;;  gnus-registry-use-long-group-names t)
+;; (setq gnus-registry-max-entries 2500
+;;       gnus-registry-use-long-group-names t)
 
-;; (require 'gnus-registry)
+;; (gnus-registry-initialize)
 
 ;; Then use this in your fancy-split:
 
@@ -60,23 +60,32 @@
 (require 'gnus)
 (require 'gnus-int)
 (require 'gnus-sum)
+(require 'gnus-util)
 (require 'nnmail)
 
+(defvar gnus-adaptive-word-syntax-table)
+
 (defvar gnus-registry-dirty t
  "Boolean set to t when the registry is modified")
 
 (defgroup gnus-registry nil
   "The Gnus registry."
+  :version "22.1"
   :group 'gnus)
 
-(defvar gnus-registry-hashtb nil
+(defvar gnus-registry-hashtb (make-hash-table 			    
+			      :size 256
+			      :test 'equal)
   "*The article registry by Message ID.")
 
-(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."
+(defcustom gnus-registry-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$")
+  "List of groups that gnus-registry-split-fancy-with-parent won't return.
+The group names are matched, they don't have to be fully
+qualified.  This parameter tells the Registry 'never split a
+message into a group that matches one of these, regardless of
+references.'"
   :group 'gnus-registry
-  :type '(repeat string))
+  :type '(repeat regexp))
 
 (defcustom gnus-registry-install nil
   "Whether the registry should be installed."
@@ -85,7 +94,8 @@ The group names are matched, they don't have to be fully qualified."
 
 (defcustom gnus-registry-clean-empty t
   "Whether the empty registry entries should be deleted.
-Registry entries are considered empty when they have no groups."
+Registry entries are considered empty when they have no groups
+and no extra data."
   :group 'gnus-registry
   :type 'boolean)
 
@@ -95,11 +105,14 @@ Registry entries are considered empty when they have no groups."
   :type 'boolean)
 
 (defcustom gnus-registry-track-extra nil
-  "Whether the registry should track other things about a message.
-The Subject header is currently the only thing that can be
-tracked this way."
+  "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 'boolean)
+  :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."
@@ -116,7 +129,10 @@ tracked this way."
   :group 'gnus-registry
   :type 'boolean)
 
-(defcustom gnus-registry-cache-file "~/.gnus.registry.eld"
+(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)
@@ -125,14 +141,13 @@ tracked this way."
   "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)))
+		(integer :format "Maximum number: %v")))
 
-;; 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)))
+(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."
@@ -143,6 +158,8 @@ tracked this way."
       (gnus-load file)
       (gnus-message 5 "Reading %s...done" file))))
 
+;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in
+;; `gnus-start.el'.  --rsteib
 (defun gnus-registry-cache-save ()
   "Save the registry cache file."
   (interactive)
@@ -179,12 +196,12 @@ tracked this way."
 				 "%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.
@@ -194,21 +211,21 @@ tracked this way."
 		    (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)
-		(set-file-modes startup-file setmodes)))
+		(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 5 "Adding whitespace to %s" filename)
+  (gnus-message 7 "Adding whitespace to %s" filename)
   (save-excursion
     (goto-char (point-min))
     (while (re-search-forward "^(\\|(\\\"" nil t)
@@ -229,11 +246,14 @@ tracked this way."
 	     (remhash key gnus-registry-hashtb)))
        gnus-registry-hashtb)
       ;; remove empty entries
-      (when gnus-registry-clean-empty 
+      (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)))
+      ;; now trim and clean text properties from the registry appropriately
+      (setq gnus-registry-alist 
+	    (gnus-registry-remove-alist-text-properties
+	     (gnus-registry-trim
+	      (gnus-hashtable-to-alist
+	       gnus-registry-hashtb))))
       ;; really save
       (gnus-registry-cache-save)
       (setq gnus-registry-entry-caching caching)
@@ -242,71 +262,92 @@ tracked this way."
 (defun gnus-registry-clean-empty-function ()
   "Remove all empty entries from the registry.  Returns count thereof."
   (let ((count 0))
+
     (maphash
      (lambda (key value)
-       (unless (gnus-registry-fetch-group key)
-	 (incf count)
-	 (remhash key gnus-registry-hashtb)))
+       (when (stringp key)
+	 (dolist (group (gnus-registry-fetch-groups key))
+	   (when (gnus-parameter-registry-ignore group)
+	     (gnus-message
+	      10 
+	      "gnus-registry: deleted ignored group %s from key %s"
+	      group key)
+	     (gnus-registry-delete-group key group)))
+
+	 (unless (gnus-registry-group-count key)
+	   (gnus-registry-delete-id key))
+
+	 (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)
+	   (gnus-registry-delete-id key))
+	 
+	 (unless (stringp key)
+	   (gnus-message 
+	    10 
+	    "gnus-registry key %s was not a string, removing" 
+	    key)
+	   (gnus-registry-delete-id key))))
+       
      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-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
   (setq gnus-registry-dirty nil))
 
+(defun gnus-registry-remove-alist-text-properties (v)
+  "Remove text properties from all strings in alist."
+  (if (stringp v)
+      (gnus-string-remove-all-properties v)
+    (if (and (listp v) (listp (cdr v)))
+	(mapcar 'gnus-registry-remove-alist-text-properties v)
+      (if (and (listp v) (stringp (cdr v)))
+	  (cons (gnus-registry-remove-alist-text-properties (car v))
+		(gnus-registry-remove-alist-text-properties (cdr v)))
+      v))))
+
 (defun gnus-registry-trim (alist)
-  "Trim alist to size, using gnus-registry-max-entries."
+  "Trim alist to size, using gnus-registry-max-entries.
+Also, drop all gnus-registry-ignored-groups matches."
   (if (null gnus-registry-max-entries)
-      alist				; just return the alist
+      alist                             ; just return the alist
     ;; else, when given max-entries, trim the alist
-    (let ((timehash (make-hash-table 			    
-		     :size 4096
-		     :test 'equal)))
+    (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))
+         (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
-	     (- (length alist) gnus-registry-max-entries)
-	     (sort alist 
+	     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."
-  (let ((ht (make-hash-table 			    
-	     :size 4096
-	     :test 'equal)))
-    (mapc
-     (lambda (kv-pair)
-       (puthash (car kv-pair) (cdr kv-pair) ht))
-     alist)
-     ht))
-
-(defun hashtable-to-alist (hash)
-  "Build an alist from the values in HASH."
-  (let ((list nil))
-    (maphash
-     (lambda (key value)
-       (setq list (cons (cons key value) list)))
-     hash)
-    list))
+		     (time-less-p
+		      (or (cdr (gethash (car a) timehash)) '(0 0 0))
+		      (or (cdr (gethash (car b) timehash)) '(0 0 0))))))))))
 
 (defun gnus-registry-action (action data-header from &optional to method)
   (let* ((id (mail-header-id data-header))
-	 (subject (gnus-registry-simplify-subject 
-		   (mail-header-subject 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-string-remove-all-properties
+		   (gnus-registry-simplify-subject
+		    (mail-header-subject data-header))))
+	 (sender (gnus-string-remove-all-properties (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
@@ -315,22 +356,19 @@ tracked this way."
     ;; All except copy will need a delete
     (gnus-registry-delete-group id from)
 
-    (when (equal 'copy action) 
-      (gnus-registry-add-group id from subject)) ; undo the delete
+    (when (equal 'copy action)
+      (gnus-registry-add-group id from subject sender)) ; undo the delete
 
-    (gnus-registry-add-group id to subject)))
+    (gnus-registry-add-group id to subject sender)))
 
-(defun gnus-registry-spool-action (id group &optional subject)
-  ;; 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 subject))
-;)
+(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.
@@ -338,72 +376,175 @@ tracked this way."
   "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) 
+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.
+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, unless it matches one of the entries in
+gnus-registry-unfollowed-groups or
+nnmail-split-fancy-with-parent-ignore-groups.
 
 See the Info node `(gnus)Fancy Mail Splitting' for more details."
-  (let ((refstr (or (message-fetch-field "references")
-		    (message-fetch-field "in-reply-to")))
+  (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))
-      ;; there were no references, now try the extra tracking
-      (when gnus-registry-track-extra
-	(let ((subject (gnus-registry-simplify-subject 
-			(message-fetch-field "subject"))))
-	  (when (and subject
-		     (< gnus-registry-minimum-subject-length (length subject)))
-	    (maphash
-	     (lambda (key value)
-	       (let ((this-subject (cdr 
-				    (gnus-registry-fetch-extra key 'subject))))
-		 (when (and this-subject
-			    (equal subject this-subject))
-		   (setq res (gnus-registry-fetch-group key))
+	res)
+    ;; the references string must be valid and parse to valid references
+    (if (and refstr (gnus-extract-references refstr))
+	(dolist (reference (nreverse (gnus-extract-references refstr)))
+	  (setq res (or (gnus-registry-fetch-group reference) 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)))
+
+      ;; else: there were no references, now try the extra tracking
+      (let ((sender (gnus-string-remove-all-properties(message-fetch-field "from")))
+	    (subject (gnus-string-remove-all-properties
+		      (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 5 9) 
+		    (if gnus-registry-track-extra 7 9)
 		    "%s (extra tracking) traced subject %s to group %s"
 		    "gnus-registry-split-fancy-with-parent"
 		    subject
-		    (if res res "nil")))))
-	     gnus-registry-hashtb)))))
-    (gnus-message
-     5 
-     "gnus-registry-split-fancy-with-parent traced %s to group %s"
-     refstr (if res res "nil"))
+		    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 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-wash-for-keywords (&optional force)
+  (interactive)
+  (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
+	word words)
+    (if (or (not (gnus-registry-fetch-extra id 'keywords))
+	    force)
+	(save-excursion
+	  (set-buffer gnus-article-buffer)
+	  (article-goto-body)
+	  (save-window-excursion
+	    (save-restriction
+	      (narrow-to-region (point) (point-max))
+	      (with-syntax-table gnus-adaptive-word-syntax-table
+		(while (re-search-forward "\\b\\w+\\b" nil t)
+		  (setq word (gnus-registry-remove-alist-text-properties
+			      (downcase (buffer-substring
+					 (match-beginning 0) (match-end 0)))))
+		  (if (> (length word) 3)
+		      (push word words))))))
+	  (gnus-registry-store-extra-entry id 'keywords words)))))
+
+(defun gnus-registry-find-keywords (keyword)
+  (interactive "skeyword: ")
+  (let (articles)
+    (maphash
+     (lambda (key value)
+       (when (gnus-registry-grep-in-list
+	      keyword
+	      (cdr (gnus-registry-fetch-extra key 'keywords)))
+	 (push key articles)))
+     gnus-registry-hashtb)
+    articles))
+
 (defun gnus-registry-register-message-ids ()
   "Register the Message-ID of every article in the group"
   (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" 
+	  (gnus-message 9 "Registry: Registering article %d with group %s"
 			article gnus-newsgroup-name)
-	  (gnus-registry-add-group 
+	  (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-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"
@@ -413,28 +554,65 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
     nil))
 
 (defun gnus-registry-simplify-subject (subject)
-  (if (null subject)
-      nil
-    (gnus-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)))))
+      (gnus-string-remove-all-properties
+       (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)))
+      (gnus-string-remove-all-properties
+       (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
 	  (mapcar 'not
-		  (mapcar 
+		  (mapcar
 		   (lambda (x)
-		     (string-match x word))
+		     (string-match word x))
 		   list)))))
 
+;;; if this extends to more than 'flags, it should be improved to be more generic.
+(defun gnus-registry-fetch-extra-flags (id)
+  "Get the flags of a message, based on the message ID.
+Returns a list of symbol flags or nil."
+  (car-safe (cdr (gnus-registry-fetch-extra id 'flags))))
+
+(defun gnus-registry-has-extra-flag (id flag)
+  "Checks if a message has `flag', based on the message ID."
+  (memq flag (gnus-registry-fetch-extra-flags id)))
+
+(defun gnus-registry-store-extra-flags (id &rest flag-list)
+  "Set the flags of a message, based on the message ID.
+The `flag-list' can be nil, in which case no flags are left."
+  (gnus-registry-store-extra-entry id 'flags (list flag-list)))
+
+(defun gnus-registry-delete-extra-flags (id &rest flag-delete-list)
+  "Delete the message flags in `flag-delete-list', based on the message ID."
+  (let ((flags (gnus-registry-fetch-extra-flags id)))
+    (when flags
+      (dolist (flag flag-delete-list)
+	(setq flags (delq flag flags))))
+    (gnus-registry-store-extra-flags id (car flags))))
+
+(defun gnus-registry-delete-all-extra-flags (id)
+  "Delete all the flags for a message ID."
+  (gnus-registry-store-extra-flags id nil))
+
 (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."
@@ -466,7 +644,7 @@ Update the entry cache if needed."
 
 	  ;; 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
@@ -480,16 +658,32 @@ 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)))
+	  (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))))
+      (setq gnus-registry-dirty t)))))
+
+(defun gnus-registry-delete-extra-entry (id key)
+  "Delete a specific entry in the extras field of the registry entry for id."
+  (gnus-registry-store-extra-entry id key nil))
 
 (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)))))
+	 ;; all the entries except the one for `key'
+	 (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) 
+	 (alist (if value
+		    (gnus-registry-remove-alist-text-properties
+		     (cons (cons key value)
+			   the-rest))
+		  the-rest)))
     (gnus-registry-store-extra id alist)))
 
 (defun gnus-registry-fetch-group (id)
@@ -500,7 +694,26 @@ Returns the first place where the trail finds a group name."
     (let ((trail (gethash id gnus-registry-hashtb)))
       (dolist (crumb trail)
 	(when (stringp crumb)
-	  (return (gnus-group-short-name crumb)))))))
+	  (return (if gnus-registry-use-long-group-names
+		       crumb
+		     (gnus-group-short-name crumb))))))))
+
+(defun gnus-registry-fetch-groups (id)
+  "Get the groups of a message, based on the message ID."
+  (let ((trail (gethash id gnus-registry-hashtb))
+	groups)
+    (dolist (crumb trail)
+      (when (stringp crumb)
+	;; push the group name into the list
+	(setq 
+	 groups
+	 (cons
+	  (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
+	      crumb
+	    (gnus-group-short-name crumb))
+	 groups))))
+    ;; return the list of groups
+    groups))
 
 (defun gnus-registry-group-count (id)
   "Get the number of groups of a message, based on the message ID."
@@ -511,62 +724,89 @@ Returns the first place where the trail finds a group name."
 
 (defun gnus-registry-delete-group (id group)
   "Delete a group for a message, based on the message ID."
-  (when group
-    (when id
+  (when (and group id)
       (let ((trail (gethash id gnus-registry-hashtb))
-	    (group (gnus-group-short-name group)))
+	    (short-group (gnus-group-short-name group)))
 	(puthash id (if trail
-			(delete group trail)
+			(delete short-group (delete group trail))
 		      nil)
 		 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)
-	  (remhash id gnus-registry-hashtb)))
-      (gnus-registry-store-extra-entry id 'mtime (current-time)))))
+	  (gnus-registry-delete-id id)))
+      ;; is this ID still in the registry?
+      (when (gethash id gnus-registry-hashtb)
+	(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 &optional subject)
+(defun gnus-registry-add-group (id group &optional subject sender)
   "Add a group for a message, based on the message ID."
-  ;; make sure there are no duplicate entries
   (when 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 
+	    (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 
+
+	(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)
 
-	  (when gnus-registry-track-extra 
-	    (gnus-registry-store-extra-entry 
-	     id 
-	     'subject 
+	  (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)
-  (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+  (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
   (setq gnus-registry-dirty t))
 
+;;;###autoload
+(defun gnus-registry-initialize ()
+  (interactive)
+  (setq gnus-registry-install t)
+  (gnus-registry-install-hooks)
+  (gnus-registry-read))
+
+;;;###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-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)
 
@@ -575,16 +815,18 @@ Returns the first place where the trail finds a group name."
 (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-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))
 
+(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
+
 (when gnus-registry-install
   (gnus-registry-install-hooks)
   (gnus-registry-read))
@@ -593,4 +835,5 @@ Returns the first place where the trail finds a group name."
 
 (provide 'gnus-registry)
 
+;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
 ;;; gnus-registry.el ends here