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