;;; 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 <tzz@lifelogs.com>
;; Keywords: news registry
;; 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)
;; 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))
-(require 'ert)
(require 'gnus)
(require 'gnus-int)
(require 'gnus-sum)
(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))
(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-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
(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
+ (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)
(interactive "fGnus registry persistence file: \n")
(gnus-registry-fixup-registry
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 ()
file)
(gnus-registry-remake-db t)))))
-(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))))
- db)
-
(defun gnus-registry-save (&optional file db)
"Save the registry cache file."
(interactive)
(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 (gnus-string-remove-all-properties
- (gnus-registry-simplify-subject
- (mail-header-subject data-header))))
- (sender (gnus-string-remove-all-properties
- (mail-header-from data-header)))
+ (subject (mail-header-subject 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")))
id
;; unless copying, remove the old "from" group
(if (not (equal 'copy action)) from nil)
- to subject sender)))
-
-(defun gnus-registry-spool-action (id group &optional subject sender)
- (let ((to (gnus-group-guess-full-name-from-command-method group)))
+ to subject sender recipients)))
+
+(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))
(setq id (substring id 0 -1)))
(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 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)))
+ (entry (gnus-registry-get-or-make-entry id))
+ (subject (gnus-string-remove-all-properties
+ (gnus-registry-simplify-subject subject)))
+ (sender (gnus-string-remove-all-properties sender)))
;; this could be done by calling `gnus-registry-set-id-key'
;; several times but it's better to bunch the transactions
(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.
;; 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"))))
: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
- "gnus-registry--split-fancy-with-parent-internal: %S" spec)
+ "gnus-registry--split-fancy-with-parent-internal %S" spec)
(let ((db gnus-registry-db)
found)
- ;; this is a big if-else statement. it uses
+ ;; this is a big chain of statements. it uses
;; gnus-registry-post-process-groups to filter the results after
;; every step.
- (cond
- ;; the references string must be valid and parse to valid references
- (references
+ ;; the references string must be valid and parse to valid references
+ (when references
+ (gnus-message
+ 9
+ "%s is tracing references %s"
+ log-agent refstr)
(dolist (reference (nreverse references))
- (gnus-message
- 9
- "%s is looking for matches for reference %s from [%s]"
- log-agent reference refstr)
- (setq found
- (loop for group in (gnus-registry-get-id-key reference 'group)
- when (gnus-registry-follow-group-p group)
- do (gnus-message
- 7
- "%s traced the reference %s from [%s] to group %s"
- log-agent reference refstr group)
- collect group)))
+ (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
+ (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
- ((and (memq 'sender gnus-registry-track-extra)
- sender
- (gnus-grep-in-list
- sender
- gnus-registry-unfollowed-addresses))
- (setq found
- (loop for group
- in (registry-lookup-secondary-value db 'sender sender)
-
- when (gnus-registry-follow-group-p group)
-
- do (gnus-message
- ;; raise level of messaging if gnus-registry-track-extra
- (if gnus-registry-track-extra 7 9)
- "%s (extra tracking) traced sender '%s' to groups %s"
- log-agent sender found)
- 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, now try the extra tracking by subject
- ((and (memq 'subject gnus-registry-track-extra)
- subject
- (< gnus-registry-minimum-subject-length (length subject)))
- (setq found
- (loop for group
- in (registry-lookup-secondary-value db 'subject subject)
-
- when (gnus-registry-follow-group-p group)
-
- do (gnus-message
- ;; raise level of messaging if gnus-registry-track-extra
- (if gnus-registry-track-extra 7 9)
- "%s (extra tracking) traced subject '%s' to groups %s"
- log-agent subject found)
- 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))))
- ;; after the (cond) we extract the actual value safely
- (car-safe found)))
+ (when (and (null found)
+ (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 '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 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, try the extra tracking by sender
+ (when (and (null found)
+ (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 '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 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)))
(defun gnus-registry-post-process-groups (mode key groups)
"Inspects GROUPS found by MODE for KEY to determine which ones to follow.
Reduces the list to a single group, or complains if that's not
possible. Uses `gnus-registry-split-strategy'."
(let ((log-agent "gnus-registry-post-process-group")
- out)
-
- ;; the strategy can be nil, in which case groups is nil
- (setq groups
+ (desc (format "%d groups" (length groups)))
+ out chosen)
+ ;; the strategy can be nil, in which case chosen is nil
+ (setq chosen
(case gnus-registry-split-strategy
- ;; first strategy
+ ;; default, take only one-element lists into chosen
+ ((nil)
+ (and (= (length groups) 1)
+ (car-safe groups)))
+
((first)
- (and groups (list (car-safe groups))))
+ (car-safe groups))
((majority)
(let ((freq (make-hash-table
:size 256
:test 'equal)))
- (mapc (lambda (x) (puthash x (1+ (gethash x freq 0)) freq))
+ (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
+ (puthash x (1+ (gethash x freq 0)) freq)))
groups)
- (list (car-safe
- (sort groups (lambda (a b)
- (> (gethash a freq 0)
- (gethash b freq 0))))))))))
+ (setq desc (format "%d groups, %d unique"
+ (length groups)
+ (hash-table-count freq)))
+ (car-safe
+ (sort groups
+ (lambda (a b)
+ (> (gethash (gnus-group-short-name a) freq 0)
+ (gethash (gnus-group-short-name b) freq 0)))))))))
+
+ (if chosen
+ (gnus-message
+ 9
+ "%s: strategy %s on %s produced %s"
+ log-agent gnus-registry-split-strategy desc chosen)
+ (gnus-message
+ 9
+ "%s: strategy %s on %s did not produce an answer"
+ log-agent
+ (or gnus-registry-split-strategy "default")
+ desc))
+
+ (setq groups (and chosen (list chosen)))
(dolist (group groups)
(let ((m1 (gnus-find-method-for-group group))
(if (gnus-methods-equal-p m1 m2)
(progn
;; this is REALLY just for debugging
- (gnus-message
- 10
- "%s stripped group %s to %s"
- log-agent group short-name)
+ (when (not (equal group short-name))
+ (gnus-message
+ 10
+ "%s: stripped group %s to %s"
+ log-agent group short-name))
(add-to-list 'out short-name))
;; else...
(gnus-message
7
- "%s ignored foreign group %s"
+ "%s: ignored foreign group %s"
log-agent group))))
- ;; is there just one group?
+ (setq out (delq nil out))
+
(cond
((= (length out) 1) out)
((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))))
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."
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)
(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-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)
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
;; 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)
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."
(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))))
+(defun gnus-registry-delete-entries (idlist)
+ (registry-delete gnus-registry-db idlist nil))
+
(defun gnus-registry-get-id-key (id key)
(cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
(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))
-
-(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."))
+(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:
+ ;; (setq gnus-registry-alist '(
+ ;; ("<messageID>" ((marks nil)
+ ;; (mtime 19365 1776 440496)
+ ;; (sender . "root (Cron Daemon)")
+ ;; (subject . "Cron"))
+ ;; "cron" "nnml+private:cron")
+ (load file t)
+ (when (boundp 'gnus-registry-alist)
+ (let* ((old (symbol-value 'gnus-registry-alist))
+ (count 0)
+ (expected (length old))
+ entry)
+ (while (car-safe old)
+ (incf count)
+ ;; don't use progress reporters for backwards compatibility
+ (when (and (< 0 expected)
+ (= 0 (mod count 100)))
+ (message "importing: %d of %d (%.2f%%)"
+ count expected (/ (* 100 count) expected)))
+ (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)
+ collect p))
+ extra-cell key val)
+ ;; remove all the strings from the entry
+ (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))
+ (while (car-safe rest)
+ (setq extra-cell (car-safe rest)
+ key (car-safe extra-cell)
+ val (cdr-safe extra-cell)
+ rest (cdr-safe rest))
+ (when (and val (atom val))
+ (setq val (list val)))
+ (gnus-registry-set-id-key id key val))))
+ (message "Import done, collected %d entries" count))))
;;;###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))
(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)
(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)
+
+;; 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
+ (ignore-errors
+ (gnus-select-group-with-message-id group message-id))
+ (throw 'found t)))))))
;; TODO: a few things
projects / gnus / blobdiff