X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=f0d955d790ccf1a47b0c29655881c882f6d5689a;hb=7a9f34c33d683889f228897bc047eebd9ddb6c95;hp=c1e6d58f4212be85fc06fe3ca9366b7dc7b43d7c;hpb=2d276a19b9e77e0b82069721d8a6ca929cf9cee0;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index c1e6d58..f0d955d 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -24,11 +24,11 @@ ;;; 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 @@ -84,7 +84,8 @@ The group names are matched, they don't have to be fully qualified." (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) @@ -118,7 +119,10 @@ way." :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) @@ -198,7 +202,7 @@ way." ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) - (set-file-modes startup-file setmodes))) + (gnus-set-file-modes startup-file setmodes))) (condition-case nil (delete-file working-file) (file-error nil))))) @@ -209,7 +213,7 @@ way." ;; Idea from Dan Christensen ;; 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) @@ -245,7 +249,11 @@ way." (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) @@ -259,20 +267,22 @@ way." (defun gnus-registry-trim (alist) "Trim alist to size, using gnus-registry-max-entries." (if (null gnus-registry-max-entries) - alist ; just return the alist + alist ; just return the alist ;; else, when given max-entries, trim the alist - (let ((timehash (make-hash-table - :size 4096 - :test 'equal))) + (let* ((timehash (make-hash-table + :size 4096 + :test 'equal)) + (trim-length (- (length alist) gnus-registry-max-entries)) + (trim-length (if (natnump trim-length) trim-length 0))) (maphash (lambda (key value) - (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)) + (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)) gnus-registry-hashtb) ;; we use the return value of this setq, which is the trimmed alist (setq alist (nthcdr - (- (length alist) gnus-registry-max-entries) + trim-length (sort alist (lambda (a b) (time-less-p @@ -308,7 +318,7 @@ way." (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 5 "Registry: article %s %s from %s to %s" + (gnus-message 7 "Registry: article %s %s from %s to %s" id (if method "respooling" "going") from @@ -326,7 +336,7 @@ way." (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 5 "Registry: article %s spooled to %s" + (gnus-message 7 "Registry: article %s spooled to %s" id group) (gnus-registry-add-group id group subject sender))) @@ -339,13 +349,21 @@ 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 +`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. See the Info node `(gnus)Fancy Mail Splitting' for more details." - (let ((refstr (or (message-fetch-field "references") - (message-fetch-field "in-reply-to"))) + (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string + (reply-to (message-fetch-field "in-reply-to")) ; grab reply-to + ;; now, if reply-to is valid, append it to the References + (refstr (if reply-to + (concat refstr " " reply-to) + refstr)) (nnmail-split-fancy-with-parent-ignore-groups (if (listp nnmail-split-fancy-with-parent-ignore-groups) nnmail-split-fancy-with-parent-ignore-groups @@ -375,7 +393,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." sender) (maphash (lambda (key value) - (let ((this-sender (cdr + (let ((this-sender (cdr (gnus-registry-fetch-extra key 'sender)))) (when (and single-match this-sender @@ -387,7 +405,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (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 @@ -411,7 +429,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (when (and subject 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 subject %s to group %s" "gnus-registry-split-fancy-with-parent" subject @@ -419,7 +437,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." gnus-registry-hashtb)) (unless single-match (gnus-message - 5 + 3 "gnus-registry-split-fancy-with-parent: too many extra matches for %s" refstr) (setq res nil)))) @@ -444,7 +462,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (setq res short-res)) ;; else... (gnus-message - 5 + 7 "gnus-registry-split-fancy-with-parent ignored foreign group %s" res) (setq res nil))))