1 /* JSON parsing and serialization.
3 Copyright (C) 2017-2018 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
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.
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.
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/>. */
33 #define JSON_HAS_ERROR_CODE (JANSSON_VERSION_HEX >= 0x020B00)
37 # include "w32common.h"
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
,
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
));
77 /* This is called by json_decref, which is an inline function. */
78 void json_delete(json_t
*json
)
80 fn_json_delete (json
);
83 static bool json_initialized
;
86 init_json_functions (void)
88 HMODULE library
= w32_delayed_load (Qjson
);
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
);
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
157 #endif /* WINDOWSNT */
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.
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. */
171 json_malloc (size_t size
)
173 if (size
> PTRDIFF_MAX
)
178 return malloc (size
);
182 json_free (void *ptr
)
190 json_set_alloc_funcs (json_malloc
, json_free
);
193 #if !JSON_HAS_ERROR_CODE
195 /* Return whether STRING starts with PREFIX. */
198 json_has_prefix (const char *string
, const char *prefix
)
200 size_t string_len
= strlen (string
);
201 size_t prefix_len
= strlen (prefix
);
202 return string_len
>= prefix_len
&& memcmp (string
, prefix
, prefix_len
) == 0;
205 /* Return whether STRING ends with SUFFIX. */
208 json_has_suffix (const char *string
, const char *suffix
)
210 size_t string_len
= strlen (string
);
211 size_t suffix_len
= strlen (suffix
);
212 return string_len
>= suffix_len
213 && memcmp (string
+ string_len
- suffix_len
, suffix
, suffix_len
) == 0;
218 /* Create a multibyte Lisp string from the UTF-8 string in
219 [DATA, DATA + SIZE). If the range [DATA, DATA + SIZE) does not
220 contain a valid UTF-8 string, an unspecified string is returned.
221 Note that all callers below either pass only value UTF-8 strings or
222 use this function for formatting error messages; in the latter case
223 correctness isn't critical. */
226 json_make_string (const char *data
, ptrdiff_t size
)
228 return code_convert_string (make_specified_string (data
, -1, size
, false),
229 Qutf_8_unix
, Qt
, false, true, true);
232 /* Create a multibyte Lisp string from the null-terminated UTF-8
233 string beginning at DATA. If the string is not a valid UTF-8
234 string, an unspecified string is returned. Note that all callers
235 below either pass only value UTF-8 strings or use this function for
236 formatting error messages; in the latter case correctness isn't
240 json_build_string (const char *data
)
242 return json_make_string (data
, strlen (data
));
245 /* Return a unibyte string containing the sequence of UTF-8 encoding
246 units of the UTF-8 representation of STRING. If STRING does not
247 represent a sequence of Unicode scalar values, return a string with
248 unspecified contents. */
251 json_encode (Lisp_Object string
)
253 /* FIXME: Raise an error if STRING is not a scalar value
255 return code_convert_string (string
, Qutf_8_unix
, Qt
, true, true, true);
258 static _Noreturn
void
259 json_out_of_memory (void)
261 xsignal0 (Qjson_out_of_memory
);
264 /* Signal a Lisp error corresponding to the JSON ERROR. */
266 static _Noreturn
void
267 json_parse_error (const json_error_t
*error
)
270 #if JSON_HAS_ERROR_CODE
271 switch (json_error_code (error
))
273 case json_error_premature_end_of_input
:
274 symbol
= Qjson_end_of_file
;
276 case json_error_end_of_input_expected
:
277 symbol
= Qjson_trailing_content
;
280 symbol
= Qjson_parse_error
;
284 if (json_has_suffix (error
->text
, "expected near end of file"))
285 symbol
= Qjson_end_of_file
;
286 else if (json_has_prefix (error
->text
, "end of file expected"))
287 symbol
= Qjson_trailing_content
;
289 symbol
= Qjson_parse_error
;
292 list5 (json_build_string (error
->text
),
293 json_build_string (error
->source
), make_fixed_natnum (error
->line
),
294 make_fixed_natnum (error
->column
), make_fixed_natnum (error
->position
)));
298 json_release_object (void *object
)
300 json_decref (object
);
303 /* Signal an error if OBJECT is not a string, or if OBJECT contains
304 embedded null characters. */
307 check_string_without_embedded_nulls (Lisp_Object object
)
309 CHECK_STRING (object
);
310 CHECK_TYPE (memchr (SDATA (object
), '\0', SBYTES (object
)) == NULL
,
311 Qstring_without_embedded_nulls_p
, object
);
314 /* Signal an error of type `json-out-of-memory' if OBJECT is
318 json_check (json_t
*object
)
321 json_out_of_memory ();
325 /* If STRING is not a valid UTF-8 string, signal an error of type
326 `wrong-type-argument'. STRING must be a unibyte string. */
329 json_check_utf8 (Lisp_Object string
)
331 CHECK_TYPE (utf8_string_p (string
), Qutf_8_string_p
, string
);
334 enum json_object_type
{
335 json_object_hashtable
,
340 struct json_configuration
{
341 enum json_object_type object_type
;
342 Lisp_Object null_object
;
343 Lisp_Object false_object
;
346 static json_t
*lisp_to_json (Lisp_Object
, struct json_configuration
*conf
);
348 /* Convert a Lisp object to a toplevel JSON object (array or object). */
351 lisp_to_json_toplevel_1 (Lisp_Object lisp
,
352 struct json_configuration
*conf
)
359 ptrdiff_t size
= ASIZE (lisp
);
360 json
= json_check (json_array ());
361 count
= SPECPDL_INDEX ();
362 record_unwind_protect_ptr (json_release_object
, json
);
363 for (ptrdiff_t i
= 0; i
< size
; ++i
)
366 = json_array_append_new (json
, lisp_to_json (AREF (lisp
, i
),
369 json_out_of_memory ();
371 eassert (json_array_size (json
) == size
);
373 else if (HASH_TABLE_P (lisp
))
375 struct Lisp_Hash_Table
*h
= XHASH_TABLE (lisp
);
376 json
= json_check (json_object ());
377 count
= SPECPDL_INDEX ();
378 record_unwind_protect_ptr (json_release_object
, json
);
379 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
380 if (!NILP (HASH_HASH (h
, i
)))
382 Lisp_Object key
= json_encode (HASH_KEY (h
, i
));
383 /* We can't specify the length, so the string must be
385 check_string_without_embedded_nulls (key
);
386 const char *key_str
= SSDATA (key
);
387 /* Reject duplicate keys. These are possible if the hash
388 table test is not `equal'. */
389 if (json_object_get (json
, key_str
) != NULL
)
390 wrong_type_argument (Qjson_value_p
, lisp
);
391 int status
= json_object_set_new (json
, key_str
,
392 lisp_to_json (HASH_VALUE (h
, i
),
396 /* A failure can be caused either by an invalid key or
398 json_check_utf8 (key
);
399 json_out_of_memory ();
403 else if (NILP (lisp
))
404 return json_check (json_object ());
405 else if (CONSP (lisp
))
407 Lisp_Object tail
= lisp
;
408 json
= json_check (json_object ());
409 count
= SPECPDL_INDEX ();
410 record_unwind_protect_ptr (json_release_object
, json
);
411 bool is_plist
= !CONSP (XCAR (tail
));
416 Lisp_Object key_symbol
;
419 key_symbol
= XCAR (tail
);
423 if (EQ (tail
, li
.tortoise
)) circular_list (lisp
);
427 Lisp_Object pair
= XCAR (tail
);
429 key_symbol
= XCAR (pair
);
432 CHECK_SYMBOL (key_symbol
);
433 Lisp_Object key
= SYMBOL_NAME (key_symbol
);
434 /* We can't specify the length, so the string must be
436 check_string_without_embedded_nulls (key
);
437 key_str
= SSDATA (key
);
438 /* In plists, ensure leading ":" in keys is stripped. It
439 will be reconstructed later in `json_to_lisp'.*/
440 if (is_plist
&& ':' == key_str
[0] && key_str
[1])
442 key_str
= &key_str
[1];
444 /* Only add element if key is not already present. */
445 if (json_object_get (json
, key_str
) == NULL
)
448 = json_object_set_new (json
, key_str
, lisp_to_json (value
,
451 json_out_of_memory ();
454 CHECK_LIST_END (tail
, lisp
);
457 wrong_type_argument (Qjson_value_p
, lisp
);
459 clear_unwind_protect (count
);
460 unbind_to (count
, Qnil
);
464 /* Convert LISP to a toplevel JSON object (array or object). Signal
465 an error of type `wrong-type-argument' if LISP is not a vector,
466 hashtable, alist, or plist. */
469 lisp_to_json_toplevel (Lisp_Object lisp
, struct json_configuration
*conf
)
471 if (++lisp_eval_depth
> max_lisp_eval_depth
)
472 xsignal0 (Qjson_object_too_deep
);
473 json_t
*json
= lisp_to_json_toplevel_1 (lisp
, conf
);
478 /* Convert LISP to any JSON object. Signal an error of type
479 `wrong-type-argument' if the type of LISP can't be converted to a
483 lisp_to_json (Lisp_Object lisp
, struct json_configuration
*conf
)
485 if (EQ (lisp
, conf
->null_object
))
486 return json_check (json_null ());
487 else if (EQ (lisp
, conf
->false_object
))
488 return json_check (json_false ());
489 else if (EQ (lisp
, Qt
))
490 return json_check (json_true ());
491 else if (INTEGERP (lisp
))
493 intmax_t low
= TYPE_MINIMUM (json_int_t
);
494 intmax_t high
= TYPE_MAXIMUM (json_int_t
);
496 if (! integer_to_intmax (lisp
, &value
) || value
< low
|| high
< value
)
497 args_out_of_range_3 (lisp
, make_int (low
), make_int (high
));
498 return json_check (json_integer (value
));
500 else if (FLOATP (lisp
))
501 return json_check (json_real (XFLOAT_DATA (lisp
)));
502 else if (STRINGP (lisp
))
504 Lisp_Object encoded
= json_encode (lisp
);
505 json_t
*json
= json_stringn (SSDATA (encoded
), SBYTES (encoded
));
508 /* A failure can be caused either by an invalid string or by
510 json_check_utf8 (encoded
);
511 json_out_of_memory ();
516 /* LISP now must be a vector, hashtable, alist, or plist. */
517 return lisp_to_json_toplevel (lisp
, conf
);
521 json_parse_args (ptrdiff_t nargs
,
523 struct json_configuration
*conf
,
524 bool configure_object_type
)
526 if ((nargs
% 2) != 0)
527 wrong_type_argument (Qplistp
, Flist (nargs
, args
));
529 /* Start from the back so keyword values appearing
530 first take precedence. */
531 for (ptrdiff_t i
= nargs
; i
> 0; i
-= 2) {
532 Lisp_Object key
= args
[i
- 2];
533 Lisp_Object value
= args
[i
- 1];
534 if (configure_object_type
&& EQ (key
, QCobject_type
))
536 if (EQ (value
, Qhash_table
))
537 conf
->object_type
= json_object_hashtable
;
538 else if (EQ (value
, Qalist
))
539 conf
->object_type
= json_object_alist
;
540 else if (EQ (value
, Qplist
))
541 conf
->object_type
= json_object_plist
;
543 wrong_choice (list3 (Qhash_table
, Qalist
, Qplist
), value
);
545 else if (EQ (key
, QCnull_object
))
546 conf
->null_object
= value
;
547 else if (EQ (key
, QCfalse_object
))
548 conf
->false_object
= value
;
549 else if (configure_object_type
)
550 wrong_choice (list3 (QCobject_type
,
555 wrong_choice (list2 (QCnull_object
,
561 DEFUN ("json-serialize", Fjson_serialize
, Sjson_serialize
, 1, MANY
,
563 doc
: /* Return the JSON representation of OBJECT as a string.
565 OBJECT must be a vector, hashtable, alist, or plist and its elements
566 can recursively contain the Lisp equivalents to the JSON null and
567 false values, t, numbers, strings, or other vectors hashtables, alists
568 or plists. t will be converted to the JSON true value. Vectors will
569 be converted to JSON arrays, whereas hashtables, alists and plists are
570 converted to JSON objects. Hashtable keys must be strings without
571 embedded null characters and must be unique within each object. Alist
572 and plist keys must be symbols; if a key is duplicate, the first
575 The Lisp equivalents to the JSON null and false values are
576 configurable in the arguments ARGS, a list of keyword/argument pairs:
578 The keyword argument `:null-object' specifies which object to use
579 to represent a JSON null value. It defaults to `:null'.
581 The keyword argument `:false-object' specifies which object to use to
582 represent a JSON false value. It defaults to `:false'.
584 In you specify the same value for `:null-object' and `:false-object',
585 a potentially ambiguous situation, the JSON output will not contain
586 any JSON false values.
587 usage: (json-serialize OBJECT &rest ARGS) */)
588 (ptrdiff_t nargs
, Lisp_Object
*args
)
590 ptrdiff_t count
= SPECPDL_INDEX ();
593 if (!json_initialized
)
596 json_initialized
= init_json_functions ();
597 status
= json_initialized
? Qt
: Qnil
;
598 Vlibrary_cache
= Fcons (Fcons (Qjson
, status
), Vlibrary_cache
);
600 if (!json_initialized
)
602 message1 ("jansson library not found");
607 struct json_configuration conf
= {json_object_hashtable
, QCnull
, QCfalse
};
608 json_parse_args (nargs
- 1, args
+ 1, &conf
, false);
610 json_t
*json
= lisp_to_json_toplevel (args
[0], &conf
);
611 record_unwind_protect_ptr (json_release_object
, json
);
613 /* If desired, we might want to add the following flags:
614 JSON_DECODE_ANY, JSON_ALLOW_NUL. */
615 char *string
= json_dumps (json
, JSON_COMPACT
);
617 json_out_of_memory ();
618 record_unwind_protect_ptr (json_free
, string
);
620 return unbind_to (count
, json_build_string (string
));
623 struct json_buffer_and_size
630 json_insert (void *data
)
632 struct json_buffer_and_size
*buffer_and_size
= data
;
633 /* FIXME: This should be possible without creating an intermediate
636 = json_make_string (buffer_and_size
->buffer
, buffer_and_size
->size
);
641 struct json_insert_data
643 /* nil if json_insert succeeded, otherwise the symbol
644 Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */
648 /* Callback for json_dump_callback that inserts the UTF-8 string in
649 [BUFFER, BUFFER + SIZE) into the current buffer.
650 If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string,
651 an unspecified string is inserted into the buffer. DATA must point
652 to a structure of type json_insert_data. This function may not
653 exit nonlocally. It catches all nonlocal exits and stores them in
654 data->error for reraising. */
657 json_insert_callback (const char *buffer
, size_t size
, void *data
)
659 struct json_insert_data
*d
= data
;
660 struct json_buffer_and_size buffer_and_size
661 = {.buffer
= buffer
, .size
= size
};
662 d
->error
= internal_catch_all (json_insert
, &buffer_and_size
, Fidentity
);
663 return NILP (d
->error
) ? 0 : -1;
666 DEFUN ("json-insert", Fjson_insert
, Sjson_insert
, 1, MANY
,
668 doc
: /* Insert the JSON representation of OBJECT before point.
669 This is the same as (insert (json-serialize OBJECT)), but potentially
670 faster. See the function `json-serialize' for allowed values of
672 usage: (json-insert OBJECT &rest ARGS) */)
673 (ptrdiff_t nargs
, Lisp_Object
*args
)
675 ptrdiff_t count
= SPECPDL_INDEX ();
678 if (!json_initialized
)
681 json_initialized
= init_json_functions ();
682 status
= json_initialized
? Qt
: Qnil
;
683 Vlibrary_cache
= Fcons (Fcons (Qjson
, status
), Vlibrary_cache
);
685 if (!json_initialized
)
687 message1 ("jansson library not found");
692 struct json_configuration conf
= {json_object_hashtable
, QCnull
, QCfalse
};
693 json_parse_args (nargs
- 1, args
+ 1, &conf
, false);
695 json_t
*json
= lisp_to_json (args
[0], &conf
);
696 record_unwind_protect_ptr (json_release_object
, json
);
698 struct json_insert_data data
;
699 /* If desired, we might want to add the following flags:
700 JSON_DECODE_ANY, JSON_ALLOW_NUL. */
702 = json_dump_callback (json
, json_insert_callback
, &data
, JSON_COMPACT
);
705 if (CONSP (data
.error
))
706 xsignal (XCAR (data
.error
), XCDR (data
.error
));
708 json_out_of_memory ();
711 return unbind_to (count
, Qnil
);
714 /* Convert a JSON object to a Lisp object. */
716 static Lisp_Object
ARG_NONNULL ((1))
717 json_to_lisp (json_t
*json
, struct json_configuration
*conf
)
719 switch (json_typeof (json
))
722 return conf
->null_object
;
724 return conf
->false_object
;
729 json_int_t i
= json_integer_value (json
);
730 return INT_TO_INTEGER (i
);
733 return make_float (json_real_value (json
));
735 return json_make_string (json_string_value (json
),
736 json_string_length (json
));
739 if (++lisp_eval_depth
> max_lisp_eval_depth
)
740 xsignal0 (Qjson_object_too_deep
);
741 size_t size
= json_array_size (json
);
742 if (FIXNUM_OVERFLOW_P (size
))
744 Lisp_Object result
= Fmake_vector (make_fixed_natnum (size
), Qunbound
);
745 for (ptrdiff_t i
= 0; i
< size
; ++i
)
747 json_to_lisp (json_array_get (json
, i
), conf
));
753 if (++lisp_eval_depth
> max_lisp_eval_depth
)
754 xsignal0 (Qjson_object_too_deep
);
756 switch (conf
->object_type
)
758 case json_object_hashtable
:
760 size_t size
= json_object_size (json
);
761 if (FIXNUM_OVERFLOW_P (size
))
763 result
= CALLN (Fmake_hash_table
, QCtest
, Qequal
, QCsize
,
764 make_fixed_natnum (size
));
765 struct Lisp_Hash_Table
*h
= XHASH_TABLE (result
);
768 json_object_foreach (json
, key_str
, value
)
770 Lisp_Object key
= json_build_string (key_str
);
772 ptrdiff_t i
= hash_lookup (h
, key
, &hash
);
773 /* Keys in JSON objects are unique, so the key can't
776 hash_put (h
, key
, json_to_lisp (value
, conf
), hash
);
780 case json_object_alist
:
785 json_object_foreach (json
, key_str
, value
)
787 Lisp_Object key
= Fintern (json_build_string (key_str
), Qnil
);
789 = Fcons (Fcons (key
, json_to_lisp (value
, conf
)),
792 result
= Fnreverse (result
);
795 case json_object_plist
:
800 json_object_foreach (json
, key_str
, value
)
803 ptrdiff_t key_str_len
= strlen (key_str
);
804 char *keyword_key_str
= SAFE_ALLOCA (1 + key_str_len
+ 1);
805 keyword_key_str
[0] = ':';
806 strcpy (&keyword_key_str
[1], key_str
);
807 Lisp_Object key
= intern_1 (keyword_key_str
, key_str_len
+ 1);
808 /* Build the plist as value-key since we're going to
809 reverse it in the end.*/
810 result
= Fcons (key
, result
);
811 result
= Fcons (json_to_lisp (value
, conf
), result
);
814 result
= Fnreverse (result
);
818 /* Can't get here. */
825 /* Can't get here. */
829 DEFUN ("json-parse-string", Fjson_parse_string
, Sjson_parse_string
, 1, MANY
,
831 doc
: /* Parse the JSON STRING into a Lisp object.
833 This is essentially the reverse operation of `json-serialize', which
834 see. The returned object will be a vector, hashtable, alist, or
835 plist. Its elements will be the JSON null value, the JSON false
836 value, t, numbers, strings, or further vectors, hashtables, alists, or
837 plists. If there are duplicate keys in an object, all but the last
838 one are ignored. If STRING doesn't contain a valid JSON object, an
839 error of type `json-parse-error' is signaled. The arguments ARGS are
840 a list of keyword/argument pairs:
842 The keyword argument `:object-type' specifies which Lisp type is used
843 to represent objects; it can be `hash-table', `alist' or `plist'.
845 The keyword argument `:null-object' specifies which object to use
846 to represent a JSON null value. It defaults to `:null'.
848 The keyword argument `:false-object' specifies which object to use to
849 represent a JSON false value. It defaults to `:false'.
850 usage: (json-parse-string STRING &rest ARGS) */)
851 (ptrdiff_t nargs
, Lisp_Object
*args
)
853 ptrdiff_t count
= SPECPDL_INDEX ();
856 if (!json_initialized
)
859 json_initialized
= init_json_functions ();
860 status
= json_initialized
? Qt
: Qnil
;
861 Vlibrary_cache
= Fcons (Fcons (Qjson
, status
), Vlibrary_cache
);
863 if (!json_initialized
)
865 message1 ("jansson library not found");
870 Lisp_Object string
= args
[0];
871 Lisp_Object encoded
= json_encode (string
);
872 check_string_without_embedded_nulls (encoded
);
873 struct json_configuration conf
= {json_object_hashtable
, QCnull
, QCfalse
};
874 json_parse_args (nargs
- 1, args
+ 1, &conf
, true);
877 json_t
*object
= json_loads (SSDATA (encoded
), 0, &error
);
879 json_parse_error (&error
);
881 /* Avoid leaking the object in case of further errors. */
883 record_unwind_protect_ptr (json_release_object
, object
);
885 return unbind_to (count
, json_to_lisp (object
, &conf
));
888 struct json_read_buffer_data
890 /* Byte position of position to read the next chunk from. */
894 /* Callback for json_load_callback that reads from the current buffer.
895 DATA must point to a structure of type json_read_buffer_data.
896 data->point must point to the byte position to read from; after
897 reading, data->point is advanced accordingly. The buffer point
898 itself is ignored. This function may not exit nonlocally. */
901 json_read_buffer_callback (void *buffer
, size_t buflen
, void *data
)
903 struct json_read_buffer_data
*d
= data
;
905 /* First, parse from point to the gap or the end of the accessible
906 portion, whatever is closer. */
907 ptrdiff_t point
= d
->point
;
908 ptrdiff_t end
= BUFFER_CEILING_OF (point
) + 1;
909 ptrdiff_t count
= end
- point
;
912 memcpy (buffer
, BYTE_POS_ADDR (point
), count
);
917 DEFUN ("json-parse-buffer", Fjson_parse_buffer
, Sjson_parse_buffer
,
919 doc
: /* Read JSON object from current buffer starting at point.
920 This is similar to `json-parse-string', which see. Move point after
921 the end of the object if parsing was successful. On error, point is
923 usage: (json-parse-buffer &rest args) */)
924 (ptrdiff_t nargs
, Lisp_Object
*args
)
926 ptrdiff_t count
= SPECPDL_INDEX ();
929 if (!json_initialized
)
932 json_initialized
= init_json_functions ();
933 status
= json_initialized
? Qt
: Qnil
;
934 Vlibrary_cache
= Fcons (Fcons (Qjson
, status
), Vlibrary_cache
);
936 if (!json_initialized
)
938 message1 ("jansson library not found");
943 struct json_configuration conf
= {json_object_hashtable
, QCnull
, QCfalse
};
944 json_parse_args (nargs
, args
, &conf
, true);
946 ptrdiff_t point
= PT_BYTE
;
947 struct json_read_buffer_data data
= {.point
= point
};
949 json_t
*object
= json_load_callback (json_read_buffer_callback
, &data
,
950 JSON_DISABLE_EOF_CHECK
, &error
);
953 json_parse_error (&error
);
955 /* Avoid leaking the object in case of further errors. */
956 record_unwind_protect_ptr (json_release_object
, object
);
958 /* Convert and then move point only if everything succeeded. */
959 Lisp_Object lisp
= json_to_lisp (object
, &conf
);
961 /* Adjust point by how much we just read. */
962 point
+= error
.position
;
963 SET_PT_BOTH (BYTE_TO_CHAR (point
), point
);
965 return unbind_to (count
, lisp
);
968 /* Simplified version of 'define-error' that works with pure
972 define_error (Lisp_Object name
, const char *message
, Lisp_Object parent
)
974 eassert (SYMBOLP (name
));
975 eassert (SYMBOLP (parent
));
976 Lisp_Object parent_conditions
= Fget (parent
, Qerror_conditions
);
977 eassert (CONSP (parent_conditions
));
978 eassert (!NILP (Fmemq (parent
, parent_conditions
)));
979 eassert (NILP (Fmemq (name
, parent_conditions
)));
980 Fput (name
, Qerror_conditions
, pure_cons (name
, parent_conditions
));
981 Fput (name
, Qerror_message
, build_pure_c_string (message
));
987 DEFSYM (QCnull
, ":null");
988 DEFSYM (QCfalse
, ":false");
990 DEFSYM (Qstring_without_embedded_nulls_p
, "string-without-embedded-nulls-p");
991 DEFSYM (Qjson_value_p
, "json-value-p");
992 DEFSYM (Qutf_8_string_p
, "utf-8-string-p");
994 DEFSYM (Qjson_error
, "json-error");
995 DEFSYM (Qjson_out_of_memory
, "json-out-of-memory");
996 DEFSYM (Qjson_parse_error
, "json-parse-error");
997 DEFSYM (Qjson_end_of_file
, "json-end-of-file");
998 DEFSYM (Qjson_trailing_content
, "json-trailing-content");
999 DEFSYM (Qjson_object_too_deep
, "json-object-too-deep");
1000 define_error (Qjson_error
, "generic JSON error", Qerror
);
1001 define_error (Qjson_out_of_memory
,
1002 "not enough memory for creating JSON object", Qjson_error
);
1003 define_error (Qjson_parse_error
, "could not parse JSON stream",
1005 define_error (Qjson_end_of_file
, "end of JSON stream", Qjson_parse_error
);
1006 define_error (Qjson_trailing_content
, "trailing content after JSON stream",
1008 define_error (Qjson_object_too_deep
,
1009 "object cyclic or Lisp evaluation too deep", Qjson_error
);
1011 DEFSYM (Qpure
, "pure");
1012 DEFSYM (Qside_effect_free
, "side-effect-free");
1014 DEFSYM (Qjson_serialize
, "json-serialize");
1015 DEFSYM (Qjson_parse_string
, "json-parse-string");
1016 Fput (Qjson_serialize
, Qpure
, Qt
);
1017 Fput (Qjson_serialize
, Qside_effect_free
, Qt
);
1018 Fput (Qjson_parse_string
, Qpure
, Qt
);
1019 Fput (Qjson_parse_string
, Qside_effect_free
, Qt
);
1021 DEFSYM (QCobject_type
, ":object-type");
1022 DEFSYM (QCnull_object
, ":null-object");
1023 DEFSYM (QCfalse_object
, ":false-object");
1024 DEFSYM (Qalist
, "alist");
1025 DEFSYM (Qplist
, "plist");
1027 defsubr (&Sjson_serialize
);
1028 defsubr (&Sjson_insert
);
1029 defsubr (&Sjson_parse_string
);
1030 defsubr (&Sjson_parse_buffer
);