aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--configure.ac20
-rw-r--r--doc/lispref/text.texi87
-rw-r--r--etc/NEWS11
-rw-r--r--src/Makefile.in11
-rw-r--r--src/emacs.c8
-rw-r--r--src/eval.c54
-rw-r--r--src/json.c576
-rw-r--r--src/lisp.h7
-rw-r--r--test/src/json-tests.el97
9 files changed, 867 insertions, 4 deletions
diff --git a/configure.ac b/configure.ac
index 61455a4b0fa..83369f763aa 100644
--- a/configure.ac
+++ b/configure.ac
@@ -355,6 +355,7 @@ OPTION_DEFAULT_ON([libsystemd],[don't compile with libsystemd support])
355OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)]) 355OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)])
356OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) 356OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support])
357OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image support]) 357OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image support])
358OPTION_DEFAULT_ON([json], [don't compile with native JSON support])
358 359
359OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) 360OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts])
360OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support]) 361OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support])
@@ -2870,6 +2871,22 @@ fi
2870AC_SUBST(LIBSYSTEMD_LIBS) 2871AC_SUBST(LIBSYSTEMD_LIBS)
2871AC_SUBST(LIBSYSTEMD_CFLAGS) 2872AC_SUBST(LIBSYSTEMD_CFLAGS)
2872 2873
2874HAVE_JSON=no
2875JSON_OBJ=
2876
2877if test "${with_json}" = yes; then
2878 EMACS_CHECK_MODULES([JSON], [jansson >= 2.5],
2879 [HAVE_JSON=yes], [HAVE_JSON=no])
2880 if test "${HAVE_JSON}" = yes; then
2881 AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.])
2882 JSON_OBJ=json.o
2883 fi
2884fi
2885
2886AC_SUBST(JSON_LIBS)
2887AC_SUBST(JSON_CFLAGS)
2888AC_SUBST(JSON_OBJ)
2889
2873NOTIFY_OBJ= 2890NOTIFY_OBJ=
2874NOTIFY_SUMMARY=no 2891NOTIFY_SUMMARY=no
2875 2892
@@ -5366,7 +5383,7 @@ emacs_config_features=
5366for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ 5383for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \
5367 GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \ 5384 GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \
5368 LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 NS MODULES \ 5385 LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 NS MODULES \
5369 XWIDGETS LIBSYSTEMD CANNOT_DUMP LCMS2; do 5386 XWIDGETS LIBSYSTEMD JSON CANNOT_DUMP LCMS2; do
5370 5387
5371 case $opt in 5388 case $opt in
5372 CANNOT_DUMP) eval val=\${$opt} ;; 5389 CANNOT_DUMP) eval val=\${$opt} ;;
@@ -5416,6 +5433,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D
5416 Does Emacs use -lotf? ${HAVE_LIBOTF} 5433 Does Emacs use -lotf? ${HAVE_LIBOTF}
5417 Does Emacs use -lxft? ${HAVE_XFT} 5434 Does Emacs use -lxft? ${HAVE_XFT}
5418 Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD} 5435 Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD}
5436 Does Emacs use -ljansson? ${HAVE_JSON}
5419 Does Emacs directly use zlib? ${HAVE_ZLIB} 5437 Does Emacs directly use zlib? ${HAVE_ZLIB}
5420 Does Emacs have dynamic modules support? ${HAVE_MODULES} 5438 Does Emacs have dynamic modules support? ${HAVE_MODULES}
5421 Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS} 5439 Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS}
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index 35ba5d0dddc..5b288d9750e 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -61,6 +61,7 @@ the character after point.
61* Checksum/Hash:: Computing cryptographic hashes. 61* Checksum/Hash:: Computing cryptographic hashes.
62* GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS. 62* GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS.
63* Parsing HTML/XML:: Parsing HTML and XML. 63* Parsing HTML/XML:: Parsing HTML and XML.
64* Parsing JSON:: Parsing and generating JSON values.
64* Atomic Changes:: Installing several buffer changes atomically. 65* Atomic Changes:: Installing several buffer changes atomically.
65* Change Hooks:: Supplying functions to be run when text is changed. 66* Change Hooks:: Supplying functions to be run when text is changed.
66@end menu 67@end menu
@@ -4934,6 +4935,92 @@ textual nodes that just contain white-space.
4934@end table 4935@end table
4935 4936
4936 4937
4938@node Parsing JSON
4939@section Parsing and generating JSON values
4940@cindex JSON
4941
4942 When Emacs is compiled with JSON support, it provides a couple of
4943functions to convert between Lisp objects and JSON values. Any JSON
4944value can be converted to a Lisp object, but not vice versa.
4945Specifically:
4946
4947@itemize
4948
4949@item
4950JSON has a couple of keywords: @code{null}, @code{false}, and
4951@code{true}. These are represented in Lisp using the keywords
4952@code{:null}, @code{:false}, and @code{t}, respectively.
4953
4954@item
4955JSON only has floating-point numbers. They can represent both Lisp
4956integers and Lisp floating-point numbers.
4957
4958@item
4959JSON strings are always Unicode strings. Lisp strings can contain
4960non-Unicode characters.
4961
4962@item
4963JSON has only one sequence type, the array. JSON arrays are
4964represented using Lisp vectors.
4965
4966@item
4967JSON has only one map type, the object. JSON objects are represented
4968using Lisp hashtables.
4969
4970@end itemize
4971
4972@noindent
4973Note that @code{nil} doesn't represent any JSON values: this is to
4974avoid confusion, because @code{nil} could either represent
4975@code{null}, @code{false}, or an empty array, all of which are
4976different JSON values.
4977
4978 If some Lisp object can't be represented in JSON, the serialization
4979functions will signal an error of type @code{wrong-type-argument}.
4980The parsing functions will signal the following errors:
4981
4982@table @code
4983
4984@item json-end-of-file
4985 Signaled when encountering a premature end of the input text.
4986
4987@item json-trailing-content
4988 Signaled when encountering unexpected input after the first JSON
4989 object parsed.
4990
4991@item json-parse-error
4992 Signaled when encountering invalid JSON syntax.
4993
4994@end table
4995
4996 Only top-level values (arrays and objects) can be serialized to
4997JSON. The subobjects within these top-level values can be of any
4998type. Likewise, the parsing functions will only return vectors and
4999hashtables.
5000
5001@defun json-serialize object
5002This function returns a new Lisp string which contains the JSON
5003representation of @var{object}.
5004@end defun
5005
5006@defun json-insert object
5007This function inserts the JSON representation of @var{object} into the
5008current buffer before point.
5009@end defun
5010
5011@defun json-parse-string string
5012This function parses the JSON value in @var{string}, which must be a
5013Lisp string.
5014@end defun
5015
5016@defun json-parse-buffer
5017This function reads the next JSON value from the current buffer,
5018starting at point. It moves point to the position immediately after
5019the value if a value could be read and converted to Lisp; otherwise it
5020doesn't move point.
5021@end defun
5022
5023
4937@node Atomic Changes 5024@node Atomic Changes
4938@section Atomic Change Groups 5025@section Atomic Change Groups
4939@cindex atomic changes 5026@cindex atomic changes
diff --git a/etc/NEWS b/etc/NEWS
index dd7d9839700..c0d0d42d3f7 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -24,6 +24,13 @@ When you add a new item, use the appropriate mark if you are sure it applies,
24 24
25* Installation Changes in Emacs 27.1 25* Installation Changes in Emacs 27.1
26 26
27** The new configure option '--with-json' adds support for JSON using
28the Jansson library. It is on by default; use 'configure
29--with-json=no' to build without Jansson support. The new JSON
30functions 'json-serialize', 'json-insert', 'json-parse-string', and
31'json-parse-buffer' are typically much faster than their Lisp
32counterparts from json.el.
33
27 34
28* Startup Changes in Emacs 27.1 35* Startup Changes in Emacs 27.1
29 36
@@ -164,6 +171,10 @@ remote systems, which support this check.
164If the optional third argument is non-nil, 'make-string' will produce 171If the optional third argument is non-nil, 'make-string' will produce
165a multibyte string even if its second argument is an ASCII character. 172a multibyte string even if its second argument is an ASCII character.
166 173
174** New JSON parsing and serialization functions 'json-serialize',
175'json-insert', 'json-parse-string', and 'json-parse-buffer'. These
176are implemented in C using the Jansson library.
177
167 178
168* Changes in Emacs 27.1 on Non-Free Operating Systems 179* Changes in Emacs 27.1 on Non-Free Operating Systems
169 180
diff --git a/src/Makefile.in b/src/Makefile.in
index 9a8c9c85f04..b395627893d 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -312,6 +312,10 @@ LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@
312LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@ 312LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@
313LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@ 313LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@
314 314
315JSON_LIBS = @JSON_LIBS@
316JSON_CFLAGS = @JSON_CFLAGS@
317JSON_OBJ = @JSON_OBJ@
318
315INTERVALS_H = dispextern.h intervals.h composite.h 319INTERVALS_H = dispextern.h intervals.h composite.h
316 320
317GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ 321GETLOADAVG_LIBS = @GETLOADAVG_LIBS@
@@ -363,7 +367,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \
363 $(WEBKIT_CFLAGS) \ 367 $(WEBKIT_CFLAGS) \
364 $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ 368 $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \
365 $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ 369 $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \
366 $(LIBSYSTEMD_CFLAGS) \ 370 $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \
367 $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ 371 $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \
368 $(WERROR_CFLAGS) 372 $(WERROR_CFLAGS)
369ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) 373ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS)
@@ -397,7 +401,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
397 thread.o systhread.o \ 401 thread.o systhread.o \
398 $(if $(HYBRID_MALLOC),sheap.o) \ 402 $(if $(HYBRID_MALLOC),sheap.o) \
399 $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ 403 $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
400 $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) 404 $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ)
401obj = $(base_obj) $(NS_OBJC_OBJ) 405obj = $(base_obj) $(NS_OBJC_OBJ)
402 406
403## Object files used on some machine or other. 407## Object files used on some machine or other.
@@ -493,7 +497,8 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \
493 $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ 497 $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \
494 $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ 498 $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
495 $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \ 499 $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \
496 $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) 500 $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \
501 $(JSON_LIBS)
497 502
498## FORCE it so that admin/unidata can decide whether these files 503## FORCE it so that admin/unidata can decide whether these files
499## are up-to-date. Although since charprop depends on bootstrap-emacs, 504## are up-to-date. Although since charprop depends on bootstrap-emacs,
diff --git a/src/emacs.c b/src/emacs.c
index 808abcd9aa2..7c1ae1f2c5b 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1262,6 +1262,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
1262 running_asynch_code = 0; 1262 running_asynch_code = 0;
1263 init_random (); 1263 init_random ();
1264 1264
1265#ifdef HAVE_JSON
1266 init_json ();
1267#endif
1268
1265 no_loadup 1269 no_loadup
1266 = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); 1270 = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args);
1267 1271
@@ -1608,6 +1612,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
1608 syms_of_threads (); 1612 syms_of_threads ();
1609 syms_of_profiler (); 1613 syms_of_profiler ();
1610 1614
1615#ifdef HAVE_JSON
1616 syms_of_json ();
1617#endif
1618
1611 keys_of_casefiddle (); 1619 keys_of_casefiddle ();
1612 keys_of_cmds (); 1620 keys_of_cmds ();
1613 keys_of_buffer (); 1621 keys_of_buffer ();
diff --git a/src/eval.c b/src/eval.c
index 47c4f17eabc..b774fd06139 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1416,6 +1416,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
1416 } 1416 }
1417} 1417}
1418 1418
1419static Lisp_Object
1420internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument)
1421{
1422 struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL);
1423 if (c == NULL)
1424 return Qcatch_all_memory_full;
1425
1426 if (sys_setjmp (c->jmp) == 0)
1427 {
1428 Lisp_Object val = function (argument);
1429 eassert (handlerlist == c);
1430 handlerlist = c->next;
1431 return val;
1432 }
1433 else
1434 {
1435 eassert (handlerlist == c);
1436 Lisp_Object val = c->val;
1437 handlerlist = c->next;
1438 Fsignal (Qno_catch, val);
1439 }
1440}
1441
1442/* Like a combination of internal_condition_case_1 and internal_catch.
1443 Catches all signals and throws. Never exits nonlocally; returns
1444 Qcatch_all_memory_full if no handler could be allocated. */
1445
1446Lisp_Object
1447internal_catch_all (Lisp_Object (*function) (void *), void *argument,
1448 Lisp_Object (*handler) (Lisp_Object))
1449{
1450 struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE);
1451 if (c == NULL)
1452 return Qcatch_all_memory_full;
1453
1454 if (sys_setjmp (c->jmp) == 0)
1455 {
1456 Lisp_Object val = internal_catch_all_1 (function, argument);
1457 eassert (handlerlist == c);
1458 handlerlist = c->next;
1459 return val;
1460 }
1461 else
1462 {
1463 eassert (handlerlist == c);
1464 Lisp_Object val = c->val;
1465 handlerlist = c->next;
1466 return handler (val);
1467 }
1468}
1469
1419struct handler * 1470struct handler *
1420push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype) 1471push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype)
1421{ 1472{
@@ -4067,6 +4118,9 @@ alist of active lexical bindings. */);
4067 4118
4068 inhibit_lisp_code = Qnil; 4119 inhibit_lisp_code = Qnil;
4069 4120
4121 DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full");
4122 Funintern (Qcatch_all_memory_full, Qnil);
4123
4070 defsubr (&Sor); 4124 defsubr (&Sor);
4071 defsubr (&Sand); 4125 defsubr (&Sand);
4072 defsubr (&Sif); 4126 defsubr (&Sif);
diff --git a/src/json.c b/src/json.c
new file mode 100644
index 00000000000..dc449e43e11
--- /dev/null
+++ b/src/json.c
@@ -0,0 +1,576 @@
1/* JSON parsing and serialization.
2
3Copyright (C) 2017 Free Software Foundation, Inc.
4
5This file is part of GNU Emacs.
6
7GNU Emacs is free software: you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation, either version 3 of the License, or (at
10your option) any later version.
11
12GNU Emacs is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
19
20#include <config.h>
21
22#include <errno.h>
23#include <stddef.h>
24#include <stdint.h>
25#include <stdlib.h>
26
27#include <jansson.h>
28
29#include "lisp.h"
30#include "buffer.h"
31#include "coding.h"
32
33/* We install a custom allocator so that we can avoid objects larger
34 than PTRDIFF_MAX. Such objects wouldn’t play well with the rest of
35 Emacs’s codebase, which generally uses ptrdiff_t for sizes and
36 indices. The other functions in this file also generally assume
37 that size_t values never exceed PTRDIFF_MAX. */
38
39static void *
40json_malloc (size_t size)
41{
42 if (size > PTRDIFF_MAX)
43 {
44 errno = ENOMEM;
45 return NULL;
46 }
47 return malloc (size);
48}
49
50static void
51json_free (void *ptr)
52{
53 free (ptr);
54}
55
56void
57init_json (void)
58{
59 json_set_alloc_funcs (json_malloc, json_free);
60}
61
62/* Return whether STRING starts with PREFIX. */
63
64static bool
65json_has_prefix (const char *string, const char *prefix)
66{
67 size_t string_len = strlen (string);
68 size_t prefix_len = strlen (prefix);
69 return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0;
70}
71
72/* Return whether STRING ends with SUFFIX. */
73
74static bool
75json_has_suffix (const char *string, const char *suffix)
76{
77 size_t string_len = strlen (string);
78 size_t suffix_len = strlen (suffix);
79 return string_len >= suffix_len
80 && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0;
81}
82
83/* Create a multibyte Lisp string from the UTF-8 string in
84 [DATA, DATA + SIZE). If the range [DATA, DATA + SIZE) does not
85 contain a valid UTF-8 string, an unspecified string is
86 returned. */
87
88static Lisp_Object
89json_make_string (const char *data, ptrdiff_t size)
90{
91 return code_convert_string (make_specified_string (data, -1, size, false),
92 Qutf_8_unix, Qt, false, true, true);
93}
94
95/* Create a multibyte Lisp string from the null-terminated UTF-8
96 string beginning at DATA. If the string is not a valid UTF-8
97 string, an unspecified string is returned. */
98
99static Lisp_Object
100json_build_string (const char *data)
101{
102 return json_make_string (data, strlen (data));
103}
104
105/* Return a unibyte string containing the sequence of UTF-8 encoding
106 units of the UTF-8 representation of STRING. If STRING does not
107 represent a sequence of Unicode scalar values, return a string with
108 unspecified contents. */
109
110static Lisp_Object
111json_encode (Lisp_Object string)
112{
113 return code_convert_string (string, Qutf_8_unix, Qt, true, true, true);
114}
115
116static _Noreturn void
117json_out_of_memory (void)
118{
119 xsignal0 (Qjson_out_of_memory);
120}
121
122/* Signal a Lisp error corresponding to the JSON ERROR. */
123
124static _Noreturn void
125json_parse_error (const json_error_t *error)
126{
127 Lisp_Object symbol;
128 /* FIXME: Upstream Jansson should have a way to return error codes
129 without parsing the error messages. See
130 https://github.com/akheron/jansson/issues/352. */
131 if (json_has_suffix (error->text, "expected near end of file"))
132 symbol = Qjson_end_of_file;
133 else if (json_has_prefix (error->text, "end of file expected"))
134 symbol = Qjson_trailing_content;
135 else
136 symbol = Qjson_parse_error;
137 xsignal (symbol,
138 list5 (json_build_string (error->text),
139 json_build_string (error->source), make_natnum (error->line),
140 make_natnum (error->column), make_natnum (error->position)));
141}
142
143static void
144json_release_object (void *object)
145{
146 json_decref (object);
147}
148
149/* Signal an error if OBJECT is not a string, or if OBJECT contains
150 embedded null characters. */
151
152static void
153check_string_without_embedded_nulls (Lisp_Object object)
154{
155 CHECK_STRING (object);
156 CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL,
157 Qstring_without_embedded_nulls_p, object);
158}
159
160/* Signal an error of type `json-out-of-memory' if OBJECT is
161 NULL. */
162
163static json_t *
164json_check (json_t *object)
165{
166 if (object == NULL)
167 json_out_of_memory ();
168 return object;
169}
170
171static json_t *lisp_to_json (Lisp_Object);
172
173/* Convert a Lisp object to a toplevel JSON object (array or object).
174 This returns Lisp_Object so we can use unbind_to. The return value
175 is always nil. */
176
177static _GL_ARG_NONNULL ((2)) Lisp_Object
178lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json)
179{
180 if (VECTORP (lisp))
181 {
182 ptrdiff_t size = ASIZE (lisp);
183 *json = json_check (json_array ());
184 ptrdiff_t count = SPECPDL_INDEX ();
185 record_unwind_protect_ptr (json_release_object, json);
186 for (ptrdiff_t i = 0; i < size; ++i)
187 {
188 int status
189 = json_array_append_new (*json, lisp_to_json (AREF (lisp, i)));
190 if (status == -1)
191 json_out_of_memory ();
192 }
193 eassert (json_array_size (*json) == size);
194 clear_unwind_protect (count);
195 return unbind_to (count, Qnil);
196 }
197 else if (HASH_TABLE_P (lisp))
198 {
199 struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
200 *json = json_check (json_object ());
201 ptrdiff_t count = SPECPDL_INDEX ();
202 record_unwind_protect_ptr (json_release_object, *json);
203 for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
204 if (!NILP (HASH_HASH (h, i)))
205 {
206 Lisp_Object key = json_encode (HASH_KEY (h, i));
207 /* We can’t specify the length, so the string must be
208 null-terminated. */
209 check_string_without_embedded_nulls (key);
210 int status = json_object_set_new (*json, SSDATA (key),
211 lisp_to_json (HASH_VALUE (h, i)));
212 if (status == -1)
213 json_out_of_memory ();
214 }
215 clear_unwind_protect (count);
216 return unbind_to (count, Qnil);
217 }
218 wrong_type_argument (Qjson_value_p, lisp);
219}
220
221/* Convert LISP to a toplevel JSON object (array or object). Signal
222 an error of type `wrong-type-argument' if LISP is not a vector or
223 hashtable. */
224
225static json_t *
226lisp_to_json_toplevel (Lisp_Object lisp)
227{
228 if (++lisp_eval_depth > max_lisp_eval_depth)
229 xsignal0 (Qjson_object_too_deep);
230 json_t *json;
231 lisp_to_json_toplevel_1 (lisp, &json);
232 --lisp_eval_depth;
233 return json;
234}
235
236/* Convert LISP to any JSON object. Signal an error of type
237 `wrong-type-argument' if the type of LISP can't be converted to a
238 JSON object. */
239
240static json_t *
241lisp_to_json (Lisp_Object lisp)
242{
243 if (EQ (lisp, QCnull))
244 return json_check (json_null ());
245 else if (EQ (lisp, QCfalse))
246 return json_check (json_false ());
247 else if (EQ (lisp, Qt))
248 return json_check (json_true ());
249 else if (INTEGERP (lisp))
250 {
251 CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp);
252 return json_check (json_integer (XINT (lisp)));
253 }
254 else if (FLOATP (lisp))
255 return json_check (json_real (XFLOAT_DATA (lisp)));
256 else if (STRINGP (lisp))
257 {
258 Lisp_Object encoded = json_encode (lisp);
259 ptrdiff_t size = SBYTES (encoded);
260 return json_check (json_stringn (SSDATA (encoded), size));
261 }
262
263 /* LISP now must be a vector or hashtable. */
264 return lisp_to_json_toplevel (lisp);
265}
266
267DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL,
268 doc: /* Return the JSON representation of OBJECT as a string.
269OBJECT must be a vector or hashtable, and its elements can recursively
270contain `:null', `:false', t, numbers, strings, or other vectors and
271hashtables. `:null', `:false', and t will be converted to JSON null,
272false, and true values, respectively. Vectors will be converted to
273JSON arrays, and hashtables to JSON objects. Hashtable keys must be
274strings without embedded null characters and must be unique within
275each object. */)
276 (Lisp_Object object)
277{
278 ptrdiff_t count = SPECPDL_INDEX ();
279
280 json_t *json = lisp_to_json_toplevel (object);
281 record_unwind_protect_ptr (json_release_object, json);
282
283 char *string = json_dumps (json, JSON_COMPACT);
284 if (string == NULL)
285 json_out_of_memory ();
286 record_unwind_protect_ptr (free, string);
287
288 return unbind_to (count, json_build_string (string));
289}
290
291struct json_buffer_and_size
292{
293 const char *buffer;
294 ptrdiff_t size;
295};
296
297static Lisp_Object
298json_insert (void *data)
299{
300 struct json_buffer_and_size *buffer_and_size = data;
301 /* FIXME: This should be possible without creating an intermediate
302 string object. */
303 Lisp_Object string
304 = json_make_string (buffer_and_size->buffer, buffer_and_size->size);
305 insert1 (string);
306 return Qnil;
307}
308
309struct json_insert_data
310{
311 /* nil if json_insert succeeded, otherwise the symbol
312 Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */
313 Lisp_Object error;
314};
315
316/* Callback for json_dump_callback that inserts the UTF-8 string in
317 [BUFFER, BUFFER + SIZE) into the current buffer.
318 If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string,
319 an unspecified string is inserted into the buffer. DATA must point
320 to a structure of type json_insert_data. This function may not
321 exit nonlocally. It catches all nonlocal exits and stores them in
322 data->error for reraising. */
323
324static int
325json_insert_callback (const char *buffer, size_t size, void *data)
326{
327 struct json_insert_data *d = data;
328 struct json_buffer_and_size buffer_and_size
329 = {.buffer = buffer, .size = size};
330 d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity);
331 return NILP (d->error) ? 0 : -1;
332}
333
334DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL,
335 doc: /* Insert the JSON representation of OBJECT before point.
336This is the same as (insert (json-serialize OBJECT)), but potentially
337faster. See the function `json-serialize' for allowed values of
338OBJECT. */)
339 (Lisp_Object object)
340{
341 ptrdiff_t count = SPECPDL_INDEX ();
342
343 json_t *json = lisp_to_json (object);
344 record_unwind_protect_ptr (json_release_object, json);
345
346 struct json_insert_data data;
347 int status
348 = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT);
349 if (status == -1)
350 {
351 if (CONSP (data.error))
352 xsignal (XCAR (data.error), XCDR (data.error));
353 else
354 json_out_of_memory ();
355 }
356
357 return unbind_to (count, Qnil);
358}
359
360/* Convert a JSON object to a Lisp object. */
361
362static _GL_ARG_NONNULL ((1)) Lisp_Object
363json_to_lisp (json_t *json)
364{
365 switch (json_typeof (json))
366 {
367 case JSON_NULL:
368 return QCnull;
369 case JSON_FALSE:
370 return QCfalse;
371 case JSON_TRUE:
372 return Qt;
373 case JSON_INTEGER:
374 /* Return an integer if possible, a floating-point number
375 otherwise. This loses precision for integers with large
376 magnitude; however, such integers tend to be nonportable
377 anyway because many JSON implementations use only 64-bit
378 floating-point numbers with 53 mantissa bits. See
379 https://tools.ietf.org/html/rfc7159#section-6 for some
380 discussion. */
381 return make_fixnum_or_float (json_integer_value (json));
382 case JSON_REAL:
383 return make_float (json_real_value (json));
384 case JSON_STRING:
385 return json_make_string (json_string_value (json),
386 json_string_length (json));
387 case JSON_ARRAY:
388 {
389 if (++lisp_eval_depth > max_lisp_eval_depth)
390 xsignal0 (Qjson_object_too_deep);
391 size_t size = json_array_size (json);
392 if (FIXNUM_OVERFLOW_P (size))
393 xsignal0 (Qoverflow_error);
394 Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound);
395 for (ptrdiff_t i = 0; i < size; ++i)
396 ASET (result, i,
397 json_to_lisp (json_array_get (json, i)));
398 --lisp_eval_depth;
399 return result;
400 }
401 case JSON_OBJECT:
402 {
403 if (++lisp_eval_depth > max_lisp_eval_depth)
404 xsignal0 (Qjson_object_too_deep);
405 size_t size = json_object_size (json);
406 if (FIXNUM_OVERFLOW_P (size))
407 xsignal0 (Qoverflow_error);
408 Lisp_Object result = CALLN (Fmake_hash_table, QCtest, Qequal,
409 QCsize, make_natnum (size));
410 struct Lisp_Hash_Table *h = XHASH_TABLE (result);
411 const char *key_str;
412 json_t *value;
413 json_object_foreach (json, key_str, value)
414 {
415 Lisp_Object key = json_build_string (key_str);
416 EMACS_UINT hash;
417 ptrdiff_t i = hash_lookup (h, key, &hash);
418 /* Keys in JSON objects are unique, so the key can’t be
419 present yet. */
420 eassert (i < 0);
421 hash_put (h, key, json_to_lisp (value), hash);
422 }
423 --lisp_eval_depth;
424 return result;
425 }
426 }
427 /* Can’t get here. */
428 emacs_abort ();
429}
430
431DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, 1, NULL,
432 doc: /* Parse the JSON STRING into a Lisp object.
433This is essentially the reverse operation of `json-serialize', which
434see. The returned object will be a vector or hashtable. Its elements
435will be `:null', `:false', t, numbers, strings, or further vectors and
436hashtables. If there are duplicate keys in an object, all but the
437last one are ignored. If STRING doesn't contain a valid JSON object,
438an error of type `json-parse-error' is signaled. */)
439 (Lisp_Object string)
440{
441 ptrdiff_t count = SPECPDL_INDEX ();
442 Lisp_Object encoded = json_encode (string);
443 check_string_without_embedded_nulls (encoded);
444
445 json_error_t error;
446 json_t *object = json_loads (SSDATA (encoded), 0, &error);
447 if (object == NULL)
448 json_parse_error (&error);
449
450 /* Avoid leaking the object in case of further errors. */
451 if (object != NULL)
452 record_unwind_protect_ptr (json_release_object, object);
453
454 return unbind_to (count, json_to_lisp (object));
455}
456
457struct json_read_buffer_data
458{
459 /* Byte position of position to read the next chunk from. */
460 ptrdiff_t point;
461};
462
463/* Callback for json_load_callback that reads from the current buffer.
464 DATA must point to a structure of type json_read_buffer_data.
465 data->point must point to the byte position to read from; after
466 reading, data->point is advanced accordingly. The buffer point
467 itself is ignored. This function may not exit nonlocally. */
468
469static size_t
470json_read_buffer_callback (void *buffer, size_t buflen, void *data)
471{
472 struct json_read_buffer_data *d = data;
473
474 /* First, parse from point to the gap or the end of the accessible
475 portion, whatever is closer. */
476 ptrdiff_t point = d->point;
477 ptrdiff_t end = BUFFER_CEILING_OF (point) + 1;
478 ptrdiff_t count = end - point;
479 if (buflen < count)
480 count = buflen;
481 memcpy (buffer, BYTE_POS_ADDR (point), count);
482 d->point += count;
483 return count;
484}
485
486DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
487 0, 0, NULL,
488 doc: /* Read JSON object from current buffer starting at point.
489This is similar to `json-parse-string', which see. Move point after
490the end of the object if parsing was successful. On error, point is
491not moved. */)
492 (void)
493{
494 ptrdiff_t count = SPECPDL_INDEX ();
495
496 ptrdiff_t point = PT_BYTE;
497 struct json_read_buffer_data data = {.point = point};
498 json_error_t error;
499 json_t *object = json_load_callback (json_read_buffer_callback, &data,
500 JSON_DISABLE_EOF_CHECK, &error);
501
502 if (object == NULL)
503 json_parse_error (&error);
504
505 /* Avoid leaking the object in case of further errors. */
506 record_unwind_protect_ptr (json_release_object, object);
507
508 /* Convert and then move point only if everything succeeded. */
509 Lisp_Object lisp = json_to_lisp (object);
510
511 /* Adjust point by how much we just read. */
512 point += error.position;
513 SET_PT_BOTH (BYTE_TO_CHAR (point), point);
514
515 return unbind_to (count, lisp);
516}
517
518/* Simplified version of ‘define-error’ that works with pure
519 objects. */
520
521static void
522define_error (Lisp_Object name, const char *message, Lisp_Object parent)
523{
524 eassert (SYMBOLP (name));
525 eassert (SYMBOLP (parent));
526 Lisp_Object parent_conditions = Fget (parent, Qerror_conditions);
527 eassert (CONSP (parent_conditions));
528 eassert (!NILP (Fmemq (parent, parent_conditions)));
529 eassert (NILP (Fmemq (name, parent_conditions)));
530 Fput (name, Qerror_conditions, pure_cons (name, parent_conditions));
531 Fput (name, Qerror_message, build_pure_c_string (message));
532}
533
534void
535syms_of_json (void)
536{
537 DEFSYM (QCnull, ":null");
538 DEFSYM (QCfalse, ":false");
539
540 DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p");
541 DEFSYM (Qjson_value_p, "json-value-p");
542
543 DEFSYM (Qutf_8_unix, "utf-8-unix");
544
545 DEFSYM (Qjson_error, "json-error");
546 DEFSYM (Qjson_out_of_memory, "json-out-of-memory");
547 DEFSYM (Qjson_parse_error, "json-parse-error");
548 DEFSYM (Qjson_end_of_file, "json-end-of-file");
549 DEFSYM (Qjson_trailing_content, "json-trailing-content");
550 DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
551 define_error (Qjson_error, "generic JSON error", Qerror);
552 define_error (Qjson_out_of_memory,
553 "not enough memory for creating JSON object", Qjson_error);
554 define_error (Qjson_parse_error, "could not parse JSON stream",
555 Qjson_error);
556 define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error);
557 define_error (Qjson_trailing_content, "trailing content after JSON stream",
558 Qjson_parse_error);
559 define_error (Qjson_object_too_deep,
560 "object cyclic or Lisp evaluation too deep", Qjson_error);
561
562 DEFSYM (Qpure, "pure");
563 DEFSYM (Qside_effect_free, "side-effect-free");
564
565 DEFSYM (Qjson_serialize, "json-serialize");
566 DEFSYM (Qjson_parse_string, "json-parse-string");
567 Fput (Qjson_serialize, Qpure, Qt);
568 Fput (Qjson_serialize, Qside_effect_free, Qt);
569 Fput (Qjson_parse_string, Qpure, Qt);
570 Fput (Qjson_parse_string, Qside_effect_free, Qt);
571
572 defsubr (&Sjson_serialize);
573 defsubr (&Sjson_insert);
574 defsubr (&Sjson_parse_string);
575 defsubr (&Sjson_parse_buffer);
576}
diff --git a/src/lisp.h b/src/lisp.h
index 68824d6b393..91ed14fa4c9 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3452,6 +3452,12 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_t);
3452extern void reset_image_types (void); 3452extern void reset_image_types (void);
3453extern void syms_of_image (void); 3453extern void syms_of_image (void);
3454 3454
3455#ifdef HAVE_JSON
3456/* Defined in json.c. */
3457extern void init_json (void);
3458extern void syms_of_json (void);
3459#endif
3460
3455/* Defined in insdel.c. */ 3461/* Defined in insdel.c. */
3456extern void move_gap_both (ptrdiff_t, ptrdiff_t); 3462extern void move_gap_both (ptrdiff_t, ptrdiff_t);
3457extern _Noreturn void buffer_overflow (void); 3463extern _Noreturn void buffer_overflow (void);
@@ -3875,6 +3881,7 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp
3875extern Lisp_Object internal_condition_case_n 3881extern Lisp_Object internal_condition_case_n
3876 (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, 3882 (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
3877 Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); 3883 Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
3884extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (Lisp_Object));
3878extern struct handler *push_handler (Lisp_Object, enum handlertype); 3885extern struct handler *push_handler (Lisp_Object, enum handlertype);
3879extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype); 3886extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
3880extern void specbind (Lisp_Object, Lisp_Object); 3887extern void specbind (Lisp_Object, Lisp_Object);
diff --git a/test/src/json-tests.el b/test/src/json-tests.el
new file mode 100644
index 00000000000..5d3c84a136c
--- /dev/null
+++ b/test/src/json-tests.el
@@ -0,0 +1,97 @@
1;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2017 Free Software Foundation, Inc.
4
5;; This file is part of GNU Emacs.
6
7;; GNU Emacs is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; GNU Emacs is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;; Unit tests for src/json.c.
23
24;;; Code:
25
26(require 'cl-lib)
27(require 'map)
28
29(ert-deftest json-serialize/roundtrip ()
30 (let ((lisp [:null :false t 0 123 -456 3.75 "abcαβγ"])
31 (json "[null,false,true,0,123,-456,3.75,\"abcαβγ\"]"))
32 (should (equal (json-serialize lisp) json))
33 (with-temp-buffer
34 (json-insert lisp)
35 (should (equal (buffer-string) json))
36 (should (eobp)))
37 (should (equal (json-parse-string json) lisp))
38 (with-temp-buffer
39 (insert json)
40 (goto-char 1)
41 (should (equal (json-parse-buffer) lisp))
42 (should (eobp)))))
43
44(ert-deftest json-serialize/object ()
45 (let ((table (make-hash-table :test #'equal)))
46 (puthash "abc" [1 2 t] table)
47 (puthash "def" :null table)
48 (should (equal (json-serialize table)
49 "{\"abc\":[1,2,true],\"def\":null}"))))
50
51(ert-deftest json-parse-string/object ()
52 (let ((actual
53 (json-parse-string
54 "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n")))
55 (should (hash-table-p actual))
56 (should (equal (hash-table-count actual) 2))
57 (should (equal (cl-sort (map-pairs actual) #'string< :key #'car)
58 '(("abc" . [9 :false]) ("def" . :null))))))
59
60(ert-deftest json-parse-string/string ()
61 (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error)
62 (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""]))
63 (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"]))
64 (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"]")
65 ["\nasdфывfgh\t"]))
66 (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"]))
67 (should-error (json-parse-string "foo") :type 'json-parse-error))
68
69(ert-deftest json-serialize/string ()
70 (should (equal (json-serialize ["foo"]) "[\"foo\"]"))
71 (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]"))
72 (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"])
73 "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]")))
74
75(ert-deftest json-parse-string/incomplete ()
76 (should-error (json-parse-string "[123") :type 'json-end-of-file))
77
78(ert-deftest json-parse-string/trailing ()
79 (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content))
80
81(ert-deftest json-parse-buffer/incomplete ()
82 (with-temp-buffer
83 (insert "[123")
84 (goto-char 1)
85 (should-error (json-parse-buffer) :type 'json-end-of-file)
86 (should (bobp))))
87
88(ert-deftest json-parse-buffer/trailing ()
89 (with-temp-buffer
90 (insert "[123] [456]")
91 (goto-char 1)
92 (should (equal (json-parse-buffer) [123]))
93 (should-not (bobp))
94 (should (looking-at-p (rx " [456]" eos)))))
95
96(provide 'json-tests)
97;;; json-tests.el ends here