X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=a4d510764ea94a4598c5dc5ca5bf1d6a2d5ee22c;hb=348ca824b5116f395afc7d69321c3cedf60b0d3f;hp=736db5d3eba1919296862acb85386e6bd233a185;hpb=7c662495ed6fa89a966bf6e4e555a05d07638c7f;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 736db5d..a4d5107 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -1,6 +1,7 @@ ;;; gnus-registry.el --- article registry for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Ted Zlatanov ;; Keywords: news @@ -19,8 +20,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -66,7 +67,7 @@ (defgroup gnus-registry nil "The Gnus registry." - :version "21.4" + :version "22.1" :group 'gnus) (defvar gnus-registry-hashtb (make-hash-table @@ -102,7 +103,7 @@ and no extra data." The Subject and Sender (From:) headers are currently tracked this way." :group 'gnus-registry - :type + :type '(set :tag "Tracking choices" (const :tag "Track by subject (Subject: header)" subject) (const :tag "Track by sender (From: header)" sender))) @@ -187,12 +188,12 @@ way." "%s#tmp#%d")) working-dir (setq i (1+ i)))) (file-exists-p working-file))) - + (unwind-protect (progn (gnus-with-output-to-file working-file (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) - + ;; These bindings will mislead the current buffer ;; into thinking that it is visiting the startup ;; file. @@ -202,14 +203,14 @@ way." (setmodes (file-modes startup-file))) ;; Backup the current version of the startup file. (backup-buffer) - + ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) (gnus-set-file-modes startup-file setmodes))) (condition-case nil (delete-file working-file) (file-error nil))))) - + (gnus-kill-buffer (current-buffer)) (gnus-message 5 "Saving %s...done" file)))) @@ -237,10 +238,10 @@ way." (remhash key gnus-registry-hashtb))) gnus-registry-hashtb) ;; remove empty entries - (when gnus-registry-clean-empty + (when gnus-registry-clean-empty (gnus-registry-clean-empty-function)) ;; now trim the registry appropriately - (setq gnus-registry-alist (gnus-registry-trim + (setq gnus-registry-alist (gnus-registry-trim (hashtable-to-alist gnus-registry-hashtb))) ;; really save (gnus-registry-cache-save) @@ -250,15 +251,37 @@ way." (defun gnus-registry-clean-empty-function () "Remove all empty entries from the registry. Returns count thereof." (let ((count 0)) + (maphash (lambda (key value) - (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))) + (when (stringp key) + (dolist (group (gnus-registry-fetch-groups key)) + (when (gnus-parameter-registry-ignore group) + (gnus-message + 10 + "gnus-registry: deleted ignored group %s from key %s" + group key) + (gnus-registry-delete-group key group))) + + (unless (gnus-registry-group-count key) + (gnus-registry-delete-id 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) + (stringp key)) + (incf count) + (gnus-registry-delete-id key)) + + (unless (stringp key) + (gnus-message + 10 + "gnus-registry key %s was not a string, removing" + key) + (gnus-registry-delete-id key)))) + gnus-registry-hashtb) count)) @@ -268,7 +291,8 @@ way." (setq gnus-registry-dirty nil)) (defun gnus-registry-trim (alist) - "Trim alist to size, using gnus-registry-max-entries." + "Trim alist to size, using gnus-registry-max-entries. +Also, drop all gnus-registry-ignored-groups matches." (if (null gnus-registry-max-entries) alist ; just return the alist ;; else, when given max-entries, trim the alist @@ -281,20 +305,20 @@ way." (lambda (key value) (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 trim-length (sort alist (lambda (a b) - (time-less-p - (cdr (gethash (car a) timehash)) - (cdr (gethash (car b) timehash)))))))))) + (time-less-p + (or (cdr (gethash (car a) timehash)) '(0 0 0)) + (or (cdr (gethash (car b) timehash)) '(0 0 0)))))))))) (defun alist-to-hashtable (alist) "Build a hashtable from the values in ALIST." - (let ((ht (make-hash-table + (let ((ht (make-hash-table :size 4096 :test 'equal))) (mapc @@ -314,7 +338,7 @@ way." (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) - (subject (gnus-registry-simplify-subject + (subject (gnus-registry-simplify-subject (mail-header-subject data-header))) (sender (mail-header-from data-header)) (from (gnus-group-guess-full-name-from-command-method from)) @@ -330,7 +354,7 @@ way." ;; All except copy will need a delete (gnus-registry-delete-group id from) - (when (equal 'copy action) + (when (equal 'copy action) (gnus-registry-add-group id from subject sender)) ; undo the delete (gnus-registry-add-group id to subject sender))) @@ -350,7 +374,7 @@ way." "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: (: gnus-registry-split-fancy-with-parent) This function tracks ALL backends, unlike `nnmail-split-fancy-with-parent' which tracks only nnmail @@ -381,7 +405,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (when (or (gnus-registry-grep-in-list res gnus-registry-unfollowed-groups) - (gnus-registry-grep-in-list + (gnus-registry-grep-in-list res nnmail-split-fancy-with-parent-ignore-groups)) (setq res nil))) @@ -421,7 +445,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (< gnus-registry-minimum-subject-length (length subject))) (maphash (lambda (key value) - (let ((this-subject (cdr + (let ((this-subject (cdr (gnus-registry-fetch-extra key 'subject)))) (when (and single-match this-subject @@ -453,13 +477,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (when (and res gnus-registry-use-long-group-names) (let ((m1 (gnus-find-method-for-group res)) - (m2 (or gnus-command-method + (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 + 9 "gnus-registry-split-fancy-with-parent stripped group %s to %s" res short-res) @@ -478,9 +502,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (dolist (article gnus-newsgroup-articles) (let ((id (gnus-registry-fetch-message-id-fast article))) (unless (gnus-registry-fetch-group id) - (gnus-message 9 "Registry: Registering article %d with group %s" + (gnus-message 9 "Registry: Registering article %d with group %s" article gnus-newsgroup-name) - (gnus-registry-add-group + (gnus-registry-add-group (gnus-registry-fetch-message-id-fast article) gnus-newsgroup-name (gnus-registry-fetch-simplified-message-subject-fast article) @@ -519,7 +543,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (when word (memq nil (mapcar 'not - (mapcar + (mapcar (lambda (x) (string-match x word)) list))))) @@ -555,7 +579,7 @@ Update the entry cache if needed." ;; get the entree from the hash table or from the alist (setq entree (gethash id entry-cache))) - + (unless entree (setq entree (assq entry alist)) (when gnus-registry-entry-caching @@ -596,10 +620,27 @@ Returns the first place where the trail finds a group name." (let ((trail (gethash id gnus-registry-hashtb))) (dolist (crumb trail) (when (stringp crumb) - (return (if gnus-registry-use-long-group-names - crumb + (return (if gnus-registry-use-long-group-names + crumb (gnus-group-short-name crumb)))))))) +(defun gnus-registry-fetch-groups (id) + "Get the groups of a message, based on the message ID." + (let ((trail (gethash id gnus-registry-hashtb)) + groups) + (dolist (crumb trail) + (when (stringp crumb) + ;; push the group name into the list + (setq + groups + (cons + (if (or (not (stringp crumb)) gnus-registry-use-long-group-names) + crumb + (gnus-group-short-name crumb)) + groups)))) + ;; return the list of groups + groups)) + (defun gnus-registry-group-count (id) "Get the number of groups of a message, based on the message ID." (let ((trail (gethash id gnus-registry-hashtb))) @@ -609,19 +650,20 @@ Returns the first place where the trail finds a group name." (defun gnus-registry-delete-group (id group) "Delete a group for a message, based on the message ID." - (when group - (when id + (when (and group id) (let ((trail (gethash id gnus-registry-hashtb)) - (group (gnus-group-short-name group))) + (short-group (gnus-group-short-name group))) (puthash id (if trail - (delete group trail) + (delete short-group (delete group trail)) nil) gnus-registry-hashtb)) ;; now, clear the entry if there are no more groups (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." @@ -639,8 +681,8 @@ Returns the first place where the trail finds a group name." (when (and id (not (string-match "totally-fudged-out-message-id" id))) (let ((full-group group) - (group (if gnus-registry-use-long-group-names - group + (group (if gnus-registry-use-long-group-names + group (gnus-group-short-name group)))) (gnus-registry-delete-group id group) @@ -656,16 +698,16 @@ Returns the first place where the trail finds a group name." (when (and (gnus-registry-track-subject-p) subject) (gnus-registry-store-extra-entry - id - 'subject + id + 'subject (gnus-registry-simplify-subject subject))) (when (and (gnus-registry-track-sender-p) sender) (gnus-registry-store-extra-entry - id + id 'sender sender)) - + (gnus-registry-store-extra-entry id 'mtime (current-time))))))) (defun gnus-registry-clear () @@ -686,11 +728,11 @@ Returns the first place where the trail finds a group name." (defun gnus-registry-install-hooks () "Install the registry hooks." (interactive) - (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) + (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) (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) - + (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) @@ -699,11 +741,11 @@ Returns the first place where the trail finds a group name." (defun gnus-registry-unload-hook () "Uninstall the registry hooks." (interactive) - (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) + (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) - + (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)