X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=829734f17c3c1e153c72fe15f73e8cae9917680d;hp=3dbffd98333d341d71bd9818e6cb62447cf166bb;hb=68819187129126e5cfb9aa0cf0249f98cddc375c;hpb=1c149399d21d6a36c2ccf0b2e28addc52a4f926d diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 3dbffd983..829734f17 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -1,6 +1,6 @@ ;;; gnus-registry.el --- article registry for Gnus -;; Copyright (C) 2002-2011 Free Software Foundation, Inc. +;; Copyright (C) 2002-2013 Free Software Foundation, Inc. ;; Author: Ted Zlatanov ;; Keywords: news registry @@ -31,7 +31,17 @@ ;; gnus-registry.el intercepts article respooling, moving, deleting, ;; and copying for all backends. If it doesn't work correctly for ;; you, submit a bug report and I'll be glad to fix it. It needs -;; documentation in the manual (also on my to-do list). +;; better documentation in the manual (also on my to-do list). + +;; If you want to track recipients (and you should to make the +;; gnus-registry splitting work better), you need the To and Cc +;; headers collected by Gnus. Note that in more recent Gnus versions +;; this is already the case: look at `gnus-extra-headers' to be sure. + +;; ;;; you may also want Gcc Newsgroups Keywords X-Face +;; (add-to-list 'gnus-extra-headers 'To) +;; (add-to-list 'gnus-extra-headers 'Cc) +;; (setq nnmail-extra-headers gnus-extra-headers) ;; Put this in your startup file (~/.gnus.el for instance) or use Customize: @@ -47,6 +57,16 @@ ;; You should also consider using the nnregistry backend to look up ;; articles. See the Gnus manual for more information. +;; Finally, you can put %uM in your summary line format to show the +;; registry marks if you do this: + +;; show the marks as single characters (see the :char property in +;; `gnus-registry-marks'): +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) + +;; show the marks by name (see `gnus-registry-marks'): +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) + ;; TODO: ;; - get the correct group on spool actions @@ -58,12 +78,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile - (when (null (ignore-errors (require 'ert))) - (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) - -(ignore-errors - (require 'ert)) (require 'gnus) (require 'gnus-int) (require 'gnus-sum) @@ -76,7 +90,7 @@ (defvar gnus-adaptive-word-syntax-table) (defvar gnus-registry-dirty t - "Boolean set to t when the registry is modified") + "Boolean set to t when the registry is modified.") (defgroup gnus-registry nil "The Gnus registry." @@ -122,6 +136,7 @@ display.") The addresses are matched, they don't have to be fully qualified. In the messages, these addresses can be the sender or the recipients." + :version "24.1" :group 'gnus-registry :type '(repeat regexp)) @@ -144,6 +159,8 @@ nnmairix groups are specifically excluded because they are ephemeral." (const :tag "Always Install" t) (const :tag "Ask Me" ask))) +(defvar gnus-registry-enabled nil) + (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. (defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus @@ -221,6 +238,7 @@ the Bit Bucket." (defcustom gnus-registry-max-pruned-entries nil "Maximum number of pruned entries in the registry, nil for unlimited." + :version "24.1" :group 'gnus-registry :type '(radio (const :format "Unlimited " nil) (integer :format "Maximum number: %v"))) @@ -234,6 +252,8 @@ the Bit Bucket." (oset db :max-hard (or gnus-registry-max-entries most-positive-fixnum)) + (oset db :prune-factor + 0.1) (oset db :max-soft (or gnus-registry-max-pruned-entries most-positive-fixnum)) @@ -241,7 +261,7 @@ the Bit Bucket." (append gnus-registry-track-extra '(mark group keyword))) (when (not (equal old (oref db :tracked))) - (gnus-message 4 "Reindexing the Gnus registry (tracked change)") + (gnus-message 9 "Reindexing the Gnus registry (tracked change)") (registry-reindex db)))) db) @@ -258,7 +278,7 @@ the Bit Bucket." :tracked nil))) (defvar gnus-registry-db (gnus-registry-make-db) - "*The article registry by Message ID. See `registry-db'") + "The article registry by Message ID. See `registry-db'.") ;; top-level registry data management (defun gnus-registry-remake-db (&optional forsure) @@ -276,8 +296,13 @@ This is not required after changing `gnus-registry-cache-file'." (condition-case nil (progn (gnus-message 5 "Reading Gnus registry from %s..." file) - (setq gnus-registry-db (gnus-registry-fixup-registry - (eieio-persistent-read file))) + (setq gnus-registry-db + (gnus-registry-fixup-registry + (condition-case nil + (eieio-persistent-read file 'registry-db) + ;; Older EIEIO versions do not check the class name. + ('wrong-number-of-arguments + (eieio-persistent-read file))))) (gnus-message 5 "Reading Gnus registry from %s...done" file)) (error (gnus-message @@ -299,13 +324,28 @@ This is not required after changing `gnus-registry-cache-file'." (gnus-message 5 "Saving Gnus registry (size %d) to %s...done" (registry-size db) file))) +(defun gnus-registry-remove-ignored () + (interactive) + (let* ((db gnus-registry-db) + (grouphashtb (registry-lookup-secondary db 'group)) + (old-size (registry-size db))) + (registry-reindex db) + (loop for k being the hash-keys of grouphashtb + using (hash-values v) + when (gnus-registry-ignore-group-p k) + do (registry-delete db v nil)) + (registry-reindex db) + (gnus-message 4 "Removed %d ignored entries from the Gnus registry" + (- old-size (registry-size db))))) + ;; article move/copy/spool/delete actions (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) (subject (mail-header-subject data-header)) + (extra (mail-header-extra data-header)) (recipients (gnus-registry-sort-addresses - (or (cdr (assq "Cc" data-header)) "") - (or (cdr (assq "To" data-header)) ""))) + (or (cdr-safe (assq 'Cc extra)) "") + (or (cdr-safe (assq 'To extra)) ""))) (sender (nth 0 (gnus-registry-extract-addresses (mail-header-from data-header)))) (from (gnus-group-guess-full-name-from-command-method from)) @@ -323,9 +363,9 @@ This is not required after changing `gnus-registry-cache-file'." (defun gnus-registry-spool-action (id group &optional subject sender recipients) (let ((to (gnus-group-guess-full-name-from-command-method group)) (recipients (or recipients - (gnus-registry-sort-addresses - (or (message-fetch-field "cc") "") - (or (message-fetch-field "to") "")))) + (gnus-registry-sort-addresses + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") "")))) (subject (or subject (message-fetch-field "subject"))) (sender (or sender (message-fetch-field "from")))) (when (and (stringp id) (string-match "\r$" id)) @@ -341,6 +381,8 @@ This is not required after changing `gnus-registry-cache-file'." 10 "gnus-registry-handle-action %S" (list id from to subject sender recipients)) (let ((db gnus-registry-db) + ;; if the group is ignored, set the destination to nil (same as delete) + (to (if (gnus-registry-ignore-group-p to) nil to)) ;; safe if not found (entry (gnus-registry-get-or-make-entry id)) (subject (gnus-string-remove-all-properties @@ -370,14 +412,14 @@ This is not required after changing `gnus-registry-cache-file'." (gnus-message 10 "Gnus registry: new entry for %s is %S" id entry) - (registry-insert db id entry))) + (gnus-registry-insert db id entry))) ;; 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 + "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 function tracks ALL backends, unlike @@ -402,8 +444,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (sender (gnus-string-remove-all-properties (message-fetch-field "from"))) (recipients (gnus-registry-sort-addresses - (or (message-fetch-field "cc") "") - (or (message-fetch-field "to") ""))) + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") ""))) (subject (gnus-string-remove-all-properties (gnus-registry-simplify-subject (message-fetch-field "subject")))) @@ -643,6 +685,34 @@ Consults `gnus-registry-unfollowed-groups' and group nnmail-split-fancy-with-parent-ignore-groups))))) +;; note that gnus-registry-ignored-groups is defined in gnus.el as a +;; group/topic parameter and an associated variable! + +;; we do special logic for ignoring to accept regular expressions and +;; nnmail-split-fancy-with-parent-ignore-groups as well +(defun gnus-registry-ignore-group-p (group) + "Determines if a group name should be ignored. +Consults `gnus-registry-ignored-groups' and +`nnmail-split-fancy-with-parent-ignore-groups'." + (and group + (or (gnus-grep-in-list + group + (delq nil (mapcar (lambda (g) + (cond + ((stringp g) g) + ((and (listp g) (nth 1 g)) + (nth 0 g)) + (t nil))) gnus-registry-ignored-groups))) + ;; only use `gnus-parameter-registry-ignore' if + ;; `gnus-registry-ignored-groups' is a list of lists + ;; (it can be a list of regexes) + (and (listp (nth 0 gnus-registry-ignored-groups)) + (get-buffer "*Group*") ; in automatic tests this is false + (gnus-parameter-registry-ignore group)) + (gnus-grep-in-list + group + nnmail-split-fancy-with-parent-ignore-groups)))) + (defun gnus-registry-wash-for-keywords (&optional force) "Get the keywords of the current article. Overrides existing keywords with FORCE set non-nil." @@ -675,7 +745,7 @@ Overrides existing keywords with FORCE set non-nil." (registry-lookup-secondary-value gnus-registry-db 'keyword keyword)) (defun gnus-registry-register-message-ids () - "Register the Message-ID of every article in the group" + "Register the Message-ID of every article in the group." (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) (dolist (article gnus-newsgroup-articles) (let* ((id (gnus-registry-fetch-message-id-fast article)) @@ -690,7 +760,7 @@ Overrides existing keywords with FORCE set non-nil." ;; message field fetchers (defun gnus-registry-fetch-message-id-fast (article) - "Fetch the Message-ID quickly, using the internal gnus-data-list function" + "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)))) @@ -714,7 +784,7 @@ Addresses without a name will say \"noname\"." (defun gnus-registry-sort-addresses (&rest addresses) "Return a normalized and sorted list of ADDRESSES." (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses)) - 'string-lessp)) + 'string-lessp)) (defun gnus-registry-simplify-subject (subject) (if (stringp subject) @@ -722,7 +792,7 @@ Addresses without a name will say \"noname\"." nil)) (defun gnus-registry-fetch-simplified-message-subject-fast (article) - "Fetch the Subject quickly, using the internal gnus-data-list function" + "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 @@ -740,12 +810,12 @@ Addresses without a name will say \"noname\"." (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) ""))) (defun gnus-registry-fetch-header-fast (article header) - "Fetch the HEADER quickly, using the internal gnus-data-list function" + "Fetch the HEADER quickly, using the internal gnus-data-list function." (if (and (numberp article) (assoc article (gnus-data-list nil))) (gnus-string-remove-all-properties (cdr (assq header (gnus-data-header - (assoc article (gnus-data-list nil)))))) + (assoc article (gnus-data-list nil)))))) nil)) ;; registry marks glue @@ -760,7 +830,34 @@ FUNCTION should take two parameters, a mark symbol and the cell value." (when cell-data (funcall function mark cell-data))))) -;;; this is ugly code, but I don't know how to do it better +;; FIXME: Why not merge gnus-registry--set/remove-mark and +;; gnus-registry-set-article-mark-internal? +(defun gnus-registry--set/remove-mark (remove mark articles) + "Set/remove the MARK over process-marked ARTICLES." + ;; If this is called and the user doesn't want the + ;; registry enabled, we'll ask anyhow. + (unless gnus-registry-install + (let ((gnus-registry-install 'ask)) + (gnus-registry-install-p))) + + ;; 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. + mark articles remove t) + ;; FIXME: Why do we do the above only here and not directly inside + ;; gnus-registry-set-article-mark-internal? I.e. we wouldn't we want to do + ;; the things below when gnus-registry-set-article-mark-internal is called + ;; from gnus-registry-set-article-mark or + ;; gnus-registry-remove-article-mark? + (gnus-message 9 "Applying mark %s to %d articles" + mark (length articles)) + (dolist (article articles) + (gnus-summary-update-article + article + (assoc article (gnus-data-list nil)))))) + +;; 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." @@ -772,68 +869,41 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (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)) +;;; 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) + (function-name + (intern (format function-format variant-name))) + (shortcut (format "%c" (if remove (upcase data) data)))) + (defalias function-name + ;; If it weren't for the function's docstring, we could + ;; use a closure, with lexical-let :-( + `(lambda (&rest articles) + ,(format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark ',mark ',remove articles))) + (push function-name keys-plist) (push shortcut keys-plist) (push (vector (format "%s %s" (upcase-initials variant-name) (symbol-name mark)) - (intern function-name) t) + function-name t) gnus-registry-misc-menus) - (gnus-message - 9 - "Defined mark handling function %s" - function-name)))))) + (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) @@ -844,22 +914,32 @@ Uses `gnus-registry-marks' to find what shortcuts to install." 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) +(make-obsolete 'gnus-registry-user-format-function-M + 'gnus-registry-article-marks-to-chars "24.1") ? + +(defalias 'gnus-registry-user-format-function-M + 'gnus-registry-article-marks-to-chars) + +;; use like this: +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +(defun gnus-registry-article-marks-to-chars (headers) + "Show the marks for an article by the :char property." + (let* ((id (mail-header-message-id headers)) + (marks (when id (gnus-registry-get-id-key id 'mark)))) + (mapconcat (lambda (mark) + (plist-get + (cdr-safe + (assoc mark gnus-registry-marks)) + :char)) + marks ""))) + +;; use like this: +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +(defun gnus-registry-article-marks-to-names (headers) + "Show the marks for an article by name." (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (apply 'concat (mapcar (lambda (mark) - (let ((c - (plist-get - (cdr-safe - (assoc mark gnus-registry-marks)) - :char))) - (if c - (list c) - nil))) - marks)))) + (mapconcat (lambda (mark) (symbol-name mark)) marks ","))) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." @@ -907,7 +987,7 @@ only the last one's marks are returned." (let* ((article (last articles)) (id (gnus-registry-fetch-message-id-fast article)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (when (interactive-p) + (when (gmm-called-interactively-p 'any) (gnus-message 1 "Marks are %S" marks)) marks)) @@ -921,8 +1001,8 @@ only the last one's marks are returned." (entries (registry-lookup db (list id)))) (when (null entries) - (registry-insert db id (list (list 'creation-time (current-time)) - '(group) '(sender) '(subject))) + (gnus-registry-insert db id (list (list 'creation-time (current-time)) + '(group) '(sender) '(subject))) (setq entries (registry-lookup db (list id)))) (nth 1 (assoc id entries)))) @@ -938,9 +1018,17 @@ only the last one's marks are returned." (entry (gnus-registry-get-or-make-entry id))) (registry-delete db (list id) nil) (setq entry (cons (cons key vals) (assq-delete-all key entry))) - (registry-insert db id entry) + (gnus-registry-insert db id entry) entry)) +(defun gnus-registry-insert (db id entry) + "Just like `registry-insert' but tries to prune on error." + (when (registry-full db) + (message "Trying to prune the registry because it's full") + (registry-prune db)) + (registry-insert db id entry) + entry) + (defun gnus-registry-import-eld (file) (interactive "fOld registry file to import? ") ;; example content: @@ -974,7 +1062,7 @@ only the last one's marks are returned." extra-cell key val) ;; remove all the strings from the entry (dolist (elem rest) - (if (stringp elem) (setq rest (delq elem rest)))) + (if (stringp elem) (setq rest (delq elem rest)))) (gnus-registry-set-id-key id 'group groups) ;; just use the first extra element (setq rest (car-safe rest)) @@ -988,93 +1076,21 @@ only the last one's marks are returned." (gnus-registry-set-id-key id key val)))) (message "Import done, collected %d entries" count)))) -(ert-deftest gnus-registry-misc-test () - (should-error (gnus-registry-extract-addresses '("" ""))) - - (should (equal '("Ted Zlatanov " - "noname " - "noname " - "noname ") - (gnus-registry-extract-addresses - (concat "Ted Zlatanov , " - "ed , " ; "ed" is not a valid name here - "cyd@stupidchicken.com, " - "tzz@lifelogs.com"))))) - -(ert-deftest gnus-registry-usage-test () - (let* ((n 100) - (tempfile (make-temp-file "gnus-registry-persist")) - (db (gnus-registry-make-db tempfile)) - (gnus-registry-db db) - back size) - (message "Adding %d keys to the test Gnus registry" n) - (dotimes (i n) - (let ((id (number-to-string i))) - (gnus-registry-handle-action id - (if (>= 50 i) "fromgroup" nil) - "togroup" - (when (>= 70 i) - (format "subject %d" (mod i 10))) - (when (>= 80 i) - (format "sender %d" (mod i 10)))))) - (message "Testing Gnus registry size is %d" n) - (should (= n (registry-size db))) - (message "Looking up individual keys (registry-lookup)") - (should (equal (loop for e - in (mapcar 'cadr - (registry-lookup db '("20" "83" "72"))) - collect (assq 'subject e) - collect (assq 'sender e) - collect (assq 'group e)) - '((subject "subject 0") (sender "sender 0") (group "togroup") - (subject) (sender) (group "togroup") - (subject) (sender "sender 2") (group "togroup")))) - - (message "Looking up individual keys (gnus-registry-id-key)") - (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup"))) - (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4"))) - (message "Trying to insert a duplicate key") - (should-error (registry-insert db "55" '())) - (message "Looking up individual keys (gnus-registry-get-or-make-entry)") - (should (gnus-registry-get-or-make-entry "22")) - (message "Saving the Gnus registry to %s" tempfile) - (should (gnus-registry-save tempfile db)) - (setq size (nth 7 (file-attributes tempfile))) - (message "Saving the Gnus registry to %s: size %d" tempfile size) - (should (< 0 size)) - (with-temp-buffer - (insert-file-contents-literally tempfile) - (should (looking-at (concat ";; Object " - "Gnus Registry" - "\n;; EIEIO PERSISTENT OBJECT")))) - (message "Reading Gnus registry back") - (setq back (eieio-persistent-read tempfile)) - (should back) - (message "Read Gnus registry back: %d keys, expected %d==%d" - (registry-size back) n (registry-size db)) - (should (= (registry-size back) n)) - (should (= (registry-size back) (registry-size db))) - (delete-file tempfile) - (message "Pruning Gnus registry to 0 by setting :max-soft") - (oset db :max-soft 0) - (registry-prune db) - (should (= (registry-size db) 0))) - (message "Done with Gnus registry usage testing.")) - ;;;###autoload (defun gnus-registry-initialize () -"Initialize the Gnus registry." + "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) (gnus-registry-read)) +;; FIXME: Why autoload this function? ;;;###autoload (defun gnus-registry-install-hooks () "Install the registry hooks." (interactive) + (setq gnus-registry-enabled t) (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) @@ -1096,23 +1112,72 @@ only the last one's marks are returned." (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)) + (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) + (setq gnus-registry-enabled nil)) (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) (defun gnus-registry-install-p () + "If the registry is not already enabled, and `gnus-registry-install' is t, +the registry is enabled. If `gnus-registry-install' is `ask', +the user is asked first. Returns non-nil iff the registry is enabled." (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! + (unless gnus-registry-enabled + (when (if (eq gnus-registry-install 'ask) + (gnus-y-or-n-p + (concat "Enable the Gnus registry? " + "See the variable `gnus-registry-install' " + "to get rid of this query permanently. ")) + gnus-registry-install) (gnus-registry-initialize))) -;;; we could call it here: (customize-variable 'gnus-registry-install) - gnus-registry-install) + gnus-registry-enabled) + +;; largely based on nnir-warp-to-article +(defun gnus-try-warping-via-registry () + "Try to warp via the registry. +This will be done via the current article's source group based on +data stored in the registry." + (interactive) + (when (gnus-summary-article-header) + (let* ((message-id (mail-header-id (gnus-summary-article-header))) + ;; Retrieve the message's group(s) from the registry + (groups (gnus-registry-get-id-key message-id 'group)) + ;; If starting from an ephemeral group, this describes + ;; how to restore the window configuration + (quit-config + (gnus-ephemeral-group-p gnus-newsgroup-name)) + (seen-groups (list (gnus-group-group-name)))) + + (catch 'found + (dolist (group (mapcar 'gnus-simplify-group-name groups)) + + ;; skip over any groups we really don't want to warp to. + (unless (or (member group seen-groups) + (gnus-ephemeral-group-p group) ;; any ephemeral group + (memq (car (gnus-find-method-for-group group)) + ;; Specific methods; this list may need to expand. + '(nnir))) + + ;; remember that we've seen this group already + (push group seen-groups) + + ;; first exit from any ephemeral summary buffer. + (when quit-config + (gnus-summary-exit) + ;; and if the ephemeral summary buffer in turn came from + ;; another summary buffer we have to clean that summary + ;; up too. + (when (eq (cdr quit-config) 'summary) + (gnus-summary-exit)) + ;; remember that we've already done this part + (setq quit-config nil)) + + ;; Try to activate the group. If that fails, just move + ;; along. We may have more groups to work with + (when + (ignore-errors + (gnus-select-group-with-message-id group message-id) t) + (throw 'found t)))))))) ;; TODO: a few things