+ gnus-newsgroup-name
+ (gnus-registry-fetch-simplified-message-subject-fast article)
+ (gnus-registry-fetch-sender-fast article)))))))
+
+(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-simplify-subject (subject)
+ (if (stringp subject)
+ (gnus-simplify-subject subject)
+ nil))
+
+(defun gnus-registry-fetch-simplified-message-subject-fast (article)
+ "Fetch the Subject quickly, using the internal gnus-data-list function"
+ (if (and (numberp article)
+ (assoc article (gnus-data-list nil)))
+ (gnus-string-remove-all-properties
+ (gnus-registry-simplify-subject
+ (mail-header-subject (gnus-data-header
+ (assoc article (gnus-data-list nil))))))
+ nil))
+
+(defun gnus-registry-fetch-sender-fast (article)
+ "Fetch the Sender quickly, using the internal gnus-data-list function"
+ (if (and (numberp article)
+ (assoc article (gnus-data-list nil)))
+ (gnus-string-remove-all-properties
+ (mail-header-from (gnus-data-header
+ (assoc article (gnus-data-list nil)))))
+ nil))
+
+(defun gnus-registry-do-marks (type function)
+ "For each known mark, call FUNCTION for each cell of type TYPE.
+
+FUNCTION should take two parameters, a mark symbol and the cell value."
+ (dolist (mark-info gnus-registry-marks)
+ (let* ((mark (car-safe mark-info))
+ (data (cdr-safe mark-info))
+ (cell-data (plist-get data type)))
+ (when cell-data
+ (funcall function mark cell-data)))))
+
+;;; this is ugly code, but I don't know how to do it better
+(defun gnus-registry-install-shortcuts ()
+ "Install the keyboard shortcuts and menus for the registry.
+Uses `gnus-registry-marks' to find what shortcuts to install."
+ (let (keys-plist)
+ (setq gnus-registry-misc-menus nil)
+ (gnus-registry-do-marks
+ :char
+ (lambda (mark data)
+ (let ((function-format
+ (format "gnus-registry-%%s-article-%s-mark" mark)))
+
+;;; The following generates these functions:
+;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
+;;; "Apply the Important mark to process-marked ARTICLES."
+;;; (interactive (gnus-summary-work-articles current-prefix-arg))
+;;; (gnus-registry-set-article-mark-internal 'Important articles nil t))
+;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
+;;; "Apply the Important mark to process-marked ARTICLES."
+;;; (interactive (gnus-summary-work-articles current-prefix-arg))
+;;; (gnus-registry-set-article-mark-internal 'Important articles t t))
+
+ (dolist (remove '(t nil))
+ (let* ((variant-name (if remove "remove" "set"))
+ (function-name (format function-format variant-name))
+ (shortcut (format "%c" data))
+ (shortcut (if remove (upcase shortcut) shortcut)))
+ (unintern function-name obarray)
+ (eval
+ `(defun
+ ;; function name
+ ,(intern function-name)
+ ;; parameter definition
+ (&rest articles)
+ ;; documentation
+ ,(format
+ "%s the %s mark over process-marked ARTICLES."
+ (upcase-initials variant-name)
+ mark)
+ ;; interactive definition
+ (interactive
+ (gnus-summary-work-articles current-prefix-arg))
+ ;; actual code
+
+ ;; if this is called and the user doesn't want the
+ ;; registry enabled, we'll ask anyhow
+ (when (eq gnus-registry-install nil)
+ (setq gnus-registry-install 'ask))
+
+ ;; now the user is asked if gnus-registry-install is 'ask
+ (when (gnus-registry-install-p)
+ (gnus-registry-set-article-mark-internal
+ ;; all this just to get the mark, I must be doing it wrong
+ (intern ,(symbol-name mark))
+ articles ,remove t)
+ (gnus-message
+ 9
+ "Applying mark %s to %d articles"
+ ,(symbol-name mark) (length articles))
+ (dolist (article articles)
+ (gnus-summary-update-article
+ article
+ (assoc article (gnus-data-list nil)))))))
+ (push (intern function-name) keys-plist)
+ (push shortcut keys-plist)
+ (push (vector (format "%s %s"
+ (upcase-initials variant-name)
+ (symbol-name mark))
+ (intern function-name) t)
+ gnus-registry-misc-menus)
+ (gnus-message
+ 9
+ "Defined mark handling function %s"
+ function-name))))))
+ (gnus-define-keys-1
+ '(gnus-registry-mark-map "M" gnus-summary-mark-map)
+ keys-plist)
+ (add-hook 'gnus-summary-menu-hook
+ (lambda ()
+ (easy-menu-add-item
+ gnus-summary-misc-menu
+ nil
+ (cons "Registry Marks" gnus-registry-misc-menus))))))
+
+;;; use like this:
+;;; (defalias 'gnus-user-format-function-M
+;;; 'gnus-registry-user-format-function-M)
+(defun gnus-registry-user-format-function-M (headers)
+ (let* ((id (mail-header-message-id headers))
+ (marks (when id (gnus-registry-fetch-extra-marks id))))
+ (apply 'concat (mapcar (lambda(mark)
+ (let ((c
+ (plist-get
+ (cdr-safe
+ (assoc mark gnus-registry-marks))
+ :char)))
+ (if c
+ (list c)
+ nil)))
+ marks))))
+
+(defun gnus-registry-read-mark ()
+ "Read a mark name from the user with completion."
+ (let ((mark (gnus-completing-read
+ "Label"
+ (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
+ nil nil nil
+ (symbol-name gnus-registry-default-mark))))
+ (when (stringp mark)
+ (intern mark))))
+
+(defun gnus-registry-set-article-mark (&rest articles)
+ "Apply a mark to process-marked ARTICLES."
+ (interactive (gnus-summary-work-articles current-prefix-arg))
+ (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t))
+
+(defun gnus-registry-remove-article-mark (&rest articles)
+ "Remove a mark from process-marked ARTICLES."
+ (interactive (gnus-summary-work-articles current-prefix-arg))
+ (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t))
+
+(defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message)
+ "Apply a mark to a list of ARTICLES."
+ (let ((article-id-list
+ (mapcar 'gnus-registry-fetch-message-id-fast articles)))
+ (dolist (id article-id-list)
+ (let* (
+ ;; all the marks for this article without the mark of
+ ;; interest
+ (marks
+ (delq mark (gnus-registry-fetch-extra-marks id)))
+ ;; the new marks we want to use
+ (new-marks (if remove
+ marks
+ (cons mark marks))))
+ (when show-message
+ (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
+ (if remove "Removing" "Adding")
+ mark id new-marks))
+
+ (apply 'gnus-registry-store-extra-marks ; set the extra marks
+ id ; for the message ID
+ new-marks)))))
+
+(defun gnus-registry-get-article-marks (&rest articles)
+ "Get the Gnus registry marks for ARTICLES and show them if interactive.
+Uses process/prefix conventions. For multiple articles,
+only the last one's marks are returned."
+ (interactive (gnus-summary-work-articles 1))
+ (let (marks)
+ (dolist (article articles)
+ (let ((article-id
+ (gnus-registry-fetch-message-id-fast article)))
+ (setq marks (gnus-registry-fetch-extra-marks article-id))))
+ (when (interactive-p)
+ (gnus-message 1 "Marks are %S" marks))
+ marks))
+
+;;; if this extends to more than 'marks, it should be improved to be more generic.
+(defun gnus-registry-fetch-extra-marks (id)
+ "Get the marks of a message, based on the message ID.
+Returns a list of symbol marks or nil."
+ (car-safe (cdr (gnus-registry-fetch-extra id 'marks))))
+
+(defun gnus-registry-has-extra-mark (id mark)
+ "Checks if a message has `mark', based on the message ID `id'."
+ (memq mark (gnus-registry-fetch-extra-marks id)))
+
+(defun gnus-registry-store-extra-marks (id &rest mark-list)
+ "Set the marks of a message, based on the message ID.
+The `mark-list' can be nil, in which case no marks are left."
+ (gnus-registry-store-extra-entry id 'marks (list mark-list)))
+
+(defun gnus-registry-delete-extra-marks (id &rest mark-delete-list)
+ "Delete the message marks in `mark-delete-list', based on the message ID."
+ (let ((marks (gnus-registry-fetch-extra-marks id)))
+ (when marks
+ (dolist (mark mark-delete-list)
+ (setq marks (delq mark marks))))
+ (gnus-registry-store-extra-marks id (car marks))))
+
+(defun gnus-registry-delete-all-extra-marks (id)
+ "Delete all the marks for a message ID."
+ (gnus-registry-store-extra-marks id nil))
+
+(defun gnus-registry-fetch-extra (id &optional entry)
+ "Get the extra data of a message, based on the message ID.
+Returns the first place where the trail finds a nonstring."
+ (let ((entry-cache (gethash entry gnus-registry-hashtb)))
+ (if (and entry
+ (hash-table-p entry-cache)
+ (gethash id entry-cache))
+ (gethash id entry-cache)
+ ;; else, if there is no caching possible...
+ (let ((trail (gethash id gnus-registry-hashtb)))
+ (when (listp trail)
+ (dolist (crumb trail)
+ (unless (stringp crumb)
+ (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
+
+(defun gnus-registry-fetch-extra-entry (alist &optional entry id)
+ "Get the extra data of a message, or a specific entry in it.
+Update the entry cache if needed."
+ (if (and entry id)
+ (let ((entry-cache (gethash entry gnus-registry-hashtb))
+ entree)
+ (when gnus-registry-entry-caching
+ ;; create the hash table
+ (unless (hash-table-p entry-cache)
+ (setq entry-cache (make-hash-table
+ :size 4096
+ :test 'equal))
+ (puthash entry entry-cache gnus-registry-hashtb))
+
+ ;; 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
+ (puthash id entree entry-cache)))
+ entree)
+ alist))
+
+(defun gnus-registry-store-extra (id extra)
+ "Store the extra data of a message, based on the message ID.
+The message must have at least one group name."
+ (when (gnus-registry-group-count id)
+ ;; we now know the trail has at least 1 group name, so it's not empty
+ (let ((trail (gethash id gnus-registry-hashtb))
+ (old-extra (gnus-registry-fetch-extra id))
+ entry-cache)
+ (dolist (crumb trail)
+ (unless (stringp crumb)
+ (dolist (entry crumb)
+ (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
+ (when entry-cache
+ (remhash id entry-cache))))
+ (puthash id (cons extra (delete old-extra trail))
+ gnus-registry-hashtb)
+ (setq gnus-registry-dirty t)))))
+
+(defun gnus-registry-delete-extra-entry (id key)
+ "Delete a specific entry in the extras field of the registry entry for id."
+ (gnus-registry-store-extra-entry id key nil))
+
+(defun gnus-registry-store-extra-entry (id key value)
+ "Put a specific entry in the extras field of the registry entry for id."
+ (let* ((extra (gnus-registry-fetch-extra id))
+ ;; all the entries except the one for `key'
+ (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
+ (alist (if value
+ (gnus-registry-remove-alist-text-properties
+ (cons (cons key value)
+ the-rest))
+ the-rest)))
+ (gnus-registry-store-extra id alist)))
+
+(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 group name."
+ (when (gnus-registry-group-count id)
+ ;; we now know the trail has at least 1 group name
+ (let ((trail (gethash id gnus-registry-hashtb)))
+ (dolist (crumb trail)
+ (when (stringp crumb)
+ (return (if gnus-registry-use-long-group-names
+ crumb
+ (gnus-group-short-name crumb))))))))
+
+(defun gnus-registry-fetch-groups (id &optional max)
+ "Get the groups (up to MAX, if given) 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))
+ (when (and max (> (length groups) max))
+ (return))))
+ ;; 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)))
+ (if (and trail (listp trail))
+ (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
+ 0)))
+
+(defun gnus-registry-delete-group (id group)
+ "Delete a group for a message, based on the message ID."
+ (when (and group id)
+ (let ((trail (gethash id gnus-registry-hashtb))
+ (short-group (gnus-group-short-name group)))
+ (puthash id (if 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)))
+ ;; 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."
+ (when (stringp id)
+ (remhash id gnus-registry-hashtb)
+ (maphash
+ (lambda (key value)
+ (when (hash-table-p value)
+ (remhash id value)))
+ gnus-registry-hashtb)))
+
+(defun gnus-registry-add-group (id group &optional subject sender)
+ "Add a group for a message, based on the message ID."
+ (when group
+ (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
+ (gnus-group-short-name group))))
+ (gnus-registry-delete-group id group)
+
+ (unless gnus-registry-use-long-group-names ;; unnecessary in this case
+ (gnus-registry-delete-group id full-group))
+
+ (let ((trail (gethash id gnus-registry-hashtb)))
+ (puthash id (if trail
+ (cons group trail)
+ (list group))
+ gnus-registry-hashtb)
+
+ (when (and (gnus-registry-track-subject-p)
+ subject)
+ (gnus-registry-store-extra-entry
+ id
+ 'subject
+ (gnus-registry-simplify-subject subject)))
+ (when (and (gnus-registry-track-sender-p)
+ sender)
+ (gnus-registry-store-extra-entry
+ id
+ 'sender
+ sender))
+
+ (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
+
+(defun gnus-registry-clear ()
+ "Clear the Gnus registry."
+ (interactive)
+ (setq gnus-registry-alist nil)
+ (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
+ (setq gnus-registry-dirty t))
+
+;;;###autoload
+(defun gnus-registry-initialize ()
+"Initialize the Gnus registry."
+ (interactive)
+ (gnus-message 5 "Initializing the registry")
+ (setq gnus-registry-install t) ; in case it was 'ask or nil
+ (gnus-registry-install-hooks)
+ (gnus-registry-install-shortcuts)
+ (when (featurep 'nnregistry)
+ (gnus-registry-install-nnregistry))
+ (gnus-registry-read))
+
+;;;###autoload
+(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-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)
+
+ (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
+
+;;;###autoload
+(defun gnus-registry-install-nnregistry ()
+ "Install the nnregistry refer method in `gnus-refer-article-method'."
+ (interactive)
+ (cond ((eq 'nnregistry gnus-refer-article-method))
+ ((null gnus-refer-article-method)
+ (setq gnus-refer-article-method 'nnregistry))
+ ((consp gnus-refer-article-method)
+ (unless (memq 'nnregistry gnus-refer-article-method)
+ (setq gnus-refer-article-method
+ (append gnus-refer-article-method '(nnregistry)))))
+ (t
+ (setq gnus-refer-article-method
+ (list gnus-refer-article-method 'nnregistry)))))
+
+(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-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)
+
+ (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
+
+(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
+
+(defun gnus-registry-install-p ()
+ (interactive)
+ (when (eq gnus-registry-install 'ask)
+ (setq gnus-registry-install
+ (gnus-y-or-n-p
+ (concat "Enable the Gnus registry? "
+ "See the variable `gnus-registry-install' "
+ "to get rid of this query permanently. ")))
+ (when gnus-registry-install
+ ;; we just set gnus-registry-install to t, so initialize the registry!
+ (gnus-registry-initialize)))
+;;; we could call it here: (customize-variable 'gnus-registry-install)
+ gnus-registry-install)
+
+;; TODO: a few things