/* JSON parsing and serialization.

Copyright (C) 2017-2024 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 <https://www.gnu.org/licenses/>.  */

#include <config.h>

#include <errno.h>
#include <stddef.h>
#include <stdint.h>
#include <stdlib.h>
#include <math.h>

#include <jansson.h>

#include "lisp.h"
#include "buffer.h"
#include "coding.h"

#define JSON_HAS_ERROR_CODE (JANSSON_VERSION_HEX >= 0x020B00)

#ifdef WINDOWSNT
# include <windows.h>
# include "w32common.h"
# include "w32.h"

DEF_DLL_FN (void, json_set_alloc_funcs,
	    (json_malloc_t malloc_fn, json_free_t free_fn));
DEF_DLL_FN (void, json_delete, (json_t *json));
DEF_DLL_FN (json_t *, json_array, (void));
DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value));
DEF_DLL_FN (size_t, json_array_size, (const json_t *array));
DEF_DLL_FN (json_t *, json_object, (void));
DEF_DLL_FN (int, json_object_set_new,
	    (json_t *object, const char *key, json_t *value));
DEF_DLL_FN (json_t *, json_null, (void));
DEF_DLL_FN (json_t *, json_true, (void));
DEF_DLL_FN (json_t *, json_false, (void));
DEF_DLL_FN (json_t *, json_integer, (json_int_t value));
DEF_DLL_FN (json_t *, json_real, (double value));
DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len));
DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags));
DEF_DLL_FN (int, json_dump_callback,
	    (const json_t *json, json_dump_callback_t callback, void *data,
	     size_t flags));
DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer));
DEF_DLL_FN (double, json_real_value, (const json_t *real));
DEF_DLL_FN (const char *, json_string_value, (const json_t *string));
DEF_DLL_FN (size_t, json_string_length, (const json_t *string));
DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index));
DEF_DLL_FN (json_t *, json_object_get, (const json_t *object, const char *key));
DEF_DLL_FN (size_t, json_object_size, (const json_t *object));
DEF_DLL_FN (const char *, json_object_iter_key, (void *iter));
DEF_DLL_FN (void *, json_object_iter, (json_t *object));
DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter));
DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key));
DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter));
DEF_DLL_FN (json_t *, json_loads,
	    (const char *input, size_t flags, json_error_t *error));
DEF_DLL_FN (json_t *, json_load_callback,
	    (json_load_callback_t callback, void *data, size_t flags,
	     json_error_t *error));

/* This is called by json_decref, which is an inline function.  */
void json_delete(json_t *json)
{
  fn_json_delete (json);
}

static bool json_initialized;

static bool
init_json_functions (void)
{
  HMODULE library = w32_delayed_load (Qjson);

  if (!library)
    return false;

  LOAD_DLL_FN (library, json_set_alloc_funcs);
  LOAD_DLL_FN (library, json_delete);
  LOAD_DLL_FN (library, json_array);
  LOAD_DLL_FN (library, json_array_append_new);
  LOAD_DLL_FN (library, json_array_size);
  LOAD_DLL_FN (library, json_object);
  LOAD_DLL_FN (library, json_object_set_new);
  LOAD_DLL_FN (library, json_null);
  LOAD_DLL_FN (library, json_true);
  LOAD_DLL_FN (library, json_false);
  LOAD_DLL_FN (library, json_integer);
  LOAD_DLL_FN (library, json_real);
  LOAD_DLL_FN (library, json_stringn);
  LOAD_DLL_FN (library, json_dumps);
  LOAD_DLL_FN (library, json_dump_callback);
  LOAD_DLL_FN (library, json_integer_value);
  LOAD_DLL_FN (library, json_real_value);
  LOAD_DLL_FN (library, json_string_value);
  LOAD_DLL_FN (library, json_string_length);
  LOAD_DLL_FN (library, json_array_get);
  LOAD_DLL_FN (library, json_object_get);
  LOAD_DLL_FN (library, json_object_size);
  LOAD_DLL_FN (library, json_object_iter_key);
  LOAD_DLL_FN (library, json_object_iter);
  LOAD_DLL_FN (library, json_object_iter_value);
  LOAD_DLL_FN (library, json_object_key_to_iter);
  LOAD_DLL_FN (library, json_object_iter_next);
  LOAD_DLL_FN (library, json_loads);
  LOAD_DLL_FN (library, json_load_callback);

  init_json ();

  return true;
}

#define json_set_alloc_funcs fn_json_set_alloc_funcs
#define json_array fn_json_array
#define json_array_append_new fn_json_array_append_new
#define json_array_size fn_json_array_size
#define json_object fn_json_object
#define json_object_set_new fn_json_object_set_new
#define json_null fn_json_null
#define json_true fn_json_true
#define json_false fn_json_false
#define json_integer fn_json_integer
#define json_real fn_json_real
#define json_stringn fn_json_stringn
#define json_dumps fn_json_dumps
#define json_dump_callback fn_json_dump_callback
#define json_integer_value fn_json_integer_value
#define json_real_value fn_json_real_value
#define json_string_value fn_json_string_value
#define json_string_length fn_json_string_length
#define json_array_get fn_json_array_get
#define json_object_get fn_json_object_get
#define json_object_size fn_json_object_size
#define json_object_iter_key fn_json_object_iter_key
#define json_object_iter fn_json_object_iter
#define json_object_iter_value fn_json_object_iter_value
#define json_object_key_to_iter fn_json_object_key_to_iter
#define json_object_iter_next fn_json_object_iter_next
#define json_loads fn_json_loads
#define json_load_callback fn_json_load_callback

#endif	/* WINDOWSNT */

/* We install a custom allocator so that we can avoid objects larger
   than PTRDIFF_MAX.  Such objects wouldn't play well with the rest of
   Emacs's codebase, which generally uses ptrdiff_t for sizes and
   indices.  The other functions in this file also generally assume
   that size_t values never exceed PTRDIFF_MAX.

   In addition, we need to use a custom allocator because on
   MS-Windows we replace malloc/free with our own functions, see
   w32heap.c, so we must force the library to use our allocator, or
   else we won't be able to free storage allocated by the library.  */

static void *
json_malloc (size_t size)
{
  if (size > PTRDIFF_MAX)
    {
      errno = ENOMEM;
      return NULL;
    }
  return malloc (size);
}

static void
json_free (void *ptr)
{
  free (ptr);
}

void
init_json (void)
{
  json_set_alloc_funcs (json_malloc, json_free);
}

#if !JSON_HAS_ERROR_CODE

/* Return whether STRING starts with PREFIX.  */

static bool
json_has_prefix (const char *string, const char *prefix)
{
  return strncmp (string, prefix, strlen (prefix)) == 0;
}

/* Return whether STRING ends with SUFFIX.  */

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;
}

#endif

/* Note that all callers of make_string_from_utf8 and build_string_from_utf8
   below either pass only value UTF-8 strings or use the functionf for
   formatting error messages; in the latter case correctness isn't
   critical.  */

/* Return a unibyte string containing the sequence of UTF-8 encoding
   units of the UTF-8 representation of STRING.  If STRING does not
   represent a sequence of Unicode scalar values, return a string with
   unspecified contents.  */

static Lisp_Object
json_encode (Lisp_Object string)
{
  /* FIXME: Raise an error if STRING is not a scalar value
     sequence.  */
  return encode_string_utf_8 (string, Qnil, false, Qt, Qt);
}

/* Signal a Lisp error corresponding to the JSON ERROR.  */

static AVOID
json_parse_error (const json_error_t *error)
{
  Lisp_Object symbol;
#if JSON_HAS_ERROR_CODE
  switch (json_error_code (error))
    {
    case json_error_premature_end_of_input:
      symbol = Qjson_end_of_file;
      break;
    case json_error_end_of_input_expected:
      symbol = Qjson_trailing_content;
      break;
    default:
      symbol = Qjson_parse_error;
      break;
    }
#else
  if (json_has_suffix (error->text, "expected near end of file"))
    symbol = Qjson_end_of_file;
  else if (json_has_prefix (error->text, "end of file expected"))
    symbol = Qjson_trailing_content;
  else
    symbol = Qjson_parse_error;
#endif
  xsignal (symbol,
           list5 (build_string_from_utf8 (error->text),
                  build_string_from_utf8 (error->source),
		  INT_TO_INTEGER (error->line),
                  INT_TO_INTEGER (error->column),
		  INT_TO_INTEGER (error->position)));
}

static void
json_release_object (void *object)
{
  json_decref (object);
}

/* Signal an error if OBJECT is not a string, or if OBJECT contains
   embedded null characters.  */

static void
check_string_without_embedded_nulls (Lisp_Object object)
{
  CHECK_STRING (object);
  CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL,
              Qstring_without_embedded_nulls_p, object);
}

enum json_object_type {
  json_object_hashtable,
  json_object_alist,
  json_object_plist
};

enum json_array_type {
  json_array_array,
  json_array_list
};

struct json_configuration {
  enum json_object_type object_type;
  enum json_array_type array_type;
  Lisp_Object null_object;
  Lisp_Object false_object;
};

static void
json_parse_args (ptrdiff_t nargs,
                 Lisp_Object *args,
                 struct json_configuration *conf,
                 bool parse_object_types)
{
  if ((nargs % 2) != 0)
    wrong_type_argument (Qplistp, Flist (nargs, args));

  /* Start from the back so keyword values appearing
     first take precedence. */
  for (ptrdiff_t i = nargs; i > 0; i -= 2) {
    Lisp_Object key = args[i - 2];
    Lisp_Object value = args[i - 1];
    if (parse_object_types && EQ (key, QCobject_type))
      {
        if (EQ (value, Qhash_table))
          conf->object_type = json_object_hashtable;
        else if (EQ (value, Qalist))
          conf->object_type = json_object_alist;
        else if (EQ (value, Qplist))
          conf->object_type = json_object_plist;
        else
          wrong_choice (list3 (Qhash_table, Qalist, Qplist), value);
      }
    else if (parse_object_types && EQ (key, QCarray_type))
      {
        if (EQ (value, Qarray))
          conf->array_type = json_array_array;
        else if (EQ (value, Qlist))
          conf->array_type = json_array_list;
        else
          wrong_choice (list2 (Qarray, Qlist), value);
      }
    else if (EQ (key, QCnull_object))
      conf->null_object = value;
    else if (EQ (key, QCfalse_object))
      conf->false_object = value;
    else if (parse_object_types)
      wrong_choice (list4 (QCobject_type,
                           QCarray_type,
                           QCnull_object,
                           QCfalse_object),
                    value);
    else
      wrong_choice (list2 (QCnull_object,
                           QCfalse_object),
                    value);
  }
}

static bool
json_available_p (void)
{
#ifdef WINDOWSNT
  if (!json_initialized)
    {
      Lisp_Object status;
      json_initialized = init_json_functions ();
      status = json_initialized ? Qt : Qnil;
      Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache);
    }
  return json_initialized;
#else  /* !WINDOWSNT */
  return true;
#endif
}

#ifdef WINDOWSNT
static void
ensure_json_available (void)
{
  if (!json_available_p ())
    Fsignal (Qjson_unavailable,
	     list1 (build_unibyte_string ("jansson library not found")));
}
#endif

DEFUN ("json--available-p", Fjson__available_p, Sjson__available_p, 0, 0, NULL,
       doc: /* Return non-nil if libjansson is available (internal use only).  */)
  (void)
{
  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 symset_tbl *ss_table;	/* table used by containing object */
  struct json_configuration conf;
} json_out_t;

/* Set of symbols */
typedef struct {
  int count;			/* symbols in table */
  int bits;			/* log2(table size) */
  struct symset_tbl *table;	/* heap-allocated table */
} symset_t;

struct symset_tbl
{
  /* Table used by the containing object if any, so that we can easily
     all tables if an error occurs.  */
  struct symset_tbl *up;
  /* Table of symbols (2**bits entries), Qunbound where unused.  */
  Lisp_Object entries[];
};

static struct symset_tbl *
alloc_symset_table (int bits)
{
  struct symset_tbl *st = xmalloc (sizeof *st + (sizeof *st->entries << bits));
  int size = 1 << bits;
  for (ptrdiff_t i = 0; i < size; i++)
    st->entries[i] = Qunbound;
  return st;
}

/* Create a new symset to use for a new object.  */
static symset_t
push_symset (json_out_t *jo)
{
  int bits = 4;
  struct symset_tbl *tbl = alloc_symset_table (bits);
  tbl->up = jo->ss_table;
  jo->ss_table = tbl;
  return (symset_t){ .count = 0, .bits = 4, .table = tbl };
}

/* Destroy the current symset.  */
static void
pop_symset (json_out_t *jo, symset_t *ss)
{
  jo->ss_table = ss->table->up;
  xfree (ss->table);
}

/* Remove all heap-allocated symset tables, in case an error occurred.  */
static void
cleanup_symset_tables (struct symset_tbl *st)
{
  while (st)
    {
      struct symset_tbl *up = st->up;
      xfree (st);
      st = up;
    }
}

static inline uint32_t
symset_hash (Lisp_Object sym, int bits)
{
  return knuth_hash (reduce_emacs_uint_to_hash_hash (XHASH (sym)), bits);
}

/* Enlarge the table used by a symset. */
static NO_INLINE void
symset_expand (symset_t *ss)
{
  struct symset_tbl *old_table = ss->table;
  int oldbits = ss->bits;
  int oldsize = 1 << oldbits;
  int bits = oldbits + 1;
  ss->bits = bits;
  ss->table = alloc_symset_table (bits);
  ss->table->up = old_table->up;
  /* Move all entries from the old table to the new one.  */
  int mask = (1 << bits) - 1;
  struct symset_tbl *tbl = ss->table;
  for (ptrdiff_t i = 0; i < oldsize; i++)
    {
      Lisp_Object sym = old_table->entries[i];
      if (!BASE_EQ (sym, Qunbound))
	{
	  ptrdiff_t j = symset_hash (sym, bits);
	  while (!BASE_EQ (tbl->entries[j], Qunbound))
	    j = (j + 1) & mask;
	  tbl->entries[j] = sym;
	}
    }
  xfree (old_table);
}

/* If sym is in ss, return false; otherwise add it and return true.
   Comparison is done by strict identity.  */
static inline bool
symset_add (json_out_t *jo, symset_t *ss, Lisp_Object sym)
{
  /* Make sure we don't fill more than half of the table.  */
  if (ss->count * 2 >= (1 << ss->bits))
    {
      symset_expand (ss);
      jo->ss_table = ss->table;
    }

  struct symset_tbl *tbl = ss->table;
  int mask = (1 << ss->bits) - 1;
  for (ptrdiff_t i = symset_hash (sym, ss->bits); ; i = (i + 1) & mask)
    {
      Lisp_Object s = tbl->entries[i];
      if (BASE_EQ (s, sym))
	return false;		/* Previous occurrence found.  */
      if (BASE_EQ (s, Qunbound))
	{
	  /* Not in set, add it.  */
	  tbl->entries[i] = sym;
	  ss->count++;
	  return true;
	}
    }
}

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);
  cleanup_symset_tables (jo->ss_table);
}

/* 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);
  symset_t ss = push_symset (jo);
  json_out_byte (jo, '{');
  bool is_alist = CONSP (XCAR (obj));
  bool first = true;
  Lisp_Object tail = obj;
  FOR_EACH_TAIL (tail)
    {
      Lisp_Object key;
      Lisp_Object value;
      if (is_alist)
	{
	  Lisp_Object pair = XCAR (tail);
	  CHECK_CONS (pair);
	  key = XCAR (pair);
	  value = XCDR (pair);
	}
      else
	{
	  key = XCAR (tail);
	  tail = XCDR (tail);
	  CHECK_CONS (tail);
	  value = XCAR (tail);
	}
      key = maybe_remove_pos_from_symbol (key);
      CHECK_TYPE (BARE_SYMBOL_P (key), Qsymbolp, key);

      if (symset_add (jo, &ss, key))
	{
	  if (!first)
	    json_out_byte (jo, ',');
	  first = false;

	  Lisp_Object key_str = SYMBOL_NAME (key);
	  const char *str = SSDATA (key_str);
	  /* Skip leading ':' in plist keys.  */
	  int skip = !is_alist && str[0] == ':' && str[1] ? 1 : 0;
	  json_out_string (jo, key_str, skip);
	  json_out_byte (jo, ':');
	  json_out_something (jo, value);
	}
    }
  CHECK_LIST_END (tail, obj);
  json_out_byte (jo, '}');
  pop_symset (jo, &ss);
  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);
}

DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, MANY,
       NULL,
       doc: /* Return the JSON representation of OBJECT as a string.

OBJECT must be t, a number, string, vector, hashtable, alist, plist,
or the Lisp equivalents to the JSON null and false values, and its
elements must recursively consist of the same kinds of values.  t will
be converted to the JSON true value.  Vectors will be converted to
JSON arrays, whereas hashtables, alists and plists are converted to
JSON objects.  Hashtable keys must be strings and must be unique within
each object.  Alist and plist keys must be symbols; if a key is duplicate,
the first instance is used.

The Lisp equivalents to the JSON null and false values are
configurable in the arguments ARGS, a list of keyword/argument pairs:

The keyword argument `:null-object' specifies which object to use
to represent a JSON null value.  It defaults to `:null'.

The keyword argument `:false-object' specifies which object to use to
represent a JSON false value.  It defaults to `:false'.

In you specify the same value for `:null-object' and `:false-object',
a potentially ambiguous situation, the JSON output will not contain
any JSON false values.
usage: (json-serialize OBJECT &rest ARGS)  */)
     (ptrdiff_t nargs, Lisp_Object *args)
{
  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];

  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,
       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.
usage: (json-insert OBJECT &rest ARGS)  */)
     (ptrdiff_t nargs, Lisp_Object *args)
{
  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];

  specpdl_ref count = SPECPDL_INDEX ();
  record_unwind_protect_ptr (cleanup_json_out, &jo);
  json_out_something (&jo, object);

  /* 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);
  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 = 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))
    {
      /* 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.  */
  signal_after_change (PT, 0, inserted);
  if (inserted > 0)
    {
      update_compositions (PT, PT, CHECK_BORDER);
      /* Move point to after the inserted text.  */
      SET_PT_BOTH (PT + inserted, PT_BYTE + inserted_bytes);
    }

  return Qnil;
}

/* Convert a JSON object to a Lisp object.  */

static Lisp_Object ARG_NONNULL ((1))
json_to_lisp (json_t *json, const struct json_configuration *conf)
{
  switch (json_typeof (json))
    {
    case JSON_NULL:
      return conf->null_object;
    case JSON_FALSE:
      return conf->false_object;
    case JSON_TRUE:
      return Qt;
    case JSON_INTEGER:
      {
	json_int_t i = json_integer_value (json);
	return INT_TO_INTEGER (i);
      }
    case JSON_REAL:
      return make_float (json_real_value (json));
    case JSON_STRING:
      return make_string_from_utf8 (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 (PTRDIFF_MAX < size)
          overflow_error ();
        Lisp_Object result;
        switch (conf->array_type)
          {
          case json_array_array:
            {
              result = make_vector (size, Qunbound);
              for (ptrdiff_t i = 0; i < size; ++i)
                {
                  rarely_quit (i);
                  ASET (result, i,
                        json_to_lisp (json_array_get (json, i), conf));
                }
              break;
            }
          case json_array_list:
            {
              result = Qnil;
              for (ptrdiff_t i = size - 1; i >= 0; --i)
                {
                  rarely_quit (i);
                  result = Fcons (json_to_lisp (json_array_get (json, i), conf),
                                  result);
                }
              break;
            }
          default:
            /* Can't get here.  */
            emacs_abort ();
          }
        --lisp_eval_depth;
        return result;
      }
    case JSON_OBJECT:
      {
        if (++lisp_eval_depth > max_lisp_eval_depth)
          xsignal0 (Qjson_object_too_deep);
        Lisp_Object result;
        switch (conf->object_type)
          {
          case json_object_hashtable:
            {
              size_t size = json_object_size (json);
              if (FIXNUM_OVERFLOW_P (size))
                overflow_error ();
              result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize,
                              make_fixed_natnum (size));
              struct Lisp_Hash_Table *h = XHASH_TABLE (result);
              const char *key_str;
              json_t *value;
              json_object_foreach (json, key_str, value)
                {
		  Lisp_Object key = build_string_from_utf8 (key_str);
		  hash_hash_t hash;
                  ptrdiff_t i = hash_lookup_get_hash (h, key, &hash);
                  /* Keys in JSON objects are unique, so the key can't
                     be present yet.  */
                  eassert (i < 0);
                  hash_put (h, key, json_to_lisp (value, conf), hash);
                }
              break;
            }
          case json_object_alist:
            {
              result = Qnil;
              const char *key_str;
              json_t *value;
              json_object_foreach (json, key_str, value)
                {
                  Lisp_Object key
		    = Fintern (build_string_from_utf8 (key_str), Qnil);
                  result
                    = Fcons (Fcons (key, json_to_lisp (value, conf)),
                             result);
                }
              result = Fnreverse (result);
              break;
            }
          case json_object_plist:
            {
              result = Qnil;
              const char *key_str;
              json_t *value;
              json_object_foreach (json, key_str, value)
                {
                  USE_SAFE_ALLOCA;
                  ptrdiff_t key_str_len = strlen (key_str);
                  char *keyword_key_str = SAFE_ALLOCA (1 + key_str_len + 1);
                  keyword_key_str[0] = ':';
                  strcpy (&keyword_key_str[1], key_str);
                  Lisp_Object key = intern_1 (keyword_key_str, key_str_len + 1);
                  /* Build the plist as value-key since we're going to
                     reverse it in the end.*/
                  result = Fcons (key, result);
                  result = Fcons (json_to_lisp (value, conf), result);
                  SAFE_FREE ();
                }
              result = Fnreverse (result);
              break;
            }
          default:
            /* Can't get here.  */
            emacs_abort ();
          }
        --lisp_eval_depth;
        return result;
      }
    }
  /* Can't get here.  */
  emacs_abort ();
}

DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY,
       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 the JSON null value, the JSON false
value, t, a number, a string, a vector, a list, a hashtable, an alist,
or a plist.  Its elements will be further objects of these types.  If
there are duplicate keys in an object, all but the last one are
ignored.  If STRING doesn't contain a valid JSON object, this function
signals an error of type `json-parse-error'.

The arguments ARGS are a list of keyword/argument pairs:

The keyword argument `:object-type' specifies which Lisp type is used
to represent objects; it can be `hash-table', `alist' or `plist'.  It
defaults to `hash-table'.

The keyword argument `:array-type' specifies which Lisp type is used
to represent arrays; it can be `array' (the default) or `list'.

The keyword argument `:null-object' specifies which object to use
to represent a JSON null value.  It defaults to `:null'.

The keyword argument `:false-object' specifies which object to use to
represent a JSON false value.  It defaults to `:false'.
usage: (json-parse-string STRING &rest ARGS) */)
  (ptrdiff_t nargs, Lisp_Object *args)
{
  specpdl_ref count = SPECPDL_INDEX ();

#ifdef WINDOWSNT
  ensure_json_available ();
#endif

  Lisp_Object string = args[0];
  CHECK_STRING (string);
  Lisp_Object encoded = json_encode (string);
  check_string_without_embedded_nulls (encoded);
  struct json_configuration conf =
    {json_object_hashtable, json_array_array, QCnull, QCfalse};
  json_parse_args (nargs - 1, args + 1, &conf, true);

  json_error_t error;
  json_t *object
    = json_loads (SSDATA (encoded), JSON_DECODE_ANY | JSON_ALLOW_NUL, &error);
  if (object == NULL)
    json_parse_error (&error);

  /* Avoid leaking the object in case of further errors.  */
  if (object != NULL)
    record_unwind_protect_ptr (json_release_object, object);

  return unbind_to (count, json_to_lisp (object, &conf));
}

struct json_read_buffer_data
{
  /* Byte position of position to read the next chunk from.  */
  ptrdiff_t point;
};

/* Callback for json_load_callback that reads from the current buffer.
   DATA must point to a structure of type json_read_buffer_data.
   data->point must point to the byte position to read from; after
   reading, data->point is advanced accordingly.  The buffer point
   itself is ignored.  This function may not exit nonlocally.  */

static size_t
json_read_buffer_callback (void *buffer, size_t buflen, void *data)
{
  struct json_read_buffer_data *d = 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 = BUFFER_CEILING_OF (point) + 1;
  ptrdiff_t count = end - point;
  if (buflen < count)
    count = buflen;
  memcpy (buffer, BYTE_POS_ADDR (point), count);
  d->point += count;
  return count;
}

DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
       0, MANY, NULL,
       doc: /* Read JSON object from current buffer starting at point.
Move point after the end of the object if parsing was successful.
On error, don't move point.

The returned object will be a vector, list, hashtable, alist, or
plist.  Its elements will be the JSON null value, the JSON false
value, t, numbers, strings, or further vectors, lists, hashtables,
alists, or plists.  If there are duplicate keys in an object, all
but the last one are ignored.

If the current buffer doesn't contain a valid JSON object, the
function signals an error of type `json-parse-error'.

The arguments ARGS are a list of keyword/argument pairs:

The keyword argument `:object-type' specifies which Lisp type is used
to represent objects; it can be `hash-table', `alist' or `plist'.  It
defaults to `hash-table'.

The keyword argument `:array-type' specifies which Lisp type is used
to represent arrays; it can be `array' (the default) or `list'.

The keyword argument `:null-object' specifies which object to use
to represent a JSON null value.  It defaults to `:null'.

The keyword argument `:false-object' specifies which object to use to
represent a JSON false value.  It defaults to `:false'.
usage: (json-parse-buffer &rest args) */)
     (ptrdiff_t nargs, Lisp_Object *args)
{
  specpdl_ref count = SPECPDL_INDEX ();

#ifdef WINDOWSNT
  ensure_json_available ();
#endif

  struct json_configuration conf =
    {json_object_hashtable, json_array_array, QCnull, QCfalse};
  json_parse_args (nargs, args, &conf, true);

  ptrdiff_t point = PT_BYTE;
  struct json_read_buffer_data data = {.point = point};
  json_error_t error;
  json_t *object
    = json_load_callback (json_read_buffer_callback, &data,
                          JSON_DECODE_ANY
			  | JSON_DISABLE_EOF_CHECK
			  | JSON_ALLOW_NUL,
                          &error);

  if (object == 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 = json_to_lisp (object, &conf);

  /* Adjust point by how much we just read.  */
  point += error.position;
  SET_PT_BOTH (BYTE_TO_CHAR (point), point);

  return unbind_to (count, lisp);
}

void
syms_of_json (void)
{
  DEFSYM (QCnull, ":null");
  DEFSYM (QCfalse, ":false");

  DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p");
  DEFSYM (Qjson_value_p, "json-value-p");

  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");
  DEFSYM (Qjson_unavailable, "json-unavailable");
  define_error (Qjson_error, "generic JSON error", Qerror);
  define_error (Qjson_out_of_memory,
                "not enough memory for creating JSON object", 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_error);
  define_error (Qjson_trailing_content, "trailing content after JSON stream",
                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);

  DEFSYM (QCobject_type, ":object-type");
  DEFSYM (QCarray_type, ":array-type");
  DEFSYM (QCnull_object, ":null-object");
  DEFSYM (QCfalse_object, ":false-object");
  DEFSYM (Qalist, "alist");
  DEFSYM (Qplist, "plist");
  DEFSYM (Qarray, "array");

  defsubr (&Sjson__available_p);
  defsubr (&Sjson_serialize);
  defsubr (&Sjson_insert);
  defsubr (&Sjson_parse_string);
  defsubr (&Sjson_parse_buffer);
}