Fix json.el encoding of confusable object keys

* lisp/json.el (json-encode-string): Clarify commentary.
(json--encode-stringlike): New function that covers a subset of
json-encode.
(json-encode-key): Use it for more efficient encoding and
validation, and to avoid mishandling confusable keys like boolean
symbols (bug#42545).
(json-encode-array): Make it clearer that argument can be a list.
(json-encode): Reuse json-encode-keyword and json--encode-stringlike
for a subset of the dispatch logic.
(json-pretty-print): Ensure confusable keys like ":a" survive a
decoding/encoding roundtrip (bug#24252, bug#45032).

* test/lisp/json-tests.el (test-json-encode-string)
(test-json-encode-hash-table, test-json-encode-alist)
(test-json-encode-plist, test-json-pretty-print-object): Test
encoding of confusable keys.

2 files changed, 90 insertions, 25 deletions

diff --git a/lisp/json.el b/lisp/json.el
index 1f1f608eaba..f20123fcfbc 100644
--- a/lisp/json.el
+++ b/lisp/json.el
@@ -438,7 +438,8 @@ Initialized lazily by `json-encode-string'.")
               ;; This seems to afford decent performance gains.
               (setq-local inhibit-modification-hooks t)
               (setq json--string-buffer (current-buffer))))
-      (insert ?\" (substring-no-properties string)) ; see bug#43549
+      ;; Strip `read-only' property (bug#43549).
+      (insert ?\" (substring-no-properties string))
       (goto-char (1+ (point-min)))
       (while (re-search-forward (rx json--escape) nil 'move)
         (let ((char (preceding-char)))
@@ -452,14 +453,20 @@ Initialized lazily by `json-encode-string'.")
       ;; Empty buffer for next invocation.
       (delete-and-extract-region (point-min) (point-max)))))
 
+(defun json--encode-stringlike (object)
+  "Return OBJECT encoded as a JSON string, or nil if not possible."
+  (cond ((stringp object)  (json-encode-string object))
+        ((keywordp object) (json-encode-string
+                            (substring (symbol-name object) 1)))
+        ((symbolp object)  (json-encode-string (symbol-name object)))))
+
 (defun json-encode-key (object)
   "Return a JSON representation of OBJECT.
 If the resulting JSON object isn't a valid JSON object key,
 this signals `json-key-format'."
-  (let ((encoded (json-encode object)))
-    (unless (stringp (json-read-from-string encoded))
-      (signal 'json-key-format (list object)))
-    encoded))
+  ;; Encoding must be a JSON string.
+  (or (json--encode-stringlike object)
+      (signal 'json-key-format (list object))))
 
 ;;; Objects
 
@@ -652,11 +659,10 @@ become JSON objects."
 ;; Array encoding
 
 (defun json-encode-array (array)
-  "Return a JSON representation of ARRAY."
+  "Return a JSON representation of ARRAY.
+ARRAY can also be a list."
   (if (and json-encoding-pretty-print
-           (if (listp array)
-               array
-             (> (length array) 0)))
+           (not (length= array 0)))
       (concat
        "["
        (json--with-indentation
@@ -737,15 +743,9 @@ you will get the following structure returned:
 OBJECT should have a structure like one returned by `json-read'.
 If an error is detected during encoding, an error based on
 `json-error' is signaled."
-  (cond ((eq object t)          (json-encode-keyword object))
-        ((eq object json-null)  (json-encode-keyword object))
-        ((eq object json-false) (json-encode-keyword object))
-        ((stringp object)       (json-encode-string object))
-        ((keywordp object)      (json-encode-string
-                                 (substring (symbol-name object) 1)))
+  (cond ((json-encode-keyword object))
         ((listp object)         (json-encode-list object))
-        ((symbolp object)       (json-encode-string
-                                 (symbol-name object)))
+        ((json--encode-stringlike object))
         ((numberp object)       (json-encode-number object))
         ((arrayp object)        (json-encode-array object))
         ((hash-table-p object)  (json-encode-hash-table object))
@@ -774,6 +774,8 @@ With prefix argument MINIMIZE, minimize it instead."
         (json-null :json-null)
         ;; Ensure that ordering is maintained.
         (json-object-type 'alist)
+        ;; Ensure that keys survive roundtrip (bug#24252, bug#42545).
+        (json-key-type 'string)
         (orig-buf (current-buffer))
         error)
     ;; Strategy: Repeatedly `json-read' from the original buffer and
diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el
index 11b61d8b47e..9886dc0d457 100644
--- a/test/lisp/json-tests.el
+++ b/test/lisp/json-tests.el
@@ -421,12 +421,21 @@ Point is moved to beginning of the buffer."
                  "\"\\nasdфыв\\u001f\u007ffgh\\t\"")))
 
 (ert-deftest test-json-encode-key ()
-  (should (equal (json-encode-key "") "\"\""))
   (should (equal (json-encode-key '##) "\"\""))
   (should (equal (json-encode-key :) "\"\""))
-  (should (equal (json-encode-key "foo") "\"foo\""))
-  (should (equal (json-encode-key 'foo) "\"foo\""))
-  (should (equal (json-encode-key :foo) "\"foo\""))
+  (should (equal (json-encode-key "") "\"\""))
+  (should (equal (json-encode-key 'a) "\"a\""))
+  (should (equal (json-encode-key :a) "\"a\""))
+  (should (equal (json-encode-key "a") "\"a\""))
+  (should (equal (json-encode-key t) "\"t\""))
+  (should (equal (json-encode-key :t) "\"t\""))
+  (should (equal (json-encode-key "t") "\"t\""))
+  (should (equal (json-encode-key nil) "\"nil\""))
+  (should (equal (json-encode-key :nil) "\"nil\""))
+  (should (equal (json-encode-key "nil") "\"nil\""))
+  (should (equal (json-encode-key ":a") "\":a\""))
+  (should (equal (json-encode-key ":t") "\":t\""))
+  (should (equal (json-encode-key ":nil") "\":nil\""))
   (should (equal (should-error (json-encode-key 5))
                  '(json-key-format 5)))
   (should (equal (should-error (json-encode-key ["foo"]))
@@ -572,6 +581,39 @@ Point is moved to beginning of the buffer."
     (should (equal (json-encode-hash-table #s(hash-table)) "{}"))
     (should (equal (json-encode-hash-table #s(hash-table data (a 1)))
                    "{\"a\":1}"))
+    (should (equal (json-encode-hash-table #s(hash-table data (t 1)))
+                   "{\"t\":1}"))
+    (should (equal (json-encode-hash-table #s(hash-table data (nil 1)))
+                   "{\"nil\":1}"))
+    (should (equal (json-encode-hash-table #s(hash-table data (:a 1)))
+                   "{\"a\":1}"))
+    (should (equal (json-encode-hash-table #s(hash-table data (:t 1)))
+                   "{\"t\":1}"))
+    (should (equal (json-encode-hash-table #s(hash-table data (:nil 1)))
+                   "{\"nil\":1}"))
+    (should (equal (json-encode-hash-table
+                    #s(hash-table test equal data ("a" 1)))
+                   "{\"a\":1}"))
+    (should (equal (json-encode-hash-table
+                    #s(hash-table test equal data ("t" 1)))
+                   "{\"t\":1}"))
+    (should (equal (json-encode-hash-table
+                    #s(hash-table test equal data ("nil" 1)))
+                   "{\"nil\":1}"))
+    (should (equal (json-encode-hash-table
+                    #s(hash-table test equal data (":a" 1)))
+                   "{\":a\":1}"))
+    (should (equal (json-encode-hash-table
+                    #s(hash-table test equal data (":t" 1)))
+                   "{\":t\":1}"))
+    (should (equal (json-encode-hash-table
+                    #s(hash-table test equal data (":nil" 1)))
+                   "{\":nil\":1}"))
+    (should (member (json-encode-hash-table #s(hash-table data (t 2 :nil 1)))
+                    '("{\"nil\":1,\"t\":2}" "{\"t\":2,\"nil\":1}")))
+    (should (member (json-encode-hash-table
+                     #s(hash-table test equal data (:t 2 ":t" 1)))
+                    '("{\":t\":1,\"t\":2}" "{\"t\":2,\":t\":1}")))
     (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1)))
                     '("{\"a\":1,\"b\":2}" "{\"b\":2,\"a\":1}")))
     (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1)))
@@ -638,7 +680,16 @@ Point is moved to beginning of the buffer."
   (let ((json-encoding-object-sort-predicate nil)
         (json-encoding-pretty-print nil))
     (should (equal (json-encode-alist ()) "{}"))
-    (should (equal (json-encode-alist '((a . 1))) "{\"a\":1}"))
+    (should (equal (json-encode-alist '((a . 1) (t . 2) (nil . 3)))
+                   "{\"a\":1,\"t\":2,\"nil\":3}"))
+    (should (equal (json-encode-alist '((:a . 1) (:t . 2) (:nil . 3)))
+                   "{\"a\":1,\"t\":2,\"nil\":3}"))
+    (should (equal (json-encode-alist '(("a" . 1) ("t" . 2) ("nil" . 3)))
+                   "{\"a\":1,\"t\":2,\"nil\":3}"))
+    (should (equal (json-encode-alist '((":a" . 1) (":t" . 2) (":nil" . 3)))
+                   "{\":a\":1,\":t\":2,\":nil\":3}"))
+    (should (equal (json-encode-alist '((t . 1) (:nil . 2) (":nil" . 3)))
+                   "{\"t\":1,\"nil\":2,\":nil\":3}"))
     (should (equal (json-encode-alist '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}"))
     (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1)))
                    "{\"c\":3,\"b\":2,\"a\":1}"))))
@@ -687,8 +738,14 @@ Point is moved to beginning of the buffer."
     (should (equal (json-encode-plist ()) "{}"))
     (should (equal (json-encode-plist '(:a 1)) "{\"a\":1}"))
     (should (equal (json-encode-plist '(:b 2 :a 1)) "{\"b\":2,\"a\":1}"))
-    (should (equal (json-encode-plist '(:c 3 :b 2 :a 1))
-                   "{\"c\":3,\"b\":2,\"a\":1}"))))
+    (should (equal (json-encode-plist '(":d" 4 "c" 3 b 2 :a 1))
+                   "{\":d\":4,\"c\":3,\"b\":2,\"a\":1}"))
+    (should (equal (json-encode-plist '(nil 2 t 1))
+                   "{\"nil\":2,\"t\":1}"))
+    (should (equal (json-encode-plist '(:nil 2 :t 1))
+                   "{\"nil\":2,\"t\":1}"))
+    (should (equal (json-encode-plist '(":nil" 4 "nil" 3 ":t" 2 "t" 1))
+                   "{\":nil\":4,\"nil\":3,\":t\":2,\"t\":1}"))))
 
 (ert-deftest test-json-encode-plist-pretty ()
   (let ((json-encoding-object-sort-predicate nil)
@@ -950,7 +1007,13 @@ nil, ORIGINAL should stay unchanged by pretty-printing."
   ;; Nested array.
   (json-tests-equal-pretty-print
    "{\"key\":[1,2]}"
-   "{\n  \"key\": [\n    1,\n    2\n  ]\n}"))
+   "{\n  \"key\": [\n    1,\n    2\n  ]\n}")
+  ;; Confusable keys (bug#24252, bug#42545).
+  (json-tests-equal-pretty-print
+   (concat "{\"t\":1,\"nil\":2,\":t\":3,\":nil\":4,"
+           "\"null\":5,\":json-null\":6,\":json-false\":7}")
+   (concat "{\n  \"t\": 1,\n  \"nil\": 2,\n  \":t\": 3,\n  \":nil\": 4,"
+           "\n  \"null\": 5,\n  \":json-null\": 6,\n  \":json-false\": 7\n}")))
 
 (ert-deftest test-json-pretty-print-array ()
   ;; Empty.