[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] /srv/bzr/emacs/trunk r103930: registry.el (registry-reinde
From: |
Katsumi Yamaoka |
Subject: |
[Emacs-diffs] /srv/bzr/emacs/trunk r103930: registry.el (registry-reindex): New method to recreate the secondary registry indices. |
Date: |
Sat, 16 Apr 2011 06:56:17 +0000 |
User-agent: |
Bazaar (2.3.1) |
------------------------------------------------------------
revno: 103930
author: Teodor Zlatanov <address@hidden>
committer: Katsumi Yamaoka <address@hidden>
branch nick: trunk
timestamp: Sat 2011-04-16 06:56:17 +0000
message:
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'.
modified:
lisp/gnus/ChangeLog
lisp/gnus/gnus-registry.el
lisp/gnus/registry.el
=== modified file 'lisp/gnus/ChangeLog'
--- a/lisp/gnus/ChangeLog 2011-04-15 14:29:02 +0000
+++ b/lisp/gnus/ChangeLog 2011-04-16 06:56:17 +0000
@@ -1,3 +1,23 @@
+2011-04-16 Teodor Zlatanov <address@hidden>
+
+ * 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 <address@hidden>
* gnus-registry.el (gnus-registry--split-fancy-with-parent-internal):
=== modified file 'lisp/gnus/gnus-registry.el'
--- a/lisp/gnus/gnus-registry.el 2011-04-15 14:29:02 +0000
+++ b/lisp/gnus/gnus-registry.el 2011-04-16 06:56:17 +0000
@@ -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 @@
(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 @@
(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 @@
(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 @@
(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 @@
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 @@
(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 @@
(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 @@
;; 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 @@
: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 @@
(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 @@
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 @@
(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 @@
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 @@
(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 <address@hidden>"
+ "noname <address@hidden>"
+ "noname <address@hidden>"
+ "noname <address@hidden>")
+ (gnus-registry-extract-addresses
+ (concat "Ted Zlatanov <address@hidden>, "
+ "ed <address@hidden>, " ; "ed" is not a valid name
here
+ "address@hidden, "
+ "address@hidden")))))
+
(ert-deftest gnus-registry-usage-test ()
(let* ((n 100)
(tempfile (make-temp-file "gnus-registry-persist"))
=== modified file 'lisp/gnus/registry.el'
--- a/lisp/gnus/registry.el 2011-04-11 01:18:19 +0000
+++ b/lisp/gnus/registry.el 2011-04-16 06:56:17 +0000
@@ -281,6 +281,25 @@
(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 @@
(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"))))))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] /srv/bzr/emacs/trunk r103930: registry.el (registry-reindex): New method to recreate the secondary registry indices.,
Katsumi Yamaoka <=