[elpa] externals/hyperbole 78aad8eee8 4/9: Initial work toward finishing ibut:operate

[ELPA Syncer]

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

    Initial work toward finishing ibut:operate
    
    Add and update some ibut:operate tests
---
 hbut.el            | 195 ++++++++++++++++++++++++++++++-----------------------
 test/hbut-tests.el | 132 +++++++++++++++++++++++++++++++++++-
 2 files changed, 240 insertions(+), 87 deletions(-)

diff --git a/hbut.el b/hbut.el
index 1771269e29..2ce10b2df4 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:      2-Jul-23 at 00:22:53 by Bob Weiner
+;; Last-Mod:      3-Jul-23 at 23:57:18 by Bob Weiner
 ;;
 ;; SPDX-License-Identifier: GPL-3.0-or-later
 ;;
@@ -470,12 +470,12 @@ For interactive creation, use `hui:ebut-create' instead."
             (if (or (and actype-sym (fboundp actype-sym))
                    (functionp actype))
                (hattr:set 'hbut:current 'actype actype)
-             (error (format "(%s)" actype)))
+             (error "(%s)" actype))
            (hattr:set 'hbut:current 'args args)
            (ebut:operate label nil))
        (error (hattr:clear 'hbut:current)
               (if (and (listp (cdr err)) (= (length (cdr err)) 1))
-                  (error (format "(ebut:program): actype arg must be a bound 
symbol (not a string): %S" actype))
+                  (error "(ebut:program): actype arg must be a bound symbol 
(not a string): %S" actype)
                 (error "(ebut:program): %S" err)))))))
 
 (defun    ebut:search (string out-buf &optional match-part)
@@ -982,7 +982,8 @@ Default is the symbol hbut:current."
        action)
     (setq action (car (hattr:get hbut 'action))
          atype  (hattr:get hbut 'actype))
-    (if (= (length (symbol-name atype)) 2)
+    (if (and (symbolp atype)
+            (= (length (symbol-name atype)) 2))
        atype
       (or action (actype:action atype)))))
 
@@ -2171,7 +2172,7 @@ move to the first occurrence of the button."
 
 (defun    ibut:operate (&optional new-name edit-flag)
   "Insert/modify an ibutton based on `hbut:current' in current buffer.
-Optional non-nil NEW-NAME is name to give button.  With optional
+Optional non-nil NEW-NAME is new name to give button.  With optional
 EDIT-FLAG non-nil, modify an existing in-buffer ibutton rather
 than creating a new one.
 
@@ -2182,20 +2183,28 @@ Return instance string appended to name to form a 
per-buffer unique
 name; nil if name is already unique or no name.  Signal an error when no
 such button is found in the current buffer.
 
-Summary of operations based on inputs:
-|-------+----------+--------+------------------------------------------------|
-| name  | new-name | region | operation                                      |
-|-------+----------+--------+------------------------------------------------|
-| nil   | nil      | nil    | create: unnamed ibut                           |
-| aname | nil      | nil    | create/update: aname named ibut                |
-| aname | nil      | region | create/update: aname named ibut (skip region)  |
-| nil   | nil      | region | create/update: region named ibut               |
-| aname | newname  | nil    | mod: rename aname to newname                   |
-| aname | newname  | region | mod: rename aname to newname (skip region)     |
-| nil   | newname  | nil    | mod: add newname to lbl-key ibut at point      |
-| nil   | newname  | region | mod: add newname to lbl-key ibut (skip region) |
-|-------+----------+--------+------------------------------------------------|"
-  ;; !! TODO: Code does not yet fully match what is in docstring table
+Summary of operations based on inputs (name arg comes from \\='hbut:current 
attrs):
+|----+------+----------+--------+------+-----------------------------------------------|
+|  # | name | new-name | region | edit | operation                             
        |
+|----+------+----------+--------+------+-----------------------------------------------|
+|  1 | nil  | nil      | nil    | nil  | create: unnamed ibut from 
hbut:current attrs  |
+|  2 | nil  | new-name | nil    | nil  | create: new-name named ibut           
        |
+|  3 | name | nil      | nil    | nil  | create: aname named ibut              
        |
+|  4 | name | new-name | nil    | nil  | ERROR: create can't have name and 
new-name    |
+|  5 | name | new-name | region | nil  | ERROR: create can't have name and 
new-name    |
+|  6 | name | nil      | region | nil  | create: aname named ibut (skip 
region)        |
+|  7 | nil  | nil      | region | nil  | create: region named ibut             
        |
+|  8 | nil  | new-name | region | nil  | create: new-name named ibut (skip 
region)     |
+|----+------+----------+--------+------+-----------------------------------------------|
+|  9 | nil  | nil      | nil    | t    | mod: unnamed ibut from hbut:current 
attrs     |
+| 10 | nil  | new-name | nil    | t    | mod: add new-name to lbl-key ibut at 
point    |
+| 11 | name | nil      | nil    | t    | mod: aname named ibut from 
hbut:current attrs |
+| 12 | name | new-name | nil    | t    | mod: rename aname to new-name         
        |
+| 13 | name | new-name | region | t    | ERROR: Can't use region to mod 
existing ibut  |
+| 14 | name | nil      | region | t    | ERROR: Can't use region to mod 
existing ibut  |
+| 15 | nil  | nil      | region | t    | ERROR: Can't use region to mod 
existing ibut  |
+| 16 | nil  | new-name | region | t    | ERROR: Can't use region to mod 
existing ibut  |
+|----+------+----------+--------+------+-----------------------------------------------|"
   (let* ((actype (hattr:get 'hbut:current 'actype))
         (name (hattr:get 'hbut:current 'name))
         (name-regexp (ibut:label-regexp (ibut:label-to-key name)))
@@ -2207,6 +2216,10 @@ Summary of operations based on inputs:
     (when (and new-name (or (not (stringp new-name)) (string-empty-p 
new-name)))
       (hypb:error "(ibut:operate): 'new-name' value must be a non-empty 
string, not: '%s'"
                  new-name))
+    (when (and name new-name (not edit-flag))
+      (hypb:error "(ibut:operate): 'edit-flag' must be t to rename a button 
(hbut:current name and new-name both given)"))
+    (when (and region-flag edit-flag)
+      (hypb:error "(ibut:operate): 'edit-flag' must be nil when region is 
highlighted to use region as new button name"))
 
     (unless new-name
       (setq new-name name))
@@ -2214,14 +2227,8 @@ Summary of operations based on inputs:
       (hattr:set 'hbut:current 'name new-name))
     (save-excursion
       (if (progn
-           (if edit-flag
-               (progn
-                 (setq instance-flag
-                       (hbdata:ibut-instance-last (ibut:label-to-key 
new-name)))
-                 (run-hooks 'ibut-edit-hook))
-             (setq instance-flag
-                   (hbdata:ibut-instance-last (ibut:label-to-key name)))
-             (run-hooks 'ibut-create-hook))
+           (setq instance-flag (hbdata:ibut-instance-last (ibut:label-to-key
+                                                           (if edit-flag 
new-name name))))
            (when (null instance-flag)
              (setq instance-flag t))
            instance-flag)
@@ -2231,43 +2238,47 @@ Summary of operations based on inputs:
                    (if edit-flag "modify" "create")
                    ibut:label-start name ibut:label-end
                    (buffer-name))))
-    (cond (edit-flag
-          (if name
-              ;; Rename all occurrences of button - those with same name
-              (let* ((but-key-and-pos (ibut:label-p nil nil nil 'pos))
-                     (at-but (equal (car but-key-and-pos)
-                                    (ibut:label-to-key new-name))))
-                (when at-but
-                  (ibut:delimit (nth 1 but-key-and-pos)
-                                (nth 2 but-key-and-pos)
+    (let (start end mark prev-point)
+      (cond (edit-flag
+            (cond (name
+                   ;; Rename all occurrences of button - those with same name
+                   (let* ((but-key-and-pos (ibut:label-p nil nil nil 'pos))
+                          (at-but (equal (car but-key-and-pos)
+                                         (ibut:label-to-key new-name))))
+                     (when at-but
+                       (ibut:delimit (nth 1 but-key-and-pos)
+                                     (nth 2 but-key-and-pos)
+                                     instance-flag))
+                     (cond ((ibut:map
+                             (lambda (_lbl start end)
+                               (delete-region start end)
+                               (ibut:delimit
+                                (point)
+                                (progn (insert new-name) (point))
                                 instance-flag))
-                (cond ((ibut:map
-                        (lambda (_lbl start end)
-                          (delete-region start end)
-                          (ibut:delimit
-                           (point)
-                           (progn (insert new-name) (point))
-                           instance-flag))
-                        name-regexp 'include-delims))
-                      (at-but)
-                      ((hypb:error "(ibut:operate): No button matching: %s" 
name))))
-            ;; Add new-name to nameless button at point
-            (goto-char (or (hattr:get 'hbut:current 'lbl-start) (point)))
-            (ibut:delimit (point)
-                          (progn (insert new-name) (point))
-                          instance-flag)))
-
-         (instance-flag
-          ;; Above flag is 't when there is exactly one existing
-          ;; instance of the button name
-          ;;
-          ;; Add a new implicit button in the buffer, recording its
-          ;; start and end positions; new-name is always nil here
-          (let (start end mark prev-point buf-lbl)
+                             name-regexp 'include-delims))
+                           (at-but)
+                           ((hypb:error "(ibut:operate): No button matching: 
%s" name)))))
+                  (new-name
+                   ;; Add new-name to nameless button at point
+                   (goto-char (or (hattr:get 'hbut:current 'lbl-start) 
(point)))
+                   (ibut:delimit (point)
+                                 (progn (insert new-name) (point))
+                                 instance-flag))))
+
+           (instance-flag
+            ;; Above flag is 't when there is exactly one existing
+            ;; instance of the button name
+            ;;
+            ;; Add a new implicit button in the buffer, recording its
+            ;; start and end positions; new-name is always nil here
             (cond ((not (or name region-flag))
                    ;; No name to insert, just insert ibutton text below
                    )
                   ((and region-flag
+                        ;; ignore region when name or new-name are set
+                        (not (or name new-name))
+                        ;; new-name is always nil here
                         (if (hyperb:stack-frame
                              '(hui:ebut-create hui:ebut-edit 
hui:ebut-edit-region
                                                hui:ebut-link-create 
hui:gbut-create
@@ -2275,43 +2286,45 @@ Summary of operations based on inputs:
                                                hui:ibut-create hui:ibut-edit
                                                hui:ibut-link-create 
ibut:program))
                             ;; Ignore action-key-depress-prev-point
-                            (progn (setq mark (marker-position (mark-marker))
-                                         start (region-beginning)
-                                         end (region-end)
-                                         buf-lbl 
(buffer-substring-no-properties start end))
-                                   (equal buf-lbl name))
+                            (setq start (region-beginning)
+                                  end (region-end)
+                                  name (buffer-substring-no-properties start 
end))
                           ;; Utilize any action-key-depress-prev-point
-                          (setq mark (marker-position (mark-marker)))
-                          (setq prev-point (and action-key-depress-prev-point
-                                                (marker-position 
action-key-depress-prev-point)))
-                          (setq start (if (and prev-point mark (<= prev-point 
mark))
+                          (setq mark (marker-position (mark-marker))
+                                prev-point (and action-key-depress-prev-point
+                                                (marker-position 
action-key-depress-prev-point))
+                                start (if (and prev-point mark (<= prev-point 
mark))
                                           prev-point
                                         (region-beginning))
                                 end (if (and prev-point mark (> prev-point 
mark))
                                         prev-point
                                       (region-end))
-                                buf-lbl (buffer-substring-no-properties start 
end))
-                          (equal buf-lbl name)))
+                                name (buffer-substring-no-properties start 
end))))
                    nil)
                   ((progn (when start (goto-char start))
-                          (when name  (looking-at (regexp-quote name))))
+                          (or (when name  (looking-at (regexp-quote name)))
+                              (when new-name  (looking-at (regexp-quote 
new-name)))))
                    (setq start (point)
                          end (match-end 0)))
                   (name
                    (setq start (point))
                    (insert name)
-                   (setq end (point))))
-
-            (when (and start end)
-              (ibut:delimit start end instance-flag))
-            (ibut:insert-text 'hbut:current)
-            (if start
-                (goto-char start)
-              (goto-char (max (- (point) 2) (point-min))))))
-
-         (t (hypb:error
-             "(ibut:operate): Operation failed.  Check button attribute 
permissions: %s"
-             hattr:filename)))
+                   (setq end (point)))
+                  (new-name
+                   (setq start (point))
+                   (insert new-name)
+                   (setq end (point)))))
+           (t (hypb:error
+               "(ibut:operate): Operation failed.  Check button attribute 
permissions: %s"
+               hattr:filename)))
+
+      (unless edit-flag
+       (when (and start end)
+         (ibut:delimit start end instance-flag))
+       (ibut:insert-text 'hbut:current)
+       (if start
+           (goto-char start)
+         (goto-char (max (- (point) 2) (point-min))))))
 
     ;; Append any instance-flag string to the button name
     (when (stringp instance-flag)
@@ -2342,6 +2355,8 @@ Summary of operations based on inputs:
        (hypb:error "(ibut:operate): hbut:current ibut lbl-key '%s' must be 
non-nil"
                    lbl-key)))
 
+    (run-hooks (if edit-flag 'ibut-edit-hook 'ibut-create-hook))
+
     ;; instance-flag might be 't which we don't want to return.
     (when (stringp instance-flag) instance-flag)))
 
@@ -2449,10 +2464,20 @@ function, followed by a list of arguments for the 
actype, aside from
 the button NAME which is automatically provided as the first argument.
 
 For interactive creation, use `hui:ibut-create' instead."
+  ;; Throw an error if on a named or delimited Hyperbole button since
+  ;; cannot create another button within such contexts.
+  (when (hbut:at-p)
+    (let ((name (hattr:get 'hbut:current 'name))
+         (lbl (hbut:key-to-label (hattr:get 'hbut:current 'lbl-key)))
+         (lbl-start (hattr:get 'hbut:current 'lbl-start))
+         (lbl-end (hattr:get 'hbut:current 'lbl-end)))
+      (when (or name lbl (and lbl-start lbl-end))
+       (error "(ibut:program): Cannot nest an ibut within the existing button: 
%s"
+              (or name lbl (buffer-substring-no-properties lbl-start 
lbl-end))))))
   (save-excursion
     (let ((but-buf (current-buffer))
          (actype-sym (actype:action actype)))
-      (hui:buf-writable-err but-buf "ibut-create")
+      (hui:buf-writable-err but-buf "ibut:program")
       (hattr:clear 'hbut:current)
       (hattr:set 'hbut:current 'name name)
       (hattr:set 'hbut:current 'categ 'implicit)
@@ -2461,7 +2486,7 @@ For interactive creation, use `hui:ibut-create' instead."
       (if (or (and actype-sym (fboundp actype-sym))
              (functionp actype))
          (hattr:set 'hbut:current 'actype actype)
-       (error (format "actype arg must be a bound symbol (not a string): %S" 
actype)))
+       (error "actype arg must be a bound symbol (not a string): %S" actype))
       (hattr:set 'hbut:current 'args args)
       (condition-case err
          (ibut:operate)
diff --git a/test/hbut-tests.el b/test/hbut-tests.el
index 751b041e44..8f95038b07 100644
--- a/test/hbut-tests.el
+++ b/test/hbut-tests.el
@@ -3,7 +3,7 @@
 ;; Author:       Mats Lidell <matsl@gnu.org>
 ;;
 ;; Orig-Date:    30-may-21 at 09:33:00
-;; Last-Mod:      1-Jul-23 at 13:41:36 by Bob Weiner
+;; Last-Mod:      5-Jul-23 at 00:29:02 by Bob Weiner
 ;;
 ;; SPDX-License-Identifier: GPL-3.0-or-later
 ;;
@@ -26,7 +26,7 @@
 (require 'hy-test-helpers "test/hy-test-helpers")
 
 (defun hbut-tests:should-match-tmp-folder (tmp)
-  "Check that TMP matches either of \"/tmp\" or \"private/tmp\".
+  "Check that TMP matches either of \"/tmp\" or \"/private/tmp\".
 Needed since hyperbole expands all links to absolute paths and
 /tmp can be a symbolic link."
   (should (and (stringp tmp) (string-match-p 
"\\`\"?\\(/\\|./\\|/private/\\)tmp\"?\\'" tmp) t)))
@@ -337,6 +337,134 @@ Needed since hyperbole expands all links to absolute 
paths and
     `(dolist (bd ,hbut-tests-actypes-list)
        (with-temp-file "hypb.txt" ,@body))))
 
+;; ibut:operate tests
+
+(ert-deftest hbut-tests--ibut-operate--none ()
+  "Create unnamed ibut.
+  
|------+----------+--------+-----------+-----------------------------------------------|
+  | name | new-name | region | edit-flag | operation                           
          |
+  
|------+----------+--------+-----------+-----------------------------------------------|
+  | nil  | nil      | nil    | nil       | create: unnamed ibut from 
hbut:current attrs  |
+  
|------+----------+--------+-----------+-----------------------------------------------|"
+  (with-temp-buffer
+    (insert "/tmp")
+    (goto-char 2)
+    (should (hbut:at-p))
+    (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    (hbut-tests:should-match-tmp-folder (buffer-substring-no-properties 
(point-min) (point-max)))
+    (erase-buffer)
+    (should-not (ibut:operate))
+    (should (hbut:at-p))
+    (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    (hbut-tests:should-match-tmp-folder (buffer-substring-no-properties 
(point-min) (point-max)))))
+
+(ert-deftest hbut-tests--ibut-operate--aname ()
+  "Create aname ibut."
+  (with-temp-buffer
+    (insert "<[aname]> - /tmp")
+    (goto-char 2)
+    (should (hbut:at-p))
+    (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    (hbut-tests:should-match-tmp-folder (buffer-substring-no-properties 
(point-min) (point-max)))
+    (erase-buffer)
+    (
+     (hattr:set 'hbut:current 'name "aname")
+     (hattr:set 'hbut:current 'name "")
+    (should-not (ibut:operate))
+    (should (hbut:at-p))
+    (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    (should (string= "<[aname]> - /tmp<[aname]> - \"/tmp\""
+                    (buffer-substring-no-properties (point-min) 
(point-max)))))))
+
+(ert-deftest hbut-tests--ibut-operate--aname-region-skip-region ()
+  "Create aname ibut and ignore region."
+  (with-temp-buffer
+    (insert "<[aname]> - /tmp")
+    (goto-char 2)
+    (should (hbut:at-p))
+    (end-of-buffer)
+    (insert "\n")
+    (set-mark (point))
+    (insert "abcd")
+    (should (region-active-p))
+    (should-not (ibut:operate))
+    ;; Inserted just before region which is kept
+    (should (string= "<[aname]> - /tmp\n<[aname]> - \"/tmp\"abcd"
+                    (buffer-substring-no-properties (point-min) 
(point-max))))))
+
+(ert-deftest hbut-tests--ibut-operate--region ()
+  "Create ibut with aname, ignore region."
+  (with-temp-buffer
+    (insert "/tmp")
+    (goto-char 2)
+    (should (hbut:at-p))
+    (end-of-buffer)
+    (insert "\n")
+    (set-mark (point))
+    (insert "name")
+    (should (region-active-p))
+    (should-not (ibut:operate))
+    (should (string= "/tmp\n<[name]>\"/tmp\""
+                    (buffer-substring-no-properties (point-min) 
(point-max))))))
+
+(ert-deftest hbut-tests--ibut-operate--modify-named ()
+  "Add new-name to named ibut."
+  (with-temp-buffer
+    (insert "<[name]> /tmp")
+    (goto-char 2)
+    (should (hbut:at-p))
+    (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    (should-not (ibut:operate "new-name" t))
+    (should (hbut:at-p))
+    (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    (should (string= "<[new-name]> /tmp"
+                    (buffer-substring-no-properties (point-min) 
(point-max))))))
+
+(ert-deftest hbut-tests--ibut-operate--modify-named-skip-region ()
+  "Add new-name to named ibut and ignore region."
+  (with-temp-buffer
+    (insert "<[name]> /tmp")
+    (goto-char 2)
+    (should (hbut:at-p))
+    (set-mark (point-max))
+    (should (region-active-p))
+    (should-not (ibut:operate "new-name" t))
+    (should (hbut:at-p))
+    (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    (should (string= "<[new-name]> /tmp"
+                    (buffer-substring-no-properties (point-min) 
(point-max))))))
+
+(ert-deftest hbut-tests--ibut-operate--add-new-name ()
+  "Add new-name to unnamed ibut."
+  (with-temp-buffer
+    (insert "/tmp")
+    (goto-char 2)
+    (should (hbut:at-p))
+    (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    (should-not (ibut:operate "new-name" t))
+    ;; Missing delimiter -- Not identified as a ibut after name is inserted
+    ;; (should (hbut:at-p))
+    ;; (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    ;; delimiter
+    (should (string= "<[new-name]>/tmp"
+                    (buffer-substring-no-properties (point-min) 
(point-max))))))
+
+(ert-deftest hbut-tests--ibut-operate--add-new-name-skip-region ()
+  "Add new-name to unnamed ibut, skip active region."
+  (with-temp-buffer
+    (insert "/tmp")
+    (goto-char 2)
+    (should (hbut:at-p))
+    (set-mark (point-max))
+    (should (region-active-p))
+    (should-not (ibut:operate "new-name" t))
+    ;; Missing delimiter -- Not identified as a ibut after name is inserted
+    ;; (should (hbut:at-p))
+    ;; (should (eq (hattr:get 'hbut:current 'actype) 'actypes::link-to-file))
+    ;; Missing delimiter
+    (should (string= "<[new-name]>/tmp"
+                    ))))
+
 ;; This file can't be byte-compiled without the `el-mock' package (because of
 ;; the use of the `with-mock' macro), which is not a dependency of Hyperbole.
 ;;  Local Variables: