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