X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FData%2FDumper%2FDumper.xs;h=e6940a3f0f2088ffff5abc3852530dee2e8a481a;hb=65e66c80cefadd5e860e8232c69fd1a11e6c5b92;hp=00b52dfa0017f527d082f916738c0db4c9087aeb;hpb=3bef8b4a6d7c7e51bf579a6adc7c4edd24022569;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index 00b52df..e6940a3 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -3,37 +3,54 @@ #include "perl.h" #include "XSUB.h" -#ifndef PERL_VERSION -# include -# ifndef PERL_VERSION -# include -# endif -# define PERL_VERSION PATCHLEVEL -#endif - -#if PERL_VERSION < 5 -# ifndef PL_sv_undef -# define PL_sv_undef sv_undef -# endif -# ifndef ERRSV -# define ERRSV GvSV(errgv) -# endif -# ifndef newSVpvn -# define newSVpvn newSVpv -# endif -#endif - static I32 num_q (char *s, STRLEN slen); static I32 esc_q (char *dest, char *src, STRLEN slen); static I32 esc_q_utf8 (pTHX_ SV *sv, char *src, STRLEN slen); -static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n); -static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, +static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n); +static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, AV *postav, I32 *levelp, I32 indent, - SV *pad, SV *xpad, SV *apad, SV *sep, + SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys); +#ifndef HvNAME_get +#define HvNAME_get HvNAME +#endif + +#if PERL_VERSION <= 6 /* Perl 5.6 and earlier */ + +# ifdef EBCDIC +# define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch)) +# else +# define UNI_TO_NATIVE(ch) (ch) +# endif + +UV +Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen) +{ + UV uv = utf8_to_uv(s, UTF8_MAXLEN, retlen, + ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + return UNI_TO_NATIVE(uv); +} + +# if !defined(PERL_IMPLICIT_CONTEXT) +# define utf8_to_uvchr Perl_utf8_to_uvchr +# else +# define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b) +# endif + +#endif /* PERL_VERSION <= 6 */ + +/* Changes in 5.7 series mean that now IOK is only set if scalar is + precisely integer but in 5.6 and earlier we need to do a more + complex test */ +#if PERL_VERSION <= 6 +#define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv))) +#else +#define DD_is_integer(sv) SvIOK(sv) +#endif + /* does a string need to be protected? */ static I32 needs_quote(register char *s) @@ -191,18 +208,20 @@ esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen) /* append a repeated string to an SV */ static SV * -sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n) +sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n) { if (sv == Nullsv) sv = newSVpvn("", 0); +#ifdef DEBUGGING else assert(SvTYPE(sv) >= SVt_PV); +#endif if (n > 0) { SvGROW(sv, len*n + SvCUR(sv) + 1); if (len == 1) { char *start = SvPVX(sv) + SvCUR(sv); - SvCUR(sv) += n; + SvCUR_set(sv, SvCUR(sv) + n); start[n] = '\0'; while (n > 0) start[--n] = str[0]; @@ -222,9 +241,9 @@ sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n) * efficiency raisins.) Ugggh! */ static I32 -DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, +DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad, - SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity, + SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys) { char tmpbuf[128]; @@ -247,20 +266,20 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, mg_get(val); if (SvROK(val)) { + /* If a freeze method is provided and the object has it, call + it. Warn on errors. */ if (SvOBJECT(SvRV(val)) && freezer && - SvPOK(freezer) && SvCUR(freezer)) + SvPOK(freezer) && SvCUR(freezer) && + gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer), + SvCUR(freezer), -1) != NULL) { dSP; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(val); PUTBACK; - i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR); + i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID); SPAGAIN; if (SvTRUE(ERRSV)) warn("WARNING(Freezer method call failed): %"SVf"", ERRSV); - else if (i) - val = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; - if (i) - (void)sv_2mortal(val); } ival = SvRV(val); @@ -268,7 +287,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, (void) sprintf(id, "0x%"UVxf, PTR2UV(ival)); idlen = strlen(id); if (SvOBJECT(ival)) - realpack = HvNAME(SvSTASH(ival)); + realpack = HvNAME_get(SvSTASH(ival)); else realpack = Nullch; @@ -299,9 +318,9 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, } else { if (name[0] == '@' || name[0] == '%') { - if ((SvPVX(othername))[0] == '\\' && - (SvPVX(othername))[1] == name[0]) { - sv_catpvn(retval, SvPVX(othername)+1, + if ((SvPVX_const(othername))[0] == '\\' && + (SvPVX_const(othername))[1] == name[0]) { + sv_catpvn(retval, SvPVX_const(othername)+1, SvCUR(othername)-1); } else { @@ -339,7 +358,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, (void)SvREFCNT_inc(val); av_push(seenentry, val); (void)hv_store(seenhv, id, strlen(id), - newRV((SV*)seenentry), 0); + newRV_inc((SV*)seenentry), 0); SvREFCNT_dec(seenentry); } } @@ -388,7 +407,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, } (*levelp)++; - ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp); + ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp); if (realtype <= SVt_PVBM) { /* scalar ref */ SV *namesv = newSVpvn("${", 2); @@ -396,16 +415,16 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, sv_catpvn(namesv, "}", 1); if (realpack) { /* blessed */ sv_catpvn(retval, "do{\\(my $o = ", 13); - DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, - postav, levelp, indent, pad, xpad, apad, sep, + DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, + postav, levelp, indent, pad, xpad, apad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, sortkeys); sv_catpvn(retval, ")}", 2); } /* plain */ else { sv_catpvn(retval, "\\", 1); - DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, - postav, levelp, indent, pad, xpad, apad, sep, + DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, + postav, levelp, indent, pad, xpad, apad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, sortkeys); } @@ -416,8 +435,8 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, sv_catpvn(namesv, name, namelen); sv_catpvn(namesv, "}", 1); sv_catpvn(retval, "\\", 1); - DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, - postav, levelp, indent, pad, xpad, apad, sep, + DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, + postav, levelp, indent, pad, xpad, apad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, sortkeys); SvREFCNT_dec(namesv); @@ -486,14 +505,14 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, sv_catsv(retval, totpad); sv_catsv(retval, ipad); DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, - levelp, indent, pad, xpad, apad, sep, + levelp, indent, pad, xpad, apad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, sortkeys); if (ix < ixmax) sv_catpvn(retval, ",", 1); } if (ixmax >= 0) { - SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1); + SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1); sv_catsv(retval, totpad); sv_catsv(retval, opad); SvREFCNT_dec(opad); @@ -546,6 +565,9 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, /* If requested, get a sorted/filtered array of hash keys */ if (sortkeys) { if (sortkeys == &PL_sv_yes) { +#if PERL_VERSION < 8 + sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23)); +#else keys = newAV(); (void)hv_iterinit((HV*)ival); while ((entry = hv_iternext((HV*)ival))) { @@ -553,17 +575,18 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, SvREFCNT_inc(sv); av_push(keys, sv); } -#ifdef USE_LOCALE_NUMERIC +# ifdef USE_LOCALE_NUMERIC sortsv(AvARRAY(keys), av_len(keys)+1, IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp); -#else +# else sortsv(AvARRAY(keys), av_len(keys)+1, Perl_sv_cmp); +# endif #endif } - else { + if (sortkeys != &PL_sv_yes) { dSP; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK; i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL); @@ -593,9 +616,11 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, I32 nlen; bool do_utf8 = FALSE; - if ((sortkeys && !(keys && (I32)i <= av_len(keys))) || - !(entry = hv_iternext((HV *)ival))) - break; + if (sortkeys) { + if (!(keys && (I32)i <= av_len(keys))) break; + } else { + if (!(entry = hv_iternext((HV *)ival))) break; + } if (i) sv_catpvn(retval, ",", 1); @@ -640,7 +665,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, There should also be less tests for the (probably currently) more common doesn't need quoting case. The code is also smaller (22044 vs 22260) because I've been - able to pull the comon logic out to both sides. */ + able to pull the common logic out to both sides. */ if (quotekeys || needs_quote(key)) { if (do_utf8) { STRLEN ocur = SvCUR(retval); @@ -671,7 +696,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, sv_catpvn(sname, nkey, nlen); sv_catpvn(sname, "}", 1); - sv_catpvn(retval, " => ", 4); + sv_catsv(retval, pair); if (indent >= 2) { char *extra; I32 elen = 0; @@ -686,8 +711,8 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, else newapad = apad; - DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv, - postav, levelp, indent, pad, xpad, newapad, sep, + DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv, + postav, levelp, indent, pad, xpad, newapad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, sortkeys); SvREFCNT_dec(sname); @@ -696,7 +721,7 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, SvREFCNT_dec(newapad); } if (i) { - SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1); + SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1); sv_catsv(retval, totpad); sv_catsv(retval, opad); SvREFCNT_dec(opad); @@ -759,24 +784,19 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, sv_catpvn(namesv, name, namelen); seenentry = newAV(); av_push(seenentry, namesv); - av_push(seenentry, newRV(val)); - (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0); + av_push(seenentry, newRV_inc(val)); + (void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0); SvREFCNT_dec(seenentry); } } - if (SvIOK(val)) { + if (DD_is_integer(val)) { STRLEN len; if (SvIsUV(val)) (void) sprintf(tmpbuf, "%"UVuf, SvUV(val)); else (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); len = strlen(tmpbuf); - /* For 5.6.x and earlier will need to change this test to check - NV if NOK, as there NOK trumps IOK, and NV=3.5,IV=3 is valid. - Current code will Dump that as $VAR1 = 3; - Changes in 5.7 series mean that now IOK is only set if scalar - is precisely integer. */ if (SvPOK(val)) { /* Need to check to see if this is a string such as " 0". I'm assuming from sprintf isn't going to clash with utf8. @@ -818,8 +838,8 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, SvCUR_set(retval, SvCUR(retval)+i); if (purity) { - static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; - static STRLEN sizes[] = { 8, 7, 6 }; + static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; + static const STRLEN sizes[] = { 8, 7, 6 }; SV *e; SV *nname = newSVpvn("", 0); SV *newapad = newSVpvn("", 0); @@ -841,15 +861,15 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, sv_catpvn(nname, entries[j], sizes[j]); sv_catpvn(postentry, " = ", 3); av_push(postav, postentry); - e = newRV(e); + e = newRV_inc(e); - SvCUR(newapad) = 0; + SvCUR_set(newapad, 0); if (indent >= 2) (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry)); - DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry, + DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry, seenhv, postav, &nlevel, indent, pad, xpad, - newapad, sep, freezer, toaster, purity, + newapad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, sortkeys); SvREFCNT_dec(e); @@ -914,7 +934,7 @@ Data_Dumper_Dumpxs(href, ...) I32 level = 0; I32 indent, terse, i, imax, postlen; SV **svp; - SV *val, *name, *pad, *xpad, *apad, *sep, *varname; + SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname; SV *freezer, *toaster, *bless, *sortkeys; I32 purity, deepcopy, quotekeys, maxdepth = 0; char tmpbuf[1024]; @@ -947,8 +967,8 @@ Data_Dumper_Dumpxs(href, ...) todumpav = namesav = Nullav; seenhv = Nullhv; - val = pad = xpad = apad = sep = varname - = freezer = toaster = bless = &PL_sv_undef; + val = pad = xpad = apad = sep = pair = varname + = freezer = toaster = bless = sortkeys = &PL_sv_undef; name = sv_newmortal(); indent = 2; terse = purity = deepcopy = 0; @@ -983,6 +1003,8 @@ Data_Dumper_Dumpxs(href, ...) apad = *svp; if ((svp = hv_fetch(hv, "sep", 3, FALSE))) sep = *svp; + if ((svp = hv_fetch(hv, "pair", 4, FALSE))) + pair = *svp; if ((svp = hv_fetch(hv, "varname", 7, FALSE))) varname = *svp; if ((svp = hv_fetch(hv, "freezer", 7, FALSE))) @@ -1023,13 +1045,16 @@ Data_Dumper_Dumpxs(href, ...) val = *svp; else val = &PL_sv_undef; - if ((svp = av_fetch(namesav, i, TRUE))) + if ((svp = av_fetch(namesav, i, TRUE))) { sv_setsv(name, *svp); + if (SvOK(*svp) && !SvPOK(*svp)) + (void)SvPV_nolen_const(name); + } else (void)SvOK_off(name); - if (SvOK(name)) { - if ((SvPVX(name))[0] == '*') { + if (SvPOK(name)) { + if ((SvPVX_const(name))[0] == '*') { if (SvROK(val)) { switch (SvTYPE(SvRV(val))) { case SVt_PVAV: @@ -1049,7 +1074,7 @@ Data_Dumper_Dumpxs(href, ...) else (SvPVX(name))[0] = '$'; } - else if ((SvPVX(name))[0] != '$') + else if ((SvPVX_const(name))[0] != '$') sv_insert(name, 0, 0, "$", 1); } else { @@ -1070,8 +1095,8 @@ Data_Dumper_Dumpxs(href, ...) else newapad = apad; - DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv, - postav, &level, indent, pad, xpad, newapad, sep, + DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv, + postav, &level, indent, pad, xpad, newapad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, sortkeys); @@ -1081,7 +1106,7 @@ Data_Dumper_Dumpxs(href, ...) postlen = av_len(postav); if (postlen >= 0 || !terse) { sv_insert(valstr, 0, 0, " = ", 3); - sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name)); + sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name)); sv_catpvn(valstr, ";", 1); } sv_catsv(retval, pad);