X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=4221af663d5b2bdb911c5d0fe3e0173c5f47efa1;hp=511012df577410c7b8fb7732fd29453c6a6f0d32;hb=bbe68edb313e02acb4557e5cc4ff2f87a41ca66c;hpb=4b3eae16e6dfbed9198a27657860934a02b5b8b5

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index 511012df5..4221af663 100644
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -1,6 +1,6 @@
 ;;; gnus-registry.el --- article registry for Gnus
 
-;; Copyright (C) 2002-2011  Free Software Foundation, Inc.
+;; Copyright (C) 2002-2012  Free Software Foundation, Inc.
 
 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
 ;; Keywords: news registry
@@ -31,11 +31,22 @@
 ;; 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).
+;; better documentation in the manual (also on my to-do list).
 
-;; Put this in your startup file (~/.gnus.el for instance)
+;; If you want to track recipients (and you should to make the
+;; gnus-registry splitting work better), you need the To and Cc
+;; headers collected by Gnus.  Note that in more recent Gnus versions
+;; this is already the case: look at `gnus-extra-headers' to be sure.
 
-;; (setq gnus-registry-max-entries 2500)
+;; ;;; you may also want Gcc Newsgroups Keywords X-Face
+;; (add-to-list 'gnus-extra-headers 'To)
+;; (add-to-list 'gnus-extra-headers 'Cc)
+;; (setq nnmail-extra-headers gnus-extra-headers)
+
+;; Put this in your startup file (~/.gnus.el for instance) or use Customize:
+
+;; (setq gnus-registry-max-entries 2500
+;;       gnus-registry-track-extra '(sender subject recipient))
 
 ;; (gnus-registry-initialize)
 
@@ -46,6 +57,16 @@
 ;; You should also consider using the nnregistry backend to look up
 ;; articles.  See the Gnus manual for more information.
 
+;; Finally, you can put %uM in your summary line format to show the
+;; registry marks if you do this:
+
+;; show the marks as single characters (see the :char property in
+;; `gnus-registry-marks'):
+;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
+
+;; show the marks by name (see `gnus-registry-marks'):
+;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
+
 ;; TODO:
 
 ;; - get the correct group on spool actions
@@ -57,10 +78,6 @@
 
 (eval-when-compile (require 'cl))
 
-(eval-when-compile
-  (when (null (require 'ert nil t))
-    (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
-
 (require 'gnus)
 (require 'gnus-int)
 (require 'gnus-sum)
@@ -116,7 +133,10 @@ display.")
 (defcustom gnus-registry-unfollowed-addresses
   (list (regexp-quote user-mail-address))
   "List of addresses that gnus-registry-split-fancy-with-parent won't trace.
-The addresses are matched, they don't have to be fully qualified."
+The addresses are matched, they don't have to be fully qualified.
+In the messages, these addresses can be the sender or the
+recipients."
+  :version "24.1"
   :group 'gnus-registry
   :type '(repeat regexp))
 
@@ -139,6 +159,8 @@ nnmairix groups are specifically excluded because they are ephemeral."
                  (const :tag "Always Install" t)
                  (const :tag "Ask Me" ask)))
 
+(defvar gnus-registry-enabled nil)
+
 (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
 
 (defvar gnus-registry-misc-menus nil)   ; ugly way to keep the menus
@@ -149,14 +171,15 @@ nnmairix groups are specifically excluded because they are ephemeral."
 (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
 (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
 
-(defcustom gnus-registry-track-extra '(subject sender)
+(defcustom gnus-registry-track-extra '(subject sender recipient)
   "Whether the registry should track extra data about a message.
-The Subject and Sender (From:) headers are tracked this way by
-default."
+The subject, recipients (To: and Cc:), and Sender (From:) headers
+are tracked this way by default."
   :group 'gnus-registry
   :type
   '(set :tag "Tracking choices"
     (const :tag "Track by subject (Subject: header)" subject)
+    (const :tag "Track by recipient (To: and Cc: headers)" recipient)
     (const :tag "Track by sender (From: header)"  sender)))
 
 (defcustom gnus-registry-split-strategy nil
@@ -215,24 +238,31 @@ the Bit Bucket."
 
 (defcustom gnus-registry-max-pruned-entries nil
   "Maximum number of pruned entries in the registry, nil for unlimited."
+  :version "24.1"
   :group 'gnus-registry
   :type '(radio (const :format "Unlimited " nil)
                 (integer :format "Maximum number: %v")))
 
 (defun gnus-registry-fixup-registry (db)
   (when db
-    (oset db :precious
-          (append gnus-registry-extra-entries-precious
-                  '()))
-    (oset db :max-hard
-          (or gnus-registry-max-entries
-              most-positive-fixnum))
-    (oset db :max-soft
-          (or gnus-registry-max-pruned-entries
-              most-positive-fixnum))
-    (oset db :tracked
-          (append gnus-registry-track-extra
-                  '(mark group keyword))))
+    (let ((old (oref db :tracked)))
+      (oset db :precious
+            (append gnus-registry-extra-entries-precious
+                    '()))
+      (oset db :max-hard
+            (or gnus-registry-max-entries
+                most-positive-fixnum))
+      (oset db :prune-factor
+            0.1)
+      (oset db :max-soft
+            (or gnus-registry-max-pruned-entries
+                most-positive-fixnum))
+      (oset db :tracked
+            (append gnus-registry-track-extra
+                    '(mark group keyword)))
+      (when (not (equal old (oref db :tracked)))
+        (gnus-message 9 "Reindexing the Gnus registry (tracked change)")
+        (registry-reindex db))))
   db)
 
 (defun gnus-registry-make-db (&optional file)
@@ -256,7 +286,7 @@ the Bit Bucket."
 This is not required after changing `gnus-registry-cache-file'."
   (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
   (when forsure
-    (gnus-message 1 "Remaking the Gnus registry")
+    (gnus-message 4 "Remaking the Gnus registry")
     (setq gnus-registry-db (gnus-registry-make-db))))
 
 (defun gnus-registry-read ()
@@ -289,14 +319,30 @@ This is not required after changing `gnus-registry-cache-file'."
     (gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
                   (registry-size db) file)))
 
+(defun gnus-registry-remove-ignored ()
+  (interactive)
+  (let* ((db gnus-registry-db)
+         (grouphashtb (registry-lookup-secondary db 'group))
+         (old-size (registry-size db)))
+    (registry-reindex db)
+    (loop for k being the hash-keys of grouphashtb
+          using (hash-values v)
+          when (gnus-registry-ignore-group-p k)
+          do (registry-delete db v nil))
+    (registry-reindex db)
+    (gnus-message 4 "Removed %d ignored entries from the Gnus registry"
+                  (- old-size (registry-size db)))))
+
 ;; article move/copy/spool/delete actions
 (defun gnus-registry-action (action data-header from &optional to method)
   (let* ((id (mail-header-id data-header))
-         (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)))
+         (subject (mail-header-subject data-header))
+         (extra (mail-header-extra data-header))
+         (recipients (gnus-registry-sort-addresses
+                      (or (cdr-safe (assq 'Cc extra)) "")
+                      (or (cdr-safe (assq 'To extra)) "")))
+         (sender (nth 0 (gnus-registry-extract-addresses
+                         (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")))
@@ -307,21 +353,36 @@ This is not required after changing `gnus-registry-cache-file'."
      id
      ;; unless copying, remove the old "from" group
      (if (not (equal 'copy action)) from nil)
-     to subject sender)))
-
-(defun gnus-registry-spool-action (id group &optional subject sender)
-  (let ((to (gnus-group-guess-full-name-from-command-method group)))
+     to subject sender recipients)))
+
+(defun gnus-registry-spool-action (id group &optional subject sender recipients)
+  (let ((to (gnus-group-guess-full-name-from-command-method group))
+        (recipients (or recipients
+                        (gnus-registry-sort-addresses
+                         (or (message-fetch-field "cc") "")
+                         (or (message-fetch-field "to") ""))))
+        (subject (or subject (message-fetch-field "subject")))
+        (sender (or sender (message-fetch-field "from"))))
     (when (and (stringp id) (string-match "\r$" id))
       (setq id (substring id 0 -1)))
     (gnus-message 7 "Gnus registry: article %s spooled to %s"
                   id
                   to)
-    (gnus-registry-handle-action id nil to subject sender)))
+    (gnus-registry-handle-action id nil to subject sender recipients)))
 
-(defun gnus-registry-handle-action (id from to subject sender)
+(defun gnus-registry-handle-action (id from to subject sender
+                                       &optional recipients)
+  (gnus-message
+   10
+   "gnus-registry-handle-action %S" (list id from to subject sender recipients))
   (let ((db gnus-registry-db)
+        ;; if the group is ignored, set the destination to nil (same as delete)
+        (to (if (gnus-registry-ignore-group-p to) nil to))
         ;; safe if not found
-        (entry (gnus-registry-get-or-make-entry id)))
+        (entry (gnus-registry-get-or-make-entry id))
+        (subject (gnus-string-remove-all-properties
+                  (gnus-registry-simplify-subject subject)))
+        (sender (gnus-string-remove-all-properties sender)))
 
     ;; this could be done by calling `gnus-registry-set-id-key'
     ;; several times but it's better to bunch the transactions
@@ -332,17 +393,21 @@ This is not required after changing `gnus-registry-cache-file'."
       (setq entry (cons (delete from (assoc 'group entry))
                         (assq-delete-all 'group entry))))
 
-    (dolist (kv `((group ,to) (sender ,sender) (subject ,subject)))
+    (dolist (kv `((group ,to)
+                  (sender ,sender)
+                  (recipient ,@recipients)
+                  (subject ,subject)))
       (when (second kv)
         (let ((new (or (assq (first kv) entry)
                        (list (first kv)))))
-          (add-to-list 'new (second kv) t)
+          (dolist (toadd (cdr kv))
+            (add-to-list 'new toadd t))
           (setq entry (cons new
                             (assq-delete-all (first kv) entry))))))
     (gnus-message 10 "Gnus registry: new entry for %s is %S"
                   id
                   entry)
-    (registry-insert db id entry)))
+    (gnus-registry-insert db id entry)))
 
 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 ;; the cache and if a match is found, return that group.
@@ -373,6 +438,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
          ;; these may not be used, but the code is cleaner having them up here
          (sender (gnus-string-remove-all-properties
                   (message-fetch-field "from")))
+         (recipients (gnus-registry-sort-addresses
+                      (or (message-fetch-field "cc") "")
+                      (or (message-fetch-field "to") "")))
          (subject (gnus-string-remove-all-properties
                    (gnus-registry-simplify-subject
                     (message-fetch-field "subject"))))
@@ -385,94 +453,126 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
      :references references
      :refstr refstr
      :sender sender
+     :recipients recipients
      :subject subject
      :log-agent "Gnus registry fancy splitting with parent")))
 
 (defun* gnus-registry--split-fancy-with-parent-internal
     (&rest spec
-           &key references refstr sender subject log-agent
+           &key references refstr sender subject recipients log-agent
            &allow-other-keys)
   (gnus-message
    10
-   "gnus-registry--split-fancy-with-parent-internal: %S" spec)
+   "gnus-registry--split-fancy-with-parent-internal %S" spec)
   (let ((db gnus-registry-db)
         found)
-    ;; this is a big if-else statement.  it uses
+    ;; this is a big chain of statements.  it uses
     ;; gnus-registry-post-process-groups to filter the results after
     ;; every step.
-    (cond
-     ;; the references string must be valid and parse to valid references
-     (references
+    ;; the references string must be valid and parse to valid references
+    (when references
+      (gnus-message
+       9
+       "%s is tracing references %s"
+       log-agent refstr)
       (dolist (reference (nreverse references))
-        (gnus-message
-         9
-         "%s is looking for matches for reference %s from [%s]"
-         log-agent reference refstr)
-        (setq found
-              (loop for group in (gnus-registry-get-id-key reference 'group)
-                    when (gnus-registry-follow-group-p group)
-                    do (gnus-message
-                        7
-                        "%s traced the reference %s from [%s] to group %s"
-                        log-agent reference refstr group)
-                    collect group)))
+        (gnus-message 9 "%s is looking up %s" log-agent reference)
+        (loop for group in (gnus-registry-get-id-key reference 'group)
+              when (gnus-registry-follow-group-p group)
+              do
+              (progn
+                (gnus-message 7 "%s traced %s to %s" log-agent reference 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)))
 
-     ;; else: there were no matches, try the extra tracking by sender
-     ((and (memq 'sender gnus-registry-track-extra)
-           sender
-           (gnus-grep-in-list
-            sender
-            gnus-registry-unfollowed-addresses))
-      (let ((groups (apply
-                     'append
-                     (mapcar
-                      (lambda (reference)
-                        (gnus-registry-get-id-key reference 'group))
-                      (registry-lookup-secondary-value db 'sender sender)))))
-        (setq found
-              (loop for group in groups
-                    when (gnus-registry-follow-group-p group)
-                  do (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 groups %s"
-                      log-agent sender found)
-                  collect group)))
-
-      ;; filter the found groups and return them
-      ;; the found groups are NOT the full groups
-      (setq found (gnus-registry-post-process-groups
-                   "sender" sender found)))
-
      ;; else: there were no matches, now try the extra tracking by subject
-     ((and (memq 'subject gnus-registry-track-extra)
-           subject
-           (< gnus-registry-minimum-subject-length (length subject)))
-      (let ((groups (apply
-                     'append
-                     (mapcar
-                      (lambda (reference)
-                        (gnus-registry-get-id-key reference 'group))
-                      (registry-lookup-secondary-value db 'subject subject)))))
-        (setq found
-              (loop for group in groups
-                    when (gnus-registry-follow-group-p group)
-                    do (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 groups %s"
-                        log-agent subject found)
-                    collect group))
-      ;; 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)))))
-    ;; after the (cond) we extract the actual value safely
-    (car-safe found)))
+     (when (and (null found)
+                (memq 'subject gnus-registry-track-extra)
+                subject
+                (< gnus-registry-minimum-subject-length (length subject)))
+       (let ((groups (apply
+                      'append
+                      (mapcar
+                       (lambda (reference)
+                         (gnus-registry-get-id-key reference 'group))
+                       (registry-lookup-secondary-value db 'subject subject)))))
+         (setq found
+               (loop for group in groups
+                     when (gnus-registry-follow-group-p group)
+                     do (gnus-message
+                         ;; warn more if gnus-registry-track-extra
+                         (if gnus-registry-track-extra 7 9)
+                         "%s (extra tracking) traced subject '%s' to %s"
+                         log-agent subject group)
+                    and collect group))
+         ;; 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))))
+
+     ;; else: there were no matches, try the extra tracking by sender
+     (when (and (null found)
+                (memq 'sender gnus-registry-track-extra)
+                sender
+                (not (gnus-grep-in-list
+                      sender
+                      gnus-registry-unfollowed-addresses)))
+       (let ((groups (apply
+                      'append
+                      (mapcar
+                       (lambda (reference)
+                         (gnus-registry-get-id-key reference 'group))
+                       (registry-lookup-secondary-value db 'sender sender)))))
+         (setq found
+               (loop for group in groups
+                     when (gnus-registry-follow-group-p group)
+                     do (gnus-message
+                         ;; warn more if gnus-registry-track-extra
+                         (if gnus-registry-track-extra 7 9)
+                         "%s (extra tracking) traced sender '%s' to %s"
+                         log-agent sender group)
+                     and collect group)))
+
+       ;; filter the found groups and return them
+       ;; the found groups are NOT the full groups
+       (setq found (gnus-registry-post-process-groups
+                    "sender" sender found)))
+
+     ;; else: there were no matches, try the extra tracking by recipient
+     (when (and (null found)
+                (memq 'recipient gnus-registry-track-extra)
+                recipients)
+       (dolist (recp recipients)
+         (when (and (null found)
+                    (not (gnus-grep-in-list
+                          recp
+                          gnus-registry-unfollowed-addresses)))
+           (let ((groups (apply 'append
+                                (mapcar
+                                 (lambda (reference)
+                                   (gnus-registry-get-id-key reference 'group))
+                                 (registry-lookup-secondary-value
+                                  db 'recipient recp)))))
+             (setq found
+                   (loop for group in groups
+                         when (gnus-registry-follow-group-p group)
+                         do (gnus-message
+                             ;; warn more if gnus-registry-track-extra
+                             (if gnus-registry-track-extra 7 9)
+                             "%s (extra tracking) traced recipient '%s' to %s"
+                             log-agent recp group)
+                        and collect group)))))
+
+       ;; filter the found groups and return them
+       ;; the found groups are NOT the full groups
+       (setq found (gnus-registry-post-process-groups
+                    "recipients" (mapconcat 'identity recipients ", ") found)))
+
+     ;; after the (cond) we extract the actual value safely
+     (car-safe found)))
 
 (defun gnus-registry-post-process-groups (mode key groups)
   "Inspects GROUPS found by MODE for KEY to determine which ones to follow.
@@ -489,25 +589,48 @@ Foreign methods are not supported so they are rejected.
 Reduces the list to a single group, or complains if that's not
 possible.  Uses `gnus-registry-split-strategy'."
   (let ((log-agent "gnus-registry-post-process-group")
-        out)
-
-    ;; the strategy can be nil, in which case groups is nil
-    (setq groups
+        (desc (format "%d groups" (length groups)))
+        out chosen)
+    ;; the strategy can be nil, in which case chosen is nil
+    (setq chosen
           (case gnus-registry-split-strategy
-            ;; first strategy
+            ;; default, take only one-element lists into chosen
+            ((nil)
+             (and (= (length groups) 1)
+                  (car-safe groups)))
+
             ((first)
-             (and groups (list (car-safe groups))))
+             (car-safe groups))
 
             ((majority)
              (let ((freq (make-hash-table
                           :size 256
                           :test 'equal)))
-               (mapc (lambda (x) (puthash x (1+ (gethash x freq 0)) freq))
+               (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
+                              (puthash x (1+ (gethash x freq 0)) freq)))
                      groups)
-               (list (car-safe
-                      (sort groups (lambda (a b)
-                                     (> (gethash a freq 0)
-                                        (gethash b freq 0))))))))))
+               (setq desc (format "%d groups, %d unique"
+                                  (length groups)
+                                  (hash-table-count freq)))
+               (car-safe
+                (sort groups
+                      (lambda (a b)
+                        (> (gethash (gnus-group-short-name a) freq 0)
+                           (gethash (gnus-group-short-name b) freq 0)))))))))
+
+    (if chosen
+        (gnus-message
+         9
+         "%s: strategy %s on %s produced %s"
+         log-agent gnus-registry-split-strategy desc chosen)
+      (gnus-message
+       9
+       "%s: strategy %s on %s did not produce an answer"
+       log-agent
+       (or gnus-registry-split-strategy "default")
+       desc))
+
+    (setq groups (and chosen (list chosen)))
 
     (dolist (group groups)
       (let ((m1 (gnus-find-method-for-group group))
@@ -517,29 +640,31 @@ possible.  Uses `gnus-registry-split-strategy'."
         (if (gnus-methods-equal-p m1 m2)
             (progn
               ;; this is REALLY just for debugging
-              (gnus-message
-               10
-               "%s stripped group %s to %s"
-               log-agent group short-name)
+              (when (not (equal group short-name))
+                (gnus-message
+                 10
+                 "%s: stripped group %s to %s"
+                 log-agent group short-name))
               (add-to-list 'out short-name))
           ;; else...
           (gnus-message
            7
-           "%s ignored foreign group %s"
+           "%s: ignored foreign group %s"
            log-agent group))))
 
-    ;; is there just one group?
+    (setq out (delq nil out))
+
     (cond
      ((= (length out) 1) out)
      ((null out)
       (gnus-message
        5
-       "%s: no matches for %s %s."
-       log-agent out mode key)
+       "%s: no matches for %s '%s'."
+       log-agent mode key)
       nil)
      (t (gnus-message
          5
-         "%s: too many extra matches (%s) for %s %s.  Returning none."
+         "%s: too many extra matches (%s) for %s '%s'.  Returning none."
          log-agent out mode key)
         nil))))
 
@@ -555,6 +680,34 @@ Consults `gnus-registry-unfollowed-groups' and
                  group
                  nnmail-split-fancy-with-parent-ignore-groups)))))
 
+;; note that gnus-registry-ignored-groups is defined in gnus.el as a
+;; group/topic parameter and an associated variable!
+
+;; we do special logic for ignoring to accept regular expressions and
+;; nnmail-split-fancy-with-parent-ignore-groups as well
+(defun gnus-registry-ignore-group-p (group)
+  "Determines if a group name should be ignored.
+Consults `gnus-registry-ignored-groups' and
+`nnmail-split-fancy-with-parent-ignore-groups'."
+  (and group
+       (or (gnus-grep-in-list
+            group
+            (delq nil (mapcar (lambda (g)
+                                (cond
+                                 ((stringp g) g)
+                                 ((and (listp g) (nth 1 g))
+                                  (nth 0 g))
+                                 (t nil))) gnus-registry-ignored-groups)))
+           ;; only use `gnus-parameter-registry-ignore' if
+           ;; `gnus-registry-ignored-groups' is a list of lists
+           ;; (it can be a list of regexes)
+           (and (listp (nth 0 gnus-registry-ignored-groups))
+                (get-buffer "*Group*")  ; in automatic tests this is false
+                (gnus-parameter-registry-ignore group))
+           (gnus-grep-in-list
+            group
+            nnmail-split-fancy-with-parent-ignore-groups))))
+
 (defun gnus-registry-wash-for-keywords (&optional force)
   "Get the keywords of the current article.
 Overrides existing keywords with FORCE set non-nil."
@@ -597,7 +750,8 @@ Overrides existing keywords with FORCE set non-nil."
                         article gnus-newsgroup-name)
           (gnus-registry-handle-action id nil gnus-newsgroup-name
            (gnus-registry-fetch-simplified-message-subject-fast article)
-           (gnus-registry-fetch-sender-fast article)))))))
+           (gnus-registry-fetch-sender-fast article)
+           (gnus-registry-fetch-recipients-fast article)))))))
 
 ;; message field fetchers
 (defun gnus-registry-fetch-message-id-fast (article)
@@ -607,6 +761,26 @@ Overrides existing keywords with FORCE set non-nil."
       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
     nil))
 
+(defun gnus-registry-extract-addresses (text)
+  "Extract all the addresses in a normalized way from TEXT.
+Returns an unsorted list of strings in the name <address> format.
+Addresses without a name will say \"noname\"."
+  (mapcar (lambda (add)
+            (gnus-string-remove-all-properties
+             (let* ((name (or (nth 0 add) "noname"))
+                    (addr (nth 1 add))
+                    (addr (if (bufferp addr)
+                              (with-current-buffer addr
+                                (buffer-string))
+                            addr)))
+               (format "%s <%s>" name addr))))
+          (mail-extract-address-components text t)))
+
+(defun gnus-registry-sort-addresses (&rest addresses)
+  "Return a normalized and sorted list of ADDRESSES."
+  (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
+        'string-lessp))
+
 (defun gnus-registry-simplify-subject (subject)
   (if (stringp subject)
       (gnus-simplify-subject subject)
@@ -623,12 +797,20 @@ Overrides existing keywords with FORCE set non-nil."
     nil))
 
 (defun gnus-registry-fetch-sender-fast (article)
-  "Fetch the Sender quickly, using the internal gnus-data-list function"
+  (gnus-registry-fetch-header-fast "from" article))
+
+(defun gnus-registry-fetch-recipients-fast (article)
+  (gnus-registry-sort-addresses
+   (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
+   (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
+
+(defun gnus-registry-fetch-header-fast (article header)
+  "Fetch the HEADER 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)))))
+       (cdr (assq header (gnus-data-header
+                          (assoc article (gnus-data-list nil))))))
     nil))
 
 ;; registry marks glue
@@ -689,8 +871,9 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
 
                  ;; if this is called and the user doesn't want the
                  ;; registry enabled, we'll ask anyhow
-                 (when (eq gnus-registry-install nil)
-                   (setq gnus-registry-install 'ask))
+                 (unless gnus-registry-install
+                   (let ((gnus-registry-install 'ask))
+                     (gnus-registry-install-p)))
 
                  ;; now the user is asked if gnus-registry-install is 'ask
                  (when (gnus-registry-install-p)
@@ -727,22 +910,32 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
                  nil
                  (cons "Registry Marks" gnus-registry-misc-menus))))))
 
-;;; use like this:
-;;; (defalias 'gnus-user-format-function-M
-;;;           'gnus-registry-user-format-function-M)
-(defun gnus-registry-user-format-function-M (headers)
+(make-obsolete 'gnus-registry-user-format-function-M
+               'gnus-registry-article-marks-to-chars "24.1") ?
+
+(defalias 'gnus-registry-user-format-function-M
+  'gnus-registry-article-marks-to-chars)
+
+;; use like this:
+;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
+(defun gnus-registry-article-marks-to-chars (headers)
+  "Show the marks for an article by the :char property"
+  (let* ((id (mail-header-message-id headers))
+         (marks (when id (gnus-registry-get-id-key id 'mark))))
+    (mapconcat (lambda (mark)
+                 (plist-get
+                  (cdr-safe
+                   (assoc mark gnus-registry-marks))
+                  :char))
+               marks "")))
+
+;; use like this:
+;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
+(defun gnus-registry-article-marks-to-names (headers)
+  "Show the marks for an article by name"
   (let* ((id (mail-header-message-id headers))
          (marks (when id (gnus-registry-get-id-key id 'mark))))
-    (apply 'concat (mapcar (lambda (mark)
-                             (let ((c
-                                    (plist-get
-                                     (cdr-safe
-                                      (assoc mark gnus-registry-marks))
-                                     :char)))
-                               (if c
-                                   (list c)
-                                 nil)))
-                           marks))))
+    (mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
 
 (defun gnus-registry-read-mark ()
   "Read a mark name from the user with completion."
@@ -804,8 +997,8 @@ only the last one's marks are returned."
          (entries (registry-lookup db (list id))))
 
     (when (null entries)
-      (registry-insert db id (list (list 'creation-time (current-time))
-                                   '(group) '(sender) '(subject)))
+      (gnus-registry-insert db id (list (list 'creation-time (current-time))
+                                        '(group) '(sender) '(subject)))
       (setq entries (registry-lookup db (list id))))
 
     (nth 1 (assoc id entries))))
@@ -821,9 +1014,17 @@ only the last one's marks are returned."
          (entry (gnus-registry-get-or-make-entry id)))
     (registry-delete db (list id) nil)
     (setq entry (cons (cons key vals) (assq-delete-all key entry)))
-    (registry-insert db id entry)
+    (gnus-registry-insert db id entry)
     entry))
 
+(defun gnus-registry-insert (db id entry)
+  "Just like `registry-insert' but tries to prune on error."
+  (when (registry-full db)
+    (message "Trying to prune the registry because it's full")
+    (registry-prune db))
+  (registry-insert db id entry)
+  entry)
+
 (defun gnus-registry-import-eld (file)
   (interactive "fOld registry file to import? ")
   ;; example content:
@@ -856,7 +1057,8 @@ only the last one's marks are returned."
                              collect p))
                extra-cell key val)
           ;; remove all the strings from the entry
-          (delete* nil rest :test (lambda (a b) (stringp b)))
+          (dolist (elem rest)
+            (if (stringp elem) (setq rest (delq elem rest))))
           (gnus-registry-set-id-key id 'group groups)
           ;; just use the first extra element
           (setq rest (car-safe rest))
@@ -870,72 +1072,11 @@ only the last one's marks are returned."
             (gnus-registry-set-id-key id key val))))
       (message "Import done, collected %d entries" count))))
 
-(ert-deftest gnus-registry-usage-test ()
-  (let* ((n 100)
-         (tempfile (make-temp-file "gnus-registry-persist"))
-         (db (gnus-registry-make-db tempfile))
-         (gnus-registry-db db)
-         back size)
-    (message "Adding %d keys to the test Gnus registry" n)
-    (dotimes (i n)
-      (let ((id (number-to-string i)))
-        (gnus-registry-handle-action id
-                                     (if (>= 50 i) "fromgroup" nil)
-                                     "togroup"
-                                     (when (>= 70 i)
-                                       (format "subject %d" (mod i 10)))
-                                     (when (>= 80 i)
-                                       (format "sender %d" (mod i 10))))))
-    (message "Testing Gnus registry size is %d" n)
-    (should (= n (registry-size db)))
-    (message "Looking up individual keys (registry-lookup)")
-    (should (equal (loop for e
-                         in (mapcar 'cadr
-                                    (registry-lookup db '("20" "83" "72")))
-                         collect (assq 'subject e)
-                         collect (assq 'sender e)
-                         collect (assq 'group e))
-                   '((subject "subject 0") (sender "sender 0") (group "togroup")
-                     (subject) (sender) (group "togroup")
-                     (subject) (sender "sender 2") (group "togroup"))))
-
-    (message "Looking up individual keys (gnus-registry-id-key)")
-    (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup")))
-    (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4")))
-    (message "Trying to insert a duplicate key")
-    (should-error (registry-insert db "55" '()))
-    (message "Looking up individual keys (gnus-registry-get-or-make-entry)")
-    (should (gnus-registry-get-or-make-entry "22"))
-    (message "Saving the Gnus registry to %s" tempfile)
-    (should (gnus-registry-save tempfile db))
-    (setq size (nth 7 (file-attributes tempfile)))
-    (message "Saving the Gnus registry to %s: size %d" tempfile size)
-    (should (< 0 size))
-    (with-temp-buffer
-      (insert-file-contents-literally tempfile)
-      (should (looking-at (concat ";; Object "
-                                  "Gnus Registry"
-                                  "\n;; EIEIO PERSISTENT OBJECT"))))
-    (message "Reading Gnus registry back")
-    (setq back (eieio-persistent-read tempfile))
-    (should back)
-    (message "Read Gnus registry back: %d keys, expected %d==%d"
-             (registry-size back) n (registry-size db))
-    (should (= (registry-size back) n))
-    (should (= (registry-size back) (registry-size db)))
-    (delete-file tempfile)
-    (message "Pruning Gnus registry to 0 by setting :max-soft")
-    (oset db :max-soft 0)
-    (registry-prune db)
-    (should (= (registry-size db) 0)))
-  (message "Done with Gnus registry usage testing."))
-
 ;;;###autoload
 (defun gnus-registry-initialize ()
 "Initialize the Gnus registry."
   (interactive)
   (gnus-message 5 "Initializing the registry")
-  (setq gnus-registry-install t)        ; in case it was 'ask or nil
   (gnus-registry-install-hooks)
   (gnus-registry-install-shortcuts)
   (gnus-registry-read))
@@ -944,6 +1085,7 @@ only the last one's marks are returned."
 (defun gnus-registry-install-hooks ()
   "Install the registry hooks."
   (interactive)
+  (setq gnus-registry-enabled t)
   (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)
@@ -965,23 +1107,25 @@ only the last one's marks are returned."
   (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))
+  (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
+  (setq gnus-registry-enabled nil))
 
 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
 
 (defun gnus-registry-install-p ()
+  "If the registry is not already enabled, and `gnus-registry-install' is t,
+the registry is enabled.  If `gnus-registry-install' is `ask',
+the user is asked first.  Returns non-nil iff the registry is enabled."
   (interactive)
-  (when (eq gnus-registry-install 'ask)
-    (setq gnus-registry-install
-          (gnus-y-or-n-p
-           (concat "Enable the Gnus registry?  "
-                   "See the variable `gnus-registry-install' "
-                   "to get rid of this query permanently. ")))
-    (when gnus-registry-install
-      ;; we just set gnus-registry-install to t, so initialize the registry!
+  (unless gnus-registry-enabled
+    (when (if (eq gnus-registry-install 'ask)
+              (gnus-y-or-n-p
+               (concat "Enable the Gnus registry?  "
+                       "See the variable `gnus-registry-install' "
+                       "to get rid of this query permanently. "))
+            gnus-registry-install)
       (gnus-registry-initialize)))
-;;; we could call it here: (customize-variable 'gnus-registry-install)
-  gnus-registry-install)
+  gnus-registry-enabled)
 
 ;; TODO: a few things