/* JSON parsing and serialization.

Copyright (C) 2017-2018 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 <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 "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.  */

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)
{
  size_t string_len = strlen (string);
  size_t prefix_len = strlen (prefix);
  return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 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

/* Create a multibyte Lisp string from the UTF-8 string in
   [DATA, DATA + SIZE).  If the range [DATA, DATA + SIZE) does not
   contain a valid UTF-8 string, an unspecified string is returned.
   Note that all callers below either pass only value UTF-8 strings or
   use this function for formatting error messages; in the latter case
   correctness isn't critical.  */

static Lisp_Object
json_make_string (const char *data, ptrdiff_t size)
{
  return code_convert_string (make_specified_string (data, -1, size, false),
                              Qutf_8_unix, Qt, false, true, true);
}

/* Create a multibyte Lisp string from the null-terminated UTF-8
   string beginning at DATA.  If the string is not a valid UTF-8
   string, an unspecified string is returned.  Note that all callers
   below either pass only value UTF-8 strings or use this function for
   formatting error messages; in the latter case correctness isn't
   critical.  */

static Lisp_Object
json_build_string (const char *data)
{
  return json_make_string (data, strlen (data));
}

/* 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 code_convert_string (string, Qutf_8_unix, Qt, true, true, true);
}

static _Noreturn void
json_out_of_memory (void)
{
  xsignal0 (Qjson_out_of_memory);
}

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

static _Noreturn void
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 (json_build_string (error->text),
                  json_build_string (error->source), make_natnum (error->line),
                  make_natnum (error->column), make_natnum (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);
}

/* 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);
}

static json_t *lisp_to_json (Lisp_Object);

/* Convert a Lisp object to a toplevel JSON object (array or object).
   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 = ASIZE (lisp);
      *json = json_check (json_array ());
      ptrdiff_t 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)));
          if (status == -1)
            json_out_of_memory ();
        }
      eassert (json_array_size (*json) == size);
      clear_unwind_protect (count);
      return unbind_to (count, Qnil);
    }
  else if (HASH_TABLE_P (lisp))
    {
      struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
      *json = json_check (json_object ());
      ptrdiff_t count = SPECPDL_INDEX ();
      record_unwind_protect_ptr (json_release_object, *json);
      for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
        if (!NILP (HASH_HASH (h, i)))
          {
            Lisp_Object key = json_encode (HASH_KEY (h, i));
            /* We can't specify the length, so the string must be
               null-terminated.  */
            check_string_without_embedded_nulls (key);
            const char *key_str = SSDATA (key);
            /* 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 (HASH_VALUE (h, i)));
            if (status == -1)
              {
                /* A failure can be caused either by an invalid key or
                   by low memory.  */
                json_check_utf8 (key);
                json_out_of_memory ();
              }
          }
      clear_unwind_protect (count);
      return unbind_to (count, Qnil);
    }
  else if (NILP (lisp))
    {
      *json = json_check (json_object ());
      return Qnil;
    }
  else if (CONSP (lisp))
    {
      Lisp_Object tail = lisp;
      *json = json_check (json_object ());
      ptrdiff_t count = SPECPDL_INDEX ();
      record_unwind_protect_ptr (json_release_object, *json);
      FOR_EACH_TAIL (tail)
        {
          const char *key_str;
          Lisp_Object value;
          Lisp_Object key_symbol;
          if ( EQ (Vjson_serialize_use_plists, Qt) ) {
            key_symbol = XCAR (tail);
            tail = XCDR(tail);
            CHECK_CONS (tail);
            value = XCAR (tail);
            if (EQ (tail, li.tortoise)) circular_list (lisp);
          } 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);
          /* If using plists, maybe strip the ":" from symbol-name */
          if (EQ (Vjson_serialize_use_plists, Qt) &&
              ':' == 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));
              if (status == -1)
                json_out_of_memory ();
            }
        }
      CHECK_LIST_END (tail, lisp);
      clear_unwind_protect (count);
      return unbind_to (count, Qnil);
    }
  wrong_type_argument (Qjson_value_p, lisp);
}

/* Convert LISP to a toplevel JSON object (array or object).  Signal
   an error of type `wrong-type-argument' if LISP is not a vector,
   hashtable, or alist.  */

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

/* 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)
{
  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 = 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, or alist.  */
  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 of values or a key-value map.  Hashtables,
alists and plists are accepted as maps, the variable
`json-serialize-use-plists' controlling which one of the latter two to
use.  In any of these cases, values can be `:null', `:false', t,
numbers, strings, or, recursively, other vectors, hashtables, alists
or plists.  `:null', `:false', and t will be converted to JSON null,
false, and true values, respectively.  Vectors will be converted to
JSON arrays, and hashtables, alists and plists to JSON objects.
Hashtable keys must be strings without embedded null characters and
must be unique within each object.  Alist or plist keys must be
symbols; if a key is duplicate, the first instance is used.  */)
  (Lisp_Object object)
{
  ptrdiff_t count = SPECPDL_INDEX ();

#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);
    }
  if (!json_initialized)
    {
      message1 ("jansson library not found");
      return Qnil;
    }
#endif

  json_t *json = lisp_to_json_toplevel (object);
  record_unwind_protect_ptr (json_release_object, json);

  /* If desired, we might want to add the following flags:
     JSON_DECODE_ANY, JSON_ALLOW_NUL.  */
  char *string = json_dumps (json, JSON_COMPACT);
  if (string == 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;
  ptrdiff_t size;
};

static Lisp_Object
json_insert (void *data)
{
  struct json_buffer_and_size *buffer_and_size = data;
  /* FIXME: This should be possible without creating an intermediate
     string object.  */
  Lisp_Object string
    = json_make_string (buffer_and_size->buffer, buffer_and_size->size);
  insert1 (string);
  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;
};

/* Callback for json_dump_callback that inserts the UTF-8 string in
   [BUFFER, BUFFER + SIZE) into the current buffer.
   If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string,
   an unspecified string is inserted into the buffer.  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};
  d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity);
  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 = SPECPDL_INDEX ();

#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);
    }
  if (!json_initialized)
    {
      message1 ("jansson library not found");
      return Qnil;
    }
#endif

  json_t *json = lisp_to_json (object);
  record_unwind_protect_ptr (json_release_object, json);

  struct json_insert_data data;
  /* If desired, we might want to add the following flags:
     JSON_DECODE_ANY, JSON_ALLOW_NUL.  */
  int status
    = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT);
  if (status == -1)
    {
      if (CONSP (data.error))
        xsignal (XCAR (data.error), XCDR (data.error));
      else
        json_out_of_memory ();
    }

  return unbind_to (count, Qnil);
}

enum json_object_type {
  json_object_hashtable,
  json_object_alist,
  json_object_plist
};

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

static _GL_ARG_NONNULL ((1)) Lisp_Object
json_to_lisp (json_t *json, enum json_object_type object_type)
{
  switch (json_typeof (json))
    {
    case JSON_NULL:
      return QCnull;
    case JSON_FALSE:
      return QCfalse;
    case JSON_TRUE:
      return Qt;
    case JSON_INTEGER:
      /* Return an integer if possible, a floating-point number
         otherwise.  This loses precision for integers with large
         magnitude; however, such integers tend to be nonportable
         anyway because many JSON implementations use only 64-bit
         floating-point numbers with 53 mantissa bits.  See
         https://tools.ietf.org/html/rfc7159#section-6 for some
         discussion.  */
      return make_fixnum_or_float (json_integer_value (json));
    case JSON_REAL:
      return make_float (json_real_value (json));
    case JSON_STRING:
      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))
          xsignal0 (Qoverflow_error);
        Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound);
        for (ptrdiff_t i = 0; i < size; ++i)
          ASET (result, i,
                json_to_lisp (json_array_get (json, i), object_type));
        --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 (object_type)
          {
          case json_object_hashtable:
            {
              size_t size = json_object_size (json);
              if (FIXNUM_OVERFLOW_P (size))
                xsignal0 (Qoverflow_error);
              result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize,
                              make_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 = json_build_string (key_str);
                  EMACS_UINT hash;
                  ptrdiff_t i = hash_lookup (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, object_type), 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 (json_build_string (key_str), Qnil);
                  result
                    = Fcons (Fcons (key, json_to_lisp (value, object_type)),
                             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)
                {
                  /* No idea if using AUTO_STRING and Fconcat for
                     making keywords is idiomatic, but seems to work
                     nicely */
                  AUTO_STRING (colon, ":");
                  Lisp_Object key =
                    Fintern (CALLN (Fconcat, colon, json_build_string (key_str))
                             , Qnil);
                  result = Fcons (key, result); /* build the plist as
                                                   value-key since
                                                   we're going to
                                                   reverse it in the
                                                   end.*/
                  result = Fcons (json_to_lisp (value, object_type), result);
                }
              result = Fnreverse (result);
              break;
            }
          default:
            /* Can't get here.  */
            emacs_abort ();
          }
        --lisp_eval_depth;
        return result;
      }
    }
  /* Can't get here.  */
  emacs_abort ();
}

static enum json_object_type
json_parse_object_type (ptrdiff_t nargs, Lisp_Object *args)
{
  switch (nargs)
    {
    case 0:
      return json_object_hashtable;
    case 2:
      {
        Lisp_Object key = args[0];
        Lisp_Object value = args[1];
        if (!EQ (key, QCobject_type))
          wrong_choice (list1 (QCobject_type), key);
        if (EQ (value, Qhash_table))
          return json_object_hashtable;
        else if (EQ (value, Qalist))
          return json_object_alist;
        else if (EQ (value, Qplist))
          return json_object_plist;
        else
          wrong_choice (list3 (Qhash_table, Qalist, Qplist), value);
      }
    default:
      wrong_type_argument (Qplistp, Flist (nargs, args));
    }
}

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 a vector, hashtable, alist, or
plist.  Its elements will be `:null', `:false', t, numbers, strings,
or further vectors, hashtables, alists, or plists.  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.  The keyword argument `:object-type'
specifies which Lisp type is used to represent objects; it can be
`hash-table', `alist' or `plist'.
usage: (json-parse-string STRING &key (OBJECT-TYPE \\='hash-table)) */)
     (ptrdiff_t nargs, Lisp_Object *args)
{
  ptrdiff_t count = SPECPDL_INDEX ();

#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);
    }
  if (!json_initialized)
    {
      message1 ("jansson library not found");
      return Qnil;
    }
#endif

  Lisp_Object string = args[0];
  Lisp_Object encoded = json_encode (string);
  check_string_without_embedded_nulls (encoded);
  enum json_object_type object_type
    = json_parse_object_type (nargs - 1, args + 1);

  json_error_t error;
  json_t *object = json_loads (SSDATA (encoded), 0, &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, object_type));
}

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.
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.
usage: (json-parse-buffer &key (OBJECT-TYPE \\='hash-table))  */)
  (ptrdiff_t nargs, Lisp_Object *args)
{
  ptrdiff_t count = SPECPDL_INDEX ();

#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);
    }
  if (!json_initialized)
    {
      message1 ("jansson library not found");
      return Qnil;
    }
#endif

  enum json_object_type object_type = json_parse_object_type (nargs, args);

  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_DISABLE_EOF_CHECK, &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, object_type);

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

  return unbind_to (count, lisp);
}

/* Simplified version of 'define-error' 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 = 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-nulls-p");
  DEFSYM (Qjson_value_p, "json-value-p");
  DEFSYM (Qutf_8_string_p, "utf-8-string-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");
  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");

  DEFVAR_LISP ("json-serialize-use-plists", Vjson_serialize_use_plists,
               doc:
               /* If non-nil use plists instead of alists in json-serialize.*/);
  Vjson_serialize_use_plists = Qnil;

  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 (Qalist, "alist");
  DEFSYM (Qplist, "plist");

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