[PATCH] Allow native JSON functions to specify values for false/null.

[PATCH] Allow native JSON functions to specify values for false/null.

[Vibhav Pant]

* src/fns.c (get_key_arg): Make function public/non-static.

* src/lisp.h: Add extern declaration for get_key_arg.

* src/json.c: Add new struct `json_values'.

* src/json.c (lisp_to_json, lisp_to_json_toplevel_1,
  lisp_to_json_toplevel, lisp_to_json): Take new parameter,
  json_values.

* src/json.c (json-serialize, json-insert, json-parse-string,
  json-parse-buffer): Add two new keyword arguments, :json-false and
  :json-null. Encoding and parsing JSON will use their values for
  representing false and null respectively.

* src/json.c (json_parse_object_type): Use get_key_arg for getting the
  value of :object-type, taking (char *) as a new argument.

* src/json.c (syms_of_json): Define symbols :json-false and
  :json-null.

* test/src/json-tests.el (json-serialize/json-false,
  json-serialize/json-null, json-parse-string/json-false,
  json-parse-string/json-null): Add tests for custom falsy values
  using :json-false and :json-null.
---
 src/fns.c              |   2 +-
 src/json.c             | 209 ++++++++++++++++++++++++++++++++++---------------
 src/lisp.h             |   1 +
 test/src/json-tests.el |  28 +++++++
 4 files changed, 175 insertions(+), 65 deletions(-)

diff --git a/src/fns.c b/src/fns.c
index 9db9bea9f7..6193319228 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -3558,7 +3558,7 @@ next_almost_prime (EMACS_INT n)
    0.  This function is used to extract a keyword/argument pair from
    a DEFUN parameter list.  */
 
-static ptrdiff_t
+ptrdiff_t
 get_key_arg (Lisp_Object key, ptrdiff_t nargs, Lisp_Object *args, char *used)
 {
   ptrdiff_t i;
diff --git a/src/json.c b/src/json.c
index 88db86ad2e..f620d09588 100644
--- a/src/json.c
+++ b/src/json.c
@@ -155,6 +155,12 @@ init_json_functions (void)
 
 #endif	/* WINDOWSNT */
 
+struct json_values
+{
+  Lisp_Object json_false;
+  Lisp_Object json_null;
+};
+
 /* 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
@@ -316,14 +322,14 @@ json_check (json_t *object)
   return object;
 }
 
-static json_t *lisp_to_json (Lisp_Object);
+static json_t *lisp_to_json (Lisp_Object, struct json_values *);
 
 /* 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)
+lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json, struct json_values *values)
 {
   if (VECTORP (lisp))
     {
@@ -334,7 +340,7 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json)
       for (ptrdiff_t i = 0; i < size; ++i)
         {
           int status
-            = json_array_append_new (*json, lisp_to_json (AREF (lisp, i)));
+            = json_array_append_new (*json, lisp_to_json (AREF (lisp, i), values));
           if (status == -1)
             json_out_of_memory ();
         }
@@ -361,7 +367,7 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json)
             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)));
+                                              lisp_to_json (HASH_VALUE (h, i), values));
             if (status == -1)
               /* FIXME: A failure here might also indicate that the
                  key is not a valid Unicode string.  */
@@ -397,7 +403,7 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json)
           if (json_object_get (*json, key_str) == NULL)
             {
               int status
-                = json_object_set_new (*json, key_str, lisp_to_json (value));
+                = json_object_set_new (*json, key_str, lisp_to_json (value, values));
               if (status == -1)
                 json_out_of_memory ();
             }
@@ -414,12 +420,12 @@ lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json)
    hashtable, or alist.  */
 
 static json_t *
-lisp_to_json_toplevel (Lisp_Object lisp)
+lisp_to_json_toplevel (Lisp_Object lisp, struct json_values *values)
 {
   if (++lisp_eval_depth > max_lisp_eval_depth)
     xsignal0 (Qjson_object_too_deep);
   json_t *json;
-  lisp_to_json_toplevel_1 (lisp, &json);
+  lisp_to_json_toplevel_1 (lisp, &json, values);
   --lisp_eval_depth;
   return json;
 }
@@ -429,11 +435,11 @@ lisp_to_json_toplevel (Lisp_Object lisp)
    JSON object.  */
 
 static json_t *
-lisp_to_json (Lisp_Object lisp)
+lisp_to_json (Lisp_Object lisp, struct json_values *values)
 {
-  if (EQ (lisp, QCnull))
+  if (EQ (lisp, values->json_null))
     return json_check (json_null ());
-  else if (EQ (lisp, QCfalse))
+  else if (EQ (lisp, values->json_false))
     return json_check (json_false ());
   else if (EQ (lisp, Qt))
     return json_check (json_true ());
@@ -453,10 +459,11 @@ lisp_to_json (Lisp_Object lisp)
     }
 
   /* LISP now must be a vector, hashtable, or alist.  */
-  return lisp_to_json_toplevel (lisp);
+  return lisp_to_json_toplevel (lisp, values);
 }
 
-DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL,
+DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, MANY,
+        NULL,
        doc: /* Return the JSON representation of OBJECT as a string.
 OBJECT must be a vector, hashtable, or alist, and its elements can
 recursively contain `:null', `:false', t, numbers, strings, or other
@@ -465,10 +472,19 @@ converted to JSON null, false, and true values, respectively.  Vectors
 will be converted to JSON arrays, and hashtables and alists to JSON
 objects.  Hashtable keys must be strings without embedded null
 characters and must be unique within each object.  Alist keys must be
-symbols; if a key is duplicate, the first instance is used.  */)
-  (Lisp_Object object)
+symbols; if a key is duplicate, the first instance is used. The following
+keyword arguments are defined:
+
+:json-false FALSE -- Value to use while reading JSON `false', instead of
+`:false'.
+
+:json-null NULL -- Value to use while reading JSON `null', instead of
+`:null'.
+
+usage: (json-serialize OBJECT &rest KEYWORD-ARGS) */)
+  (ptrdiff_t nargs, Lisp_Object *args)
 {
-  ptrdiff_t count = SPECPDL_INDEX ();
+  ptrdiff_t i;
 
 #ifdef WINDOWSNT
   if (!json_initialized)
@@ -485,7 +501,23 @@ symbols; if a key is duplicate, the first instance is used.  */)
     }
 #endif
 
-  json_t *json = lisp_to_json_toplevel (object);
+  USE_SAFE_ALLOCA;
+  Lisp_Object object = args[0];
+  struct json_values values;
+  char *used = SAFE_ALLOCA ((nargs - 1) * sizeof *used);
+  memset (used, 0, (nargs - 1) * sizeof *used);
+
+  i = get_key_arg (QCjson_false, nargs - 1, args + 1, used);
+  values.json_false = i ? args[i + 1] : QCfalse;
+  i = get_key_arg (QCjson_null, nargs - 1, args + 1, used);
+  values.json_null = i ? args[i + 1] : QCnull;
+  for (i = 0; i < nargs - 1; i++)
+    if (!used[i])
+      signal_error ("Invalid argument list", args[i + 1]);
+  SAFE_FREE ();
+
+  ptrdiff_t count = SPECPDL_INDEX ();
+  json_t *json = lisp_to_json_toplevel (object, &values);
   record_unwind_protect_ptr (json_release_object, json);
 
   /* If desired, we might want to add the following flags:
@@ -541,14 +573,15 @@ json_insert_callback (const char *buffer, size_t size, void *data)
   return NILP (d->error) ? 0 : -1;
 }
 
-DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL,
+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.  */)
-  (Lisp_Object object)
+OBJECT and supported keyword arguments.
+usage: (json-insert OBJECT &rest KEYWORD-ARGS)*/)
+  (ptrdiff_t nargs, Lisp_Object *args)
 {
-  ptrdiff_t count = SPECPDL_INDEX ();
+  ptrdiff_t i;
 
 #ifdef WINDOWSNT
   if (!json_initialized)
@@ -565,7 +598,23 @@ OBJECT.  */)
     }
 #endif
 
-  json_t *json = lisp_to_json (object);
+  USE_SAFE_ALLOCA;
+  Lisp_Object object = args[0];
+  struct json_values values;
+  char *used = SAFE_ALLOCA ((nargs - 1) * sizeof *used);
+  memset (used, 0, (nargs - 1) * sizeof *used);
+
+  i = get_key_arg (QCjson_false, nargs - 1, args + 1, used);
+  values.json_false = i ? args[i + 1] : QCfalse;
+  i = get_key_arg (QCjson_null, nargs - 1, args + 1, used);
+  values.json_null = i ? args[i + 1] : QCnull;
+  for (i = 0; i < nargs - 1; i++)
+    if (!used[i])
+      signal_error ("Invalid argument list", args[i + 1]);
+  SAFE_FREE ();
+
+  ptrdiff_t count = SPECPDL_INDEX ();
+  json_t *json = lisp_to_json (object, &values);
   record_unwind_protect_ptr (json_release_object, json);
 
   struct json_insert_data data;
@@ -581,7 +630,7 @@ OBJECT.  */)
         json_out_of_memory ();
     }
 
-  return unbind_to (count, Qnil);
+  return unbind_to(count, Qnil);
 }
 
 enum json_object_type {
@@ -592,14 +641,14 @@ enum json_object_type {
 /* 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)
+json_to_lisp (json_t *json, enum json_object_type object_type, struct json_values *values)
 {
   switch (json_typeof (json))
     {
     case JSON_NULL:
-      return QCnull;
+      return values->json_null;
     case JSON_FALSE:
-      return QCfalse;
+      return values->json_false;
     case JSON_TRUE:
       return Qt;
     case JSON_INTEGER:
@@ -626,7 +675,7 @@ json_to_lisp (json_t *json, enum json_object_type object_type)
         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));
+                json_to_lisp (json_array_get (json, i), object_type, values));
         --lisp_eval_depth;
         return result;
       }
@@ -655,7 +704,7 @@ json_to_lisp (json_t *json, enum json_object_type object_type)
                   /* 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);
+                  hash_put (h, key, json_to_lisp (value, object_type, values), hash);
                 }
               break;
             }
@@ -668,7 +717,7 @@ json_to_lisp (json_t *json, enum json_object_type object_type)
                 {
                   Lisp_Object key = Fintern (json_build_string (key_str), Qnil);
                   result
-                    = Fcons (Fcons (key, json_to_lisp (value, object_type)),
+                    = Fcons (Fcons (key, json_to_lisp (value, object_type, values)),
                              result);
                 }
               result = Fnreverse (result);
@@ -687,28 +736,23 @@ json_to_lisp (json_t *json, enum json_object_type object_type)
 }
 
 static enum json_object_type
-json_parse_object_type (ptrdiff_t nargs, Lisp_Object *args)
+json_parse_object_type (ptrdiff_t nargs, Lisp_Object *args, char *used)
 {
-  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
-          wrong_choice (list2 (Qhash_table, Qalist), value);
-      }
-    default:
-      wrong_type_argument (Qplistp, Flist (nargs, args));
-    }
+  ptrdiff_t i;
+  enum json_object_type type;
+
+  i = get_key_arg (QCobject_type, nargs, args, used);
+
+  if (!i)
+    type = json_object_hashtable;
+  else if (EQ (args[i], Qhash_table))
+    type = json_object_hashtable;
+  else if (EQ (args[i], Qalist))
+    type = json_object_alist;
+  else
+    wrong_choice (list2 (Qhash_table, Qalist), args[i]);
+
+  return type;
 }
 
 DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY,
@@ -720,13 +764,21 @@ elements will be `:null', `:false', t, numbers, strings, or further
 vectors, hashtables, and alists.  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' or `alist'.
-usage: (string &key (OBJECT-TYPE \\='hash-table)) */)
+The following keyword arguments are defined:
+
+`:object-type' TYPE -- Lisp type to be used to represent objects, can
+be `hash-table' or `alist'.
+
+:json-false FALSE -- Value to use while reading JSON `false', instead of
+`:false'.
+
+:json-null NULL -- Value to use while reading JSON `null', instead of
+`:null'.
+
+usage: (json-parse-string STRING &rest KEYWORD-ARGS) */)
   (ptrdiff_t nargs, Lisp_Object *args)
 {
-  ptrdiff_t count = SPECPDL_INDEX ();
-
+  ptrdiff_t i;
 #ifdef WINDOWSNT
   if (!json_initialized)
     {
@@ -742,11 +794,26 @@ usage: (string &key (OBJECT-TYPE \\='hash-table)) */)
     }
 #endif
 
+  USE_SAFE_ALLOCA;
   Lisp_Object string = args[0];
+  struct json_values values;
+  char *used = SAFE_ALLOCA ((nargs - 1) * sizeof *used);
+  memset (used, 0, (nargs - 1) * sizeof *used);
+  i = get_key_arg (QCjson_false, nargs - 1, args + 1, used);
+  values.json_false = i ? args[i + 1] : QCfalse;
+  i = get_key_arg (QCjson_null, nargs - 1, args + 1, used);
+  values.json_null = i ? args[i + 1] : QCnull;
+  enum json_object_type object_type =
+    json_parse_object_type (nargs - 1, args + 1, used);
+  for (i = 0; i < nargs - 1; i++)
+    if (!used[i])
+      signal_error ("Invalid argument list", args[i + 1]);
+  SAFE_FREE ();
+
+  ptrdiff_t count = SPECPDL_INDEX ();
+
   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);
@@ -757,7 +824,7 @@ usage: (string &key (OBJECT-TYPE \\='hash-table)) */)
   if (object != NULL)
     record_unwind_protect_ptr (json_release_object, object);
 
-  return unbind_to (count, json_to_lisp (object, object_type));
+  return unbind_to (count, json_to_lisp (object, object_type, &values));
 }
 
 struct json_read_buffer_data
@@ -795,11 +862,10 @@ DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
 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: (&key (OBJECT-TYPE \\='hash-table))  */)
+usage: (json-parse-buffer &rest KEYWORD-ARGS)  */)
   (ptrdiff_t nargs, Lisp_Object *args)
 {
-  ptrdiff_t count = SPECPDL_INDEX ();
-
+  ptrdiff_t i;
 #ifdef WINDOWSNT
   if (!json_initialized)
     {
@@ -815,9 +881,22 @@ usage: (&key (OBJECT-TYPE \\='hash-table))  */)
     }
 #endif
 
-  enum json_object_type object_type = json_parse_object_type (nargs, args);
-
-  ptrdiff_t point = PT_BYTE;
+  USE_SAFE_ALLOCA;
+  struct json_values values;
+  char *used = SAFE_ALLOCA (nargs * sizeof *used);
+  memset (used, 0, nargs * sizeof *used);
+
+  i = get_key_arg (QCjson_false, nargs, args, used);
+  values.json_false = i ? args[i] : QCfalse;
+  i = get_key_arg (QCjson_null, nargs, args, used);
+  values.json_null = i ? args[i] : QCnull;
+  enum json_object_type object_type = json_parse_object_type (nargs, args, used);
+  for (i = 0; i < nargs; i++)
+    if (!used[i])
+      signal_error ("Invalid argument list", args[i + 1]);
+  SAFE_FREE ();
+
+  ptrdiff_t point = PT_BYTE, count = SPECPDL_INDEX ();
   struct json_read_buffer_data data = {.point = point};
   json_error_t error;
   json_t *object = json_load_callback (json_read_buffer_callback, &data,
@@ -830,7 +909,7 @@ usage: (&key (OBJECT-TYPE \\='hash-table))  */)
   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);
+  Lisp_Object lisp = json_to_lisp (object, object_type, &values);
 
   /* Adjust point by how much we just read.  */
   point += error.position;
@@ -894,6 +973,8 @@ syms_of_json (void)
   Fput (Qjson_parse_string, Qside_effect_free, Qt);
 
   DEFSYM (QCobject_type, ":object-type");
+  DEFSYM (QCjson_false, ":json-false");
+  DEFSYM (QCjson_null, ":json-null");
   DEFSYM (Qalist, "alist");
 
   defsubr (&Sjson_serialize);
diff --git a/src/lisp.h b/src/lisp.h
index eb31ba209a..9c54913972 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3494,6 +3494,7 @@ extern void syms_of_syntax (void);
 /* Defined in fns.c.  */
 enum { NEXT_ALMOST_PRIME_LIMIT = 11 };
 extern EMACS_INT next_almost_prime (EMACS_INT) ATTRIBUTE_CONST;
+extern ptrdiff_t get_key_arg (Lisp_Object, ptrdiff_t, Lisp_Object *, char *);
 extern Lisp_Object larger_vector (Lisp_Object, ptrdiff_t, ptrdiff_t);
 extern void sweep_weak_hash_tables (void);
 extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *);
diff --git a/test/src/json-tests.el b/test/src/json-tests.el
index e394583bc7..59b838f27b 100644
--- a/test/src/json-tests.el
+++ b/test/src/json-tests.el
@@ -64,6 +64,16 @@
   (should-error (json-serialize '#1=((a . 1) . #1#)) :type 'circular-list)
   (should-error (json-serialize '(#1=(a #1#)))))
 
+(ert-deftest json-serialize/json-false ()
+  (skip-unless (fboundp 'json-serialize))
+  (should (equal (json-serialize '((a . nil)) :json-false nil) "{\"a\":false}"))
+  (should (equal (json-serialize '((a . foo)) :json-false 'foo) "{\"a\":false}")))
+
+(ert-deftest json-serialize/json-null ()
+  (skip-unless (fboundp 'json-serialize))
+  (should (equal (json-serialize '((a . nil)) :json-null nil) "{\"a\":null}"))
+  (should (equal (json-serialize '((a . foo)) :json-null 'foo) "{\"a\":null}")))
+
 (ert-deftest json-serialize/object-with-duplicate-keys ()
   (skip-unless (fboundp 'json-serialize))
   (let ((table (make-hash-table :test #'eq)))
@@ -96,6 +106,24 @@
   ;; FIXME: Is this the right behavior?
   (should (equal (json-parse-string "[\"\u00C4\xC3\x84\"]") ["\u00C4\u00C4"])))
 
+(ert-deftest json-parse-string/json-false ()
+  (skip-unless (fboundp 'json-parse-string))
+  (let* ((input "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n")
+         (json-false-nil (json-parse-string input :json-false nil))
+         (json-false-foo (json-parse-string input :json-false 'foo)))
+    (should (eq (aref (gethash "abc" json-false-nil 'wrong) 1) nil))
+    (should (eq (gethash "def" json-false-nil 'wrong) :null))
+    (should (eq (aref (gethash "abc" json-false-foo 'wrong) 1) 'foo))))
+
+(ert-deftest json-parse-string/json-null ()
+  (skip-unless (fboundp 'json-parse-string))
+  (let* ((input "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n")
+         (json-null-nil (json-parse-string input :json-null nil))
+         (json-null-foo (json-parse-string input :json-null 'foo)))
+    (should (null (gethash "def" json-null-nil 'wrong)))
+    (should (eq (aref (gethash "abc" json-null-nil 'wrong) 1) :false))
+    (should (eq (gethash "def" json-null-foo 'wrong) 'foo))))
+
 (ert-deftest json-serialize/string ()
   (skip-unless (fboundp 'json-serialize))
   (should (equal (json-serialize ["foo"]) "[\"foo\"]"))
-- 
2.15.1