X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=4221af663d5b2bdb911c5d0fe3e0173c5f47efa1;hp=8847dacd77c92b5c94ca9d42166fe6d7a7033590;hb=bbe68edb313e02acb4557e5cc4ff2f87a41ca66c;hpb=672f5b7e94dafa543a9424059b16b1a7f310dccf diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 8847dacd7..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 ;; 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,12 +78,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile - (when (null (ignore-errors (require 'ert))) - (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) - -(ignore-errors - (require 'ert)) (require 'gnus) (require 'gnus-int) (require 'gnus-sum) @@ -118,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)) @@ -141,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 @@ -151,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 @@ -217,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) @@ -258,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 () @@ -291,11 +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 (mail-header-subject data-header)) - (sender (mail-header-from 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"))) @@ -306,10 +353,14 @@ 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 + (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)) @@ -317,13 +368,16 @@ 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) + ;; 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)) (subject (gnus-string-remove-all-properties @@ -339,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. @@ -380,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")))) @@ -392,12 +453,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 @@ -417,65 +479,98 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (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 (gnus-message 7 "%s traced %s to %s" log-agent reference group) - do (push group found))) + 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 + ;; else: there were no matches, now try the extra tracking by subject (when (and (null found) - (memq 'sender gnus-registry-track-extra) - sender - (gnus-grep-in-list - sender - gnus-registry-unfollowed-addresses)) + (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 'sender sender))))) + (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 sender '%s' to %s" - log-agent sender 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 - "sender" sender found))) + "%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, now try the extra tracking by subject + ;; else: there were no matches, try the extra tracking by sender (when (and (null found) - (memq 'subject gnus-registry-track-extra) - subject - (< gnus-registry-minimum-subject-length (length subject))) + (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 'subject subject))))) + (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 subject '%s' to %s" - log-agent subject 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 - "subject" subject found)))) + "%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))) @@ -564,12 +659,12 @@ possible. Uses `gnus-registry-split-strategy'." ((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)))) @@ -585,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." @@ -627,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) @@ -637,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
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) @@ -653,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 @@ -719,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) @@ -757,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)))) - (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) + (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)))) + (mapconcat (lambda (mark) (symbol-name mark)) marks ","))) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." @@ -834,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)))) @@ -851,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: @@ -886,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)) @@ -900,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)) @@ -974,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) @@ -995,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