File Coverage

json-create-perl.c

Criterion	Covered	Total	%
statement	623	724	86.0
branch	378	1200	31.5
condition			n/a
subroutine			n/a
pod			n/a
total	1001	1924	52.0

/*
   This is the main part of JSON::Create.

   It's kept in a separate file but #included into the main file,
   Create.xs.
*/

#ifdef __GNUC__
#define INLINE inline
#else
#define INLINE
#endif /* __GNUC__ */

/* These are return statuses for the types of failures which can
   occur. */

typedef enum {
    json_create_ok,

    /* The following set of exceptions indicate something went wrong
       in JSON::Create's code, in other words bugs. */

    /* An error from the unicode.c library. */
    json_create_unicode_error,
    /* A printed number turned out to be longer than MARGIN bytes. */
    json_create_number_too_long,
    /* Unknown type of floating point number. */
    json_create_unknown_floating_point,
    /* Bad format for floating point. */
    json_create_bad_floating_format,

    /* The following set of exceptions indicate bad input, in other
       words these are user-generated exceptions. */

    /* Badly-formatted UTF-8. */
    json_create_unicode_bad_utf8,
    /* Unknown Perl svtype within the structure. */
    json_create_unknown_type,
    /* User's routine returned invalid stuff. */
    json_create_invalid_user_json,
    /* User gave us an undefined value from a user subroutine. */
    json_create_undefined_return_value,
    /* Rejected non-ASCII, non-character string in strict mode. */
    json_create_non_ascii_byte,
    /* Rejected scalar reference in strict mode. */
    json_create_scalar_reference,
    /* Rejected non-finite number in strict mode. */
    json_create_non_finite_number,
}
json_create_status_t;

#define BUFSIZE 0x4000

/* MARGIN is the size of the "spillover" area where we can print
   numbers or Unicode UTF-8 whole characters (runes) into the buffer
   without having to check the printed length after each byte. */

#define MARGIN 0x40

#define INDENT

typedef struct json_create {
    /* The length of the input string. */
    int length;
    unsigned char * buffer;
    /* Place to write the buffer to. */
    SV * output;
    /* Format for floating point numbers. */
    char * fformat;
    /* Memory leak counter. */
    int n_mallocs;
    /* Handlers for objects and booleans. If there are no handlers,
       this is zero (a NULL pointer). */
    HV * handlers;
    /* User reference handler. */
    SV * type_handler;
    /* User obj handler. */
    SV * obj_handler;
    /* User non-finite-float handler, what to do with "inf", "nan"
       type numbers. */
    SV * non_finite_handler;
    /* User's sorter for entries. */
    SV * cmp;
#ifdef INDENT
    /* Indentation depth (no. of tabs). */
    unsigned int depth;
#endif /* def INDENT */

    /* One-bit flags. */

    /* Do any of the SVs have a Unicode flag? */
    unsigned int unicode : 1;
    /* Should we convert / into \/? */
    unsigned int escape_slash : 1;
    /* Should Unicode be upper case? */
    unsigned int unicode_upper : 1;
    /* Should we escape all non-ascii? */
    unsigned int unicode_escape_all : 1;
    /* Should we validate user-defined JSON? */
    unsigned int validate : 1;
    /* Do not escape U+2028 and U+2029. */
    unsigned int no_javascript_safe : 1;
    /* Make errors fatal. */
    unsigned int fatal_errors : 1;
    /* Replace bad UTF-8 with the "replacement character". */
    unsigned int replace_bad_utf8 : 1;
    /* Never upgrade the output to "utf8". */
    unsigned int downgrade_utf8 : 1;
    /* Output may contain invalid UTF-8. */
    unsigned int utf8_dangerous : 1;
    /* Strict mode, reject lots of things. */
    unsigned int strict : 1;
#ifdef INDENT
    /* Add whitespace to output to make it human-readable. */
    unsigned int indent : 1;
    /* Sort the keys of objects. */
    unsigned int sort : 1;
#endif /* INDENT */
}
json_create_t;

/* Check the length of the buffer, and if we don't have more than
   MARGIN bytes left to write into, then we put "jc->buffer" into the
   Perl scalar "jc->output" via "json_create_buffer_fill". We always
   want to be at least MARGIN bytes from the end of "jc->buffer" after
   every write operation, so that we always have room to put a number
   or a UTF-8 "rune" in the buffer without checking the length
   excessively. */

#define CHECKLENGTH				\
    if (jc->length >= BUFSIZE - MARGIN) {	\
	CALL (json_create_buffer_fill (jc));	\
    }

/* Debug the internal handling of types. */

//#define JCDEBUGTYPES
#ifdef JCDEBUGTYPES
#define MSG(format, args...) \
    fprintf (stderr, "%s:%d: ", __FILE__, __LINE__);\
    fprintf (stderr, format, ## args);\
    fprintf (stderr, "\n");
#else
#define MSG(format, args...)
#endif /* def JCDEBUGTYPES */

/* Print an error to stderr. */

static int
json_create_error_handler_default (const char * file, int line_number, const char * msg, ...)
{
    int printed;
    va_list vargs;
    va_start (vargs, msg);
    printed = 0;
    printed += fprintf (stderr, "%s:%d: ", file, line_number);
    printed += vfprintf (stderr, msg, vargs);
    printed += fprintf (stderr, "\n");
    va_end (vargs);
    return printed;
}

static int (* json_create_error_handler) (const char * file, int line_number, const char * msg, ...) = json_create_error_handler_default;

#define JCEH json_create_error_handler

#define HANDLE_STATUS(x,status) {				\
	switch (status) {					\
	    /* These exceptions indicate a user error. */	\
	case json_create_unknown_type:				\
	case json_create_unicode_bad_utf8:			\
	case json_create_invalid_user_json:			\
	case json_create_undefined_return_value:		\
	case json_create_non_ascii_byte:			\
	case json_create_scalar_reference:			\
	case json_create_non_finite_number:			\
	    break;						\
	    							\
	    /* All other exceptions are our bugs. */		\
	default:						\
	    if (JCEH) {						\
		(*JCEH) (__FILE__, __LINE__,			\
			 "call to %s failed with status %d",	\
			 #x, status);				\
	    }							\
	}							\
    }

#define CALL(x) {							\
	json_create_status_t status;					\
	status = x;							\
	if (status != json_create_ok) {					\
	    HANDLE_STATUS (x,status);					\
	    return status;						\
	}								\
    }

static void
json_create_user_message (json_create_t * jc, json_create_status_t status, const char * format, ...)
{
    va_list a;
    /* Check the status. */
    va_start (a, format);
    if (jc->fatal_errors) {
	vcroak (format, & a);
    }
    else {
	vwarn (format, & a);
    }
}

/* Everything else in this file is ordered from callee at the top to
   caller at the bottom, but because of the recursion as we look at
   JSON values within arrays or hashes, we need to forward-declare
   "json_create_recursively". */

static json_create_status_t
json_create_recursively (json_create_t * jc, SV * input);

/* Copy the jc buffer into its SV. */

static INLINE json_create_status_t
json_create_buffer_fill (json_create_t * jc)
{
    /* There is nothing to put in the output. */
    if (jc->length == 0) {
	if (jc->output == 0) {
	    /* And there was not anything before either. */
	    jc->output = & PL_sv_undef;
	}
	/* Either way, we don't need to do anything more. */
	return json_create_ok;
    }
    if (! jc->output) {
	jc->output = newSVpvn ((char *) jc->buffer, (STRLEN) jc->length);
    }
    else {
	sv_catpvn (jc->output, (char *) jc->buffer, (STRLEN) jc->length);
    }
    /* "Empty" the buffer, we don't bother cleaning out the old
       values, so "jc->length" is our only clue as to the clean/dirty
       state of the buffer. */
    jc->length = 0;
    return json_create_ok;
}

/* Add one character to the end of jc. */

static INLINE json_create_status_t
add_char (json_create_t * jc, unsigned char c)
{
    jc->buffer[jc->length] = c;
    jc->length++;
    /* The size we have to use before we write the buffer out. */
    CHECKLENGTH;
    return json_create_ok;
}

/* Add a nul-terminated string to "jc", up to the nul byte. This
   should not be used unless it's strictly necessary, prefer to use
   "add_str_len" instead. Basically, don't use this. This is not
   intended to be Unicode-safe, it is only to be used for strings
   which we know do not need to be checked for Unicode validity (for
   example sprintf'd numbers or something). */

static INLINE json_create_status_t
add_str (json_create_t * jc, const char * s)
{
    int i;
    for (i = 0; s[i]; i++) {
	unsigned char c;
	c = (unsigned char) s[i];
	CALL (add_char (jc, c));
    }
    return json_create_ok;
}

/* Add a string "s" with length "slen" to "jc". This does not test for
   nul bytes, but just copies "slen" bytes of the string.  This is not
   intended to be Unicode-safe, it is only to be used for strings we
   know do not need to be checked for Unicode validity. */

static INLINE json_create_status_t
add_str_len (json_create_t * jc, const char * s, unsigned int slen)
{
    int i;
    /* We know that (BUFSIZE - jc->length) is always bigger than
       MARGIN going into this, but the compiler doesn't. Hopefully,
       the compiler optimizes the following "if" statement away to a
       true value for almost all cases when this is inlined and slen
       is known to be smaller than MARGIN. */
    if (slen < MARGIN || slen < BUFSIZE - jc->length) {
	for (i = 0; i < slen; i++) {
	    jc->buffer[jc->length + i] = s[i];
	}
	jc->length += slen;
	CHECKLENGTH;
    }
    else {
	/* A very long string which may overflow the buffer, so use
	   checking routines. */
	for (i = 0; i < slen; i++) {
	    CALL (add_char (jc, (unsigned char) s[i]));
	}
    }
    return json_create_ok;
}

#ifdef INDENT

static json_create_status_t newline_indent(json_create_t * jc)
{
    int d;
    CALL (add_char (jc, '\n'));
    for (d = 0; d < jc->depth; d++) {
	CALL (add_char (jc, '\t'));		\
    }
    return json_create_ok;
}

static INLINE json_create_status_t
add_str_len_indent (json_create_t * jc, const char * s, unsigned int slen)
{
    int i;

    for (i = 0; i < slen; i++) {
	unsigned char c;
	c = (unsigned char) s[i];
	if (c == '\n') {
	    if (i < slen - 1) {
		CALL (newline_indent (jc));
	    }
	    // else just discard it, final newline
	}
	else {
	    CALL (add_char (jc, c));
	}
    }
    return json_create_ok;
}

#endif /* def INDENT */

/* "Add a string" macro, this just saves cut and pasting a string and
   typing "strlen" over and over again. For ASCII values only, not
   Unicode safe. */

#define ADD(x) CALL (add_str_len (jc, x, strlen (x)));

static const char *uc_hex = "0123456789ABCDEF";
static const char *lc_hex = "0123456789abcdef";

static INLINE json_create_status_t
add_one_u (json_create_t * jc, unsigned int u)
{
    char * spillover;
    const char * hex;
    hex = lc_hex;
    if (jc->unicode_upper) {
	hex = uc_hex;
    }
    spillover = (char *) (jc->buffer) + jc->length;
    spillover[0] = '\\';
    spillover[1] = 'u';
    // Method poached from https://metacpan.org/source/CHANSEN/Unicode-UTF8-0.60/UTF8.xs#L196
    spillover[5] = hex[u & 0xf];
    u >>= 4;
    spillover[4] = hex[u & 0xf];
    u >>= 4;
    spillover[3] = hex[u & 0xf];
    u >>= 4;
    spillover[2] = hex[u & 0xf];
    jc->length += 6;
    CHECKLENGTH;
    return json_create_ok;
}

/* Add a "\u3000" or surrogate pair if necessary. */

static INLINE json_create_status_t
add_u (json_create_t * jc, unsigned int u)
{
    if (u > 0xffff) {
	int hi;
	int lo;
	int status = unicode_to_surrogates (u, & hi, & lo);
	if (status != UNICODE_OK) {
	    if (JCEH) {
		(*JCEH) (__FILE__, __LINE__,
			 "Error %d making surrogate pairs from %X",
			 status, u);
	    }
	    return json_create_unicode_error;
	}
	CALL (add_one_u (jc, hi));
	/* Backtrace fallthrough. */
	return add_one_u (jc, lo);
    }
    else {
	/* Backtrace fallthrough. */
	return add_one_u (jc, u);
    }
}

#define BADUTF8								\
    if (jc->replace_bad_utf8) {						\
	/* We have to switch on Unicode otherwise the replacement */	\
	/* characters don't work as intended. */			\
	jc->unicode = 1;						\
	/* This is �, U+FFFD, as UTF-8 bytes. */			\
	CALL (add_str_len (jc, "\xEF\xBF\xBD", 3));			\
    }									\
    else {								\
	json_create_user_message (jc, json_create_unicode_bad_utf8,	\
				  "Invalid UTF-8");			\
	return json_create_unicode_bad_utf8;				\
    }

/* Jump table. Doing it this way is not the fastest possible way, but
   it's also very difficult for a compiler to mess this
   up. Theoretically, it would be faster to make a jump table by the
   compiler from the switch statement, but some compilers sometimes
   cannot do that. */

/* In this enum, I use three letters as a compromise between
   readability and formatting. The control character names are from
   "man ascii" with an X tagged on the end. */

typedef enum {
    CTL,  // control char, escape to \u
    BSX,  // backslash b
    HTX,  // Tab character
    NLX,  // backslash n, new line
    NPX,  // backslash f
    CRX,  // backslash r
    ASC,  // Non-special ASCII
    QUO,  // double quote
    BSL,  // backslash
    FSL,  // forward slash, "/"
    BAD,  // Invalid UTF-8 value.
    UT2,  // UTF-8, two bytes
    UT3,  // UTF-8, three bytes
    UT4,  // UTF-8, four bytes
}
jump_t;

static jump_t jump[0x100] = {
    CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,BSX,HTX,NLX,CTL,NPX,CRX,CTL,CTL,
    CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,CTL,
    ASC,ASC,QUO,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,FSL,
    ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,
    ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,
    ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,BSL,ASC,ASC,ASC,
    ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,
    ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,ASC,
    BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,
    BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,
    BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,
    BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,
    BAD,BAD,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,
    UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,UT2,
    UT3,UT3,UT3,UT3,UT3,UT3,UT3,UT3,UT3,UT3,UT3,UT3,UT3,UT3,UT3,UT3,
    UT4,UT4,UT4,UT4,UT4,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,BAD,
};

/* Need this twice, once within the ASCII handler and once within the
   Unicode handler. */

#define ASCII					\
    case CTL:					\
    CALL (add_one_u (jc, (unsigned int) c));	\
    i++;					\
    break;					\
						\
    case BSX:					\
    ADD ("\\b");				\
    i++;					\
    break;					\
						\
    case HTX:					\
    ADD ("\\t");				\
    i++;					\
    break;					\
						\
    case NLX:					\
    ADD ("\\n");				\
    i++;					\
    break;					\
						\
    case NPX:					\
    ADD ("\\f");				\
    i++;					\
    break;					\
						\
    case CRX:					\
    ADD ("\\r");				\
    i++;					\
    break;					\
						\
    case ASC:					\
    CALL (add_char (jc, c));			\
    i++;					\
    break;					\
						\
    case QUO:					\
    ADD ("\\\"");				\
    i++;					\
    break;					\
						\
    case FSL:					\
    if (jc->escape_slash) {			\
	ADD ("\\/");				\
    }						\
    else {					\
	CALL (add_char (jc, c));		\
    }						\
    i++;					\
    break;					\
						\
    case BSL:					\
    ADD ("\\\\");				\
    i++;					\
    break;


static INLINE json_create_status_t
json_create_add_ascii_key_len (json_create_t * jc, const unsigned char * key, STRLEN keylen)
{
    int i;

    CALL (add_char (jc, '"'));
    for (i = 0; i < keylen; ) {
	unsigned char c;

	c = key[i];
	switch (jump[c]) {

	ASCII;

	default:
	    json_create_user_message (jc, json_create_non_ascii_byte,
				      "Non-ASCII byte in non-utf8 string: %X",
				      key[i]);
	    return json_create_non_ascii_byte;
	}
    }
    CALL (add_char (jc, '"'));
    return json_create_ok;
}


/* Add a string to the buffer with quotes around it and escapes for
   the escapables. */

static INLINE json_create_status_t
json_create_add_key_len (json_create_t * jc, const unsigned char * key, STRLEN keylen)
{
    int i;

    CALL (add_char (jc, '"'));
    for (i = 0; i < keylen; ) {
	unsigned char c, d, e, f;
	c = key[i];

	switch (jump[c]) {

	ASCII;

	case BAD:
	    BADUTF8;
	    i++;
	    break;

	case UT2:
	    d = key[i + 1];
	    if (d < 0x80 || d > 0xBF) {
		BADUTF8;
		i++;
		break;
	    }
	    if (jc->unicode_escape_all) {
		unsigned int u;
		u = (c & 0x1F)<<6
		  | (d & 0x3F);
		CALL (add_u (jc, u));
	    }
	    else {
		CALL (add_str_len (jc, (const char *) key + i, 2));
	    }
	    // Increment i
	    i += 2;
	    break;

	case UT3:
	    d = key[i + 1];
	    e = key[i + 2];
	    if (d < 0x80 || d > 0xBF ||
		e < 0x80 || e > 0xBF) {
		BADUTF8;
		i++;
		break;
	    }
	    if (! jc->no_javascript_safe &&
		c == 0xe2 && d == 0x80 &&
		(e == 0xa8 || e == 0xa9)) {
		CALL (add_one_u (jc, 0x2028 + e - 0xa8));
	    }
	    else {
		if (jc->unicode_escape_all) {
		    unsigned int u;
		    u = (c & 0x0F)<<12
		      | (d & 0x3F)<<6
		      | (e & 0x3F);
		    CALL (add_u (jc, u));
		}
		else {
		    CALL (add_str_len (jc, (const char *) key + i, 3));
		}
	    }
	    // Increment i
	    i += 3;
	    break;

	case UT4:
           d = key[i + 1];
           e = key[i + 2];
           f = key[i + 3];
           if (
               // These byte values are copied from
               // https://github.com/htacg/tidy-html5/blob/768ad46968b43e29167f4d1394a451b8c6f40b7d/src/utf8.c

               // 0x40000 - 0xfffff
               (c < 0xf4 &&
                (d < 0x80 || d > 0xBF ||
                 e < 0x80 || e > 0xBF ||
                 f < 0x80 || f > 0xBF))
               ||
               // 0x100000 - 0x10ffff
               (c == 0xf4 &&
                (d < 0x80 || d > 0x8F ||
                 e < 0x80 || e > 0xBF ||
                 f < 0x80 || f > 0xBF))
               ) {
               BADUTF8;
               i++;
               break;
           }
	    if (jc->unicode_escape_all) {
		unsigned int u;
		const unsigned char * input;
		input = key + i;
		u = (c & 0x07) << 18
		  | (d & 0x3F) << 12
                  | (e & 0x3F) <<  6
                  | (f & 0x3F);
		add_u (jc, u);
	    }
	    else {
		CALL (add_str_len (jc, (const char *) key + i, 4));
	    }
	    // Increment i
	    i += 4;
	    break;
	}
    }
    CALL (add_char (jc, '"'));
    return json_create_ok;
}

static INLINE json_create_status_t
json_create_add_string (json_create_t * jc, SV * input)
{
    char * istring;
    STRLEN ilength;

    istring = SvPV (input, ilength);
    if (SvUTF8 (input)) {
	/* "jc->unicode" is true if Perl says that anything in the
	   whole of the input to "json_create" is a "SvUTF8"
	   scalar. We have to force everything in the whole output to
	   Unicode. */
	jc->unicode = 1;
    }
    else if (jc->strict) {
	/* Backtrace fall through, remember to check the caller's line. */
	return json_create_add_ascii_key_len (jc, (unsigned char *) istring,
					      (STRLEN) ilength);
    }
    /* Backtrace fall through, remember to check the caller's line. */
    return json_create_add_key_len (jc, (unsigned char *) istring,
				    (STRLEN) ilength);
}

/* Extract the remainder of x when divided by ten and then turn it
   into the equivalent ASCII digit. '0' in ASCII is 0x30, and (x)%10
   is guaranteed not to have any of the high bits set. */

#define DIGIT(x) (((x)%10)|0x30)

static INLINE json_create_status_t
json_create_add_unsigned(json_create_t * jc, SV * sv) {
    long unsigned int uv;
    int uvlen;
    char * spillover;
    uv = SvUV (sv);
    uvlen = 0;
    spillover = ((char *) jc->buffer) + jc->length;
    uvlen += snprintf (spillover + uvlen, MARGIN - uvlen, "%lu", uv);
    if (uvlen >= MARGIN) {
	if (JCEH) {
	    (*JCEH) (__FILE__, __LINE__,
		     "A printed integer number %ld was "
		     "longer than MARGIN=%d bytes",
		     SvIV (sv), MARGIN);
	}
	return json_create_number_too_long;
    }
    jc->length += uvlen;
    CHECKLENGTH;
    return json_create_ok;
}

static INLINE json_create_status_t
json_create_add_integer (json_create_t * jc, SV * sv)
{
    long int iv;
    int ivlen;
    char * spillover;

    if (SvIOK_UV(sv)) {
	return json_create_add_unsigned (jc, sv);
    }
    iv = SvIV (sv);
    ivlen = 0;

    /* Pointer arithmetic. */

    spillover = ((char *) jc->buffer) + jc->length;

    /* Souped-up integer printing for small integers. The following is
       all just souped up versions of snprintf ("%d", iv);. */

    if (iv < 0) {
	spillover[ivlen] = '-';
	ivlen++;
	iv = -iv;
    }
    if (iv < 10) {
	/* iv has exactly one digit. The first digit may be zero. */
	spillover[ivlen] = DIGIT (iv);
	ivlen++;
    }
    else if (iv < 100) {
	/* iv has exactly two digits. The first digit is not zero. */
	spillover[ivlen] = DIGIT (iv/10);
	ivlen++;
	spillover[ivlen] = DIGIT (iv);
	ivlen++;
    }
    else if (iv < 1000) {
	/* iv has exactly three digits. The first digit is not
	   zero. */
	spillover[ivlen] = DIGIT (iv/100);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10);
	ivlen++;
	spillover[ivlen] = DIGIT (iv);
	ivlen++;
    }
    else if (iv < 10000) {
	/* etc. */
	spillover[ivlen] = DIGIT (iv/1000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/100);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10);
	ivlen++;
	spillover[ivlen] = DIGIT (iv);
	ivlen++;
    }
    else if (iv < 100000) {
	spillover[ivlen] = DIGIT (iv/10000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/1000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/100);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10);
	ivlen++;
	spillover[ivlen] = DIGIT (iv);
	ivlen++;
    }
    else if (iv < 1000000) {
	spillover[ivlen] = DIGIT (iv/100000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/1000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/100);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10);
	ivlen++;
	spillover[ivlen] = DIGIT (iv);
	ivlen++;
    }
    else if (iv < 10000000) {
	spillover[ivlen] = DIGIT (iv/1000000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/100000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/1000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/100);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10);
	ivlen++;
	spillover[ivlen] = DIGIT (iv);
	ivlen++;
    }
    else if (iv < 100000000) {
	spillover[ivlen] = DIGIT (iv/10000000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/1000000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/100000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/1000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/100);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10);
	ivlen++;
	spillover[ivlen] = DIGIT (iv);
	ivlen++;
    }
    else if (iv < 1000000000) {
	spillover[ivlen] = DIGIT (iv/100000000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10000000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/1000000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/100000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/1000);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/100);
	ivlen++;
	spillover[ivlen] = DIGIT (iv/10);
	ivlen++;
	spillover[ivlen] = DIGIT (iv);
	ivlen++;
    }
    else {
	/* The number is one billion (1000,000,000) or more, so we're
	   just going to print it into "jc->buffer" with snprintf. */
	ivlen += snprintf (spillover + ivlen, MARGIN - ivlen, "%ld", iv);
	if (ivlen >= MARGIN) {
	    if (JCEH) {
		(*JCEH) (__FILE__, __LINE__,
			 "A printed integer number %ld was "
			 "longer than MARGIN=%d bytes",
			 SvIV (sv), MARGIN);
	    }
	    return json_create_number_too_long;
	}
    }
    jc->length += ivlen;
    CHECKLENGTH;
    return json_create_ok;
}

#define UNKNOWN_TYPE_FAIL(t)				\
    if (JCEH) {						\
	(*JCEH) (__FILE__, __LINE__,			\
		 "Unknown Perl type %d", t);		\
    }							\
    return json_create_unknown_type

//#define DEBUGOBJ

static json_create_status_t
json_create_validate_user_json (json_create_t * jc, SV * json)
{
    SV * error;
    dSP;
    ENTER;
    SAVETMPS;
    PUSHMARK (SP);
    XPUSHs (sv_2mortal (newSVsv (json)));
    PUTBACK;
    call_pv ("JSON::Parse::assert_valid_json",
	     G_EVAL|G_DISCARD);
    FREETMPS;
    LEAVE;
    error = get_sv ("@", 0);
    if (! error) {
	return json_create_ok;
    }
    if (SvOK (error) && SvCUR (error) > 0) {
	json_create_user_message (jc, json_create_invalid_user_json,
				  "JSON::Parse::assert_valid_json failed for '%s': %s",
				  SvPV_nolen (json), SvPV_nolen (error));
	return json_create_invalid_user_json;
    }
    return json_create_ok;
}

static json_create_status_t
json_create_call_to_json (json_create_t * jc, SV * cv, SV * r)
{
    SV * json;
    char * jsonc;
    STRLEN jsonl;
    // https://metacpan.org/source/AMBS/Math-GSL-0.35/swig/gsl_typemaps.i#L438
    dSP;

    ENTER;
    SAVETMPS;

    PUSHMARK (SP);
    //https://metacpan.org/source/AMBS/Math-GSL-0.35/swig/gsl_typemaps.i#L482
    XPUSHs (sv_2mortal (newRV (r)));
    PUTBACK;
    call_sv (cv, 0);
    json = POPs;
    SvREFCNT_inc (json);
    FREETMPS;
    LEAVE;

    if (! SvOK (json)) {
	/* User returned an undefined value. */
	SvREFCNT_dec (json);
	json_create_user_message (jc, json_create_undefined_return_value,
				  "Undefined value from user routine");
	return json_create_undefined_return_value;
    }
    if (SvUTF8 (json)) {
	/* We have to force everything in the whole output to
	   Unicode. */
	jc->unicode = 1;
    }
    jsonc = SvPV (json, jsonl);
    if (jc->validate) {
	CALL (json_create_validate_user_json (jc, json));
    }
    else {
	/* This string may contain invalid UTF-8. */
	jc->utf8_dangerous = 1;
    }
#ifdef INDENT
    if (jc->indent) {
       	CALL (add_str_len_indent (jc, jsonc, jsonl));
    }
    else {
#endif
	CALL (add_str_len (jc, jsonc, jsonl));
#ifdef INDENT
    }
#endif
    SvREFCNT_dec (json);
    return json_create_ok;
}

static INLINE json_create_status_t
json_create_add_float (json_create_t * jc, SV * sv)
{
    double fv;
    STRLEN fvlen;
    fv = SvNV (sv);
    if (isfinite (fv)) {
	if (jc->fformat) {
	    fvlen = snprintf ((char *) jc->buffer + jc->length, MARGIN, jc->fformat, fv);
	}
	else {
	    fvlen = snprintf ((char *) jc->buffer + jc->length, MARGIN,
			      "%g", fv);
	}
	if (fvlen >= MARGIN) {
	    return json_create_number_too_long;
	}
	jc->length += fvlen;
	CHECKLENGTH;
    }
    else {
	if (jc->non_finite_handler) {
	    CALL (json_create_call_to_json (jc, jc->non_finite_handler, sv));
	}
	else {
	    if (jc->strict) {
		json_create_user_message (jc, json_create_non_finite_number,
					  "Non-finite number in input");
		return json_create_non_finite_number;
	    }
	    if (isnan (fv)) {
		ADD ("\"nan\"");
	    }
	    else if (isinf (fv)) {
		if (fv < 0.0) {
		    ADD ("\"-inf\"");
		}
		else {
		    ADD ("\"inf\"");
		}
	    }
	    else {
		return json_create_unknown_floating_point;
	    }
	}
    }
    return json_create_ok;
}

static INLINE json_create_status_t
json_create_add_magic (json_create_t * jc, SV * r)
{
    /* There are some edge cases with blessed references
       containing numbers which we need to handle correctly. */
    if (SvIOK (r)) {
	CALL (json_create_add_integer (jc, r));
    }
    else if (SvNOK (r)) {
	CALL (json_create_add_float (jc, r));
    }
    else {
	CALL (json_create_add_string (jc, r));
    }
    return json_create_ok;
}

/* Add a number which is already stringified. This bypasses snprintf
   and just copies the Perl string straight into the buffer. */

static INLINE json_create_status_t
json_create_add_stringified (json_create_t * jc, SV *r)
{
    /* Stringified number. */
    char * s;
    /* Length of "r". */
    STRLEN rlen;
    int i;
    int notdigits = 0;

    s = SvPV (r, rlen);

    /* Somehow or another it's possible to arrive here with a
       non-digit string, precisely this happened with the "script"
       value returned by Unicode::UCD::charinfo, which had the value
       "Common" and was an SVt_PVIV. */
    for (i = 0; i < rlen; i++) {
	char c = s[i];
	if (!isdigit (c) && c != '.' && c != '-' && c != 'e' && c != 'E') {
	    notdigits = 1;
	}
    }
    /* If the stringified number has leading zeros, don't skip those,
       but put the string in quotes. It can happen that something like
       a Huffman code has leading zeros and should be treated as a
       string, yet Perl also thinks it is a number. */
     if (s[0] == '0' && rlen > 1 && isdigit (s[1])) {
	 notdigits = 1;
     }

     if (notdigits) {
	 CALL (add_char (jc, '"'));
	 CALL (add_str_len (jc, s, (unsigned int) rlen));
	 CALL (add_char (jc, '"'));
	 return json_create_ok;
     }
     /* This doesn't backtrace correctly, but the calling routine
       should print out that it was calling "add_stringified", so as
       long as we're careful not to ignore the caller line, it
       shouldn't matter. */
    return add_str_len (jc, s, (unsigned int) rlen);
}

#ifdef INDENT
#define DINC if (jc->indent) { jc->depth++; }
#define DDEC if (jc->indent) { jc->depth--; }
#endif /* def INDENT */

/* Add a comma where necessary. This is shared between objects and
   arrays. */

#ifdef INDENT
#define COMMA					\
    if (i > 0) {				\
	CALL (add_char (jc, ','));		\
	if (jc->indent) {			\
	    CALL (newline_indent (jc));		\
	}					\
    }
#else /* INDENT */
#define COMMA					\
    if (i > 0) {				\
	CALL (add_char (jc, ','));		\
    }
#endif /* INDENT */

static INLINE json_create_status_t
add_open (json_create_t * jc, unsigned char c)
{
    CALL (add_char (jc, c));
#ifdef INDENT
    if (jc->indent) {
       	DINC;
       	CALL (newline_indent (jc));		\
    }
#endif /* INDENT */
    return json_create_ok;
}

static INLINE json_create_status_t
add_close (json_create_t * jc, unsigned char c)
{
#ifdef INDENT
    if (jc->indent) {
       	DDEC;
       	CALL (newline_indent (jc));		\
    }
#endif /* def INDENT */
    CALL (add_char (jc, c));
#ifdef INDENT
    if (jc->indent) {
       	/* Add a new line after the final brace, otherwise we have no
       	   newline on the final line of output. */
       	if (jc->depth == 0) {
       	    CALL (add_char (jc, '\n'));
       	}
    }
#endif /* def INDENT */
    return json_create_ok;
}

//#define JCDEBUGTYPES

static int
json_create_user_compare (void * thunk, const void * va, const void * vb)
{
    dSP;
    SV * sa;
    SV * sb;
    json_create_t * jc;
    int n;
    int c;

    sa = *(SV **) va;
    sb = *(SV **) vb;
    jc = (json_create_t *) thunk;

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    EXTEND(SP, 2);
    XPUSHs(sv_2mortal (newSVsv (sa)));
    XPUSHs(sv_2mortal (newSVsv (sb)));
    PUTBACK;
    n = call_sv (jc->cmp, G_SCALAR);
    if (n != 1) {
	croak ("Wrong number of return values %d from comparison function",
	       n);
    }
    SPAGAIN;
    c = POPi;
    PUTBACK;
    FREETMPS;
    LEAVE;
    return c;
}

static INLINE json_create_status_t
json_create_add_object_sorted (json_create_t * jc, HV * input_hv)
{
    I32 n_keys;
    int i;
    SV ** keys;

    n_keys = hv_iterinit (input_hv);
    if (n_keys == 0) {
	CALL (add_str_len (jc, "{}", strlen ("{}")));
	return json_create_ok;
    }
    CALL (add_open (jc, '{'));
    Newxz (keys, n_keys, SV *);
    jc->n_mallocs++;
    for (i = 0; i < n_keys; i++) {
	HE * he;
	he = hv_iternext (input_hv);
	keys[i] = hv_iterkeysv (he);
	if (HeUTF8 (he)) {
	    jc->unicode = 1;
	}
    }

    if (jc->cmp) {
	json_create_qsort_r (keys, n_keys, sizeof (SV **), jc,
			     json_create_user_compare);
    }
    else {
	sortsv_flags (keys, (size_t) n_keys, Perl_sv_cmp, /* flags */ 0);
    }

    for (i = 0; i < n_keys; i++) {
	SV * key_sv;
	char * key;
	STRLEN keylen;
	HE * he;

	COMMA;
	key_sv = keys[i];
	key = SvPV (key_sv, keylen);
	CALL (json_create_add_key_len (jc, (const unsigned char *) key,
				       keylen));
	he = hv_fetch_ent (input_hv, key_sv, 0, 0);
	if (! he) {
	    croak ("%s:%d: invalid sv_ptr for '%s' at offset %d",
		   __FILE__, __LINE__, key, i);
	}
	CALL (add_char (jc, ':'));
	CALL (json_create_recursively (jc, HeVAL(he)));
    }
    Safefree (keys);
    jc->n_mallocs--;

    CALL (add_close (jc, '}'));

    return json_create_ok;
}

/* Given a reference to a hash in "input_hv", recursively process it
   into JSON. "object" here means "JSON object", not "Perl object". */

static INLINE json_create_status_t
json_create_add_object (json_create_t * jc, HV * input_hv)
{
    I32 n_keys;
    int i;
    SV * value;
    char * key;
    /* I32 is correct, not STRLEN; see hv.c. */
    I32 keylen;
#ifdef INDENT
    if (jc->sort) {
       	return json_create_add_object_sorted (jc, input_hv);
    }
#endif /* INDENT */
    n_keys = hv_iterinit (input_hv);
    if (n_keys == 0) {
	CALL (add_str_len (jc, "{}", strlen ("{}")));
	return json_create_ok;
    }
    CALL (add_open (jc, '{'));
    for (i = 0; i < n_keys; i++) {
	HE * he;

	/* Get the information from the hash. */
	/* The following is necessary because "hv_iternextsv" doesn't
	   tell us whether the key is "SvUTF8" or not. */
	he = hv_iternext (input_hv);
	key = hv_iterkey (he, & keylen);
	value = hv_iterval (input_hv, he);

	/* Write the information into the buffer. */

	COMMA;
	if (HeUTF8 (he)) {
	    jc->unicode = 1;
	    CALL (json_create_add_key_len (jc, (const unsigned char *) key,
					   (STRLEN) keylen));
	}
	else if (jc->strict) {
	    CALL (json_create_add_ascii_key_len (jc, (unsigned char *) key,
						 (STRLEN) keylen));
	}
	else {
	    CALL (json_create_add_key_len (jc, (const unsigned char *) key,
					   (STRLEN) keylen));
	}
	CALL (add_char (jc, ':'));
	MSG ("Creating value of hash");
	CALL (json_create_recursively (jc, value));
    }
    CALL (add_close (jc, '}'));
    return json_create_ok;
}

/* Given an array reference in "av", recursively process it into
   JSON. */

static INLINE json_create_status_t
json_create_add_array (json_create_t * jc, AV * av)
{
    I32 n_keys;
    int i;
    SV * value;
    SV ** avv;

    MSG ("Adding first char [");
    CALL (add_open (jc, '['));
    n_keys = av_len (av) + 1;
    MSG ("n_keys = %ld", n_keys);

    /* This deals correctly with empty arrays, since av_len is -1 if
       the array is empty, so we do not test for a valid n_keys value
       before entering the loop. */
    for (i = 0; i < n_keys; i++) {
	MSG ("i = %d", i);
	COMMA;

	avv = av_fetch (av, i, 0 /* don't delete the array value */);
	if (avv) {
	    value = * avv;
	}
	else {
	    MSG ("null value returned by av_fetch");
	    value = & PL_sv_undef;
	}
	CALL (json_create_recursively (jc, value));
    }
    MSG ("Adding last char ]");
    CALL (add_close (jc, ']'));
    return json_create_ok;
}


static INLINE json_create_status_t
json_create_handle_unknown_type (json_create_t * jc, SV * r)
{
    if (jc->type_handler) {
	CALL (json_create_call_to_json (jc, jc->type_handler, r));
	return json_create_ok;
    }
    json_create_user_message (jc, json_create_unknown_type,
			      "Input's type cannot be serialized to JSON");
    return json_create_unknown_type;
}

#define STRICT_NO_SCALAR						\
    if (jc->strict) {							\
	goto handle_type;						\
    }

static INLINE json_create_status_t
json_create_handle_ref (json_create_t * jc, SV * r)
{
    svtype t;
    t = SvTYPE (r);
    MSG ("Type is %d", t);
    switch (t) {
    case SVt_PVAV:
	MSG("Array");
	CALL (json_create_add_array (jc, (AV *) r));
	break;

    case SVt_PVHV:
	MSG("Hash");
	CALL (json_create_add_object (jc, (HV *) r));
	break;

    case SVt_NV:
    case SVt_PVNV:
	MSG("NV/PVNV");
	STRICT_NO_SCALAR;
	CALL (json_create_add_float (jc, r));
	break;

    case SVt_IV:
    case SVt_PVIV:
	MSG("IV/PVIV");
	STRICT_NO_SCALAR;
	CALL (json_create_add_integer (jc, r));
	break;

    case SVt_PV:
	MSG("PV");
	STRICT_NO_SCALAR;
	CALL (json_create_add_string (jc, r));
	break;

    case SVt_PVMG:
	MSG("PVMG");
	STRICT_NO_SCALAR;
	CALL (json_create_add_magic (jc, r));
	break;

    default:
    handle_type:
	CALL (json_create_handle_unknown_type (jc, r));
    }
    return json_create_ok;
}

/* In strict mode, if no object handlers exist, then we reject the
   object. */

#define REJECT_OBJECT(objtype)						\
    json_create_user_message (jc, json_create_unknown_type,		\
			      "Object cannot be "			\
			      "serialized to JSON: %s",			\
			      objtype);					\
    return json_create_unknown_type;


static INLINE json_create_status_t
json_create_handle_object (json_create_t * jc, SV * r,
			   const char * objtype, I32 olen)
{
    SV ** sv_ptr;
#ifdef DEBUGOBJ
    fprintf (stderr, "Have found an object of type %s.\n", objtype);
#endif
    sv_ptr = hv_fetch (jc->handlers, objtype, olen, 0);
    if (sv_ptr) {
	char * pv;
	STRLEN pvlen;
	pv = SvPV (*sv_ptr, pvlen);
#ifdef DEBUGOBJ
	fprintf (stderr, "Have found a handler %s for %s.\n", pv, objtype);
#endif
	if (pvlen == strlen ("bool") &&
	    strncmp (pv, "bool", 4) == 0) {
	    if (SvTRUE (r)) {
		ADD ("true");
	    }
	    else {
		ADD ("false");
	    }
	}
	else if (SvROK (*sv_ptr)) {
	    SV * what;
	    what = SvRV (*sv_ptr);
	    switch (SvTYPE (what)) {
	    case SVt_PVCV:
		CALL (json_create_call_to_json (jc, what, r));
		break;
	    default:
		/* Weird handler, not a code reference. */
		goto nothandled;
	    }
	}
	else {
	    /* It's an object, it's in our handlers, but we don't
	       have any code to deal with it, so we'll print an
	       error and then stringify it. */
	    if (JCEH) {
		(*JCEH) (__FILE__, __LINE__, "Unhandled handler %s.\n",
			 pv);
		goto nothandled;
	    }
	}
    }
    else {
#ifdef DEBUGOBJ
	/* Leaving this debugging code here since this is liable
	   to change a lot. */
	I32 hvnum;
	SV * s;
	char * key;
	I32 retlen;
	fprintf (stderr, "Nothing in handlers for %s.\n", objtype);
	hvnum = hv_iterinit (jc->handlers);

	fprintf (stderr, "There are %ld keys in handlers.\n", hvnum);
	while (1) {
	    s = hv_iternextsv (jc->handlers, & key, & retlen);
	    if (! s) {
		break;
	    }
	    fprintf (stderr, "%s: %s\n", key, SvPV_nolen (s));
	}
#endif /* 0 */
    nothandled:
	if (jc->strict) {
	    REJECT_OBJECT(objtype);
	}
	CALL (json_create_handle_ref (jc, r));
    }
    return json_create_ok;
}

#define JCBOOL "JSON::Create::Bool"

static json_create_status_t
json_create_refobj (json_create_t * jc, SV * input)
{
    SV * r;
    r = SvRV (input);

    MSG("A reference");
    /* We have a reference, so decide what to do with it. */
    if (sv_isobject (input)) {
	const char * objtype;
	I32 olen;
	objtype = sv_reftype (r, 1);
	olen = (I32) strlen (objtype);
	if (olen == strlen (JCBOOL) &&
	    strncmp (objtype, JCBOOL, strlen (JCBOOL)) == 0) {
	    if (SvTRUE (r)) {
		ADD("true");
	    }
	    else {
		ADD("false");
	    }
	    return json_create_ok;
	}
	if (jc->obj_handler) {
	    CALL (json_create_call_to_json (jc, jc->obj_handler, r));
	    return json_create_ok;
	}
	if (jc->handlers) {
	    CALL (json_create_handle_object (jc, r, objtype, olen));
	    return json_create_ok;
	}
	if (jc->strict) {
	    REJECT_OBJECT (objtype);
	    return json_create_ok;
	}
    }

    MSG ("create handle references");

    CALL (json_create_handle_ref (jc, r));
    return json_create_ok;
}

#ifdef INDENT
#define TOP_NEWLINE \
    if (jc->indent && jc->depth == 0) {\
	MSG ("Top-level non-object non-array with indent, adding newline");\
	CALL (add_char (jc, '\n'));\
    }
#else
#define TOP_NEWLINE
#endif /* INDENT */

static json_create_status_t
json_create_not_ref (json_create_t * jc, SV * r)
{
    svtype t;

    MSG("Not a reference.");

    t = SvTYPE (r);
    switch (t) {

    case SVt_NULL:
	ADD ("null");
	break;

    case SVt_PVMG:
	MSG ("SVt_PVMG %s", SvPV_nolen (r));
	CALL (json_create_add_magic (jc, r));
	break;

    case SVt_PV:
	MSG ("SVt_PV %s", SvPV_nolen (r));
	CALL (json_create_add_string (jc, r));
	break;

    case SVt_IV:
	MSG ("SVt_IV %ld\n", SvIV (r));
	CALL (json_create_add_integer (jc, r));
	break;

    case SVt_NV:
	MSG ("SVt_NV %g", SvNV (r));
	CALL (json_create_add_float (jc, r));
	break;

    case SVt_PVNV:
	if (SvNIOK (r)) {
	    if (SvNOK (r)) {
		MSG ("SVt_PVNV with double %s/%g", SvPV_nolen (r), SvNV (r));

		/* We need to handle non-finite numbers without using
		   Perl's stringified forms, because we need to put quotes
		   around them, whereas Perl will just print 'nan' the
		   same way it will print '0.01'. 'nan' is not valid JSON,
		   so we have to convert to '"nan"'. */
		CALL (json_create_add_float (jc, r));
	    }
	    else if (SvIOK (r)) {
		MSG ("SVt_PVNV with integer %s/%g", SvPV_nolen (r), SvNV (r));

		/* We need to handle non-finite numbers without using
		   Perl's stringified forms, because we need to put quotes
		   around them, whereas Perl will just print 'nan' the
		   same way it will print '0.01'. 'nan' is not valid JSON,
		   so we have to convert to '"nan"'. */
		CALL (json_create_add_integer (jc, r));
	    }
	    else {
		/* I'm not sure if this will be reached. */
		MSG ("SVt_PVNV without valid NV/IV %s", SvPV_nolen (r));
		CALL (json_create_add_string (jc, r));
	    }
	}
	else {
	    MSG ("SVt_PVNV without valid NV/IV %s", SvPV_nolen (r));
	    CALL (json_create_add_string (jc, r));
	}
	break;

    case SVt_PVIV:
	/* Add numbers with a string version using the strings
	   which Perl contains. */
	if (SvIOK (r)) {
	    MSG ("SVt_PVIV %s/%ld", SvPV_nolen (r), SvIV (r));
	    CALL (json_create_add_integer (jc, r));
	}
	else {

	    /* This combination of things happens e.g. with the
	       value returned under "script" by charinfo of
	       Unicode::UCD. If we don't catch it with SvIOK as
	       above, we get an error of the form 'Argument
	       "Latin" isn't numeric in subroutine entry' */
#if 0
	    fprintf (stderr, "%s:%d: SVt_PVIV without valid IV %s\n",
		     __FILE__, __LINE__, SvPV_nolen (r));
#endif /* 0 */
	    CALL (json_create_add_string (jc, r));
	}
	break;

    default:
	CALL (json_create_handle_unknown_type (jc, r));
    }
    TOP_NEWLINE;
    return json_create_ok;
}

/* This is the core routine, it is called recursively as hash values
   and array values containing array or hash references are
   handled. */

static json_create_status_t
json_create_recursively (json_create_t * jc, SV * input)
{

    MSG("sv = %p.", input);

    if (! SvOK (input)) {
	/* We were told to add an undefined value, so put the literal
	   'null' (without quotes) at the end of "jc" then return. */
	MSG("Adding 'null'");
	ADD ("null");
	TOP_NEWLINE;
	return json_create_ok;
    }
    /* JSON::Parse inserts pointers to &PL_sv_yes and no as literal
       "true" and "false" markers. */
    if (input == &PL_sv_yes) {
	MSG("Adding 'true'");
	ADD ("true");
	return json_create_ok;
    }
    if (input == &PL_sv_no) {
	MSG("Adding 'false'");
	ADD ("false");
	return json_create_ok;
    }
    if (SvROK (input)) {
	CALL (json_create_refobj (jc, input));
	return json_create_ok;
    }
    CALL (json_create_not_ref (jc, input));
    return json_create_ok;
}

/* Master-caller macro. Calls to subsystems from "json_create" cannot
   be handled using the CALL macro above, because we need to return a
   non-status value from json_create. If things go wrong somewhere, we
   return "undef". */

#define FINALCALL(x) {						\
	json_create_status_t status;				\
	status = x;						\
	if (status != json_create_ok) {				\
	    HANDLE_STATUS (x, status);				\
	    /* Free the memory of "output". */			\
	    if (jc->output) {					\
		SvREFCNT_dec (jc->output);			\
		jc->output = 0;					\
	    }							\
	    /* return undef; */					\
	    return & PL_sv_undef;				\
	}							\
    }

/* This is the main routine of JSON::Create, where the JSON is
   produced from the Perl structure in "input". */

static INLINE SV *
json_create_create (json_create_t * jc, SV * input)
{
    unsigned char buffer[BUFSIZE];

    /* Set up all the transient variables for reading. */

    jc->buffer = buffer;
    jc->length = 0;
    /* Tell json_create_buffer_fill that it needs to allocate an
       SV. */
    jc->output = 0;
    /* Not Unicode. */
    jc->unicode = 0;

    FINALCALL (json_create_recursively (jc, input));
    FINALCALL (json_create_buffer_fill (jc));

    if (jc->unicode && ! jc->downgrade_utf8) {
	if (jc->utf8_dangerous) {
	    if (is_utf8_string ((U8 *) SvPV_nolen (jc->output),
				SvCUR (jc->output))) {
		SvUTF8_on (jc->output);
	    }
	    else {
		json_create_user_message (jc, json_create_unicode_bad_utf8,
					  "Invalid UTF-8 from user routine");
		return & PL_sv_undef;
	    }
	}
	else {
	    SvUTF8_on (jc->output);
	}
    }

    /* We didn't allocate any memory except for the SV, all our memory
       is on the stack, so there is nothing to free here. */

    return jc->output;
}

/*  __  __      _   _               _
   |  \/  | ___| |_| |__   ___   __| |___
   | |\/| |/ _ \ __| '_ \ / _ \ / _` / __|
   | |  | |  __/ |_| | | | (_) | (_| \__ \
   |_|  |_|\___|\__|_| |_|\___/ \__,_|___/ */


static json_create_status_t
json_create_new (json_create_t ** jc_ptr)
{
    json_create_t * jc;
    Newxz (jc, 1, json_create_t);
    jc->n_mallocs = 0;
    jc->n_mallocs++;
    jc->fformat = 0;
    jc->type_handler = 0;
    jc->handlers = 0;
    * jc_ptr = jc;
    return json_create_ok;
}

static json_create_status_t
json_create_free_fformat (json_create_t * jc)
{
    if (jc->fformat) {
	Safefree (jc->fformat);
	jc->fformat = 0;
	jc->n_mallocs--;
    }
    return json_create_ok;
}

static json_create_status_t
json_create_set_fformat (json_create_t * jc, SV * fformat)
{
    char * ff;
    STRLEN fflen;
    int i;

    CALL (json_create_free_fformat (jc));
    if (! SvTRUE (fformat)) {
	jc->fformat = 0;
	return json_create_ok;
    }

    ff = SvPV (fformat, fflen);
    if (! strchr (ff, '%')) {
	return json_create_bad_floating_format;
    }
    Newx (jc->fformat, fflen + 1, char);
    jc->n_mallocs++;
    for (i = 0; i < fflen; i++) {
	/* We could also check the format in this loop. */
	jc->fformat[i] = ff[i];
    }
    jc->fformat[fflen] = '\0';
    return json_create_ok;
}

static json_create_status_t
json_create_remove_handlers (json_create_t * jc)
{
    if (jc->handlers) {
	SvREFCNT_dec ((SV *) jc->handlers);
	jc->handlers = 0;
	jc->n_mallocs--;
    }
    return json_create_ok;
}

static json_create_status_t
json_create_remove_type_handler (json_create_t * jc)
{
    if (jc->type_handler) {
	SvREFCNT_dec (jc->type_handler);
	jc->type_handler = 0;
	jc->n_mallocs--;
    }
    return json_create_ok;
}

static json_create_status_t
json_create_remove_obj_handler (json_create_t * jc)
{
    if (jc->obj_handler) {
	SvREFCNT_dec (jc->obj_handler);
	jc->obj_handler = 0;
	jc->n_mallocs--;
    }
    return json_create_ok;
}

static json_create_status_t
json_create_remove_non_finite_handler (json_create_t * jc)
{
    if (jc->non_finite_handler) {
	SvREFCNT_dec (jc->non_finite_handler);
	jc->non_finite_handler = 0;
	jc->n_mallocs--;
    }
    return json_create_ok;
}

static json_create_status_t
json_create_remove_cmp (json_create_t * jc)
{
    if (jc->cmp) {
	SvREFCNT_dec (jc->cmp);
	jc->cmp = 0;
	jc->n_mallocs--;
    }
    return json_create_ok;
}

static json_create_status_t
json_create_free (json_create_t * jc)
{
    CALL (json_create_free_fformat (jc));
    CALL (json_create_remove_handlers (jc));
    CALL (json_create_remove_type_handler (jc));
    CALL (json_create_remove_obj_handler (jc));
    CALL (json_create_remove_non_finite_handler (jc));
    CALL (json_create_remove_cmp (jc));

    /* Finished, check we have no leaks before freeing. */

    jc->n_mallocs--;
    if (jc->n_mallocs != 0) {
	fprintf (stderr, "%s:%d: n_mallocs = %d\n",
		 __FILE__, __LINE__, jc->n_mallocs);
    }
    Safefree (jc);
    return json_create_ok;
}

static void
bump (json_create_t * jc, SV * h)
{
    SvREFCNT_inc (h);
    jc->n_mallocs++;
}

static void
set_non_finite_handler (json_create_t * jc, SV * oh)
{
    jc->non_finite_handler = oh;
    bump (jc, oh);
}

static void
set_object_handler (json_create_t * jc, SV * oh)
{
    jc->obj_handler = oh;
    bump (jc, oh);
}

static void
set_type_handler (json_create_t * jc, SV * th)
{
    jc->type_handler = th;
    bump (jc, th);
}

/* Use the length of the string to eliminate impossible matches before
   looking at the string's bytes. */

#define CMP(x) (strlen(#x) == (size_t) key_len && \
		strncmp(#x, key, key_len) == 0)

#define BOOL(x)								\
    if (CMP(x)) {							\
	jc->x = SvTRUE (value) ? 1 : 0;					\
	return;								\
    }

#define HANDLER(x)				\
    if (CMP(x ## _handler)) {			\
	set_ ## x ## _handler (jc, value);	\
	return;					\
    }

static void
json_create_set (json_create_t * jc, SV * key_sv, SV * value)
{
    const char * key;
    STRLEN key_len;

    key = SvPV (key_sv, key_len);

    BOOL (downgrade_utf8);
    BOOL (escape_slash);
    BOOL (fatal_errors);
    BOOL (indent);
    BOOL (no_javascript_safe);
    BOOL (replace_bad_utf8);
    BOOL (sort);
    BOOL (strict);
    BOOL (unicode_upper);
    BOOL (unicode_escape_all);
    BOOL (validate);
    HANDLER (non_finite);
    HANDLER (object);
    HANDLER (type);
    warn ("Unknown option '%s'", key);
}