all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
* bug#70007: [PATCH] native JSON encoder
@ 2024-03-26 15:33 Mattias Engdegård
  2024-03-26 16:46 ` Eli Zaretskii
  0 siblings, 1 reply; 37+ messages in thread
From: Mattias Engdegård @ 2024-03-26 15:33 UTC (permalink / raw)
  To: 70007

[-- Attachment #1: Type: text/plain, Size: 897 bytes --]

If we replace the lisp-to-JSON encoder with native code, we would not need the jansson library for it and it would be faster.

There is ongoing work on a JSON-to-lisp parser, but the author has made it clear that he does not have time to write an encoder, so I spent a morning mashing up the attached patch.

It generally produces the same result as the old code, except:

- The old code incorrectly accepted strings with non-Unicode characters (raw bytes). There is no reason to do this; JSON is UTF-8 only.
- The old code spent a lot of time ensuring that object keys were unique. The new code doesn't: it's a garbage-in garbage-out type of situation.

The new code could do with some optimisation but it's already about twice as fast as the old code, sometimes more.

I'd be very happy if someone could test it with packages that use this interface (json-serialise, json-insert).


[-- Attachment #2: json-serialise.diff --]
[-- Type: application/octet-stream, Size: 27596 bytes --]

diff --git a/src/json.c b/src/json.c
index e849ccaf722..7fbe700e07c 100644
--- a/src/json.c
+++ b/src/json.c
@@ -23,6 +23,7 @@ Copyright (C) 2017-2024 Free Software Foundation, Inc.
 #include <stddef.h>
 #include <stdint.h>
 #include <stdlib.h>
+#include <math.h>
 
 #include <jansson.h>
 
@@ -231,12 +232,6 @@ json_encode (Lisp_Object string)
   return encode_string_utf_8 (string, Qnil, false, Qt, Qt);
 }
 
-static AVOID
-json_out_of_memory (void)
-{
-  xsignal0 (Qjson_out_of_memory);
-}
-
 /* Signal a Lisp error corresponding to the JSON ERROR.  */
 
 static AVOID
@@ -289,26 +284,6 @@ check_string_without_embedded_nulls (Lisp_Object object)
               Qstring_without_embedded_nulls_p, object);
 }
 
-/* Signal an error of type `json-out-of-memory' if OBJECT is
-   NULL.  */
-
-static json_t *
-json_check (json_t *object)
-{
-  if (object == NULL)
-    json_out_of_memory ();
-  return object;
-}
-
-/* If STRING is not a valid UTF-8 string, signal an error of type
-   `wrong-type-argument'.  STRING must be a unibyte string.  */
-
-static void
-json_check_utf8 (Lisp_Object string)
-{
-  CHECK_TYPE (utf8_string_p (string), Qutf_8_string_p, string);
-}
-
 enum json_object_type {
   json_object_hashtable,
   json_object_alist,
@@ -327,179 +302,6 @@ json_check_utf8 (Lisp_Object string)
   Lisp_Object false_object;
 };
 
-static json_t *lisp_to_json (Lisp_Object,
-                             const struct json_configuration *conf);
-
-/* Convert a Lisp object to a nonscalar JSON object (array or object).  */
-
-static json_t *
-lisp_to_json_nonscalar_1 (Lisp_Object lisp,
-                          const struct json_configuration *conf)
-{
-  json_t *json;
-  specpdl_ref count;
-
-  if (VECTORP (lisp))
-    {
-      ptrdiff_t size = ASIZE (lisp);
-      json = json_check (json_array ());
-      count = SPECPDL_INDEX ();
-      record_unwind_protect_ptr (json_release_object, json);
-      for (ptrdiff_t i = 0; i < size; ++i)
-        {
-          int status
-            = json_array_append_new (json, lisp_to_json (AREF (lisp, i),
-                                                         conf));
-          if (status == -1)
-            json_out_of_memory ();
-        }
-      eassert (json_array_size (json) == size);
-    }
-  else if (HASH_TABLE_P (lisp))
-    {
-      struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
-      json = json_check (json_object ());
-      count = SPECPDL_INDEX ();
-      record_unwind_protect_ptr (json_release_object, json);
-      DOHASH (h, key, v)
-        {
-	  CHECK_STRING (key);
-	  Lisp_Object ekey = json_encode (key);
-	  /* We can't specify the length, so the string must be
-	     null-terminated.  */
-	  check_string_without_embedded_nulls (ekey);
-	  const char *key_str = SSDATA (ekey);
-	  /* Reject duplicate keys.  These are possible if the hash
-	     table test is not `equal'.  */
-	  if (json_object_get (json, key_str) != NULL)
-	    wrong_type_argument (Qjson_value_p, lisp);
-	  int status
-	    = json_object_set_new (json, key_str,
-				   lisp_to_json (v, conf));
-	  if (status == -1)
-	    {
-	      /* A failure can be caused either by an invalid key or
-		 by low memory.  */
-	      json_check_utf8 (ekey);
-	      json_out_of_memory ();
-	    }
-	}
-    }
-  else if (NILP (lisp))
-    return json_check (json_object ());
-  else if (CONSP (lisp))
-    {
-      Lisp_Object tail = lisp;
-      json = json_check (json_object ());
-      count = SPECPDL_INDEX ();
-      record_unwind_protect_ptr (json_release_object, json);
-      bool is_plist = !CONSP (XCAR (tail));
-      FOR_EACH_TAIL (tail)
-        {
-          const char *key_str;
-          Lisp_Object value;
-          Lisp_Object key_symbol;
-          if (is_plist)
-            {
-              key_symbol = XCAR (tail);
-              tail = XCDR (tail);
-              CHECK_CONS (tail);
-              value = XCAR (tail);
-            }
-          else
-            {
-              Lisp_Object pair = XCAR (tail);
-              CHECK_CONS (pair);
-              key_symbol = XCAR (pair);
-              value = XCDR (pair);
-            }
-          CHECK_SYMBOL (key_symbol);
-          Lisp_Object key = SYMBOL_NAME (key_symbol);
-          /* We can't specify the length, so the string must be
-             null-terminated.  */
-          check_string_without_embedded_nulls (key);
-          key_str = SSDATA (key);
-          /* In plists, ensure leading ":" in keys is stripped.  It
-             will be reconstructed later in `json_to_lisp'.*/
-          if (is_plist && ':' == key_str[0] && key_str[1])
-            {
-              key_str = &key_str[1];
-            }
-          /* Only add element if key is not already present.  */
-          if (json_object_get (json, key_str) == NULL)
-            {
-              int status
-                = json_object_set_new (json, key_str, lisp_to_json (value,
-                                                                    conf));
-              if (status == -1)
-                json_out_of_memory ();
-            }
-        }
-      CHECK_LIST_END (tail, lisp);
-    }
-  else
-    wrong_type_argument (Qjson_value_p, lisp);
-
-  clear_unwind_protect (count);
-  unbind_to (count, Qnil);
-  return json;
-}
-
-/* Convert LISP to a nonscalar JSON object (array or object).  Signal
-   an error of type `wrong-type-argument' if LISP is not a vector,
-   hashtable, alist, or plist.  */
-
-static json_t *
-lisp_to_json_nonscalar (Lisp_Object lisp,
-                        const struct json_configuration *conf)
-{
-  if (++lisp_eval_depth > max_lisp_eval_depth)
-    xsignal0 (Qjson_object_too_deep);
-  json_t *json = lisp_to_json_nonscalar_1 (lisp, conf);
-  --lisp_eval_depth;
-  return json;
-}
-
-/* Convert LISP to any JSON object.  Signal an error of type
-   `wrong-type-argument' if the type of LISP can't be converted to a
-   JSON object.  */
-
-static json_t *
-lisp_to_json (Lisp_Object lisp, const struct json_configuration *conf)
-{
-  if (EQ (lisp, conf->null_object))
-    return json_check (json_null ());
-  else if (EQ (lisp, conf->false_object))
-    return json_check (json_false ());
-  else if (EQ (lisp, Qt))
-    return json_check (json_true ());
-  else if (INTEGERP (lisp))
-    {
-      intmax_t low = TYPE_MINIMUM (json_int_t);
-      intmax_t high = TYPE_MAXIMUM (json_int_t);
-      intmax_t value = check_integer_range (lisp, low, high);
-      return json_check (json_integer (value));
-    }
-  else if (FLOATP (lisp))
-    return json_check (json_real (XFLOAT_DATA (lisp)));
-  else if (STRINGP (lisp))
-    {
-      Lisp_Object encoded = json_encode (lisp);
-      json_t *json = json_stringn (SSDATA (encoded), SBYTES (encoded));
-      if (json == NULL)
-        {
-          /* A failure can be caused either by an invalid string or by
-             low memory.  */
-          json_check_utf8 (encoded);
-          json_out_of_memory ();
-        }
-      return json;
-    }
-
-  /* LISP now must be a vector, hashtable, alist, or plist.  */
-  return lisp_to_json_nonscalar (lisp, conf);
-}
-
 static void
 json_parse_args (ptrdiff_t nargs,
                  Lisp_Object *args,
@@ -585,6 +387,332 @@ DEFUN ("json--available-p", Fjson__available_p, Sjson__available_p, 0, 0, NULL,
   return json_available_p () ? Qt : Qnil;
 }
 
+/* JSON encoding context */
+typedef struct {
+  char *buf;
+  ptrdiff_t size;		/* number of bytes in buf */
+  ptrdiff_t capacity;		/* allocated size of buf */
+  ptrdiff_t chars_delta;        /* size - {number of Unicode chars in buf} */
+
+  int maxdepth;
+  struct json_configuration conf;
+} json_out_t;
+
+static NO_INLINE void
+json_out_grow (json_out_t *jo, ptrdiff_t bytes)
+{
+  ptrdiff_t need = jo->size + bytes;
+  ptrdiff_t new_size = max (need, 512);
+  while (new_size < need)
+    new_size <<= 1;
+  jo->buf = xrealloc (jo->buf, new_size);
+  jo->capacity = new_size;
+}
+
+static void
+cleanup_json_out (void *arg)
+{
+  json_out_t *jo = arg;
+  xfree (jo->buf);
+  jo->buf = NULL;
+}
+
+/* Make room for `bytes` more bytes in buffer.  */
+static void
+json_make_room (json_out_t *jo, ptrdiff_t bytes)
+{
+  if (bytes > jo->capacity - jo->size)
+    json_out_grow (jo, bytes);
+}
+
+#define JSON_OUT_STR(jo, str) (json_out_str (jo, str, sizeof (str) - 1))
+
+/* Add `bytes` bytes from `str` to the buffer.  */
+static void
+json_out_str (json_out_t *jo, const char *str, size_t bytes)
+{
+  json_make_room (jo, bytes);
+  memcpy (jo->buf + jo->size, str, bytes);
+  jo->size += bytes;
+}
+
+static void
+json_out_byte (json_out_t *jo, unsigned char c)
+{
+  json_make_room (jo, 1);
+  jo->buf[jo->size++] = c;
+}
+
+static void
+json_out_fixnum (json_out_t *jo, EMACS_INT x)
+{
+  char buf[INT_BUFSIZE_BOUND (EMACS_INT)];
+  char *end = buf + sizeof buf;
+  char *p = fixnum_to_string (x, buf, end);
+  json_out_str (jo, p, end - p);
+}
+
+static AVOID
+string_not_unicode (Lisp_Object obj)
+{
+  /* FIXME: for test compatibility, not a very descriptive error */
+  wrong_type_argument (Qjson_value_p, obj);
+}
+
+static unsigned char json_plain_char[256] = {
+  /* 32 chars/line: 1 for printable ASCII + DEL except " and \, 0 elsewhere */
+  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 00-1f */
+  1,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* 20-3f */
+  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1, /* 40-5f */
+  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, /* 60-7f */
+  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* 80-9f */
+  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* a0-bf */
+  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* c0-df */
+  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, /* e0-ff */
+};
+
+static void
+json_out_string (json_out_t *jo, Lisp_Object str, int skip)
+{
+  /* FIXME: this code is slow, make faster! */
+
+  static const char hexchar[16] = "0123456789ABCDEF";
+  ptrdiff_t len = SBYTES (str);
+  json_make_room (jo, len + 2);
+  json_out_byte (jo, '"');
+  unsigned char *p = SDATA (str);
+  unsigned char *end = p + len;
+  p += skip;
+  while (p < end)
+    {
+      unsigned char c = *p;
+      if (json_plain_char[c])
+	{
+	  json_out_byte (jo, c);
+	  p++;
+	}
+      else if (c > 0x7f)
+	{
+	  if (STRING_MULTIBYTE (str))
+	    {
+	      int n;
+	      if (c <= 0xc1)
+		string_not_unicode (str);
+	      if (c <= 0xdf)
+		n = 2;
+	      else if (c <= 0xef)
+		{
+		  int v = (((c & 0x0f) << 12)
+			   + ((p[1] & 0x3f) << 6) + (p[2] & 0x3f));
+		  if (char_surrogate_p (v))
+		    string_not_unicode (str);
+		  n = 3;
+		}
+	      else if (c <= 0xf7)
+		{
+		  int v = (((c & 0x07) << 18)
+			   + ((p[1] & 0x3f) << 12)
+			   + ((p[2] & 0x3f) << 6)
+			   + (p[3] & 0x3f));
+		  if (v > MAX_UNICODE_CHAR)
+		    string_not_unicode (str);
+		  n = 4;
+		}
+	      else
+		string_not_unicode (str);
+	      json_out_str (jo, (const char *)p, n);
+	      jo->chars_delta += n - 1;
+	      p += n;
+	    }
+	  else
+	    string_not_unicode (str);
+	}
+      else
+	{
+	  json_out_byte (jo, '\\');
+	  switch (c)
+	    {
+	    case '"':
+	    case '\\': json_out_byte (jo, c); break;
+	    case '\b': json_out_byte (jo, 'b'); break;
+	    case '\t': json_out_byte (jo, 't'); break;
+	    case '\n': json_out_byte (jo, 'n'); break;
+	    case '\f': json_out_byte (jo, 'f'); break;
+	    case '\r': json_out_byte (jo, 'r'); break;
+	    default:
+	      {
+		char hex[5] = { 'u', '0', '0',
+				hexchar[c >> 4], hexchar[c & 0xf] };
+		json_out_str (jo, hex, 5);
+		break;
+	      }
+	    }
+	  p++;
+	}
+    }
+  json_out_byte (jo, '"');
+}
+
+static void
+json_out_nest (json_out_t *jo)
+{
+  --jo->maxdepth;
+  if (jo->maxdepth < 0)
+    error ("Maximum JSON serialisation depth exceeded");
+}
+
+static void
+json_out_unnest (json_out_t *jo)
+{
+  ++jo->maxdepth;
+}
+
+static void json_out_something (json_out_t *jo, Lisp_Object obj);
+
+static void
+json_out_object_cons (json_out_t *jo, Lisp_Object obj)
+{
+  json_out_nest (jo);
+  json_out_byte (jo, '{');
+  bool is_alist = CONSP (XCAR (obj));
+  bool first = true;
+  Lisp_Object tail = obj;
+  FOR_EACH_TAIL (tail)
+    {
+      if (!first)
+	json_out_byte (jo, ',');
+      first = false;
+      Lisp_Object key_sym;
+      Lisp_Object value;
+      if (is_alist)
+	{
+	  Lisp_Object pair = XCAR (tail);
+	  CHECK_CONS (pair);
+	  key_sym = XCAR (pair);
+	  value = XCDR (pair);
+	}
+      else
+	{
+	  key_sym = XCAR (tail);
+	  tail = XCDR (tail);
+	  CHECK_CONS (tail);
+	  value = XCAR (tail);
+	}
+      /* FIXME: do we care about dup keys here? (probably not) */
+      CHECK_SYMBOL (key_sym);
+      Lisp_Object key = SYMBOL_NAME (key_sym);
+      const char *keystr = SSDATA (key);
+      /* Skip leading ':' in plist keys.  */
+      int skip = !is_alist && keystr[0] == ':' && keystr[1] ? 1 : 0;
+      json_out_string (jo, key, skip);
+      json_out_byte (jo, ':');
+      json_out_something (jo, value);
+    }
+  CHECK_LIST_END (tail, obj);
+  json_out_byte (jo, '}');
+  json_out_unnest (jo);
+}
+
+static void
+json_out_object_hash (json_out_t *jo, Lisp_Object obj)
+{
+  json_out_nest (jo);
+  json_out_byte (jo, '{');
+  struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
+  bool first = true;
+  DOHASH (h, k, v)
+    {
+      if (!first)
+	json_out_byte (jo, ',');
+      first = false;
+      /* FIXME: do we care about dup keys here? (probably not) */
+      CHECK_STRING (k);
+      json_out_string (jo, k, 0);
+      json_out_byte (jo, ':');
+      json_out_something (jo, v);
+    }
+  json_out_byte (jo, '}');
+  json_out_unnest (jo);
+
+}
+
+static void
+json_out_array (json_out_t *jo, Lisp_Object obj)
+{
+  json_out_nest (jo);
+  json_out_byte (jo, '[');
+  ptrdiff_t n = ASIZE (obj);
+  for (ptrdiff_t i = 0; i < n; i++)
+    {
+      if (i > 0)
+	json_out_byte (jo, ',');
+      json_out_something (jo, AREF (obj, i));
+    }
+  json_out_byte (jo, ']');
+  json_out_unnest (jo);
+}
+
+static void
+json_out_float (json_out_t *jo, Lisp_Object f)
+{
+  double x = XFLOAT_DATA (f);
+  if (isinf (x) || isnan (x))
+    signal_error ("not a finite number", f);
+  json_make_room (jo, FLOAT_TO_STRING_BUFSIZE);
+  int n = float_to_string (jo->buf + jo->size, x);
+  jo->size += n;
+}
+
+static void
+json_out_bignum (json_out_t *jo, Lisp_Object x)
+{
+  int base = 10;
+  ptrdiff_t size = bignum_bufsize (x, base);
+  json_make_room (jo, size);
+  int n = bignum_to_c_string (jo->buf + jo->size, size, x, base);
+  jo->size += n;
+}
+
+static void
+json_out_something (json_out_t *jo, Lisp_Object obj)
+{
+  if (EQ (obj, jo->conf.null_object))
+    JSON_OUT_STR (jo, "null");
+  else if (EQ (obj, jo->conf.false_object))
+    JSON_OUT_STR (jo, "false");
+  else if (EQ (obj, Qt))
+    JSON_OUT_STR (jo, "true");
+  else if (NILP (obj))
+    JSON_OUT_STR (jo, "{}");
+  else if (FIXNUMP (obj))
+    json_out_fixnum (jo, XFIXNUM (obj));
+  else if (STRINGP (obj))
+    json_out_string (jo, obj, 0);
+  else if (CONSP (obj))
+    json_out_object_cons (jo, obj);
+  else if (FLOATP (obj))
+    json_out_float (jo, obj);
+  else if (HASH_TABLE_P (obj))
+    json_out_object_hash (jo, obj);
+  else if (VECTORP (obj))
+    json_out_array (jo, obj);
+  else if (BIGNUMP (obj))
+    json_out_bignum (jo, obj);
+  else
+    wrong_type_argument (Qjson_value_p, obj);
+}
+
+static Lisp_Object
+json_out_string_result (json_out_t *jo)
+{
+  /* FIXME: should this be a unibyte or multibyte string?
+     Right now we make a multibyte string for test compatibility,
+     but we are really encoding so unibyte would make more sense.  */
+  ptrdiff_t nchars = jo->size - jo->chars_delta;
+  return make_multibyte_string (jo->buf, nchars, jo->size);
+}
+
+/* FIXME: update doc string */
 DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, MANY,
        NULL,
        doc: /* Return the JSON representation of OBJECT as a string.
@@ -614,95 +742,17 @@ DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, MANY,
 usage: (json-serialize OBJECT &rest ARGS)  */)
      (ptrdiff_t nargs, Lisp_Object *args)
 {
-  specpdl_ref count = SPECPDL_INDEX ();
+  json_out_t jo = {
+    .maxdepth = 25,
+    .conf = {json_object_hashtable, json_array_array, QCnull, QCfalse}
+  };
+  json_parse_args (nargs - 1, args + 1, &jo.conf, false);
+  Lisp_Object object = args[0];
 
-#ifdef WINDOWSNT
-  ensure_json_available ();
-#endif
-
-  struct json_configuration conf =
-    {json_object_hashtable, json_array_array, QCnull, QCfalse};
-  json_parse_args (nargs - 1, args + 1, &conf, false);
-
-  json_t *json = lisp_to_json (args[0], &conf);
-  record_unwind_protect_ptr (json_release_object, json);
-
-  char *string = json_dumps (json, JSON_COMPACT | JSON_ENCODE_ANY);
-  if (string == NULL)
-    json_out_of_memory ();
-  record_unwind_protect_ptr (json_free, string);
-
-  return unbind_to (count, build_string_from_utf8 (string));
-}
-
-struct json_buffer_and_size
-{
-  const char *buffer;
-  ptrdiff_t size;
-  /* This tracks how many bytes were inserted by the callback since
-     json_dump_callback was called.  */
-  ptrdiff_t inserted_bytes;
-};
-
-static Lisp_Object
-json_insert (void *data)
-{
-  struct json_buffer_and_size *buffer_and_size = data;
-  ptrdiff_t len = buffer_and_size->size;
-  ptrdiff_t inserted_bytes = buffer_and_size->inserted_bytes;
-  ptrdiff_t gap_size = GAP_SIZE - inserted_bytes;
-
-  /* Enlarge the gap if necessary.  */
-  if (gap_size < len)
-    make_gap (len - gap_size);
-
-  /* Copy this chunk of data into the gap.  */
-  memcpy ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE + inserted_bytes,
-	  buffer_and_size->buffer, len);
-  buffer_and_size->inserted_bytes += len;
-  return Qnil;
-}
-
-static Lisp_Object
-json_handle_nonlocal_exit (enum nonlocal_exit type, Lisp_Object data)
-{
-  switch (type)
-    {
-    case NONLOCAL_EXIT_SIGNAL:
-      return data;
-    case NONLOCAL_EXIT_THROW:
-      return Fcons (Qno_catch, data);
-    default:
-      eassume (false);
-    }
-}
-
-struct json_insert_data
-{
-  /* This tracks how many bytes were inserted by the callback since
-     json_dump_callback was called.  */
-  ptrdiff_t inserted_bytes;
-  /* nil if json_insert succeeded, otherwise the symbol
-     Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA).  */
-  Lisp_Object error;
-};
-
-/* Callback for json_dump_callback that inserts a JSON representation
-   as a unibyte string into the gap.  DATA must point to a structure
-   of type json_insert_data.  This function may not exit nonlocally.
-   It catches all nonlocal exits and stores them in data->error for
-   reraising.  */
-
-static int
-json_insert_callback (const char *buffer, size_t size, void *data)
-{
-  struct json_insert_data *d = data;
-  struct json_buffer_and_size buffer_and_size
-    = {.buffer = buffer, .size = size, .inserted_bytes = d->inserted_bytes};
-  d->error = internal_catch_all (json_insert, &buffer_and_size,
-                                 json_handle_nonlocal_exit);
-  d->inserted_bytes = buffer_and_size.inserted_bytes;
-  return NILP (d->error) ? 0 : -1;
+  specpdl_ref count = SPECPDL_INDEX ();
+  record_unwind_protect_ptr (cleanup_json_out, &jo);
+  json_out_something (&jo, object);
+  return unbind_to (count, json_out_string_result (&jo));
 }
 
 DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, MANY,
@@ -714,72 +764,61 @@ DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, MANY,
 usage: (json-insert OBJECT &rest ARGS)  */)
      (ptrdiff_t nargs, Lisp_Object *args)
 {
-  specpdl_ref count = SPECPDL_INDEX ();
+  json_out_t jo = {
+    .maxdepth = 25,
+    .conf = {json_object_hashtable, json_array_array, QCnull, QCfalse}
+  };
+  json_parse_args (nargs - 1, args + 1, &jo.conf, false);
+  Lisp_Object object = args[0];
 
-#ifdef WINDOWSNT
-  ensure_json_available ();
-#endif
-
-  struct json_configuration conf =
-    {json_object_hashtable, json_array_array, QCnull, QCfalse};
-  json_parse_args (nargs - 1, args + 1, &conf, false);
+  specpdl_ref count = SPECPDL_INDEX ();
+  record_unwind_protect_ptr (cleanup_json_out, &jo);
+  json_out_something (&jo, object);
 
-  json_t *json = lisp_to_json (args[0], &conf);
-  record_unwind_protect_ptr (json_release_object, json);
+  /* FIXME: Do we really need to do all this work below to insert a string?
+     Is there no function already written?  I must be missing something.  */
 
   prepare_to_modify_buffer (PT, PT, NULL);
   move_gap_both (PT, PT_BYTE);
-  struct json_insert_data data;
-  data.inserted_bytes = 0;
-  /* Could have used json_dumpb, but that became available only in
-     Jansson 2.10, whereas we want to support 2.7 and upward.  */
-  int status = json_dump_callback (json, json_insert_callback, &data,
-                                   JSON_COMPACT | JSON_ENCODE_ANY);
-  if (status == -1)
-    {
-      if (CONSP (data.error))
-        xsignal (XCAR (data.error), XCDR (data.error));
-      else
-        json_out_of_memory ();
-    }
+  if (GAP_SIZE < jo.size)
+    make_gap (jo.size - GAP_SIZE);
+  memcpy ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE, jo.buf, jo.size);
+
+  /* No need to keep allocation beyond this point.  */
+  unbind_to (count, Qnil);
 
   ptrdiff_t inserted = 0;
-  ptrdiff_t inserted_bytes = data.inserted_bytes;
-  if (inserted_bytes > 0)
+  ptrdiff_t inserted_bytes = jo.size;
+
+  /* If required, decode the stuff we've read into the gap.  */
+  struct coding_system coding;
+  /* JSON strings are UTF-8 encoded strings.  */
+  setup_coding_system (Qutf_8_unix, &coding);
+  coding.dst_multibyte = !NILP (BVAR (current_buffer,
+				      enable_multibyte_characters));
+  if (CODING_MAY_REQUIRE_DECODING (&coding))
     {
-      /* If required, decode the stuff we've read into the gap.  */
-      struct coding_system coding;
-      /* JSON strings are UTF-8 encoded strings.  If for some reason
-	 the text returned by the Jansson library includes invalid
-	 byte sequences, they will be represented by raw bytes in the
-	 buffer text.  */
-      setup_coding_system (Qutf_8_unix, &coding);
-      coding.dst_multibyte =
-	!NILP (BVAR (current_buffer, enable_multibyte_characters));
-      if (CODING_MAY_REQUIRE_DECODING (&coding))
-	{
-          /* Now we have all the new bytes at the beginning of the gap,
-             but `decode_coding_gap` needs them at the end of the gap, so
-             we need to move them.  */
-          memmove (GAP_END_ADDR - inserted_bytes, GPT_ADDR, inserted_bytes);
-	  decode_coding_gap (&coding, inserted_bytes);
-	  inserted = coding.produced_char;
-	}
-      else
-	{
-          /* Make the inserted text part of the buffer, as unibyte text.  */
-          eassert (NILP (BVAR (current_buffer, enable_multibyte_characters)));
-          insert_from_gap_1 (inserted_bytes, inserted_bytes, false);
-
-	  /* The target buffer is unibyte, so we don't need to decode.  */
-	  invalidate_buffer_caches (current_buffer,
-				    PT, PT + inserted_bytes);
-	  adjust_after_insert (PT, PT_BYTE,
-			       PT + inserted_bytes,
-			       PT_BYTE + inserted_bytes,
-			       inserted_bytes);
-	  inserted = inserted_bytes;
-	}
+      /* Now we have all the new bytes at the beginning of the gap,
+	 but `decode_coding_gap` needs them at the end of the gap, so
+	 we need to move them.  */
+      memmove (GAP_END_ADDR - inserted_bytes, GPT_ADDR, inserted_bytes);
+      decode_coding_gap (&coding, inserted_bytes);
+      inserted = coding.produced_char;
+    }
+  else
+    {
+      /* Make the inserted text part of the buffer, as unibyte text.  */
+      eassert (NILP (BVAR (current_buffer, enable_multibyte_characters)));
+      insert_from_gap_1 (inserted_bytes, inserted_bytes, false);
+
+      /* The target buffer is unibyte, so we don't need to decode.  */
+      invalidate_buffer_caches (current_buffer,
+				PT, PT + inserted_bytes);
+      adjust_after_insert (PT, PT_BYTE,
+			   PT + inserted_bytes,
+			   PT_BYTE + inserted_bytes,
+			   inserted_bytes);
+      inserted = inserted_bytes;
     }
 
   /* Call after-change hooks.  */
@@ -791,7 +830,7 @@ DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, MANY,
       SET_PT_BOTH (PT + inserted, PT_BYTE + inserted_bytes);
     }
 
-  return unbind_to (count, Qnil);
+  return Qnil;
 }
 
 /* Convert a JSON object to a Lisp object.  */
diff --git a/test/src/json-tests.el b/test/src/json-tests.el
index dffc6291ca1..c908c031a82 100644
--- a/test/src/json-tests.el
+++ b/test/src/json-tests.el
@@ -90,8 +90,11 @@ json-serialize/object
                  "{\"abc\":[1,2,true],\"def\":null}"))
   (should (equal (json-serialize nil) "{}"))
   (should (equal (json-serialize '((abc))) "{\"abc\":{}}"))
-  (should (equal (json-serialize '((a . 1) (b . 2) (a . 3)))
+  (should (equal (json-serialize '((a . 1) (b . 2)))
                  "{\"a\":1,\"b\":2}"))
+  ;; FIXME: we assume hash table keys to be unique
+  ;; (should (equal (json-serialize '((a . 1) (b . 2) (a . 3)))
+  ;;                "{\"a\":1,\"b\":2}"))
   (should-error (json-serialize '(abc)) :type 'wrong-type-argument)
   (should-error (json-serialize '((a 1))) :type 'wrong-type-argument)
   (should-error (json-serialize '((1 . 2))) :type 'wrong-type-argument)
@@ -124,13 +127,14 @@ json-serialize/object
 \"detect-plist\":{\"bla\":\"ble\"}\
 }")))
 
-(ert-deftest json-serialize/object-with-duplicate-keys ()
-  (skip-unless (fboundp 'json-serialize))
-  (let ((table (make-hash-table :test #'eq)))
-    (puthash (copy-sequence "abc") [1 2 t] table)
-    (puthash (copy-sequence "abc") :null table)
-    (should (equal (hash-table-count table) 2))
-    (should-error (json-serialize table) :type 'wrong-type-argument)))
+;; FIXME: we don't check for duplicate keys
+;; (ert-deftest json-serialize/object-with-duplicate-keys ()
+;;   (skip-unless (fboundp 'json-serialize))
+;;   (let ((table (make-hash-table :test #'eq)))
+;;     (puthash (copy-sequence "abc") [1 2 t] table)
+;;     (puthash (copy-sequence "abc") :null table)
+;;     (should (equal (hash-table-count table) 2))
+;;     (should-error (json-serialize table) :type 'wrong-type-argument)))
 
 (ert-deftest json-parse-string/object ()
   (skip-unless (fboundp 'json-parse-string))
@@ -174,7 +178,10 @@ json-serialize/string
                  "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]"))
   (should (equal (json-serialize ["a\0b"]) "[\"a\\u0000b\"]"))
   ;; FIXME: Is this the right behavior?
-  (should (equal (json-serialize ["\u00C4\xC3\x84"]) "[\"\u00C4\u00C4\"]")))
+  ;; FIXME: (no it's not)
+  ;; (should (equal (json-serialize ["\u00C4\xC3\x84"]) "[\"\u00C4\u00C4\"]"))
+  (should-error (json-serialize ["\u00C4\xC3\x84"]))
+  )
 
 (ert-deftest json-serialize/invalid-unicode ()
   (skip-unless (fboundp 'json-serialize))

^ permalink raw reply related	[flat|nested] 37+ messages in thread

end of thread, other threads:[~2024-09-08 18:33 UTC | newest]

Thread overview: 37+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-03-26 15:33 bug#70007: [PATCH] native JSON encoder Mattias Engdegård
2024-03-26 16:46 ` Eli Zaretskii
2024-03-27 12:46   ` Mattias Engdegård
2024-03-27 15:49     ` Mattias Engdegård
2024-03-27 17:40       ` Eli Zaretskii
2024-03-27 18:57         ` Mattias Engdegård
2024-03-27 19:05           ` Eli Zaretskii
2024-03-28 20:59             ` Mattias Engdegård
2024-03-29  6:04               ` Eli Zaretskii
2024-03-30 11:41                 ` Mattias Engdegård
2024-03-30 13:22                   ` Eli Zaretskii
2024-03-30 14:22                     ` Mattias Engdegård
2024-03-30 16:14                       ` Richard Copley
2024-03-30 16:40                         ` Eli Zaretskii
2024-03-30 23:29                           ` Richard Copley
2024-03-30 16:45                         ` Andy Moreton
2024-03-30 20:36                           ` Corwin Brust
2024-03-30 16:37                       ` Eli Zaretskii
2024-03-30 20:21                         ` Mattias Engdegård
2024-04-02 14:13                       ` Mattias Engdegård
2024-04-02 16:13                         ` Eli Zaretskii
2024-04-02 17:19                           ` Mattias Engdegård
2024-08-24 15:33                             ` Mattias Engdegård
2024-08-24 16:14                               ` Eli Zaretskii
2024-08-24 19:45                                 ` Mattias Engdegård
2024-08-25  5:07                                   ` Eli Zaretskii
2024-08-25 17:55                                     ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-08-25 18:26                                       ` Eli Zaretskii
2024-08-25 19:20                                         ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-08-31 22:15                                           ` Stefan Kangas
2024-09-07  7:26                                             ` Eli Zaretskii
2024-09-07 15:48                                               ` Andrea Corallo
2024-09-07 15:52                                                 ` Eli Zaretskii
2024-09-08 18:33                                                   ` Mattias Engdegård
2024-08-25 20:08                                       ` Mattias Engdegård
2024-08-31  9:45                                         ` Eli Zaretskii
2024-03-28 19:16   ` Theodor Thornhill via Bug reports for GNU Emacs, the Swiss army knife of text editors

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/emacs.git
	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.