(require 'gnus-sum)
(require 'nnmail)
-;; (defcustom gnus-summary-article-spool-hook nil
-;; "*A hook called after an article is spooled."
-;; :group 'gnus-summary
-;; :type 'hook)
-
-(defun regtest (action id from &optional to method)
- (message "Registry: article %s %s from %s to %s"
- id
- (if method "respooling" "going")
- (gnus-group-guess-full-name from)
- (if to (gnus-group-guess-full-name to) "the Bit Bucket in the sky")))
-
-(defun regtest-nnmail (id group)
- (message "Registry: article %s spooled to %s"
- id
- (gnus-group-prefixed-name group gnus-internal-registry-spool-current-method t)))
-
-;;(add-hook 'gnus-summary-article-move-hook 'regtest) ; also does copy, respool, and crosspost
-;;(add-hook 'gnus-summary-article-delete-hook 'regtest)
-;;(add-hook 'gnus-summary-article-expire-hook 'regtest)
-(add-hook 'nnmail-spool-hook 'regtest-nnmail)
-
-;; TODO:
+(defgroup gnus-registry nil
+ "The Gnus registry."
+ :group 'gnus)
+
+(defvar gnus-registry-hashtb nil
+ "*The article registry by Message ID.")
+
+(defvar gnus-registry-headers-hashtb nil
+ "*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.
+The group names are matched, they don't have to be fully qualified."
+ :group 'gnus-registry
+ :type '(repeat string))
+
+;; Function(s) missing in Emacs 20
+(when (memq nil (mapcar 'fboundp '(puthash)))
+ (require 'cl)
+ (unless (fboundp 'puthash)
+ ;; alias puthash is missing from Emacs 20 cl-extra.el
+ (defalias 'puthash 'cl-puthash)))
+
+(defun gnus-registry-translate-to-alist ()
+ (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)))
+
+(defun alist-to-hashtable (alist)
+ "Build a hashtable from the values in ALIST."
+ (let ((ht (make-hash-table
+ :size 4096
+ :test 'equal)))
+ (mapc
+ (lambda (kv-pair)
+ (puthash (car kv-pair) (cdr kv-pair) ht))
+ alist)
+ ht))
+
+(defun hashtable-to-alist (hash)
+ "Build an alist from the values in HASH."
+ (let ((list nil))
+ (maphash
+ (lambda (key value)
+ (setq list (cons (cons key value) list)))
+ hash)
+ list))
+
+(defun gnus-register-action (action data-header from &optional to method)
+ (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"))
+ (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)
+
+ ;; 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)
+ (gnus-registry-add-group id group))
+;)
+
+;; Function for nn{mail|imap}-split-fancy: look up all references in
+;; the cache and if a match is found, return that group.
+(defun gnus-registry-split-fancy-with-parent ()
+ "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)
+
+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")))
+ (references nil)
+ (res nil))
+ (when refstr
+ (setq references (nreverse (gnus-split-references refstr)))
+ (mapcar (lambda (x)
+ (setq res (or (gnus-registry-fetch-group x) res))
+ (when (or (gnus-registry-grep-in-list
+ res
+ gnus-registry-unfollowed-groups)
+ (gnus-registry-grep-in-list
+ res
+ 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-register-message-ids ()
+ "Register the Message-ID of every article in the group"
+ (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."
+ (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."
+ (interactive)
+ (setq gnus-registry-alist nil
+ gnus-registry-headers-alist nil)
+ (gnus-registry-translate-from-alist))
+
+; also does copy, respool, and crosspost
+(add-hook 'gnus-summary-article-move-hook 'gnus-register-action)
+(add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
+(add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
+(add-hook 'nnmail-spool-hook 'gnus-register-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)
projects / elisp / gnus.git- / blobdiff