Add recipient tracking to the Gnus registry. Reindex it on read if necessary.

* gnus-registry.el (gnus-registry-fixup-registry): Use it if the
tracked field changes.
(gnus-registry-unfollowed-addresses, gnus-registry-track-extra)
(gnus-registry-action, gnus-registry-spool-action)
(gnus-registry-handle-action)
(gnus-registry--split-fancy-with-parent-internal)
(gnus-registry-split-fancy-with-parent)
(gnus-registry-register-message-ids): Add recipient tracking on spool,
move, and delete actions, and for fancy splitting with parent.
(gnus-registry-extract-addresses)
(gnus-registry-fetch-recipients-fast)
(gnus-registry-fetch-header-fast): Convenience functions.
(gnus-registry-misc-test): ERT test of
`gnus-registry-extract-addresses'.

* registry.el (registry-reindex): New method to recreate the secondary
registry indices.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 6fb79af..b6fc312 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,23 @@
+2011-04-16  Teodor Zlatanov  <tzz@lifelogs.com>
+
+       * registry.el (registry-reindex): New method to recreate the secondary
+       registry indices.
+
+       * gnus-registry.el (gnus-registry-fixup-registry): Use it if the
+       tracked field changes.
+       (gnus-registry-unfollowed-addresses, gnus-registry-track-extra)
+       (gnus-registry-action, gnus-registry-spool-action)
+       (gnus-registry-handle-action)
+       (gnus-registry--split-fancy-with-parent-internal)
+       (gnus-registry-split-fancy-with-parent)
+       (gnus-registry-register-message-ids): Add recipient tracking on spool,
+       move, and delete actions, and for fancy splitting with parent.
+       (gnus-registry-extract-addresses)
+       (gnus-registry-fetch-recipients-fast)
+       (gnus-registry-fetch-header-fast): Convenience functions.
+       (gnus-registry-misc-test): ERT test of
+       `gnus-registry-extract-addresses'.
+
 2011-04-15  Teodor Zlatanov  <tzz@lifelogs.com>
 
        * gnus-registry.el (gnus-registry--split-fancy-with-parent-internal):

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index 77ed5a5..eab4403 100644 (file)
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -36,7 +36,7 @@
 ;; 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))
+;;       gnus-registry-track-extra '(sender subject recipient))
 
 ;; (gnus-registry-initialize)
 
@@ -119,7 +119,9 @@ 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."
   :group 'gnus-registry
   :type '(repeat regexp))
 
@@ -152,14 +154,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
@@ -224,18 +227,22 @@ the Bit Bucket."
 
 (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 :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 4 "Reindexing the Gnus registry (tracked change)")
+        (registry-reindex db))))
   db)
 
 (defun gnus-registry-make-db (&optional file)
@@ -296,7 +303,17 @@ This is not required after changing `gnus-registry-cache-file'."
 (defun gnus-registry-action (action data-header from &optional to method)
   (let* ((id (mail-header-id data-header))
          (subject (mail-header-subject data-header))
-         (sender (mail-header-from data-header))
+         (recipients (sort (mapcan 'gnus-registry-extract-addresses
+                                   (list
+                                    (or (ignore-errors
+                                          (mail-header "Cc" data-header))
+                                        "")
+                                    (or (ignore-errors
+                                          (mail-header "To" data-header))
+                                        "")))
+                           'string-lessp))
+         (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,10 +324,16 @@ 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)))
+     to subject sender recipients)))
 
-(defun gnus-registry-spool-action (id group &optional subject sender)
+(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
+                        (sort (mapcan 'gnus-registry-extract-addresses
+                                      (list
+                                       (or (message-fetch-field "cc") "")
+                                       (or (message-fetch-field "to") "")))
+                              'string-lessp)))
         (subject (or subject (message-fetch-field "subject")))
         (sender (or sender (message-fetch-field "from"))))
     (when (and (stringp id) (string-match "\r$" id))
@@ -318,12 +341,13 @@ This is not required after changing `gnus-registry-cache-file'."
     (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))
+   "gnus-registry-handle-action %S" (list id from to subject sender recipients))
   (let ((db gnus-registry-db)
         ;; safe if not found
         (entry (gnus-registry-get-or-make-entry id))
@@ -340,11 +364,15 @@ 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"
@@ -381,6 +409,11 @@ 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 (sort (mapcan 'gnus-registry-extract-addresses
+                                   (list
+                                    (or (message-fetch-field "cc") "")
+                                    (or (message-fetch-field "to") "")))
+                           'string-lessp))
          (subject (gnus-string-remove-all-properties
                    (gnus-registry-simplify-subject
                     (message-fetch-field "subject"))))
@@ -393,12 +426,13 @@ 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
@@ -478,6 +512,36 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
        (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)
+                         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)))
 
@@ -629,7 +693,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)
@@ -639,6 +704,21 @@ 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-simplify-subject (subject)
   (if (stringp subject)
       (gnus-simplify-subject subject)
@@ -655,12 +735,26 @@ 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)
+  (sort (mapcan 'gnus-registry-extract-addresses
+                (list
+                 (or (ignore-errors
+                       (gnus-registry-fetch-header-fast "Cc" article))
+                     "")
+                 (or (ignore-errors
+                       (gnus-registry-fetch-header-fast "To" article))
+                     "")))
+        'string-lessp))
+
+(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)))))
+       (mail-header header (gnus-data-header
+                            (assoc article (gnus-data-list nil)))))
     nil))
 
 ;; registry marks glue
@@ -902,6 +996,19 @@ 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-misc-test ()
+  (should-error (gnus-registry-extract-addresses '("" "")))
+
+  (should (equal '("Ted Zlatanov <tzz@lifelogs.com>"
+                   "noname <ed@you.me>"
+                   "noname <cyd@stupidchicken.com>"
+                   "noname <tzz@lifelogs.com>")
+                 (gnus-registry-extract-addresses
+                  (concat "Ted Zlatanov <tzz@lifelogs.com>, "
+                          "ed <ed@you.me>, " ; "ed" is not a valid name here
+                          "cyd@stupidchicken.com, "
+                          "tzz@lifelogs.com")))))
+
 (ert-deftest gnus-registry-usage-test ()
   (let* ((n 100)
          (tempfile (make-temp-file "gnus-registry-persist"))

diff --git a/lisp/registry.el b/lisp/registry.el
index 23e7581..3e63842 100644 (file)
--- a/lisp/registry.el
+++ b/lisp/registry.el
@@ -281,6 +281,25 @@ Errors out if the key exists already."
         (registry-lookup-secondary-value db tr val value-keys))))
   entry)
 
+(defmethod registry-reindex ((db registry-db))
+  "Rebuild the secondary indices of registry-db THIS."
+  (let ((count 0)
+        (expected (* (length (oref db :tracked)) (registry-size db))))
+    (dolist (tr (oref db :tracked))
+      (let (values)
+        (maphash
+         (lambda (key v)
+           (incf count)
+           (when (and (< 0 expected)
+                      (= 0 (mod count 1000)))
+             (message "reindexing: %d of %d (%.2f%%)"
+                      count expected (/ (* 1000 count) expected)))
+           (dolist (val (cdr-safe (assq tr v)))
+             (let* ((value-keys (registry-lookup-secondary-value db tr val)))
+               (push key value-keys)
+               (registry-lookup-secondary-value db tr val value-keys))))
+         (oref db :data))))))
+
 (defmethod registry-size ((db registry-db))
   "Returns the size of the registry-db object THIS.
 This is the key count of the :data slot."
@@ -360,10 +379,11 @@ Removes only entries without the :precious keys."
     (when (boundp 'lexical-binding)
       (message "Individual lookup (breaks before lexbind)")
       (should (= 58
-                (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99)))))
+                 (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99)))))
       (message "Grouped individual lookup (breaks before lexbind)")
       (should (= 3
-                (length (registry-lookup-breaks-before-lexbind db '(1 58 99))))))
+                 (length (registry-lookup-breaks-before-lexbind db
+                                                                '(1 58 99))))))
     (message "Search")
     (should (= n (length (registry-search db :all t))))
     (should (= n (length (registry-search db :member '((sender "me"))))))