branch: externals/compat
commit 7e678b3fa102a86553921d6c24056bbbe5365c7e
Author: Daniel Mendler <m...@daniel-mendler.de>
Commit: Daniel Mendler <m...@daniel-mendler.de>
Add json-parse-string, json-parse-buffer, json-serialize and json-insert
---
NEWS.org | 2 +
compat-tests.el | 157 ++++++++++++++++++++++++++++++++++++++
compat.el | 233 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
compat.texi | 69 ++++++++++++++++-
4 files changed, 460 insertions(+), 1 deletion(-)
diff --git a/NEWS.org b/NEWS.org
index 84a9331abc..0973994b52 100644
--- a/NEWS.org
+++ b/NEWS.org
@@ -3,6 +3,8 @@
* Development
- compat-27: Add ~file-name-unquote~.
+- compat-28: Add libjansson compatibility functions ~json-parse-string~,
+ ~json-parse-buffer~, ~json-serialize~ and ~json-insert~.
- compat-29: Replace ~string-lines~ with version from Emacs 29, support
optional
KEEP-NEWLINES argument.
diff --git a/compat-tests.el b/compat-tests.el
index 9724314f5f..cf7af9b947 100644
--- a/compat-tests.el
+++ b/compat-tests.el
@@ -2839,5 +2839,162 @@
(should sentence-end-double-space)
(should-equal major-mode #'text-mode)))
+(ert-deftest json-parse-string ()
+ ;; Errors
+ (should-error (compat-call json-parse-string ""))
+ (should-error (compat-call json-parse-string " "))
+ (should-error (compat-call json-parse-string "11 22 33"))
+ (should-error (compat-call json-parse-string "[1][2]"))
+ (should-error (compat-call json-parse-string "[1"))
+ (should-error (compat-call json-parse-string " \"foo bar\"\"baz\" "))
+ ;; True, Null, False
+ (should-equal [t :false :null] (compat-call json-parse-string "
[true,false,null] "))
+ (should-equal [t nil nil] (compat-call json-parse-string " [true,false,null]
" :false-object nil :null-object nil))
+ (should-equal [t "false" nil] (compat-call json-parse-string "
[true,false,null] " :null-object nil :false-object "false"))
+ ;; RFC 4627
+ (should-equal [1 2 3] (compat-call json-parse-string " [1,2,3] "))
+ (should-equal [1 2 3] (compat-call json-parse-string "[1,2,3]"))
+ (should-equal ["a" 2 3] (compat-call json-parse-string "[\"a\",2,3]"))
+ (should-equal [["a" 2] 3] (compat-call json-parse-string "[[\"a\",2],3]"))
+ (should-equal [["a" 2] 3] (compat-call json-parse-string "[[\"a\",2],3]"
:array-type 'array))
+ (should-equal '(("a" 2) 3) (compat-call json-parse-string "[[\"a\",2],3]"
:array-type 'list))
+ (should-equal ["false" t] (compat-call json-parse-string "[false, true]"
:false-object "false"))
+ (let ((input "{\"key\":[\"abc\", 2], \"yek\": null}"))
+ (let ((obj (compat-call json-parse-string input :object-type 'alist)))
+ (should-equal (cdr (assq 'key obj)) ["abc" 2])
+ (should-equal (cdr (assq 'yek obj)) :null))
+ (let ((obj (compat-call json-parse-string input :object-type 'plist)))
+ (should-equal (plist-get obj :key) ["abc" 2])
+ (should-equal (plist-get obj :yek) :null))
+ (let ((obj (compat-call json-parse-string input :object-type 'hash-table)))
+ (should-equal (gethash "key" obj) ["abc" 2])
+ (should-equal (gethash "yek" obj) :null))
+ (let ((obj (compat-call json-parse-string input)))
+ (should-equal (gethash "key" obj) ["abc" 2])
+ (should-equal (gethash "yek" obj) :null)))
+ ;; RFC 8259
+ (should-equal "foo bar" (compat-call json-parse-string " \"foo bar\" "))
+ (should-equal 0 (compat-call json-parse-string " 0 "))
+ (should-equal 0 (compat-call json-parse-string " 0"))
+ (should-equal 0 (compat-call json-parse-string "0"))
+ (should-equal 1 (compat-call json-parse-string "1"))
+ (should-equal 0.5 (compat-call json-parse-string "0.5"))
+ (should-equal 'foo (compat-call json-parse-string "null" :null-object 'foo)))
+
+(ert-deftest json-parse-buffer ()
+ ;; Errors
+ (with-temp-buffer
+ (should-error (compat-call json-parse-buffer))
+ (insert " ")
+ (goto-char (point-min))
+ (should-error (compat-call json-parse-buffer)))
+ (with-temp-buffer
+ (insert "[1")
+ (goto-char (point-min))
+ (should-error (compat-call json-parse-buffer)))
+ ;; RFC 4627
+ (with-temp-buffer
+ (insert "[1,2] [4,5]")
+ (goto-char (point-min))
+ (should-equal [1 2] (compat-call json-parse-buffer)))
+ (with-temp-buffer
+ (insert "[1,2,3]")
+ (goto-char (point-min))
+ (should-equal [1 2 3] (compat-call json-parse-buffer)))
+ (with-temp-buffer
+ (insert " [1,2,3] ")
+ (goto-char (point-min))
+ (should-equal '(1 2 3) (compat-call json-parse-buffer :array-type 'list)))
+ ;; RFC 8259
+ (with-temp-buffer
+ (insert " 11 22 33 ")
+ (goto-char (point-min))
+ (should-equal 11 (compat-call json-parse-buffer)))
+ (with-temp-buffer
+ (insert "11 22 33")
+ (goto-char (point-min))
+ (should-equal 11 (compat-call json-parse-buffer)))
+ (with-temp-buffer
+ (insert " \"foo\" ")
+ (goto-char (point-min))
+ (should-equal "foo" (compat-call json-parse-buffer)))
+ (with-temp-buffer
+ (insert " [1,2,3][4,5,6]123{\"a\":1,\"b\":2}\"str\"")
+ (goto-char (point-min))
+ (should-equal [1 2 3] (compat-call json-parse-buffer))
+ (should-equal [4 5 6] (compat-call json-parse-buffer))
+ (should-equal 123 (compat-call json-parse-buffer))
+ (should (member
+ (compat-call json-parse-buffer :object-type 'plist)
+ '((:b 2 :a 1) (:a 1 :b 2))))
+ (should-equal "str" (compat-call json-parse-buffer)))
+ ;; TODO Our compatibility functions don't support RFC 4627 toplevel strings
+ ;; with spaces.
+ ;; (with-temp-buffer ;; TODO
+ ;; (insert " \"foo bar\"\"baz\" ")
+ ;; (goto-char (point-min))
+ ;; (should-equal "foo bar" (compat-call json-parse-buffer))
+ ;; (should-equal "baz" (compat-call json-parse-buffer)))
+ ;; (with-temp-buffer ;; TODO
+ ;; (insert " \"foo bar\" \"baz\" ")
+ ;; (goto-char (point-min))
+ ;; (should-equal "foo bar" (compat-call json-parse-buffer)))
+ (with-temp-buffer
+ (insert "0")
+ (goto-char (point-min))
+ (should-equal 0 (compat-call json-parse-buffer)))
+ (with-temp-buffer
+ (insert " 1 ")
+ (goto-char (point-min))
+ (should-equal 1 (compat-call json-parse-buffer))))
+
+(ert-deftest json-insert ()
+ (with-temp-buffer
+ (should-error (compat-call json-insert '(("a" . 1)))))
+ (with-temp-buffer
+ (compat-call json-insert nil)
+ (compat-call json-insert 1)
+ (compat-call json-insert [2 3 4])
+ (should-equal "{}1[2,3,4]" (buffer-string))))
+
+(ert-deftest json-serialize ()
+ (should-error (compat-call json-serialize '(("a" . 1))))
+ (should-error (compat-call json-serialize '("a" 1)))
+ (should-error (compat-call json-serialize '("a" 1 2)))
+ (should-error (compat-call json-serialize '(:a 1 2)))
+ (should-error (compat-call json-serialize '(1 . 2)))
+ (should-error (compat-call json-serialize '(1 2 3)))
+ (should-error (compat-call json-serialize '(:a 1 :b)))
+ (should-error (compat-call json-serialize '((one 1) (two 2))))
+ (should-error (compat-call json-serialize 'invalid))
+ (should-error (compat-call json-serialize :invalid))
+ (should-error (compat-call json-serialize
+ (let ((ht (make-hash-table)))
+ (puthash 'a 1 ht)
+ ht)))
+ (should-equal "[{}]" (compat-call json-serialize [nil]))
+ (should-equal "{}" (compat-call json-serialize nil))
+ (should-equal "{\"a\":{},\"b\":{}}" (compat-call json-serialize '(:a nil :b
nil)))
+ (should-equal "{\"a\":{},\"b\":{}}" (compat-call json-serialize '((a) (b))))
+ (should-equal "{\"a\":1,\"b\":2}" (compat-call json-serialize '(:a 1 :b 2)))
+ (should-equal "{\"one\":1,\"two\":2,\"three\":3}" (compat-call
json-serialize '(:one 1 two 2 three 3)))
+ (should-equal "{\"one\":1,\"two\":2}" (compat-call json-serialize '((one .
1) (two . 2))))
+ (should-equal "[true,false,null]" (compat-call json-serialize [t :false
:null]))
+ (should-equal "[true,false,null]" (compat-call json-serialize [t f n]
:null-object 'n :false-object 'f))
+ (should-equal "[true,false,null]" (compat-call json-serialize [t f nil]
:null-object nil :false-object 'f))
+ (should-equal "[true,false,null]" (compat-call json-serialize [t nil n]
:null-object 'n :false-object nil))
+ (should-equal "1" (compat-call json-serialize 1))
+ (should-equal "\"foo\"" (compat-call json-serialize "foo"))
+ (should-equal "[1,2,3]" (compat-call json-serialize [1 2 3]))
+ (should-equal "{\"key\":[\"abc\",2],\"yek\":true}"
+ (compat-call json-serialize '(:key ["abc" 2] yek t)))
+ (should-equal "{\":key\":[\"abc\",2],\"yek\":true}"
+ (compat-call json-serialize '((:key . ["abc" 2]) (yek . t))))
+ (should-equal "{\"key\":[\"abc\",2],\"yek\":true}"
+ (compat-call json-serialize (let ((ht (make-hash-table)))
+ (puthash "key" ["abc" 2] ht)
+ (puthash "yek" t ht)
+ ht))))
+
(provide 'compat-tests)
;;; compat-tests.el ends here
diff --git a/compat.el b/compat.el
index 62ca74a09c..1e38672e45 100644
--- a/compat.el
+++ b/compat.el
@@ -80,5 +80,238 @@ See also `compat-function' to lookup compatibility
functions."
(let ((compat (intern (format "compat--%s" fun))))
`(,(if (fboundp compat) compat fun) ,@args)))
+;;;; Backported libjansson API
+
+(unless (eval-when-compile (ignore-errors (eval '(json-parse-string "0") t)))
+ (defvar json-null)
+ (defvar json-false)
+ (defvar json-array-type)
+ (defvar json-object-type)
+ (defvar json-key-type)
+ (declare-function json-read nil)
+
+ (declare-function compat--json--print nil)
+ (unless (eval-when-compile (ignore-errors (eval '(json-parse-string "[]")
t)))
+ (defun compat--json--print (obj)
+ (cond
+ ((numberp obj) (prin1 obj))
+ ((eq obj t) (insert "true"))
+ ((eq obj json-null) (insert "null"))
+ ((eq obj json-false) (insert "false"))
+ ((not obj) (insert "{}"))
+ ((stringp obj)
+ (insert ?\")
+ (goto-char (prog1 (point) (princ obj)))
+ (while (re-search-forward "[\"\\[:cntrl:]]" nil 'move)
+ (let ((char (preceding-char)))
+ (delete-char -1)
+ (insert ?\\ (or (car (rassq char
+ '((?\" . ?\")
+ (?\\ . ?\\)
+ (?b . ?\b)
+ (?f . ?\f)
+ (?n . ?\n)
+ (?r . ?\r)
+ (?t . ?\t))))
+ (format "u%04x" char)))))
+ (insert ?\"))
+ ((hash-table-p obj)
+ (insert ?\{)
+ (let ((first t))
+ (maphash
+ (lambda (key val)
+ (unless (stringp key)
+ (signal 'wrong-type-argument `(stringp ,key)))
+ (if first (setq first nil) (insert ?,))
+ (compat--json--print key)
+ (insert ?:)
+ (compat--json--print val))
+ obj))
+ (insert ?\}))
+ ((and (car-safe obj) (symbolp (car obj))) ;; plist
+ (insert ?\{)
+ (let ((head obj))
+ (while obj
+ (unless (and (car obj) (symbolp (car obj)))
+ (signal 'wrong-type-argument `(symbolp ,obj)))
+ (unless (cdr obj)
+ (signal 'wrong-type-argument `(consp ,(cdr obj))))
+ (unless (eq obj head) (insert ?,))
+ (compat--json--print
+ (if (keywordp (car obj))
+ (substring (symbol-name (car obj)) 1)
+ (symbol-name (car obj))))
+ (insert ?:)
+ (compat--json--print (cadr obj))
+ (setq obj (cddr obj))))
+ (insert ?\}))
+ ((consp (car-safe obj)) ;; alist
+ (insert ?\{)
+ (let ((head obj))
+ (while obj
+ (unless (and (caar obj) (symbolp (caar obj)))
+ (signal 'wrong-type-argument `(symbolp ,(caar obj))))
+ (unless (eq obj head) (insert ?,))
+ (compat--json--print (symbol-name (caar obj)))
+ (insert ?:)
+ (compat--json--print (cdar obj))
+ (pop obj)))
+ (insert ?\}))
+ ((vectorp obj)
+ (insert ?\[)
+ (dotimes (i (length obj))
+ (when (> i 0) (insert ?,))
+ (compat--json--print (aref obj i)))
+ (insert ?\]))
+ (t (signal 'wrong-type-argument `(vectorp ,obj))))))
+
+ (defun compat--json-serialize (object &rest args) ;;
<compat-tests:json-serialize>
+ "Return the JSON representation of OBJECT as a string.
+
+OBJECT must be t, a number, string, vector, hashtable, alist, plist,
+or the Lisp equivalents to the JSON null and false values, and its
+elements must recursively consist of the same kinds of values. t will
+be converted to the JSON true value. Vectors will be converted to
+JSON arrays, whereas hashtables, alists and plists are converted to
+JSON objects. Hashtable keys must be strings without embedded null
+characters and must be unique within each object. Alist and plist
+keys must be symbols; if a key is duplicate, the first instance is
+used.
+
+The Lisp equivalents to the JSON null and false values are
+configurable in the arguments ARGS, a list of keyword/argument pairs:
+
+The keyword argument `:null-object' specifies which object to use
+to represent a JSON null value. It defaults to `:null'.
+
+The keyword argument `:false-object' specifies which object to use to
+represent a JSON false value. It defaults to `:false'.
+
+In you specify the same value for `:null-object' and `:false-object',
+a potentially ambiguous situation, the JSON output will not contain
+any JSON false values."
+ (if (eval-when-compile (ignore-errors (eval '(json-parse-string "[]") t)))
+ (if (or (listp object) (vectorp object))
+ (apply 'json-serialize object args)
+ (substring (apply 'json-serialize (vector object) args) 1 -1))
+ (let ((json-false (if (plist-member args :false-object)
+ (plist-get args :false-object)
+ :false))
+ (json-null (if (plist-member args :null-object)
+ (plist-get args :null-object)
+ :null)))
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (compat--json--print object))))))
+
+ (defun compat--json-insert (object &rest args) ;; <compat-tests:json-insert>
+ "Insert the JSON representation of OBJECT before point.
+This is the same as (insert (json-serialize OBJECT)), but potentially
+faster. See the function `json-serialize' for allowed values of
+OBJECT."
+ (if (eval-when-compile (ignore-errors (eval '(json-parse-string "[]") t)))
+ (if (or (listp object) (vectorp object))
+ (apply 'json-insert object args)
+ (insert (substring (apply 'json-serialize (vector object) args) 1
-1)))
+ (let ((json-false (if (plist-member args :false-object)
+ (plist-get args :false-object)
+ :false))
+ (json-null (if (plist-member args :null-object)
+ (plist-get args :null-object)
+ :null))
+ (standard-output (current-buffer)))
+ (compat--json--print object))))
+
+ (defun compat--json-parse-buffer (&rest args) ;;
<compat-tests:json-parse-buffer>
+ "Read JSON object from current buffer starting at point.
+Move point after the end of the object if parsing was successful.
+On error, don't move point.
+
+The returned object will be a vector, list, hashtable, alist, or
+plist. Its elements will be the JSON null value, the JSON false
+value, t, numbers, strings, or further vectors, lists, hashtables,
+alists, or plists. If there are duplicate keys in an object, all
+but the last one are ignored.
+
+If the current buffer doesn't contain a valid JSON object, the
+function signals an error of type `json-parse-error'.
+
+The arguments ARGS are a list of keyword/argument pairs:
+
+The keyword argument `:object-type' specifies which Lisp type is used
+to represent objects; it can be `hash-table', `alist' or `plist'. It
+defaults to `hash-table'.
+
+The keyword argument `:array-type' specifies which Lisp type is used
+to represent arrays; it can be `array' (the default) or `list'.
+
+The keyword argument `:null-object' specifies which object to use
+to represent a JSON null value. It defaults to `:null'.
+
+The keyword argument `:false-object' specifies which object to use to
+represent a JSON false value. It defaults to `:false'."
+ (if (eval-when-compile (ignore-errors (eval '(json-parse-string "[]") t)))
+ (save-match-data
+ (if (looking-at "\\s-*\\([^[{[:space:]]+\\)")
+ (let ((str (match-string 1)))
+ (goto-char (match-end 0))
+ (apply 'compat--json-parse-string str args))
+ (apply 'json-parse-buffer args)))
+ (unless (fboundp 'json-read)
+ (require 'json))
+ (let ((json-key-type nil)
+ (json-object-type (or (plist-get args :object-type) 'hash-table))
+ (json-array-type (or (plist-get args :array-type) 'array))
+ (json-false (if (plist-member args :false-object)
+ (plist-get args :false-object)
+ :false))
+ (json-null (if (plist-member args :null-object)
+ (plist-get args :null-object)
+ :null)))
+ (when (eq json-array-type 'array)
+ (setq json-array-type 'vector))
+ (json-read))))
+
+ (defun compat--json-parse-string (string &rest args) ;;
<compat-tests:json-parse-string>
+ "Parse the JSON STRING into a Lisp object.
+This is essentially the reverse operation of `json-serialize', which
+see. The returned object will be the JSON null value, the JSON false
+value, t, a number, a string, a vector, a list, a hashtable, an alist,
+or a plist. Its elements will be further objects of these types. If
+there are duplicate keys in an object, all but the last one are
+ignored. If STRING doesn't contain a valid JSON object, this function
+signals an error of type `json-parse-error'.
+
+The arguments ARGS are a list of keyword/argument pairs:
+
+The keyword argument `:object-type' specifies which Lisp type is used
+to represent objects; it can be `hash-table', `alist' or `plist'. It
+defaults to `hash-table'.
+
+The keyword argument `:array-type' specifies which Lisp type is used
+to represent arrays; it can be `array' (the default) or `list'.
+
+The keyword argument `:null-object' specifies which object to use
+to represent a JSON null value. It defaults to `:null'.
+
+The keyword argument `:false-object' specifies which object to use to
+represent a JSON false value. It defaults to `:false'."
+ (if (eval-when-compile (ignore-errors (eval '(json-parse-string "[]") t)))
+ (if (string-match-p "\\`\\s-*[[{]" string)
+ (apply 'json-parse-string string args)
+ ;; Add array wrapper and extract first element, in order to
+ ;; support RFC 8259. The older RFC 4627 implemented by
+ ;; `json-parse-string' did not support parsing toplevel atoms.
+ (elt (apply 'json-parse-string (concat "[" string "]") args) 0))
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ ;; Do not use `json-read-from-string' here, since it also creates a
+ ;; temporary buffer.
+ (prog1 (apply 'compat--json-parse-buffer args)
+ (skip-chars-forward "[:space:]")
+ (unless (eobp)
+ (signal 'json-error "Trailing content after JSON stream")))))))
+
(provide 'compat)
;;; compat.el ends here
diff --git a/compat.texi b/compat.texi
index e70c63d0ee..798c663177 100644
--- a/compat.texi
+++ b/compat.texi
@@ -2028,6 +2028,73 @@ If native compilation is not available, this function
always returns
These functions must be called explicitly via @code{compat-call},
since their calling convention or behavior was extended in Emacs 28.1:
+@c copied from lispref/text.texi
+@defun compat-call@ json-serialize object &rest args
+This function returns a new Lisp string which contains the JSON
+representation of @var{object}. The argument @var{args} is a list of
+keyword/argument pairs. The following keywords are accepted:
+
+@table @code
+@item :null-object
+The value decides which Lisp object to use to represent the JSON
+keyword @code{null}. It defaults to the symbol @code{:null}.
+
+@item :false-object
+The value decides which Lisp object to use to represent the JSON
+keyword @code{false}. It defaults to the symbol @code{:false}.
+@end table
+
+@end defun
+
+@c copied from lispref/text.texi
+@defun compat-call@ json-insert object &rest args
+This function inserts the JSON representation of @var{object} into the
+current buffer before point. The argument @var{args} are interpreted
+as in @code{json-parse-string}.
+@end defun
+
+@c copied from lispref/text.texi
+@defun compat-call@ json-parse-string string &rest args
+This function parses the JSON value in @var{string}, which must be a
+Lisp string. If @var{string} doesn't contain a valid JSON object,
+this function signals the @code{json-parse-error} error.
+
+The argument @var{args} is a list of keyword/argument pairs. The
+following keywords are accepted:
+
+@table @code
+@item :object-type
+The value decides which Lisp object to use for representing the
+key-value mappings of a JSON object. It can be either
+@code{hash-table}, the default, to make hashtables with strings as
+keys; @code{alist} to use alists with symbols as keys; or @code{plist}
+to use plists with keyword symbols as keys.
+
+@item :array-type
+The value decides which Lisp object to use for representing a JSON
+array. It can be either @code{array}, the default, to use Lisp
+arrays; or @code{list} to use lists.
+
+@item :null-object
+The value decides which Lisp object to use to represent the JSON
+keyword @code{null}. It defaults to the symbol @code{:null}.
+
+@item :false-object
+The value decides which Lisp object to use to represent the JSON
+keyword @code{false}. It defaults to the symbol @code{:false}.
+@end table
+
+@end defun
+
+@c copied from lispref/text.texi
+@defun compat-call@ json-parse-buffer &rest args
+This function reads the next JSON value from the current buffer,
+starting at point. It moves point to the position immediately after
+the value if contains a valid JSON object; otherwise it signals the
+@code{json-parse-error} error and doesn't move point. The arguments
+@var{args} are interpreted as in @code{json-parse-string}.
+@end defun
+
@defun compat-call@ string-width string &optional from to
This function returns the width in columns of the string @var{string},
if it were displayed in the current buffer and the selected window.
@@ -2090,7 +2157,7 @@ Support for the @code{natnum} defcustom type.
@item
Additional Edebug keywords.
@item
-The libjansson JSON APIs, e.g., @code{json-parse-string}.
+The function @code{json-available-p}.
@item
The macro @code{pcase-setq}.
@item
