Cpanel-JSON-XS
view release on metacpan or search on metacpan
# define snprintf _snprintf // C compilers have this in stdio.h
#endif
#ifndef PERL_UNUSED_RESULT
# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
# else
# define PERL_UNUSED_RESULT(v) ((void)(v))
# endif
#endif
#if defined(_AIX) && (!defined(HAS_LONG_DOUBLE) || AIX_WORKAROUND)
#define HAVE_NO_POWL
#endif
/* Freebsd 10: It has powl, but it is too bad. strtold is good. RT #101265 */
#if defined(__FreeBSD__) && defined(__clang__) && defined(USE_LONG_DOUBLE)
#define HAVE_BAD_POWL
#endif
#if PERL_VERSION < 22 && defined(HAS_SETLOCALE)
#define NEED_NUMERIC_LOCALE_C
#ifdef I_XLOCALE
#include <xlocale.h>
#endif
#endif
/* FIXME: still a refcount error */
#define HAVE_DECODE_BOM
#define UTF8BOM "\357\273\277" /* EF BB BF */
/* UTF16/32BOM is deprecated, RFC 8259 */
#define UTF16BOM "\377\376" /* FF FE or +UFEFF */
#define UTF16BOM_BE "\376\377" /* FE FF */
#define UTF32BOM "\377\376\000\000" /* FF FE 00 00 or +UFEFF */
#define UTF32BOM_BE "\000\000\376\377" /* 00 00 FE FF */
/* Need to disable broken gcc-9.[0-3] -O1. Assume gcc-10 is also still broken */
/* Only gcc defines __GNUC_PATCHLEVEL__, clang and icc do define __GNUC__ */
#if defined(__GNUC__) && defined(__GNUC_PATCHLEVEL__) && \
(((__GNUC__ == 9) && (__GNUC_MINOR__ <= 3) || \
(__GNUC__ > 9)))
# define BROKEN_GCC_OPT
#endif
/* mingw with USE_LONG_DOUBLE (and implied USE_MINGW_ANSI_STDIO) do use the
non-msvcrt inf/nan stringification in sprintf(). */
#if defined(WIN32) && !defined(__USE_MINGW_ANSI_STDIO) && !defined(USE_LONG_DOUBLE)
/* new ucrtd.dll runtime? We do not probe the runtime or variants in the Makefile.PL yet. */
#define STR_INF "inf"
#define STR_INF2 "inf.0"
#define STR_NAN "nan"
#define STR_QNAN "nan(ind)"
/* old standard msvcrt.dll */
#define STR_INF3 "1.#INF"
#define STR_INF4 "1.#INF.0"
#define STR_NAN2 "1.#IND"
#define STR_QNAN2 "1.#QNAN"
#define HAVE_QNAN
#elif defined(sun) || defined(__sun)
#define STR_INF "Infinity"
#define STR_NAN "NaN"
#elif defined(__hpux)
#define STR_INF "++"
#define STR_NAN "-?"
#define HAVE_NEG_NAN
#define STR_NEG_INF "---"
#define STR_NEG_NAN "?"
#elif defined(_AIX) || defined(_AIX50)
/* xlC compiler: __TOS_AIX__ FIXME: This does not work yet. GH #165 */
#define STR_INF "INF"
#define STR_INF2 "INF.0"
#define HAVE_NEG_NAN
#define STR_NEG_INF "-INF"
#define HAVE_NEG_NAN
#define HAVE_QNAN
#define STR_NAN "NaN"
#define STR_QNAN "NaNQ"
//#define STR_QNAN "NANQ"
#else
#define STR_INF "inf"
#define STR_NAN "nan"
#endif
/* NV_INF compatibility for Perl 5.6 */
#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(LDBL_INFINITY)
# define NV_INF LDBL_INFINITY
#endif
#if !defined(NV_INF) && defined(DBL_INFINITY)
# define NV_INF (NV)DBL_INFINITY
#endif
#if !defined(NV_INF) && defined(INFINITY)
# define NV_INF (NV)INFINITY
#endif
#if !defined(NV_INF) && defined(INF)
# define NV_INF (NV)INF
#endif
#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
# define NV_INF (NV)HUGE_VALL
#endif
#if !defined(NV_INF) && defined(HUGE_VAL)
# define NV_INF (NV)HUGE_VAL
#endif
/* NV_NAN compatibility for Perl 5.6 */
#if !defined(NV_NAN) && defined(USE_LONG_DOUBLE)
# if !defined(NV_NAN) && defined(LDBL_NAN)
# define NV_NAN LDBL_NAN
# endif
# if !defined(NV_NAN) && defined(LDBL_QNAN)
# define NV_NAN LDBL_QNAN
# endif
# if !defined(NV_NAN) && defined(LDBL_SNAN)
# define NV_NAN LDBL_SNAN
# endif
#endif
#if !defined(NV_NAN) && defined(DBL_NAN)
# define NV_NAN (NV)DBL_NAN
#endif
#if !defined(NV_NAN) && defined(DBL_QNAN)
# define NV_NAN (NV)DBL_QNAN
#endif
#if !defined(NV_NAN) && defined(DBL_SNAN)
# define NV_NAN (NV)DBL_SNAN
#endif
#if !defined(NV_NAN) && defined(QNAN)
# define NV_NAN (NV)QNAN
#endif
#if !defined(NV_NAN) && defined(SNAN)
# define NV_NAN (NV)SNAN
#endif
#if !defined(NV_NAN) && defined(NAN)
# define NV_NAN (NV)NAN
#endif
/* modfl() segfaults for -Duselongdouble && 64-bit mingw64 && mingw
runtime version 4.0 [perl #125924] */
#if defined(USE_LONG_DOUBLE) && defined(__MINGW64__) \
char *s;
if (isref) {
pv = AMG_CALLun(sv,string);
len = SvCUR(pv);
str = SvPVX(pv);
SvREFCNT_inc(pv);
}
else {
pv = newSVpvs("");
s = SvPV(sv,len);
sv_setpvn(pv,s,len);
if (SvUTF8(sv))
SvUTF8_on(pv);
else
SvUTF8_off(pv);
SvSETMAGIC(pv);
str = SvPVutf8_force(pv, len);
}
#endif
if (!len && !SvOBJECT (sv)) {
encode_const_str (aTHX_ enc, "null", 4, 0);
SvREFCNT_dec(pv);
return;
}
} else {
/* manually call all possible magic on AV, HV, FM */
if (SvGMAGICAL(sv))
mg_get(sv);
if (MyAMG(sv)) { /* force a RV here */
SV* rv = newRV(SvREFCNT_inc(sv));
#if PERL_VERSION <= 8
HV *stash = SvSTASH(sv);
if (!SvSTASH(rv) || !(SvFLAGS(sv) & SVf_AMAGIC)) {
sv_bless(rv, stash);
Gv_AMupdate(stash);
SvFLAGS(sv) |= SVf_AMAGIC;
}
#endif
#if PERL_VERSION > 13
pv = AMG_CALLunary(rv, string_amg);
#else
pv = AMG_CALLun(rv, string);
#endif
TAINT_IF(pv && SvTAINTED(pv));
if (pv && SvPOK(pv)) {
str = SvPVutf8_force(pv, len);
encode_ch (aTHX_ enc, '"');
encode_str (aTHX_ enc, str, len, 1);
encode_ch (aTHX_ enc, '"');
SvREFCNT_dec(rv);
return;
}
SvREFCNT_dec(rv);
}
}
if (UNLIKELY(isref == 1
&& (enc->json.flags & F_ALLOW_BIGNUM) && str && str[0] == '+')) {
str++;
len--;
}
/* if ALLOW_BIGNUM and Math::Big* and NaN => according to stringify_infnan */
if (UNLIKELY(
(enc->json.flags & F_ALLOW_BIGNUM)
&& str
&& SvROK(sv)
&& (memEQc(str, "NaN") || memEQc(str, "nan") ||
memEQc(str, "inf") || memEQc(str, "-inf"))))
{
if (is_bignum_obj (aTHX_ SvRV (sv)))
{
if (enc->json.infnan_mode == 0) {
encode_const_str (aTHX_ enc, "null", 4, 0);
if (pv) SvREFCNT_dec(pv);
return;
} else if (enc->json.infnan_mode == 3) {
if (memEQc(str, "NaN") || memEQc(str, "nan"))
encode_const_str (aTHX_ enc, "nan", 3, 0);
else if (memEQc(str, "inf"))
encode_const_str (aTHX_ enc, "inf", 3, 0);
else
encode_const_str (aTHX_ enc, "-inf", 4, 0);
if (pv) SvREFCNT_dec(pv);
return;
}
}
}
if (!str)
encode_const_str (aTHX_ enc, "null", 4, 0);
else {
if (isref != 1)
encode_ch (aTHX_ enc, '"');
encode_str (aTHX_ enc, str, len, 1);
if (isref != 1)
encode_ch (aTHX_ enc, '"');
}
#undef MyAMG
}
INLINE int
encode_bool_obj (pTHX_ enc_t *enc, SV *sv, int force_conversion, int as_string)
{
if (is_bool_obj (aTHX_ sv))
{
if (as_string)
encode_ch (aTHX_ enc, '"');
/* we need to apply threads_shared magic */
if
#ifdef USE_ITHREADS
(SvIV (sv))
#else
(SvIV_nomg (sv))
#endif
encode_const_str (aTHX_ enc, "true", 4, 0);
else
encode_const_str (aTHX_ enc, "false", 5, 0);
if (as_string)
encode_ch (aTHX_ enc, '"');
}
else if (force_conversion && enc->json.flags & (F_ALLOW_BLESSED|F_CONV_BLESSED))
{
if (as_string)
encode_ch (aTHX_ enc, '"');
if (SvTRUE_nomg (sv))
encode_const_str (aTHX_ enc, "true", 4, 0);
else
encode_const_str (aTHX_ enc, "false", 5, 0);
if (as_string)
encode_ch (aTHX_ enc, '"');
}
else
return 0;
return 1;
}
INLINE int
SvPV_nolen (typesv), (unsigned int)SvFLAGS (typesv),
SvPV_nolen (sv));
}
type = SvIVX (typesv);
}
if (UNLIKELY (type))
{
force_conversion = 1;
can_be_null = (type & JSON_TYPE_CAN_BE_NULL);
type &= ~JSON_TYPE_CAN_BE_NULL;
}
else
{
if (
#ifdef PERL_HAVE_BOOLEANS
UNLIKELY (sv == &PL_sv_yes || sv == &PL_sv_no || SvIsBOOL(sv))
#else
UNLIKELY (sv == &PL_sv_yes || sv == &PL_sv_no)
#endif
) type = JSON_TYPE_BOOL;
else if (SvNOKp (sv)) type = JSON_TYPE_FLOAT;
else if (SvIOKp (sv)) type = JSON_TYPE_INT;
else if (SvPOKp (sv)) type = JSON_TYPE_STRING;
else if (SvROK (sv)) process_ref = 1;
else if (!SvOK (sv)) can_be_null = 1;
}
if (can_be_null && !SvOK (sv))
encode_const_str (aTHX_ enc, "null", 4, 0);
else if (type == JSON_TYPE_BOOL)
encode_bool (aTHX_ enc, sv);
else if (type == JSON_TYPE_FLOAT)
{
int is_bigobj = 0;
char *savecur = NULL, *saveend = NULL;
char inf_or_nan = 0;
#ifdef NEED_NUMERIC_LOCALE_C
# ifdef HAS_USELOCALE
locale_t oldloc = (locale_t)0;
locale_t newloc;
# endif
bool loc_changed = FALSE;
char *locale = NULL;
#endif
NV nv = 0;
int had_nokp = SvNOKp(sv);
if (UNLIKELY (SvROK (sv) && SvOBJECT (SvRV (sv))) && (enc->json.flags & F_ALLOW_BIGNUM) && is_bignum_obj (aTHX_ SvRV (sv)))
is_bigobj = 1;
if (UNLIKELY (is_bigobj))
{
STRLEN len;
char *str = SvPV_nomg (sv, len);
if (UNLIKELY (str[0] == '+'))
{
str++;
len--;
}
if (UNLIKELY (memEQc (str, "NaN") || memEQc (str, "nan")))
{
nv = NV_NAN;
is_bigobj = 0;
}
else if (UNLIKELY (memEQc (str, "inf")))
{
nv = NV_INF;
is_bigobj = 0;
}
else if (UNLIKELY (memEQc (str, "-inf")))
{
nv = -NV_INF;
is_bigobj = 0;
}
else
{
need (aTHX_ enc, len+1+2); /* +2 for '.0' */
savecur = enc->cur;
saveend = enc->end;
memcpy (enc->cur, str, len);
*(enc->cur+len) = '\0';
}
}
else if (SvNOKp (sv))
{
nv = SvNVX (sv);
}
else
{
if (enc->json.flags & F_ALLOW_BIGNUM)
{
STRLEN len;
char *str;
SV *pv;
SV *errsv;
int numtype;
str = SvPV_nomg (sv, len);
numtype = grok_number (str, len, NULL);
if (UNLIKELY (numtype & IS_NUMBER_INFINITY))
nv = (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF;
else if (UNLIKELY (numtype & IS_NUMBER_NAN))
nv = NV_NAN;
else if (UNLIKELY (!numtype))
nv = SvNV_nomg (sv);
else
{
pv = newSVpvs ("require Math::BigFloat && Math::BigFloat->new(\"");
sv_catpvn (pv, str, len);
sv_catpvs (pv, "\");");
eval_sv (pv, G_SCALAR);
SvREFCNT_dec (pv);
/* rethrow current error */
errsv = ERRSV;
if (SvROK (errsv))
croak (NULL);
else if (SvTRUE (errsv))
{
char *savecur, *saveend;
/* we assume we can always read an IV as a UV and vice versa */
/* we assume two's complement */
/* we assume no aliasing issues in the union */
UV uv = 0;
IV iv = 0;
int is_neg = 0;
if (UNLIKELY (SvROK (sv) && SvOBJECT (SvRV (sv)))
&& (enc->json.flags & F_ALLOW_BIGNUM))
{
HV *stash = SvSTASH (SvRV (sv));
int is_bigint = (stash && stash == gv_stashpvs ("Math::BigInt", 0));
int is_bigfloat = (stash && stash == gv_stashpvs ("Math::BigFloat", 0));
if (is_bigint || is_bigfloat)
{
STRLEN len;
char *str;
if (is_bigfloat)
{
dSP;
int is_negative;
ENTER; SAVETMPS;
PUSHMARK (SP);
XPUSHs (sv);
PUTBACK;
call_method ("is_negative", G_SCALAR);
SPAGAIN;
is_negative = SvTRUEx (POPs);
PUTBACK;
PUSHMARK (SP);
XPUSHs (sv);
PUTBACK;
/* This bceil/bfloor logic can be replaced by just one "bint" method call
* but it is not supported by older Math::BigFloat versions.
* Older Math::BigFloat versions have also "as_number" method which should
* do same thing as "bint" method but it is broken and loose precision.
* This bceil/bfloor logic needs Math::BigFloat 1.16 which is in Perl 5.8.0. */
call_method (is_negative ? "bceil" : "bfloor", G_SCALAR);
SPAGAIN;
sv = POPs;
PUTBACK;
}
str = SvPV_nomg (sv, len);
if (UNLIKELY (str[0] == '+'))
{
str++;
len--;
}
if (UNLIKELY (strEQc (str, "NaN") || strEQc (str, "nan")))
{
encode_const_str (aTHX_ enc, "0", 1, 0);
}
else if (UNLIKELY (strEQc (str, "inf")))
{
need (aTHX_ enc, IVUV_MAXCHARS);
savecur = enc->cur;
saveend = enc->end;
enc->cur += snprintf (enc->cur, IVUV_MAXCHARS, "%" UVuf, UV_MAX);
}
else if (UNLIKELY (strEQc (str, "-inf")))
{
need (aTHX_ enc, IVUV_MAXCHARS);
savecur = enc->cur;
saveend = enc->end;
enc->cur += snprintf (enc->cur, IVUV_MAXCHARS, "%" IVdf, IV_MIN);
}
else
{
need (aTHX_ enc, len+1);
savecur = enc->cur;
saveend = enc->end;
memcpy (enc->cur, str, len);
enc->cur += len;
*enc->cur = '\0';
}
if (is_bigfloat)
{
FREETMPS;
LEAVE;
}
return;
}
}
if (SvIOK (sv))
{
is_neg = !SvIsUV (sv);
iv = SvIVX (sv);
uv = SvUVX (sv);
}
else if (SvPOKp (sv))
{
int numtype = grok_number (SvPVX (sv), SvCUR (sv), &uv);
if (numtype & IS_NUMBER_IN_UV)
{
if (numtype & IS_NUMBER_NEG)
{
is_neg = 1;
if (LIKELY(uv <= (UV)(IV_MAX) + 1))
iv = -(IV)uv;
else
{
iv = IV_MIN; /* underflow, but F_ALLOW_BIGNUM can handle this */
numtype |= IS_NUMBER_GREATER_THAN_UV_MAX;
}
uv = (UV)iv;
}
if (numtype & IS_NUMBER_NOT_INT)
pv = newSVpvs ("my $obj; require Math::BigFloat && ($obj = Math::BigFloat->new(\"");
else
pv = newSVpvs ("require Math::BigInt && return Math::BigInt->new(\"");
sv_catpvn (pv, SvPVX (sv), SvCUR (sv));
if (numtype & IS_NUMBER_NOT_INT)
/* This bceil/bfloor logic can be replaced by just one "bint" method call
* but it is not supported by older Math::BigFloat versions.
* Older Math::BigFloat versions have also "as_number" method which should
* do same thing as "bint" method but it is broken and loose precision.
* This bceil/bfloor logic needs Math::BigFloat 1.16 which is in Perl 5.8.0. */
sv_catpvs (pv, "\")) && ($obj->is_negative ? $obj->bceil : $obj->bfloor);");
else
sv_catpvs (pv, "\");");
eval_sv (pv, G_SCALAR);
SvREFCNT_dec (pv);
if (!json_validate (&enc->json))
croak (NULL);
/* rethrow current error */
errsv = ERRSV;
if (SvROK (errsv))
croak (NULL);
else if (SvTRUE (errsv))
croak ("%" SVf, SVfARG (errsv));
{
dSP;
pv = POPs;
PUTBACK;
}
str = SvPV (pv, len);
if (UNLIKELY (str[0] == '+'))
{
str++;
len--;
}
need (aTHX_ enc, len+1);
savecur = enc->cur;
saveend = enc->end;
memcpy (enc->cur, str, len);
enc->cur += len;
*enc->cur = '\0';
return;
}
else if (!(numtype & (IS_NUMBER_IN_UV|IS_NUMBER_INFINITY|IS_NUMBER_NAN)))
{
sv_to_ivuv (aTHX_ sv, &is_neg, &iv, &uv);
}
}
else
{
#if PERL_VERSION < 8
/* SvIV() and SvUV() in Perl 5.6 does not handle Inf and NaN in NV slot */
if (SvNOKp (sv) && UNLIKELY (isinf (SvNVX (sv))))
{
if (SvNVX (sv) < 0)
{
is_neg = 1;
iv = IV_MIN;
uv = (UV)iv;
}
else
{
uv = UV_MAX;
iv = (IV)uv;
}
}
else if (!SvNOKp (sv) || LIKELY (!isnan (SvNVX (sv))))
#endif
sv_to_ivuv (aTHX_ sv, &is_neg, &iv, &uv);
}
if (is_neg ? iv <= 59000 && iv >= -59000
: uv <= 59000)
{
/* optimise the "small number case" */
/* code will likely be branchless and use only a single multiplication */
/* works for numbers up to 59074 */
I32 i = iv;
U32 u;
char digit, nz = 0;
need (aTHX_ enc, 6);
savecur = enc->cur;
saveend = enc->end;
*enc->cur = '-'; enc->cur += i < 0 ? 1 : 0;
u = i < 0 ? -i : i;
/* convert to 4.28 fixed-point representation */
u = u * ((0xfffffff + 10000) / 10000); /* 10**5, 5 fractional digits */
/* now output digit by digit, each time masking out the integer part */
/* and multiplying by 5 while moving the decimal point one to the right, */
/* resulting in a net multiplication by 10. */
/* we always write the digit to memory but conditionally increment */
/* the pointer, to enable the use of conditional move instructions. */
digit = u >> 28; *enc->cur = digit + '0'; enc->cur += (nz = nz || digit); u = (u & 0xfffffffUL) * 5;
digit = u >> 27; *enc->cur = digit + '0'; enc->cur += (nz = nz || digit); u = (u & 0x7ffffffUL) * 5;
digit = u >> 26; *enc->cur = digit + '0'; enc->cur += (nz = nz || digit); u = (u & 0x3ffffffUL) * 5;
digit = u >> 25; *enc->cur = digit + '0'; enc->cur += (nz = nz || digit); u = (u & 0x1ffffffUL) * 5;
digit = u >> 24; *enc->cur = digit + '0'; enc->cur += 1; /* correctly generate '0' */
*enc->cur = 0;
}
else
{
/* large integer, use the (rather slow) snprintf way. */
need (aTHX_ enc, IVUV_MAXCHARS);
savecur = enc->cur;
saveend = enc->end;
enc->cur +=
!is_neg
? snprintf (enc->cur, IVUV_MAXCHARS, "%" UVuf, uv)
: snprintf (enc->cur, IVUV_MAXCHARS, "%" IVdf, iv);
( run in 3.109 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )