diff options
| -rw-r--r-- | configure.ac | 20 | ||||
| -rw-r--r-- | doc/lispref/text.texi | 87 | ||||
| -rw-r--r-- | etc/NEWS | 11 | ||||
| -rw-r--r-- | src/Makefile.in | 11 | ||||
| -rw-r--r-- | src/emacs.c | 8 | ||||
| -rw-r--r-- | src/eval.c | 54 | ||||
| -rw-r--r-- | src/json.c | 576 | ||||
| -rw-r--r-- | src/lisp.h | 7 | ||||
| -rw-r--r-- | test/src/json-tests.el | 97 |
9 files changed, 867 insertions, 4 deletions
diff --git a/configure.ac b/configure.ac index 61455a4b0fa..83369f763aa 100644 --- a/configure.ac +++ b/configure.ac | |||
| @@ -355,6 +355,7 @@ OPTION_DEFAULT_ON([libsystemd],[don't compile with libsystemd support]) | |||
| 355 | OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)]) | 355 | OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)]) |
| 356 | OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) | 356 | OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) |
| 357 | OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image support]) | 357 | OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image support]) |
| 358 | OPTION_DEFAULT_ON([json], [don't compile with native JSON support]) | ||
| 358 | 359 | ||
| 359 | OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) | 360 | OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) |
| 360 | OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support]) | 361 | OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support]) |
| @@ -2870,6 +2871,22 @@ fi | |||
| 2870 | AC_SUBST(LIBSYSTEMD_LIBS) | 2871 | AC_SUBST(LIBSYSTEMD_LIBS) |
| 2871 | AC_SUBST(LIBSYSTEMD_CFLAGS) | 2872 | AC_SUBST(LIBSYSTEMD_CFLAGS) |
| 2872 | 2873 | ||
| 2874 | HAVE_JSON=no | ||
| 2875 | JSON_OBJ= | ||
| 2876 | |||
| 2877 | if test "${with_json}" = yes; then | ||
| 2878 | EMACS_CHECK_MODULES([JSON], [jansson >= 2.5], | ||
| 2879 | [HAVE_JSON=yes], [HAVE_JSON=no]) | ||
| 2880 | if test "${HAVE_JSON}" = yes; then | ||
| 2881 | AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.]) | ||
| 2882 | JSON_OBJ=json.o | ||
| 2883 | fi | ||
| 2884 | fi | ||
| 2885 | |||
| 2886 | AC_SUBST(JSON_LIBS) | ||
| 2887 | AC_SUBST(JSON_CFLAGS) | ||
| 2888 | AC_SUBST(JSON_OBJ) | ||
| 2889 | |||
| 2873 | NOTIFY_OBJ= | 2890 | NOTIFY_OBJ= |
| 2874 | NOTIFY_SUMMARY=no | 2891 | NOTIFY_SUMMARY=no |
| 2875 | 2892 | ||
| @@ -5366,7 +5383,7 @@ emacs_config_features= | |||
| 5366 | for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ | 5383 | for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ |
| 5367 | GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \ | 5384 | GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \ |
| 5368 | LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 NS MODULES \ | 5385 | LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 NS MODULES \ |
| 5369 | XWIDGETS LIBSYSTEMD CANNOT_DUMP LCMS2; do | 5386 | XWIDGETS LIBSYSTEMD JSON CANNOT_DUMP LCMS2; do |
| 5370 | 5387 | ||
| 5371 | case $opt in | 5388 | case $opt in |
| 5372 | CANNOT_DUMP) eval val=\${$opt} ;; | 5389 | CANNOT_DUMP) eval val=\${$opt} ;; |
| @@ -5416,6 +5433,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D | |||
| 5416 | Does Emacs use -lotf? ${HAVE_LIBOTF} | 5433 | Does Emacs use -lotf? ${HAVE_LIBOTF} |
| 5417 | Does Emacs use -lxft? ${HAVE_XFT} | 5434 | Does Emacs use -lxft? ${HAVE_XFT} |
| 5418 | Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD} | 5435 | Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD} |
| 5436 | Does Emacs use -ljansson? ${HAVE_JSON} | ||
| 5419 | Does Emacs directly use zlib? ${HAVE_ZLIB} | 5437 | Does Emacs directly use zlib? ${HAVE_ZLIB} |
| 5420 | Does Emacs have dynamic modules support? ${HAVE_MODULES} | 5438 | Does Emacs have dynamic modules support? ${HAVE_MODULES} |
| 5421 | Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS} | 5439 | Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS} |
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 35ba5d0dddc..5b288d9750e 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi | |||
| @@ -61,6 +61,7 @@ the character after point. | |||
| 61 | * Checksum/Hash:: Computing cryptographic hashes. | 61 | * Checksum/Hash:: Computing cryptographic hashes. |
| 62 | * GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS. | 62 | * GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS. |
| 63 | * Parsing HTML/XML:: Parsing HTML and XML. | 63 | * Parsing HTML/XML:: Parsing HTML and XML. |
| 64 | * Parsing JSON:: Parsing and generating JSON values. | ||
| 64 | * Atomic Changes:: Installing several buffer changes atomically. | 65 | * Atomic Changes:: Installing several buffer changes atomically. |
| 65 | * Change Hooks:: Supplying functions to be run when text is changed. | 66 | * Change Hooks:: Supplying functions to be run when text is changed. |
| 66 | @end menu | 67 | @end menu |
| @@ -4934,6 +4935,92 @@ textual nodes that just contain white-space. | |||
| 4934 | @end table | 4935 | @end table |
| 4935 | 4936 | ||
| 4936 | 4937 | ||
| 4938 | @node Parsing JSON | ||
| 4939 | @section Parsing and generating JSON values | ||
| 4940 | @cindex JSON | ||
| 4941 | |||
| 4942 | When Emacs is compiled with JSON support, it provides a couple of | ||
| 4943 | functions to convert between Lisp objects and JSON values. Any JSON | ||
| 4944 | value can be converted to a Lisp object, but not vice versa. | ||
| 4945 | Specifically: | ||
| 4946 | |||
| 4947 | @itemize | ||
| 4948 | |||
| 4949 | @item | ||
| 4950 | JSON has a couple of keywords: @code{null}, @code{false}, and | ||
| 4951 | @code{true}. These are represented in Lisp using the keywords | ||
| 4952 | @code{:null}, @code{:false}, and @code{t}, respectively. | ||
| 4953 | |||
| 4954 | @item | ||
| 4955 | JSON only has floating-point numbers. They can represent both Lisp | ||
| 4956 | integers and Lisp floating-point numbers. | ||
| 4957 | |||
| 4958 | @item | ||
| 4959 | JSON strings are always Unicode strings. Lisp strings can contain | ||
| 4960 | non-Unicode characters. | ||
| 4961 | |||
| 4962 | @item | ||
| 4963 | JSON has only one sequence type, the array. JSON arrays are | ||
| 4964 | represented using Lisp vectors. | ||
| 4965 | |||
| 4966 | @item | ||
| 4967 | JSON has only one map type, the object. JSON objects are represented | ||
| 4968 | using Lisp hashtables. | ||
| 4969 | |||
| 4970 | @end itemize | ||
| 4971 | |||
| 4972 | @noindent | ||
| 4973 | Note that @code{nil} doesn't represent any JSON values: this is to | ||
| 4974 | avoid confusion, because @code{nil} could either represent | ||
| 4975 | @code{null}, @code{false}, or an empty array, all of which are | ||
| 4976 | different JSON values. | ||
| 4977 | |||
| 4978 | If some Lisp object can't be represented in JSON, the serialization | ||
| 4979 | functions will signal an error of type @code{wrong-type-argument}. | ||
| 4980 | The parsing functions will signal the following errors: | ||
| 4981 | |||
| 4982 | @table @code | ||
| 4983 | |||
| 4984 | @item json-end-of-file | ||
| 4985 | Signaled when encountering a premature end of the input text. | ||
| 4986 | |||
| 4987 | @item json-trailing-content | ||
| 4988 | Signaled when encountering unexpected input after the first JSON | ||
| 4989 | object parsed. | ||
| 4990 | |||
| 4991 | @item json-parse-error | ||
| 4992 | Signaled when encountering invalid JSON syntax. | ||
| 4993 | |||
| 4994 | @end table | ||
| 4995 | |||
| 4996 | Only top-level values (arrays and objects) can be serialized to | ||
| 4997 | JSON. The subobjects within these top-level values can be of any | ||
| 4998 | type. Likewise, the parsing functions will only return vectors and | ||
| 4999 | hashtables. | ||
| 5000 | |||
| 5001 | @defun json-serialize object | ||
| 5002 | This function returns a new Lisp string which contains the JSON | ||
| 5003 | representation of @var{object}. | ||
| 5004 | @end defun | ||
| 5005 | |||
| 5006 | @defun json-insert object | ||
| 5007 | This function inserts the JSON representation of @var{object} into the | ||
| 5008 | current buffer before point. | ||
| 5009 | @end defun | ||
| 5010 | |||
| 5011 | @defun json-parse-string string | ||
| 5012 | This function parses the JSON value in @var{string}, which must be a | ||
| 5013 | Lisp string. | ||
| 5014 | @end defun | ||
| 5015 | |||
| 5016 | @defun json-parse-buffer | ||
| 5017 | This function reads the next JSON value from the current buffer, | ||
| 5018 | starting at point. It moves point to the position immediately after | ||
| 5019 | the value if a value could be read and converted to Lisp; otherwise it | ||
| 5020 | doesn't move point. | ||
| 5021 | @end defun | ||
| 5022 | |||
| 5023 | |||
| 4937 | @node Atomic Changes | 5024 | @node Atomic Changes |
| 4938 | @section Atomic Change Groups | 5025 | @section Atomic Change Groups |
| 4939 | @cindex atomic changes | 5026 | @cindex atomic changes |
| @@ -24,6 +24,13 @@ When you add a new item, use the appropriate mark if you are sure it applies, | |||
| 24 | 24 | ||
| 25 | * Installation Changes in Emacs 27.1 | 25 | * Installation Changes in Emacs 27.1 |
| 26 | 26 | ||
| 27 | ** The new configure option '--with-json' adds support for JSON using | ||
| 28 | the Jansson library. It is on by default; use 'configure | ||
| 29 | --with-json=no' to build without Jansson support. The new JSON | ||
| 30 | functions 'json-serialize', 'json-insert', 'json-parse-string', and | ||
| 31 | 'json-parse-buffer' are typically much faster than their Lisp | ||
| 32 | counterparts from json.el. | ||
| 33 | |||
| 27 | 34 | ||
| 28 | * Startup Changes in Emacs 27.1 | 35 | * Startup Changes in Emacs 27.1 |
| 29 | 36 | ||
| @@ -164,6 +171,10 @@ remote systems, which support this check. | |||
| 164 | If the optional third argument is non-nil, 'make-string' will produce | 171 | If the optional third argument is non-nil, 'make-string' will produce |
| 165 | a multibyte string even if its second argument is an ASCII character. | 172 | a multibyte string even if its second argument is an ASCII character. |
| 166 | 173 | ||
| 174 | ** New JSON parsing and serialization functions 'json-serialize', | ||
| 175 | 'json-insert', 'json-parse-string', and 'json-parse-buffer'. These | ||
| 176 | are implemented in C using the Jansson library. | ||
| 177 | |||
| 167 | 178 | ||
| 168 | * Changes in Emacs 27.1 on Non-Free Operating Systems | 179 | * Changes in Emacs 27.1 on Non-Free Operating Systems |
| 169 | 180 | ||
diff --git a/src/Makefile.in b/src/Makefile.in index 9a8c9c85f04..b395627893d 100644 --- a/src/Makefile.in +++ b/src/Makefile.in | |||
| @@ -312,6 +312,10 @@ LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@ | |||
| 312 | LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@ | 312 | LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@ |
| 313 | LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@ | 313 | LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@ |
| 314 | 314 | ||
| 315 | JSON_LIBS = @JSON_LIBS@ | ||
| 316 | JSON_CFLAGS = @JSON_CFLAGS@ | ||
| 317 | JSON_OBJ = @JSON_OBJ@ | ||
| 318 | |||
| 315 | INTERVALS_H = dispextern.h intervals.h composite.h | 319 | INTERVALS_H = dispextern.h intervals.h composite.h |
| 316 | 320 | ||
| 317 | GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ | 321 | GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ |
| @@ -363,7 +367,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ | |||
| 363 | $(WEBKIT_CFLAGS) \ | 367 | $(WEBKIT_CFLAGS) \ |
| 364 | $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ | 368 | $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ |
| 365 | $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ | 369 | $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ |
| 366 | $(LIBSYSTEMD_CFLAGS) \ | 370 | $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ |
| 367 | $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ | 371 | $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ |
| 368 | $(WERROR_CFLAGS) | 372 | $(WERROR_CFLAGS) |
| 369 | ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) | 373 | ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) |
| @@ -397,7 +401,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ | |||
| 397 | thread.o systhread.o \ | 401 | thread.o systhread.o \ |
| 398 | $(if $(HYBRID_MALLOC),sheap.o) \ | 402 | $(if $(HYBRID_MALLOC),sheap.o) \ |
| 399 | $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ | 403 | $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ |
| 400 | $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) | 404 | $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) |
| 401 | obj = $(base_obj) $(NS_OBJC_OBJ) | 405 | obj = $(base_obj) $(NS_OBJC_OBJ) |
| 402 | 406 | ||
| 403 | ## Object files used on some machine or other. | 407 | ## Object files used on some machine or other. |
| @@ -493,7 +497,8 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ | |||
| 493 | $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ | 497 | $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ |
| 494 | $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ | 498 | $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ |
| 495 | $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \ | 499 | $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \ |
| 496 | $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) | 500 | $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ |
| 501 | $(JSON_LIBS) | ||
| 497 | 502 | ||
| 498 | ## FORCE it so that admin/unidata can decide whether these files | 503 | ## FORCE it so that admin/unidata can decide whether these files |
| 499 | ## are up-to-date. Although since charprop depends on bootstrap-emacs, | 504 | ## are up-to-date. Although since charprop depends on bootstrap-emacs, |
diff --git a/src/emacs.c b/src/emacs.c index 808abcd9aa2..7c1ae1f2c5b 100644 --- a/src/emacs.c +++ b/src/emacs.c | |||
| @@ -1262,6 +1262,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem | |||
| 1262 | running_asynch_code = 0; | 1262 | running_asynch_code = 0; |
| 1263 | init_random (); | 1263 | init_random (); |
| 1264 | 1264 | ||
| 1265 | #ifdef HAVE_JSON | ||
| 1266 | init_json (); | ||
| 1267 | #endif | ||
| 1268 | |||
| 1265 | no_loadup | 1269 | no_loadup |
| 1266 | = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); | 1270 | = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); |
| 1267 | 1271 | ||
| @@ -1608,6 +1612,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem | |||
| 1608 | syms_of_threads (); | 1612 | syms_of_threads (); |
| 1609 | syms_of_profiler (); | 1613 | syms_of_profiler (); |
| 1610 | 1614 | ||
| 1615 | #ifdef HAVE_JSON | ||
| 1616 | syms_of_json (); | ||
| 1617 | #endif | ||
| 1618 | |||
| 1611 | keys_of_casefiddle (); | 1619 | keys_of_casefiddle (); |
| 1612 | keys_of_cmds (); | 1620 | keys_of_cmds (); |
| 1613 | keys_of_buffer (); | 1621 | keys_of_buffer (); |
diff --git a/src/eval.c b/src/eval.c index 47c4f17eabc..b774fd06139 100644 --- a/src/eval.c +++ b/src/eval.c | |||
| @@ -1416,6 +1416,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), | |||
| 1416 | } | 1416 | } |
| 1417 | } | 1417 | } |
| 1418 | 1418 | ||
| 1419 | static Lisp_Object | ||
| 1420 | internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument) | ||
| 1421 | { | ||
| 1422 | struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL); | ||
| 1423 | if (c == NULL) | ||
| 1424 | return Qcatch_all_memory_full; | ||
| 1425 | |||
| 1426 | if (sys_setjmp (c->jmp) == 0) | ||
| 1427 | { | ||
| 1428 | Lisp_Object val = function (argument); | ||
| 1429 | eassert (handlerlist == c); | ||
| 1430 | handlerlist = c->next; | ||
| 1431 | return val; | ||
| 1432 | } | ||
| 1433 | else | ||
| 1434 | { | ||
| 1435 | eassert (handlerlist == c); | ||
| 1436 | Lisp_Object val = c->val; | ||
| 1437 | handlerlist = c->next; | ||
| 1438 | Fsignal (Qno_catch, val); | ||
| 1439 | } | ||
| 1440 | } | ||
| 1441 | |||
| 1442 | /* Like a combination of internal_condition_case_1 and internal_catch. | ||
| 1443 | Catches all signals and throws. Never exits nonlocally; returns | ||
| 1444 | Qcatch_all_memory_full if no handler could be allocated. */ | ||
| 1445 | |||
| 1446 | Lisp_Object | ||
| 1447 | internal_catch_all (Lisp_Object (*function) (void *), void *argument, | ||
| 1448 | Lisp_Object (*handler) (Lisp_Object)) | ||
| 1449 | { | ||
| 1450 | struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE); | ||
| 1451 | if (c == NULL) | ||
| 1452 | return Qcatch_all_memory_full; | ||
| 1453 | |||
| 1454 | if (sys_setjmp (c->jmp) == 0) | ||
| 1455 | { | ||
| 1456 | Lisp_Object val = internal_catch_all_1 (function, argument); | ||
| 1457 | eassert (handlerlist == c); | ||
| 1458 | handlerlist = c->next; | ||
| 1459 | return val; | ||
| 1460 | } | ||
| 1461 | else | ||
| 1462 | { | ||
| 1463 | eassert (handlerlist == c); | ||
| 1464 | Lisp_Object val = c->val; | ||
| 1465 | handlerlist = c->next; | ||
| 1466 | return handler (val); | ||
| 1467 | } | ||
| 1468 | } | ||
| 1469 | |||
| 1419 | struct handler * | 1470 | struct handler * |
| 1420 | push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype) | 1471 | push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype) |
| 1421 | { | 1472 | { |
| @@ -4067,6 +4118,9 @@ alist of active lexical bindings. */); | |||
| 4067 | 4118 | ||
| 4068 | inhibit_lisp_code = Qnil; | 4119 | inhibit_lisp_code = Qnil; |
| 4069 | 4120 | ||
| 4121 | DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full"); | ||
| 4122 | Funintern (Qcatch_all_memory_full, Qnil); | ||
| 4123 | |||
| 4070 | defsubr (&Sor); | 4124 | defsubr (&Sor); |
| 4071 | defsubr (&Sand); | 4125 | defsubr (&Sand); |
| 4072 | defsubr (&Sif); | 4126 | defsubr (&Sif); |
diff --git a/src/json.c b/src/json.c new file mode 100644 index 00000000000..dc449e43e11 --- /dev/null +++ b/src/json.c | |||
| @@ -0,0 +1,576 @@ | |||
| 1 | /* JSON parsing and serialization. | ||
| 2 | |||
| 3 | Copyright (C) 2017 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | This file is part of GNU Emacs. | ||
| 6 | |||
| 7 | GNU Emacs is free software: you can redistribute it and/or modify | ||
| 8 | it under the terms of the GNU General Public License as published by | ||
| 9 | the Free Software Foundation, either version 3 of the License, or (at | ||
| 10 | your option) any later version. | ||
| 11 | |||
| 12 | GNU Emacs is distributed in the hope that it will be useful, | ||
| 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 15 | GNU General Public License for more details. | ||
| 16 | |||
| 17 | You should have received a copy of the GNU General Public License | ||
| 18 | along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ | ||
| 19 | |||
| 20 | #include <config.h> | ||
| 21 | |||
| 22 | #include <errno.h> | ||
| 23 | #include <stddef.h> | ||
| 24 | #include <stdint.h> | ||
| 25 | #include <stdlib.h> | ||
| 26 | |||
| 27 | #include <jansson.h> | ||
| 28 | |||
| 29 | #include "lisp.h" | ||
| 30 | #include "buffer.h" | ||
| 31 | #include "coding.h" | ||
| 32 | |||
| 33 | /* We install a custom allocator so that we can avoid objects larger | ||
| 34 | than PTRDIFF_MAX. Such objects wouldn’t play well with the rest of | ||
| 35 | Emacs’s codebase, which generally uses ptrdiff_t for sizes and | ||
| 36 | indices. The other functions in this file also generally assume | ||
| 37 | that size_t values never exceed PTRDIFF_MAX. */ | ||
| 38 | |||
| 39 | static void * | ||
| 40 | json_malloc (size_t size) | ||
| 41 | { | ||
| 42 | if (size > PTRDIFF_MAX) | ||
| 43 | { | ||
| 44 | errno = ENOMEM; | ||
| 45 | return NULL; | ||
| 46 | } | ||
| 47 | return malloc (size); | ||
| 48 | } | ||
| 49 | |||
| 50 | static void | ||
| 51 | json_free (void *ptr) | ||
| 52 | { | ||
| 53 | free (ptr); | ||
| 54 | } | ||
| 55 | |||
| 56 | void | ||
| 57 | init_json (void) | ||
| 58 | { | ||
| 59 | json_set_alloc_funcs (json_malloc, json_free); | ||
| 60 | } | ||
| 61 | |||
| 62 | /* Return whether STRING starts with PREFIX. */ | ||
| 63 | |||
| 64 | static bool | ||
| 65 | json_has_prefix (const char *string, const char *prefix) | ||
| 66 | { | ||
| 67 | size_t string_len = strlen (string); | ||
| 68 | size_t prefix_len = strlen (prefix); | ||
| 69 | return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0; | ||
| 70 | } | ||
| 71 | |||
| 72 | /* Return whether STRING ends with SUFFIX. */ | ||
| 73 | |||
| 74 | static bool | ||
| 75 | json_has_suffix (const char *string, const char *suffix) | ||
| 76 | { | ||
| 77 | size_t string_len = strlen (string); | ||
| 78 | size_t suffix_len = strlen (suffix); | ||
| 79 | return string_len >= suffix_len | ||
| 80 | && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0; | ||
| 81 | } | ||
| 82 | |||
| 83 | /* Create a multibyte Lisp string from the UTF-8 string in | ||
| 84 | [DATA, DATA + SIZE). If the range [DATA, DATA + SIZE) does not | ||
| 85 | contain a valid UTF-8 string, an unspecified string is | ||
| 86 | returned. */ | ||
| 87 | |||
| 88 | static Lisp_Object | ||
| 89 | json_make_string (const char *data, ptrdiff_t size) | ||
| 90 | { | ||
| 91 | return code_convert_string (make_specified_string (data, -1, size, false), | ||
| 92 | Qutf_8_unix, Qt, false, true, true); | ||
| 93 | } | ||
| 94 | |||
| 95 | /* Create a multibyte Lisp string from the null-terminated UTF-8 | ||
| 96 | string beginning at DATA. If the string is not a valid UTF-8 | ||
| 97 | string, an unspecified string is returned. */ | ||
| 98 | |||
| 99 | static Lisp_Object | ||
| 100 | json_build_string (const char *data) | ||
| 101 | { | ||
| 102 | return json_make_string (data, strlen (data)); | ||
| 103 | } | ||
| 104 | |||
| 105 | /* Return a unibyte string containing the sequence of UTF-8 encoding | ||
| 106 | units of the UTF-8 representation of STRING. If STRING does not | ||
| 107 | represent a sequence of Unicode scalar values, return a string with | ||
| 108 | unspecified contents. */ | ||
| 109 | |||
| 110 | static Lisp_Object | ||
| 111 | json_encode (Lisp_Object string) | ||
| 112 | { | ||
| 113 | return code_convert_string (string, Qutf_8_unix, Qt, true, true, true); | ||
| 114 | } | ||
| 115 | |||
| 116 | static _Noreturn void | ||
| 117 | json_out_of_memory (void) | ||
| 118 | { | ||
| 119 | xsignal0 (Qjson_out_of_memory); | ||
| 120 | } | ||
| 121 | |||
| 122 | /* Signal a Lisp error corresponding to the JSON ERROR. */ | ||
| 123 | |||
| 124 | static _Noreturn void | ||
| 125 | json_parse_error (const json_error_t *error) | ||
| 126 | { | ||
| 127 | Lisp_Object symbol; | ||
| 128 | /* FIXME: Upstream Jansson should have a way to return error codes | ||
| 129 | without parsing the error messages. See | ||
| 130 | https://github.com/akheron/jansson/issues/352. */ | ||
| 131 | if (json_has_suffix (error->text, "expected near end of file")) | ||
| 132 | symbol = Qjson_end_of_file; | ||
| 133 | else if (json_has_prefix (error->text, "end of file expected")) | ||
| 134 | symbol = Qjson_trailing_content; | ||
| 135 | else | ||
| 136 | symbol = Qjson_parse_error; | ||
| 137 | xsignal (symbol, | ||
| 138 | list5 (json_build_string (error->text), | ||
| 139 | json_build_string (error->source), make_natnum (error->line), | ||
| 140 | make_natnum (error->column), make_natnum (error->position))); | ||
| 141 | } | ||
| 142 | |||
| 143 | static void | ||
| 144 | json_release_object (void *object) | ||
| 145 | { | ||
| 146 | json_decref (object); | ||
| 147 | } | ||
| 148 | |||
| 149 | /* Signal an error if OBJECT is not a string, or if OBJECT contains | ||
| 150 | embedded null characters. */ | ||
| 151 | |||
| 152 | static void | ||
| 153 | check_string_without_embedded_nulls (Lisp_Object object) | ||
| 154 | { | ||
| 155 | CHECK_STRING (object); | ||
| 156 | CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL, | ||
| 157 | Qstring_without_embedded_nulls_p, object); | ||
| 158 | } | ||
| 159 | |||
| 160 | /* Signal an error of type `json-out-of-memory' if OBJECT is | ||
| 161 | NULL. */ | ||
| 162 | |||
| 163 | static json_t * | ||
| 164 | json_check (json_t *object) | ||
| 165 | { | ||
| 166 | if (object == NULL) | ||
| 167 | json_out_of_memory (); | ||
| 168 | return object; | ||
| 169 | } | ||
| 170 | |||
| 171 | static json_t *lisp_to_json (Lisp_Object); | ||
| 172 | |||
| 173 | /* Convert a Lisp object to a toplevel JSON object (array or object). | ||
| 174 | This returns Lisp_Object so we can use unbind_to. The return value | ||
| 175 | is always nil. */ | ||
| 176 | |||
| 177 | static _GL_ARG_NONNULL ((2)) Lisp_Object | ||
| 178 | lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json) | ||
| 179 | { | ||
| 180 | if (VECTORP (lisp)) | ||
| 181 | { | ||
| 182 | ptrdiff_t size = ASIZE (lisp); | ||
| 183 | *json = json_check (json_array ()); | ||
| 184 | ptrdiff_t count = SPECPDL_INDEX (); | ||
| 185 | record_unwind_protect_ptr (json_release_object, json); | ||
| 186 | for (ptrdiff_t i = 0; i < size; ++i) | ||
| 187 | { | ||
| 188 | int status | ||
| 189 | = json_array_append_new (*json, lisp_to_json (AREF (lisp, i))); | ||
| 190 | if (status == -1) | ||
| 191 | json_out_of_memory (); | ||
| 192 | } | ||
| 193 | eassert (json_array_size (*json) == size); | ||
| 194 | clear_unwind_protect (count); | ||
| 195 | return unbind_to (count, Qnil); | ||
| 196 | } | ||
| 197 | else if (HASH_TABLE_P (lisp)) | ||
| 198 | { | ||
| 199 | struct Lisp_Hash_Table *h = XHASH_TABLE (lisp); | ||
| 200 | *json = json_check (json_object ()); | ||
| 201 | ptrdiff_t count = SPECPDL_INDEX (); | ||
| 202 | record_unwind_protect_ptr (json_release_object, *json); | ||
| 203 | for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) | ||
| 204 | if (!NILP (HASH_HASH (h, i))) | ||
| 205 | { | ||
| 206 | Lisp_Object key = json_encode (HASH_KEY (h, i)); | ||
| 207 | /* We can’t specify the length, so the string must be | ||
| 208 | null-terminated. */ | ||
| 209 | check_string_without_embedded_nulls (key); | ||
| 210 | int status = json_object_set_new (*json, SSDATA (key), | ||
| 211 | lisp_to_json (HASH_VALUE (h, i))); | ||
| 212 | if (status == -1) | ||
| 213 | json_out_of_memory (); | ||
| 214 | } | ||
| 215 | clear_unwind_protect (count); | ||
| 216 | return unbind_to (count, Qnil); | ||
| 217 | } | ||
| 218 | wrong_type_argument (Qjson_value_p, lisp); | ||
| 219 | } | ||
| 220 | |||
| 221 | /* Convert LISP to a toplevel JSON object (array or object). Signal | ||
| 222 | an error of type `wrong-type-argument' if LISP is not a vector or | ||
| 223 | hashtable. */ | ||
| 224 | |||
| 225 | static json_t * | ||
| 226 | lisp_to_json_toplevel (Lisp_Object lisp) | ||
| 227 | { | ||
| 228 | if (++lisp_eval_depth > max_lisp_eval_depth) | ||
| 229 | xsignal0 (Qjson_object_too_deep); | ||
| 230 | json_t *json; | ||
| 231 | lisp_to_json_toplevel_1 (lisp, &json); | ||
| 232 | --lisp_eval_depth; | ||
| 233 | return json; | ||
| 234 | } | ||
| 235 | |||
| 236 | /* Convert LISP to any JSON object. Signal an error of type | ||
| 237 | `wrong-type-argument' if the type of LISP can't be converted to a | ||
| 238 | JSON object. */ | ||
| 239 | |||
| 240 | static json_t * | ||
| 241 | lisp_to_json (Lisp_Object lisp) | ||
| 242 | { | ||
| 243 | if (EQ (lisp, QCnull)) | ||
| 244 | return json_check (json_null ()); | ||
| 245 | else if (EQ (lisp, QCfalse)) | ||
| 246 | return json_check (json_false ()); | ||
| 247 | else if (EQ (lisp, Qt)) | ||
| 248 | return json_check (json_true ()); | ||
| 249 | else if (INTEGERP (lisp)) | ||
| 250 | { | ||
| 251 | CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp); | ||
| 252 | return json_check (json_integer (XINT (lisp))); | ||
| 253 | } | ||
| 254 | else if (FLOATP (lisp)) | ||
| 255 | return json_check (json_real (XFLOAT_DATA (lisp))); | ||
| 256 | else if (STRINGP (lisp)) | ||
| 257 | { | ||
| 258 | Lisp_Object encoded = json_encode (lisp); | ||
| 259 | ptrdiff_t size = SBYTES (encoded); | ||
| 260 | return json_check (json_stringn (SSDATA (encoded), size)); | ||
| 261 | } | ||
| 262 | |||
| 263 | /* LISP now must be a vector or hashtable. */ | ||
| 264 | return lisp_to_json_toplevel (lisp); | ||
| 265 | } | ||
| 266 | |||
| 267 | DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL, | ||
| 268 | doc: /* Return the JSON representation of OBJECT as a string. | ||
| 269 | OBJECT must be a vector or hashtable, and its elements can recursively | ||
| 270 | contain `:null', `:false', t, numbers, strings, or other vectors and | ||
| 271 | hashtables. `:null', `:false', and t will be converted to JSON null, | ||
| 272 | false, and true values, respectively. Vectors will be converted to | ||
| 273 | JSON arrays, and hashtables to JSON objects. Hashtable keys must be | ||
| 274 | strings without embedded null characters and must be unique within | ||
| 275 | each object. */) | ||
| 276 | (Lisp_Object object) | ||
| 277 | { | ||
| 278 | ptrdiff_t count = SPECPDL_INDEX (); | ||
| 279 | |||
| 280 | json_t *json = lisp_to_json_toplevel (object); | ||
| 281 | record_unwind_protect_ptr (json_release_object, json); | ||
| 282 | |||
| 283 | char *string = json_dumps (json, JSON_COMPACT); | ||
| 284 | if (string == NULL) | ||
| 285 | json_out_of_memory (); | ||
| 286 | record_unwind_protect_ptr (free, string); | ||
| 287 | |||
| 288 | return unbind_to (count, json_build_string (string)); | ||
| 289 | } | ||
| 290 | |||
| 291 | struct json_buffer_and_size | ||
| 292 | { | ||
| 293 | const char *buffer; | ||
| 294 | ptrdiff_t size; | ||
| 295 | }; | ||
| 296 | |||
| 297 | static Lisp_Object | ||
| 298 | json_insert (void *data) | ||
| 299 | { | ||
| 300 | struct json_buffer_and_size *buffer_and_size = data; | ||
| 301 | /* FIXME: This should be possible without creating an intermediate | ||
| 302 | string object. */ | ||
| 303 | Lisp_Object string | ||
| 304 | = json_make_string (buffer_and_size->buffer, buffer_and_size->size); | ||
| 305 | insert1 (string); | ||
| 306 | return Qnil; | ||
| 307 | } | ||
| 308 | |||
| 309 | struct json_insert_data | ||
| 310 | { | ||
| 311 | /* nil if json_insert succeeded, otherwise the symbol | ||
| 312 | Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */ | ||
| 313 | Lisp_Object error; | ||
| 314 | }; | ||
| 315 | |||
| 316 | /* Callback for json_dump_callback that inserts the UTF-8 string in | ||
| 317 | [BUFFER, BUFFER + SIZE) into the current buffer. | ||
| 318 | If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string, | ||
| 319 | an unspecified string is inserted into the buffer. DATA must point | ||
| 320 | to a structure of type json_insert_data. This function may not | ||
| 321 | exit nonlocally. It catches all nonlocal exits and stores them in | ||
| 322 | data->error for reraising. */ | ||
| 323 | |||
| 324 | static int | ||
| 325 | json_insert_callback (const char *buffer, size_t size, void *data) | ||
| 326 | { | ||
| 327 | struct json_insert_data *d = data; | ||
| 328 | struct json_buffer_and_size buffer_and_size | ||
| 329 | = {.buffer = buffer, .size = size}; | ||
| 330 | d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity); | ||
| 331 | return NILP (d->error) ? 0 : -1; | ||
| 332 | } | ||
| 333 | |||
| 334 | DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL, | ||
| 335 | doc: /* Insert the JSON representation of OBJECT before point. | ||
| 336 | This is the same as (insert (json-serialize OBJECT)), but potentially | ||
| 337 | faster. See the function `json-serialize' for allowed values of | ||
| 338 | OBJECT. */) | ||
| 339 | (Lisp_Object object) | ||
| 340 | { | ||
| 341 | ptrdiff_t count = SPECPDL_INDEX (); | ||
| 342 | |||
| 343 | json_t *json = lisp_to_json (object); | ||
| 344 | record_unwind_protect_ptr (json_release_object, json); | ||
| 345 | |||
| 346 | struct json_insert_data data; | ||
| 347 | int status | ||
| 348 | = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT); | ||
| 349 | if (status == -1) | ||
| 350 | { | ||
| 351 | if (CONSP (data.error)) | ||
| 352 | xsignal (XCAR (data.error), XCDR (data.error)); | ||
| 353 | else | ||
| 354 | json_out_of_memory (); | ||
| 355 | } | ||
| 356 | |||
| 357 | return unbind_to (count, Qnil); | ||
| 358 | } | ||
| 359 | |||
| 360 | /* Convert a JSON object to a Lisp object. */ | ||
| 361 | |||
| 362 | static _GL_ARG_NONNULL ((1)) Lisp_Object | ||
| 363 | json_to_lisp (json_t *json) | ||
| 364 | { | ||
| 365 | switch (json_typeof (json)) | ||
| 366 | { | ||
| 367 | case JSON_NULL: | ||
| 368 | return QCnull; | ||
| 369 | case JSON_FALSE: | ||
| 370 | return QCfalse; | ||
| 371 | case JSON_TRUE: | ||
| 372 | return Qt; | ||
| 373 | case JSON_INTEGER: | ||
| 374 | /* Return an integer if possible, a floating-point number | ||
| 375 | otherwise. This loses precision for integers with large | ||
| 376 | magnitude; however, such integers tend to be nonportable | ||
| 377 | anyway because many JSON implementations use only 64-bit | ||
| 378 | floating-point numbers with 53 mantissa bits. See | ||
| 379 | https://tools.ietf.org/html/rfc7159#section-6 for some | ||
| 380 | discussion. */ | ||
| 381 | return make_fixnum_or_float (json_integer_value (json)); | ||
| 382 | case JSON_REAL: | ||
| 383 | return make_float (json_real_value (json)); | ||
| 384 | case JSON_STRING: | ||
| 385 | return json_make_string (json_string_value (json), | ||
| 386 | json_string_length (json)); | ||
| 387 | case JSON_ARRAY: | ||
| 388 | { | ||
| 389 | if (++lisp_eval_depth > max_lisp_eval_depth) | ||
| 390 | xsignal0 (Qjson_object_too_deep); | ||
| 391 | size_t size = json_array_size (json); | ||
| 392 | if (FIXNUM_OVERFLOW_P (size)) | ||
| 393 | xsignal0 (Qoverflow_error); | ||
| 394 | Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound); | ||
| 395 | for (ptrdiff_t i = 0; i < size; ++i) | ||
| 396 | ASET (result, i, | ||
| 397 | json_to_lisp (json_array_get (json, i))); | ||
| 398 | --lisp_eval_depth; | ||
| 399 | return result; | ||
| 400 | } | ||
| 401 | case JSON_OBJECT: | ||
| 402 | { | ||
| 403 | if (++lisp_eval_depth > max_lisp_eval_depth) | ||
| 404 | xsignal0 (Qjson_object_too_deep); | ||
| 405 | size_t size = json_object_size (json); | ||
| 406 | if (FIXNUM_OVERFLOW_P (size)) | ||
| 407 | xsignal0 (Qoverflow_error); | ||
| 408 | Lisp_Object result = CALLN (Fmake_hash_table, QCtest, Qequal, | ||
| 409 | QCsize, make_natnum (size)); | ||
| 410 | struct Lisp_Hash_Table *h = XHASH_TABLE (result); | ||
| 411 | const char *key_str; | ||
| 412 | json_t *value; | ||
| 413 | json_object_foreach (json, key_str, value) | ||
| 414 | { | ||
| 415 | Lisp_Object key = json_build_string (key_str); | ||
| 416 | EMACS_UINT hash; | ||
| 417 | ptrdiff_t i = hash_lookup (h, key, &hash); | ||
| 418 | /* Keys in JSON objects are unique, so the key can’t be | ||
| 419 | present yet. */ | ||
| 420 | eassert (i < 0); | ||
| 421 | hash_put (h, key, json_to_lisp (value), hash); | ||
| 422 | } | ||
| 423 | --lisp_eval_depth; | ||
| 424 | return result; | ||
| 425 | } | ||
| 426 | } | ||
| 427 | /* Can’t get here. */ | ||
| 428 | emacs_abort (); | ||
| 429 | } | ||
| 430 | |||
| 431 | DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, 1, NULL, | ||
| 432 | doc: /* Parse the JSON STRING into a Lisp object. | ||
| 433 | This is essentially the reverse operation of `json-serialize', which | ||
| 434 | see. The returned object will be a vector or hashtable. Its elements | ||
| 435 | will be `:null', `:false', t, numbers, strings, or further vectors and | ||
| 436 | hashtables. If there are duplicate keys in an object, all but the | ||
| 437 | last one are ignored. If STRING doesn't contain a valid JSON object, | ||
| 438 | an error of type `json-parse-error' is signaled. */) | ||
| 439 | (Lisp_Object string) | ||
| 440 | { | ||
| 441 | ptrdiff_t count = SPECPDL_INDEX (); | ||
| 442 | Lisp_Object encoded = json_encode (string); | ||
| 443 | check_string_without_embedded_nulls (encoded); | ||
| 444 | |||
| 445 | json_error_t error; | ||
| 446 | json_t *object = json_loads (SSDATA (encoded), 0, &error); | ||
| 447 | if (object == NULL) | ||
| 448 | json_parse_error (&error); | ||
| 449 | |||
| 450 | /* Avoid leaking the object in case of further errors. */ | ||
| 451 | if (object != NULL) | ||
| 452 | record_unwind_protect_ptr (json_release_object, object); | ||
| 453 | |||
| 454 | return unbind_to (count, json_to_lisp (object)); | ||
| 455 | } | ||
| 456 | |||
| 457 | struct json_read_buffer_data | ||
| 458 | { | ||
| 459 | /* Byte position of position to read the next chunk from. */ | ||
| 460 | ptrdiff_t point; | ||
| 461 | }; | ||
| 462 | |||
| 463 | /* Callback for json_load_callback that reads from the current buffer. | ||
| 464 | DATA must point to a structure of type json_read_buffer_data. | ||
| 465 | data->point must point to the byte position to read from; after | ||
| 466 | reading, data->point is advanced accordingly. The buffer point | ||
| 467 | itself is ignored. This function may not exit nonlocally. */ | ||
| 468 | |||
| 469 | static size_t | ||
| 470 | json_read_buffer_callback (void *buffer, size_t buflen, void *data) | ||
| 471 | { | ||
| 472 | struct json_read_buffer_data *d = data; | ||
| 473 | |||
| 474 | /* First, parse from point to the gap or the end of the accessible | ||
| 475 | portion, whatever is closer. */ | ||
| 476 | ptrdiff_t point = d->point; | ||
| 477 | ptrdiff_t end = BUFFER_CEILING_OF (point) + 1; | ||
| 478 | ptrdiff_t count = end - point; | ||
| 479 | if (buflen < count) | ||
| 480 | count = buflen; | ||
| 481 | memcpy (buffer, BYTE_POS_ADDR (point), count); | ||
| 482 | d->point += count; | ||
| 483 | return count; | ||
| 484 | } | ||
| 485 | |||
| 486 | DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer, | ||
| 487 | 0, 0, NULL, | ||
| 488 | doc: /* Read JSON object from current buffer starting at point. | ||
| 489 | This is similar to `json-parse-string', which see. Move point after | ||
| 490 | the end of the object if parsing was successful. On error, point is | ||
| 491 | not moved. */) | ||
| 492 | (void) | ||
| 493 | { | ||
| 494 | ptrdiff_t count = SPECPDL_INDEX (); | ||
| 495 | |||
| 496 | ptrdiff_t point = PT_BYTE; | ||
| 497 | struct json_read_buffer_data data = {.point = point}; | ||
| 498 | json_error_t error; | ||
| 499 | json_t *object = json_load_callback (json_read_buffer_callback, &data, | ||
| 500 | JSON_DISABLE_EOF_CHECK, &error); | ||
| 501 | |||
| 502 | if (object == NULL) | ||
| 503 | json_parse_error (&error); | ||
| 504 | |||
| 505 | /* Avoid leaking the object in case of further errors. */ | ||
| 506 | record_unwind_protect_ptr (json_release_object, object); | ||
| 507 | |||
| 508 | /* Convert and then move point only if everything succeeded. */ | ||
| 509 | Lisp_Object lisp = json_to_lisp (object); | ||
| 510 | |||
| 511 | /* Adjust point by how much we just read. */ | ||
| 512 | point += error.position; | ||
| 513 | SET_PT_BOTH (BYTE_TO_CHAR (point), point); | ||
| 514 | |||
| 515 | return unbind_to (count, lisp); | ||
| 516 | } | ||
| 517 | |||
| 518 | /* Simplified version of ‘define-error’ that works with pure | ||
| 519 | objects. */ | ||
| 520 | |||
| 521 | static void | ||
| 522 | define_error (Lisp_Object name, const char *message, Lisp_Object parent) | ||
| 523 | { | ||
| 524 | eassert (SYMBOLP (name)); | ||
| 525 | eassert (SYMBOLP (parent)); | ||
| 526 | Lisp_Object parent_conditions = Fget (parent, Qerror_conditions); | ||
| 527 | eassert (CONSP (parent_conditions)); | ||
| 528 | eassert (!NILP (Fmemq (parent, parent_conditions))); | ||
| 529 | eassert (NILP (Fmemq (name, parent_conditions))); | ||
| 530 | Fput (name, Qerror_conditions, pure_cons (name, parent_conditions)); | ||
| 531 | Fput (name, Qerror_message, build_pure_c_string (message)); | ||
| 532 | } | ||
| 533 | |||
| 534 | void | ||
| 535 | syms_of_json (void) | ||
| 536 | { | ||
| 537 | DEFSYM (QCnull, ":null"); | ||
| 538 | DEFSYM (QCfalse, ":false"); | ||
| 539 | |||
| 540 | DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p"); | ||
| 541 | DEFSYM (Qjson_value_p, "json-value-p"); | ||
| 542 | |||
| 543 | DEFSYM (Qutf_8_unix, "utf-8-unix"); | ||
| 544 | |||
| 545 | DEFSYM (Qjson_error, "json-error"); | ||
| 546 | DEFSYM (Qjson_out_of_memory, "json-out-of-memory"); | ||
| 547 | DEFSYM (Qjson_parse_error, "json-parse-error"); | ||
| 548 | DEFSYM (Qjson_end_of_file, "json-end-of-file"); | ||
| 549 | DEFSYM (Qjson_trailing_content, "json-trailing-content"); | ||
| 550 | DEFSYM (Qjson_object_too_deep, "json-object-too-deep"); | ||
| 551 | define_error (Qjson_error, "generic JSON error", Qerror); | ||
| 552 | define_error (Qjson_out_of_memory, | ||
| 553 | "not enough memory for creating JSON object", Qjson_error); | ||
| 554 | define_error (Qjson_parse_error, "could not parse JSON stream", | ||
| 555 | Qjson_error); | ||
| 556 | define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error); | ||
| 557 | define_error (Qjson_trailing_content, "trailing content after JSON stream", | ||
| 558 | Qjson_parse_error); | ||
| 559 | define_error (Qjson_object_too_deep, | ||
| 560 | "object cyclic or Lisp evaluation too deep", Qjson_error); | ||
| 561 | |||
| 562 | DEFSYM (Qpure, "pure"); | ||
| 563 | DEFSYM (Qside_effect_free, "side-effect-free"); | ||
| 564 | |||
| 565 | DEFSYM (Qjson_serialize, "json-serialize"); | ||
| 566 | DEFSYM (Qjson_parse_string, "json-parse-string"); | ||
| 567 | Fput (Qjson_serialize, Qpure, Qt); | ||
| 568 | Fput (Qjson_serialize, Qside_effect_free, Qt); | ||
| 569 | Fput (Qjson_parse_string, Qpure, Qt); | ||
| 570 | Fput (Qjson_parse_string, Qside_effect_free, Qt); | ||
| 571 | |||
| 572 | defsubr (&Sjson_serialize); | ||
| 573 | defsubr (&Sjson_insert); | ||
| 574 | defsubr (&Sjson_parse_string); | ||
| 575 | defsubr (&Sjson_parse_buffer); | ||
| 576 | } | ||
diff --git a/src/lisp.h b/src/lisp.h index 68824d6b393..91ed14fa4c9 100644 --- a/src/lisp.h +++ b/src/lisp.h | |||
| @@ -3452,6 +3452,12 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_t); | |||
| 3452 | extern void reset_image_types (void); | 3452 | extern void reset_image_types (void); |
| 3453 | extern void syms_of_image (void); | 3453 | extern void syms_of_image (void); |
| 3454 | 3454 | ||
| 3455 | #ifdef HAVE_JSON | ||
| 3456 | /* Defined in json.c. */ | ||
| 3457 | extern void init_json (void); | ||
| 3458 | extern void syms_of_json (void); | ||
| 3459 | #endif | ||
| 3460 | |||
| 3455 | /* Defined in insdel.c. */ | 3461 | /* Defined in insdel.c. */ |
| 3456 | extern void move_gap_both (ptrdiff_t, ptrdiff_t); | 3462 | extern void move_gap_both (ptrdiff_t, ptrdiff_t); |
| 3457 | extern _Noreturn void buffer_overflow (void); | 3463 | extern _Noreturn void buffer_overflow (void); |
| @@ -3875,6 +3881,7 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp | |||
| 3875 | extern Lisp_Object internal_condition_case_n | 3881 | extern Lisp_Object internal_condition_case_n |
| 3876 | (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, | 3882 | (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, |
| 3877 | Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); | 3883 | Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); |
| 3884 | extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (Lisp_Object)); | ||
| 3878 | extern struct handler *push_handler (Lisp_Object, enum handlertype); | 3885 | extern struct handler *push_handler (Lisp_Object, enum handlertype); |
| 3879 | extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype); | 3886 | extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype); |
| 3880 | extern void specbind (Lisp_Object, Lisp_Object); | 3887 | extern void specbind (Lisp_Object, Lisp_Object); |
diff --git a/test/src/json-tests.el b/test/src/json-tests.el new file mode 100644 index 00000000000..5d3c84a136c --- /dev/null +++ b/test/src/json-tests.el | |||
| @@ -0,0 +1,97 @@ | |||
| 1 | ;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*- | ||
| 2 | |||
| 3 | ;; Copyright (C) 2017 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; This file is part of GNU Emacs. | ||
| 6 | |||
| 7 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 8 | ;; it under the terms of the GNU General Public License as published by | ||
| 9 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 10 | ;; (at 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 | ;;; Commentary: | ||
| 21 | |||
| 22 | ;; Unit tests for src/json.c. | ||
| 23 | |||
| 24 | ;;; Code: | ||
| 25 | |||
| 26 | (require 'cl-lib) | ||
| 27 | (require 'map) | ||
| 28 | |||
| 29 | (ert-deftest json-serialize/roundtrip () | ||
| 30 | (let ((lisp [:null :false t 0 123 -456 3.75 "abcαβγ"]) | ||
| 31 | (json "[null,false,true,0,123,-456,3.75,\"abcαβγ\"]")) | ||
| 32 | (should (equal (json-serialize lisp) json)) | ||
| 33 | (with-temp-buffer | ||
| 34 | (json-insert lisp) | ||
| 35 | (should (equal (buffer-string) json)) | ||
| 36 | (should (eobp))) | ||
| 37 | (should (equal (json-parse-string json) lisp)) | ||
| 38 | (with-temp-buffer | ||
| 39 | (insert json) | ||
| 40 | (goto-char 1) | ||
| 41 | (should (equal (json-parse-buffer) lisp)) | ||
| 42 | (should (eobp))))) | ||
| 43 | |||
| 44 | (ert-deftest json-serialize/object () | ||
| 45 | (let ((table (make-hash-table :test #'equal))) | ||
| 46 | (puthash "abc" [1 2 t] table) | ||
| 47 | (puthash "def" :null table) | ||
| 48 | (should (equal (json-serialize table) | ||
| 49 | "{\"abc\":[1,2,true],\"def\":null}")))) | ||
| 50 | |||
| 51 | (ert-deftest json-parse-string/object () | ||
| 52 | (let ((actual | ||
| 53 | (json-parse-string | ||
| 54 | "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n"))) | ||
| 55 | (should (hash-table-p actual)) | ||
| 56 | (should (equal (hash-table-count actual) 2)) | ||
| 57 | (should (equal (cl-sort (map-pairs actual) #'string< :key #'car) | ||
| 58 | '(("abc" . [9 :false]) ("def" . :null)))))) | ||
| 59 | |||
| 60 | (ert-deftest json-parse-string/string () | ||
| 61 | (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error) | ||
| 62 | (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""])) | ||
| 63 | (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"])) | ||
| 64 | (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"]") | ||
| 65 | ["\nasdфывfgh\t"])) | ||
| 66 | (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"])) | ||
| 67 | (should-error (json-parse-string "foo") :type 'json-parse-error)) | ||
| 68 | |||
| 69 | (ert-deftest json-serialize/string () | ||
| 70 | (should (equal (json-serialize ["foo"]) "[\"foo\"]")) | ||
| 71 | (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]")) | ||
| 72 | (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"]) | ||
| 73 | "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]"))) | ||
| 74 | |||
| 75 | (ert-deftest json-parse-string/incomplete () | ||
| 76 | (should-error (json-parse-string "[123") :type 'json-end-of-file)) | ||
| 77 | |||
| 78 | (ert-deftest json-parse-string/trailing () | ||
| 79 | (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content)) | ||
| 80 | |||
| 81 | (ert-deftest json-parse-buffer/incomplete () | ||
| 82 | (with-temp-buffer | ||
| 83 | (insert "[123") | ||
| 84 | (goto-char 1) | ||
| 85 | (should-error (json-parse-buffer) :type 'json-end-of-file) | ||
| 86 | (should (bobp)))) | ||
| 87 | |||
| 88 | (ert-deftest json-parse-buffer/trailing () | ||
| 89 | (with-temp-buffer | ||
| 90 | (insert "[123] [456]") | ||
| 91 | (goto-char 1) | ||
| 92 | (should (equal (json-parse-buffer) [123])) | ||
| 93 | (should-not (bobp)) | ||
| 94 | (should (looking-at-p (rx " [456]" eos))))) | ||
| 95 | |||
| 96 | (provide 'json-tests) | ||
| 97 | ;;; json-tests.el ends here | ||