src/json.c

   1 /* JSON parsing and serialization.
   2
   3 Copyright (C) 2017-2018 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 /* If STRING is not a valid UTF-8 string, signal an error of type
 320    `wrong-type-argument'.  STRING must be a unibyte string.  */
 321
 322 static void
 323 json_check_utf8 (Lisp_Object string)
 324 {
 325   CHECK_TYPE (utf8_string_p (string), Qutf_8_string_p, string);
 326 }
 327
 328 static json_t *lisp_to_json (Lisp_Object);
 329
 330 /* Convert a Lisp object to a toplevel JSON object (array or object).
 331    This returns Lisp_Object so we can use unbind_to.  The return value
 332    is always nil.  */
 333
 334 static _GL_ARG_NONNULL ((2)) Lisp_Object
 335 lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json)
 336 {
 337   if (VECTORP (lisp))
 338     {
 339       ptrdiff_t size = ASIZE (lisp);
 340       *json = json_check (json_array ());
 341       ptrdiff_t count = SPECPDL_INDEX ();
 342       record_unwind_protect_ptr (json_release_object, json);
 343       for (ptrdiff_t i = 0; i < size; ++i)
 344         {
 345           int status
 346             = json_array_append_new (*json, lisp_to_json (AREF (lisp, i)));
 347           if (status == -1)
 348             json_out_of_memory ();
 349         }
 350       eassert (json_array_size (*json) == size);
 351       clear_unwind_protect (count);
 352       return unbind_to (count, Qnil);
 353     }
 354   else if (HASH_TABLE_P (lisp))
 355     {
 356       struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
 357       *json = json_check (json_object ());
 358       ptrdiff_t count = SPECPDL_INDEX ();
 359       record_unwind_protect_ptr (json_release_object, *json);
 360       for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
 361         if (!NILP (HASH_HASH (h, i)))
 362           {
 363             Lisp_Object key = json_encode (HASH_KEY (h, i));
 364             /* We can't specify the length, so the string must be
 365                null-terminated.  */
 366             check_string_without_embedded_nulls (key);
 367             const char *key_str = SSDATA (key);
 368             /* Reject duplicate keys.  These are possible if the hash
 369                table test is not `equal'.  */
 370             if (json_object_get (*json, key_str) != NULL)
 371               wrong_type_argument (Qjson_value_p, lisp);
 372             int status = json_object_set_new (*json, key_str,
 373                                               lisp_to_json (HASH_VALUE (h, i)));
 374             if (status == -1)
 375               {
 376                 /* A failure can be caused either by an invalid key or
 377                    by low memory.  */
 378                 json_check_utf8 (key);
 379                 json_out_of_memory ();
 380               }
 381           }
 382       clear_unwind_protect (count);
 383       return unbind_to (count, Qnil);
 384     }
 385   else if (NILP (lisp))
 386     {
 387       *json = json_check (json_object ());
 388       return Qnil;
 389     }
 390   else if (CONSP (lisp))
 391     {
 392       Lisp_Object tail = lisp;
 393       *json = json_check (json_object ());
 394       ptrdiff_t count = SPECPDL_INDEX ();
 395       record_unwind_protect_ptr (json_release_object, *json);
 396       FOR_EACH_TAIL (tail)
 397         {
 398           Lisp_Object pair = XCAR (tail);
 399           CHECK_CONS (pair);
 400           Lisp_Object key_symbol = XCAR (pair);
 401           Lisp_Object value = XCDR (pair);
 402           CHECK_SYMBOL (key_symbol);
 403           Lisp_Object key = SYMBOL_NAME (key_symbol);
 404           /* We can't specify the length, so the string must be
 405              null-terminated.  */
 406           check_string_without_embedded_nulls (key);
 407           const char *key_str = SSDATA (key);
 408           /* Only add element if key is not already present.  */
 409           if (json_object_get (*json, key_str) == NULL)
 410             {
 411               int status
 412                 = json_object_set_new (*json, key_str, lisp_to_json (value));
 413               if (status == -1)
 414                 json_out_of_memory ();
 415             }
 416         }
 417       CHECK_LIST_END (tail, lisp);
 418       clear_unwind_protect (count);
 419       return unbind_to (count, Qnil);
 420     }
 421   wrong_type_argument (Qjson_value_p, lisp);
 422 }
 423
 424 /* Convert LISP to a toplevel JSON object (array or object).  Signal
 425    an error of type `wrong-type-argument' if LISP is not a vector,
 426    hashtable, or alist.  */
 427
 428 static json_t *
 429 lisp_to_json_toplevel (Lisp_Object lisp)
 430 {
 431   if (++lisp_eval_depth > max_lisp_eval_depth)
 432     xsignal0 (Qjson_object_too_deep);
 433   json_t *json;
 434   lisp_to_json_toplevel_1 (lisp, &json);
 435   --lisp_eval_depth;
 436   return json;
 437 }
 438
 439 /* Convert LISP to any JSON object.  Signal an error of type
 440    `wrong-type-argument' if the type of LISP can't be converted to a
 441    JSON object.  */
 442
 443 static json_t *
 444 lisp_to_json (Lisp_Object lisp)
 445 {
 446   if (EQ (lisp, QCnull))
 447     return json_check (json_null ());
 448   else if (EQ (lisp, QCfalse))
 449     return json_check (json_false ());
 450   else if (EQ (lisp, Qt))
 451     return json_check (json_true ());
 452   else if (INTEGERP (lisp))
 453     {
 454       CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp);
 455       return json_check (json_integer (XINT (lisp)));
 456     }
 457   else if (FLOATP (lisp))
 458     return json_check (json_real (XFLOAT_DATA (lisp)));
 459   else if (STRINGP (lisp))
 460     {
 461       Lisp_Object encoded = json_encode (lisp);
 462       json_t *json = json_stringn (SSDATA (encoded), SBYTES (encoded));
 463       if (json == NULL)
 464         {
 465           /* A failure can be caused either by an invalid string or by
 466              low memory.  */
 467           json_check_utf8 (encoded);
 468           json_out_of_memory ();
 469         }
 470       return json;
 471     }
 472
 473   /* LISP now must be a vector, hashtable, or alist.  */
 474   return lisp_to_json_toplevel (lisp);
 475 }
 476
 477 DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL,
 478        doc: /* Return the JSON representation of OBJECT as a string.
 479 OBJECT must be a vector, hashtable, or alist, and its elements can
 480 recursively contain `:null', `:false', t, numbers, strings, or other
 481 vectors hashtables, and alist.  `:null', `:false', and t will be
 482 converted to JSON null, false, and true values, respectively.  Vectors
 483 will be converted to JSON arrays, and hashtables and alists to JSON
 484 objects.  Hashtable keys must be strings without embedded null
 485 characters and must be unique within each object.  Alist keys must be
 486 symbols; if a key is duplicate, the first instance is used.  */)
 487   (Lisp_Object object)
 488 {
 489   ptrdiff_t count = SPECPDL_INDEX ();
 490
 491 #ifdef WINDOWSNT
 492   if (!json_initialized)
 493     {
 494       Lisp_Object status;
 495       json_initialized = init_json_functions ();
 496       status = json_initialized ? Qt : Qnil;
 497       Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
 498     }
 499   if (!json_initialized)
 500     {
 501       message1 ("jansson library not found");
 502       return Qnil;
 503     }
 504 #endif
 505
 506   json_t *json = lisp_to_json_toplevel (object);
 507   record_unwind_protect_ptr (json_release_object, json);
 508
 509   /* If desired, we might want to add the following flags:
 510      JSON_DECODE_ANY, JSON_ALLOW_NUL.  */
 511   char *string = json_dumps (json, JSON_COMPACT);
 512   if (string == NULL)
 513     json_out_of_memory ();
 514   record_unwind_protect_ptr (free, string);
 515
 516   return unbind_to (count, json_build_string (string));
 517 }
 518
 519 struct json_buffer_and_size
 520 {
 521   const char *buffer;
 522   ptrdiff_t size;
 523 };
 524
 525 static Lisp_Object
 526 json_insert (void *data)
 527 {
 528   struct json_buffer_and_size *buffer_and_size = data;
 529   /* FIXME: This should be possible without creating an intermediate
 530      string object.  */
 531   Lisp_Object string
 532     = json_make_string (buffer_and_size->buffer, buffer_and_size->size);
 533   insert1 (string);
 534   return Qnil;
 535 }
 536
 537 struct json_insert_data
 538 {
 539   /* nil if json_insert succeeded, otherwise the symbol
 540      Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA).  */
 541   Lisp_Object error;
 542 };
 543
 544 /* Callback for json_dump_callback that inserts the UTF-8 string in
 545    [BUFFER, BUFFER + SIZE) into the current buffer.
 546    If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string,
 547    an unspecified string is inserted into the buffer.  DATA must point
 548    to a structure of type json_insert_data.  This function may not
 549    exit nonlocally.  It catches all nonlocal exits and stores them in
 550    data->error for reraising.  */
 551
 552 static int
 553 json_insert_callback (const char *buffer, size_t size, void *data)
 554 {
 555   struct json_insert_data *d = data;
 556   struct json_buffer_and_size buffer_and_size
 557     = {.buffer = buffer, .size = size};
 558   d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity);
 559   return NILP (d->error) ? 0 : -1;
 560 }
 561
 562 DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL,
 563        doc: /* Insert the JSON representation of OBJECT before point.
 564 This is the same as (insert (json-serialize OBJECT)), but potentially
 565 faster.  See the function `json-serialize' for allowed values of
 566 OBJECT.  */)
 567   (Lisp_Object object)
 568 {
 569   ptrdiff_t count = SPECPDL_INDEX ();
 570
 571 #ifdef WINDOWSNT
 572   if (!json_initialized)
 573     {
 574       Lisp_Object status;
 575       json_initialized = init_json_functions ();
 576       status = json_initialized ? Qt : Qnil;
 577       Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
 578     }
 579   if (!json_initialized)
 580     {
 581       message1 ("jansson library not found");
 582       return Qnil;
 583     }
 584 #endif
 585
 586   json_t *json = lisp_to_json (object);
 587   record_unwind_protect_ptr (json_release_object, json);
 588
 589   struct json_insert_data data;
 590   /* If desired, we might want to add the following flags:
 591      JSON_DECODE_ANY, JSON_ALLOW_NUL.  */
 592   int status
 593     = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT);
 594   if (status == -1)
 595     {
 596       if (CONSP (data.error))
 597         xsignal (XCAR (data.error), XCDR (data.error));
 598       else
 599         json_out_of_memory ();
 600     }
 601
 602   return unbind_to (count, Qnil);
 603 }
 604
 605 enum json_object_type {
 606   json_object_hashtable,
 607   json_object_alist,
 608 };
 609
 610 /* Convert a JSON object to a Lisp object.  */
 611
 612 static _GL_ARG_NONNULL ((1)) Lisp_Object
 613 json_to_lisp (json_t *json, enum json_object_type object_type)
 614 {
 615   switch (json_typeof (json))
 616     {
 617     case JSON_NULL:
 618       return QCnull;
 619     case JSON_FALSE:
 620       return QCfalse;
 621     case JSON_TRUE:
 622       return Qt;
 623     case JSON_INTEGER:
 624       /* Return an integer if possible, a floating-point number
 625          otherwise.  This loses precision for integers with large
 626          magnitude; however, such integers tend to be nonportable
 627          anyway because many JSON implementations use only 64-bit
 628          floating-point numbers with 53 mantissa bits.  See
 629          https://tools.ietf.org/html/rfc7159#section-6 for some
 630          discussion.  */
 631       return make_fixnum_or_float (json_integer_value (json));
 632     case JSON_REAL:
 633       return make_float (json_real_value (json));
 634     case JSON_STRING:
 635       return json_make_string (json_string_value (json),
 636                                json_string_length (json));
 637     case JSON_ARRAY:
 638       {
 639         if (++lisp_eval_depth > max_lisp_eval_depth)
 640           xsignal0 (Qjson_object_too_deep);
 641         size_t size = json_array_size (json);
 642         if (FIXNUM_OVERFLOW_P (size))
 643           xsignal0 (Qoverflow_error);
 644         Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound);
 645         for (ptrdiff_t i = 0; i < size; ++i)
 646           ASET (result, i,
 647                 json_to_lisp (json_array_get (json, i), object_type));
 648         --lisp_eval_depth;
 649         return result;
 650       }
 651     case JSON_OBJECT:
 652       {
 653         if (++lisp_eval_depth > max_lisp_eval_depth)
 654           xsignal0 (Qjson_object_too_deep);
 655         Lisp_Object result;
 656         switch (object_type)
 657           {
 658           case json_object_hashtable:
 659             {
 660               size_t size = json_object_size (json);
 661               if (FIXNUM_OVERFLOW_P (size))
 662                 xsignal0 (Qoverflow_error);
 663               result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize,
 664                               make_natnum (size));
 665               struct Lisp_Hash_Table *h = XHASH_TABLE (result);
 666               const char *key_str;
 667               json_t *value;
 668               json_object_foreach (json, key_str, value)
 669                 {
 670                   Lisp_Object key = json_build_string (key_str);
 671                   EMACS_UINT hash;
 672                   ptrdiff_t i = hash_lookup (h, key, &hash);
 673                   /* Keys in JSON objects are unique, so the key can't
 674                      be present yet.  */
 675                   eassert (i < 0);
 676                   hash_put (h, key, json_to_lisp (value, object_type), hash);
 677                 }
 678               break;
 679             }
 680           case json_object_alist:
 681             {
 682               result = Qnil;
 683               const char *key_str;
 684               json_t *value;
 685               json_object_foreach (json, key_str, value)
 686                 {
 687                   Lisp_Object key = Fintern (json_build_string (key_str), Qnil);
 688                   result
 689                     = Fcons (Fcons (key, json_to_lisp (value, object_type)),
 690                              result);
 691                 }
 692               result = Fnreverse (result);
 693               break;
 694             }
 695           default:
 696             /* Can't get here.  */
 697             emacs_abort ();
 698           }
 699         --lisp_eval_depth;
 700         return result;
 701       }
 702     }
 703   /* Can't get here.  */
 704   emacs_abort ();
 705 }
 706
 707 static enum json_object_type
 708 json_parse_object_type (ptrdiff_t nargs, Lisp_Object *args)
 709 {
 710   switch (nargs)
 711     {
 712     case 0:
 713       return json_object_hashtable;
 714     case 2:
 715       {
 716         Lisp_Object key = args[0];
 717         Lisp_Object value = args[1];
 718         if (!EQ (key, QCobject_type))
 719           wrong_choice (list1 (QCobject_type), key);
 720         if (EQ (value, Qhash_table))
 721           return json_object_hashtable;
 722         else if (EQ (value, Qalist))
 723           return json_object_alist;
 724         else
 725           wrong_choice (list2 (Qhash_table, Qalist), value);
 726       }
 727     default:
 728       wrong_type_argument (Qplistp, Flist (nargs, args));
 729     }
 730 }
 731
 732 DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY,
 733        NULL,
 734        doc: /* Parse the JSON STRING into a Lisp object.
 735 This is essentially the reverse operation of `json-serialize', which
 736 see.  The returned object will be a vector, hashtable, or alist.  Its
 737 elements will be `:null', `:false', t, numbers, strings, or further
 738 vectors, hashtables, and alists.  If there are duplicate keys in an
 739 object, all but the last one are ignored.  If STRING doesn't contain a
 740 valid JSON object, an error of type `json-parse-error' is signaled.
 741 The keyword argument `:object-type' specifies which Lisp type is used
 742 to represent objects; it can be `hash-table' or `alist'.
 743 usage: (string &key (OBJECT-TYPE \\='hash-table)) */)
 744   (ptrdiff_t nargs, Lisp_Object *args)
 745 {
 746   ptrdiff_t count = SPECPDL_INDEX ();
 747
 748 #ifdef WINDOWSNT
 749   if (!json_initialized)
 750     {
 751       Lisp_Object status;
 752       json_initialized = init_json_functions ();
 753       status = json_initialized ? Qt : Qnil;
 754       Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
 755     }
 756   if (!json_initialized)
 757     {
 758       message1 ("jansson library not found");
 759       return Qnil;
 760     }
 761 #endif
 762
 763   Lisp_Object string = args[0];
 764   Lisp_Object encoded = json_encode (string);
 765   check_string_without_embedded_nulls (encoded);
 766   enum json_object_type object_type
 767     = json_parse_object_type (nargs - 1, args + 1);
 768
 769   json_error_t error;
 770   json_t *object = json_loads (SSDATA (encoded), 0, &error);
 771   if (object == NULL)
 772     json_parse_error (&error);
 773
 774   /* Avoid leaking the object in case of further errors.  */
 775   if (object != NULL)
 776     record_unwind_protect_ptr (json_release_object, object);
 777
 778   return unbind_to (count, json_to_lisp (object, object_type));
 779 }
 780
 781 struct json_read_buffer_data
 782 {
 783   /* Byte position of position to read the next chunk from.  */
 784   ptrdiff_t point;
 785 };
 786
 787 /* Callback for json_load_callback that reads from the current buffer.
 788    DATA must point to a structure of type json_read_buffer_data.
 789    data->point must point to the byte position to read from; after
 790    reading, data->point is advanced accordingly.  The buffer point
 791    itself is ignored.  This function may not exit nonlocally.  */
 792
 793 static size_t
 794 json_read_buffer_callback (void *buffer, size_t buflen, void *data)
 795 {
 796   struct json_read_buffer_data *d = data;
 797
 798   /* First, parse from point to the gap or the end of the accessible
 799      portion, whatever is closer.  */
 800   ptrdiff_t point = d->point;
 801   ptrdiff_t end = BUFFER_CEILING_OF (point) + 1;
 802   ptrdiff_t count = end - point;
 803   if (buflen < count)
 804     count = buflen;
 805   memcpy (buffer, BYTE_POS_ADDR (point), count);
 806   d->point += count;
 807   return count;
 808 }
 809
 810 DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
 811        0, MANY, NULL,
 812        doc: /* Read JSON object from current buffer starting at point.
 813 This is similar to `json-parse-string', which see.  Move point after
 814 the end of the object if parsing was successful.  On error, point is
 815 not moved.
 816 usage: (&key (OBJECT-TYPE \\='hash-table))  */)
 817   (ptrdiff_t nargs, Lisp_Object *args)
 818 {
 819   ptrdiff_t count = SPECPDL_INDEX ();
 820
 821 #ifdef WINDOWSNT
 822   if (!json_initialized)
 823     {
 824       Lisp_Object status;
 825       json_initialized = init_json_functions ();
 826       status = json_initialized ? Qt : Qnil;
 827       Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
 828     }
 829   if (!json_initialized)
 830     {
 831       message1 ("jansson library not found");
 832       return Qnil;
 833     }
 834 #endif
 835
 836   enum json_object_type object_type = json_parse_object_type (nargs, args);
 837
 838   ptrdiff_t point = PT_BYTE;
 839   struct json_read_buffer_data data = {.point = point};
 840   json_error_t error;
 841   json_t *object = json_load_callback (json_read_buffer_callback, &data,
 842                                        JSON_DISABLE_EOF_CHECK, &error);
 843
 844   if (object == NULL)
 845     json_parse_error (&error);
 846
 847   /* Avoid leaking the object in case of further errors.  */
 848   record_unwind_protect_ptr (json_release_object, object);
 849
 850   /* Convert and then move point only if everything succeeded.  */
 851   Lisp_Object lisp = json_to_lisp (object, object_type);
 852
 853   /* Adjust point by how much we just read.  */
 854   point += error.position;
 855   SET_PT_BOTH (BYTE_TO_CHAR (point), point);
 856
 857   return unbind_to (count, lisp);
 858 }
 859
 860 /* Simplified version of 'define-error' that works with pure
 861    objects.  */
 862
 863 static void
 864 define_error (Lisp_Object name, const char *message, Lisp_Object parent)
 865 {
 866   eassert (SYMBOLP (name));
 867   eassert (SYMBOLP (parent));
 868   Lisp_Object parent_conditions = Fget (parent, Qerror_conditions);
 869   eassert (CONSP (parent_conditions));
 870   eassert (!NILP (Fmemq (parent, parent_conditions)));
 871   eassert (NILP (Fmemq (name, parent_conditions)));
 872   Fput (name, Qerror_conditions, pure_cons (name, parent_conditions));
 873   Fput (name, Qerror_message, build_pure_c_string (message));
 874 }
 875
 876 void
 877 syms_of_json (void)
 878 {
 879   DEFSYM (QCnull, ":null");
 880   DEFSYM (QCfalse, ":false");
 881
 882   DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p");
 883   DEFSYM (Qjson_value_p, "json-value-p");
 884   DEFSYM (Qutf_8_string_p, "utf-8-string-p");
 885
 886   DEFSYM (Qjson_error, "json-error");
 887   DEFSYM (Qjson_out_of_memory, "json-out-of-memory");
 888   DEFSYM (Qjson_parse_error, "json-parse-error");
 889   DEFSYM (Qjson_end_of_file, "json-end-of-file");
 890   DEFSYM (Qjson_trailing_content, "json-trailing-content");
 891   DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
 892   define_error (Qjson_error, "generic JSON error", Qerror);
 893   define_error (Qjson_out_of_memory,
 894                 "not enough memory for creating JSON object", Qjson_error);
 895   define_error (Qjson_parse_error, "could not parse JSON stream",
 896                 Qjson_error);
 897   define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error);
 898   define_error (Qjson_trailing_content, "trailing content after JSON stream",
 899                 Qjson_parse_error);
 900   define_error (Qjson_object_too_deep,
 901                 "object cyclic or Lisp evaluation too deep", Qjson_error);
 902
 903   DEFSYM (Qpure, "pure");
 904   DEFSYM (Qside_effect_free, "side-effect-free");
 905
 906   DEFSYM (Qjson_serialize, "json-serialize");
 907   DEFSYM (Qjson_parse_string, "json-parse-string");
 908   Fput (Qjson_serialize, Qpure, Qt);
 909   Fput (Qjson_serialize, Qside_effect_free, Qt);
 910   Fput (Qjson_parse_string, Qpure, Qt);
 911   Fput (Qjson_parse_string, Qside_effect_free, Qt);
 912
 913   DEFSYM (QCobject_type, ":object-type");
 914   DEFSYM (Qalist, "alist");
 915
 916   defsubr (&Sjson_serialize);
 917   defsubr (&Sjson_insert);
 918   defsubr (&Sjson_parse_string);
 919   defsubr (&Sjson_parse_buffer);
 920 }