From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Paul Eggert Newsgroups: gmane.emacs.devel Subject: Re: JSON/YAML/TOML/etc. parsing performance Date: Thu, 5 Oct 2017 18:58:34 -0700 Organization: UCLA Computer Science Department Message-ID: References: <87poaqhc63.fsf@lifelogs.com> <8360ceh5f1.fsf@gnu.org> <83h8vl5lf9.fsf@gnu.org> <83r2um3fqi.fsf@gnu.org> <43520b71-9e25-926c-d744-78098dad6441@cs.ucla.edu> <83o9pnzddc.fsf@gnu.org> <472176ce-846b-1f24-716b-98eb95ceaa47@cs.ucla.edu> <83d163z6dy.fsf@gnu.org> <73477c99-1600-a53d-d84f-737837d0f91f@cs.ucla.edu> <83poa2ya8j.fsf@gnu.org> <21b0ba97-ed49-43ae-e86f-63fba762353a@cs.ucla.edu> <83lgkqxe3l.fsf@gnu.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------2A3BDE20BC0439A2B8943D93" X-Trace: blaine.gmane.org 1507255186 8999 195.159.176.226 (6 Oct 2017 01:59:46 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Fri, 6 Oct 2017 01:59:46 +0000 (UTC) User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.3.0 Cc: p.stephani2@gmail.com, emacs-devel@gnu.org To: Eli Zaretskii Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Fri Oct 06 03:59:31 2017 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e0HvF-0000Lt-P0 for ged-emacs-devel@m.gmane.org; Fri, 06 Oct 2017 03:59:30 +0200 Original-Received: from localhost ([::1]:42621 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1e0HvM-00012F-Tw for ged-emacs-devel@m.gmane.org; Thu, 05 Oct 2017 21:59:36 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:53079) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1e0Hue-00010s-2x for emacs-devel@gnu.org; Thu, 05 Oct 2017 21:58:56 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1e0HuZ-0003yi-8Z for emacs-devel@gnu.org; Thu, 05 Oct 2017 21:58:52 -0400 Original-Received: from zimbra.cs.ucla.edu ([131.179.128.68]:47356) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1e0HuT-0003wO-3b; Thu, 05 Oct 2017 21:58:41 -0400 Original-Received: from localhost (localhost [127.0.0.1]) by zimbra.cs.ucla.edu (Postfix) with ESMTP id 545FA160E3B; Thu, 5 Oct 2017 18:58:39 -0700 (PDT) Original-Received: from zimbra.cs.ucla.edu ([127.0.0.1]) by localhost (zimbra.cs.ucla.edu [127.0.0.1]) (amavisd-new, port 10032) with ESMTP id DPvahhn2rmiT; Thu, 5 Oct 2017 18:58:35 -0700 (PDT) Original-Received: from localhost (localhost [127.0.0.1]) by zimbra.cs.ucla.edu (Postfix) with ESMTP id 13D78160E14; Thu, 5 Oct 2017 18:58:35 -0700 (PDT) X-Virus-Scanned: amavisd-new at zimbra.cs.ucla.edu Original-Received: from zimbra.cs.ucla.edu ([127.0.0.1]) by localhost (zimbra.cs.ucla.edu [127.0.0.1]) (amavisd-new, port 10026) with ESMTP id c5YjrlN_pCHD; Thu, 5 Oct 2017 18:58:34 -0700 (PDT) Original-Received: from Penguin.CS.UCLA.EDU (Penguin.CS.UCLA.EDU [131.179.64.200]) by zimbra.cs.ucla.edu (Postfix) with ESMTPSA id D64DD160E3D; Thu, 5 Oct 2017 18:58:34 -0700 (PDT) In-Reply-To: <83lgkqxe3l.fsf@gnu.org> Content-Language: en-US X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x [fuzzy] X-Received-From: 131.179.128.68 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.org gmane.emacs.devel:219158 Archived-At: This is a multi-part message in MIME format. --------------2A3BDE20BC0439A2B8943D93 Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 7bit On 10/05/2017 12:12 AM, Eli Zaretskii wrote: > If ptrdiff_t overflows are reliably diagnosed, then why do we have to > test for them explicitly in our code, as in the proposed json.c? They're diagnosed only if one compiles with debugging flags like -fsanitize=undefined. And even then the checks are "reliable" only in some sense: some overflows at the source level are not caught at the machine level even if the code is executed, because the overflows are optimized away. So testing a program with -fsanizitize=undefined does not guarantee that the same test will avoid ptrdiff_t overflow on some other platform. > AFAIU, ptrdiff_t overflows are the _only_ reason for json.c checks > whether a size_t value is too large In the most recent patch I proposed, there were only two such checks; there were two other checks for too-large size_t that were fixnum checks, not ptrdiff_t checks. However, I can see that you really don't like those checks. So I tweaked the proposed patch to remove them all from json.c. Please see the attached 3 patches (the first is just Philipp's patch rebased to master). The basic idea here is that json.c should be using xmalloc for allocation anyway, for reasons other than size overflow checking. And once it uses the Emacs malloc we can make sure that it never allocates objects that are too large for ptrdiff_t. > I'm not arguing for general replacement of ptrdiff_t with size_t, only > for doing that in those primitives where negative values are a clear > mistake/bug. This is exactly where we should be cautious about using unsigned types. The longstanding Emacs style is to prefer signed integers, to avoid the common typos that occur with unsigned. If we start changing the style, these primitives (or people debugging these primitives) often won't be able to distinguish buggy from valid-but-enormous cases. And when we compile such primitives (or their callers) with -fsanitize=undefined, we won't be able to catch integer-overflow bugs automatically at runtime, since unsigned integer arithmetic silently wraps around even when -fsanitize=undefined is used. > "kids, don't do that at home -- we are trained professionals" I help maintain several GNU programs that use unsigned types for sizes, and find that style to be trickier than the style Emacs uses, with respect to integer-overflow bugs. I've been gradually changing some of the non-Emacs GNU code to use signed types, and the results have been encouraging: the code is more readable and more obviously correct. I would rather not go back to the unsigned style: although you're right that it can be done, it is too error-prone and the errors can lead to serious bugs. Even for trained professionals, this particular set of acrobatics is best done with a net. --------------2A3BDE20BC0439A2B8943D93 Content-Type: text/x-patch; name="0001-Implement-native-JSON-support-using-Jansson.patch" Content-Disposition: attachment; filename="0001-Implement-native-JSON-support-using-Jansson.patch" Content-Transfer-Encoding: quoted-printable >From 8a1689de7c9391a84f26cba97ce2b43d2eec893b Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Mon, 18 Sep 2017 10:51:39 +0200 Subject: [PATCH 1/3] Implement native JSON support using Jansson * configure.ac: New option --with-json. * src/json.c (Fjson_serialize, Fjson_insert, Fjson_parse_string) (Fjson_parse_buffer): New defuns. (json_has_prefix, json_has_suffix, json_make_string) (json_build_string, json_encode, json_out_of_memory, json_parse_error) (json_release_object, check_string_without_embedded_nulls, json_check) (lisp_to_json, lisp_to_json_toplevel, lisp_to_json_toplevel_1) (json_insert, json_insert_callback, json_to_lisp) (json_read_buffer_callback, Fjson_parse_buffer, define_error): New helper functions. (syms_of_json): New file. * src/lisp.h: Declaration for syms_of_json. * src/conf_post.h (ATTRIBUTE_WARN_UNUSED_RESULT): New attribute macro. * src/emacs.c (main): Enable JSON functions. * src/eval.c (internal_catch_all, internal_catch_all_1): New helper functions to catch all signals. (syms_of_eval): Add uninterned symbol to signify out of memory. * src/Makefile.in (JSON_LIBS, JSON_CFLAGS, JSON_OBJ, EMACS_CFLAGS) (base_obj, LIBES): Compile json.c if --with-json is enabled. * test/src/json-tests.el (json-serialize/roundtrip) (json-serialize/object, json-parse-string/object) (json-parse-string/string, json-serialize/string) (json-parse-string/incomplete, json-parse-string/trailing) (json-parse-buffer/incomplete, json-parse-buffer/trailing): New unit tests. --- configure.ac | 20 +- etc/NEWS | 7 + src/Makefile.in | 11 +- src/conf_post.h | 6 + src/emacs.c | 4 + src/eval.c | 54 ++++++ src/json.c | 517 +++++++++++++++++++++++++++++++++++++++++++= ++++++ src/lisp.h | 6 + test/src/json-tests.el | 97 ++++++++++ 9 files changed, 718 insertions(+), 4 deletions(-) create mode 100644 src/json.c create mode 100644 test/src/json-tests.el diff --git a/configure.ac b/configure.ac index eba95e2fb8..a0e25cf631 100644 --- a/configure.ac +++ b/configure.ac @@ -348,6 +348,7 @@ AC_DEFUN OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)]) OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image su= pport]) +OPTION_DEFAULT_ON([json], [don't compile with native JSON support]) =20 OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support]) @@ -2856,6 +2857,22 @@ AC_DEFUN AC_SUBST(LIBSYSTEMD_LIBS) AC_SUBST(LIBSYSTEMD_CFLAGS) =20 +HAVE_JSON=3Dno +JSON_OBJ=3D + +if test "${with_json}" =3D yes; then + EMACS_CHECK_MODULES([JSON], [jansson >=3D 2.5], + [HAVE_JSON=3Dyes], [HAVE_JSON=3Dno]) + if test "${HAVE_JSON}" =3D yes; then + AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.]) + JSON_OBJ=3Djson.o + fi +fi + +AC_SUBST(JSON_LIBS) +AC_SUBST(JSON_CFLAGS) +AC_SUBST(JSON_OBJ) + NOTIFY_OBJ=3D NOTIFY_SUMMARY=3Dno =20 @@ -5368,7 +5385,7 @@ AC_DEFUN for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM = DBUS \ GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT= \ LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 NS MODULES = \ - XWIDGETS LIBSYSTEMD CANNOT_DUMP LCMS2; do + XWIDGETS LIBSYSTEMD JSON CANNOT_DUMP LCMS2; do =20 case $opt in CANNOT_DUMP) eval val=3D\${$opt} ;; @@ -5418,6 +5435,7 @@ AC_DEFUN Does Emacs use -lotf? ${HAVE_LIBOTF} Does Emacs use -lxft? ${HAVE_XFT} Does Emacs use -lsystemd? ${HAVE_LIBSYST= EMD} + Does Emacs use -ljansson? ${HAVE_JSON} Does Emacs directly use zlib? ${HAVE_ZLIB} Does Emacs have dynamic modules support? ${HAVE_MODULES= } Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_= SCROLL_BARS} diff --git a/etc/NEWS b/etc/NEWS index 15661808c7..81586ceb97 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -25,6 +25,13 @@ When you add a new item, use the appropriate mark if y= ou are sure it applies, =0C * Installation Changes in Emacs 27.1 =20 +** The new configure option '--with-json' adds support for JSON using +the Jansson library. It is on by default; use 'configure +--with-json=3Dno' to build without Jansson support. The new JSON +functions 'json-serialize', 'json-insert', 'json-parse-string', and +'json-parse-buffer' are typically much faster than their Lisp +counterparts from json.el. + =0C * Startup Changes in Emacs 27.1 =20 diff --git a/src/Makefile.in b/src/Makefile.in index 9a8c9c85f0..b395627893 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -312,6 +312,10 @@ LIBGNUTLS_CFLAGS =3D LIBSYSTEMD_LIBS =3D @LIBSYSTEMD_LIBS@ LIBSYSTEMD_CFLAGS =3D @LIBSYSTEMD_CFLAGS@ =20 +JSON_LIBS =3D @JSON_LIBS@ +JSON_CFLAGS =3D @JSON_CFLAGS@ +JSON_OBJ =3D @JSON_OBJ@ + INTERVALS_H =3D dispextern.h intervals.h composite.h =20 GETLOADAVG_LIBS =3D @GETLOADAVG_LIBS@ @@ -363,7 +367,7 @@ EMACS_CFLAGS=3D $(WEBKIT_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ - $(LIBSYSTEMD_CFLAGS) \ + $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ $(WERROR_CFLAGS) ALL_CFLAGS =3D $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) @@ -397,7 +401,7 @@ base_obj =3D thread.o systhread.o \ $(if $(HYBRID_MALLOC),sheap.o) \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ - $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) + $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) obj =3D $(base_obj) $(NS_OBJC_OBJ) =20 ## Object files used on some machine or other. @@ -493,7 +497,8 @@ LIBES =3D $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS= ) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \ - $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) + $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ + $(JSON_LIBS) =20 ## FORCE it so that admin/unidata can decide whether these files ## are up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/conf_post.h b/src/conf_post.h index febdb8b8bf..1a7f51fa51 100644 --- a/src/conf_post.h +++ b/src/conf_post.h @@ -338,6 +338,12 @@ extern int emacs_setenv_TZ (char const *); # define ATTRIBUTE_NO_SANITIZE_ADDRESS #endif =20 +#if __has_attribute (warn_unused_result) +# define ATTRIBUTE_WARN_UNUSED_RESULT __attribute__ ((__warn_unused_resu= lt__)) +#else +# define ATTRIBUTE_WARN_UNUSED_RESULT +#endif + /* gcc -fsanitize=3Daddress does not work with vfork in Fedora 25 x86-64= . For now, assume that this problem occurs on all platforms. */ #if ADDRESS_SANITIZER && !defined vfork diff --git a/src/emacs.c b/src/emacs.c index 0fe7d9113b..39761016ef 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1610,6 +1610,10 @@ Using an Emacs configured with --with-x-toolkit=3D= lucid does not have this problem syms_of_threads (); syms_of_profiler (); =20 +#ifdef HAVE_JSON + syms_of_json (); +#endif + keys_of_casefiddle (); keys_of_cmds (); keys_of_buffer (); diff --git a/src/eval.c b/src/eval.c index acda64e7f0..11804d1819 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1416,6 +1416,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (pt= rdiff_t, Lisp_Object *), } } =20 +static Lisp_Object +internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument) +{ + struct handler *c =3D push_handler_nosignal (Qt, CATCHER_ALL); + if (c =3D=3D NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) =3D=3D 0) + { + Lisp_Object val =3D function (argument); + eassert (handlerlist =3D=3D c); + handlerlist =3D c->next; + return val; + } + else + { + eassert (handlerlist =3D=3D c); + Lisp_Object val =3D c->val; + handlerlist =3D c->next; + Fsignal (Qno_catch, val); + } +} + +/* Like a combination of internal_condition_case_1 and internal_catch. + Catches all signals and throws. Never exits nonlocally; returns + Qcatch_all_memory_full if no handler could be allocated. */ + +Lisp_Object +internal_catch_all (Lisp_Object (*function) (void *), void *argument, + Lisp_Object (*handler) (Lisp_Object)) +{ + struct handler *c =3D push_handler_nosignal (Qt, CONDITION_CASE); + if (c =3D=3D NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) =3D=3D 0) + { + Lisp_Object val =3D internal_catch_all_1 (function, argument); + eassert (handlerlist =3D=3D c); + handlerlist =3D c->next; + return val; + } + else + { + eassert (handlerlist =3D=3D c); + Lisp_Object val =3D c->val; + handlerlist =3D c->next; + return handler (val); + } +} + struct handler * push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype) { @@ -4065,6 +4116,9 @@ alist of active lexical bindings. */); =20 inhibit_lisp_code =3D Qnil; =20 + DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full"); + Funintern (Qcatch_all_memory_full, Qnil); + defsubr (&Sor); defsubr (&Sand); defsubr (&Sif); diff --git a/src/json.c b/src/json.c new file mode 100644 index 0000000000..79be55bd54 --- /dev/null +++ b/src/json.c @@ -0,0 +1,517 @@ +/* JSON parsing and serialization. + +Copyright (C) 2017 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#include +#include + +#include + +#include "lisp.h" +#include "buffer.h" +#include "coding.h" + +static bool +json_has_prefix (const char *string, const char *prefix) +{ + size_t string_len =3D strlen (string); + size_t prefix_len =3D strlen (prefix); + return string_len >=3D prefix_len && memcmp (string, prefix, prefix_le= n) =3D=3D 0; +} + +static bool +json_has_suffix (const char *string, const char *suffix) +{ + size_t string_len =3D strlen (string); + size_t suffix_len =3D strlen (suffix); + return string_len >=3D suffix_len + && memcmp (string + string_len - suffix_len, suffix, suffix_len) =3D= =3D 0; +} + +static Lisp_Object +json_make_string (const char *data, ptrdiff_t size) +{ + return make_specified_string (data, -1, size, true); +} + +static Lisp_Object +json_build_string (const char *data) +{ + size_t size =3D strlen (data); + eassert (size < PTRDIFF_MAX); + return json_make_string (data, size); +} + +static Lisp_Object +json_encode (Lisp_Object string) +{ + return code_convert_string (string, Qutf_8_unix, Qt, true, true, true)= ; +} + +static _Noreturn void +json_out_of_memory (void) +{ + xsignal0 (Qjson_out_of_memory); +} + +static _Noreturn void +json_parse_error (const json_error_t *error) +{ + Lisp_Object symbol; + if (json_has_suffix (error->text, "expected near end of file")) + symbol =3D Qjson_end_of_file; + else if (json_has_prefix (error->text, "end of file expected")) + symbol =3D Qjson_trailing_content; + else + symbol =3D Qjson_parse_error; + xsignal (symbol, + list5 (json_build_string (error->text), + json_build_string (error->source), make_natnum (error-= >line), + make_natnum (error->column), make_natnum (error->posit= ion))); +} + +static void +json_release_object (void *object) +{ + json_decref (object); +} + +static void +check_string_without_embedded_nulls (Lisp_Object object) +{ + CHECK_STRING (object); + CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) =3D=3D NULL= , + Qstring_without_embedded_nulls_p, object); +} + +static ATTRIBUTE_WARN_UNUSED_RESULT json_t * +json_check (json_t *object) +{ + if (object =3D=3D NULL) + json_out_of_memory (); + return object; +} + +static json_t *lisp_to_json (Lisp_Object) ATTRIBUTE_WARN_UNUSED_RESULT; + +/* This returns Lisp_Object so we can use unbind_to. The return value + is always nil. */ + +static _GL_ARG_NONNULL ((2)) Lisp_Object +lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json) +{ + if (VECTORP (lisp)) + { + ptrdiff_t size =3D ASIZE (lisp); + eassert (size >=3D 0); + if (size > SIZE_MAX) + xsignal1 (Qoverflow_error, build_string ("vector is too long")); + *json =3D json_check (json_array ()); + ptrdiff_t count =3D SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, json); + for (ptrdiff_t i =3D 0; i < size; ++i) + { + int status + =3D json_array_append_new (*json, lisp_to_json (AREF (lisp, = i))); + if (status =3D=3D -1) + json_out_of_memory (); + eassert (status =3D=3D 0); + } + eassert (json_array_size (*json) =3D=3D size); + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + else if (HASH_TABLE_P (lisp)) + { + struct Lisp_Hash_Table *h =3D XHASH_TABLE (lisp); + *json =3D json_check (json_object ()); + ptrdiff_t count =3D SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, *json); + for (ptrdiff_t i =3D 0; i < HASH_TABLE_SIZE (h); ++i) + if (!NILP (HASH_HASH (h, i))) + { + Lisp_Object key =3D json_encode (HASH_KEY (h, i)); + /* We can=E2=80=99t specify the length, so the string must b= e + null-terminated. */ + check_string_without_embedded_nulls (key); + int status =3D json_object_set_new (*json, SSDATA (key), + lisp_to_json (HASH_VALUE (= h, i))); + if (status =3D=3D -1) + json_out_of_memory (); + eassert (status =3D=3D 0); + } + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + wrong_type_argument (Qjson_value_p, lisp); +} + +static ATTRIBUTE_WARN_UNUSED_RESULT json_t * +lisp_to_json_toplevel (Lisp_Object lisp) +{ + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + json_t *json; + lisp_to_json_toplevel_1 (lisp, &json); + --lisp_eval_depth; + return json; +} + +static ATTRIBUTE_WARN_UNUSED_RESULT json_t * +lisp_to_json (Lisp_Object lisp) +{ + if (EQ (lisp, QCnull)) + return json_check (json_null ()); + else if (EQ (lisp, QCfalse)) + return json_check (json_false ()); + else if (EQ (lisp, Qt)) + return json_check (json_true ()); + else if (INTEGERP (lisp)) + { + CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp); + return json_check (json_integer (XINT (lisp))); + } + else if (FLOATP (lisp)) + return json_check (json_real (XFLOAT_DATA (lisp))); + else if (STRINGP (lisp)) + { + Lisp_Object encoded =3D json_encode (lisp); + ptrdiff_t size =3D SBYTES (encoded); + eassert (size >=3D 0); + if (size > SIZE_MAX) + xsignal1 (Qoverflow_error, build_string ("string is too long")); + return json_check (json_stringn (SSDATA (encoded), size)); + } + + /* LISP now must be a vector or hashtable. */ + return lisp_to_json_toplevel (lisp); +} + +DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL, + doc: /* Return the JSON representation of OBJECT as a string. +OBJECT must be a vector or hashtable, and its elements can recursively +contain `:null', `:false', t, numbers, strings, or other vectors and +hashtables. `:null', `:false', and t will be converted to JSON null, +false, and true values, respectively. Vectors will be converted to +JSON arrays, and hashtables to JSON objects. Hashtable keys must be +strings without embedded null characters and must be unique within +each object. */) + (Lisp_Object object) +{ + ptrdiff_t count =3D SPECPDL_INDEX (); + + json_t *json =3D lisp_to_json_toplevel (object); + record_unwind_protect_ptr (json_release_object, json); + + char *string =3D json_dumps (json, JSON_COMPACT); + if (string =3D=3D NULL) + json_out_of_memory (); + record_unwind_protect_ptr (free, string); + + return unbind_to (count, json_build_string (string)); +} + +struct json_buffer_and_size +{ + const char *buffer; + size_t size; +}; + +static Lisp_Object +json_insert (void *data) +{ + const struct json_buffer_and_size *buffer_and_size =3D data; + if (buffer_and_size->size > PTRDIFF_MAX) + xsignal1 (Qoverflow_error, build_string ("buffer too large")); + insert (buffer_and_size->buffer, buffer_and_size->size); + return Qnil; +} + +struct json_insert_data +{ + /* nil if json_insert succeeded, otherwise the symbol + Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */ + Lisp_Object error; +}; + +static int +json_insert_callback (const char *buffer, size_t size, void *data) +{ + /* This function may not exit nonlocally. */ + struct json_insert_data *d =3D data; + struct json_buffer_and_size buffer_and_size + =3D {.buffer =3D buffer, .size =3D size}; + d->error =3D internal_catch_all (json_insert, &buffer_and_size, Fident= ity); + return NILP (d->error) ? 0 : -1; +} + +DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL, + doc: /* Insert the JSON representation of OBJECT before point. +This is the same as (insert (json-serialize OBJECT)), but potentially +faster. See the function `json-serialize' for allowed values of +OBJECT. */) + (Lisp_Object object) +{ + ptrdiff_t count =3D SPECPDL_INDEX (); + + json_t *json =3D lisp_to_json (object); + record_unwind_protect_ptr (json_release_object, json); + + struct json_insert_data data; + int status + =3D json_dump_callback (json, json_insert_callback, &data, JSON_COMP= ACT); + if (status =3D=3D -1) + { + if (CONSP (data.error)) + xsignal (XCAR (data.error), XCDR (data.error)); + else + json_out_of_memory (); + } + eassert (status =3D=3D 0); + eassert (NILP (data.error)); + return unbind_to (count, Qnil); +} + +static _GL_ARG_NONNULL ((1)) Lisp_Object +json_to_lisp (json_t *json) +{ + switch (json_typeof (json)) + { + case JSON_NULL: + return QCnull; + case JSON_FALSE: + return QCfalse; + case JSON_TRUE: + return Qt; + case JSON_INTEGER: + { + json_int_t value =3D json_integer_value (json); + if (FIXNUM_OVERFLOW_P (value)) + xsignal1 (Qoverflow_error, + build_string ("JSON integer is too large")); + return make_number (value); + } + case JSON_REAL: + return make_float (json_real_value (json)); + case JSON_STRING: + { + size_t size =3D json_string_length (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal1 (Qoverflow_error, build_string ("JSON string is too l= ong")); + return json_make_string (json_string_value (json), size); + } + case JSON_ARRAY: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + size_t size =3D json_array_size (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal1 (Qoverflow_error, build_string ("JSON array is too lo= ng")); + Lisp_Object result =3D Fmake_vector (make_natnum (size), Qunboun= d); + for (ptrdiff_t i =3D 0; i < size; ++i) + ASET (result, i, + json_to_lisp (json_array_get (json, i))); + --lisp_eval_depth; + return result; + } + case JSON_OBJECT: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + size_t size =3D json_object_size (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal1 (Qoverflow_error, + build_string ("JSON object has too many elements")); + Lisp_Object result =3D CALLN (Fmake_hash_table, QCtest, Qequal, + QCsize, make_natnum (size)); + struct Lisp_Hash_Table *h =3D XHASH_TABLE (result); + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + Lisp_Object key =3D json_build_string (key_str); + EMACS_UINT hash; + ptrdiff_t i =3D hash_lookup (h, key, &hash); + eassert (i < 0); + hash_put (h, key, json_to_lisp (value), hash); + } + --lisp_eval_depth; + return result; + } + } + /* Can=E2=80=99t get here. */ + emacs_abort (); +} + +DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, 1= , NULL, + doc: /* Parse the JSON STRING into a Lisp object. +This is essentially the reverse operation of `json-serialize', which +see. The returned object will be a vector or hashtable. Its elements +will be `:null', `:false', t, numbers, strings, or further vectors and +hashtables. If there are duplicate keys in an object, all but the +last one are ignored. If STRING doesn't contain a valid JSON object, +an error of type `json-parse-error' is signaled. */) + (Lisp_Object string) +{ + ptrdiff_t count =3D SPECPDL_INDEX (); + Lisp_Object encoded =3D json_encode (string); + check_string_without_embedded_nulls (encoded); + + json_error_t error; + json_t *object =3D json_loads (SSDATA (encoded), 0, &error); + if (object =3D=3D NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + if (object !=3D NULL) + record_unwind_protect_ptr (json_release_object, object); + + return unbind_to (count, json_to_lisp (object)); +} + +struct json_read_buffer_data +{ + ptrdiff_t point; +}; + +static size_t +json_read_buffer_callback (void *buffer, size_t buflen, void *data) +{ + struct json_read_buffer_data *d =3D data; + + /* First, parse from point to the gap or the end of the accessible + portion, whatever is closer. */ + ptrdiff_t point =3D d->point; + ptrdiff_t end; + { + bool overflow =3D INT_ADD_WRAPV (BUFFER_CEILING_OF (point), 1, &end)= ; + eassert (!overflow); + } + size_t count; + { + bool overflow =3D INT_SUBTRACT_WRAPV (end, point, &count); + eassert (!overflow); + } + if (buflen < count) + count =3D buflen; + memcpy (buffer, BYTE_POS_ADDR (point), count); + { + bool overflow =3D INT_ADD_WRAPV (d->point, count, &d->point); + eassert (!overflow); + } + return count; +} + +DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer, + 0, 0, NULL, + doc: /* Read JSON object from current buffer starting at point. +This is similar to `json-parse-string', which see. Move point after +the end of the object if parsing was successful. On error, point is +not moved. */) + (void) +{ + ptrdiff_t count =3D SPECPDL_INDEX (); + + ptrdiff_t point =3D PT_BYTE; + struct json_read_buffer_data data =3D {.point =3D point}; + json_error_t error; + json_t *object =3D json_load_callback (json_read_buffer_callback, &dat= a, + JSON_DISABLE_EOF_CHECK, &error); + + if (object =3D=3D NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + record_unwind_protect_ptr (json_release_object, object); + + /* Convert and then move point only if everything succeeded. */ + Lisp_Object lisp =3D json_to_lisp (object); + + { + /* Adjust point by how much we just read. Do this here because + tokener->char_offset becomes incorrect below. */ + bool overflow =3D INT_ADD_WRAPV (point, error.position, &point); + eassert (!overflow); + eassert (point <=3D ZV_BYTE); + SET_PT_BOTH (BYTE_TO_CHAR (point), point); + } + + return unbind_to (count, lisp); +} + +/* Simplified version of =E2=80=98define-error=E2=80=99 that works with = pure + objects. */ + +static void +define_error (Lisp_Object name, const char *message, Lisp_Object parent) +{ + eassert (SYMBOLP (name)); + eassert (SYMBOLP (parent)); + Lisp_Object parent_conditions =3D Fget (parent, Qerror_conditions); + eassert (CONSP (parent_conditions)); + eassert (!NILP (Fmemq (parent, parent_conditions))); + eassert (NILP (Fmemq (name, parent_conditions))); + Fput (name, Qerror_conditions, pure_cons (name, parent_conditions)); + Fput (name, Qerror_message, build_pure_c_string (message)); +} + +void +syms_of_json (void) +{ + DEFSYM (QCnull, ":null"); + DEFSYM (QCfalse, ":false"); + + DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nul= ls-p"); + DEFSYM (Qjson_value_p, "json-value-p"); + + DEFSYM (Qutf_8_unix, "utf-8-unix"); + + DEFSYM (Qjson_error, "json-error"); + DEFSYM (Qjson_out_of_memory, "json-out-of-memory"); + DEFSYM (Qjson_parse_error, "json-parse-error"); + DEFSYM (Qjson_end_of_file, "json-end-of-file"); + DEFSYM (Qjson_trailing_content, "json-trailing-content"); + DEFSYM (Qjson_object_too_deep, "json-object-too-deep"); + define_error (Qjson_error, "generic JSON error", Qerror); + define_error (Qjson_out_of_memory, "no free memory for creating JSON o= bject", + Qjson_error); + define_error (Qjson_parse_error, "could not parse JSON stream", + Qjson_error); + define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_err= or); + define_error (Qjson_trailing_content, "trailing content after JSON str= eam", + Qjson_parse_error); + define_error (Qjson_object_too_deep, + "object cyclic or Lisp evaluation too deep", Qjson_error= ); + + DEFSYM (Qpure, "pure"); + DEFSYM (Qside_effect_free, "side-effect-free"); + + DEFSYM (Qjson_serialize, "json-serialize"); + DEFSYM (Qjson_parse_string, "json-parse-string"); + Fput (Qjson_serialize, Qpure, Qt); + Fput (Qjson_serialize, Qside_effect_free, Qt); + Fput (Qjson_parse_string, Qpure, Qt); + Fput (Qjson_parse_string, Qside_effect_free, Qt); + + defsubr (&Sjson_serialize); + defsubr (&Sjson_insert); + defsubr (&Sjson_parse_string); + defsubr (&Sjson_parse_buffer); +} diff --git a/src/lisp.h b/src/lisp.h index 680c25d4c4..43d8846619 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3440,6 +3440,11 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_= t); extern void reset_image_types (void); extern void syms_of_image (void); =20 +#ifdef HAVE_JSON +/* Defined in json.c. */ +extern void syms_of_json (void); +#endif + /* Defined in insdel.c. */ extern void move_gap_both (ptrdiff_t, ptrdiff_t); extern _Noreturn void buffer_overflow (void); @@ -3863,6 +3868,7 @@ extern Lisp_Object internal_condition_case_2 (Lisp_= Object (*) (Lisp_Object, Lisp extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object = *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *= )); +extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *,= Lisp_Object (*) (Lisp_Object)); extern struct handler *push_handler (Lisp_Object, enum handlertype); extern struct handler *push_handler_nosignal (Lisp_Object, enum handlert= ype); 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 0000000000..8820c682ba --- /dev/null +++ b/test/src/json-tests.el @@ -0,0 +1,97 @@ +;;; json-tests.el --- unit tests for json.c -*- lexical-binding= : t; -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Unit tests for src/json.c. + +;;; Code: + +(require 'cl-lib) +(require 'map) + +(ert-deftest json-serialize/roundtrip () + (let ((lisp [:null :false t 0 123 -456 3.75 "foo"]) + (json "[null,false,true,0,123,-456,3.75,\"foo\"]")) + (should (equal (json-serialize lisp) json)) + (with-temp-buffer + (json-insert lisp) + (should (equal (buffer-string) json)) + (should (eobp))) + (should (equal (json-parse-string json) lisp)) + (with-temp-buffer + (insert json) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) + (should (eobp))))) + +(ert-deftest json-serialize/object () + (let ((table (make-hash-table :test #'equal))) + (puthash "abc" [1 2 t] table) + (puthash "def" :null table) + (should (equal (json-serialize table) + "{\"abc\":[1,2,true],\"def\":null}")))) + +(ert-deftest json-parse-string/object () + (let ((actual + (json-parse-string + "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false= ] }\n"))) + (should (hash-table-p actual)) + (should (equal (hash-table-count actual) 2)) + (should (equal (cl-sort (map-pairs actual) #'string< :key #'car) + '(("abc" . [9 :false]) ("def" . :null)))))) + +(ert-deftest json-parse-string/string () + (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse= -error) + (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar= \""])) + (should (equal (json-parse-string "[\"abc=CE=B1=CE=B2=CE=B3\"]") ["abc= =CE=B1=CE=B2=CE=B3"])) + (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\= t\"]") + ["\nasd=D1=84=D1=8B=D0=B2fgh\t"])) + (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E= "])) + (should-error (json-parse-string "foo") :type 'json-parse-error)) + +(ert-deftest json-serialize/string () + (should (equal (json-serialize ["foo"]) "[\"foo\"]")) + (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]")) + (should (equal (json-serialize ["\nasd=D1=84=D1=8B=D0=B2\u001f\u007ffg= h\t"]) + "[\"\\nasd=D1=84=D1=8B=D0=B2\\u001F\u007ffgh\\t\"]"))) + +(ert-deftest json-parse-string/incomplete () + (should-error (json-parse-string "[123") :type 'json-end-of-file)) + +(ert-deftest json-parse-string/trailing () + (should-error (json-parse-string "[123] [456]") :type 'json-trailing-c= ontent)) + +(ert-deftest json-parse-buffer/incomplete () + (with-temp-buffer + (insert "[123") + (goto-char 1) + (should-error (json-parse-buffer) :type 'json-end-of-file) + (should (bobp)))) + +(ert-deftest json-parse-buffer/trailing () + (with-temp-buffer + (insert "[123] [456]") + (goto-char 1) + (should (equal (json-parse-buffer) [123])) + (should-not (bobp)) + (should (looking-at-p (rx " [456]" eos))))) + +(provide 'json-tests) +;;; json-tests.el ends here --=20 2.13.6 --------------2A3BDE20BC0439A2B8943D93 Content-Type: text/x-patch; name="0002-Do-not-malloc-more-than-PTRDIFF_MAX.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="0002-Do-not-malloc-more-than-PTRDIFF_MAX.patch" >From c27ea3054d37a38c64f339e30044b1f463b9affe Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 5 Oct 2017 17:59:07 -0700 Subject: [PATCH 2/3] Do not malloc more than PTRDIFF_MAX * src/alloc.c (lmalloc, lrealloc): Do not allocate objects containing more than PTRDIFF_MAX bytes, as they would cause pointer subtraction to stop working. Much of Emacs already checks for this; this change closes a couple of loopholes. --- src/alloc.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/alloc.c b/src/alloc.c index 2e6399e7f8..ed482c88f2 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -1440,6 +1440,12 @@ laligned (void *p, size_t size) static void * lmalloc (size_t size) { + if (PTRDIFF_MAX < size) + { + errno = ENOMEM; + return NULL; + } + #if USE_ALIGNED_ALLOC if (! MALLOC_IS_GC_ALIGNED && size % GCALIGNMENT == 0) return aligned_alloc (GCALIGNMENT, size); @@ -1460,6 +1466,12 @@ lmalloc (size_t size) static void * lrealloc (void *p, size_t size) { + if (PTRDIFF_MAX < size) + { + errno = ENOMEM; + return NULL; + } + while (true) { p = realloc (p, size); -- 2.13.6 --------------2A3BDE20BC0439A2B8943D93 Content-Type: text/x-patch; name="0003-Minor-JSON-cleanups-mostly-for-overflow.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="0003-Minor-JSON-cleanups-mostly-for-overflow.patch" >From 991b22ef18152fb0f2238f25998bb141951ab2cd Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Wed, 4 Oct 2017 18:38:07 -0700 Subject: [PATCH 3/3] Minor JSON cleanups, mostly for overflow Tell Jansson to use the Emacs allocators, to avoid problems with objects containing more than PTRDIFF_MAX bytes, along with other problems. Also, fix some other minor integer-overflow problems. * src/emacs.c (main) [HAVE_JSON]: Call init_json. * src/json.c (json_has_prefix): Simplify via strncmp. (json_has_suffix): Indent a la GNU. (json_has_suffix, struct json_buffer_and_size): Use ptrdiff_t instead of size_t where either will do. (json_build_string, lisp_to_json_toplevel_1, lisp_to_json) (json_insert, json_to_lisp, json_read_buffer_callback) (define_error): Remove useless or no-longer-needed checks. (json_out_of_memory, json_to_lisp): Just call memory_full. (check_string_without_embedded_nulls): Use strlen, not memchr; it is typically faster. (lisp_to_json_toplevel_1, json_to_lisp): Do not bother with _GL_ARG_NONNULL on static functions; it is not worth the trouble. (json_to_lisp): Just signal overflow error, to be consistent with other signalers. Use allocate_vector instead of Fmake_vector, to avoid need for initializing vector twice. Use make_hash_table instead of Fmake_hash_table, as it is a bit simpler. (init_json): New function. --- src/emacs.c | 4 +++ src/json.c | 105 +++++++++++++++++++++--------------------------------------- src/lisp.h | 1 + 3 files changed, 42 insertions(+), 68 deletions(-) diff --git a/src/emacs.c b/src/emacs.c index 39761016ef..9f635acdbc 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1271,6 +1271,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem build_details = ! argmatch (argv, argc, "-no-build-details", "--no-build-details", 7, NULL, &skip_args); +#ifdef HAVE_JSON + init_json (); +#endif + #ifdef HAVE_MODULES bool module_assertions = argmatch (argv, argc, "-module-assertions", "--module-assertions", 15, diff --git a/src/json.c b/src/json.c index 79be55bd54..0f3b227a78 100644 --- a/src/json.c +++ b/src/json.c @@ -31,18 +31,17 @@ along with GNU Emacs. If not, see . */ static bool json_has_prefix (const char *string, const char *prefix) { - size_t string_len = strlen (string); - size_t prefix_len = strlen (prefix); - return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0; + return strncmp (string, prefix, strlen (prefix)) == 0; } static bool json_has_suffix (const char *string, const char *suffix) { - size_t string_len = strlen (string); - size_t suffix_len = strlen (suffix); - return string_len >= suffix_len - && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0; + ptrdiff_t string_len = strlen (string); + ptrdiff_t suffix_len = strlen (suffix); + return (string_len >= suffix_len + && (memcmp (string + string_len - suffix_len, suffix, suffix_len) + == 0)); } static Lisp_Object @@ -54,9 +53,7 @@ json_make_string (const char *data, ptrdiff_t size) static Lisp_Object json_build_string (const char *data) { - size_t size = strlen (data); - eassert (size < PTRDIFF_MAX); - return json_make_string (data, size); + return json_make_string (data, strlen (data)); } static Lisp_Object @@ -68,7 +65,7 @@ json_encode (Lisp_Object string) static _Noreturn void json_out_of_memory (void) { - xsignal0 (Qjson_out_of_memory); + memory_full (SIZE_MAX); } static _Noreturn void @@ -97,7 +94,7 @@ static void check_string_without_embedded_nulls (Lisp_Object object) { CHECK_STRING (object); - CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL, + CHECK_TYPE (strlen (SSDATA (object)) == SBYTES (object), Qstring_without_embedded_nulls_p, object); } @@ -114,15 +111,12 @@ static json_t *lisp_to_json (Lisp_Object) ATTRIBUTE_WARN_UNUSED_RESULT; /* This returns Lisp_Object so we can use unbind_to. The return value is always nil. */ -static _GL_ARG_NONNULL ((2)) Lisp_Object +static Lisp_Object lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json) { if (VECTORP (lisp)) { ptrdiff_t size = ASIZE (lisp); - eassert (size >= 0); - if (size > SIZE_MAX) - xsignal1 (Qoverflow_error, build_string ("vector is too long")); *json = json_check (json_array ()); ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_ptr (json_release_object, json); @@ -194,9 +188,6 @@ lisp_to_json (Lisp_Object lisp) { Lisp_Object encoded = json_encode (lisp); ptrdiff_t size = SBYTES (encoded); - eassert (size >= 0); - if (size > SIZE_MAX) - xsignal1 (Qoverflow_error, build_string ("string is too long")); return json_check (json_stringn (SSDATA (encoded), size)); } @@ -231,15 +222,13 @@ each object. */) struct json_buffer_and_size { const char *buffer; - size_t size; + ptrdiff_t size; }; static Lisp_Object json_insert (void *data) { const struct json_buffer_and_size *buffer_and_size = data; - if (buffer_and_size->size > PTRDIFF_MAX) - xsignal1 (Qoverflow_error, build_string ("buffer too large")); insert (buffer_and_size->buffer, buffer_and_size->size); return Qnil; } @@ -289,7 +278,7 @@ OBJECT. */) return unbind_to (count, Qnil); } -static _GL_ARG_NONNULL ((1)) Lisp_Object +static Lisp_Object json_to_lisp (json_t *json) { switch (json_typeof (json)) @@ -304,43 +293,33 @@ json_to_lisp (json_t *json) { json_int_t value = json_integer_value (json); if (FIXNUM_OVERFLOW_P (value)) - xsignal1 (Qoverflow_error, - build_string ("JSON integer is too large")); + xsignal0 (Qoverflow_error); return make_number (value); } case JSON_REAL: return make_float (json_real_value (json)); case JSON_STRING: - { - size_t size = json_string_length (json); - if (FIXNUM_OVERFLOW_P (size)) - xsignal1 (Qoverflow_error, build_string ("JSON string is too long")); - return json_make_string (json_string_value (json), size); - } + return json_make_string (json_string_value (json), + json_string_length (json)); case JSON_ARRAY: { if (++lisp_eval_depth > max_lisp_eval_depth) xsignal0 (Qjson_object_too_deep); - size_t size = json_array_size (json); - if (FIXNUM_OVERFLOW_P (size)) - xsignal1 (Qoverflow_error, build_string ("JSON array is too long")); - Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound); + ptrdiff_t size = json_array_size (json); + struct Lisp_Vector *v = allocate_vector (size); for (ptrdiff_t i = 0; i < size; ++i) - ASET (result, i, - json_to_lisp (json_array_get (json, i))); + v->contents[i] = json_to_lisp (json_array_get (json, i)); --lisp_eval_depth; - return result; + return make_lisp_ptr (v, Lisp_Vectorlike); } case JSON_OBJECT: { if (++lisp_eval_depth > max_lisp_eval_depth) xsignal0 (Qjson_object_too_deep); - size_t size = json_object_size (json); - if (FIXNUM_OVERFLOW_P (size)) - xsignal1 (Qoverflow_error, - build_string ("JSON object has too many elements")); - Lisp_Object result = CALLN (Fmake_hash_table, QCtest, Qequal, - QCsize, make_natnum (size)); + ptrdiff_t size = json_object_size (json); + Lisp_Object result + = make_hash_table (hashtest_equal, size, DEFAULT_REHASH_SIZE, + DEFAULT_REHASH_THRESHOLD, Qnil, false); struct Lisp_Hash_Table *h = XHASH_TABLE (result); const char *key_str; json_t *value; @@ -399,23 +378,12 @@ json_read_buffer_callback (void *buffer, size_t buflen, void *data) /* First, parse from point to the gap or the end of the accessible portion, whatever is closer. */ ptrdiff_t point = d->point; - ptrdiff_t end; - { - bool overflow = INT_ADD_WRAPV (BUFFER_CEILING_OF (point), 1, &end); - eassert (!overflow); - } - size_t count; - { - bool overflow = INT_SUBTRACT_WRAPV (end, point, &count); - eassert (!overflow); - } + ptrdiff_t end = BUFFER_CEILING_OF (point) + 1; + ptrdiff_t count = end - point; if (buflen < count) count = buflen; memcpy (buffer, BYTE_POS_ADDR (point), count); - { - bool overflow = INT_ADD_WRAPV (d->point, count, &d->point); - eassert (!overflow); - } + d->point += count; return count; } @@ -444,14 +412,11 @@ not moved. */) /* Convert and then move point only if everything succeeded. */ Lisp_Object lisp = json_to_lisp (object); - { - /* Adjust point by how much we just read. Do this here because - tokener->char_offset becomes incorrect below. */ - bool overflow = INT_ADD_WRAPV (point, error.position, &point); - eassert (!overflow); - eassert (point <= ZV_BYTE); - SET_PT_BOTH (BYTE_TO_CHAR (point), point); - } + /* Adjust point by how much we just read. Do this here because + tokener->char_offset becomes incorrect below. */ + eassert (0 <= error.position && error.position <= ZV_BYTE - point); + point += error.position; + SET_PT_BOTH (BYTE_TO_CHAR (point), point); return unbind_to (count, lisp); } @@ -462,8 +427,6 @@ not moved. */) static void define_error (Lisp_Object name, const char *message, Lisp_Object parent) { - eassert (SYMBOLP (name)); - eassert (SYMBOLP (parent)); Lisp_Object parent_conditions = Fget (parent, Qerror_conditions); eassert (CONSP (parent_conditions)); eassert (!NILP (Fmemq (parent, parent_conditions))); @@ -473,6 +436,12 @@ define_error (Lisp_Object name, const char *message, Lisp_Object parent) } void +init_json (void) +{ + json_set_alloc_funcs (xmalloc, xfree); +} + +void syms_of_json (void) { DEFSYM (QCnull, ":null"); diff --git a/src/lisp.h b/src/lisp.h index 43d8846619..8e530619b8 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3442,6 +3442,7 @@ extern void syms_of_image (void); #ifdef HAVE_JSON /* Defined in json.c. */ +extern void init_json (void); extern void syms_of_json (void); #endif -- 2.13.6 --------------2A3BDE20BC0439A2B8943D93--