1 /* JSON parsing and serialization.
2
3 Copyright (C) 2017-2021 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or (at
10 your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
19
20 #include <config.h>
21
22 #include <errno.h>
23 #include <stddef.h>
24 #include <stdint.h>
25 #include <stdlib.h>
26
27 #include <jansson.h>
28
29 #include "lisp.h"
30 #include "buffer.h"
31 #include "coding.h"
32
33 #define JSON_HAS_ERROR_CODE (JANSSON_VERSION_HEX >= 0x020B00)
34
35 #ifdef WINDOWSNT
36 # include <windows.h>
37 # include "w32common.h"
38 # include "w32.h"
39
40 DEF_DLL_FN (void, json_set_alloc_funcs,
41 (json_malloc_t malloc_fn, json_free_t free_fn));
42 DEF_DLL_FN (void, json_delete, (json_t *json));
43 DEF_DLL_FN (json_t *, json_array, (void));
44 DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value));
45 DEF_DLL_FN (size_t, json_array_size, (const json_t *array));
46 DEF_DLL_FN (json_t *, json_object, (void));
47 DEF_DLL_FN (int, json_object_set_new,
48 (json_t *object, const char *key, json_t *value));
49 DEF_DLL_FN (json_t *, json_null, (void));
50 DEF_DLL_FN (json_t *, json_true, (void));
51 DEF_DLL_FN (json_t *, json_false, (void));
52 DEF_DLL_FN (json_t *, json_integer, (json_int_t value));
53 DEF_DLL_FN (json_t *, json_real, (double value));
54 DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len));
55 DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags));
56 DEF_DLL_FN (int, json_dump_callback,
57 (const json_t *json, json_dump_callback_t callback, void *data,
58 size_t flags));
59 DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer));
60 DEF_DLL_FN (double, json_real_value, (const json_t *real));
61 DEF_DLL_FN (const char *, json_string_value, (const json_t *string));
62 DEF_DLL_FN (size_t, json_string_length, (const json_t *string));
63 DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index));
64 DEF_DLL_FN (json_t *, json_object_get, (const json_t *object, const char *key));
65 DEF_DLL_FN (size_t, json_object_size, (const json_t *object));
66 DEF_DLL_FN (const char *, json_object_iter_key, (void *iter));
67 DEF_DLL_FN (void *, json_object_iter, (json_t *object));
68 DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter));
69 DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key));
70 DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter));
71 DEF_DLL_FN (json_t *, json_loads,
72 (const char *input, size_t flags, json_error_t *error));
73 DEF_DLL_FN (json_t *, json_load_callback,
74 (json_load_callback_t callback, void *data, size_t flags,
75 json_error_t *error));
76
77 /* This is called by json_decref, which is an inline function. */
json_delete(json_t * json)78 void json_delete(json_t *json)
79 {
80 fn_json_delete (json);
81 }
82
83 static bool json_initialized;
84
85 static bool
init_json_functions(void)86 init_json_functions (void)
87 {
88 HMODULE library = w32_delayed_load (Qjson);
89
90 if (!library)
91 return false;
92
93 LOAD_DLL_FN (library, json_set_alloc_funcs);
94 LOAD_DLL_FN (library, json_delete);
95 LOAD_DLL_FN (library, json_array);
96 LOAD_DLL_FN (library, json_array_append_new);
97 LOAD_DLL_FN (library, json_array_size);
98 LOAD_DLL_FN (library, json_object);
99 LOAD_DLL_FN (library, json_object_set_new);
100 LOAD_DLL_FN (library, json_null);
101 LOAD_DLL_FN (library, json_true);
102 LOAD_DLL_FN (library, json_false);
103 LOAD_DLL_FN (library, json_integer);
104 LOAD_DLL_FN (library, json_real);
105 LOAD_DLL_FN (library, json_stringn);
106 LOAD_DLL_FN (library, json_dumps);
107 LOAD_DLL_FN (library, json_dump_callback);
108 LOAD_DLL_FN (library, json_integer_value);
109 LOAD_DLL_FN (library, json_real_value);
110 LOAD_DLL_FN (library, json_string_value);
111 LOAD_DLL_FN (library, json_string_length);
112 LOAD_DLL_FN (library, json_array_get);
113 LOAD_DLL_FN (library, json_object_get);
114 LOAD_DLL_FN (library, json_object_size);
115 LOAD_DLL_FN (library, json_object_iter_key);
116 LOAD_DLL_FN (library, json_object_iter);
117 LOAD_DLL_FN (library, json_object_iter_value);
118 LOAD_DLL_FN (library, json_object_key_to_iter);
119 LOAD_DLL_FN (library, json_object_iter_next);
120 LOAD_DLL_FN (library, json_loads);
121 LOAD_DLL_FN (library, json_load_callback);
122
123 init_json ();
124
125 return true;
126 }
127
128 #define json_set_alloc_funcs fn_json_set_alloc_funcs
129 #define json_array fn_json_array
130 #define json_array_append_new fn_json_array_append_new
131 #define json_array_size fn_json_array_size
132 #define json_object fn_json_object
133 #define json_object_set_new fn_json_object_set_new
134 #define json_null fn_json_null
135 #define json_true fn_json_true
136 #define json_false fn_json_false
137 #define json_integer fn_json_integer
138 #define json_real fn_json_real
139 #define json_stringn fn_json_stringn
140 #define json_dumps fn_json_dumps
141 #define json_dump_callback fn_json_dump_callback
142 #define json_integer_value fn_json_integer_value
143 #define json_real_value fn_json_real_value
144 #define json_string_value fn_json_string_value
145 #define json_string_length fn_json_string_length
146 #define json_array_get fn_json_array_get
147 #define json_object_get fn_json_object_get
148 #define json_object_size fn_json_object_size
149 #define json_object_iter_key fn_json_object_iter_key
150 #define json_object_iter fn_json_object_iter
151 #define json_object_iter_value fn_json_object_iter_value
152 #define json_object_key_to_iter fn_json_object_key_to_iter
153 #define json_object_iter_next fn_json_object_iter_next
154 #define json_loads fn_json_loads
155 #define json_load_callback fn_json_load_callback
156
157 #endif /* WINDOWSNT */
158
159 /* We install a custom allocator so that we can avoid objects larger
160 than PTRDIFF_MAX. Such objects wouldn't play well with the rest of
161 Emacs's codebase, which generally uses ptrdiff_t for sizes and
162 indices. The other functions in this file also generally assume
163 that size_t values never exceed PTRDIFF_MAX.
164
165 In addition, we need to use a custom allocator because on
166 MS-Windows we replace malloc/free with our own functions, see
167 w32heap.c, so we must force the library to use our allocator, or
168 else we won't be able to free storage allocated by the library. */
169
170 static void *
json_malloc(size_t size)171 json_malloc (size_t size)
172 {
173 if (size > PTRDIFF_MAX)
174 {
175 errno = ENOMEM;
176 return NULL;
177 }
178 return malloc (size);
179 }
180
181 static void
json_free(void * ptr)182 json_free (void *ptr)
183 {
184 free (ptr);
185 }
186
187 void
init_json(void)188 init_json (void)
189 {
190 json_set_alloc_funcs (json_malloc, json_free);
191 }
192
193 #if !JSON_HAS_ERROR_CODE
194
195 /* Return whether STRING starts with PREFIX. */
196
197 static bool
json_has_prefix(const char * string,const char * prefix)198 json_has_prefix (const char *string, const char *prefix)
199 {
200 return strncmp (string, prefix, strlen (prefix)) == 0;
201 }
202
203 /* Return whether STRING ends with SUFFIX. */
204
205 static bool
json_has_suffix(const char * string,const char * suffix)206 json_has_suffix (const char *string, const char *suffix)
207 {
208 size_t string_len = strlen (string);
209 size_t suffix_len = strlen (suffix);
210 return string_len >= suffix_len
211 && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0;
212 }
213
214 #endif
215
216 /* Note that all callers of make_string_from_utf8 and build_string_from_utf8
217 below either pass only value UTF-8 strings or use the functionf for
218 formatting error messages; in the latter case correctness isn't
219 critical. */
220
221 /* Return a unibyte string containing the sequence of UTF-8 encoding
222 units of the UTF-8 representation of STRING. If STRING does not
223 represent a sequence of Unicode scalar values, return a string with
224 unspecified contents. */
225
226 static Lisp_Object
json_encode(Lisp_Object string)227 json_encode (Lisp_Object string)
228 {
229 /* FIXME: Raise an error if STRING is not a scalar value
230 sequence. */
231 return encode_string_utf_8 (string, Qnil, false, Qt, Qt);
232 }
233
234 static AVOID
json_out_of_memory(void)235 json_out_of_memory (void)
236 {
237 xsignal0 (Qjson_out_of_memory);
238 }
239
240 /* Signal a Lisp error corresponding to the JSON ERROR. */
241
242 static AVOID
json_parse_error(const json_error_t * error)243 json_parse_error (const json_error_t *error)
244 {
245 Lisp_Object symbol;
246 #if JSON_HAS_ERROR_CODE
247 switch (json_error_code (error))
248 {
249 case json_error_premature_end_of_input:
250 symbol = Qjson_end_of_file;
251 break;
252 case json_error_end_of_input_expected:
253 symbol = Qjson_trailing_content;
254 break;
255 default:
256 symbol = Qjson_parse_error;
257 break;
258 }
259 #else
260 if (json_has_suffix (error->text, "expected near end of file"))
261 symbol = Qjson_end_of_file;
262 else if (json_has_prefix (error->text, "end of file expected"))
263 symbol = Qjson_trailing_content;
264 else
265 symbol = Qjson_parse_error;
266 #endif
267 xsignal (symbol,
268 list5 (build_string_from_utf8 (error->text),
269 build_string_from_utf8 (error->source),
270 INT_TO_INTEGER (error->line),
271 INT_TO_INTEGER (error->column),
272 INT_TO_INTEGER (error->position)));
273 }
274
275 static void
json_release_object(void * object)276 json_release_object (void *object)
277 {
278 json_decref (object);
279 }
280
281 /* Signal an error if OBJECT is not a string, or if OBJECT contains
282 embedded NUL characters. */
283
284 static void
check_string_without_embedded_nuls(Lisp_Object object)285 check_string_without_embedded_nuls (Lisp_Object object)
286 {
287 CHECK_STRING (object);
288 CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL,
289 Qstring_without_embedded_nulls_p, object);
290 }
291
292 /* Signal an error of type `json-out-of-memory' if OBJECT is
293 NULL. */
294
295 static json_t *
json_check(json_t * object)296 json_check (json_t *object)
297 {
298 if (object == NULL)
299 json_out_of_memory ();
300 return object;
301 }
302
303 /* If STRING is not a valid UTF-8 string, signal an error of type
304 `wrong-type-argument'. STRING must be a unibyte string. */
305
306 static void
json_check_utf8(Lisp_Object string)307 json_check_utf8 (Lisp_Object string)
308 {
309 CHECK_TYPE (utf8_string_p (string), Qutf_8_string_p, string);
310 }
311
312 enum json_object_type {
313 json_object_hashtable,
314 json_object_alist,
315 json_object_plist
316 };
317
318 enum json_array_type {
319 json_array_array,
320 json_array_list
321 };
322
323 struct json_configuration {
324 enum json_object_type object_type;
325 enum json_array_type array_type;
326 Lisp_Object null_object;
327 Lisp_Object false_object;
328 };
329
330 static json_t *lisp_to_json (Lisp_Object, struct json_configuration *conf);
331
332 /* Convert a Lisp object to a toplevel JSON object (array or object). */
333
334 static json_t *
lisp_to_json_toplevel_1(Lisp_Object lisp,struct json_configuration * conf)335 lisp_to_json_toplevel_1 (Lisp_Object lisp,
336 struct json_configuration *conf)
337 {
338 json_t *json;
339 ptrdiff_t count;
340
341 if (VECTORP (lisp))
342 {
343 ptrdiff_t size = ASIZE (lisp);
344 json = json_check (json_array ());
345 count = SPECPDL_INDEX ();
346 record_unwind_protect_ptr (json_release_object, json);
347 for (ptrdiff_t i = 0; i < size; ++i)
348 {
349 int status
350 = json_array_append_new (json, lisp_to_json (AREF (lisp, i),
351 conf));
352 if (status == -1)
353 json_out_of_memory ();
354 }
355 eassert (json_array_size (json) == size);
356 }
357 else if (HASH_TABLE_P (lisp))
358 {
359 struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
360 json = json_check (json_object ());
361 count = SPECPDL_INDEX ();
362 record_unwind_protect_ptr (json_release_object, json);
363 for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
364 {
365 Lisp_Object key = HASH_KEY (h, i);
366 if (!EQ (key, Qunbound))
367 {
368 CHECK_STRING (key);
369 Lisp_Object ekey = json_encode (key);
370 /* We can't specify the length, so the string must be
371 NUL-terminated. */
372 check_string_without_embedded_nuls (ekey);
373 const char *key_str = SSDATA (ekey);
374 /* Reject duplicate keys. These are possible if the hash
375 table test is not `equal'. */
376 if (json_object_get (json, key_str) != NULL)
377 wrong_type_argument (Qjson_value_p, lisp);
378 int status
379 = json_object_set_new (json, key_str,
380 lisp_to_json (HASH_VALUE (h, i), conf));
381 if (status == -1)
382 {
383 /* A failure can be caused either by an invalid key or
384 by low memory. */
385 json_check_utf8 (ekey);
386 json_out_of_memory ();
387 }
388 }
389 }
390 }
391 else if (NILP (lisp))
392 return json_check (json_object ());
393 else if (CONSP (lisp))
394 {
395 Lisp_Object tail = lisp;
396 json = json_check (json_object ());
397 count = SPECPDL_INDEX ();
398 record_unwind_protect_ptr (json_release_object, json);
399 bool is_plist = !CONSP (XCAR (tail));
400 FOR_EACH_TAIL (tail)
401 {
402 const char *key_str;
403 Lisp_Object value;
404 Lisp_Object key_symbol;
405 if (is_plist)
406 {
407 key_symbol = XCAR (tail);
408 tail = XCDR (tail);
409 CHECK_CONS (tail);
410 value = XCAR (tail);
411 }
412 else
413 {
414 Lisp_Object pair = XCAR (tail);
415 CHECK_CONS (pair);
416 key_symbol = XCAR (pair);
417 value = XCDR (pair);
418 }
419 CHECK_SYMBOL (key_symbol);
420 Lisp_Object key = SYMBOL_NAME (key_symbol);
421 /* We can't specify the length, so the string must be
422 NUL-terminated. */
423 check_string_without_embedded_nuls (key);
424 key_str = SSDATA (key);
425 /* In plists, ensure leading ":" in keys is stripped. It
426 will be reconstructed later in `json_to_lisp'.*/
427 if (is_plist && ':' == key_str[0] && key_str[1])
428 {
429 key_str = &key_str[1];
430 }
431 /* Only add element if key is not already present. */
432 if (json_object_get (json, key_str) == NULL)
433 {
434 int status
435 = json_object_set_new (json, key_str, lisp_to_json (value,
436 conf));
437 if (status == -1)
438 json_out_of_memory ();
439 }
440 }
441 CHECK_LIST_END (tail, lisp);
442 }
443 else
444 wrong_type_argument (Qjson_value_p, lisp);
445
446 clear_unwind_protect (count);
447 unbind_to (count, Qnil);
448 return json;
449 }
450
451 /* Convert LISP to a toplevel JSON object (array or object). Signal
452 an error of type `wrong-type-argument' if LISP is not a vector,
453 hashtable, alist, or plist. */
454
455 static json_t *
lisp_to_json_toplevel(Lisp_Object lisp,struct json_configuration * conf)456 lisp_to_json_toplevel (Lisp_Object lisp, struct json_configuration *conf)
457 {
458 if (++lisp_eval_depth > max_lisp_eval_depth)
459 xsignal0 (Qjson_object_too_deep);
460 json_t *json = lisp_to_json_toplevel_1 (lisp, conf);
461 --lisp_eval_depth;
462 return json;
463 }
464
465 /* Convert LISP to any JSON object. Signal an error of type
466 `wrong-type-argument' if the type of LISP can't be converted to a
467 JSON object. */
468
469 static json_t *
lisp_to_json(Lisp_Object lisp,struct json_configuration * conf)470 lisp_to_json (Lisp_Object lisp, struct json_configuration *conf)
471 {
472 if (EQ (lisp, conf->null_object))
473 return json_check (json_null ());
474 else if (EQ (lisp, conf->false_object))
475 return json_check (json_false ());
476 else if (EQ (lisp, Qt))
477 return json_check (json_true ());
478 else if (INTEGERP (lisp))
479 {
480 intmax_t low = TYPE_MINIMUM (json_int_t);
481 intmax_t high = TYPE_MAXIMUM (json_int_t);
482 intmax_t value;
483 if (! (integer_to_intmax (lisp, &value) && low <= value && value <= high))
484 args_out_of_range_3 (lisp, make_int (low), make_int (high));
485 return json_check (json_integer (value));
486 }
487 else if (FLOATP (lisp))
488 return json_check (json_real (XFLOAT_DATA (lisp)));
489 else if (STRINGP (lisp))
490 {
491 Lisp_Object encoded = json_encode (lisp);
492 json_t *json = json_stringn (SSDATA (encoded), SBYTES (encoded));
493 if (json == NULL)
494 {
495 /* A failure can be caused either by an invalid string or by
496 low memory. */
497 json_check_utf8 (encoded);
498 json_out_of_memory ();
499 }
500 return json;
501 }
502
503 /* LISP now must be a vector, hashtable, alist, or plist. */
504 return lisp_to_json_toplevel (lisp, conf);
505 }
506
507 static void
json_parse_args(ptrdiff_t nargs,Lisp_Object * args,struct json_configuration * conf,bool parse_object_types)508 json_parse_args (ptrdiff_t nargs,
509 Lisp_Object *args,
510 struct json_configuration *conf,
511 bool parse_object_types)
512 {
513 if ((nargs % 2) != 0)
514 wrong_type_argument (Qplistp, Flist (nargs, args));
515
516 /* Start from the back so keyword values appearing
517 first take precedence. */
518 for (ptrdiff_t i = nargs; i > 0; i -= 2) {
519 Lisp_Object key = args[i - 2];
520 Lisp_Object value = args[i - 1];
521 if (parse_object_types && EQ (key, QCobject_type))
522 {
523 if (EQ (value, Qhash_table))
524 conf->object_type = json_object_hashtable;
525 else if (EQ (value, Qalist))
526 conf->object_type = json_object_alist;
527 else if (EQ (value, Qplist))
528 conf->object_type = json_object_plist;
529 else
530 wrong_choice (list3 (Qhash_table, Qalist, Qplist), value);
531 }
532 else if (parse_object_types && EQ (key, QCarray_type))
533 {
534 if (EQ (value, Qarray))
535 conf->array_type = json_array_array;
536 else if (EQ (value, Qlist))
537 conf->array_type = json_array_list;
538 else
539 wrong_choice (list2 (Qarray, Qlist), value);
540 }
541 else if (EQ (key, QCnull_object))
542 conf->null_object = value;
543 else if (EQ (key, QCfalse_object))
544 conf->false_object = value;
545 else if (parse_object_types)
546 wrong_choice (list4 (QCobject_type,
547 QCarray_type,
548 QCnull_object,
549 QCfalse_object),
550 value);
551 else
552 wrong_choice (list2 (QCnull_object,
553 QCfalse_object),
554 value);
555 }
556 }
557
558 DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, MANY,
559 NULL,
560 doc: /* Return the JSON representation of OBJECT as a string.
561
562 OBJECT must be a vector, hashtable, alist, or plist and its elements
563 can recursively contain the Lisp equivalents to the JSON null and
564 false values, t, numbers, strings, or other vectors hashtables, alists
565 or plists. t will be converted to the JSON true value. Vectors will
566 be converted to JSON arrays, whereas hashtables, alists and plists are
567 converted to JSON objects. Hashtable keys must be strings without
568 embedded NUL characters and must be unique within each object. Alist
569 and plist keys must be symbols; if a key is duplicate, the first
570 instance is used.
571
572 The Lisp equivalents to the JSON null and false values are
573 configurable in the arguments ARGS, a list of keyword/argument pairs:
574
575 The keyword argument `:null-object' specifies which object to use
576 to represent a JSON null value. It defaults to `:null'.
577
578 The keyword argument `:false-object' specifies which object to use to
579 represent a JSON false value. It defaults to `:false'.
580
581 In you specify the same value for `:null-object' and `:false-object',
582 a potentially ambiguous situation, the JSON output will not contain
583 any JSON false values.
584 usage: (json-serialize OBJECT &rest ARGS) */)
585 (ptrdiff_t nargs, Lisp_Object *args)
586 {
587 ptrdiff_t count = SPECPDL_INDEX ();
588
589 #ifdef WINDOWSNT
590 if (!json_initialized)
591 {
592 Lisp_Object status;
593 json_initialized = init_json_functions ();
594 status = json_initialized ? Qt : Qnil;
595 Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
596 }
597 if (!json_initialized)
598 {
599 message1 ("jansson library not found");
600 return Qnil;
601 }
602 #endif
603
604 struct json_configuration conf =
605 {json_object_hashtable, json_array_array, QCnull, QCfalse};
606 json_parse_args (nargs - 1, args + 1, &conf, false);
607
608 json_t *json = lisp_to_json_toplevel (args[0], &conf);
609 record_unwind_protect_ptr (json_release_object, json);
610
611 /* If desired, we might want to add the following flags:
612 JSON_DECODE_ANY, JSON_ALLOW_NUL. */
613 char *string = json_dumps (json, JSON_COMPACT);
614 if (string == NULL)
615 json_out_of_memory ();
616 record_unwind_protect_ptr (json_free, string);
617
618 return unbind_to (count, build_string_from_utf8 (string));
619 }
620
621 struct json_buffer_and_size
622 {
623 const char *buffer;
624 ptrdiff_t size;
625 /* This tracks how many bytes were inserted by the callback since
626 json_dump_callback was called. */
627 ptrdiff_t inserted_bytes;
628 };
629
630 static Lisp_Object
json_insert(void * data)631 json_insert (void *data)
632 {
633 struct json_buffer_and_size *buffer_and_size = data;
634 ptrdiff_t len = buffer_and_size->size;
635 ptrdiff_t inserted_bytes = buffer_and_size->inserted_bytes;
636 ptrdiff_t gap_size = GAP_SIZE - inserted_bytes;
637
638 /* Enlarge the gap if necessary. */
639 if (gap_size < len)
640 make_gap (len - gap_size);
641
642 /* Copy this chunk of data into the gap. */
643 memcpy ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE + inserted_bytes,
644 buffer_and_size->buffer, len);
645 buffer_and_size->inserted_bytes += len;
646 return Qnil;
647 }
648
649 static Lisp_Object
json_handle_nonlocal_exit(enum nonlocal_exit type,Lisp_Object data)650 json_handle_nonlocal_exit (enum nonlocal_exit type, Lisp_Object data)
651 {
652 switch (type)
653 {
654 case NONLOCAL_EXIT_SIGNAL:
655 return data;
656 case NONLOCAL_EXIT_THROW:
657 return Fcons (Qno_catch, data);
658 default:
659 eassume (false);
660 }
661 }
662
663 struct json_insert_data
664 {
665 /* This tracks how many bytes were inserted by the callback since
666 json_dump_callback was called. */
667 ptrdiff_t inserted_bytes;
668 /* nil if json_insert succeeded, otherwise the symbol
669 Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */
670 Lisp_Object error;
671 };
672
673 /* Callback for json_dump_callback that inserts a JSON representation
674 as a unibyte string into the gap. DATA must point to a structure
675 of type json_insert_data. This function may not exit nonlocally.
676 It catches all nonlocal exits and stores them in data->error for
677 reraising. */
678
679 static int
json_insert_callback(const char * buffer,size_t size,void * data)680 json_insert_callback (const char *buffer, size_t size, void *data)
681 {
682 struct json_insert_data *d = data;
683 struct json_buffer_and_size buffer_and_size
684 = {.buffer = buffer, .size = size, .inserted_bytes = d->inserted_bytes};
685 d->error = internal_catch_all (json_insert, &buffer_and_size,
686 json_handle_nonlocal_exit);
687 d->inserted_bytes = buffer_and_size.inserted_bytes;
688 return NILP (d->error) ? 0 : -1;
689 }
690
691 DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, MANY,
692 NULL,
693 doc: /* Insert the JSON representation of OBJECT before point.
694 This is the same as (insert (json-serialize OBJECT)), but potentially
695 faster. See the function `json-serialize' for allowed values of
696 OBJECT.
697 usage: (json-insert OBJECT &rest ARGS) */)
698 (ptrdiff_t nargs, Lisp_Object *args)
699 {
700 ptrdiff_t count = SPECPDL_INDEX ();
701
702 #ifdef WINDOWSNT
703 if (!json_initialized)
704 {
705 Lisp_Object status;
706 json_initialized = init_json_functions ();
707 status = json_initialized ? Qt : Qnil;
708 Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
709 }
710 if (!json_initialized)
711 {
712 message1 ("jansson library not found");
713 return Qnil;
714 }
715 #endif
716
717 struct json_configuration conf =
718 {json_object_hashtable, json_array_array, QCnull, QCfalse};
719 json_parse_args (nargs - 1, args + 1, &conf, false);
720
721 json_t *json = lisp_to_json (args[0], &conf);
722 record_unwind_protect_ptr (json_release_object, json);
723
724 prepare_to_modify_buffer (PT, PT, NULL);
725 move_gap_both (PT, PT_BYTE);
726 struct json_insert_data data;
727 data.inserted_bytes = 0;
728 /* If desired, we might want to add the following flags:
729 JSON_DECODE_ANY, JSON_ALLOW_NUL. */
730 int status
731 /* Could have used json_dumpb, but that became available only in
732 Jansson 2.10, whereas we want to support 2.7 and upward. */
733 = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT);
734 if (status == -1)
735 {
736 if (CONSP (data.error))
737 xsignal (XCAR (data.error), XCDR (data.error));
738 else
739 json_out_of_memory ();
740 }
741
742 ptrdiff_t inserted = 0;
743 ptrdiff_t inserted_bytes = data.inserted_bytes;
744 if (inserted_bytes > 0)
745 {
746 /* If required, decode the stuff we've read into the gap. */
747 struct coding_system coding;
748 /* JSON strings are UTF-8 encoded strings. If for some reason
749 the text returned by the Jansson library includes invalid
750 byte sequences, they will be represented by raw bytes in the
751 buffer text. */
752 setup_coding_system (Qutf_8_unix, &coding);
753 coding.dst_multibyte =
754 !NILP (BVAR (current_buffer, enable_multibyte_characters));
755 if (CODING_MAY_REQUIRE_DECODING (&coding))
756 {
757 /* Now we have all the new bytes at the beginning of the gap,
758 but `decode_coding_gap` needs them at the end of the gap, so
759 we need to move them. */
760 memmove (GAP_END_ADDR - inserted_bytes, GPT_ADDR, inserted_bytes);
761 decode_coding_gap (&coding, inserted_bytes);
762 inserted = coding.produced_char;
763 }
764 else
765 {
766 /* Make the inserted text part of the buffer, as unibyte text. */
767 eassert (NILP (BVAR (current_buffer, enable_multibyte_characters)));
768 insert_from_gap_1 (inserted_bytes, inserted_bytes, false);
769
770 /* The target buffer is unibyte, so we don't need to decode. */
771 invalidate_buffer_caches (current_buffer,
772 PT, PT + inserted_bytes);
773 adjust_after_insert (PT, PT_BYTE,
774 PT + inserted_bytes,
775 PT_BYTE + inserted_bytes,
776 inserted_bytes);
777 inserted = inserted_bytes;
778 }
779 }
780
781 /* Call after-change hooks. */
782 signal_after_change (PT, 0, inserted);
783 if (inserted > 0)
784 {
785 update_compositions (PT, PT, CHECK_BORDER);
786 /* Move point to after the inserted text. */
787 SET_PT_BOTH (PT + inserted, PT_BYTE + inserted_bytes);
788 }
789
790 return unbind_to (count, Qnil);
791 }
792
793 /* Convert a JSON object to a Lisp object. */
794
795 static Lisp_Object ARG_NONNULL ((1))
json_to_lisp(json_t * json,struct json_configuration * conf)796 json_to_lisp (json_t *json, struct json_configuration *conf)
797 {
798 switch (json_typeof (json))
799 {
800 case JSON_NULL:
801 return conf->null_object;
802 case JSON_FALSE:
803 return conf->false_object;
804 case JSON_TRUE:
805 return Qt;
806 case JSON_INTEGER:
807 {
808 json_int_t i = json_integer_value (json);
809 return INT_TO_INTEGER (i);
810 }
811 case JSON_REAL:
812 return make_float (json_real_value (json));
813 case JSON_STRING:
814 return make_string_from_utf8 (json_string_value (json),
815 json_string_length (json));
816 case JSON_ARRAY:
817 {
818 if (++lisp_eval_depth > max_lisp_eval_depth)
819 xsignal0 (Qjson_object_too_deep);
820 size_t size = json_array_size (json);
821 if (PTRDIFF_MAX < size)
822 overflow_error ();
823 Lisp_Object result;
824 switch (conf->array_type)
825 {
826 case json_array_array:
827 {
828 result = make_vector (size, Qunbound);
829 for (ptrdiff_t i = 0; i < size; ++i)
830 {
831 rarely_quit (i);
832 ASET (result, i,
833 json_to_lisp (json_array_get (json, i), conf));
834 }
835 break;
836 }
837 case json_array_list:
838 {
839 result = Qnil;
840 for (ptrdiff_t i = size - 1; i >= 0; --i)
841 {
842 rarely_quit (i);
843 result = Fcons (json_to_lisp (json_array_get (json, i), conf),
844 result);
845 }
846 break;
847 }
848 default:
849 /* Can't get here. */
850 emacs_abort ();
851 }
852 --lisp_eval_depth;
853 return result;
854 }
855 case JSON_OBJECT:
856 {
857 if (++lisp_eval_depth > max_lisp_eval_depth)
858 xsignal0 (Qjson_object_too_deep);
859 Lisp_Object result;
860 switch (conf->object_type)
861 {
862 case json_object_hashtable:
863 {
864 size_t size = json_object_size (json);
865 if (FIXNUM_OVERFLOW_P (size))
866 overflow_error ();
867 result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize,
868 make_fixed_natnum (size));
869 struct Lisp_Hash_Table *h = XHASH_TABLE (result);
870 const char *key_str;
871 json_t *value;
872 json_object_foreach (json, key_str, value)
873 {
874 Lisp_Object key = build_string_from_utf8 (key_str), hash;
875 ptrdiff_t i = hash_lookup (h, key, &hash);
876 /* Keys in JSON objects are unique, so the key can't
877 be present yet. */
878 eassert (i < 0);
879 hash_put (h, key, json_to_lisp (value, conf), hash);
880 }
881 break;
882 }
883 case json_object_alist:
884 {
885 result = Qnil;
886 const char *key_str;
887 json_t *value;
888 json_object_foreach (json, key_str, value)
889 {
890 Lisp_Object key
891 = Fintern (build_string_from_utf8 (key_str), Qnil);
892 result
893 = Fcons (Fcons (key, json_to_lisp (value, conf)),
894 result);
895 }
896 result = Fnreverse (result);
897 break;
898 }
899 case json_object_plist:
900 {
901 result = Qnil;
902 const char *key_str;
903 json_t *value;
904 json_object_foreach (json, key_str, value)
905 {
906 USE_SAFE_ALLOCA;
907 ptrdiff_t key_str_len = strlen (key_str);
908 char *keyword_key_str = SAFE_ALLOCA (1 + key_str_len + 1);
909 keyword_key_str[0] = ':';
910 strcpy (&keyword_key_str[1], key_str);
911 Lisp_Object key = intern_1 (keyword_key_str, key_str_len + 1);
912 /* Build the plist as value-key since we're going to
913 reverse it in the end.*/
914 result = Fcons (key, result);
915 result = Fcons (json_to_lisp (value, conf), result);
916 SAFE_FREE ();
917 }
918 result = Fnreverse (result);
919 break;
920 }
921 default:
922 /* Can't get here. */
923 emacs_abort ();
924 }
925 --lisp_eval_depth;
926 return result;
927 }
928 }
929 /* Can't get here. */
930 emacs_abort ();
931 }
932
933 DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY,
934 NULL,
935 doc: /* Parse the JSON STRING into a Lisp object.
936 This is essentially the reverse operation of `json-serialize', which
937 see. The returned object will be a vector, list, hashtable, alist, or
938 plist. Its elements will be the JSON null value, the JSON false
939 value, t, numbers, strings, or further vectors, hashtables, alists, or
940 plists. If there are duplicate keys in an object, all but the last
941 one are ignored. If STRING doesn't contain a valid JSON object, this
942 function signals an error of type `json-parse-error'.
943
944 The arguments ARGS are a list of keyword/argument pairs:
945
946 The keyword argument `:object-type' specifies which Lisp type is used
947 to represent objects; it can be `hash-table', `alist' or `plist'. It
948 defaults to `hash-table'.
949
950 The keyword argument `:array-type' specifies which Lisp type is used
951 to represent arrays; it can be `array' (the default) or `list'.
952
953 The keyword argument `:null-object' specifies which object to use
954 to represent a JSON null value. It defaults to `:null'.
955
956 The keyword argument `:false-object' specifies which object to use to
957 represent a JSON false value. It defaults to `:false'.
958 usage: (json-parse-string STRING &rest ARGS) */)
959 (ptrdiff_t nargs, Lisp_Object *args)
960 {
961 ptrdiff_t count = SPECPDL_INDEX ();
962
963 #ifdef WINDOWSNT
964 if (!json_initialized)
965 {
966 Lisp_Object status;
967 json_initialized = init_json_functions ();
968 status = json_initialized ? Qt : Qnil;
969 Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
970 }
971 if (!json_initialized)
972 {
973 message1 ("jansson library not found");
974 return Qnil;
975 }
976 #endif
977
978 Lisp_Object string = args[0];
979 CHECK_STRING (string);
980 Lisp_Object encoded = json_encode (string);
981 check_string_without_embedded_nuls (encoded);
982 struct json_configuration conf =
983 {json_object_hashtable, json_array_array, QCnull, QCfalse};
984 json_parse_args (nargs - 1, args + 1, &conf, true);
985
986 json_error_t error;
987 json_t *object = json_loads (SSDATA (encoded), 0, &error);
988 if (object == NULL)
989 json_parse_error (&error);
990
991 /* Avoid leaking the object in case of further errors. */
992 if (object != NULL)
993 record_unwind_protect_ptr (json_release_object, object);
994
995 return unbind_to (count, json_to_lisp (object, &conf));
996 }
997
998 struct json_read_buffer_data
999 {
1000 /* Byte position of position to read the next chunk from. */
1001 ptrdiff_t point;
1002 };
1003
1004 /* Callback for json_load_callback that reads from the current buffer.
1005 DATA must point to a structure of type json_read_buffer_data.
1006 data->point must point to the byte position to read from; after
1007 reading, data->point is advanced accordingly. The buffer point
1008 itself is ignored. This function may not exit nonlocally. */
1009
1010 static size_t
json_read_buffer_callback(void * buffer,size_t buflen,void * data)1011 json_read_buffer_callback (void *buffer, size_t buflen, void *data)
1012 {
1013 struct json_read_buffer_data *d = data;
1014
1015 /* First, parse from point to the gap or the end of the accessible
1016 portion, whatever is closer. */
1017 ptrdiff_t point = d->point;
1018 ptrdiff_t end = BUFFER_CEILING_OF (point) + 1;
1019 ptrdiff_t count = end - point;
1020 if (buflen < count)
1021 count = buflen;
1022 memcpy (buffer, BYTE_POS_ADDR (point), count);
1023 d->point += count;
1024 return count;
1025 }
1026
1027 DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
1028 0, MANY, NULL,
1029 doc: /* Read JSON object from current buffer starting at point.
1030 Move point after the end of the object if parsing was successful.
1031 On error, don't move point.
1032
1033 The returned object will be a vector, list, hashtable, alist, or
1034 plist. Its elements will be the JSON null value, the JSON false
1035 value, t, numbers, strings, or further vectors, lists, hashtables,
1036 alists, or plists. If there are duplicate keys in an object, all
1037 but the last one are ignored.
1038
1039 If the current buffer doesn't contain a valid JSON object, the
1040 function signals an error of type `json-parse-error'.
1041
1042 The arguments ARGS are a list of keyword/argument pairs:
1043
1044 The keyword argument `:object-type' specifies which Lisp type is used
1045 to represent objects; it can be `hash-table', `alist' or `plist'. It
1046 defaults to `hash-table'.
1047
1048 The keyword argument `:array-type' specifies which Lisp type is used
1049 to represent arrays; it can be `array' (the default) or `list'.
1050
1051 The keyword argument `:null-object' specifies which object to use
1052 to represent a JSON null value. It defaults to `:null'.
1053
1054 The keyword argument `:false-object' specifies which object to use to
1055 represent a JSON false value. It defaults to `:false'.
1056 usage: (json-parse-buffer &rest args) */)
1057 (ptrdiff_t nargs, Lisp_Object *args)
1058 {
1059 ptrdiff_t count = SPECPDL_INDEX ();
1060
1061 #ifdef WINDOWSNT
1062 if (!json_initialized)
1063 {
1064 Lisp_Object status;
1065 json_initialized = init_json_functions ();
1066 status = json_initialized ? Qt : Qnil;
1067 Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
1068 }
1069 if (!json_initialized)
1070 {
1071 message1 ("jansson library not found");
1072 return Qnil;
1073 }
1074 #endif
1075
1076 struct json_configuration conf =
1077 {json_object_hashtable, json_array_array, QCnull, QCfalse};
1078 json_parse_args (nargs, args, &conf, true);
1079
1080 ptrdiff_t point = PT_BYTE;
1081 struct json_read_buffer_data data = {.point = point};
1082 json_error_t error;
1083 json_t *object = json_load_callback (json_read_buffer_callback, &data,
1084 JSON_DISABLE_EOF_CHECK, &error);
1085
1086 if (object == NULL)
1087 json_parse_error (&error);
1088
1089 /* Avoid leaking the object in case of further errors. */
1090 record_unwind_protect_ptr (json_release_object, object);
1091
1092 /* Convert and then move point only if everything succeeded. */
1093 Lisp_Object lisp = json_to_lisp (object, &conf);
1094
1095 /* Adjust point by how much we just read. */
1096 point += error.position;
1097 SET_PT_BOTH (BYTE_TO_CHAR (point), point);
1098
1099 return unbind_to (count, lisp);
1100 }
1101
1102 /* Simplified version of 'define-error' that works with pure
1103 objects. */
1104
1105 static void
define_error(Lisp_Object name,const char * message,Lisp_Object parent)1106 define_error (Lisp_Object name, const char *message, Lisp_Object parent)
1107 {
1108 eassert (SYMBOLP (name));
1109 eassert (SYMBOLP (parent));
1110 Lisp_Object parent_conditions = Fget (parent, Qerror_conditions);
1111 eassert (CONSP (parent_conditions));
1112 eassert (!NILP (Fmemq (parent, parent_conditions)));
1113 eassert (NILP (Fmemq (name, parent_conditions)));
1114 Fput (name, Qerror_conditions, pure_cons (name, parent_conditions));
1115 Fput (name, Qerror_message, build_pure_c_string (message));
1116 }
1117
1118 void
syms_of_json(void)1119 syms_of_json (void)
1120 {
1121 DEFSYM (QCnull, ":null");
1122 DEFSYM (QCfalse, ":false");
1123
1124 DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p");
1125 DEFSYM (Qjson_value_p, "json-value-p");
1126 DEFSYM (Qutf_8_string_p, "utf-8-string-p");
1127
1128 DEFSYM (Qjson_error, "json-error");
1129 DEFSYM (Qjson_out_of_memory, "json-out-of-memory");
1130 DEFSYM (Qjson_parse_error, "json-parse-error");
1131 DEFSYM (Qjson_end_of_file, "json-end-of-file");
1132 DEFSYM (Qjson_trailing_content, "json-trailing-content");
1133 DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
1134 define_error (Qjson_error, "generic JSON error", Qerror);
1135 define_error (Qjson_out_of_memory,
1136 "not enough memory for creating JSON object", Qjson_error);
1137 define_error (Qjson_parse_error, "could not parse JSON stream",
1138 Qjson_error);
1139 define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error);
1140 define_error (Qjson_trailing_content, "trailing content after JSON stream",
1141 Qjson_parse_error);
1142 define_error (Qjson_object_too_deep,
1143 "object cyclic or Lisp evaluation too deep", Qjson_error);
1144
1145 DEFSYM (Qpure, "pure");
1146 DEFSYM (Qside_effect_free, "side-effect-free");
1147
1148 DEFSYM (Qjson_serialize, "json-serialize");
1149 DEFSYM (Qjson_parse_string, "json-parse-string");
1150 Fput (Qjson_serialize, Qpure, Qt);
1151 Fput (Qjson_serialize, Qside_effect_free, Qt);
1152 Fput (Qjson_parse_string, Qpure, Qt);
1153 Fput (Qjson_parse_string, Qside_effect_free, Qt);
1154
1155 DEFSYM (QCobject_type, ":object-type");
1156 DEFSYM (QCarray_type, ":array-type");
1157 DEFSYM (QCnull_object, ":null-object");
1158 DEFSYM (QCfalse_object, ":false-object");
1159 DEFSYM (Qalist, "alist");
1160 DEFSYM (Qplist, "plist");
1161 DEFSYM (Qarray, "array");
1162
1163 defsubr (&Sjson_serialize);
1164 defsubr (&Sjson_insert);
1165 defsubr (&Sjson_parse_string);
1166 defsubr (&Sjson_parse_buffer);
1167 }
1168