;;; gnus-registry.el --- article registry for Gnus
-;; Copyright (C) 2002-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2015 Free Software Foundation, Inc.
;; Author: Ted Zlatanov <tzz@lifelogs.com>
;; Keywords: news registry
;; 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
(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)
(require 'easymenu)
(require 'registry)
+;; Silence XEmacs byte compiler, which will otherwise complain about
+;; call to `eieio-persistent-read'.
+(when (featurep 'xemacs)
+ (byte-compiler-options
+ (warnings (- callargs))))
+
(defvar gnus-adaptive-word-syntax-table)
(defvar gnus-registry-dirty t
- "Boolean set to t when the registry is modified")
+ "Boolean set to t when the registry is modified.")
(defgroup gnus-registry nil
"The Gnus registry."
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))
(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
(make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
(make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
(make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
+;; FIXME it was simply deleted.
+(make-obsolete-variable 'gnus-registry-max-pruned-entries nil "25.1")
(defcustom gnus-registry-track-extra '(subject sender recipient)
"Whether the registry should track extra data about a message.
(defcustom gnus-registry-cache-file
(nnheader-concat
(or gnus-dribble-directory gnus-home-directory "~/")
- ".gnus.registry.eioio")
+ ".gnus.registry.eieio")
"File where the Gnus registry will be stored."
:group 'gnus-registry
:type 'file)
:type '(radio (const :format "Unlimited " nil)
(integer :format "Maximum number: %v")))
-(defcustom gnus-registry-max-pruned-entries nil
- "Maximum number of pruned entries in the registry, nil for unlimited."
+(defcustom gnus-registry-prune-factor 0.1
+ "When pruning, try to prune back to this factor less than the maximum size.
+
+In order to prevent constant pruning, we prune back to a number
+somewhat less than the maximum size. This option controls
+exactly how much less. For example, given a maximum size of
+50000 and a prune factor of 0.1, the pruning process will try to
+cut the registry back to \(- 50000 \(* 50000 0.1\)\) -> 45000
+entries. The pruning process is constrained by the presence of
+\"precious\" entries."
+ :version "25.1"
:group 'gnus-registry
- :type '(radio (const :format "Unlimited " nil)
- (integer :format "Maximum number: %v")))
+ :type 'float)
+
+(defcustom gnus-registry-default-sort-function
+ #'gnus-registry-sort-by-creation-time
+ "Sort function to use when pruning the registry.
+Entries that sort to the front of the list are pruned first.
+This can slow pruning down. Set to nil to perform no sorting."
+ :version "25.1"
+ :group 'gnus-registry
+ :type '(choice (const :tag "No sorting" nil) function))
+
+(defun gnus-registry-sort-by-creation-time (l r)
+ "Sort older entries to front of list."
+ ;; Pruning starts from the front of the list.
+ (time-less-p
+ (cadr (assq 'creation-time r))
+ (cadr (assq 'creation-time l))))
(defun gnus-registry-fixup-registry (db)
(when db
- (let ((old (oref db :tracked)))
- (oset db :precious
+ (let ((old (oref db tracked)))
+ (setf (oref db precious)
(append gnus-registry-extra-entries-precious
'()))
- (oset db :max-hard
+ (setf (oref db max-size)
(or gnus-registry-max-entries
most-positive-fixnum))
- (oset db :max-soft
- (or gnus-registry-max-pruned-entries
- most-positive-fixnum))
- (oset db :tracked
+ (setf (oref db prune-factor)
+ (or gnus-registry-prune-factor
+ 0.1))
+ (setf (oref 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)")
+ (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)
(interactive "fGnus registry persistence file: \n")
(gnus-registry-fixup-registry
- (registry-db
- "Gnus Registry"
- :file (or file gnus-registry-cache-file)
- ;; these parameters are set in `gnus-registry-fixup-registry'
- :max-hard most-positive-fixnum
- :max-soft most-positive-fixnum
- :precious nil
- :tracked nil)))
+ (make-instance 'registry-db
+ :file (or file gnus-registry-cache-file)
+ ;; these parameters are set in `gnus-registry-fixup-registry'
+ :max-size most-positive-fixnum
+ :version registry-db-version
+ :precious nil
+ :tracked nil)))
(defvar gnus-registry-db (gnus-registry-make-db)
- "*The article registry by Message ID. See `registry-db'")
+ "The article registry by Message ID. See `registry-db'.")
;; top-level registry data management
(defun gnus-registry-remake-db (&optional forsure)
(gnus-message 4 "Remaking the Gnus registry")
(setq gnus-registry-db (gnus-registry-make-db))))
-(defun gnus-registry-read ()
- "Read the registry cache file."
+(defun gnus-registry-load ()
+ "Load the registry from the cache file."
(interactive)
(let ((file gnus-registry-cache-file))
(condition-case nil
- (progn
- (gnus-message 5 "Reading Gnus registry from %s..." file)
- (setq gnus-registry-db (gnus-registry-fixup-registry
- (eieio-persistent-read file)))
- (gnus-message 5 "Reading Gnus registry from %s...done" file))
+ (gnus-registry-read file)
+ (file-error
+ ;; Fix previous mis-naming of the registry file.
+ (let ((old-file-name
+ (concat (file-name-sans-extension
+ gnus-registry-cache-file)
+ ".eioio")))
+ (if (and (file-exists-p old-file-name)
+ (yes-or-no-p
+ (format "Rename registry file from %s to %s? "
+ old-file-name file)))
+ (progn
+ (gnus-registry-read old-file-name)
+ (setf (oref gnus-registry-db :file) file)
+ (gnus-message 1 "Registry filename changed to %s" file))
+ (gnus-registry-remake-db t))))
(error
(gnus-message
1
file)
(gnus-registry-remake-db t)))))
+(defun gnus-registry-read (file)
+ "Do the actual reading of the registry persistence file."
+ (gnus-message 5 "Reading Gnus registry from %s..." file)
+ (setq gnus-registry-db
+ (gnus-registry-fixup-registry
+ (condition-case nil
+ (with-no-warnings
+ (eieio-persistent-read file 'registry-db))
+ ;; Older EIEIO versions do not check the class name.
+ ('wrong-number-of-arguments
+ (eieio-persistent-read file)))))
+ (gnus-message 5 "Reading Gnus registry from %s...done" file))
+
(defun gnus-registry-save (&optional file db)
"Save the registry cache file."
(interactive)
(db (or db gnus-registry-db)))
(gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
(registry-size db) file)
- (registry-prune db)
+ (registry-prune
+ db gnus-registry-default-sort-function)
;; TODO: call (gnus-string-remove-all-properties v) on all elements?
(eieio-persistent-save db 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))
(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")))
+ (to (if to (gnus-group-guess-full-name-from-command-method to) nil)))
(gnus-message 7 "Gnus registry: article %s %s from %s to %s"
id (if method "respooling" "going") from to)
(let ((new (or (assq (first kv) entry)
(list (first kv)))))
(dolist (toadd (cdr kv))
- (add-to-list 'new toadd t))
+ (unless (member toadd new)
+ (setq new (append new (list toadd)))))
(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.
(defun gnus-registry-split-fancy-with-parent ()
- "Split this message into the same group as its parent. The parent
-is obtained from the registry. This function can be used as an entry
-in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
+ "Split this message into the same group as its parent.
+The parent is obtained from the registry. This function can be used as an
+entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
this: (: gnus-registry-split-fancy-with-parent)
This function tracks ALL backends, unlike
10
"%s: stripped group %s to %s"
log-agent group short-name))
- (add-to-list 'out short-name))
+ (pushnew short-name out :test #'equal))
;; else...
(gnus-message
7
Consults `gnus-registry-ignored-groups' and
`nnmail-split-fancy-with-parent-ignore-groups'."
(and group
- (or (gnus-parameter-registry-ignore group)
- (gnus-grep-in-list
+ (or (gnus-grep-in-list
group
(delq nil (mapcar (lambda (g)
(cond
((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))))
(gnus-registry-set-id-key id 'keyword words)))))
(defun gnus-registry-keywords ()
- (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)))
- (when table (maphash (lambda (k v) k) table))))
+ (let ((table (registry-lookup-secondary gnus-registry-db 'keyword))
+ (ks ()))
+ (when table (maphash (lambda (k _v) (push k ks)) table) ks)))
(defun gnus-registry-find-keywords (keyword)
(interactive (list
(registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
(defun gnus-registry-register-message-ids ()
- "Register the Message-ID of every article in the group"
+ "Register the Message-ID of every article in the group."
(unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
(dolist (article gnus-newsgroup-articles)
(let* ((id (gnus-registry-fetch-message-id-fast article))
;; message field fetchers
(defun gnus-registry-fetch-message-id-fast (article)
- "Fetch the Message-ID quickly, using the internal gnus-data-list function"
+ "Fetch the Message-ID quickly, using the internal gnus-data-list function."
(if (and (numberp article)
(assoc article (gnus-data-list nil)))
(mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
nil))
(defun gnus-registry-fetch-simplified-message-subject-fast (article)
- "Fetch the Subject quickly, using the internal gnus-data-list function"
+ "Fetch the Subject quickly, using the internal gnus-data-list function."
(if (and (numberp article)
(assoc article (gnus-data-list nil)))
(gnus-string-remove-all-properties
(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"
+ "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
(when cell-data
(funcall function mark cell-data)))))
-;;; this is ugly code, but I don't know how to do it better
+;; FIXME: Why not merge gnus-registry--set/remove-mark and
+;; gnus-registry-set-article-mark-internal?
+(defun gnus-registry--set/remove-mark (remove mark articles)
+ "Set/remove the MARK over process-marked ARTICLES."
+ ;; If this is called and the user doesn't want the
+ ;; registry enabled, we'll ask anyhow.
+ (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)
+ (gnus-registry-set-article-mark-internal
+ ;; All this just to get the mark, I must be doing it wrong.
+ mark articles remove t)
+ ;; FIXME: Why do we do the above only here and not directly inside
+ ;; gnus-registry-set-article-mark-internal? I.e. we wouldn't we want to do
+ ;; the things below when gnus-registry-set-article-mark-internal is called
+ ;; from gnus-registry-set-article-mark or
+ ;; gnus-registry-remove-article-mark?
+ (gnus-message 9 "Applying mark %s to %d articles"
+ mark (length articles))
+ (dolist (article articles)
+ (gnus-summary-update-article
+ article
+ (assoc article (gnus-data-list nil))))))
+
+;; This is ugly code, but I don't know how to do it better.
(defun gnus-registry-install-shortcuts ()
"Install the keyboard shortcuts and menus for the registry.
Uses `gnus-registry-marks' to find what shortcuts to install."
(let ((function-format
(format "gnus-registry-%%s-article-%s-mark" mark)))
-;;; The following generates these functions:
-;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
-;;; "Apply the Important mark to process-marked ARTICLES."
-;;; (interactive (gnus-summary-work-articles current-prefix-arg))
-;;; (gnus-registry-set-article-mark-internal 'Important articles nil t))
-;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
-;;; "Apply the Important mark to process-marked ARTICLES."
-;;; (interactive (gnus-summary-work-articles current-prefix-arg))
-;;; (gnus-registry-set-article-mark-internal 'Important articles t t))
+;;; The following generates these functions:
+;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
+;;; "Apply the Important mark to process-marked ARTICLES."
+;;; (interactive (gnus-summary-work-articles current-prefix-arg))
+;;; (gnus-registry-set-article-mark-internal 'Important articles nil t))
+;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
+;;; "Apply the Important mark to process-marked ARTICLES."
+;;; (interactive (gnus-summary-work-articles current-prefix-arg))
+;;; (gnus-registry-set-article-mark-internal 'Important articles t t))
(dolist (remove '(t nil))
(let* ((variant-name (if remove "remove" "set"))
- (function-name (format function-format variant-name))
- (shortcut (format "%c" data))
- (shortcut (if remove (upcase shortcut) shortcut)))
- (unintern function-name obarray)
- (eval
- `(defun
- ;; function name
- ,(intern function-name)
- ;; parameter definition
- (&rest articles)
- ;; documentation
- ,(format
- "%s the %s mark over process-marked ARTICLES."
- (upcase-initials variant-name)
- mark)
- ;; interactive definition
- (interactive
- (gnus-summary-work-articles current-prefix-arg))
- ;; actual code
-
- ;; 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))
-
- ;; now the user is asked if gnus-registry-install is 'ask
- (when (gnus-registry-install-p)
- (gnus-registry-set-article-mark-internal
- ;; all this just to get the mark, I must be doing it wrong
- (intern ,(symbol-name mark))
- articles ,remove t)
- (gnus-message
- 9
- "Applying mark %s to %d articles"
- ,(symbol-name mark) (length articles))
- (dolist (article articles)
- (gnus-summary-update-article
- article
- (assoc article (gnus-data-list nil)))))))
- (push (intern function-name) keys-plist)
+ (function-name
+ (intern (format function-format variant-name)))
+ (shortcut (format "%c" (if remove (upcase data) data))))
+ (defalias function-name
+ ;; If it weren't for the function's docstring, we could
+ ;; use a closure, with lexical-let :-(
+ `(lambda (&rest articles)
+ ,(format
+ "%s the %s mark over process-marked ARTICLES."
+ (upcase-initials variant-name)
+ mark)
+ (interactive
+ (gnus-summary-work-articles current-prefix-arg))
+ (gnus-registry--set/remove-mark ',mark ',remove articles)))
+ (push function-name keys-plist)
(push shortcut keys-plist)
(push (vector (format "%s %s"
(upcase-initials variant-name)
(symbol-name mark))
- (intern function-name) t)
+ function-name t)
gnus-registry-misc-menus)
- (gnus-message
- 9
- "Defined mark handling function %s"
- function-name))))))
+ (gnus-message 9 "Defined mark handling function %s"
+ function-name))))))
(gnus-define-keys-1
'(gnus-registry-mark-map "M" gnus-summary-mark-map)
keys-plist)
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."
(let* ((article (last articles))
(id (gnus-registry-fetch-message-id-fast article))
(marks (when id (gnus-registry-get-id-key id 'mark))))
- (when (interactive-p)
+ (when (gmm-called-interactively-p 'any)
(gnus-message 1 "Marks are %S" marks))
marks))
(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))))
(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 gnus-registry-default-sort-function))
+ (registry-insert db id entry)
+ entry)
+
(defun gnus-registry-import-eld (file)
(interactive "fOld registry file to import? ")
;; example content:
(setq entry (car-safe old)
old (cdr-safe old))
(let* ((id (car-safe entry))
- (new-entry (gnus-registry-get-or-make-entry id))
(rest (cdr-safe entry))
(groups (loop for p in rest
when (stringp p)
(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"))
- (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."
+ "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))
+ (gnus-registry-load))
+;; FIXME: Why autoload this function?
;;;###autoload
(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)
(add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
(add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
- (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
+ (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load)
(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
(remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
(remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
- (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
+ (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load)
- (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 ()
+ "Return non-nil if the registry is enabled (and maybe enable it first).
+If the registry is not already enabled, then if `gnus-registry-install'
+is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it."
(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)
+
+;; largely based on nnir-warp-to-article
+(defun gnus-try-warping-via-registry ()
+ "Try to warp via the registry.
+This will be done via the current article's source group based on
+data stored in the registry."
+ (interactive)
+ (when (gnus-summary-article-header)
+ (let* ((message-id (mail-header-id (gnus-summary-article-header)))
+ ;; Retrieve the message's group(s) from the registry
+ (groups (gnus-registry-get-id-key message-id 'group))
+ ;; If starting from an ephemeral group, this describes
+ ;; how to restore the window configuration
+ (quit-config
+ (gnus-ephemeral-group-p gnus-newsgroup-name))
+ (seen-groups (list (gnus-group-group-name))))
+
+ (catch 'found
+ (dolist (group (mapcar 'gnus-simplify-group-name groups))
+
+ ;; skip over any groups we really don't want to warp to.
+ (unless (or (member group seen-groups)
+ (gnus-ephemeral-group-p group) ;; any ephemeral group
+ (memq (car (gnus-find-method-for-group group))
+ ;; Specific methods; this list may need to expand.
+ '(nnir)))
+
+ ;; remember that we've seen this group already
+ (push group seen-groups)
+
+ ;; first exit from any ephemeral summary buffer.
+ (when quit-config
+ (gnus-summary-exit)
+ ;; and if the ephemeral summary buffer in turn came from
+ ;; another summary buffer we have to clean that summary
+ ;; up too.
+ (when (eq (cdr quit-config) 'summary)
+ (gnus-summary-exit))
+ ;; remember that we've already done this part
+ (setq quit-config nil))
+
+ ;; Try to activate the group. If that fails, just move
+ ;; along. We may have more groups to work with
+ (when
+ (ignore-errors
+ (gnus-select-group-with-message-id group message-id) t)
+ (throw 'found t))))))))
+
+(defun gnus-registry-remove-extra-data (extra)
+ "Remove tracked EXTRA data from the gnus registry.
+EXTRA is a list of symbols. Valid symbols are those contained in
+the docs of `gnus-registry-track-extra'. This command is useful
+when you stop tracking some extra data and now want to purge it
+from your existing entries."
+ (interactive (list (mapcar 'intern
+ (completing-read-multiple
+ "Extra data: "
+ '("subject" "sender" "recipient")))))
+ (when extra
+ (let ((db gnus-registry-db))
+ (registry-reindex db)
+ (loop for k being the hash-keys of (oref db data)
+ using (hash-value v)
+ do (let ((newv (delq nil (mapcar #'(lambda (entry)
+ (unless (member (car entry) extra)
+ entry))
+ v))))
+ (registry-delete db (list k) nil)
+ (gnus-registry-insert db k newv)))
+ (registry-reindex db))))
;; TODO: a few things
projects / gnus / blobdiff