;;; 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))
-(eval-when-compile
- (when (null (require 'ert nil t))
- (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
-
-(require 'ert nil t)
(require 'gnus)
(require 'gnus-int)
(require 'gnus-sum)
(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."
(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
- (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)
: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)
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 ()
(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.
(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
;; 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-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)
+