src/json.c

   1 /* JSON parsing and serialization.
   2
   3 Copyright (C) 2017 Free Software Foundation, Inc.
   4
   5 This file is part of GNU Emacs.
   6
   7 GNU Emacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or (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 "w32.h"
  38
  39 DEF_DLL_FN (void, json_set_alloc_funcs,
  40             (json_malloc_t malloc_fn, json_free_t free_fn));
  41 DEF_DLL_FN (void, json_delete, (json_t *json));
  42 DEF_DLL_FN (json_t *, json_array, (void));
  43 DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value));
  44 DEF_DLL_FN (size_t, json_array_size, (const json_t *array));
  45 DEF_DLL_FN (json_t *, json_object, (void));
  46 DEF_DLL_FN (int, json_object_set_new,
  47             (json_t *object, const char *key, json_t *value));
  48 DEF_DLL_FN (json_t *, json_null, (void));
  49 DEF_DLL_FN (json_t *, json_true, (void));
  50 DEF_DLL_FN (json_t *, json_false, (void));
  51 DEF_DLL_FN (json_t *, json_integer, (json_int_t value));
  52 DEF_DLL_FN (json_t *, json_real, (double value));
  53 DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len));
  54 DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags));
  55 DEF_DLL_FN (int, json_dump_callback,
  56             (const json_t *json, json_dump_callback_t callback, void *data,
  57              size_t flags));
  58 DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer));
  59 DEF_DLL_FN (double, json_real_value, (const json_t *real));
  60 DEF_DLL_FN (const char *, json_string_value, (const json_t *string));
  61 DEF_DLL_FN (size_t, json_string_length, (const json_t *string));
  62 DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index));
  63 DEF_DLL_FN (json_t *, json_object_get, (const json_t *object, const char *key));
  64 DEF_DLL_FN (size_t, json_object_size, (const json_t *object));
  65 DEF_DLL_FN (const char *, json_object_iter_key, (void *iter));
  66 DEF_DLL_FN (void *, json_object_iter, (json_t *object));
  67 DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter));
  68 DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key));
  69 DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter));
  70 DEF_DLL_FN (json_t *, json_loads,
  71             (const char *input, size_t flags, json_error_t *error));
  72 DEF_DLL_FN (json_t *, json_load_callback,
  73             (json_load_callback_t callback, void *data, size_t flags,
  74              json_error_t *error));
  75
  76 /* This is called by json_decref, which is an inline function.  */
  77 void json_delete(json_t *json)
  78 {
  79   fn_json_delete (json);
  80 }
  81
  82 static bool json_initialized;
  83
  84 static bool
  85 init_json_functions (void)
  86 {
  87   HMODULE library = w32_delayed_load (Qjson);
  88
  89   if (!library)
  90     return false;
  91
  92   LOAD_DLL_FN (library, json_set_alloc_funcs);
  93   LOAD_DLL_FN (library, json_delete);
  94   LOAD_DLL_FN (library, json_array);
  95   LOAD_DLL_FN (library, json_array_append_new);
  96   LOAD_DLL_FN (library, json_array_size);
  97   LOAD_DLL_FN (library, json_object);
  98   LOAD_DLL_FN (library, json_object_set_new);
  99   LOAD_DLL_FN (library, json_null);
 100   LOAD_DLL_FN (library, json_true);
 101   LOAD_DLL_FN (library, json_false);
 102   LOAD_DLL_FN (library, json_integer);
 103   LOAD_DLL_FN (library, json_real);
 104   LOAD_DLL_FN (library, json_stringn);
 105   LOAD_DLL_FN (library, json_dumps);
 106   LOAD_DLL_FN (library, json_dump_callback);
 107   LOAD_DLL_FN (library, json_integer_value);
 108   LOAD_DLL_FN (library, json_real_value);
 109   LOAD_DLL_FN (library, json_string_value);
 110   LOAD_DLL_FN (library, json_string_length);
 111   LOAD_DLL_FN (library, json_array_get);
 112   LOAD_DLL_FN (library, json_object_get);
 113   LOAD_DLL_FN (library, json_object_size);
 114   LOAD_DLL_FN (library, json_object_iter_key);
 115   LOAD_DLL_FN (library, json_object_iter);
 116   LOAD_DLL_FN (library, json_object_iter_value);
 117   LOAD_DLL_FN (library, json_object_key_to_iter);
 118   LOAD_DLL_FN (library, json_object_iter_next);
 119   LOAD_DLL_FN (library, json_loads);
 120   LOAD_DLL_FN (library, json_load_callback);
 121
 122   init_json ();
 123
 124   return true;
 125 }
 126
 127 #define json_set_alloc_funcs fn_json_set_alloc_funcs
 128 #define json_array fn_json_array
 129 #define json_array_append_new fn_json_array_append_new
 130 #define json_array_size fn_json_array_size
 131 #define json_object fn_json_object
 132 #define json_object_set_new fn_json_object_set_new
 133 #define json_null fn_json_null
 134 #define json_true fn_json_true
 135 #define json_false fn_json_false
 136 #define json_integer fn_json_integer
 137 #define json_real fn_json_real
 138 #define json_stringn fn_json_stringn
 139 #define json_dumps fn_json_dumps
 140 #define json_dump_callback fn_json_dump_callback
 141 #define json_integer_value fn_json_integer_value
 142 #define json_real_value fn_json_real_value
 143 #define json_string_value fn_json_string_value
 144 #define json_string_length fn_json_string_length
 145 #define json_array_get fn_json_array_get
 146 #define json_object_get fn_json_object_get
 147 #define json_object_size fn_json_object_size
 148 #define json_object_iter_key fn_json_object_iter_key
 149 #define json_object_iter fn_json_object_iter
 150 #define json_object_iter_value fn_json_object_iter_value
 151 #define json_object_key_to_iter fn_json_object_key_to_iter
 152 #define json_object_iter_next fn_json_object_iter_next
 153 #define json_loads fn_json_loads
 154 #define json_load_callback fn_json_load_callback
 155
 156 #endif  /* WINDOWSNT */
 157
 158 /* We install a custom allocator so that we can avoid objects larger
 159    than PTRDIFF_MAX.  Such objects wouldn't play well with the rest of
 160    Emacs's codebase, which generally uses ptrdiff_t for sizes and
 161    indices.  The other functions in this file also generally assume
 162    that size_t values never exceed PTRDIFF_MAX.  */
 163
 164 static void *
 165 json_malloc (size_t size)
 166 {
 167   if (size > PTRDIFF_MAX)
 168     {
 169       errno = ENOMEM;
 170       return NULL;
 171     }
 172   return malloc (size);
 173 }
 174
 175 static void
 176 json_free (void *ptr)
 177 {
 178   free (ptr);
 179 }
 180
 181 void
 182 init_json (void)
 183 {
 184   json_set_alloc_funcs (json_malloc, json_free);
 185 }
 186
 187 #if !JSON_HAS_ERROR_CODE
 188
 189 /* Return whether STRING starts with PREFIX.  */
 190
 191 static bool
 192 json_has_prefix (const char *string, const char *prefix)
 193 {
 194   size_t string_len = strlen (string);
 195   size_t prefix_len = strlen (prefix);
 196   return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0;
 197 }
 198
 199 /* Return whether STRING ends with SUFFIX.  */
 200
 201 static bool
 202 json_has_suffix (const char *string, const char *suffix)
 203 {
 204   size_t string_len = strlen (string);
 205   size_t suffix_len = strlen (suffix);
 206   return string_len >= suffix_len
 207     && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0;
 208 }
 209
 210 #endif
 211
 212 /* Create a multibyte Lisp string from the UTF-8 string in
 213    [DATA, DATA + SIZE).  If the range [DATA, DATA + SIZE) does not
 214    contain a valid UTF-8 string, an unspecified string is returned.
 215    Note that all callers below either pass only value UTF-8 strings or
 216    use this function for formatting error messages; in the latter case
 217    correctness isn't critical.  */
 218
 219 static Lisp_Object
 220 json_make_string (const char *data, ptrdiff_t size)
 221 {
 222   return code_convert_string (make_specified_string (data, -1, size, false),
 223                               Qutf_8_unix, Qt, false, true, true);
 224 }
 225
 226 /* Create a multibyte Lisp string from the null-terminated UTF-8
 227    string beginning at DATA.  If the string is not a valid UTF-8
 228    string, an unspecified string is returned.  Note that all callers
 229    below either pass only value UTF-8 strings or use this function for
 230    formatting error messages; in the latter case correctness isn't
 231    critical.  */
 232
 233 static Lisp_Object
 234 json_build_string (const char *data)
 235 {
 236   return json_make_string (data, strlen (data));
 237 }
 238
 239 /* Return a unibyte string containing the sequence of UTF-8 encoding
 240    units of the UTF-8 representation of STRING.  If STRING does not
 241    represent a sequence of Unicode scalar values, return a string with
 242    unspecified contents.  */
 243
 244 static Lisp_Object
 245 json_encode (Lisp_Object string)
 246 {
 247   /* FIXME: Raise an error if STRING is not a scalar value
 248      sequence.  */
 249   return code_convert_string (string, Qutf_8_unix, Qt, true, true, true);
 250 }
 251
 252 static _Noreturn void
 253 json_out_of_memory (void)
 254 {
 255   xsignal0 (Qjson_out_of_memory);
 256 }
 257
 258 /* Signal a Lisp error corresponding to the JSON ERROR.  */
 259
 260 static _Noreturn void
 261 json_parse_error (const json_error_t *error)
 262 {
 263   Lisp_Object symbol;
 264 #if JSON_HAS_ERROR_CODE
 265   switch (json_error_code (error))
 266     {
 267     case json_error_premature_end_of_input:
 268       symbol = Qjson_end_of_file;
 269       break;
 270     case json_error_end_of_input_expected:
 271       symbol = Qjson_trailing_content;
 272       break;
 273     default:
 274       symbol = Qjson_parse_error;
 275       break;
 276     }
 277 #else
 278   if (json_has_suffix (error->text, "expected near end of file"))
 279     symbol = Qjson_end_of_file;
 280   else if (json_has_prefix (error->text, "end of file expected"))
 281     symbol = Qjson_trailing_content;
 282   else
 283     symbol = Qjson_parse_error;
 284 #endif
 285   xsignal (symbol,
 286            list5 (json_build_string (error->text),
 287                   json_build_string (error->source), make_natnum (error->line),
 288                   make_natnum (error->column), make_natnum (error->position)));
 289 }
 290
 291 static void
 292 json_release_object (void *object)
 293 {
 294   json_decref (object);
 295 }
 296
 297 /* Signal an error if OBJECT is not a string, or if OBJECT contains
 298    embedded null characters.  */
 299
 300 static void
 301 check_string_without_embedded_nulls (Lisp_Object object)
 302 {
 303   CHECK_STRING (object);
 304   CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL,
 305               Qstring_without_embedded_nulls_p, object);
 306 }
 307
 308 /* Signal an error of type `json-out-of-memory' if OBJECT is
 309    NULL.  */
 310
 311 static json_t *
 312 json_check (json_t *object)
 313 {
 314   if (object == NULL)
 315     json_out_of_memory ();
 316   return object;
 317 }
 318
 319 static json_t *lisp_to_json (Lisp_Object);
 320
 321 /* Convert a Lisp object to a toplevel JSON object (array or object).
 322    This returns Lisp_Object so we can use unbind_to.  The return value
 323    is always nil.  */
 324
 325 static _GL_ARG_NONNULL ((2)) Lisp_Object
 326 lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json)
 327 {
 328   if (VECTORP (lisp))
 329     {
 330       ptrdiff_t size = ASIZE (lisp);
 331       *json = json_check (json_array ());
 332       ptrdiff_t count = SPECPDL_INDEX ();
 333       record_unwind_protect_ptr (json_release_object, json);
 334       for (ptrdiff_t i = 0; i < size; ++i)
 335         {
 336           int status
 337             = json_array_append_new (*json, lisp_to_json (AREF (lisp, i)));
 338           if (status == -1)
 339             json_out_of_memory ();
 340         }
 341       eassert (json_array_size (*json) == size);
 342       clear_unwind_protect (count);
 343       return unbind_to (count, Qnil);
 344     }
 345   else if (HASH_TABLE_P (lisp))
 346     {
 347       struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
 348       *json = json_check (json_object ());
 349       ptrdiff_t count = SPECPDL_INDEX ();
 350       record_unwind_protect_ptr (json_release_object, *json);
 351       for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
 352         if (!NILP (HASH_HASH (h, i)))
 353           {
 354             Lisp_Object key = json_encode (HASH_KEY (h, i));
 355             /* We can't specify the length, so the string must be
 356                null-terminated.  */
 357             check_string_without_embedded_nulls (key);
 358             const char *key_str = SSDATA (key);
 359             /* Reject duplicate keys.  These are possible if the hash
 360                table test is not `equal'.  */
 361             if (json_object_get (*json, key_str) != NULL)
 362               wrong_type_argument (Qjson_value_p, lisp);
 363             int status = json_object_set_new (*json, key_str,
 364                                               lisp_to_json (HASH_VALUE (h, i)));
 365             if (status == -1)
 366               /* FIXME: A failure here might also indicate that the
 367                  key is not a valid Unicode string.  */
 368               json_out_of_memory ();
 369           }
 370       clear_unwind_protect (count);
 371       return unbind_to (count, Qnil);
 372     }
 373   else if (NILP (lisp))
 374     {
 375       *json = json_check (json_object ());
 376       return Qnil;
 377     }
 378   else if (CONSP (lisp))
 379     {
 380       Lisp_Object tail = lisp;
 381       *json = json_check (json_object ());
 382       ptrdiff_t count = SPECPDL_INDEX ();
 383       record_unwind_protect_ptr (json_release_object, *json);
 384       FOR_EACH_TAIL (tail)
 385         {
 386           Lisp_Object pair = XCAR (tail);
 387           CHECK_CONS (pair);
 388           Lisp_Object key_symbol = XCAR (pair);
 389           Lisp_Object value = XCDR (pair);
 390           CHECK_SYMBOL (key_symbol);
 391           Lisp_Object key = SYMBOL_NAME (key_symbol);
 392           /* We can't specify the length, so the string must be
 393              null-terminated.  */
 394           check_string_without_embedded_nulls (key);
 395           const char *key_str = SSDATA (key);
 396           /* Only add element if key is not already present.  */
 397           if (json_object_get (*json, key_str) == NULL)
 398             {
 399               int status
 400                 = json_object_set_new (*json, key_str, lisp_to_json (value));
 401               if (status == -1)
 402                 json_out_of_memory ();
 403             }
 404         }
 405       CHECK_LIST_END (tail, lisp);
 406       clear_unwind_protect (count);
 407       return unbind_to (count, Qnil);
 408     }
 409   wrong_type_argument (Qjson_value_p, lisp);
 410 }
 411
 412 /* Convert LISP to a toplevel JSON object (array or object).  Signal
 413    an error of type `wrong-type-argument' if LISP is not a vector,
 414    hashtable, or alist.  */
 415
 416 static json_t *
 417 lisp_to_json_toplevel (Lisp_Object lisp)
 418 {
 419   if (++lisp_eval_depth > max_lisp_eval_depth)
 420     xsignal0 (Qjson_object_too_deep);
 421   json_t *json;
 422   lisp_to_json_toplevel_1 (lisp, &json);
 423   --lisp_eval_depth;
 424   return json;
 425 }
 426
 427 /* Convert LISP to any JSON object.  Signal an error of type
 428    `wrong-type-argument' if the type of LISP can't be converted to a
 429    JSON object.  */
 430
 431 static json_t *
 432 lisp_to_json (Lisp_Object lisp)
 433 {
 434   if (EQ (lisp, QCnull))
 435     return json_check (json_null ());
 436   else if (EQ (lisp, QCfalse))
 437     return json_check (json_false ());
 438   else if (EQ (lisp, Qt))
 439     return json_check (json_true ());
 440   else if (INTEGERP (lisp))
 441     {
 442       CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp);
 443       return json_check (json_integer (XINT (lisp)));
 444     }
 445   else if (FLOATP (lisp))
 446     return json_check (json_real (XFLOAT_DATA (lisp)));
 447   else if (STRINGP (lisp))
 448     {
 449       Lisp_Object encoded = json_encode (lisp);
 450       /* FIXME: We might throw an out-of-memory error here if the
 451          string is not valid Unicode.  */
 452       return json_check (json_stringn (SSDATA (encoded), SBYTES (encoded)));
 453     }
 454
 455   /* LISP now must be a vector, hashtable, or alist.  */
 456   return lisp_to_json_toplevel (lisp);
 457 }
 458
 459 DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL,
 460        doc: /* Return the JSON representation of OBJECT as a string.
 461 OBJECT must be a vector, hashtable, or alist, and its elements can
 462 recursively contain `:null', `:false', t, numbers, strings, or other
 463 vectors hashtables, and alist.  `:null', `:false', and t will be
 464 converted to JSON null, false, and true values, respectively.  Vectors
 465 will be converted to JSON arrays, and hashtables and alists to JSON
 466 objects.  Hashtable keys must be strings without embedded null
 467 characters and must be unique within each object.  Alist keys must be
 468 symbols; if a key is duplicate, the first instance is used.  */)
 469   (Lisp_Object object)
 470 {
 471   ptrdiff_t count = SPECPDL_INDEX ();
 472
 473 #ifdef WINDOWSNT
 474   if (!json_initialized)
 475     {
 476       Lisp_Object status;
 477       json_initialized = init_json_functions ();
 478       status = json_initialized ? Qt : Qnil;
 479       Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
 480     }
 481   if (!json_initialized)
 482     {
 483       message1 ("jansson library not found");
 484       return Qnil;
 485     }
 486 #endif
 487
 488   json_t *json = lisp_to_json_toplevel (object);
 489   record_unwind_protect_ptr (json_release_object, json);
 490
 491   /* If desired, we might want to add the following flags:
 492      JSON_DECODE_ANY, JSON_ALLOW_NUL.  */
 493   char *string = json_dumps (json, JSON_COMPACT);
 494   if (string == NULL)
 495     json_out_of_memory ();
 496   record_unwind_protect_ptr (free, string);
 497
 498   return unbind_to (count, json_build_string (string));
 499 }
 500
 501 struct json_buffer_and_size
 502 {
 503   const char *buffer;
 504   ptrdiff_t size;
 505 };
 506
 507 static Lisp_Object
 508 json_insert (void *data)
 509 {
 510   struct json_buffer_and_size *buffer_and_size = data;
 511   /* FIXME: This should be possible without creating an intermediate
 512      string object.  */
 513   Lisp_Object string
 514     = json_make_string (buffer_and_size->buffer, buffer_and_size->size);
 515   insert1 (string);
 516   return Qnil;
 517 }
 518
 519 struct json_insert_data
 520 {
 521   /* nil if json_insert succeeded, otherwise the symbol
 522      Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA).  */
 523   Lisp_Object error;
 524 };
 525
 526 /* Callback for json_dump_callback that inserts the UTF-8 string in
 527    [BUFFER, BUFFER + SIZE) into the current buffer.
 528    If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string,
 529    an unspecified string is inserted into the buffer.  DATA must point
 530    to a structure of type json_insert_data.  This function may not
 531    exit nonlocally.  It catches all nonlocal exits and stores them in
 532    data->error for reraising.  */
 533
 534 static int
 535 json_insert_callback (const char *buffer, size_t size, void *data)
 536 {
 537   struct json_insert_data *d = data;
 538   struct json_buffer_and_size buffer_and_size
 539     = {.buffer = buffer, .size = size};
 540   d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity);
 541   return NILP (d->error) ? 0 : -1;
 542 }
 543
 544 DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL,
 545        doc: /* Insert the JSON representation of OBJECT before point.
 546 This is the same as (insert (json-serialize OBJECT)), but potentially
 547 faster.  See the function `json-serialize' for allowed values of
 548 OBJECT.  */)
 549   (Lisp_Object object)
 550 {
 551   ptrdiff_t count = SPECPDL_INDEX ();
 552
 553 #ifdef WINDOWSNT
 554   if (!json_initialized)
 555     {
 556       Lisp_Object status;
 557       json_initialized = init_json_functions ();
 558       status = json_initialized ? Qt : Qnil;
 559       Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
 560     }
 561   if (!json_initialized)
 562     {
 563       message1 ("jansson library not found");
 564       return Qnil;
 565     }
 566 #endif
 567
 568   json_t *json = lisp_to_json (object);
 569   record_unwind_protect_ptr (json_release_object, json);
 570
 571   struct json_insert_data data;
 572   /* If desired, we might want to add the following flags:
 573      JSON_DECODE_ANY, JSON_ALLOW_NUL.  */
 574   int status
 575     = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT);
 576   if (status == -1)
 577     {
 578       if (CONSP (data.error))
 579         xsignal (XCAR (data.error), XCDR (data.error));
 580       else
 581         json_out_of_memory ();
 582     }
 583
 584   return unbind_to (count, Qnil);
 585 }
 586
 587 enum json_object_type {
 588   json_object_hashtable,
 589   json_object_alist,
 590 };
 591
 592 /* Convert a JSON object to a Lisp object.  */
 593
 594 static _GL_ARG_NONNULL ((1)) Lisp_Object
 595 json_to_lisp (json_t *json, enum json_object_type object_type)
 596 {
 597   switch (json_typeof (json))
 598     {
 599     case JSON_NULL:
 600       return QCnull;
 601     case JSON_FALSE:
 602       return QCfalse;
 603     case JSON_TRUE:
 604       return Qt;
 605     case JSON_INTEGER:
 606       /* Return an integer if possible, a floating-point number
 607          otherwise.  This loses precision for integers with large
 608          magnitude; however, such integers tend to be nonportable
 609          anyway because many JSON implementations use only 64-bit
 610          floating-point numbers with 53 mantissa bits.  See
 611          https://tools.ietf.org/html/rfc7159#section-6 for some
 612          discussion.  */
 613       return make_fixnum_or_float (json_integer_value (json));
 614     case JSON_REAL:
 615       return make_float (json_real_value (json));
 616     case JSON_STRING:
 617       return json_make_string (json_string_value (json),
 618                                json_string_length (json));
 619     case JSON_ARRAY:
 620       {
 621         if (++lisp_eval_depth > max_lisp_eval_depth)
 622           xsignal0 (Qjson_object_too_deep);
 623         size_t size = json_array_size (json);
 624         if (FIXNUM_OVERFLOW_P (size))
 625           xsignal0 (Qoverflow_error);
 626         Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound);
 627         for (ptrdiff_t i = 0; i < size; ++i)
 628           ASET (result, i,
 629                 json_to_lisp (json_array_get (json, i), object_type));
 630         --lisp_eval_depth;
 631         return result;
 632       }
 633     case JSON_OBJECT:
 634       {
 635         if (++lisp_eval_depth > max_lisp_eval_depth)
 636           xsignal0 (Qjson_object_too_deep);
 637         Lisp_Object result;
 638         switch (object_type)
 639           {
 640           case json_object_hashtable:
 641             {
 642               size_t size = json_object_size (json);
 643               if (FIXNUM_OVERFLOW_P (size))
 644                 xsignal0 (Qoverflow_error);
 645               result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize,
 646                               make_natnum (size));
 647               struct Lisp_Hash_Table *h = XHASH_TABLE (result);
 648               const char *key_str;
 649               json_t *value;
 650               json_object_foreach (json, key_str, value)
 651                 {
 652                   Lisp_Object key = json_build_string (key_str);
 653                   EMACS_UINT hash;
 654                   ptrdiff_t i = hash_lookup (h, key, &hash);
 655                   /* Keys in JSON objects are unique, so the key can't
 656                      be present yet.  */
 657                   eassert (i < 0);
 658                   hash_put (h, key, json_to_lisp (value, object_type), hash);
 659                 }
 660               break;
 661             }
 662           case json_object_alist:
 663             {
 664               result = Qnil;
 665               const char *key_str;
 666               json_t *value;
 667               json_object_foreach (json, key_str, value)
 668                 {
 669                   Lisp_Object key = Fintern (json_build_string (key_str), Qnil);
 670                   result
 671                     = Fcons (Fcons (key, json_to_lisp (value, object_type)),
 672                              result);
 673                 }
 674               result = Fnreverse (result);
 675               break;
 676             }
 677           default:
 678             /* Can't get here.  */
 679             emacs_abort ();
 680           }
 681         --lisp_eval_depth;
 682         return result;
 683       }
 684     }
 685   /* Can't get here.  */
 686   emacs_abort ();
 687 }
 688
 689 static enum json_object_type
 690 json_parse_object_type (ptrdiff_t nargs, Lisp_Object *args)
 691 {
 692   switch (nargs)
 693     {
 694     case 0:
 695       return json_object_hashtable;
 696     case 2:
 697       {
 698         Lisp_Object key = args[0];
 699         Lisp_Object value = args[1];
 700         if (!EQ (key, QCobject_type))
 701           wrong_choice (list1 (QCobject_type), key);
 702         if (EQ (value, Qhash_table))
 703           return json_object_hashtable;
 704         else if (EQ (value, Qalist))
 705           return json_object_alist;
 706         else
 707           wrong_choice (list2 (Qhash_table, Qalist), value);
 708       }
 709     default:
 710       wrong_type_argument (Qplistp, Flist (nargs, args));
 711     }
 712 }
 713
 714 DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY,
 715        NULL,
 716        doc: /* Parse the JSON STRING into a Lisp object.
 717 This is essentially the reverse operation of `json-serialize', which
 718 see.  The returned object will be a vector, hashtable, or alist.  Its
 719 elements will be `:null', `:false', t, numbers, strings, or further
 720 vectors, hashtables, and alists.  If there are duplicate keys in an
 721 object, all but the last one are ignored.  If STRING doesn't contain a
 722 valid JSON object, an error of type `json-parse-error' is signaled.
 723 The keyword argument `:object-type' specifies which Lisp type is used
 724 to represent objects; it can be `hash-table' or `alist'.
 725 usage: (string &key (OBJECT-TYPE \\='hash-table)) */)
 726   (ptrdiff_t nargs, Lisp_Object *args)
 727 {
 728   ptrdiff_t count = SPECPDL_INDEX ();
 729
 730 #ifdef WINDOWSNT
 731   if (!json_initialized)
 732     {
 733       Lisp_Object status;
 734       json_initialized = init_json_functions ();
 735       status = json_initialized ? Qt : Qnil;
 736       Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
 737     }
 738   if (!json_initialized)
 739     {
 740       message1 ("jansson library not found");
 741       return Qnil;
 742     }
 743 #endif
 744
 745   Lisp_Object string = args[0];
 746   Lisp_Object encoded = json_encode (string);
 747   check_string_without_embedded_nulls (encoded);
 748   enum json_object_type object_type
 749     = json_parse_object_type (nargs - 1, args + 1);
 750
 751   json_error_t error;
 752   json_t *object = json_loads (SSDATA (encoded), 0, &error);
 753   if (object == NULL)
 754     json_parse_error (&error);
 755
 756   /* Avoid leaking the object in case of further errors.  */
 757   if (object != NULL)
 758     record_unwind_protect_ptr (json_release_object, object);
 759
 760   return unbind_to (count, json_to_lisp (object, object_type));
 761 }
 762
 763 struct json_read_buffer_data
 764 {
 765   /* Byte position of position to read the next chunk from.  */
 766   ptrdiff_t point;
 767 };
 768
 769 /* Callback for json_load_callback that reads from the current buffer.
 770    DATA must point to a structure of type json_read_buffer_data.
 771    data->point must point to the byte position to read from; after
 772    reading, data->point is advanced accordingly.  The buffer point
 773    itself is ignored.  This function may not exit nonlocally.  */
 774
 775 static size_t
 776 json_read_buffer_callback (void *buffer, size_t buflen, void *data)
 777 {
 778   struct json_read_buffer_data *d = data;
 779
 780   /* First, parse from point to the gap or the end of the accessible
 781      portion, whatever is closer.  */
 782   ptrdiff_t point = d->point;
 783   ptrdiff_t end = BUFFER_CEILING_OF (point) + 1;
 784   ptrdiff_t count = end - point;
 785   if (buflen < count)
 786     count = buflen;
 787   memcpy (buffer, BYTE_POS_ADDR (point), count);
 788   d->point += count;
 789   return count;
 790 }
 791
 792 DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
 793        0, MANY, NULL,
 794        doc: /* Read JSON object from current buffer starting at point.
 795 This is similar to `json-parse-string', which see.  Move point after
 796 the end of the object if parsing was successful.  On error, point is
 797 not moved.
 798 usage: (&key (OBJECT-TYPE \\='hash-table))  */)
 799   (ptrdiff_t nargs, Lisp_Object *args)
 800 {
 801   ptrdiff_t count = SPECPDL_INDEX ();
 802
 803 #ifdef WINDOWSNT
 804   if (!json_initialized)
 805     {
 806       Lisp_Object status;
 807       json_initialized = init_json_functions ();
 808       status = json_initialized ? Qt : Qnil;
 809       Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
 810     }
 811   if (!json_initialized)
 812     {
 813       message1 ("jansson library not found");
 814       return Qnil;
 815     }
 816 #endif
 817
 818   enum json_object_type object_type = json_parse_object_type (nargs, args);
 819
 820   ptrdiff_t point = PT_BYTE;
 821   struct json_read_buffer_data data = {.point = point};
 822   json_error_t error;
 823   json_t *object = json_load_callback (json_read_buffer_callback, &data,
 824                                        JSON_DISABLE_EOF_CHECK, &error);
 825
 826   if (object == NULL)
 827     json_parse_error (&error);
 828
 829   /* Avoid leaking the object in case of further errors.  */
 830   record_unwind_protect_ptr (json_release_object, object);
 831
 832   /* Convert and then move point only if everything succeeded.  */
 833   Lisp_Object lisp = json_to_lisp (object, object_type);
 834
 835   /* Adjust point by how much we just read.  */
 836   point += error.position;
 837   SET_PT_BOTH (BYTE_TO_CHAR (point), point);
 838
 839   return unbind_to (count, lisp);
 840 }
 841
 842 /* Simplified version of 'define-error' that works with pure
 843    objects.  */
 844
 845 static void
 846 define_error (Lisp_Object name, const char *message, Lisp_Object parent)
 847 {
 848   eassert (SYMBOLP (name));
 849   eassert (SYMBOLP (parent));
 850   Lisp_Object parent_conditions = Fget (parent, Qerror_conditions);
 851   eassert (CONSP (parent_conditions));
 852   eassert (!NILP (Fmemq (parent, parent_conditions)));
 853   eassert (NILP (Fmemq (name, parent_conditions)));
 854   Fput (name, Qerror_conditions, pure_cons (name, parent_conditions));
 855   Fput (name, Qerror_message, build_pure_c_string (message));
 856 }
 857
 858 void
 859 syms_of_json (void)
 860 {
 861   DEFSYM (QCnull, ":null");
 862   DEFSYM (QCfalse, ":false");
 863
 864   DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p");
 865   DEFSYM (Qjson_value_p, "json-value-p");
 866
 867   DEFSYM (Qutf_8_unix, "utf-8-unix");
 868
 869   DEFSYM (Qjson_error, "json-error");
 870   DEFSYM (Qjson_out_of_memory, "json-out-of-memory");
 871   DEFSYM (Qjson_parse_error, "json-parse-error");
 872   DEFSYM (Qjson_end_of_file, "json-end-of-file");
 873   DEFSYM (Qjson_trailing_content, "json-trailing-content");
 874   DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
 875   define_error (Qjson_error, "generic JSON error", Qerror);
 876   define_error (Qjson_out_of_memory,
 877                 "not enough memory for creating JSON object", Qjson_error);
 878   define_error (Qjson_parse_error, "could not parse JSON stream",
 879                 Qjson_error);
 880   define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error);
 881   define_error (Qjson_trailing_content, "trailing content after JSON stream",
 882                 Qjson_parse_error);
 883   define_error (Qjson_object_too_deep,
 884                 "object cyclic or Lisp evaluation too deep", Qjson_error);
 885
 886   DEFSYM (Qpure, "pure");
 887   DEFSYM (Qside_effect_free, "side-effect-free");
 888
 889   DEFSYM (Qjson_serialize, "json-serialize");
 890   DEFSYM (Qjson_parse_string, "json-parse-string");
 891   Fput (Qjson_serialize, Qpure, Qt);
 892   Fput (Qjson_serialize, Qside_effect_free, Qt);
 893   Fput (Qjson_parse_string, Qpure, Qt);
 894   Fput (Qjson_parse_string, Qside_effect_free, Qt);
 895
 896   DEFSYM (QCobject_type, ":object-type");
 897   DEFSYM (Qalist, "alist");
 898
 899   defsubr (&Sjson_serialize);
 900   defsubr (&Sjson_insert);
 901   defsubr (&Sjson_parse_string);
 902   defsubr (&Sjson_parse_buffer);
 903 }