From: Teodor Zlatanov Date: Sat, 16 Apr 2011 06:56:17 +0000 (+0000) Subject: registry.el (registry-reindex): New method to recreate the secondary registry indices. X-Git-Tag: emacs-pretest-24.0.90~104^2~275^2~272 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=cf8b0c278be93e9584cf91315b2f11fc88da37a9;p=emacs.git 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'. --- diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index be6f3737ae1..eac53d413cc 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,23 @@ +2011-04-16 Teodor Zlatanov + + * 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 * gnus-registry.el (gnus-registry--split-fancy-with-parent-internal): diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 77ed5a55aed..eab4403c34b 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/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
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 " + "noname " + "noname " + "noname ") + (gnus-registry-extract-addresses + (concat "Ted Zlatanov , " + "ed , " ; "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/gnus/registry.el b/lisp/gnus/registry.el index 23e75815979..3e638427897 100644 --- a/lisp/gnus/registry.el +++ b/lisp/gnus/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"))))))