;;; Commentary:
-;; This is the gnus-registry.el package, works with other backends
-;; besides nnmail. The major issue is that it doesn't go across
-;; backends, so for instance if an article is in nnml:sys and you see
-;; a reference to it in nnimap splitting, the article will end up in
-;; nnimap:sys
+;; This is the gnus-registry.el package, which works with all
+;; backends, not just nnmail (e.g. NNTP). The major issue is that it
+;; doesn't go across backends, so for instance if an article is in
+;; nnml:sys and you see a reference to it in nnimap splitting, the
+;; article will end up in nnimap:sys
;; gnus-registry.el intercepts article respooling, moving, deleting,
;; and copying for all backends. If it doesn't work correctly for
(defcustom gnus-registry-clean-empty t
"Whether the empty registry entries should be deleted.
-Registry entries are considered empty when they have no groups."
+Registry entries are considered empty when they have no groups
+and no extra data."
:group 'gnus-registry
:type 'boolean)
:type 'boolean)
(defcustom gnus-registry-track-extra nil
- "Whether the registry should track other things about a message.
-The Subject header is currently the only thing that can be
-tracked this way."
+ "Whether the registry should track extra data about a message.
+The Subject and Sender (From:) headers are currently tracked this
+way."
:group 'gnus-registry
- :type 'boolean)
+ :type
+ '(set :tag "Tracking choices"
+ (const :tag "Track by subject (Subject: header)" subject)
+ (const :tag "Track by sender (From: header)" sender)))
(defcustom gnus-registry-entry-caching t
"Whether the registry should cache extra information."
:group 'gnus-registry
:type 'boolean)
-(defcustom gnus-registry-cache-file "~/.gnus.registry.eld"
+(defcustom gnus-registry-cache-file
+ (nnheader-concat
+ (or gnus-dribble-directory gnus-home-directory "~/")
+ ".gnus.registry.eld")
"File where the Gnus registry will be stored."
:group 'gnus-registry
:type 'file)
:type '(radio (const :format "Unlimited " nil)
(integer :format "Maximum number: %v\n" :size 0)))
-;; Function(s) missing in Emacs 20
-(when (memq nil (mapcar 'fboundp '(puthash)))
- (require 'cl)
- (unless (fboundp 'puthash)
- ;; alias puthash is missing from Emacs 20 cl-extra.el
- (defalias 'puthash 'cl-puthash)))
+(defun gnus-registry-track-subject-p ()
+ (memq 'subject gnus-registry-track-extra))
+
+(defun gnus-registry-track-sender-p ()
+ (memq 'sender gnus-registry-track-extra))
(defun gnus-registry-cache-read ()
"Read the registry cache file."
;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
;; Save the gnus-registry file with extra line breaks.
(defun gnus-registry-cache-whitespace (filename)
- (gnus-message 5 "Adding whitespace to %s" filename)
+ (gnus-message 7 "Adding whitespace to %s" filename)
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^(\\|(\\\"" nil t)
(let ((count 0))
(maphash
(lambda (key value)
- (unless (gnus-registry-fetch-group key)
+ (unless (or
+ (gnus-registry-fetch-group key)
+ ;; TODO: look for specific extra data here!
+ ;; in this example, we look for 'label
+ (gnus-registry-fetch-extra key 'label))
(incf count)
(remhash key gnus-registry-hashtb)))
gnus-registry-hashtb)
(let* ((id (mail-header-id data-header))
(subject (gnus-registry-simplify-subject
(mail-header-subject data-header)))
- (from (gnus-group-guess-full-name from))
- (to (if to (gnus-group-guess-full-name to) nil))
- (to-name (if to to "the Bit Bucket"))
- (old-entry (gethash id gnus-registry-hashtb)))
- (gnus-message 5 "Registry: article %s %s from %s to %s"
+ (sender (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"))
+ (old-entry (gethash id gnus-registry-hashtb)))
+ (gnus-message 7 "Registry: article %s %s from %s to %s"
id
(if method "respooling" "going")
from
(gnus-registry-delete-group id from)
(when (equal 'copy action)
- (gnus-registry-add-group id from subject)) ; undo the delete
-
- (gnus-registry-add-group id to subject)))
-
-(defun gnus-registry-spool-action (id group &optional subject)
- ;; do not process the draft IDs
-; (unless (string-match "totally-fudged-out-message-id" id)
-; (let ((group (gnus-group-guess-full-name group)))
- (when (and (stringp id) (string-match "\r$" id))
- (setq id (substring id 0 -1)))
- (gnus-message 5 "Registry: article %s spooled to %s"
- id
- group)
- (gnus-registry-add-group id group subject))
-;)
+ (gnus-registry-add-group id from subject sender)) ; undo the delete
+
+ (gnus-registry-add-group id to subject sender)))
+
+(defun gnus-registry-spool-action (id group &optional subject sender)
+ (let ((group (gnus-group-guess-full-name-from-command-method group)))
+ (when (and (stringp id) (string-match "\r$" id))
+ (setq id (substring id 0 -1)))
+ (gnus-message 7 "Registry: article %s spooled to %s"
+ id
+ group)
+ (gnus-registry-add-group id group subject sender)))
;; Function for nn{mail|imap}-split-fancy: look up all references in
;; the cache and if a match is found, return that group.
in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
this: (: gnus-registry-split-fancy-with-parent)
+This function tracks ALL backends, unlike
+`nnmail-split-fancy-with-parent' which tracks only nnmail
+messages.
+
For a message to be split, it looks for the parent message in the
References or In-Reply-To header and then looks in the registry to
see which group that message was put in. This group is returned.
nnmail-split-fancy-with-parent-ignore-groups))
(setq res nil)))
references))
- ;; there were no references, now try the extra tracking
- (when gnus-registry-track-extra
- (let ((subject (gnus-registry-simplify-subject
- (message-fetch-field "subject"))))
- (when (and subject
- (< gnus-registry-minimum-subject-length (length subject)))
- (maphash
- (lambda (key value)
- (let ((this-subject (cdr
- (gnus-registry-fetch-extra key 'subject))))
- (when (and this-subject
- (equal subject this-subject))
- (setq res (gnus-registry-fetch-group key))
+
+ ;; else: there were no references, now try the extra tracking
+ (let ((sender (message-fetch-field "from"))
+ (subject (gnus-registry-simplify-subject
+ (message-fetch-field "subject")))
+ (single-match t))
+ (when (and single-match
+ (gnus-registry-track-sender-p)
+ sender)
+ (maphash
+ (lambda (key value)
+ (let ((this-sender (cdr
+ (gnus-registry-fetch-extra key 'sender))))
+ (when (and single-match
+ this-sender
+ (equal sender this-sender))
+ ;; too many matches, bail
+ (unless (equal res (gnus-registry-fetch-group key))
+ (setq single-match nil))
+ (setq res (gnus-registry-fetch-group key))
+ (when (and sender res)
(gnus-message
;; raise level of messaging if gnus-registry-track-extra
- (if gnus-registry-track-extra 5 9)
+ (if gnus-registry-track-extra 7 9)
+ "%s (extra tracking) traced sender %s to group %s"
+ "gnus-registry-split-fancy-with-parent"
+ sender
+ res)))))
+ gnus-registry-hashtb))
+ (when (and single-match
+ (gnus-registry-track-subject-p)
+ subject
+ (< gnus-registry-minimum-subject-length (length subject)))
+ (maphash
+ (lambda (key value)
+ (let ((this-subject (cdr
+ (gnus-registry-fetch-extra key 'subject))))
+ (when (and single-match
+ this-subject
+ (equal subject this-subject))
+ ;; too many matches, bail
+ (unless (equal res (gnus-registry-fetch-group key))
+ (setq single-match nil))
+ (setq res (gnus-registry-fetch-group key))
+ (when (and subject res)
+ (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 group %s"
"gnus-registry-split-fancy-with-parent"
subject
- (if res res "nil")))))
- gnus-registry-hashtb)))))
- (gnus-message
- 5
- "gnus-registry-split-fancy-with-parent traced %s to group %s"
- refstr (if res res "nil"))
+ res)))))
+ gnus-registry-hashtb))
+ (unless single-match
+ (gnus-message
+ 3
+ "gnus-registry-split-fancy-with-parent: too many extra matches for %s"
+ refstr)
+ (setq res nil))))
+ (when (and refstr res)
+ (gnus-message
+ 5
+ "gnus-registry-split-fancy-with-parent traced %s to group %s"
+ refstr res))
+
+ (when (and res gnus-registry-use-long-group-names)
+ (let ((m1 (gnus-find-method-for-group res))
+ (m2 (or gnus-command-method
+ (gnus-find-method-for-group gnus-newsgroup-name)))
+ (short-res (gnus-group-short-name res)))
+ (if (gnus-methods-equal-p m1 m2)
+ (progn
+ (gnus-message
+ 9
+ "gnus-registry-split-fancy-with-parent stripped group %s to %s"
+ res
+ short-res)
+ (setq res short-res))
+ ;; else...
+ (gnus-message
+ 7
+ "gnus-registry-split-fancy-with-parent ignored foreign group %s"
+ res)
+ (setq res nil))))
res))
(defun gnus-registry-register-message-ids ()
(gnus-registry-add-group
(gnus-registry-fetch-message-id-fast article)
gnus-newsgroup-name
- (gnus-registry-fetch-simplified-message-subject-fast article)))))))
+ (gnus-registry-fetch-simplified-message-subject-fast article)
+ (gnus-registry-fetch-sender-fast article)))))))
(defun gnus-registry-fetch-message-id-fast (article)
"Fetch the Message-ID quickly, using the internal gnus-data-list function"
(assoc article (gnus-data-list nil)))))
nil))
+(defun gnus-registry-fetch-sender-fast (article)
+ "Fetch the Sender quickly, using the internal gnus-data-list function"
+ (if (and (numberp article)
+ (assoc article (gnus-data-list nil)))
+ (mail-header-from (gnus-data-header
+ (assoc article (gnus-data-list nil))))
+ nil))
+
(defun gnus-registry-grep-in-list (word list)
(when word
(memq nil
(let ((trail (gethash id gnus-registry-hashtb)))
(dolist (crumb trail)
(when (stringp crumb)
- (return (gnus-group-short-name crumb)))))))
+ (return (if gnus-registry-use-long-group-names
+ crumb
+ (gnus-group-short-name crumb))))))))
(defun gnus-registry-group-count (id)
"Get the number of groups of a message, based on the message ID."
(remhash id value)))
gnus-registry-hashtb)))
-(defun gnus-registry-add-group (id group &optional subject)
+(defun gnus-registry-add-group (id group &optional subject sender)
"Add a group for a message, based on the message ID."
- ;; make sure there are no duplicate entries
(when group
(when (and id
(not (string-match "totally-fudged-out-message-id" id)))
group
(gnus-group-short-name group))))
(gnus-registry-delete-group id group)
- (unless gnus-registry-use-long-group-names
+
+ (unless gnus-registry-use-long-group-names ;; unnecessary in this case
(gnus-registry-delete-group id full-group))
+
(let ((trail (gethash id gnus-registry-hashtb)))
(puthash id (if trail
(cons group trail)
(list group))
gnus-registry-hashtb)
- (when gnus-registry-track-extra
- (gnus-registry-store-extra-entry
+ (when (and (gnus-registry-track-subject-p)
+ subject)
+ (gnus-registry-store-extra-entry
id
'subject
(gnus-registry-simplify-subject subject)))
+ (when (and (gnus-registry-track-sender-p)
+ sender)
+ (gnus-registry-store-extra-entry
+ id
+ 'sender
+ sender))
(gnus-registry-store-extra-entry id 'mtime (current-time)))))))
projects / gnus / blobdiff