gmm-utils.el (gmm-called-interactively-p): Restore as a macro.

[gnus] / lisp / gnus-registry.el

diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el
index eac4ed7..5e20f5f 100644 (file)
--- a/lisp/gnus-registry.el
+++ b/lisp/gnus-registry.el
@@ -78,12 +78,6 @@
 
 (eval-when-compile (require 'cl))
 
 
 (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)
 (require 'gnus)
 (require 'gnus-int)
 (require 'gnus-sum)


@@ -96,7 +90,7 @@
 (defvar gnus-adaptive-word-syntax-table)
 
 (defvar gnus-registry-dirty t
 (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."
 
 (defgroup gnus-registry nil
   "The Gnus registry."


@@ -142,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."
 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))
 
   :group 'gnus-registry
   :type '(repeat regexp))
 


@@ -243,6 +238,7 @@ the Bit Bucket."
 
 (defcustom gnus-registry-max-pruned-entries nil
   "Maximum number of pruned entries in the registry, nil for unlimited."
 
 (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")))
   :group 'gnus-registry
   :type '(radio (const :format "Unlimited " nil)
                 (integer :format "Maximum number: %v")))


@@ -282,7 +278,7 @@ the Bit Bucket."
     :tracked nil)))
 
 (defvar gnus-registry-db (gnus-registry-make-db)
     :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)
 
 ;; top-level registry data management
 (defun gnus-registry-remake-db (&optional forsure)


@@ -416,9 +412,9 @@ This is not required after changing `gnus-registry-cache-file'."
 ;; 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 ()
 ;; 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
 this: (: gnus-registry-split-fancy-with-parent)
 
 This function tracks ALL backends, unlike


@@ -744,7 +740,7 @@ Overrides existing keywords with FORCE set non-nil."
   (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
 
 (defun gnus-registry-register-message-ids ()
   (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))
   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
     (dolist (article gnus-newsgroup-articles)
       (let* ((id (gnus-registry-fetch-message-id-fast article))


@@ -759,7 +755,7 @@ Overrides existing keywords with FORCE set non-nil."
 
 ;; message field fetchers
 (defun gnus-registry-fetch-message-id-fast (article)
 
 ;; 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))))
   (if (and (numberp article)
            (assoc article (gnus-data-list nil)))
       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))


@@ -791,7 +787,7 @@ Addresses without a name will say \"noname\"."
     nil))
 
 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
     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
   (if (and (numberp article)
            (assoc article (gnus-data-list nil)))
       (gnus-string-remove-all-properties


@@ -809,7 +805,7 @@ 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)
    (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
   (if (and (numberp article)
            (assoc article (gnus-data-list nil)))
       (gnus-string-remove-all-properties


@@ -829,7 +825,34 @@ FUNCTION should take two parameters, a mark symbol and the cell value."
       (when cell-data
         (funcall function mark cell-data)))))
 
       (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."
 (defun gnus-registry-install-shortcuts ()
   "Install the keyboard shortcuts and menus for the registry.
 Uses `gnus-registry-marks' to find what shortcuts to install."


@@ -841,69 +864,41 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
        (let ((function-format
               (format "gnus-registry-%%s-article-%s-mark" mark)))
 
        (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"))
 
          (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
-                 (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
-                    (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))
              (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-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)
     (gnus-define-keys-1
      '(gnus-registry-mark-map "M" gnus-summary-mark-map)
      keys-plist)


@@ -923,7 +918,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
 ;; use like this:
 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
 (defun gnus-registry-article-marks-to-chars (headers)
 ;; 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"
+  "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)
   (let* ((id (mail-header-message-id headers))
          (marks (when id (gnus-registry-get-id-key id 'mark))))
     (mapconcat (lambda (mark)


@@ -936,7 +931,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
 ;; use like this:
 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
 (defun gnus-registry-article-marks-to-names (headers)
 ;; 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"
+  "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))))
     (mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
   (let* ((id (mail-header-message-id headers))
          (marks (when id (gnus-registry-get-id-key id 'mark))))
     (mapconcat (lambda (mark) (symbol-name mark)) marks ",")))


@@ -987,7 +982,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))))
   (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))
 
       (gnus-message 1 "Marks are %S" marks))
     marks))
 


@@ -1076,88 +1071,16 @@ only the last one's marks are returned."
             (gnus-registry-set-id-key id key val))))
       (message "Import done, collected %d entries" count))))
 
             (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 <tzz@lifelogs.com>"
-                   "noname <ed@you.me>"
-                   "noname <cyd@stupidchicken.com>"
-                   "noname <tzz@lifelogs.com>")
-                 (gnus-registry-extract-addresses
-                  (concat "Ted Zlatanov <tzz@lifelogs.com>, "
-                          "ed <ed@you.me>, " ; "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 (gnus-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 ()
 ;;;###autoload
 (defun gnus-registry-initialize ()

-"Initialize the Gnus registry."
+  "Initialize the Gnus registry."

   (interactive)
   (gnus-message 5 "Initializing the registry")
   (gnus-registry-install-hooks)
   (gnus-registry-install-shortcuts)
   (gnus-registry-read))
 
   (interactive)
   (gnus-message 5 "Initializing the registry")
   (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."
 ;;;###autoload
 (defun gnus-registry-install-hooks ()
   "Install the registry hooks."


@@ -1204,6 +1127,53 @@ the user is asked first.  Returns non-nil iff the registry is enabled."
       (gnus-registry-initialize)))
   gnus-registry-enabled)
 
       (gnus-registry-initialize)))
   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
 
 (provide 'gnus-registry)
 ;; TODO: a few things
 
 (provide 'gnus-registry)