master 2671ea0: Be more allowing when looking for menu-bar items

[Stefan Kangas]

branch: master
commit 2671ea0de8e90e20241fe0441f4f8b79eeccdb12
Author: Stefan Kangas <stefan@marxist.se>
Commit: Stefan Kangas <stefan@marxist.se>

    Be more allowing when looking for menu-bar items
    
    * src/keymap.c (lookup_key_1): Factor out function from
    Flookup_key.
    (Flookup_key): Be case insensitive, and treat spaces as dashes,
    when looking for Qmenu_bar items.  (Bug#50752)
    
    * test/src/keymap-tests.el
    (keymap-lookup-key/mixed-case)
    (keymap-lookup-key/mixed-case-multibyte)
    (keymap-lookup-keymap/with-spaces)
    (keymap-lookup-keymap/with-spaces-multibyte)
    (keymap-lookup-keymap/with-spaces-multibyte-lang-env): New tests.
---
 etc/NEWS                 |  12 ++++
 src/keymap.c             | 161 ++++++++++++++++++++++++++++++++++++++++-------
 test/src/keymap-tests.el |  43 +++++++++++++
 3 files changed, 195 insertions(+), 21 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index f006fa5..cc45221 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -426,6 +426,18 @@ This returns the width of a string in pixels.  This can be 
useful when
 dealing with variable pitch fonts and glyphs that have widths that
 aren't integer multiples of the default font.
 
+---
+** 'lookup-key' is more allowing when searching for extended menu items.
+In Emacs 28.1, the behavior of 'lookup-key' was changed: when looking
+for a menu item '[menu-bar Foo-Bar]', first try to find an exact
+match, then look for the lowercased '[menu-bar foo-bar]'.
+
+This has been extended, so that when looking for a menu item with a
+symbol containing spaces, as in '[menu-bar Foo\ Bar]', first look for
+an exact match, then the lowercased '[menu-bar foo\ bar]' and finally
+'[menu-bar foo-bar]'.  This further improves backwards-compatibility
+when converting menus to use 'easy-menu-define'.
+
 
 * Changes in Emacs 29.1 on Non-Free Operating Systems
 
diff --git a/src/keymap.c b/src/keymap.c
index 8b521a8..2e98b05 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -65,6 +65,9 @@ static Lisp_Object exclude_keys;
 /* Pre-allocated 2-element vector for Fcommand_remapping to use.  */
 static Lisp_Object command_remapping_vector;
 
+/* Char table for the backwards-compatibility part in Flookup_key.  */
+static Lisp_Object unicode_case_table;
+
 /* Hash table used to cache a reverse-map to speed up calls to where-is.  */
 static Lisp_Object where_is_cache;
 /* Which keymaps are reverse-stored in the cache.  */
@@ -1209,27 +1212,8 @@ remapping in all currently active keymaps.  */)
   return FIXNUMP (command) ? Qnil : command;
 }
 
-/* Value is number if KEY is too long; nil if valid but has no definition.  */
-/* GC is possible in this function.  */
-
-DEFUN ("lookup-key", Flookup_key, Slookup_key, 2, 3, 0,
-       doc: /* Look up key sequence KEY in KEYMAP.  Return the definition.
-A value of nil means undefined.  See doc of `define-key'
-for kinds of definitions.
-
-A number as value means KEY is "too long";
-that is, characters or symbols in it except for the last one
-fail to be a valid sequence of prefix characters in KEYMAP.
-The number is how many characters at the front of KEY
-it takes to reach a non-prefix key.
-KEYMAP can also be a list of keymaps.
-
-Normally, `lookup-key' ignores bindings for t, which act as default
-bindings, used when nothing else in the keymap applies; this makes it
-usable as a general function for probing keymaps.  However, if the
-third optional argument ACCEPT-DEFAULT is non-nil, `lookup-key' will
-recognize the default bindings, just as `read-key-sequence' does.  */)
-  (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default)
+static Lisp_Object
+lookup_key_1 (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default)
 {
   bool t_ok = !NILP (accept_default);
 
@@ -1271,6 +1255,141 @@ recognize the default bindings, just as 
`read-key-sequence' does.  */)
     }
 }
 
+/* Value is number if KEY is too long; nil if valid but has no definition.  */
+/* GC is possible in this function.  */
+
+DEFUN ("lookup-key", Flookup_key, Slookup_key, 2, 3, 0,
+       doc: /* Look up key sequence KEY in KEYMAP.  Return the definition.
+A value of nil means undefined.  See doc of `define-key'
+for kinds of definitions.
+
+A number as value means KEY is "too long";
+that is, characters or symbols in it except for the last one
+fail to be a valid sequence of prefix characters in KEYMAP.
+The number is how many characters at the front of KEY
+it takes to reach a non-prefix key.
+KEYMAP can also be a list of keymaps.
+
+Normally, `lookup-key' ignores bindings for t, which act as default
+bindings, used when nothing else in the keymap applies; this makes it
+usable as a general function for probing keymaps.  However, if the
+third optional argument ACCEPT-DEFAULT is non-nil, `lookup-key' will
+recognize the default bindings, just as `read-key-sequence' does.  */)
+  (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default)
+{
+  Lisp_Object found = lookup_key_1 (keymap, key, accept_default);
+  if (!NILP (found) && !NUMBERP (found))
+    return found;
+
+  /* Menu definitions might use mixed case symbols (notably in old
+     versions of `easy-menu-define'), or use " " instead of "-".
+     The rest of this function is about accepting these variations for
+     backwards-compatibility.  (Bug#50752) */
+
+  /* Just skip everything below unless this is a menu item.  */
+  if (!VECTORP (key) || !(ASIZE (key) > 0)
+      || !EQ (AREF (key, 0), Qmenu_bar))
+    return found;
+
+  /* Initialize the unicode case table, if it wasn't already.  */
+  if (NILP (unicode_case_table))
+    {
+      unicode_case_table = uniprop_table (intern ("lowercase"));
+      staticpro (&unicode_case_table);
+    }
+
+  ptrdiff_t key_len = ASIZE (key);
+  Lisp_Object new_key = make_vector (key_len, Qnil);
+
+  /* Try both the Unicode case table, and the buffer local one.
+     Otherwise, we will fail for e.g. the "Turkish" language
+     environment where 'I' does not downcase to 'i'.  */
+  Lisp_Object tables[2] = {unicode_case_table, Fcurrent_case_table ()};
+  for (int tbl_num = 0; tbl_num < 2; tbl_num++)
+    {
+      /* First, let's try converting all symbols like "Foo-Bar-Baz" to
+        "foo-bar-baz".  */
+      for (int i = 0; i < key_len; i++)
+       {
+         Lisp_Object key_item = Fsymbol_name (AREF (key, i));
+         Lisp_Object new_item;
+         if (!STRING_MULTIBYTE (key_item))
+           new_item = Fdowncase (key_item);
+         else
+           {
+             USE_SAFE_ALLOCA;
+             ptrdiff_t size = SCHARS (key_item), n;
+             if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n))
+               n = PTRDIFF_MAX;
+             unsigned char *dst = SAFE_ALLOCA (n);
+             unsigned char *p = dst;
+             ptrdiff_t j_char = 0, j_byte = 0;
+
+             while (j_char < size)
+               {
+                 int ch = fetch_string_char_advance (key_item, &j_char, 
&j_byte);
+                 Lisp_Object ch_conv = CHAR_TABLE_REF (tables[tbl_num], ch);
+                 if (!NILP (ch_conv))
+                   CHAR_STRING (XFIXNUM (ch_conv), p);
+                 else
+                   CHAR_STRING (ch, p);
+                 p = dst + j_byte;
+               }
+             new_item = make_multibyte_string ((char *) dst,
+                                               SCHARS (key_item),
+                                               SBYTES (key_item));
+             SAFE_FREE ();
+           }
+         ASET (new_key, i, Fintern (new_item, Qnil));
+       }
+
+      /* Check for match.  */
+      found = lookup_key_1 (keymap, new_key, accept_default);
+      if (!NILP (found) && !NUMBERP (found))
+       break;
+
+      /* If we still don't have a match, let's convert any spaces in
+        our lowercased string into dashes, e.g. "foo bar baz" to
+        "foo-bar-baz".  */
+      for (int i = 0; i < key_len; i++)
+       {
+         Lisp_Object lc_key = Fsymbol_name (AREF (new_key, i));
+
+         /* If there are no spaces in this symbol, just skip it.  */
+         if (!strstr (SSDATA (lc_key), " "))
+           continue;
+
+         USE_SAFE_ALLOCA;
+         ptrdiff_t size = SCHARS (lc_key), n;
+         if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n))
+           n = PTRDIFF_MAX;
+         unsigned char *dst = SAFE_ALLOCA (n);
+
+         /* We can walk the string data byte by byte, because UTF-8
+            encoding ensures that no other byte of any multibyte
+            sequence will ever include a 7-bit byte equal to an ASCII
+            single-byte character.  */
+         memcpy (dst, SSDATA (lc_key), SBYTES (lc_key));
+         for (int i = 0; i < SBYTES (lc_key); ++i)
+           {
+             if (dst[i] == ' ')
+               dst[i] = '-';
+           }
+         Lisp_Object
+           new_it = make_multibyte_string ((char *) dst, SCHARS (lc_key), 
SBYTES (lc_key));
+         ASET (new_key, i, Fintern (new_it, Qnil));
+         SAFE_FREE ();
+       }
+
+      /* Check for match.  */
+      found = lookup_key_1 (keymap, new_key, accept_default);
+      if (!NILP (found) && !NUMBERP (found))
+       break;
+    }
+
+  return found;
+}
+
 /* Make KEYMAP define event C as a keymap (i.e., as a prefix).
    Assume that currently it does not define C at all.
    Return the keymap.  */
diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el
index 13f47b4..fc4dce0 100644
--- a/test/src/keymap-tests.el
+++ b/test/src/keymap-tests.el
@@ -124,6 +124,49 @@
 ;; (ert-deftest keymap-lookup-key/accept-default ()
 ;;   ...)
 
+(ert-deftest keymap-lookup-key/mixed-case ()
+  "Backwards compatibility behaviour (Bug#50752)."
+  (let ((map (make-keymap)))
+    (define-key map [menu-bar foo bar] 'foo)
+    (should (eq (lookup-key map [menu-bar foo bar]) 'foo))
+    (should (eq (lookup-key map [menu-bar Foo Bar]) 'foo)))
+  (let ((map (make-keymap)))
+    (define-key map [menu-bar i-bar] 'foo)
+    (should (eq (lookup-key map [menu-bar I-bar]) 'foo))))
+
+(ert-deftest keymap-lookup-key/mixed-case-multibyte ()
+  "Backwards compatibility behaviour (Bug#50752)."
+  (let ((map (make-keymap)))
+    ;; (downcase "Åäö") => "åäö"
+    (define-key map [menu-bar åäö bar] 'foo)
+    (should (eq (lookup-key map [menu-bar åäö bar]) 'foo))
+    (should (eq (lookup-key map [menu-bar Åäö Bar]) 'foo))
+    ;; (downcase "Γ") => "γ"
+    (define-key map [menu-bar γ bar] 'baz)
+    (should (eq (lookup-key map [menu-bar γ bar]) 'baz))
+    (should (eq (lookup-key map [menu-bar Γ Bar]) 'baz))))
+
+(ert-deftest keymap-lookup-keymap/with-spaces ()
+  "Backwards compatibility behaviour (Bug#50752)."
+  (let ((map (make-keymap)))
+    (define-key map [menu-bar foo-bar] 'foo)
+    (should (eq (lookup-key map [menu-bar Foo\ Bar]) 'foo))))
+
+(ert-deftest keymap-lookup-keymap/with-spaces-multibyte ()
+  "Backwards compatibility behaviour (Bug#50752)."
+  (let ((map (make-keymap)))
+    (define-key map [menu-bar åäö-bar] 'foo)
+    (should (eq (lookup-key map [menu-bar Åäö\ Bar]) 'foo))))
+
+(ert-deftest keymap-lookup-keymap/with-spaces-multibyte-lang-env ()
+  "Backwards compatibility behaviour (Bug#50752)."
+  (let ((lang-env current-language-environment))
+    (set-language-environment "Turkish")
+    (let ((map (make-keymap)))
+      (define-key map [menu-bar i-bar] 'foo)
+      (should (eq (lookup-key map [menu-bar I-bar]) 'foo)))
+    (set-language-environment lang-env)))
+
 (ert-deftest describe-buffer-bindings/header-in-current-buffer ()
   "Header should be inserted into the current buffer.
 https://debbugs.gnu.org/39149#31";