branch: externals/hyperbole
commit 20468a62698bf8903fef67d0b1d3a05603874175
Merge: 6a01ea14d5 d5b20cd859
Author: Robert Weiner <r...@gnu.org>
Commit: GitHub <nore...@github.com>
Merge pull request #696 from rswgnu/rsw
Add hattr:actype-is-p and hattr:ibtype-is-p and use in tests
---
ChangeLog | 31 +++++++++++++++++++++++++++++++
hbut.el | 16 +++++++++++++++-
hui-mouse.el | 4 ++--
test/hmouse-drv-tests.el | 35 +++++++++++++++++++++++++++++------
test/hsys-org-tests.el | 25 +++++++++++++++----------
5 files changed, 92 insertions(+), 19 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index b1ef3a5c9d..479762bb6b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,37 @@
2025-04-13 Bob Weiner <r...@gnu.org>
+* test/hsys-org-tests.el (hsys-org--meta-return-on-end-of-line): Add
+ mocks back in to prevent scrolling eob or bob errors.
+
+* test/hmouse-drv-tests.el (hbut-man-apropos-test, hbut-info-node-test,
+ hbut-ib-url-with-label, hbut-mail-address-test,
+ hbut-pathname-test, hbut-pathname-lisp-variable-test,
+ hbut-pathname-env-variable-test,
+ hbut-pathname-emacs-lisp-file-test, hbut-pathname-line-test,
+ hbut-pathname-line-test-duplicate, hbut-pathname-anchor-test,
+ hbut-pathname-anchor-trailing-text, hbut-pathname-anchor-line-test,
+ hbut-pathname-line-column-test,
+ hbut-pathname-load-path-line-column-test,
+ hbut-pathname-with-dash-loads-file-test,
+ hbut-pathname-directory-test,
+ hbut-pathname-dot-slash-in-other-folder-should-fail-test,
+ hbut-ctags-vgrind-test, hbut-etags-test, hbut-dir-summary-test):
+ Test for ibtype match after calling (action-key).
+
+* hui-mouse.el (hkey-alist): When (smart-eolp), use hact instead of
+ funcall to run action/assist-key-eol-functions.
+
+* test/hsys-org-tests.el (hsys-org--org-outside-org-mode-tmp-buffer,
+ hsys-org--org-outside-org-mode-tmp-file): Test
+ for ibtype match instead of actype.
+* test/hmouse-drv-tests.el (hbut-rfc-test):
+ test/hsys-org-tests.el (hsys-org--meta-return-on-end-of-line,
+ hsys-org--meta-return-on-end-of-line): Replace
+ all mock calls with hattr:actype-is-p checks instead.
+
* hbut.el (hattr:is-p): Add to abstract testing of hattr values.
+ (hattr:actype-is-p, hattr:ibtype-is-p): Add these convenience
+ functions for testing for specific ibtype and actype activations.
* hsys-org.el (hsys-org-thing-at-p): Fix to work outside of Org mode by
suppressing warnings and ignoring Org regex errors. This fixes two
diff --git a/hbut.el b/hbut.el
index a6d1df8155..c314e023c5 100644
--- a/hbut.el
+++ b/hbut.el
@@ -3,7 +3,7 @@
;; Author: Bob Weiner
;;
;; Orig-Date: 18-Sep-91 at 02:57:09
-;; Last-Mod: 13-Apr-25 at 11:20:12 by Bob Weiner
+;; Last-Mod: 13-Apr-25 at 14:34:35 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -891,6 +891,13 @@ Return the symbol for the button when found, else nil."
;;; hattr class
;;; ========================================================================
+(defun hattr:actype-is-p (actype-symbol &optional hbut-symbol)
+ "Return t if ACTYPE-SYMBOL matches an hbut's 'actype attr value.
+The hbut used defaults to 'hbut:current or the optional HBUT-SYMBOL."
+ (hattr:is-p 'actype
+ (or (actype:def-symbol actype-symbol) actype-symbol)
+ hbut-symbol))
+
(defun hattr:attributes (obj-symbol)
"Return a list of OBJ-SYMBOL's attributes as symbols."
(when (symbolp obj-symbol)
@@ -947,6 +954,13 @@ Return TO-HBUT."
"Return value of OBJ-SYMBOL's attribute ATTR-SYMBOL."
(get obj-symbol attr-symbol))
+(defun hattr:ibtype-is-p (ibtype-symbol &optional ibut-symbol)
+ "Return t if IBTYPE-SYMBOL matches an ibut's 'categ attr value.
+The ibut used defaults to 'hbut:current or the optional IBUT-SYMBOL."
+ (hattr:is-p 'categ
+ (or (ibtype:elisp-symbol ibtype-symbol) ibtype-symbol)
+ ibut-symbol))
+
(defun hattr:is-p (attr value &optional hbut-symbol)
"Return t if ATTR has VALUE for 'hbut:current or optional HBUT-SYMBOL."
(and (symbolp attr) attr
diff --git a/hui-mouse.el b/hui-mouse.el
index 30af357e44..49f95df4db 100644
--- a/hui-mouse.el
+++ b/hui-mouse.el
@@ -3,7 +3,7 @@
;; Author: Bob Weiner
;;
;; Orig-Date: 04-Feb-89
-;; Last-Mod: 12-Apr-25 at 14:29:25 by Bob Weiner
+;; Last-Mod: 13-Apr-25 at 14:49:05 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -296,7 +296,7 @@ Its default value is `smart-scroll-down'. To disable it,
set it to
((and (smart-eolp)
(not (and (funcall hsys-org-mode-function)
(not (equal hsys-org-enable-smart-keys t)))))
- . ((funcall action-key-eol-function) . (funcall assist-key-eol-function)))
+ . ((hact action-key-eol-function) . (hact assist-key-eol-function)))
;;
;; Handle any Org mode-specific contexts but give priority to Hyperbole
;; buttons prior to cycling Org headlines
diff --git a/test/hmouse-drv-tests.el b/test/hmouse-drv-tests.el
index bea869e7a6..64de76646c 100644
--- a/test/hmouse-drv-tests.el
+++ b/test/hmouse-drv-tests.el
@@ -3,7 +3,7 @@
;; Author: Mats Lidell <ma...@gnu.org>
;;
;; Orig-Date: 28-Feb-21 at 22:52:00
-;; Last-Mod: 16-Jun-24 at 18:46:42 by Mats Lidell
+;; Last-Mod: 13-Apr-25 at 15:43:05 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -182,7 +182,8 @@
(insert "<[PR34]>: \"https://github.com/rswgnu/hyperbole/pull/34\"";)
(goto-char 4)
(let ((browse-url-browser-function 'hbut-defal-url))
- (action-key))))
+ (action-key))
+ (should (hattr:ibtype-is-p 'www-url))))
(ert-deftest hbut-ib-create-label ()
"Create a label for an implicit button."
@@ -244,7 +245,8 @@
(goto-char 2)
(let ((mail-user-agent 'sendmail-user-agent))
(action-key))
- (should (string= "*mail*" (buffer-name))))
+ (should (hattr:ibtype-is-p 'mail-address))
+ (should (string-match "mail\\*" (buffer-name))))
(hy-test-helpers:kill-buffer "*mail*")))
;; Path name
@@ -255,6 +257,7 @@
(goto-char 2)
(let ((enable-local-variables nil))
(action-key))
+ (should (hattr:ibtype-is-p 'pathname))
(should (string= "DEMO" (buffer-name))))
(hy-test-helpers:kill-buffer "DEMO")))
@@ -265,6 +268,7 @@
(goto-char 2)
(let ((enable-local-variables nil))
(action-key))
+ (should (hattr:ibtype-is-p 'pathname))
(should (string= "DEMO" (buffer-name))))
(hy-test-helpers:kill-buffer "DEMO")))
@@ -273,6 +277,7 @@
(insert "\"${HOME}\"")
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname))
(should (equal major-mode 'dired-mode))
(should (equal (expand-file-name default-directory)
(file-name-as-directory (getenv "HOME"))))))
@@ -283,6 +288,7 @@
(insert "\"hyperbole.el\"")
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname))
(should (equal major-mode 'emacs-lisp-mode))
(should (hypb:buffer-file-name))
(should (string= "hyperbole.el" (buffer-name))))
@@ -297,6 +303,7 @@
(insert (concat "\"" file ":1\""))
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname-line-and-column))
(should (string= file (hypb:buffer-file-name)))
(should (looking-at "Line1")))
(hy-delete-file-and-buffer file))))
@@ -316,6 +323,7 @@
(should (looking-at-p (concat "\"" file ":2\"")))
(forward-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname-line-and-column))
(should (string= file (hypb:buffer-file-name)))
(should (looking-at "Line2")))
(hy-delete-file-and-buffer file)
@@ -330,6 +338,7 @@
(insert (concat "\"" file "#Anchor\""))
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname))
(should (string= file (hypb:buffer-file-name)))
(should (looking-at "\* Anchor")))
(hy-delete-file-and-buffer file))))
@@ -343,6 +352,7 @@
(insert (concat "\"" file "#Anchor Plus\""))
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname))
(should (string= file (hypb:buffer-file-name)))
(should (looking-at "\* Anchor Plus \(Parenthesised text follows\)")))
(hy-delete-file-and-buffer file))))
@@ -372,6 +382,7 @@
(insert (concat "\"" file "#Anchor:2\""))
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname-line-and-column))
(should (string= file (hypb:buffer-file-name)))
(should (looking-at "Next Line")))
(hy-delete-file-and-buffer file))))
@@ -385,6 +396,7 @@
(insert (concat "\"" file "#Anchor:2:5\""))
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname-line-and-column))
(should (string= file (hypb:buffer-file-name)))
(should (= (line-number-at-pos) 3))
(should (= (current-column) 5))
@@ -398,6 +410,7 @@
(insert "\"${load-path}/hypb.el:11:5\"")
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname-line-and-column))
(should (string= "hypb.el" (buffer-name)))
(should (= (line-number-at-pos) 11))
(should (= (current-column) 5)))
@@ -409,6 +422,7 @@
(insert "\"-${hyperb:dir}/test/hy-test-dependencies.el\"")
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname))
(hy-test-helpers:should-last-message "Loading")
(hy-test-helpers:should-last-message "hy-test-dependencies.el")))
@@ -419,6 +433,7 @@
(insert "\"/tmp\"")
(goto-char 2)
(action-key)
+ (should (hattr:ibtype-is-p 'pathname))
(should (string-equal default-directory "/tmp/"))
(should (eq major-mode 'dired-mode)))
(hy-test-helpers:kill-buffer "tmp")))
@@ -434,6 +449,7 @@
(action-key)
(error
(progn
+ (should-not (hattr:ibtype-is-p 'pathname))
(should (equal (car err) 'error))
(should (string-match
"(Hyperbole Action Key): No action defined for this
context; try another location"
@@ -450,6 +466,7 @@
(forward-char 4)
(let ((default-directory (expand-file-name "test" hyperb:dir)))
(action-key)
+ (should (hattr:ibtype-is-p 'ctags))
(should (looking-at "(defun hy-test-helpers:consume-input-events"))))
(hy-test-helpers:kill-buffer "hy-test-helpers.el")))
@@ -467,6 +484,7 @@
(forward-char 10)
(let ((default-directory (expand-file-name "test" hyperb:dir)))
(action-key)
+ (should (hattr:ibtype-is-p 'etags))
(set-buffer "hy-test-helpers.el")
(should (looking-at "(defun hy-test-helpers:consume-input-events"))))
(hy-test-helpers:kill-buffer "hy-test-helpers.el")))
@@ -479,6 +497,7 @@
(goto-char (point-min))
(re-search-forward "^[ \t]*\\* Koutl")
(action-key)
+ (should (hattr:ibtype-is-p 'text-toc))
(should (bolp))
(should (looking-at "^[ \t]*\\* Koutliner")))
(hy-test-helpers:kill-buffer "DEMO")))
@@ -493,6 +512,7 @@
(forward-char -2)
(let ((hpath:display-where 'this-window))
(action-key)
+ (should (hattr:ibtype-is-p 'dir-summary))
(should (string= "HY-ABOUT" (buffer-name)))))
(hy-test-helpers:kill-buffer "MANIFEST")
(hy-test-helpers:kill-buffer "HY-ABOUT")))
@@ -505,7 +525,8 @@
(goto-char 2)
(with-mock
(mock (actypes::link-to-rfc "822") => t)
- (should (action-key))))))
+ (should (action-key))
+ (should (hattr:ibtype-is-p 'rfc))))))
;; man-apropos
(ert-deftest hbut-man-apropos-test ()
@@ -514,7 +535,8 @@
(goto-char 4)
(with-mock
(mock (man "rm(1)") => t)
- (action-key))))
+ (should (action-key))
+ (should (hattr:ibtype-is-p 'man-apropos)))))
;; info-node
(ert-deftest hbut-info-node-test ()
@@ -524,6 +546,7 @@
(insert "\"(emacs)Top\"")
(goto-char 6)
(action-key)
+ (should (hattr:ibtype-is-p 'Info-node))
(should (string= "*info*" (buffer-name))))
(hy-test-helpers:kill-buffer "*info*")))
@@ -566,7 +589,7 @@
(should was-called)))))
(ert-deftest hbut-load-modifier-with-plain-file-loads-file-from-load-path ()
- "Path prefix - filename without directory will load from`load-path'."
+ "Path prefix - filename without directory will load from `load-path'."
(setq features (delq 'tutorial features))
(with-temp-buffer
(insert "\"-tutorial.el\"")
diff --git a/test/hsys-org-tests.el b/test/hsys-org-tests.el
index f982599afe..0e2790c01a 100644
--- a/test/hsys-org-tests.el
+++ b/test/hsys-org-tests.el
@@ -3,7 +3,7 @@
;; Author: Mats Lidell <ma...@gnu.org>
;;
;; Orig-Date: 23-Apr-21 at 20:55:00
-;; Last-Mod: 13-Apr-25 at 11:23:02 by Bob Weiner
+;; Last-Mod: 13-Apr-25 at 16:20:45 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -141,7 +141,7 @@ This is independent of the setting of
`hsys-org-enable-smart-keys'."
(goto-char 6)
(should (equal hsys-org-enable-smart-keys v)) ; Traceability
(should (action-key))
- (should (hattr:is-p 'actype #'org-open-at-point-global)))))))
+ (should (hattr:ibtype-is-p 'org-link-outside-org-mode)))))))
(ert-deftest hsys-org--org-outside-org-mode-tmp-file ()
"Org links in a non `org-mode' file should work.
@@ -157,7 +157,7 @@ This is independent of the setting of
`hsys-org-enable-smart-keys'."
(mocklet (((org-open-at-point-global) => t))
(should (equal hsys-org-enable-smart-keys v)) ; Traceability
(should (action-key))
- (should (hattr:is-p 'actype #'org-open-at-point-global))))))
+ (should (hattr:ibtype-is-p 'org-link-outside-org-mode))))))
(hy-delete-file-and-buffer file))))
(ert-deftest hsys-org--at-tags-p ()
@@ -227,7 +227,7 @@ This is independent of the setting of
`hsys-org-enable-smart-keys'."
(should (string= "agenda-func" (hsys-org-get-agenda-tags #'agenda-func)))))
(ert-deftest hsys-org--meta-return-on-end-of-line ()
- "Verify end-of-line behaves as `org-mode' when smart keys not enabled."
+ "Verify end-of-line behaves as `org-mode' when smart keys are not enabled."
(dolist (v '(nil :buttons))
(let ((hsys-org-enable-smart-keys v))
;; One line with text, no return: smart-org triggers with nil or
:buttons setting
@@ -239,7 +239,8 @@ This is independent of the setting of
`hsys-org-enable-smart-keys'."
(with-mock
(mock (hsys-org-meta-return) => t)
(should (equal hsys-org-enable-smart-keys v)) ; Ert traceability
- (should (action-key))))
+ (should (action-key))
+ (should (hattr:actype-is-p 'hsys-org-meta-return))))
;; Two lines with text and returns: smart-org triggers with nil or
:buttons setting
(with-temp-buffer
(org-mode)
@@ -249,7 +250,9 @@ This is independent of the setting of
`hsys-org-enable-smart-keys'."
(with-mock
(mock (hsys-org-meta-return) => t)
(should (equal hsys-org-enable-smart-keys v)) ; Ert traceability
- (should (action-key))))))
+ (should (action-key))
+ (should (hattr:actype-is-p 'hsys-org-meta-return))))))
+
(let ((hsys-org-enable-smart-keys t)
(v t))
;; One line with text, no return: smart-eolp triggers with t setting
@@ -260,8 +263,9 @@ This is independent of the setting of
`hsys-org-enable-smart-keys'."
(end-of-line)
(with-mock
(mock (smart-scroll-up) => t)
- (should (equal hsys-org-enable-smart-keys v)) ; Ert traceability
- (should (action-key))))
+ (should (equal hsys-org-enable-smart-keys v)) ; Ert traceability
+ (should (action-key))
+ (should (hattr:actype-is-p 'smart-scroll-up))))
;; Two lines with text and returns: smart-eolp triggers with t setting
(with-temp-buffer
(org-mode)
@@ -270,8 +274,9 @@ This is independent of the setting of
`hsys-org-enable-smart-keys'."
(end-of-line)
(with-mock
(mock (smart-scroll-up) => t)
- (should (equal hsys-org-enable-smart-keys v)) ; Ert traceability
- (should (action-key))))))
+ (should (equal hsys-org-enable-smart-keys v)) ; Ert traceability
+ (should (action-key))
+ (should (hattr:actype-is-p 'smart-scroll-up))))))
(provide 'hsys-org-tests)
