root/src/json.c

DEFINITIONS

1. json_delete
2. init_json_functions
3. json_malloc
4. json_free
5. init_json
6. json_has_prefix
7. json_has_suffix
8. json_encode
9. json_out_of_memory
10. json_parse_error
11. json_release_object
12. check_string_without_embedded_nulls
13. json_check
14. json_check_utf8
15. lisp_to_json_nonscalar_1
16. lisp_to_json_nonscalar
17. lisp_to_json
18. json_parse_args
19. json_available_p
20. ensure_json_available
21. DEFUN
22. json_insert
23. json_handle_nonlocal_exit
24. json_insert_callback
25. ARG_NONNULL
26. json_read_buffer_callback
27. syms_of_json

     1 /* JSON parsing and serialization.
     2 
     3 Copyright (C) 2017-2023 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 (at
    10 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 #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 #define JSON_HAS_ERROR_CODE (JANSSON_VERSION_HEX >= 0x020B00)
    34 
    35 #ifdef WINDOWSNT
    36 # include <windows.h>
    37 # include "w32common.h"
    38 # include "w32.h"
    39 
    40 DEF_DLL_FN (void, json_set_alloc_funcs,
    41             (json_malloc_t malloc_fn, json_free_t free_fn));
    42 DEF_DLL_FN (void, json_delete, (json_t *json));
    43 DEF_DLL_FN (json_t *, json_array, (void));
    44 DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value));
    45 DEF_DLL_FN (size_t, json_array_size, (const json_t *array));
    46 DEF_DLL_FN (json_t *, json_object, (void));
    47 DEF_DLL_FN (int, json_object_set_new,
    48             (json_t *object, const char *key, json_t *value));
    49 DEF_DLL_FN (json_t *, json_null, (void));
    50 DEF_DLL_FN (json_t *, json_true, (void));
    51 DEF_DLL_FN (json_t *, json_false, (void));
    52 DEF_DLL_FN (json_t *, json_integer, (json_int_t value));
    53 DEF_DLL_FN (json_t *, json_real, (double value));
    54 DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len));
    55 DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags));
    56 DEF_DLL_FN (int, json_dump_callback,
    57             (const json_t *json, json_dump_callback_t callback, void *data,
    58              size_t flags));
    59 DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer));
    60 DEF_DLL_FN (double, json_real_value, (const json_t *real));
    61 DEF_DLL_FN (const char *, json_string_value, (const json_t *string));
    62 DEF_DLL_FN (size_t, json_string_length, (const json_t *string));
    63 DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index));
    64 DEF_DLL_FN (json_t *, json_object_get, (const json_t *object, const char *key));
    65 DEF_DLL_FN (size_t, json_object_size, (const json_t *object));
    66 DEF_DLL_FN (const char *, json_object_iter_key, (void *iter));
    67 DEF_DLL_FN (void *, json_object_iter, (json_t *object));
    68 DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter));
    69 DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key));
    70 DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter));
    71 DEF_DLL_FN (json_t *, json_loads,
    72             (const char *input, size_t flags, json_error_t *error));
    73 DEF_DLL_FN (json_t *, json_load_callback,
    74             (json_load_callback_t callback, void *data, size_t flags,
    75              json_error_t *error));
    76 
    77 /* This is called by json_decref, which is an inline function.  */
    78 void json_delete(json_t *json)
    79 {
    80   fn_json_delete (json);
    81 }
    82 
    83 static bool json_initialized;
    84 
    85 static bool
    86 init_json_functions (void)
    87 {
    88   HMODULE library = w32_delayed_load (Qjson);
    89 
    90   if (!library)
    91     return false;
    92 
    93   LOAD_DLL_FN (library, json_set_alloc_funcs);
    94   LOAD_DLL_FN (library, json_delete);
    95   LOAD_DLL_FN (library, json_array);
    96   LOAD_DLL_FN (library, json_array_append_new);
    97   LOAD_DLL_FN (library, json_array_size);
    98   LOAD_DLL_FN (library, json_object);
    99   LOAD_DLL_FN (library, json_object_set_new);
   100   LOAD_DLL_FN (library, json_null);
   101   LOAD_DLL_FN (library, json_true);
   102   LOAD_DLL_FN (library, json_false);
   103   LOAD_DLL_FN (library, json_integer);
   104   LOAD_DLL_FN (library, json_real);
   105   LOAD_DLL_FN (library, json_stringn);
   106   LOAD_DLL_FN (library, json_dumps);
   107   LOAD_DLL_FN (library, json_dump_callback);
   108   LOAD_DLL_FN (library, json_integer_value);
   109   LOAD_DLL_FN (library, json_real_value);
   110   LOAD_DLL_FN (library, json_string_value);
   111   LOAD_DLL_FN (library, json_string_length);
   112   LOAD_DLL_FN (library, json_array_get);
   113   LOAD_DLL_FN (library, json_object_get);
   114   LOAD_DLL_FN (library, json_object_size);
   115   LOAD_DLL_FN (library, json_object_iter_key);
   116   LOAD_DLL_FN (library, json_object_iter);
   117   LOAD_DLL_FN (library, json_object_iter_value);
   118   LOAD_DLL_FN (library, json_object_key_to_iter);
   119   LOAD_DLL_FN (library, json_object_iter_next);
   120   LOAD_DLL_FN (library, json_loads);
   121   LOAD_DLL_FN (library, json_load_callback);
   122 
   123   init_json ();
   124 
   125   return true;
   126 }
   127 
   128 #define json_set_alloc_funcs fn_json_set_alloc_funcs
   129 #define json_array fn_json_array
   130 #define json_array_append_new fn_json_array_append_new
   131 #define json_array_size fn_json_array_size
   132 #define json_object fn_json_object
   133 #define json_object_set_new fn_json_object_set_new
   134 #define json_null fn_json_null
   135 #define json_true fn_json_true
   136 #define json_false fn_json_false
   137 #define json_integer fn_json_integer
   138 #define json_real fn_json_real
   139 #define json_stringn fn_json_stringn
   140 #define json_dumps fn_json_dumps
   141 #define json_dump_callback fn_json_dump_callback
   142 #define json_integer_value fn_json_integer_value
   143 #define json_real_value fn_json_real_value
   144 #define json_string_value fn_json_string_value
   145 #define json_string_length fn_json_string_length
   146 #define json_array_get fn_json_array_get
   147 #define json_object_get fn_json_object_get
   148 #define json_object_size fn_json_object_size
   149 #define json_object_iter_key fn_json_object_iter_key
   150 #define json_object_iter fn_json_object_iter
   151 #define json_object_iter_value fn_json_object_iter_value
   152 #define json_object_key_to_iter fn_json_object_key_to_iter
   153 #define json_object_iter_next fn_json_object_iter_next
   154 #define json_loads fn_json_loads
   155 #define json_load_callback fn_json_load_callback
   156 
   157 #endif  /* WINDOWSNT */
   158 
   159 /* We install a custom allocator so that we can avoid objects larger
   160    than PTRDIFF_MAX.  Such objects wouldn't play well with the rest of
   161    Emacs's codebase, which generally uses ptrdiff_t for sizes and
   162    indices.  The other functions in this file also generally assume
   163    that size_t values never exceed PTRDIFF_MAX.
   164 
   165    In addition, we need to use a custom allocator because on
   166    MS-Windows we replace malloc/free with our own functions, see
   167    w32heap.c, so we must force the library to use our allocator, or
   168    else we won't be able to free storage allocated by the library.  */
   169 
   170 static void *
   171 json_malloc (size_t size)
   172 {
   173   if (size > PTRDIFF_MAX)
   174     {
   175       errno = ENOMEM;
   176       return NULL;
   177     }
   178   return malloc (size);
   179 }
   180 
   181 static void
   182 json_free (void *ptr)
   183 {
   184   free (ptr);
   185 }
   186 
   187 void
   188 init_json (void)
   189 {
   190   json_set_alloc_funcs (json_malloc, json_free);
   191 }
   192 
   193 #if !JSON_HAS_ERROR_CODE
   194 
   195 /* Return whether STRING starts with PREFIX.  */
   196 
   197 static bool
   198 json_has_prefix (const char *string, const char *prefix)
   199 {
   200   return strncmp (string, prefix, strlen (prefix)) == 0;
   201 }
   202 
   203 /* Return whether STRING ends with SUFFIX.  */
   204 
   205 static bool
   206 json_has_suffix (const char *string, const char *suffix)
   207 {
   208   size_t string_len = strlen (string);
   209   size_t suffix_len = strlen (suffix);
   210   return string_len >= suffix_len
   211     && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0;
   212 }
   213 
   214 #endif
   215 
   216 /* Note that all callers of make_string_from_utf8 and build_string_from_utf8
   217    below either pass only value UTF-8 strings or use the functionf for
   218    formatting error messages; in the latter case correctness isn't
   219    critical.  */
   220 
   221 /* Return a unibyte string containing the sequence of UTF-8 encoding
   222    units of the UTF-8 representation of STRING.  If STRING does not
   223    represent a sequence of Unicode scalar values, return a string with
   224    unspecified contents.  */
   225 
   226 static Lisp_Object
   227 json_encode (Lisp_Object string)
   228 {
   229   /* FIXME: Raise an error if STRING is not a scalar value
   230      sequence.  */
   231   return encode_string_utf_8 (string, Qnil, false, Qt, Qt);
   232 }
   233 
   234 static AVOID
   235 json_out_of_memory (void)
   236 {
   237   xsignal0 (Qjson_out_of_memory);
   238 }
   239 
   240 /* Signal a Lisp error corresponding to the JSON ERROR.  */
   241 
   242 static AVOID
   243 json_parse_error (const json_error_t *error)
   244 {
   245   Lisp_Object symbol;
   246 #if JSON_HAS_ERROR_CODE
   247   switch (json_error_code (error))
   248     {
   249     case json_error_premature_end_of_input:
   250       symbol = Qjson_end_of_file;
   251       break;
   252     case json_error_end_of_input_expected:
   253       symbol = Qjson_trailing_content;
   254       break;
   255     default:
   256       symbol = Qjson_parse_error;
   257       break;
   258     }
   259 #else
   260   if (json_has_suffix (error->text, "expected near end of file"))
   261     symbol = Qjson_end_of_file;
   262   else if (json_has_prefix (error->text, "end of file expected"))
   263     symbol = Qjson_trailing_content;
   264   else
   265     symbol = Qjson_parse_error;
   266 #endif
   267   xsignal (symbol,
   268            list5 (build_string_from_utf8 (error->text),
   269                   build_string_from_utf8 (error->source),
   270                   INT_TO_INTEGER (error->line),
   271                   INT_TO_INTEGER (error->column),
   272                   INT_TO_INTEGER (error->position)));
   273 }
   274 
   275 static void
   276 json_release_object (void *object)
   277 {
   278   json_decref (object);
   279 }
   280 
   281 /* Signal an error if OBJECT is not a string, or if OBJECT contains
   282    embedded null characters.  */
   283 
   284 static void
   285 check_string_without_embedded_nulls (Lisp_Object object)
   286 {
   287   CHECK_STRING (object);
   288   CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL,
   289               Qstring_without_embedded_nulls_p, object);
   290 }
   291 
   292 /* Signal an error of type `json-out-of-memory' if OBJECT is
   293    NULL.  */
   294 
   295 static json_t *
   296 json_check (json_t *object)
   297 {
   298   if (object == NULL)
   299     json_out_of_memory ();
   300   return object;
   301 }
   302 
   303 /* If STRING is not a valid UTF-8 string, signal an error of type
   304    `wrong-type-argument'.  STRING must be a unibyte string.  */
   305 
   306 static void
   307 json_check_utf8 (Lisp_Object string)
   308 {
   309   CHECK_TYPE (utf8_string_p (string), Qutf_8_string_p, string);
   310 }
   311 
   312 enum json_object_type {
   313   json_object_hashtable,
   314   json_object_alist,
   315   json_object_plist
   316 };
   317 
   318 enum json_array_type {
   319   json_array_array,
   320   json_array_list
   321 };
   322 
   323 struct json_configuration {
   324   enum json_object_type object_type;
   325   enum json_array_type array_type;
   326   Lisp_Object null_object;
   327   Lisp_Object false_object;
   328 };
   329 
   330 static json_t *lisp_to_json (Lisp_Object,
   331                              const struct json_configuration *conf);
   332 
   333 /* Convert a Lisp object to a nonscalar JSON object (array or object).  */
   334 
   335 static json_t *
   336 lisp_to_json_nonscalar_1 (Lisp_Object lisp,
   337                           const struct json_configuration *conf)
   338 {
   339   json_t *json;
   340   specpdl_ref count;
   341 
   342   if (VECTORP (lisp))
   343     {
   344       ptrdiff_t size = ASIZE (lisp);
   345       json = json_check (json_array ());
   346       count = SPECPDL_INDEX ();
   347       record_unwind_protect_ptr (json_release_object, json);
   348       for (ptrdiff_t i = 0; i < size; ++i)
   349         {
   350           int status
   351             = json_array_append_new (json, lisp_to_json (AREF (lisp, i),
   352                                                          conf));
   353           if (status == -1)
   354             json_out_of_memory ();
   355         }
   356       eassert (json_array_size (json) == size);
   357     }
   358   else if (HASH_TABLE_P (lisp))
   359     {
   360       struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
   361       json = json_check (json_object ());
   362       count = SPECPDL_INDEX ();
   363       record_unwind_protect_ptr (json_release_object, json);
   364       for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
   365         {
   366           Lisp_Object key = HASH_KEY (h, i);
   367           if (!BASE_EQ (key, Qunbound))
   368             {
   369               CHECK_STRING (key);
   370               Lisp_Object ekey = json_encode (key);
   371               /* We can't specify the length, so the string must be
   372                  null-terminated.  */
   373               check_string_without_embedded_nulls (ekey);
   374               const char *key_str = SSDATA (ekey);
   375               /* Reject duplicate keys.  These are possible if the hash
   376                  table test is not `equal'.  */
   377               if (json_object_get (json, key_str) != NULL)
   378                 wrong_type_argument (Qjson_value_p, lisp);
   379               int status
   380                 = json_object_set_new (json, key_str,
   381                                        lisp_to_json (HASH_VALUE (h, i), conf));
   382               if (status == -1)
   383                 {
   384                   /* A failure can be caused either by an invalid key or
   385                    by low memory.  */
   386                   json_check_utf8 (ekey);
   387                   json_out_of_memory ();
   388                 }
   389             }
   390         }
   391     }
   392   else if (NILP (lisp))
   393     return json_check (json_object ());
   394   else if (CONSP (lisp))
   395     {
   396       Lisp_Object tail = lisp;
   397       json = json_check (json_object ());
   398       count = SPECPDL_INDEX ();
   399       record_unwind_protect_ptr (json_release_object, json);
   400       bool is_plist = !CONSP (XCAR (tail));
   401       FOR_EACH_TAIL (tail)
   402         {
   403           const char *key_str;
   404           Lisp_Object value;
   405           Lisp_Object key_symbol;
   406           if (is_plist)
   407             {
   408               key_symbol = XCAR (tail);
   409               tail = XCDR (tail);
   410               CHECK_CONS (tail);
   411               value = XCAR (tail);
   412             }
   413           else
   414             {
   415               Lisp_Object pair = XCAR (tail);
   416               CHECK_CONS (pair);
   417               key_symbol = XCAR (pair);
   418               value = XCDR (pair);
   419             }
   420           CHECK_SYMBOL (key_symbol);
   421           Lisp_Object key = SYMBOL_NAME (key_symbol);
   422           /* We can't specify the length, so the string must be
   423              null-terminated.  */
   424           check_string_without_embedded_nulls (key);
   425           key_str = SSDATA (key);
   426           /* In plists, ensure leading ":" in keys is stripped.  It
   427              will be reconstructed later in `json_to_lisp'.*/
   428           if (is_plist && ':' == key_str[0] && key_str[1])
   429             {
   430               key_str = &key_str[1];
   431             }
   432           /* Only add element if key is not already present.  */
   433           if (json_object_get (json, key_str) == NULL)
   434             {
   435               int status
   436                 = json_object_set_new (json, key_str, lisp_to_json (value,
   437                                                                     conf));
   438               if (status == -1)
   439                 json_out_of_memory ();
   440             }
   441         }
   442       CHECK_LIST_END (tail, lisp);
   443     }
   444   else
   445     wrong_type_argument (Qjson_value_p, lisp);
   446 
   447   clear_unwind_protect (count);
   448   unbind_to (count, Qnil);
   449   return json;
   450 }
   451 
   452 /* Convert LISP to a nonscalar JSON object (array or object).  Signal
   453    an error of type `wrong-type-argument' if LISP is not a vector,
   454    hashtable, alist, or plist.  */
   455 
   456 static json_t *
   457 lisp_to_json_nonscalar (Lisp_Object lisp,
   458                         const struct json_configuration *conf)
   459 {
   460   if (++lisp_eval_depth > max_lisp_eval_depth)
   461     xsignal0 (Qjson_object_too_deep);
   462   json_t *json = lisp_to_json_nonscalar_1 (lisp, conf);
   463   --lisp_eval_depth;
   464   return json;
   465 }
   466 
   467 /* Convert LISP to any JSON object.  Signal an error of type
   468    `wrong-type-argument' if the type of LISP can't be converted to a
   469    JSON object.  */
   470 
   471 static json_t *
   472 lisp_to_json (Lisp_Object lisp, const struct json_configuration *conf)
   473 {
   474   if (EQ (lisp, conf->null_object))
   475     return json_check (json_null ());
   476   else if (EQ (lisp, conf->false_object))
   477     return json_check (json_false ());
   478   else if (EQ (lisp, Qt))
   479     return json_check (json_true ());
   480   else if (INTEGERP (lisp))
   481     {
   482       intmax_t low = TYPE_MINIMUM (json_int_t);
   483       intmax_t high = TYPE_MAXIMUM (json_int_t);
   484       intmax_t value = check_integer_range (lisp, low, high);
   485       return json_check (json_integer (value));
   486     }
   487   else if (FLOATP (lisp))
   488     return json_check (json_real (XFLOAT_DATA (lisp)));
   489   else if (STRINGP (lisp))
   490     {
   491       Lisp_Object encoded = json_encode (lisp);
   492       json_t *json = json_stringn (SSDATA (encoded), SBYTES (encoded));
   493       if (json == NULL)
   494         {
   495           /* A failure can be caused either by an invalid string or by
   496              low memory.  */
   497           json_check_utf8 (encoded);
   498           json_out_of_memory ();
   499         }
   500       return json;
   501     }
   502 
   503   /* LISP now must be a vector, hashtable, alist, or plist.  */
   504   return lisp_to_json_nonscalar (lisp, conf);
   505 }
   506 
   507 static void
   508 json_parse_args (ptrdiff_t nargs,
   509                  Lisp_Object *args,
   510                  struct json_configuration *conf,
   511                  bool parse_object_types)
   512 {
   513   if ((nargs % 2) != 0)
   514     wrong_type_argument (Qplistp, Flist (nargs, args));
   515 
   516   /* Start from the back so keyword values appearing
   517      first take precedence. */
   518   for (ptrdiff_t i = nargs; i > 0; i -= 2) {
   519     Lisp_Object key = args[i - 2];
   520     Lisp_Object value = args[i - 1];
   521     if (parse_object_types && EQ (key, QCobject_type))
   522       {
   523         if (EQ (value, Qhash_table))
   524           conf->object_type = json_object_hashtable;
   525         else if (EQ (value, Qalist))
   526           conf->object_type = json_object_alist;
   527         else if (EQ (value, Qplist))
   528           conf->object_type = json_object_plist;
   529         else
   530           wrong_choice (list3 (Qhash_table, Qalist, Qplist), value);
   531       }
   532     else if (parse_object_types && EQ (key, QCarray_type))
   533       {
   534         if (EQ (value, Qarray))
   535           conf->array_type = json_array_array;
   536         else if (EQ (value, Qlist))
   537           conf->array_type = json_array_list;
   538         else
   539           wrong_choice (list2 (Qarray, Qlist), value);
   540       }
   541     else if (EQ (key, QCnull_object))
   542       conf->null_object = value;
   543     else if (EQ (key, QCfalse_object))
   544       conf->false_object = value;
   545     else if (parse_object_types)
   546       wrong_choice (list4 (QCobject_type,
   547                            QCarray_type,
   548                            QCnull_object,
   549                            QCfalse_object),
   550                     value);
   551     else
   552       wrong_choice (list2 (QCnull_object,
   553                            QCfalse_object),
   554                     value);
   555   }
   556 }
   557 
   558 static bool
   559 json_available_p (void)
   560 {
   561 #ifdef WINDOWSNT
   562   if (!json_initialized)
   563     {
   564       Lisp_Object status;
   565       json_initialized = init_json_functions ();
   566       status = json_initialized ? Qt : Qnil;
   567       Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
   568     }
   569   return json_initialized;
   570 #else  /* !WINDOWSNT */
   571   return true;
   572 #endif
   573 }
   574 
   575 #ifdef WINDOWSNT
   576 static void
   577 ensure_json_available (void)
   578 {
   579   if (!json_available_p ())
   580     Fsignal (Qjson_unavailable,
   581              list1 (build_unibyte_string ("jansson library not found")));
   582 }
   583 #endif
   584 
   585 DEFUN ("json--available-p", Fjson__available_p, Sjson__available_p, 0, 0, NULL,
   586        doc: /* Return non-nil if libjansson is available (internal use only).  */)
   587   (void)
   588 {
   589   return json_available_p () ? Qt : Qnil;
   590 }
   591 
   592 DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, MANY,
   593        NULL,
   594        doc: /* Return the JSON representation of OBJECT as a string.
   595 
   596 OBJECT must be t, a number, string, vector, hashtable, alist, plist,
   597 or the Lisp equivalents to the JSON null and false values, and its
   598 elements must recursively consist of the same kinds of values.  t will
   599 be converted to the JSON true value.  Vectors will be converted to
   600 JSON arrays, whereas hashtables, alists and plists are converted to
   601 JSON objects.  Hashtable keys must be strings without embedded null
   602 characters and must be unique within each object.  Alist and plist
   603 keys must be symbols; if a key is duplicate, the first instance is
   604 used.
   605 
   606 The Lisp equivalents to the JSON null and false values are
   607 configurable in the arguments ARGS, a list of keyword/argument pairs:
   608 
   609 The keyword argument `:null-object' specifies which object to use
   610 to represent a JSON null value.  It defaults to `:null'.
   611 
   612 The keyword argument `:false-object' specifies which object to use to
   613 represent a JSON false value.  It defaults to `:false'.
   614 
   615 In you specify the same value for `:null-object' and `:false-object',
   616 a potentially ambiguous situation, the JSON output will not contain
   617 any JSON false values.
   618 usage: (json-serialize OBJECT &rest ARGS)  */)
   619      (ptrdiff_t nargs, Lisp_Object *args)
   620 {
   621   specpdl_ref count = SPECPDL_INDEX ();
   622 
   623 #ifdef WINDOWSNT
   624   ensure_json_available ();
   625 #endif
   626 
   627   struct json_configuration conf =
   628     {json_object_hashtable, json_array_array, QCnull, QCfalse};
   629   json_parse_args (nargs - 1, args + 1, &conf, false);
   630 
   631   json_t *json = lisp_to_json (args[0], &conf);
   632   record_unwind_protect_ptr (json_release_object, json);
   633 
   634   char *string = json_dumps (json, JSON_COMPACT | JSON_ENCODE_ANY);
   635   if (string == NULL)
   636     json_out_of_memory ();
   637   record_unwind_protect_ptr (json_free, string);
   638 
   639   return unbind_to (count, build_string_from_utf8 (string));
   640 }
   641 
   642 struct json_buffer_and_size
   643 {
   644   const char *buffer;
   645   ptrdiff_t size;
   646   /* This tracks how many bytes were inserted by the callback since
   647      json_dump_callback was called.  */
   648   ptrdiff_t inserted_bytes;
   649 };
   650 
   651 static Lisp_Object
   652 json_insert (void *data)
   653 {
   654   struct json_buffer_and_size *buffer_and_size = data;
   655   ptrdiff_t len = buffer_and_size->size;
   656   ptrdiff_t inserted_bytes = buffer_and_size->inserted_bytes;
   657   ptrdiff_t gap_size = GAP_SIZE - inserted_bytes;
   658 
   659   /* Enlarge the gap if necessary.  */
   660   if (gap_size < len)
   661     make_gap (len - gap_size);
   662 
   663   /* Copy this chunk of data into the gap.  */
   664   memcpy ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE + inserted_bytes,
   665           buffer_and_size->buffer, len);
   666   buffer_and_size->inserted_bytes += len;
   667   return Qnil;
   668 }
   669 
   670 static Lisp_Object
   671 json_handle_nonlocal_exit (enum nonlocal_exit type, Lisp_Object data)
   672 {
   673   switch (type)
   674     {
   675     case NONLOCAL_EXIT_SIGNAL:
   676       return data;
   677     case NONLOCAL_EXIT_THROW:
   678       return Fcons (Qno_catch, data);
   679     default:
   680       eassume (false);
   681     }
   682 }
   683 
   684 struct json_insert_data
   685 {
   686   /* This tracks how many bytes were inserted by the callback since
   687      json_dump_callback was called.  */
   688   ptrdiff_t inserted_bytes;
   689   /* nil if json_insert succeeded, otherwise the symbol
   690      Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA).  */
   691   Lisp_Object error;
   692 };
   693 
   694 /* Callback for json_dump_callback that inserts a JSON representation
   695    as a unibyte string into the gap.  DATA must point to a structure
   696    of type json_insert_data.  This function may not exit nonlocally.
   697    It catches all nonlocal exits and stores them in data->error for
   698    reraising.  */
   699 
   700 static int
   701 json_insert_callback (const char *buffer, size_t size, void *data)
   702 {
   703   struct json_insert_data *d = data;
   704   struct json_buffer_and_size buffer_and_size
   705     = {.buffer = buffer, .size = size, .inserted_bytes = d->inserted_bytes};
   706   d->error = internal_catch_all (json_insert, &buffer_and_size,
   707                                  json_handle_nonlocal_exit);
   708   d->inserted_bytes = buffer_and_size.inserted_bytes;
   709   return NILP (d->error) ? 0 : -1;
   710 }
   711 
   712 DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, MANY,
   713        NULL,
   714        doc: /* Insert the JSON representation of OBJECT before point.
   715 This is the same as (insert (json-serialize OBJECT)), but potentially
   716 faster.  See the function `json-serialize' for allowed values of
   717 OBJECT.
   718 usage: (json-insert OBJECT &rest ARGS)  */)
   719      (ptrdiff_t nargs, Lisp_Object *args)
   720 {
   721   specpdl_ref count = SPECPDL_INDEX ();
   722 
   723 #ifdef WINDOWSNT
   724   ensure_json_available ();
   725 #endif
   726 
   727   struct json_configuration conf =
   728     {json_object_hashtable, json_array_array, QCnull, QCfalse};
   729   json_parse_args (nargs - 1, args + 1, &conf, false);
   730 
   731   json_t *json = lisp_to_json (args[0], &conf);
   732   record_unwind_protect_ptr (json_release_object, json);
   733 
   734   prepare_to_modify_buffer (PT, PT, NULL);
   735   move_gap_both (PT, PT_BYTE);
   736   struct json_insert_data data;
   737   data.inserted_bytes = 0;
   738   /* Could have used json_dumpb, but that became available only in
   739      Jansson 2.10, whereas we want to support 2.7 and upward.  */
   740   int status = json_dump_callback (json, json_insert_callback, &data,
   741                                    JSON_COMPACT | JSON_ENCODE_ANY);
   742   if (status == -1)
   743     {
   744       if (CONSP (data.error))
   745         xsignal (XCAR (data.error), XCDR (data.error));
   746       else
   747         json_out_of_memory ();
   748     }
   749 
   750   ptrdiff_t inserted = 0;
   751   ptrdiff_t inserted_bytes = data.inserted_bytes;
   752   if (inserted_bytes > 0)
   753     {
   754       /* If required, decode the stuff we've read into the gap.  */
   755       struct coding_system coding;
   756       /* JSON strings are UTF-8 encoded strings.  If for some reason
   757          the text returned by the Jansson library includes invalid
   758          byte sequences, they will be represented by raw bytes in the
   759          buffer text.  */
   760       setup_coding_system (Qutf_8_unix, &coding);
   761       coding.dst_multibyte =
   762         !NILP (BVAR (current_buffer, enable_multibyte_characters));
   763       if (CODING_MAY_REQUIRE_DECODING (&coding))
   764         {
   765           /* Now we have all the new bytes at the beginning of the gap,
   766              but `decode_coding_gap` needs them at the end of the gap, so
   767              we need to move them.  */
   768           memmove (GAP_END_ADDR - inserted_bytes, GPT_ADDR, inserted_bytes);
   769           decode_coding_gap (&coding, inserted_bytes);
   770           inserted = coding.produced_char;
   771         }
   772       else
   773         {
   774           /* Make the inserted text part of the buffer, as unibyte text.  */
   775           eassert (NILP (BVAR (current_buffer, enable_multibyte_characters)));
   776           insert_from_gap_1 (inserted_bytes, inserted_bytes, false);
   777 
   778           /* The target buffer is unibyte, so we don't need to decode.  */
   779           invalidate_buffer_caches (current_buffer,
   780                                     PT, PT + inserted_bytes);
   781           adjust_after_insert (PT, PT_BYTE,
   782                                PT + inserted_bytes,
   783                                PT_BYTE + inserted_bytes,
   784                                inserted_bytes);
   785           inserted = inserted_bytes;
   786         }
   787     }
   788 
   789   /* Call after-change hooks.  */
   790   signal_after_change (PT, 0, inserted);
   791   if (inserted > 0)
   792     {
   793       update_compositions (PT, PT, CHECK_BORDER);
   794       /* Move point to after the inserted text.  */
   795       SET_PT_BOTH (PT + inserted, PT_BYTE + inserted_bytes);
   796     }
   797 
   798   return unbind_to (count, Qnil);
   799 }
   800 
   801 /* Convert a JSON object to a Lisp object.  */
   802 
   803 static Lisp_Object ARG_NONNULL ((1))
   804 json_to_lisp (json_t *json, const struct json_configuration *conf)
   805 {
   806   switch (json_typeof (json))
   807     {
   808     case JSON_NULL:
   809       return conf->null_object;
   810     case JSON_FALSE:
   811       return conf->false_object;
   812     case JSON_TRUE:
   813       return Qt;
   814     case JSON_INTEGER:
   815       {
   816         json_int_t i = json_integer_value (json);
   817         return INT_TO_INTEGER (i);
   818       }
   819     case JSON_REAL:
   820       return make_float (json_real_value (json));
   821     case JSON_STRING:
   822       return make_string_from_utf8 (json_string_value (json),
   823                                     json_string_length (json));
   824     case JSON_ARRAY:
   825       {
   826         if (++lisp_eval_depth > max_lisp_eval_depth)
   827           xsignal0 (Qjson_object_too_deep);
   828         size_t size = json_array_size (json);
   829         if (PTRDIFF_MAX < size)
   830           overflow_error ();
   831         Lisp_Object result;
   832         switch (conf->array_type)
   833           {
   834           case json_array_array:
   835             {
   836               result = make_vector (size, Qunbound);
   837               for (ptrdiff_t i = 0; i < size; ++i)
   838                 {
   839                   rarely_quit (i);
   840                   ASET (result, i,
   841                         json_to_lisp (json_array_get (json, i), conf));
   842                 }
   843               break;
   844             }
   845           case json_array_list:
   846             {
   847               result = Qnil;
   848               for (ptrdiff_t i = size - 1; i >= 0; --i)
   849                 {
   850                   rarely_quit (i);
   851                   result = Fcons (json_to_lisp (json_array_get (json, i), conf),
   852                                   result);
   853                 }
   854               break;
   855             }
   856           default:
   857             /* Can't get here.  */
   858             emacs_abort ();
   859           }
   860         --lisp_eval_depth;
   861         return result;
   862       }
   863     case JSON_OBJECT:
   864       {
   865         if (++lisp_eval_depth > max_lisp_eval_depth)
   866           xsignal0 (Qjson_object_too_deep);
   867         Lisp_Object result;
   868         switch (conf->object_type)
   869           {
   870           case json_object_hashtable:
   871             {
   872               size_t size = json_object_size (json);
   873               if (FIXNUM_OVERFLOW_P (size))
   874                 overflow_error ();
   875               result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize,
   876                               make_fixed_natnum (size));
   877               struct Lisp_Hash_Table *h = XHASH_TABLE (result);
   878               const char *key_str;
   879               json_t *value;
   880               json_object_foreach (json, key_str, value)
   881                 {
   882                   Lisp_Object key = build_string_from_utf8 (key_str), hash;
   883                   ptrdiff_t i = hash_lookup (h, key, &hash);
   884                   /* Keys in JSON objects are unique, so the key can't
   885                      be present yet.  */
   886                   eassert (i < 0);
   887                   hash_put (h, key, json_to_lisp (value, conf), hash);
   888                 }
   889               break;
   890             }
   891           case json_object_alist:
   892             {
   893               result = Qnil;
   894               const char *key_str;
   895               json_t *value;
   896               json_object_foreach (json, key_str, value)
   897                 {
   898                   Lisp_Object key
   899                     = Fintern (build_string_from_utf8 (key_str), Qnil);
   900                   result
   901                     = Fcons (Fcons (key, json_to_lisp (value, conf)),
   902                              result);
   903                 }
   904               result = Fnreverse (result);
   905               break;
   906             }
   907           case json_object_plist:
   908             {
   909               result = Qnil;
   910               const char *key_str;
   911               json_t *value;
   912               json_object_foreach (json, key_str, value)
   913                 {
   914                   USE_SAFE_ALLOCA;
   915                   ptrdiff_t key_str_len = strlen (key_str);
   916                   char *keyword_key_str = SAFE_ALLOCA (1 + key_str_len + 1);
   917                   keyword_key_str[0] = ':';
   918                   strcpy (&keyword_key_str[1], key_str);
   919                   Lisp_Object key = intern_1 (keyword_key_str, key_str_len + 1);
   920                   /* Build the plist as value-key since we're going to
   921                      reverse it in the end.*/
   922                   result = Fcons (key, result);
   923                   result = Fcons (json_to_lisp (value, conf), result);
   924                   SAFE_FREE ();
   925                 }
   926               result = Fnreverse (result);
   927               break;
   928             }
   929           default:
   930             /* Can't get here.  */
   931             emacs_abort ();
   932           }
   933         --lisp_eval_depth;
   934         return result;
   935       }
   936     }
   937   /* Can't get here.  */
   938   emacs_abort ();
   939 }
   940 
   941 DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY,
   942        NULL,
   943        doc: /* Parse the JSON STRING into a Lisp object.
   944 This is essentially the reverse operation of `json-serialize', which
   945 see.  The returned object will be the JSON null value, the JSON false
   946 value, t, a number, a string, a vector, a list, a hashtable, an alist,
   947 or a plist.  Its elements will be further objects of these types.  If
   948 there are duplicate keys in an object, all but the last one are
   949 ignored.  If STRING doesn't contain a valid JSON object, this function
   950 signals an error of type `json-parse-error'.
   951 
   952 The arguments ARGS are a list of keyword/argument pairs:
   953 
   954 The keyword argument `:object-type' specifies which Lisp type is used
   955 to represent objects; it can be `hash-table', `alist' or `plist'.  It
   956 defaults to `hash-table'.
   957 
   958 The keyword argument `:array-type' specifies which Lisp type is used
   959 to represent arrays; it can be `array' (the default) or `list'.
   960 
   961 The keyword argument `:null-object' specifies which object to use
   962 to represent a JSON null value.  It defaults to `:null'.
   963 
   964 The keyword argument `:false-object' specifies which object to use to
   965 represent a JSON false value.  It defaults to `:false'.
   966 usage: (json-parse-string STRING &rest ARGS) */)
   967   (ptrdiff_t nargs, Lisp_Object *args)
   968 {
   969   specpdl_ref count = SPECPDL_INDEX ();
   970 
   971 #ifdef WINDOWSNT
   972   ensure_json_available ();
   973 #endif
   974 
   975   Lisp_Object string = args[0];
   976   CHECK_STRING (string);
   977   Lisp_Object encoded = json_encode (string);
   978   check_string_without_embedded_nulls (encoded);
   979   struct json_configuration conf =
   980     {json_object_hashtable, json_array_array, QCnull, QCfalse};
   981   json_parse_args (nargs - 1, args + 1, &conf, true);
   982 
   983   json_error_t error;
   984   json_t *object
   985     = json_loads (SSDATA (encoded), JSON_DECODE_ANY | JSON_ALLOW_NUL, &error);
   986   if (object == NULL)
   987     json_parse_error (&error);
   988 
   989   /* Avoid leaking the object in case of further errors.  */
   990   if (object != NULL)
   991     record_unwind_protect_ptr (json_release_object, object);
   992 
   993   return unbind_to (count, json_to_lisp (object, &conf));
   994 }
   995 
   996 struct json_read_buffer_data
   997 {
   998   /* Byte position of position to read the next chunk from.  */
   999   ptrdiff_t point;
  1000 };
  1001 
  1002 /* Callback for json_load_callback that reads from the current buffer.
  1003    DATA must point to a structure of type json_read_buffer_data.
  1004    data->point must point to the byte position to read from; after
  1005    reading, data->point is advanced accordingly.  The buffer point
  1006    itself is ignored.  This function may not exit nonlocally.  */
  1007 
  1008 static size_t
  1009 json_read_buffer_callback (void *buffer, size_t buflen, void *data)
  1010 {
  1011   struct json_read_buffer_data *d = data;
  1012 
  1013   /* First, parse from point to the gap or the end of the accessible
  1014      portion, whatever is closer.  */
  1015   ptrdiff_t point = d->point;
  1016   ptrdiff_t end = BUFFER_CEILING_OF (point) + 1;
  1017   ptrdiff_t count = end - point;
  1018   if (buflen < count)
  1019     count = buflen;
  1020   memcpy (buffer, BYTE_POS_ADDR (point), count);
  1021   d->point += count;
  1022   return count;
  1023 }
  1024 
  1025 DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
  1026        0, MANY, NULL,
  1027        doc: /* Read JSON object from current buffer starting at point.
  1028 Move point after the end of the object if parsing was successful.
  1029 On error, don't move point.
  1030 
  1031 The returned object will be a vector, list, hashtable, alist, or
  1032 plist.  Its elements will be the JSON null value, the JSON false
  1033 value, t, numbers, strings, or further vectors, lists, hashtables,
  1034 alists, or plists.  If there are duplicate keys in an object, all
  1035 but the last one are ignored.
  1036 
  1037 If the current buffer doesn't contain a valid JSON object, the
  1038 function signals an error of type `json-parse-error'.
  1039 
  1040 The arguments ARGS are a list of keyword/argument pairs:
  1041 
  1042 The keyword argument `:object-type' specifies which Lisp type is used
  1043 to represent objects; it can be `hash-table', `alist' or `plist'.  It
  1044 defaults to `hash-table'.
  1045 
  1046 The keyword argument `:array-type' specifies which Lisp type is used
  1047 to represent arrays; it can be `array' (the default) or `list'.
  1048 
  1049 The keyword argument `:null-object' specifies which object to use
  1050 to represent a JSON null value.  It defaults to `:null'.
  1051 
  1052 The keyword argument `:false-object' specifies which object to use to
  1053 represent a JSON false value.  It defaults to `:false'.
  1054 usage: (json-parse-buffer &rest args) */)
  1055      (ptrdiff_t nargs, Lisp_Object *args)
  1056 {
  1057   specpdl_ref count = SPECPDL_INDEX ();
  1058 
  1059 #ifdef WINDOWSNT
  1060   ensure_json_available ();
  1061 #endif
  1062 
  1063   struct json_configuration conf =
  1064     {json_object_hashtable, json_array_array, QCnull, QCfalse};
  1065   json_parse_args (nargs, args, &conf, true);
  1066 
  1067   ptrdiff_t point = PT_BYTE;
  1068   struct json_read_buffer_data data = {.point = point};
  1069   json_error_t error;
  1070   json_t *object
  1071     = json_load_callback (json_read_buffer_callback, &data,
  1072                           JSON_DECODE_ANY
  1073                           | JSON_DISABLE_EOF_CHECK
  1074                           | JSON_ALLOW_NUL,
  1075                           &error);
  1076 
  1077   if (object == NULL)
  1078     json_parse_error (&error);
  1079 
  1080   /* Avoid leaking the object in case of further errors.  */
  1081   record_unwind_protect_ptr (json_release_object, object);
  1082 
  1083   /* Convert and then move point only if everything succeeded.  */
  1084   Lisp_Object lisp = json_to_lisp (object, &conf);
  1085 
  1086   /* Adjust point by how much we just read.  */
  1087   point += error.position;
  1088   SET_PT_BOTH (BYTE_TO_CHAR (point), point);
  1089 
  1090   return unbind_to (count, lisp);
  1091 }
  1092 
  1093 void
  1094 syms_of_json (void)
  1095 {
  1096   DEFSYM (QCnull, ":null");
  1097   DEFSYM (QCfalse, ":false");
  1098 
  1099   DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p");
  1100   DEFSYM (Qjson_value_p, "json-value-p");
  1101 
  1102   DEFSYM (Qjson_error, "json-error");
  1103   DEFSYM (Qjson_out_of_memory, "json-out-of-memory");
  1104   DEFSYM (Qjson_parse_error, "json-parse-error");
  1105   DEFSYM (Qjson_end_of_file, "json-end-of-file");
  1106   DEFSYM (Qjson_trailing_content, "json-trailing-content");
  1107   DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
  1108   DEFSYM (Qjson_unavailable, "json-unavailable");
  1109   define_error (Qjson_error, "generic JSON error", Qerror);
  1110   define_error (Qjson_out_of_memory,
  1111                 "not enough memory for creating JSON object", Qjson_error);
  1112   define_error (Qjson_parse_error, "could not parse JSON stream",
  1113                 Qjson_error);
  1114   define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error);
  1115   define_error (Qjson_trailing_content, "trailing content after JSON stream",
  1116                 Qjson_parse_error);
  1117   define_error (Qjson_object_too_deep,
  1118                 "object cyclic or Lisp evaluation too deep", Qjson_error);
  1119 
  1120   DEFSYM (Qpure, "pure");
  1121   DEFSYM (Qside_effect_free, "side-effect-free");
  1122 
  1123   DEFSYM (Qjson_serialize, "json-serialize");
  1124   DEFSYM (Qjson_parse_string, "json-parse-string");
  1125   Fput (Qjson_serialize, Qpure, Qt);
  1126   Fput (Qjson_serialize, Qside_effect_free, Qt);
  1127   Fput (Qjson_parse_string, Qpure, Qt);
  1128   Fput (Qjson_parse_string, Qside_effect_free, Qt);
  1129 
  1130   DEFSYM (QCobject_type, ":object-type");
  1131   DEFSYM (QCarray_type, ":array-type");
  1132   DEFSYM (QCnull_object, ":null-object");
  1133   DEFSYM (QCfalse_object, ":false-object");
  1134   DEFSYM (Qalist, "alist");
  1135   DEFSYM (Qplist, "plist");
  1136   DEFSYM (Qarray, "array");
  1137 
  1138   defsubr (&Sjson__available_p);
  1139   defsubr (&Sjson_serialize);
  1140   defsubr (&Sjson_insert);
  1141   defsubr (&Sjson_parse_string);
  1142   defsubr (&Sjson_parse_buffer);
  1143 }