X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fgnus-registry.el;h=1daa0fa007fe0d99a0d0657bc6d8d440bb9f83b5;hb=f702159a4d7cb8471a17884108880aa8d7961728;hp=bce77295d22313eb301e195af850e9004ff93373;hpb=6d70ee5b48003576c48a0bd05d8ec225e741cac2;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index bce7729..1daa0fa 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -1,5 +1,5 @@ ;;; gnus-registry.el --- article registry for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Ted Zlatanov @@ -66,9 +66,12 @@ (defgroup gnus-registry nil "The Gnus registry." + :version "21.4" :group 'gnus) -(defvar gnus-registry-hashtb nil +(defvar gnus-registry-hashtb (make-hash-table + :size 256 + :test 'equal) "*The article registry by Message ID.") (defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue") @@ -131,7 +134,7 @@ way." "Maximum number of entries in the registry, nil for unlimited." :group 'gnus-registry :type '(radio (const :format "Unlimited " nil) - (integer :format "Maximum number: %v\n" :size 0))) + (integer :format "Maximum number: %v"))) (defun gnus-registry-track-subject-p () (memq 'subject gnus-registry-track-extra)) @@ -202,7 +205,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))))) @@ -213,7 +216,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) @@ -267,20 +270,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 @@ -316,7 +321,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 @@ -334,7 +339,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))) @@ -356,16 +361,21 @@ 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 (list nnmail-split-fancy-with-parent-ignore-groups))) references res) - (if refstr + ;; the references string must be valid and parse to valid references + (if (and refstr (gnus-extract-references refstr)) (progn - (setq references (nreverse (gnus-split-references refstr))) + (setq references (nreverse (gnus-extract-references refstr))) (mapcar (lambda (x) (setq res (or (gnus-registry-fetch-group x) res)) (when (or (gnus-registry-grep-in-list @@ -387,7 +397,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 @@ -399,7 +409,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 @@ -423,7 +433,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 @@ -431,7 +441,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)))) @@ -456,7 +466,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)))) @@ -611,7 +621,9 @@ Returns the first place where the trail finds a group name." (when gnus-registry-trim-articles-without-groups (unless (gnus-registry-group-count id) (gnus-registry-delete-id id))) - (gnus-registry-store-extra-entry id 'mtime (current-time))))) + ;; is this ID still in the registry? + (when (gethash id gnus-registry-hashtb) + (gnus-registry-store-extra-entry id 'mtime (current-time)))))) (defun gnus-registry-delete-id (id) "Delete a message ID from the registry." @@ -699,6 +711,8 @@ Returns the first place where the trail finds a group name." (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) +(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) + (when gnus-registry-install (gnus-registry-install-hooks) (gnus-registry-read))