[elpa] externals/hyperbole 716507c51c 16/19: Fix a number of issues with ibut attribute handling

[ELPA Syncer]

branch: externals/hyperbole
commit 716507c51c7435167cc954c2d5d2a1eb38ab81ed
Author: Bob Weiner <rsw@gnu.org>
Commit: Bob Weiner <rsw@gnu.org>

    Fix a number of issues with ibut attribute handling
---
 ChangeLog           |  15 +++++--
 hbut.el             | 117 +++++++++++++++++++++++++++++++++-------------------
 hibtypes.el         |  15 +++++--
 hpath.el            |  74 +++++++++++++++++----------------
 test/hpath-tests.el |   9 ++--
 5 files changed, 140 insertions(+), 90 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5617e81393..20459163a1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,19 @@
+2022-07-24  Bob Weiner  <rsw@gnu.org>
+
+* hibtypes.el (action): Ensure actypes:: prefix is added to any action
+    attribute that uses a Hyperbole actype.  Also, set args attribute
+    to exclude the actype.
+
+* hbut.el (ibut:create): Rewrite to prefer values from hbut:current
+    over any passed in individually.
+
 * test/demo-tests.el (fast-demo-key-series-shell-cd-hyperb-dir):
   FAST-DEMO: Change pushd to cd since /bin/sh does not support pushd.
 
-2022-07-23  Bob Weiner  <rsw@gnu.org>
+* hpath.el (hpath:find): Rename filename arg to pathname and trigger
+    an error if not a string.
 
-* hbut.el (ibut:to): Clear any hbut:current attributes before trying
-   to find the matching ibut.
+2022-07-23  Bob Weiner  <rsw@gnu.org>
 
 * hibtypes.el (action): Display the result of evaluating the action
     in the minibuffer for all types of expressions.
diff --git a/hbut.el b/hbut.el
index 724ecdac73..44ee56a214 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:     23-Jul-22 at 23:39:56 by Bob Weiner
+;; Last-Mod:     24-Jul-22 at 10:29:28 by Bob Weiner
 ;;
 ;; Copyright (C) 1991-2022  Free Software Foundation, Inc.
 ;; See the "HY-COPY" file for license information.
@@ -1581,48 +1581,80 @@ Return nil if no implicit button at point."
 
       (set-marker ibpoint nil)
 
-      (unless name
-       (setq name (ibut:label-p t nil nil nil t)))
-      (unless (and lbl-key lbl-start lbl-end)
-       (setq lbl-key-start-end (ibut:label-p nil "\"" "\"" t t)))
-      (unless lbl-key
-       (setq lbl-key (or (ibut:label-to-key name)
-                         (nth 0 lbl-key-start-end))))
-      (unless lbl-start
-       (setq lbl-start (nth 1 lbl-key-start-end)))
-      (unless lbl-end
-       (setq lbl-end (nth 2 lbl-key-start-end)))
-
       (when is-type
-       (when name
-         (hattr:set 'hbut:current 'name name))
-       (when lbl-start
-         (hattr:set 'hbut:current 'lbl-start lbl-start))
-       (when lbl-end
-         (hattr:set 'hbut:current 'lbl-end lbl-end))
-       (hattr:set 'hbut:current 'categ is-type)
-       (when lbl-key
-         (hattr:set 'hbut:current 'lbl-key lbl-key))
-       (hattr:set 'hbut:current 'loc (or loc (save-excursion
-                                               (hbut:key-src 'full))))
-       (hattr:set 'hbut:current 'dir (or dir (hui:key-dir (current-buffer))))
-       (when action
-         (hattr:set 'hbut:current 'action action)
-         (unless args (setq args action)))
-       (or (hattr:get 'hbut:current 'args)
-           (not (listp args))
-           (progn
-             (setq args (copy-sequence args))
-             (when (eq (car args) #'hact)
-               (setq args (cdr args)))
-             (hattr:set 'hbut:current 'actype
-                        (or
-                         actype
-                         ;; Hyperbole action type
-                         (symtable:actype-p (car args))
-                         ;; Regular Emacs Lisp function symbol
-                         (car args)))
-             (hattr:set 'hbut:current 'args (if actype args (cdr args)))))
+       (let ((current-name      (hattr:get 'hbut:current 'name))
+             (current-lbl-key   (hattr:get 'hbut:current 'lbl-key))
+             (current-lbl-start (hattr:get 'hbut:current 'lbl-start))
+             (current-lbl-end   (hattr:get 'hbut:current 'lbl-end))
+             (current-categ     (hattr:get 'hbut:current 'categ))
+             (current-loc       (hattr:get 'hbut:current 'loc))
+             (current-dir       (hattr:get 'hbut:current 'dir))
+             (current-action    (hattr:get 'hbut:current 'action))
+             (current-actype    (hattr:get 'hbut:current 'actype))
+             (current-args      (hattr:get 'hbut:current 'args)))
+
+         (if current-name
+             (setq name current-name)
+           (unless name
+             (setq name (ibut:label-p t nil nil nil t)))
+           (when name
+             (hattr:set 'hbut:current 'name name)))
+
+         (if current-lbl-key
+             (setq lbl-key current-lbl-key)
+           (unless lbl-key
+             (setq lbl-key (or (ibut:label-to-key name)
+                               (ibut:label-p nil "\"" "\"" nil t))))
+           (when lbl-key
+             (hattr:set 'hbut:current 'lbl-key lbl-key)))
+
+         (if current-lbl-start
+             (setq lbl-start current-lbl-start)
+           (when lbl-start
+             (hattr:set 'hbut:current 'lbl-start lbl-start)))
+
+         (if current-lbl-end
+             (setq lbl-end current-lbl-end)
+           (when lbl-end
+             (hattr:set 'hbut:current 'lbl-end lbl-end)))
+
+         (hattr:set 'hbut:current 'categ is-type)
+
+         (if current-loc
+             (setq loc current-loc)
+           (unless loc
+             (setq loc (save-excursion (hbut:key-src 'full))))
+           (when loc
+             (hattr:set 'hbut:current 'loc loc)))
+
+         (if current-dir
+             (setq dir current-dir)
+           (unless dir
+             (setq dir (hui:key-dir (current-buffer))))
+           (when dir
+             (hattr:set 'hbut:current 'dir dir)))
+
+         (if current-action
+             (setq action current-action)
+           (when action
+             (hattr:set 'hbut:current 'action action)))
+         (when action
+           (unless args (setq args action)))
+
+         (or current-args
+             (not (listp args))
+             (progn
+               (setq args (copy-sequence args))
+               (when (eq (car args) #'hact)
+                 (setq args (cdr args)))
+               (hattr:set 'hbut:current 'actype
+                          (or
+                           actype
+                           ;; Hyperbole action type
+                           (symtable:actype-p (car args))
+                           ;; Regular Emacs Lisp function symbol
+                           (car args)))
+               (hattr:set 'hbut:current 'args (if actype args (cdr args))))))
        'hbut:current))))
 
 (defun    ibut:delete (&optional but-sym)
@@ -1839,7 +1871,6 @@ the whole buffer."
   "Find the nearest implicit button with LBL-KEY (a label or label key) within 
the visible portion of the current buffer.
 Leave point inside the button text or its optional label, if it has one.
 Return the symbol for the button, else nil."
-  (hattr:clear 'hbut:current)
   (unless lbl-key
     (setq lbl-key (ibut:label-p nil nil nil nil t)))
   (hbut:funcall (lambda (lbl-key _buffer _key-src)
diff --git a/hibtypes.el b/hibtypes.el
index ba6580f93d..fe0a409052 100644
--- a/hibtypes.el
+++ b/hibtypes.el
@@ -3,7 +3,7 @@
 ;; Author:       Bob Weiner
 ;;
 ;; Orig-Date:    19-Sep-91 at 20:45:31
-;; Last-Mod:     23-Jul-22 at 22:32:54 by Bob Weiner
+;; Last-Mod:     24-Jul-22 at 09:46:12 by Bob Weiner
 ;;
 ;; Copyright (C) 1991-2022 Free Software Foundation, Inc.
 ;; See the "HY-COPY" file for license information.
@@ -1417,22 +1417,29 @@ arg1 ... argN '>'.  For example, <mail nil 
\"user@somewhere.org\">."
       (when actype
         (setq action (read (concat "(" lbl ")"))
               args (cdr action))
+       ;; Ensure action uses an fboundp symbol if executing a
+       ;; Hyperbole actype.
+       (setq a action)
+       (when (and (car action) (symbolp (car action)))
+         (setcar action
+                 (or (intern-soft (concat "actypes::" (symbol-name (car 
action))))
+                     (car action))))
        (unless assist-flag
           (cond ((and (symbolp actype) (fboundp actype)
                       (string-match "-p\\'" (symbol-name actype)))
                 ;; Is a function with a boolean result
-                (setq args `(',action)
+                (setq args `(',args)
                       action `(display-boolean ',action)
                        actype #'display-boolean))
                ((and (null args) (symbolp actype) (boundp actype)
                       (or var-flag (not (fboundp actype))))
                 ;; Is a variable, display its value as the action
-                (setq args `(',actype)
+                (setq args `(',args)
                        action `(display-variable ',actype)
                        actype #'display-variable))
                (t
                 ;; All other expressions, display the action result in the 
minibuffer
-                (setq args `(',action)
+                (setq args `(',args)
                        action `(display-value ',action)
                        actype #'display-value))))
 
diff --git a/hpath.el b/hpath.el
index 90ef169315..b8c042c992 100644
--- a/hpath.el
+++ b/hpath.el
@@ -3,7 +3,7 @@
 ;; Author:       Bob Weiner
 ;;
 ;; Orig-Date:     1-Nov-91 at 00:44:23
-;; Last-Mod:     17-Jul-22 at 09:55:47 by Bob Weiner
+;; Last-Mod:     24-Jul-22 at 01:02:25 by Bob Weiner
 ;;
 ;; Copyright (C) 1991-2022  Free Software Foundation, Inc.
 ;; See the "HY-COPY" file for license information.
@@ -1250,20 +1250,20 @@ program), else nil.
 See `hpath:find' documentation for acceptable formats of FILENAME."
   (hpath:find filename nil t))
 
-(defun hpath:find (filename &optional display-where noselect)
-  "Edit FILENAME using user customizable settings of display program and 
location.
+(defun hpath:find (pathname &optional display-where noselect)
+  "Edit PATHNAME using user customizable settings of display program and 
location.
 Return the current buffer iff file is read into a buffer (not displayed with
 an external program), else nil.
 
-FILENAME may contain references to Emacs Lisp variables or shell
+PATHNAME may contain references to Emacs Lisp variables or shell
 environment variables using the syntax, \"${variable-name}\".
 
-FILENAME may start with a special prefix character that is handled as follows:
-  !filename  - execute as a non-windowed program within a shell;
-  &filename  - execute as a windowed program;
-  -filename  - load as an Emacs Lisp program.
+PATHNAME may start with a special prefix character that is handled as follows:
+  !pathname  - execute as a non-windowed program within a shell;
+  &pathname  - execute as a windowed program;
+  -pathname  - load as an Emacs Lisp program.
 
-If FILENAME does not start with a prefix character:
+If PATHNAME does not start with a prefix character:
 
   it may be followed by a hash-style link reference to HTML, XML,
   SGML, shell script comment, Markdown or Emacs outline headings
@@ -1292,6 +1292,8 @@ If FILENAME does not start with a prefix character:
 Optional third argument, NOSELECT, means simply find the file and return its
 buffer but don't display it."
   (interactive "FFind file: ")
+  (unless (stringp pathname)
+    (error "(hpath:find): pathname arg must be a string, not, %S" pathname))
   (let ((case-fold-search t)
        (default-directory default-directory)
        modifier loc anchor hash path line-num col-num)
@@ -1301,10 +1303,10 @@ buffer but don't display it."
                                (if (stringp loc)
                                    (file-name-directory loc)
                                  default-directory)))
-    (when (string-match hpath:prefix-regexp filename)
-      (setq modifier (aref filename 0)
-           filename (substring filename (match-end 0))))
-    (setq path filename) ;; default
+    (when (string-match hpath:prefix-regexp pathname)
+      (setq modifier (aref pathname 0)
+           pathname (substring pathname (match-end 0))))
+    (setq path pathname) ;; default
     (when (string-match hpath:line-and-column-regexp path)
       (setq line-num (string-to-number (match-string 1 path))
            col-num (when (match-string 3 path)
@@ -1322,42 +1324,42 @@ buffer but don't display it."
        (setq anchor (substring anchor 0 (match-beginning 0)))))
     (if (string-empty-p path)
        (setq path ""
-             filename "")
-      ;; Never expand filenames with modifier prepended.
+             pathname "")
+      ;; Never expand pathnames with modifier prepended.
       (if modifier
          (setq path (hpath:resolve path))
        (setq path (hpath:expand path)
-             filename (hpath:absolute-to path default-directory))))
-    (let ((remote-filename (hpath:remote-p path)))
-      (or modifier remote-filename
-         (file-exists-p filename)
+             pathname (hpath:absolute-to path default-directory))))
+    (let ((remote-pathname (hpath:remote-p path)))
+      (or modifier remote-pathname
+         (file-exists-p pathname)
          (error "(hpath:find): \"%s\" does not exist"
-                (concat modifier filename (when hash "#") anchor)))
-      (or modifier remote-filename
-         (file-readable-p filename)
+                (concat modifier pathname (when hash "#") anchor)))
+      (or modifier remote-pathname
+         (file-readable-p pathname)
          (error "(hpath:find): \"%s\" is not readable"
-                (concat modifier filename (when hash "#") anchor)))
+                (concat modifier pathname (when hash "#") anchor)))
       (if noselect
-         (let ((buf (find-file-noselect filename)))
+         (let ((buf (find-file-noselect pathname)))
            (with-current-buffer buf
              (when (or hash anchor) (hpath:to-markup-anchor hash anchor))
              buf))
-       ;; If filename is a remote file (not a directory), we have to copy it to
+       ;; If pathname is a remote file (not a directory), we have to copy it to
        ;; a temporary local file and then display that.
-       (when (and remote-filename (not (file-directory-p remote-filename)))
-         (copy-file remote-filename
+       (when (and remote-pathname (not (file-directory-p remote-pathname)))
+         (copy-file remote-pathname
                     (setq path (concat hpath:tmp-prefix
-                                       (file-name-nondirectory 
remote-filename)))
+                                       (file-name-nondirectory 
remote-pathname)))
                     t t)
-         (setq filename (cond (anchor (concat remote-filename "#" anchor))
-                              (hash   (concat remote-filename "#"))
+         (setq pathname (cond (anchor (concat remote-pathname "#" anchor))
+                              (hash   (concat remote-pathname "#"))
                               (t path))))))
     (cond (modifier (cond ((= modifier ?!)
-                          (hact 'exec-shell-cmd filename))
+                          (hact 'exec-shell-cmd pathname))
                          ((= modifier ?&)
-                          (hact 'exec-window-cmd filename))
+                          (hact 'exec-window-cmd pathname))
                          ((= modifier ?-)
-                          (hact 'load filename)))
+                          (hact 'load pathname)))
                    nil)
 
          ;; If no path, e.g. just an anchor link in a non-file buffer,
@@ -1381,16 +1383,16 @@ buffer but don't display it."
                   executable)
               (cond ((stringp display-executables)
                      (hact 'exec-window-cmd
-                           (hpath:command-string display-executables filename))
+                           (hpath:command-string display-executables pathname))
                      nil)
                     ((functionp display-executables)
-                     (funcall display-executables filename)
+                     (funcall display-executables pathname)
                      (current-buffer))
                     ((and (listp display-executables) display-executables)
                      (setq executable (hpath:find-executable 
display-executables))
                      (if executable
                          (hact 'exec-window-cmd
-                               (hpath:command-string executable filename))
+                               (hpath:command-string executable pathname))
                        (error "(hpath:find): No available executable from: %s"
                               display-executables)))
                     (t (setq path (hpath:validate path))
diff --git a/test/hpath-tests.el b/test/hpath-tests.el
index 87c086ac23..cbb10bb54c 100644
--- a/test/hpath-tests.el
+++ b/test/hpath-tests.el
@@ -3,7 +3,7 @@
 ;; Author:       Mats Lidell <matsl@gnu.org>
 ;;
 ;; Orig-Date:    28-Feb-21 at 23:26:00
-;; Last-Mod:     12-Jul-22 at 23:09:14 by Mats Lidell
+;; Last-Mod:     24-Jul-22 at 10:31:32 by Bob Weiner
 ;;
 ;; Copyright (C) 2021-2022  Free Software Foundation, Inc.
 ;; See the "HY-COPY" file for license information.
@@ -184,9 +184,10 @@
 
 (defun hypb-run-shell-test-command (command buffer)
   "Run a shell COMMAND with output to BUFFER and select it."
-  (shell-command command buffer nil)
   (switch-to-buffer buffer)
-  (shell-mode))
+  (shell-mode)
+  (goto-char (point-max))
+  (shell-command command buffer nil))
 
 (ert-deftest hpath:prepend-shell-directory-test ()
   "Find file in ls -R listing."
@@ -203,7 +204,7 @@
                (default-directory hyperb:dir))
          (should explicit-shell-file-name)
           (hypb-run-shell-test-command shell-cmd shell-buffer)
-          (dolist (file '("COPYING" "man/version.texi" "man/hkey-help.txt" 
"man/im/demo.png"))
+          (dolist (file '("COPYING" "man/hkey-help.txt" "man/version.texi" 
"man/im/demo.png"))
             (goto-char (point-min))
             (should (search-forward (car (last (split-string file "/"))) nil 
t))
             (backward-char 5)