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