From a7a74cfc40c4cacab047f5da239c7b7150bb9573 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Mon, 18 Sep 2017 10:51:39 +0200 Subject: [PATCH] Implement native JSON support using Jansson * configure.ac: New option --with-json. * src/json.c (Fjson_serialize, Fjson_insert, Fjson_parse_string) (Fjson_parse_buffer): New defuns. (json_malloc, json_free, json_has_prefix, json_has_suffix) (json_make_string, json_build_string, json_encode) (json_out_of_memory, json_parse_error) (json_release_object, check_string_without_embedded_nulls, json_check) (lisp_to_json, lisp_to_json_toplevel, lisp_to_json_toplevel_1) (json_insert, json_insert_callback, json_to_lisp) (json_read_buffer_callback, Fjson_parse_buffer, define_error): New helper functions. (init_json, syms_of_json): New file. * src/lisp.h: Declaration for init_json and syms_of_json. * src/emacs.c (main): Enable JSON functions. * src/eval.c (internal_catch_all, internal_catch_all_1): New helper functions to catch all signals. (syms_of_eval): Add uninterned symbol to signify out of memory. * src/Makefile.in (JSON_LIBS, JSON_CFLAGS, JSON_OBJ, EMACS_CFLAGS) (base_obj, LIBES): Compile json.c if --with-json is enabled. * test/src/json-tests.el (json-serialize/roundtrip) (json-serialize/object, json-parse-string/object) (json-parse-string/string, json-serialize/string) (json-parse-string/incomplete, json-parse-string/trailing) (json-parse-buffer/incomplete, json-parse-buffer/trailing): New unit tests. * doc/lispref/text.texi (Parsing JSON): New manual section. --- configure.ac | 20 +- doc/lispref/text.texi | 87 ++++++++ etc/NEWS | 11 + src/Makefile.in | 11 +- src/emacs.c | 8 + src/eval.c | 54 +++++ src/json.c | 576 +++++++++++++++++++++++++++++++++++++++++++++++++ src/lisp.h | 7 + test/src/json-tests.el | 97 +++++++++ 9 files changed, 867 insertions(+), 4 deletions(-) create mode 100644 src/json.c create mode 100644 test/src/json-tests.el diff --git a/configure.ac b/configure.ac index 7437eb90d2..ba8600c61a 100644 --- a/configure.ac +++ b/configure.ac @@ -355,6 +355,7 @@ AC_DEFUN OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)]) OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image support]) +OPTION_DEFAULT_ON([json], [don't compile with native JSON support]) OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support]) @@ -2859,6 +2860,22 @@ AC_DEFUN AC_SUBST(LIBSYSTEMD_LIBS) AC_SUBST(LIBSYSTEMD_CFLAGS) +HAVE_JSON=no +JSON_OBJ= + +if test "${with_json}" = yes; then + EMACS_CHECK_MODULES([JSON], [jansson >= 2.5], + [HAVE_JSON=yes], [HAVE_JSON=no]) + if test "${HAVE_JSON}" = yes; then + AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.]) + JSON_OBJ=json.o + fi +fi + +AC_SUBST(JSON_LIBS) +AC_SUBST(JSON_CFLAGS) +AC_SUBST(JSON_OBJ) + NOTIFY_OBJ= NOTIFY_SUMMARY=no @@ -5370,7 +5387,7 @@ AC_DEFUN for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \ LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 NS MODULES \ - XWIDGETS LIBSYSTEMD CANNOT_DUMP LCMS2; do + XWIDGETS LIBSYSTEMD JSON CANNOT_DUMP LCMS2; do case $opt in CANNOT_DUMP) eval val=\${$opt} ;; @@ -5420,6 +5437,7 @@ AC_DEFUN Does Emacs use -lotf? ${HAVE_LIBOTF} Does Emacs use -lxft? ${HAVE_XFT} Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD} + Does Emacs use -ljansson? ${HAVE_JSON} Does Emacs directly use zlib? ${HAVE_ZLIB} Does Emacs have dynamic modules support? ${HAVE_MODULES} Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS} diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index baa3c708e9..217a9ba88b 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -61,6 +61,7 @@ Text * Checksum/Hash:: Computing cryptographic hashes. * GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS. * Parsing HTML/XML:: Parsing HTML and XML. +* Parsing JSON:: Parsing and generating JSON values. * Atomic Changes:: Installing several buffer changes atomically. * Change Hooks:: Supplying functions to be run when text is changed. @end menu @@ -4911,6 +4912,92 @@ Document Object Model @end table address@hidden Parsing JSON address@hidden Parsing and generating JSON values address@hidden JSON + + When Emacs is compiled with JSON support, it provides a couple of +functions to convert between Lisp objects and JSON values. Any JSON +value can be converted to a Lisp object, but not vice versa. +Specifically: + address@hidden + address@hidden +JSON has a couple of keywords: @code{null}, @code{false}, and address@hidden These are represented in Lisp using the keywords address@hidden:null}, @code{:false}, and @code{t}, respectively. + address@hidden +JSON only has floating-point numbers. They can represent both Lisp +integers and Lisp floating-point numbers. + address@hidden +JSON strings are always Unicode strings. Lisp strings can contain +non-Unicode characters. + address@hidden +JSON has only one sequence type, the array. JSON arrays are +represented using Lisp vectors. + address@hidden +JSON has only one map type, the object. JSON objects are represented +using Lisp hashtables. + address@hidden itemize + address@hidden +Note that @code{nil} doesn't represent any JSON values: this is to +avoid confusion, because @code{nil} could either represent address@hidden, @code{false}, or an empty array, all of which are +different JSON values. + + If some Lisp object can't be represented in JSON, the serialization +functions will signal an error of type @code{wrong-type-argument}. +The parsing functions will signal the following errors: + address@hidden @code + address@hidden json-end-of-file + Signaled when encountering a premature end of the input text. + address@hidden json-trailing-content + Signaled when encountering unexpected input after the first JSON + object parsed. + address@hidden json-parse-error + Signaled when encountering invalid JSON syntax. + address@hidden table + + Only top-level values (arrays and objects) can be serialized to +JSON. The subobjects within these top-level values can be of any +type. Likewise, the parsing functions will only return vectors and +hashtables. + address@hidden json-serialize object +This function returns a new Lisp string which contains the JSON +representation of @var{object}. address@hidden defun + address@hidden json-insert object +This function inserts the JSON representation of @var{object} into the +current buffer before point. address@hidden defun + address@hidden json-parse-string string +This function parses the JSON value in @var{string}, which must be a +Lisp string. address@hidden defun + address@hidden json-parse-buffer +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 a value could be read and converted to Lisp; otherwise it +doesn't move point. address@hidden defun + + @node Atomic Changes @section Atomic Change Groups @cindex atomic changes diff --git a/etc/NEWS b/etc/NEWS index 9ae36bdb03..cf84d80395 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, * Installation Changes in Emacs 27.1 +** The new configure option '--with-json' adds support for JSON using +the Jansson library. It is on by default; use 'configure +--with-json=no' to build without Jansson support. The new JSON +functions 'json-serialize', 'json-insert', 'json-parse-string', and +'json-parse-buffer' are typically much faster than their Lisp +counterparts from json.el. + * Startup Changes in Emacs 27.1 @@ -123,6 +130,10 @@ bug on OS X 10.8 and later (Bug#28639). ** The function 'get-free-disk-space' returns now a non-nil value for remote systems, which support this check. +** New JSON parsing and serialization functions 'json-serialize', +'json-insert', 'json-parse-string', and 'json-parse-buffer'. These +are implemented in C using the Jansson library. + * Changes in Emacs 27.1 on Non-Free Operating Systems diff --git a/src/Makefile.in b/src/Makefile.in index 9a8c9c85f0..b395627893 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -312,6 +312,10 @@ LIBGNUTLS_CFLAGS = LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@ LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@ +JSON_LIBS = @JSON_LIBS@ +JSON_CFLAGS = @JSON_CFLAGS@ +JSON_OBJ = @JSON_OBJ@ + INTERVALS_H = dispextern.h intervals.h composite.h GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ @@ -363,7 +367,7 @@ EMACS_CFLAGS= $(WEBKIT_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ - $(LIBSYSTEMD_CFLAGS) \ + $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ $(WERROR_CFLAGS) ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) @@ -397,7 +401,7 @@ base_obj = thread.o systhread.o \ $(if $(HYBRID_MALLOC),sheap.o) \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ - $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) + $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) obj = $(base_obj) $(NS_OBJC_OBJ) ## Object files used on some machine or other. @@ -493,7 +497,8 @@ LIBES = $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \ - $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) + $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ + $(JSON_LIBS) ## FORCE it so that admin/unidata can decide whether these files ## are up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/emacs.c b/src/emacs.c index 0fe7d9113b..202ecb0ebb 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 running_asynch_code = 0; init_random (); +#ifdef HAVE_JSON + init_json (); +#endif + no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); @@ -1610,6 +1614,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_threads (); syms_of_profiler (); +#ifdef HAVE_JSON + syms_of_json (); +#endif + keys_of_casefiddle (); keys_of_cmds (); keys_of_buffer (); diff --git a/src/eval.c b/src/eval.c index 063deb4ba0..5cc521b9de 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1416,6 +1416,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), } } +static Lisp_Object +internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument) +{ + struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL); + if (c == NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) == 0) + { + Lisp_Object val = function (argument); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } + else + { + eassert (handlerlist == c); + Lisp_Object val = c->val; + handlerlist = c->next; + Fsignal (Qno_catch, val); + } +} + +/* Like a combination of internal_condition_case_1 and internal_catch. + Catches all signals and throws. Never exits nonlocally; returns + Qcatch_all_memory_full if no handler could be allocated. */ + +Lisp_Object +internal_catch_all (Lisp_Object (*function) (void *), void *argument, + Lisp_Object (*handler) (Lisp_Object)) +{ + struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE); + if (c == NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) == 0) + { + Lisp_Object val = internal_catch_all_1 (function, argument); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } + else + { + eassert (handlerlist == c); + Lisp_Object val = c->val; + handlerlist = c->next; + return handler (val); + } +} + struct handler * push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype) { @@ -4066,6 +4117,9 @@ alist of active lexical bindings. */); inhibit_lisp_code = Qnil; + DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full"); + Funintern (Qcatch_all_memory_full, Qnil); + defsubr (&Sor); defsubr (&Sand); defsubr (&Sif); diff --git a/src/json.c b/src/json.c new file mode 100644 index 0000000000..dc449e43e1 --- /dev/null +++ b/src/json.c @@ -0,0 +1,576 @@ +/* JSON parsing and serialization. + +Copyright (C) 2017 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include +#include +#include + +#include + +#include "lisp.h" +#include "buffer.h" +#include "coding.h" + +/* We install a custom allocator so that we can avoid objects larger + than PTRDIFF_MAX. Such objects wouldn’t play well with the rest of + Emacs’s codebase, which generally uses ptrdiff_t for sizes and + indices. The other functions in this file also generally assume + that size_t values never exceed PTRDIFF_MAX. */ + +static void * +json_malloc (size_t size) +{ + if (size > PTRDIFF_MAX) + { + errno = ENOMEM; + return NULL; + } + return malloc (size); +} + +static void +json_free (void *ptr) +{ + free (ptr); +} + +void +init_json (void) +{ + json_set_alloc_funcs (json_malloc, json_free); +} + +/* Return whether STRING starts with PREFIX. */ + +static bool +json_has_prefix (const char *string, const char *prefix) +{ + size_t string_len = strlen (string); + size_t prefix_len = strlen (prefix); + return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0; +} + +/* Return whether STRING ends with SUFFIX. */ + +static bool +json_has_suffix (const char *string, const char *suffix) +{ + size_t string_len = strlen (string); + size_t suffix_len = strlen (suffix); + return string_len >= suffix_len + && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0; +} + +/* Create a multibyte Lisp string from the UTF-8 string in + [DATA, DATA + SIZE). If the range [DATA, DATA + SIZE) does not + contain a valid UTF-8 string, an unspecified string is + returned. */ + +static Lisp_Object +json_make_string (const char *data, ptrdiff_t size) +{ + return code_convert_string (make_specified_string (data, -1, size, false), + Qutf_8_unix, Qt, false, true, true); +} + +/* Create a multibyte Lisp string from the null-terminated UTF-8 + string beginning at DATA. If the string is not a valid UTF-8 + string, an unspecified string is returned. */ + +static Lisp_Object +json_build_string (const char *data) +{ + return json_make_string (data, strlen (data)); +} + +/* Return a unibyte string containing the sequence of UTF-8 encoding + units of the UTF-8 representation of STRING. If STRING does not + represent a sequence of Unicode scalar values, return a string with + unspecified contents. */ + +static Lisp_Object +json_encode (Lisp_Object string) +{ + return code_convert_string (string, Qutf_8_unix, Qt, true, true, true); +} + +static _Noreturn void +json_out_of_memory (void) +{ + xsignal0 (Qjson_out_of_memory); +} + +/* Signal a Lisp error corresponding to the JSON ERROR. */ + +static _Noreturn void +json_parse_error (const json_error_t *error) +{ + Lisp_Object symbol; + /* FIXME: Upstream Jansson should have a way to return error codes + without parsing the error messages. See + https://github.com/akheron/jansson/issues/352. */ + if (json_has_suffix (error->text, "expected near end of file")) + symbol = Qjson_end_of_file; + else if (json_has_prefix (error->text, "end of file expected")) + symbol = Qjson_trailing_content; + else + symbol = Qjson_parse_error; + xsignal (symbol, + list5 (json_build_string (error->text), + json_build_string (error->source), make_natnum (error->line), + make_natnum (error->column), make_natnum (error->position))); +} + +static void +json_release_object (void *object) +{ + json_decref (object); +} + +/* Signal an error if OBJECT is not a string, or if OBJECT contains + embedded null characters. */ + +static void +check_string_without_embedded_nulls (Lisp_Object object) +{ + CHECK_STRING (object); + CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL, + Qstring_without_embedded_nulls_p, object); +} + +/* Signal an error of type `json-out-of-memory' if OBJECT is + NULL. */ + +static json_t * +json_check (json_t *object) +{ + if (object == NULL) + json_out_of_memory (); + return object; +} + +static json_t *lisp_to_json (Lisp_Object); + +/* Convert a Lisp object to a toplevel JSON object (array or object). + This returns Lisp_Object so we can use unbind_to. The return value + is always nil. */ + +static _GL_ARG_NONNULL ((2)) Lisp_Object +lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json) +{ + if (VECTORP (lisp)) + { + ptrdiff_t size = ASIZE (lisp); + *json = json_check (json_array ()); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, json); + for (ptrdiff_t i = 0; i < size; ++i) + { + int status + = json_array_append_new (*json, lisp_to_json (AREF (lisp, i))); + if (status == -1) + json_out_of_memory (); + } + eassert (json_array_size (*json) == size); + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + else if (HASH_TABLE_P (lisp)) + { + struct Lisp_Hash_Table *h = XHASH_TABLE (lisp); + *json = json_check (json_object ()); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, *json); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + if (!NILP (HASH_HASH (h, i))) + { + Lisp_Object key = json_encode (HASH_KEY (h, i)); + /* We can’t specify the length, so the string must be + null-terminated. */ + check_string_without_embedded_nulls (key); + int status = json_object_set_new (*json, SSDATA (key), + lisp_to_json (HASH_VALUE (h, i))); + if (status == -1) + json_out_of_memory (); + } + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + wrong_type_argument (Qjson_value_p, lisp); +} + +/* Convert LISP to a toplevel JSON object (array or object). Signal + an error of type `wrong-type-argument' if LISP is not a vector or + hashtable. */ + +static json_t * +lisp_to_json_toplevel (Lisp_Object lisp) +{ + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + json_t *json; + lisp_to_json_toplevel_1 (lisp, &json); + --lisp_eval_depth; + return json; +} + +/* Convert LISP to any JSON object. Signal an error of type + `wrong-type-argument' if the type of LISP can't be converted to a + JSON object. */ + +static json_t * +lisp_to_json (Lisp_Object lisp) +{ + if (EQ (lisp, QCnull)) + return json_check (json_null ()); + else if (EQ (lisp, QCfalse)) + return json_check (json_false ()); + else if (EQ (lisp, Qt)) + return json_check (json_true ()); + else if (INTEGERP (lisp)) + { + CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp); + return json_check (json_integer (XINT (lisp))); + } + else if (FLOATP (lisp)) + return json_check (json_real (XFLOAT_DATA (lisp))); + else if (STRINGP (lisp)) + { + Lisp_Object encoded = json_encode (lisp); + ptrdiff_t size = SBYTES (encoded); + return json_check (json_stringn (SSDATA (encoded), size)); + } + + /* LISP now must be a vector or hashtable. */ + return lisp_to_json_toplevel (lisp); +} + +DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL, + doc: /* Return the JSON representation of OBJECT as a string. +OBJECT must be a vector or hashtable, and its elements can recursively +contain `:null', `:false', t, numbers, strings, or other vectors and +hashtables. `:null', `:false', and t will be converted to JSON null, +false, and true values, respectively. Vectors will be converted to +JSON arrays, and hashtables to JSON objects. Hashtable keys must be +strings without embedded null characters and must be unique within +each object. */) + (Lisp_Object object) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + json_t *json = lisp_to_json_toplevel (object); + record_unwind_protect_ptr (json_release_object, json); + + char *string = json_dumps (json, JSON_COMPACT); + if (string == NULL) + json_out_of_memory (); + record_unwind_protect_ptr (free, string); + + return unbind_to (count, json_build_string (string)); +} + +struct json_buffer_and_size +{ + const char *buffer; + ptrdiff_t size; +}; + +static Lisp_Object +json_insert (void *data) +{ + struct json_buffer_and_size *buffer_and_size = data; + /* FIXME: This should be possible without creating an intermediate + string object. */ + Lisp_Object string + = json_make_string (buffer_and_size->buffer, buffer_and_size->size); + insert1 (string); + return Qnil; +} + +struct json_insert_data +{ + /* nil if json_insert succeeded, otherwise the symbol + Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */ + Lisp_Object error; +}; + +/* Callback for json_dump_callback that inserts the UTF-8 string in + [BUFFER, BUFFER + SIZE) into the current buffer. + If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string, + an unspecified string is inserted into the buffer. DATA must point + to a structure of type json_insert_data. This function may not + exit nonlocally. It catches all nonlocal exits and stores them in + data->error for reraising. */ + +static int +json_insert_callback (const char *buffer, size_t size, void *data) +{ + struct json_insert_data *d = data; + struct json_buffer_and_size buffer_and_size + = {.buffer = buffer, .size = size}; + d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity); + return NILP (d->error) ? 0 : -1; +} + +DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL, + doc: /* 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. */) + (Lisp_Object object) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + json_t *json = lisp_to_json (object); + record_unwind_protect_ptr (json_release_object, json); + + struct json_insert_data data; + int status + = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT); + if (status == -1) + { + if (CONSP (data.error)) + xsignal (XCAR (data.error), XCDR (data.error)); + else + json_out_of_memory (); + } + + return unbind_to (count, Qnil); +} + +/* Convert a JSON object to a Lisp object. */ + +static _GL_ARG_NONNULL ((1)) Lisp_Object +json_to_lisp (json_t *json) +{ + switch (json_typeof (json)) + { + case JSON_NULL: + return QCnull; + case JSON_FALSE: + return QCfalse; + case JSON_TRUE: + return Qt; + case JSON_INTEGER: + /* Return an integer if possible, a floating-point number + otherwise. This loses precision for integers with large + magnitude; however, such integers tend to be nonportable + anyway because many JSON implementations use only 64-bit + floating-point numbers with 53 mantissa bits. See + https://tools.ietf.org/html/rfc7159#section-6 for some + discussion. */ + return make_fixnum_or_float (json_integer_value (json)); + case JSON_REAL: + return make_float (json_real_value (json)); + case JSON_STRING: + return json_make_string (json_string_value (json), + json_string_length (json)); + case JSON_ARRAY: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + size_t size = json_array_size (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal0 (Qoverflow_error); + Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound); + for (ptrdiff_t i = 0; i < size; ++i) + ASET (result, i, + json_to_lisp (json_array_get (json, i))); + --lisp_eval_depth; + return result; + } + case JSON_OBJECT: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + size_t size = json_object_size (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal0 (Qoverflow_error); + Lisp_Object result = CALLN (Fmake_hash_table, QCtest, Qequal, + QCsize, make_natnum (size)); + struct Lisp_Hash_Table *h = XHASH_TABLE (result); + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + Lisp_Object key = json_build_string (key_str); + EMACS_UINT hash; + ptrdiff_t i = hash_lookup (h, key, &hash); + /* Keys in JSON objects are unique, so the key can’t be + present yet. */ + eassert (i < 0); + hash_put (h, key, json_to_lisp (value), hash); + } + --lisp_eval_depth; + return result; + } + } + /* Can’t get here. */ + emacs_abort (); +} + +DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, 1, NULL, + doc: /* Parse the JSON STRING into a Lisp object. +This is essentially the reverse operation of `json-serialize', which +see. The returned object will be a vector or hashtable. Its elements +will be `:null', `:false', t, numbers, strings, or further vectors and +hashtables. If there are duplicate keys in an object, all but the +last one are ignored. If STRING doesn't contain a valid JSON object, +an error of type `json-parse-error' is signaled. */) + (Lisp_Object string) +{ + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object encoded = json_encode (string); + check_string_without_embedded_nulls (encoded); + + json_error_t error; + json_t *object = json_loads (SSDATA (encoded), 0, &error); + if (object == NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + if (object != NULL) + record_unwind_protect_ptr (json_release_object, object); + + return unbind_to (count, json_to_lisp (object)); +} + +struct json_read_buffer_data +{ + /* Byte position of position to read the next chunk from. */ + ptrdiff_t point; +}; + +/* Callback for json_load_callback that reads from the current buffer. + DATA must point to a structure of type json_read_buffer_data. + data->point must point to the byte position to read from; after + reading, data->point is advanced accordingly. The buffer point + itself is ignored. This function may not exit nonlocally. */ + +static size_t +json_read_buffer_callback (void *buffer, size_t buflen, void *data) +{ + struct json_read_buffer_data *d = data; + + /* First, parse from point to the gap or the end of the accessible + portion, whatever is closer. */ + ptrdiff_t point = d->point; + ptrdiff_t end = BUFFER_CEILING_OF (point) + 1; + ptrdiff_t count = end - point; + if (buflen < count) + count = buflen; + memcpy (buffer, BYTE_POS_ADDR (point), count); + d->point += count; + return count; +} + +DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer, + 0, 0, NULL, + doc: /* Read JSON object from current buffer starting at point. +This is similar to `json-parse-string', which see. Move point after +the end of the object if parsing was successful. On error, point is +not moved. */) + (void) +{ + ptrdiff_t count = SPECPDL_INDEX (); + + ptrdiff_t point = PT_BYTE; + struct json_read_buffer_data data = {.point = point}; + json_error_t error; + json_t *object = json_load_callback (json_read_buffer_callback, &data, + JSON_DISABLE_EOF_CHECK, &error); + + if (object == NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + record_unwind_protect_ptr (json_release_object, object); + + /* Convert and then move point only if everything succeeded. */ + Lisp_Object lisp = json_to_lisp (object); + + /* Adjust point by how much we just read. */ + point += error.position; + SET_PT_BOTH (BYTE_TO_CHAR (point), point); + + return unbind_to (count, lisp); +} + +/* Simplified version of ‘define-error’ that works with pure + objects. */ + +static void +define_error (Lisp_Object name, const char *message, Lisp_Object parent) +{ + eassert (SYMBOLP (name)); + eassert (SYMBOLP (parent)); + Lisp_Object parent_conditions = Fget (parent, Qerror_conditions); + eassert (CONSP (parent_conditions)); + eassert (!NILP (Fmemq (parent, parent_conditions))); + eassert (NILP (Fmemq (name, parent_conditions))); + Fput (name, Qerror_conditions, pure_cons (name, parent_conditions)); + Fput (name, Qerror_message, build_pure_c_string (message)); +} + +void +syms_of_json (void) +{ + DEFSYM (QCnull, ":null"); + DEFSYM (QCfalse, ":false"); + + DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p"); + DEFSYM (Qjson_value_p, "json-value-p"); + + DEFSYM (Qutf_8_unix, "utf-8-unix"); + + DEFSYM (Qjson_error, "json-error"); + DEFSYM (Qjson_out_of_memory, "json-out-of-memory"); + DEFSYM (Qjson_parse_error, "json-parse-error"); + DEFSYM (Qjson_end_of_file, "json-end-of-file"); + DEFSYM (Qjson_trailing_content, "json-trailing-content"); + DEFSYM (Qjson_object_too_deep, "json-object-too-deep"); + define_error (Qjson_error, "generic JSON error", Qerror); + define_error (Qjson_out_of_memory, + "not enough memory for creating JSON object", Qjson_error); + define_error (Qjson_parse_error, "could not parse JSON stream", + Qjson_error); + define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error); + define_error (Qjson_trailing_content, "trailing content after JSON stream", + Qjson_parse_error); + define_error (Qjson_object_too_deep, + "object cyclic or Lisp evaluation too deep", Qjson_error); + + DEFSYM (Qpure, "pure"); + DEFSYM (Qside_effect_free, "side-effect-free"); + + DEFSYM (Qjson_serialize, "json-serialize"); + DEFSYM (Qjson_parse_string, "json-parse-string"); + Fput (Qjson_serialize, Qpure, Qt); + Fput (Qjson_serialize, Qside_effect_free, Qt); + Fput (Qjson_parse_string, Qpure, Qt); + Fput (Qjson_parse_string, Qside_effect_free, Qt); + + defsubr (&Sjson_serialize); + defsubr (&Sjson_insert); + defsubr (&Sjson_parse_string); + defsubr (&Sjson_parse_buffer); +} diff --git a/src/lisp.h b/src/lisp.h index 266370333f..8ccad2c224 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3441,6 +3441,12 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_t); extern void reset_image_types (void); extern void syms_of_image (void); +#ifdef HAVE_JSON +/* Defined in json.c. */ +extern void init_json (void); +extern void syms_of_json (void); +#endif + /* Defined in insdel.c. */ extern void move_gap_both (ptrdiff_t, ptrdiff_t); extern _Noreturn void buffer_overflow (void); @@ -3864,6 +3870,7 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); +extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (Lisp_Object)); extern struct handler *push_handler (Lisp_Object, enum handlertype); extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype); extern 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 0000000000..5d3c84a136 --- /dev/null +++ b/test/src/json-tests.el @@ -0,0 +1,97 @@ +;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Unit tests for src/json.c. + +;;; Code: + +(require 'cl-lib) +(require 'map) + +(ert-deftest json-serialize/roundtrip () + (let ((lisp [:null :false t 0 123 -456 3.75 "abcαβγ"]) + (json "[null,false,true,0,123,-456,3.75,\"abcαβγ\"]")) + (should (equal (json-serialize lisp) json)) + (with-temp-buffer + (json-insert lisp) + (should (equal (buffer-string) json)) + (should (eobp))) + (should (equal (json-parse-string json) lisp)) + (with-temp-buffer + (insert json) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) + (should (eobp))))) + +(ert-deftest json-serialize/object () + (let ((table (make-hash-table :test #'equal))) + (puthash "abc" [1 2 t] table) + (puthash "def" :null table) + (should (equal (json-serialize table) + "{\"abc\":[1,2,true],\"def\":null}")))) + +(ert-deftest json-parse-string/object () + (let ((actual + (json-parse-string + "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n"))) + (should (hash-table-p actual)) + (should (equal (hash-table-count actual) 2)) + (should (equal (cl-sort (map-pairs actual) #'string< :key #'car) + '(("abc" . [9 :false]) ("def" . :null)))))) + +(ert-deftest json-parse-string/string () + (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error) + (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""])) + (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"])) + (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"]") + ["\nasdфывfgh\t"])) + (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"])) + (should-error (json-parse-string "foo") :type 'json-parse-error)) + +(ert-deftest json-serialize/string () + (should (equal (json-serialize ["foo"]) "[\"foo\"]")) + (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]")) + (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"]) + "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]"))) + +(ert-deftest json-parse-string/incomplete () + (should-error (json-parse-string "[123") :type 'json-end-of-file)) + +(ert-deftest json-parse-string/trailing () + (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content)) + +(ert-deftest json-parse-buffer/incomplete () + (with-temp-buffer + (insert "[123") + (goto-char 1) + (should-error (json-parse-buffer) :type 'json-end-of-file) + (should (bobp)))) + +(ert-deftest json-parse-buffer/trailing () + (with-temp-buffer + (insert "[123] [456]") + (goto-char 1) + (should (equal (json-parse-buffer) [123])) + (should-not (bobp)) + (should (looking-at-p (rx " [456]" eos))))) + +(provide 'json-tests) +;;; json-tests.el ends here -- 2.14.2