* nnmaildir.el (nnmaildir-request-set-mark): Handle the "too many

[gnus] / lisp / gnus-registry.el

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index 4291782..c1e6d58 100644 (file)
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -94,11 +94,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.
+  "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."
@@ -126,12 +129,11 @@ 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."
@@ -362,48 +364,70 @@ 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 ((sender (message-fetch-field "from"))
-             (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 5 9)
-                   "%s (extra tracking) traced subject %s to group %s"
+                   "%s (extra tracking) traced sender %s to group %s"
                    "gnus-registry-split-fancy-with-parent"
-                   subject
-                   (if res res "nil")))))
-            gnus-registry-hashtb))
-         (when sender
-           (maphash
-            (lambda (key value)
-              (let ((this-sender (cdr 
-                                   (gnus-registry-fetch-extra key 'sender))))
-                (when (and this-sender
-                           (equal sender this-sender))
-                  (setq res (gnus-registry-fetch-group key))
+                   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)
-                   "%s (extra tracking) traced sender %s to group %s"
+                   "%s (extra tracking) traced subject %s to group %s"
                    "gnus-registry-split-fancy-with-parent"
-                   sender
-                   (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"))
+                   subject
+                   res)))))
+          gnus-registry-hashtb))
+       (unless single-match
+         (gnus-message
+          5
+          "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))
@@ -607,17 +631,18 @@ Returns the first place where the trail finds a group name."
                        (list group))
                   gnus-registry-hashtb)
 
-         (when gnus-registry-track-extra
-           (when subject
-             (gnus-registry-store-extra-entry
-              id 
-              'subject 
-              (gnus-registry-simplify-subject subject)))
-           (when sender
-             (gnus-registry-store-extra-entry
-              id 
-              'sender
-              sender)))
+         (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)))))))