diff options
Diffstat (limited to 'src/json.c')
| -rw-r--r-- | src/json.c | 378 |
1 files changed, 259 insertions, 119 deletions
diff --git a/src/json.c b/src/json.c index ea941d7bb5d..5a3d0012f0a 100644 --- a/src/json.c +++ b/src/json.c @@ -1,13 +1,13 @@ /* JSON parsing and serialization. -Copyright (C) 2017-2018 Free Software Foundation, Inc. +Copyright (C) 2017-2019 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 -nyour option) any later version. +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 @@ -34,6 +34,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifdef WINDOWSNT # include <windows.h> +# include "w32common.h" # include "w32.h" DEF_DLL_FN (void, json_set_alloc_funcs, @@ -159,7 +160,12 @@ init_json_functions (void) 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. */ + that size_t values never exceed PTRDIFF_MAX. + + In addition, we need to use a custom allocator because on + MS-Windows we replace malloc/free with our own functions, see + w32heap.c, so we must force the library to use our allocator, or + else we won't be able to free storage allocated by the library. */ static void * json_malloc (size_t size) @@ -191,9 +197,7 @@ init_json (void) 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 strncmp (string, prefix, strlen (prefix)) == 0; } /* Return whether STRING ends with SUFFIX. */ @@ -209,33 +213,11 @@ json_has_suffix (const char *string, const char *suffix) #endif -/* 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. - Note that all callers below either pass only value UTF-8 strings or - use this function for formatting error messages; in the latter case - correctness isn't critical. */ - -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. Note that all callers - below either pass only value UTF-8 strings or use this function for +/* Note that all callers of make_string_from_utf8 and build_string_from_utf8 + below either pass only value UTF-8 strings or use the functionf for formatting error messages; in the latter case correctness isn't critical. */ -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 @@ -249,7 +231,7 @@ json_encode (Lisp_Object string) return code_convert_string (string, Qutf_8_unix, Qt, true, true, true); } -static _Noreturn void +static AVOID json_out_of_memory (void) { xsignal0 (Qjson_out_of_memory); @@ -257,7 +239,7 @@ json_out_of_memory (void) /* Signal a Lisp error corresponding to the JSON ERROR. */ -static _Noreturn void +static AVOID json_parse_error (const json_error_t *error) { Lisp_Object symbol; @@ -283,9 +265,11 @@ json_parse_error (const json_error_t *error) symbol = Qjson_parse_error; #endif 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))); + list5 (build_string_from_utf8 (error->text), + build_string_from_utf8 (error->source), + INT_TO_INTEGER (error->line), + INT_TO_INTEGER (error->column), + INT_TO_INTEGER (error->position))); } static void @@ -295,10 +279,10 @@ json_release_object (void *object) } /* Signal an error if OBJECT is not a string, or if OBJECT contains - embedded null characters. */ + embedded NUL characters. */ static void -check_string_without_embedded_nulls (Lisp_Object object) +check_string_without_embedded_nuls (Lisp_Object object) { CHECK_STRING (object); CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL, @@ -331,8 +315,14 @@ enum json_object_type { json_object_plist }; +enum json_array_type { + json_array_array, + json_array_list +}; + struct json_configuration { enum json_object_type object_type; + enum json_array_type array_type; Lisp_Object null_object; Lisp_Object false_object; }; @@ -371,28 +361,31 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, 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); - const char *key_str = SSDATA (key); - /* Reject duplicate keys. These are possible if the hash + { + Lisp_Object key = HASH_KEY (h, i); + if (!EQ (key, Qunbound)) + { + Lisp_Object ekey = json_encode (key); + /* We can't specify the length, so the string must be + NUL-terminated. */ + check_string_without_embedded_nuls (ekey); + const char *key_str = SSDATA (ekey); + /* Reject duplicate keys. These are possible if the hash table test is not `equal'. */ - if (json_object_get (json, key_str) != NULL) - wrong_type_argument (Qjson_value_p, lisp); - int status = json_object_set_new (json, key_str, - lisp_to_json (HASH_VALUE (h, i), - conf)); - if (status == -1) - { - /* A failure can be caused either by an invalid key or + if (json_object_get (json, key_str) != NULL) + wrong_type_argument (Qjson_value_p, lisp); + int status + = json_object_set_new (json, key_str, + lisp_to_json (HASH_VALUE (h, i), conf)); + if (status == -1) + { + /* A failure can be caused either by an invalid key or by low memory. */ - json_check_utf8 (key); - json_out_of_memory (); - } - } + json_check_utf8 (ekey); + json_out_of_memory (); + } + } + } } else if (NILP (lisp)) return json_check (json_object ()); @@ -414,7 +407,6 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, tail = XCDR (tail); CHECK_CONS (tail); value = XCAR (tail); - if (EQ (tail, li.tortoise)) circular_list (lisp); } else { @@ -426,8 +418,8 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, CHECK_SYMBOL (key_symbol); Lisp_Object key = SYMBOL_NAME (key_symbol); /* We can't specify the length, so the string must be - null-terminated. */ - check_string_without_embedded_nulls (key); + NUL-terminated. */ + check_string_without_embedded_nuls (key); key_str = SSDATA (key); /* In plists, ensure leading ":" in keys is stripped. It will be reconstructed later in `json_to_lisp'.*/ @@ -484,8 +476,12 @@ lisp_to_json (Lisp_Object lisp, struct json_configuration *conf) return json_check (json_true ()); else if (INTEGERP (lisp)) { - CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp); - return json_check (json_integer (XINT (lisp))); + intmax_t low = TYPE_MINIMUM (json_int_t); + intmax_t high = TYPE_MAXIMUM (json_int_t); + intmax_t value; + if (! (integer_to_intmax (lisp, &value) && low <= value && value <= high)) + args_out_of_range_3 (lisp, make_int (low), make_int (high)); + return json_check (json_integer (value)); } else if (FLOATP (lisp)) return json_check (json_real (XFLOAT_DATA (lisp))); @@ -511,7 +507,7 @@ static void json_parse_args (ptrdiff_t nargs, Lisp_Object *args, struct json_configuration *conf, - bool configure_object_type) + bool parse_object_types) { if ((nargs % 2) != 0) wrong_type_argument (Qplistp, Flist (nargs, args)); @@ -521,7 +517,7 @@ json_parse_args (ptrdiff_t nargs, for (ptrdiff_t i = nargs; i > 0; i -= 2) { Lisp_Object key = args[i - 2]; Lisp_Object value = args[i - 1]; - if (configure_object_type && EQ (key, QCobject_type)) + if (parse_object_types && EQ (key, QCobject_type)) { if (EQ (value, Qhash_table)) conf->object_type = json_object_hashtable; @@ -532,12 +528,22 @@ json_parse_args (ptrdiff_t nargs, else wrong_choice (list3 (Qhash_table, Qalist, Qplist), value); } + else if (parse_object_types && EQ (key, QCarray_type)) + { + if (EQ (value, Qarray)) + conf->array_type = json_array_array; + else if (EQ (value, Qlist)) + conf->array_type = json_array_list; + else + wrong_choice (list2 (Qarray, Qlist), value); + } else if (EQ (key, QCnull_object)) conf->null_object = value; else if (EQ (key, QCfalse_object)) conf->false_object = value; - else if (configure_object_type) - wrong_choice (list3 (QCobject_type, + else if (parse_object_types) + wrong_choice (list4 (QCobject_type, + QCarray_type, QCnull_object, QCfalse_object), value); @@ -558,7 +564,7 @@ false values, t, numbers, strings, or other vectors hashtables, alists or plists. 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 +embedded NUL 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. @@ -594,7 +600,8 @@ usage: (json-serialize OBJECT &rest ARGS) */) } #endif - struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse}; + struct json_configuration conf = + {json_object_hashtable, json_array_array, QCnull, QCfalse}; json_parse_args (nargs - 1, args + 1, &conf, false); json_t *json = lisp_to_json_toplevel (args[0], &conf); @@ -605,51 +612,78 @@ usage: (json-serialize OBJECT &rest ARGS) */) char *string = json_dumps (json, JSON_COMPACT); if (string == NULL) json_out_of_memory (); - record_unwind_protect_ptr (free, string); + record_unwind_protect_ptr (json_free, string); - return unbind_to (count, json_build_string (string)); + return unbind_to (count, build_string_from_utf8 (string)); } struct json_buffer_and_size { const char *buffer; ptrdiff_t size; + /* This tracks how many bytes were inserted by the callback since + json_dump_callback was called. */ + ptrdiff_t inserted_bytes; }; 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); + ptrdiff_t len = buffer_and_size->size; + ptrdiff_t inserted_bytes = buffer_and_size->inserted_bytes; + ptrdiff_t gap_size = GAP_SIZE - inserted_bytes; + + /* Enlarge the gap if necessary. */ + if (gap_size < len) + make_gap (len - gap_size); + + /* Copy this chunk of data into the gap. */ + memcpy ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE + inserted_bytes, + buffer_and_size->buffer, len); + buffer_and_size->inserted_bytes += len; return Qnil; } +static Lisp_Object +json_handle_nonlocal_exit (enum nonlocal_exit type, Lisp_Object data) +{ + switch (type) + { + case NONLOCAL_EXIT_SIGNAL: + return data; + case NONLOCAL_EXIT_THROW: + return Fcons (Qno_catch, data); + default: + eassume (false); + } +} + struct json_insert_data { + /* This tracks how many bytes were inserted by the callback since + json_dump_callback was called. */ + ptrdiff_t inserted_bytes; /* 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. */ +/* Callback for json_dump_callback that inserts a JSON representation + as a unibyte string into the gap. 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); + = {.buffer = buffer, .size = size, .inserted_bytes = d->inserted_bytes}; + d->error = internal_catch_all (json_insert, &buffer_and_size, + json_handle_nonlocal_exit); + d->inserted_bytes = buffer_and_size.inserted_bytes; return NILP (d->error) ? 0 : -1; } @@ -679,16 +713,22 @@ usage: (json-insert OBJECT &rest ARGS) */) } #endif - struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse}; + struct json_configuration conf = + {json_object_hashtable, json_array_array, QCnull, QCfalse}; json_parse_args (nargs - 1, args + 1, &conf, false); json_t *json = lisp_to_json (args[0], &conf); record_unwind_protect_ptr (json_release_object, json); + prepare_to_modify_buffer (PT, PT, NULL); + move_gap_both (PT, PT_BYTE); struct json_insert_data data; + data.inserted_bytes = 0; /* If desired, we might want to add the following flags: JSON_DECODE_ANY, JSON_ALLOW_NUL. */ int status + /* Could have used json_dumpb, but that became available only in + Jansson 2.10, whereas we want to support 2.7 and upward. */ = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT); if (status == -1) { @@ -698,12 +738,60 @@ usage: (json-insert OBJECT &rest ARGS) */) json_out_of_memory (); } + ptrdiff_t inserted = 0; + ptrdiff_t inserted_bytes = data.inserted_bytes; + if (inserted_bytes > 0) + { + /* If required, decode the stuff we've read into the gap. */ + struct coding_system coding; + /* JSON strings are UTF-8 encoded strings. If for some reason + the text returned by the Jansson library includes invalid + byte sequences, they will be represented by raw bytes in the + buffer text. */ + setup_coding_system (Qutf_8_unix, &coding); + coding.dst_multibyte = + !NILP (BVAR (current_buffer, enable_multibyte_characters)); + if (CODING_MAY_REQUIRE_DECODING (&coding)) + { + /* Now we have all the new bytes at the beginning of the gap, + but `decode_coding_gap` needs them at the end of the gap, so + we need to move them. */ + memmove (GAP_END_ADDR - inserted_bytes, GPT_ADDR, inserted_bytes); + decode_coding_gap (&coding, inserted_bytes); + inserted = coding.produced_char; + } + else + { + /* Make the inserted text part of the buffer, as unibyte text. */ + eassert (NILP (BVAR (current_buffer, enable_multibyte_characters))); + insert_from_gap_1 (inserted_bytes, inserted_bytes, false); + + /* The target buffer is unibyte, so we don't need to decode. */ + invalidate_buffer_caches (current_buffer, + PT, PT + inserted_bytes); + adjust_after_insert (PT, PT_BYTE, + PT + inserted_bytes, + PT_BYTE + inserted_bytes, + inserted_bytes); + inserted = inserted_bytes; + } + } + + /* Call after-change hooks. */ + signal_after_change (PT, 0, inserted); + if (inserted > 0) + { + update_compositions (PT, PT, CHECK_BORDER); + /* Move point to after the inserted text. */ + SET_PT_BOTH (PT + inserted, PT_BYTE + inserted_bytes); + } + return unbind_to (count, Qnil); } /* Convert a JSON object to a Lisp object. */ -static _GL_ARG_NONNULL ((1)) Lisp_Object +static Lisp_Object ARG_NONNULL ((1)) json_to_lisp (json_t *json, struct json_configuration *conf) { switch (json_typeof (json)) @@ -715,30 +803,51 @@ json_to_lisp (json_t *json, struct json_configuration *conf) 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)); + { + json_int_t i = json_integer_value (json); + return INT_TO_INTEGER (i); + } 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)); + return make_string_from_utf8 (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), conf)); + if (PTRDIFF_MAX < size) + overflow_error (); + Lisp_Object result; + switch (conf->array_type) + { + case json_array_array: + { + result = make_vector (size, Qunbound); + for (ptrdiff_t i = 0; i < size; ++i) + { + rarely_quit (i); + ASET (result, i, + json_to_lisp (json_array_get (json, i), conf)); + } + break; + } + case json_array_list: + { + result = Qnil; + for (ptrdiff_t i = size - 1; i >= 0; --i) + { + rarely_quit (i); + result = Fcons (json_to_lisp (json_array_get (json, i), conf), + result); + } + break; + } + default: + /* Can't get here. */ + emacs_abort (); + } --lisp_eval_depth; return result; } @@ -753,16 +862,15 @@ json_to_lisp (json_t *json, struct json_configuration *conf) { size_t size = json_object_size (json); if (FIXNUM_OVERFLOW_P (size)) - xsignal0 (Qoverflow_error); + overflow_error (); result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize, - make_natnum (size)); + make_fixed_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; + Lisp_Object key = build_string_from_utf8 (key_str), hash; ptrdiff_t i = hash_lookup (h, key, &hash); /* Keys in JSON objects are unique, so the key can't be present yet. */ @@ -778,7 +886,8 @@ json_to_lisp (json_t *json, struct json_configuration *conf) json_t *value; json_object_foreach (json, key_str, value) { - Lisp_Object key = Fintern (json_build_string (key_str), Qnil); + Lisp_Object key + = Fintern (build_string_from_utf8 (key_str), Qnil); result = Fcons (Fcons (key, json_to_lisp (value, conf)), result); @@ -823,18 +932,22 @@ json_to_lisp (json_t *json, struct json_configuration *conf) DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY, 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, hashtable, alist, or +see. 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, hashtables, alists, or plists. 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. The arguments ARGS are -a list of keyword/argument pairs: +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'. +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'. @@ -863,8 +976,9 @@ usage: (json-parse-string STRING &rest ARGS) */) Lisp_Object string = args[0]; Lisp_Object encoded = json_encode (string); - check_string_without_embedded_nulls (encoded); - struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse}; + check_string_without_embedded_nuls (encoded); + struct json_configuration conf = + {json_object_hashtable, json_array_array, QCnull, QCfalse}; json_parse_args (nargs - 1, args + 1, &conf, true); json_error_t error; @@ -911,9 +1025,32 @@ json_read_buffer_callback (void *buffer, size_t buflen, void *data) DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer, 0, MANY, 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. +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'. usage: (json-parse-buffer &rest args) */) (ptrdiff_t nargs, Lisp_Object *args) { @@ -934,7 +1071,8 @@ usage: (json-parse-buffer &rest args) */) } #endif - struct json_configuration conf = {json_object_hashtable, QCnull, QCfalse}; + struct json_configuration conf = + {json_object_hashtable, json_array_array, QCnull, QCfalse}; json_parse_args (nargs, args, &conf, true); ptrdiff_t point = PT_BYTE; @@ -1013,10 +1151,12 @@ syms_of_json (void) Fput (Qjson_parse_string, Qside_effect_free, Qt); DEFSYM (QCobject_type, ":object-type"); + DEFSYM (QCarray_type, ":array-type"); DEFSYM (QCnull_object, ":null-object"); DEFSYM (QCfalse_object, ":false-object"); DEFSYM (Qalist, "alist"); DEFSYM (Qplist, "plist"); + DEFSYM (Qarray, "array"); defsubr (&Sjson_serialize); defsubr (&Sjson_insert); |