X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fgnus.git-;a=blobdiff_plain;f=lisp%2Fgnus-registry.el;fp=lisp%2Fgnus-registry.el;h=324155dd1f93be8a0b1d09715206bc0e56695cea;hp=9d16500981b62a5d54e8b3bb187bfe665b222e4d;hb=9ea9abe9f6b53f086a6f28239e5a995b9810c795;hpb=c5f7362aa49943397fec729fdcfca40679946ec8 diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 9d16500..324155d 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -41,7 +41,7 @@ "*The article registry by Message ID.") (defvar gnus-registry-headers-hashtb nil - "*The article header registry by Message ID.") + "*The article header registry by Message ID. Unused for now.") (defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue") "List of groups that gnus-registry-split-fancy-with-parent won't follow. @@ -49,6 +49,11 @@ The group names are matched, they don't have to be fully qualified." :group 'gnus-registry :type '(repeat string)) +(defcustom gnus-registry-unregistered-group-regex "^nntp" + "Group name regex that gnus-registry-register-message-ids won't process." + :group 'gnus-registry + :type 'regexp) + ;; Function(s) missing in Emacs 20 (when (memq nil (mapcar 'fboundp '(puthash))) (require 'cl) @@ -57,14 +62,10 @@ The group names are matched, they don't have to be fully qualified." (defalias 'puthash 'cl-puthash))) (defun gnus-registry-translate-to-alist () - (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb)) - (setq gnus-registry-headers-alist (hashtable-to-alist - gnus-registry-headers-hashtb))) + (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb))) (defun gnus-registry-translate-from-alist () - (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) - (setq gnus-registry-headers-hashtb (alist-to-hashtable - gnus-registry-headers-alist))) + (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))) (defun alist-to-hashtable (alist) "Build a hashtable from the values in ALIST." @@ -90,30 +91,32 @@ The group names are matched, they don't have to be fully qualified." (let* ((id (mail-header-id 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"))) + (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" id (if method "respooling" "going") from - to) - (unless (gethash id gnus-registry-headers-hashtb) - (puthash id (list data-header) gnus-registry-headers-hashtb)) - (puthash id (cons (list action from to) - (gethash id gnus-registry-hashtb)) - gnus-registry-hashtb))) + to) + + ;; All except copy will need a delete + (gnus-registry-delete-group id from) + + (when (equal 'copy action) + (gnus-registry-add-group id from)) ; undo the delete + + (gnus-registry-add-group id to))) (defun gnus-register-spool-action (id group) ;; do not process the draft IDs ; (unless (string-match "totally-fudged-out-message-id" id) - (let ((group (gnus-group-guess-full-name group))) - (when (string-match "\r$" id) - (setq id (substring id 0 -1))) - (gnus-message 5 "Registry: article %s spooled to %s" - id - group) - (puthash id (cons (list 'spool nil group) - (gethash id gnus-registry-hashtb)) - gnus-registry-hashtb))) +; (let ((group (gnus-group-guess-full-name group))) + (when (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)) ;) ;; Function for nn{mail|imap}-split-fancy: look up all references in @@ -145,27 +148,77 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." nnmail-split-fancy-with-parent-ignore-groups)) (setq res nil))) references) + (gnus-message + 5 + "gnus-registry-split-fancy-with-parent traced %s to group %s" + refstr (if res res "nil")) res))) -(defun gnus-registry-grep-in-list (word list) - (memq nil - (mapcar 'not - (mapcar - (lambda (x) - (string-match x word)) - list)))) +(defun gnus-registry-register-message-ids () + "Register the Message-ID of every article in the group" + (unless (and gnus-registry-unregistered-group-regex + (string-match gnus-registry-unregistered-group-regex gnus-newsgroup-name)) + (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" + article gnus-newsgroup-name) + (gnus-registry-add-group (gnus-registry-fetch-message-id-fast article) + gnus-newsgroup-name)))))) + +(defun gnus-registry-fetch-message-id-fast (article) + "Fetch the Message-ID quickly, using the internal gnus-data-list function" + (if (and (numberp article) + (assoc article (gnus-data-list nil))) + (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) + nil)) +(defun gnus-registry-grep-in-list (word list) + (when word + (memq nil + (mapcar 'not + (mapcar + (lambda (x) + (string-match x word)) + list))))) (defun gnus-registry-fetch-group (id) "Get the group of a message, based on the message ID. Returns the first place where the trail finds a spool action." - (let ((trail (gethash id gnus-registry-hashtb))) - (dolist (crumb trail) - (let ((action (nth 0 crumb)) - (from (nth 1 crumb)) - (to (nth 2 crumb))) - (when (eq action 'spool) - (return to)))))) + (when id + (let ((trail (gethash id gnus-registry-hashtb))) + (if trail + (car trail) + nil)))) + +(defun gnus-registry-delete-group (id group) + "Get the group of a message, based on the message ID. +Returns the first place where the trail finds a spool action." + (when group + (when id + (let ((trail (gethash id gnus-registry-hashtb)) + (group (gnus-group-short-name group))) + (puthash id (if trail + (delete group trail) + nil) + gnus-registry-hashtb)) + ;; now, clear the entry if it's empty + (unless (gethash id gnus-registry-hashtb) + (remhash id gnus-registry-hashtb))))) + +(defun gnus-registry-add-group (id group) + "Get the group of a message, based on the message ID. +Returns the first place where the trail finds a spool action." + ;; make sure there are no duplicate entries + (when group + (when id + (let ((group (gnus-group-short-name group))) + (gnus-registry-delete-group id group) + (let ((trail (gethash id gnus-registry-hashtb))) + (puthash id (if trail + (cons group trail) + (list group)) + gnus-registry-hashtb)))))) (defun gnus-registry-clear () "Clear the Gnus registry." @@ -183,6 +236,8 @@ Returns the first place where the trail finds a spool action." (add-hook 'gnus-save-newsrc-hook 'gnus-registry-translate-to-alist) (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-translate-from-alist) +(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) + ;; TODO: a lot of things (provide 'gnus-registry)