X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=a84ea8394dca175d8fbe28fb2ad7c6d3d658ba1d;hb=3a98157c203684fe42ef2524ac9f3cff1c4ae72d;hp=ec14c53e0937d986697311b5cad342305bf88e47;hpb=85d83e62d3d84f12fa7305e62206b9d092da6335;p=gnus

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index ec14c53e0..a84ea8394 100644
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -24,11 +24,11 @@
 
 ;;; 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 +37,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:
 
@@ -85,7 +84,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 +95,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 +119,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)
@@ -127,12 +133,11 @@ tracked this way."
   :type '(radio (const :format "Unlimited " nil)
 		(integer :format "Maximum number: %v\n" :size 0)))
 
-;; 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."
@@ -208,7 +213,7 @@ tracked this way."
 ;; 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)
@@ -244,7 +249,11 @@ tracked this way."
   (let ((count 0))
     (maphash
      (lambda (key value)
-       (unless (gnus-registry-fetch-group 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)
 	 (remhash key gnus-registry-hashtb)))
      gnus-registry-hashtb)
@@ -302,11 +311,12 @@ tracked this way."
   (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"
+	 (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
@@ -316,21 +326,18 @@ tracked this way."
     (gnus-registry-delete-group id from)
 
     (when (equal 'copy action) 
-      (gnus-registry-add-group id from subject)) ; undo the delete
-
-    (gnus-registry-add-group id to subject)))
-
-(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 (and (stringp id) (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))
-;)
+      (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.
@@ -340,6 +347,10 @@ 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.
@@ -365,31 +376,90 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 			       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))
+
+      ;; 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 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-register-message-ids ()
@@ -403,7 +473,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 	  (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"
@@ -426,6 +497,14 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 			     (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
@@ -480,10 +559,17 @@ 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-store-extra-entry (id key value)
   "Put a specific entry in the extras field of the registry entry for id."
@@ -500,7 +586,9 @@ 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-group-count (id)
   "Get the number of groups of a message, based on the message ID."
@@ -535,9 +623,8 @@ Returns the first place where the trail finds a group name."
 	 (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)))
@@ -546,19 +633,28 @@ Returns the first place where the trail finds a group name."
 		       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 
+	  (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)))))))