master 4c468c6: Add new function 'kbd-valid-p'

[Lars Ingebrigtsen]

branch: master
commit 4c468c6b3c12c12a96a6efce7a49c9b77e73bbd0
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Add new function 'kbd-valid-p'
    
    * doc/lispref/keymaps.texi (Key Sequences): New function
    'kbd-valid-p'.
    
    * lisp/subr.el (kbd-valid-p): Document it.
---
 doc/lispref/keymaps.texi |   7 +++
 etc/NEWS                 |   7 +++
 lisp/subr.el             |  33 ++++++++++++++
 test/lisp/subr-tests.el  | 114 +++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 161 insertions(+)

diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi
index 066d8b3..4277c71 100644
--- a/doc/lispref/keymaps.texi
+++ b/doc/lispref/keymaps.texi
@@ -94,8 +94,15 @@ Manual}.
 (kbd "<f1> SPC") @result{} [f1 32]
 (kbd "C-M-<down>") @result{} [C-M-down]
 @end example
+
+@findex kbd-valid-p
+The @code{kbd} function is very permissive, and will try to return
+something sensible even if the syntax used isn't completely
+conforming.  To check whether the syntax is actually valid, use the
+@code{kbd-valid-p} function.
 @end defun
 
+
 @node Keymap Basics
 @section Keymap Basics
 @cindex key binding
diff --git a/etc/NEWS b/etc/NEWS
index e7d3de7..fcc9b4a 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -209,6 +209,13 @@ This macro allows defining keymap variables more 
conveniently.
 ** 'kbd' can now be used in built-in, preloaded libraries.
 It no longer depends on edmacro.el and cl-lib.el.
 
++++
+** New function 'kbd-valid-p'.
+The 'kbd' function is quite permissive, and will try to return
+something usable even if the syntax of the argument isn't completely
+correct.  The 'kbd-valid-p' predicate does a stricter check of the
+syntax.
+
 
 * Changes in Emacs 29.1 on Non-Free Operating Systems
 
diff --git a/lisp/subr.el b/lisp/subr.el
index 93ec76e..e55c94a 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -925,6 +925,39 @@ side-effects, and the argument LIST is not modified."
 
 ;;;; Keymap support.
 
+(defun kbd-valid-p (keys)
+  "Say whether KEYS is a valid `kbd' sequence.
+In particular, this checks the order of the modifiers, and they
+have to be specified in this order:
+
+   A-C-H-M-S-s
+
+which is
+
+   Alt-Control-Hyper-Meta-Shift-super"
+  (declare (pure t) (side-effect-free t))
+  (and (stringp keys)
+       (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys)
+       (save-match-data
+         (seq-every-p
+          (lambda (key)
+            ;; Every key might have these modifiers, and they should be
+            ;; in this order.
+            (when (string-match
+                   "\\`\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?"
+                   key)
+              (setq key (substring key (match-end 0))))
+            (or (and (= (length key) 1)
+                     ;; Don't accept control characters as keys.
+                     (not (< (aref key 0) ?\s))
+                     ;; Don't accept Meta'd characters as keys.
+                     (or (multibyte-string-p key)
+                         (not (<= 127 (aref key 0) 255))))
+                (string-match-p "\\`<[A-Za-z0-9]+>\\'" key)
+                (string-match-p
+                 "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" key)))
+          (split-string keys " ")))))
+
 (defun kbd (keys &optional need-vector)
   "Convert KEYS to the internal Emacs key representation.
 KEYS should be a string in the format returned by commands such
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index da46646..8380e8a 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -198,6 +198,120 @@
   ;; These should be equivalent:
   (should (equal (kbd "\C-xf") (kbd "C-x f"))))
 
+(ert-deftest subr-test-kbd-valid-p ()
+  (should (not (kbd-valid-p "")))
+  (should (kbd-valid-p "f"))
+  (should (kbd-valid-p "X"))
+  (should (not (kbd-valid-p " X")))
+  (should (kbd-valid-p "X f"))
+  (should (not (kbd-valid-p "a  b")))
+  (should (not (kbd-valid-p "foobar")))
+  (should (not (kbd-valid-p "return")))
+
+  (should (kbd-valid-p "<F2>"))
+  (should (kbd-valid-p "<f1> <f2> TAB"))
+  (should (kbd-valid-p "<f1> RET"))
+  (should (kbd-valid-p "<f1> SPC"))
+  (should (kbd-valid-p "<f1>"))
+  (should (not (kbd-valid-p "[f1]")))
+  (should (kbd-valid-p "<return>"))
+  (should (not (kbd-valid-p "< right >")))
+
+  ;; Modifiers:
+  (should (kbd-valid-p "C-x"))
+  (should (kbd-valid-p "C-x a"))
+  (should (kbd-valid-p "C-;"))
+  (should (kbd-valid-p "C-a"))
+  (should (kbd-valid-p "C-c SPC"))
+  (should (kbd-valid-p "C-c TAB"))
+  (should (kbd-valid-p "C-c c"))
+  (should (kbd-valid-p "C-x 4 C-f"))
+  (should (kbd-valid-p "C-x C-f"))
+  (should (kbd-valid-p "C-M-<down>"))
+  (should (not (kbd-valid-p "<C-M-down>")))
+  (should (kbd-valid-p "C-RET"))
+  (should (kbd-valid-p "C-SPC"))
+  (should (kbd-valid-p "C-TAB"))
+  (should (kbd-valid-p "C-<down>"))
+  (should (kbd-valid-p "C-c C-c C-c"))
+
+  (should (kbd-valid-p "M-a"))
+  (should (kbd-valid-p "M-<DEL>"))
+  (should (not (kbd-valid-p "M-C-a")))
+  (should (kbd-valid-p "C-M-a"))
+  (should (kbd-valid-p "M-ESC"))
+  (should (kbd-valid-p "M-RET"))
+  (should (kbd-valid-p "M-SPC"))
+  (should (kbd-valid-p "M-TAB"))
+  (should (kbd-valid-p "M-x a"))
+  (should (kbd-valid-p "M-<up>"))
+  (should (kbd-valid-p "M-c M-c M-c"))
+
+  (should (kbd-valid-p "s-SPC"))
+  (should (kbd-valid-p "s-a"))
+  (should (kbd-valid-p "s-x a"))
+  (should (kbd-valid-p "s-c s-c s-c"))
+
+  (should (not (kbd-valid-p "S-H-a")))
+  (should (kbd-valid-p "S-a"))
+  (should (kbd-valid-p "S-x a"))
+  (should (kbd-valid-p "S-c S-c S-c"))
+
+  (should (kbd-valid-p "H-<RET>"))
+  (should (kbd-valid-p "H-DEL"))
+  (should (kbd-valid-p "H-a"))
+  (should (kbd-valid-p "H-x a"))
+  (should (kbd-valid-p "H-c H-c H-c"))
+
+  (should (kbd-valid-p "A-H-a"))
+  (should (kbd-valid-p "A-SPC"))
+  (should (kbd-valid-p "A-TAB"))
+  (should (kbd-valid-p "A-a"))
+  (should (kbd-valid-p "A-c A-c A-c"))
+
+  (should (kbd-valid-p "C-M-a"))
+  (should (kbd-valid-p "C-M-<up>"))
+
+  ;; Special characters.
+  (should (kbd-valid-p "DEL"))
+  (should (kbd-valid-p "ESC C-a"))
+  (should (kbd-valid-p "ESC"))
+  (should (kbd-valid-p "LFD"))
+  (should (kbd-valid-p "NUL"))
+  (should (kbd-valid-p "RET"))
+  (should (kbd-valid-p "SPC"))
+  (should (kbd-valid-p "TAB"))
+  (should (not (kbd-valid-p "\^i")))
+  (should (not (kbd-valid-p "^M")))
+
+  ;; With numbers.
+  (should (not (kbd-valid-p "\177")))
+  (should (not (kbd-valid-p "\000")))
+  (should (not (kbd-valid-p "\\177")))
+  (should (not (kbd-valid-p "\\000")))
+  (should (not (kbd-valid-p "C-x \\150")))
+
+  ;; Multibyte
+  (should (kbd-valid-p "ñ"))
+  (should (kbd-valid-p "ü"))
+  (should (kbd-valid-p "ö"))
+  (should (kbd-valid-p "ğ"))
+  (should (kbd-valid-p "ա"))
+  (should (not (kbd-valid-p "üüöö")))
+  (should (kbd-valid-p "C-ü"))
+  (should (kbd-valid-p "M-ü"))
+  (should (kbd-valid-p "H-ü"))
+
+  ;; Handle both new and old style key descriptions (bug#45536).
+  (should (kbd-valid-p "s-<return>"))
+  (should (not (kbd-valid-p "<s-return>")))
+  (should (kbd-valid-p "C-M-<return>"))
+  (should (not (kbd-valid-p "<C-M-return>")))
+
+  (should (not (kbd-valid-p "C-xx")))
+  (should (not (kbd-valid-p "M-xx")))
+  (should (not (kbd-valid-p "M-x<TAB>"))))
+
 (ert-deftest subr-test-define-prefix-command ()
   (define-prefix-command 'foo-prefix-map)
   (defvar foo-prefix-map)