"*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.
: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)
(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."
(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
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."
(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)
projects / elisp / gnus.git- / blobdiff