Merge from gnus--devo--0

Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1128

1 files changed, 45 insertions, 7 deletions

diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index fd08d4d1e39..93ee0efce85 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -161,6 +161,17 @@ way."
     (const :tag "Track by subject (Subject: header)" subject)
     (const :tag "Track by sender (From: header)"  sender)))
 
+(defcustom gnus-registry-split-strategy 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
+  '(choice :tag "Tracking choices"
+	   (const :tag "Only use single choices, discard multiple matches" nil)
+	   (const :tag "Majority of matches wins" majority)
+	   (const :tag "First found wins"  first)))
+
 (defcustom gnus-registry-entry-caching t
   "Whether the registry should cache extra information."
   :group 'gnus-registry
@@ -486,7 +497,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 	      nnmail-split-fancy-with-parent-ignore-groups
 	    (list nnmail-split-fancy-with-parent-ignore-groups)))
 	 (log-agent "gnus-registry-split-fancy-with-parent")
-	 found)
+	 found found-full)
 
     ;; this is a big if-else statement.  it uses
     ;; gnus-registry-post-process-groups to filter the results after
@@ -507,9 +518,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 	     log-agent reference refstr group)
 	    (push group found))))
       ;; filter the found groups and return them
+      ;; the found groups are the full groups
       (setq found (gnus-registry-post-process-groups 
-		   "references" refstr found)))
-
+		   "references" refstr found found)))
+     
      ;; else: there were no matches, now try the extra tracking by sender
      ((and (gnus-registry-track-sender-p) 
 	   sender)
@@ -522,6 +534,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 		      (equal sender this-sender))
 	     (let ((groups (gnus-registry-fetch-groups key)))
 	       (dolist (group groups)
+		 (push group found-full)
 		 (setq found (append (list group) (delete group found)))))
 	     (push key matches)
 	     (gnus-message
@@ -531,7 +544,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 	      log-agent sender found matches))))
        gnus-registry-hashtb)
       ;; filter the found groups and return them
-      (setq found (gnus-registry-post-process-groups "sender" sender found)))
+      ;; the found groups are NOT the full groups
+      (setq found (gnus-registry-post-process-groups 
+		   "sender" sender found found-full)))
       
      ;; else: there were no matches, now try the extra tracking by subject
      ((and (gnus-registry-track-subject-p)
@@ -546,6 +561,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 		      (equal subject this-subject))
 	     (let ((groups (gnus-registry-fetch-groups key)))
 	       (dolist (group groups)
+		 (push group found-full)
 		 (setq found (append (list group) (delete group found)))))
 	     (push key matches)
 	     (gnus-message
@@ -555,10 +571,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 	      log-agent subject found matches))))
        gnus-registry-hashtb)
       ;; filter the found groups and return them
+      ;; the found groups are NOT the full groups
       (setq found (gnus-registry-post-process-groups 
-		   "subject" subject found))))))
+		   "subject" subject found found-full))))
+    ;; after the (cond) we extract the actual value safely
+    (car-safe found)))
 
-(defun gnus-registry-post-process-groups (mode key groups)
+(defun gnus-registry-post-process-groups (mode key groups groups-full)
   "Modifies GROUPS found by MODE for KEY to determine which ones to follow.
 
 MODE can be 'subject' or 'sender' for example.  The KEY is the
@@ -572,9 +591,28 @@ This is not possible if gnus-registry-use-long-group-names is
 false.  Foreign methods are not supported so they are rejected.
 
 Reduces the list to a single group, or complains if that's not
-possible."
+possible.  Uses `gnus-registry-split-strategy' and GROUPS-FULL if
+necessary."
   (let ((log-agent "gnus-registry-post-process-group")
 	out)
+
+    ;; the strategy can be 'first, 'majority, or nil
+    (when (eq gnus-registry-split-strategy 'first)
+      (when groups
+	(setq groups (list (car-safe groups)))))
+
+    (when (eq gnus-registry-split-strategy 'majority)
+      (let ((freq (make-hash-table
+		   :size 256
+		   :test 'equal)))
+	(mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full)
+	(setq groups (list (car-safe
+			    (sort
+			     groups
+			     (lambda (a b)
+			       (> (gethash a freq 0)
+				  (gethash b freq 0)))))))))
+    
     (if gnus-registry-use-long-group-names
 	(dolist (group groups)
 	  (let ((m1 (gnus-find-method-for-group group))