#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" 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, 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 *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) 162 { TOP: 162 if (s[0] == ':') { 16 if (*++s) { 16 if (*s++ != ':') ###### return 1; } else ###### return 1; } 162 if (isIDFIRST(*s)) { 344 while (*++s) 222 if (!isALNUM(*s)) { ###### if (*s == ':') ###### goto TOP; else ###### return 1; } } else 40 return 1; 122 return 0; } /* count the number of "'"s and "\"s in string */ static I32 num_q(register char *s, register STRLEN slen) 114 { 114 register I32 ret = 0; 319 while (slen > 0) { 205 if (*s == '\'' || *s == '\\') 2 ++ret; 205 ++s; 205 --slen; } 114 return ret; } /* returns number of chars added to escape "'"s and "\"s in s */ /* slen number of characters in s will be escaped */ /* destination must be long enough for additional chars */ static I32 esc_q(register char *d, register char *s, register STRLEN slen) 976 { 976 register I32 ret = 0; 4457 while (slen > 0) { 3481 switch (*s) { case '\'': case '\\': 2 *d = '\\'; 2 ++d; ++ret; default: 3481 *d = *s; 3481 ++d; ++s; --slen; 3481 break; } } 976 return ret; } static I32 esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen) 12 { 12 char *s, *send, *r, *rstart; 12 STRLEN j, cur = SvCUR(sv); /* Could count 128-255 and 256+ in two variables, if we want to be like &qquote and make a distinction. */ 12 STRLEN grow = 0; /* bytes needed to represent chars 128+ */ /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */ 12 STRLEN backslashes = 0; 12 STRLEN single_quotes = 0; 12 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */ 12 STRLEN normal = 0; /* this will need EBCDICification */ 58 for (s = src, send = src + slen; s < send; s += UTF8SKIP(s)) { 46 UV k = utf8_to_uvchr((U8*)s, NULL); 46 if (k > 127) { /* 4: \x{} then count the number of hex digits. */ 20 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 : #if UVSIZE == 4 8 /* We may allocate a bit more than the minimum here. */ #else k <= 0xFFFFFFFF ? 8 : UVSIZE * 4 #endif ); 26 } else if (k == '\\') { 2 backslashes++; 24 } else if (k == '\'') { 2 single_quotes++; 22 } else if (k == '"' || k == '$' || k == '@') { 10 qq_escapables++; } else { 12 normal++; } } 12 if (grow) { /* We have something needing hex. 3 is ""\0 */ 8 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes + 2*qq_escapables + normal); 8 rstart = r = SvPVX(sv) + cur; 8 *r++ = '"'; 38 for (s = src; s < send; s += UTF8SKIP(s)) { 30 UV k = utf8_to_uvchr((U8*)s, NULL); 30 if (k == '"' || k == '\\' || k == '$' || k == '@') { 8 *r++ = '\\'; 8 *r++ = (char)k; } 22 else if (k < 0x80) 2 *r++ = (char)k; else { /* The return value of sprintf() is unportable. * In modern systems it returns (int) the number of characters, * but in older systems it might return (char*) the original * buffer, or it might even be (void). The easiest portable * thing to do is probably use sprintf() in void context and * then strlen(buffer) for the length. The more proper way * would of course be to figure out the prototype of sprintf. * --jhi */ 20 sprintf(r, "\\x{%"UVxf"}", k); 20 r += strlen(r); } } 8 *r++ = '"'; } else { /* Single quotes. */ 4 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes + qq_escapables + normal); 4 rstart = r = SvPVX(sv) + cur; 4 *r++ = '\''; 20 for (s = src; s < send; s ++) { 16 char k = *s; 16 if (k == '\'' || k == '\\') 2 *r++ = '\\'; 16 *r++ = k; } 4 *r++ = '\''; } 12 *r = '\0'; 12 j = r - rstart; 12 SvCUR_set(sv, cur + j); 12 return j; } /* append a repeated string to an SV */ static SV * sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n) 1305 { 1305 if (sv == Nullsv) 1295 sv = newSVpvn("", 0); else 10 assert(SvTYPE(sv) >= SVt_PV); 1305 if (n > 0) { 1213 SvGROW(sv, len*n + SvCUR(sv) + 1); 1213 if (len == 1) { 909 char *start = SvPVX(sv) + SvCUR(sv); 909 SvCUR_set(sv, SvCUR(sv) + n); 909 start[n] = '\0'; 8128 while (n > 0) 7219 start[--n] = str[0]; } else 890 while (n > 0) { 586 sv_catpvn(sv, str, len); 586 --n; } } 1305 return sv; } /* * This ought to be split into smaller functions. (it is one long function since * it exactly parallels the perl version, which was one long thing for * efficiency raisins.) Ugggh! */ 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 *pair, SV *freezer, SV *toaster, I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys) 2148 { 2148 char tmpbuf[128]; 2148 U32 i; 2148 char *c, *r, *realpack, id[128]; 2148 SV **svp; 2148 SV *sv, *ipad, *ival; 2148 SV *blesspad = Nullsv; 2148 AV *seenentry = Nullav; 2148 char *iname; 2148 STRLEN inamelen, idlen = 0; 2148 U32 realtype; 2148 if (!val) ###### return 0; 2148 realtype = SvTYPE(val); 2148 if (SvGMAGICAL(val)) 16 mg_get(val); 2148 if (SvROK(val)) { /* If a freeze method is provided and the object has it, call it. Warn on errors. */ 446 if (SvOBJECT(SvRV(val)) && freezer && SvPOK(freezer) && SvCUR(freezer) && gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer), SvCUR(freezer), -1) != NULL) { 2 dSP; ENTER; SAVETMPS; PUSHMARK(sp); 2 XPUSHs(val); PUTBACK; 2 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID); 2 SPAGAIN; 2 if (SvTRUE(ERRSV)) 1 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV); 2 PUTBACK; FREETMPS; LEAVE; } 446 ival = SvRV(val); 446 realtype = SvTYPE(ival); 446 (void) sprintf(id, "0x%"UVxf, PTR2UV(ival)); 446 idlen = strlen(id); 446 if (SvOBJECT(ival)) 4 realpack = HvNAME_get(SvSTASH(ival)); else 442 realpack = Nullch; /* if it has a name, we need to either look it up, or keep a tab * on it so we know when we hit it later */ 446 if (namelen) { 446 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv))) { 202 SV *othername; 202 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) { 202 if (purity && *levelp > 0) { 70 SV *postentry; 70 if (realtype == SVt_PVHV) 22 sv_catpvn(retval, "{}", 2); 48 else if (realtype == SVt_PVAV) 26 sv_catpvn(retval, "[]", 2); else 22 sv_catpvn(retval, "do{my $o}", 9); 70 postentry = newSVpvn(name, namelen); 70 sv_catpvn(postentry, " = ", 3); 70 sv_catsv(postentry, othername); 70 av_push(postav, postentry); } else { 132 if (name[0] == '@' || name[0] == '%') { 30 if ((SvPVX_const(othername))[0] == '\\' && (SvPVX_const(othername))[1] == name[0]) { sv_catpvn(retval, SvPVX_const(othername)+1, 10 SvCUR(othername)-1); } else { 20 sv_catpvn(retval, name, 1); 20 sv_catpvn(retval, "{", 1); 20 sv_catsv(retval, othername); 20 sv_catpvn(retval, "}", 1); } } else 102 sv_catsv(retval, othername); } 202 return 1; } else { ###### warn("ref name not found for %s", id); ###### return 0; } } else { /* store our name and continue */ 244 SV *namesv; 244 if (name[0] == '@' || name[0] == '%') { 28 namesv = newSVpvn("\\", 1); 28 sv_catpvn(namesv, name, namelen); } 216 else if (realtype == SVt_PVCV && name[0] == '*') { ###### namesv = newSVpvn("\\", 2); ###### sv_catpvn(namesv, name, namelen); ###### (SvPVX(namesv))[1] = '&'; } else 216 namesv = newSVpvn(name, namelen); 244 seenentry = newAV(); 244 av_push(seenentry, namesv); 244 (void)SvREFCNT_inc(val); 244 av_push(seenentry, val); 244 (void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0); 244 SvREFCNT_dec(seenentry); } } 244 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) { ###### STRLEN rlen; ###### char *rval = SvPV(val, rlen); ###### char *slash = strchr(rval, '/'); ###### sv_catpvn(retval, "qr/", 3); ###### while (slash) { ###### sv_catpvn(retval, rval, slash-rval); ###### sv_catpvn(retval, "\\/", 2); ###### rlen -= slash-rval+1; ###### rval = slash+1; ###### slash = strchr(rval, '/'); } ###### sv_catpvn(retval, rval, rlen); ###### sv_catpvn(retval, "/", 1); ###### return 1; } /* If purity is not set and maxdepth is set, then check depth: * if we have reached maximum depth, return the string * representation of the thing we are currently examining * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). */ 244 if (!purity && maxdepth > 0 && *levelp >= maxdepth) { 6 STRLEN vallen; 6 char *valstr = SvPV(val,vallen); 6 sv_catpvn(retval, "'", 1); 6 sv_catpvn(retval, valstr, vallen); 6 sv_catpvn(retval, "'", 1); 6 return 1; } 238 if (realpack) { /* we have a blessed ref */ 4 STRLEN blesslen; 4 char *blessstr = SvPV(bless, blesslen); 4 sv_catpvn(retval, blessstr, blesslen); 4 sv_catpvn(retval, "( ", 2); 4 if (indent >= 2) { 4 blesspad = apad; 4 apad = newSVsv(apad); 4 sv_x(aTHX_ apad, " ", 1, blesslen+2); } } 238 (*levelp)++; 238 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp); 238 if (realtype <= SVt_PVBM) { /* scalar ref */ 64 SV *namesv = newSVpvn("${", 2); 64 sv_catpvn(namesv, name, namelen); 64 sv_catpvn(namesv, "}", 1); 64 if (realpack) { /* blessed */ ###### sv_catpvn(retval, "do{\\(my $o = ", 13); ###### 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 { 64 sv_catpvn(retval, "\\", 1); 64 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); } 64 SvREFCNT_dec(namesv); } 174 else if (realtype == SVt_PVGV) { /* glob ref */ 16 SV *namesv = newSVpvn("*{", 2); 16 sv_catpvn(namesv, name, namelen); 16 sv_catpvn(namesv, "}", 1); 16 sv_catpvn(retval, "\\", 1); 16 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); 16 SvREFCNT_dec(namesv); } 158 else if (realtype == SVt_PVAV) { 80 SV *totpad; 80 I32 ix = 0; 80 I32 ixmax = av_len((AV *)ival); 80 SV *ixsv = newSViv(0); /* allowing for a 24 char wide array index */ 80 New(0, iname, namelen+28, char); 80 (void)strcpy(iname, name); 80 inamelen = namelen; 80 if (name[0] == '@') { 20 sv_catpvn(retval, "(", 1); 20 iname[0] = '$'; } else { 60 sv_catpvn(retval, "[", 1); /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */ /*if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}' && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/ 60 if ((namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') || (namelen > 4 && (name[1] == '{' || (name[0] == '\\' && name[2] == '{')))) { 34 iname[inamelen++] = '-'; iname[inamelen++] = '>'; 34 iname[inamelen] = '\0'; } } 80 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 && (instr(iname+inamelen-8, "{SCALAR}") || instr(iname+inamelen-7, "{ARRAY}") || instr(iname+inamelen-6, "{HASH}"))) { 4 iname[inamelen++] = '-'; iname[inamelen++] = '>'; } 80 iname[inamelen++] = '['; iname[inamelen] = '\0'; 80 totpad = newSVsv(sep); 80 sv_catsv(totpad, pad); 80 sv_catsv(totpad, apad); 244 for (ix = 0; ix <= ixmax; ++ix) { 164 STRLEN ilen; 164 SV *elem; 164 svp = av_fetch((AV*)ival, ix, FALSE); 164 if (svp) 164 elem = *svp; else ###### elem = &PL_sv_undef; 164 ilen = inamelen; 164 sv_setiv(ixsv, ix); 164 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix); 164 ilen = strlen(iname); 164 iname[ilen++] = ']'; iname[ilen] = '\0'; 164 if (indent >= 3) { 14 sv_catsv(retval, totpad); 14 sv_catsv(retval, ipad); 14 sv_catpvn(retval, "#", 1); 14 sv_catsv(retval, ixsv); } 164 sv_catsv(retval, totpad); 164 sv_catsv(retval, ipad); 164 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, levelp, indent, pad, xpad, apad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, sortkeys); 164 if (ix < ixmax) 84 sv_catpvn(retval, ",", 1); } 80 if (ixmax >= 0) { 80 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1); 80 sv_catsv(retval, totpad); 80 sv_catsv(retval, opad); 80 SvREFCNT_dec(opad); } 80 if (name[0] == '@') 20 sv_catpvn(retval, ")", 1); else 60 sv_catpvn(retval, "]", 1); 80 SvREFCNT_dec(ixsv); 80 SvREFCNT_dec(totpad); 80 Safefree(iname); } 78 else if (realtype == SVt_PVHV) { 78 SV *totpad, *newapad; 78 SV *iname, *sname; 78 HE *entry; 78 char *key; 78 I32 klen; 78 SV *hval; 78 AV *keys = Nullav; 78 iname = newSVpvn(name, namelen); 78 if (name[0] == '%') { 8 sv_catpvn(retval, "(", 1); 8 (SvPVX(iname))[0] = '$'; } else { 70 sv_catpvn(retval, "{", 1); /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */ 70 if ((namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') || (namelen > 4 && (name[1] == '{' || (name[0] == '\\' && name[2] == '{')))) { 24 sv_catpvn(iname, "->", 2); } } 78 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 && (instr(name+namelen-8, "{SCALAR}") || instr(name+namelen-7, "{ARRAY}") || instr(name+namelen-6, "{HASH}"))) { 8 sv_catpvn(iname, "->", 2); } 78 sv_catpvn(iname, "{", 1); 78 totpad = newSVsv(sep); 78 sv_catsv(totpad, pad); 78 sv_catsv(totpad, apad); /* If requested, get a sorted/filtered array of hash keys */ 78 if (sortkeys) { 71 if (sortkeys == &PL_sv_yes) { #if PERL_VERSION < 8 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23)); #else 65 keys = newAV(); 65 (void)hv_iterinit((HV*)ival); 227 while ((entry = hv_iternext((HV*)ival))) { 162 sv = hv_iterkeysv(entry); 162 SvREFCNT_inc(sv); 162 av_push(keys, sv); } # ifdef USE_LOCALE_NUMERIC 65 sortsv(AvARRAY(keys), av_len(keys)+1, IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp); # else sortsv(AvARRAY(keys), av_len(keys)+1, Perl_sv_cmp); # endif #endif } 71 if (sortkeys != &PL_sv_yes) { 6 dSP; ENTER; SAVETMPS; PUSHMARK(sp); 6 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK; 6 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL); 6 SPAGAIN; 6 if (i) { 6 sv = POPs; 6 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV)) 6 keys = (AV*)SvREFCNT_inc(SvRV(sv)); } 6 if (! keys) ###### warn("Sortkeys subroutine did not return ARRAYREF\n"); 6 PUTBACK; FREETMPS; LEAVE; } 71 if (keys) 71 sv_2mortal((SV*)keys); } else 7 (void)hv_iterinit((HV*)ival); /* foreach (keys %hash) */ 302 for (i = 0; 1; i++) { 302 char *nkey; 302 char *nkey_buffer = NULL; 302 I32 nticks = 0; 302 SV* keysv; 302 STRLEN keylen; 302 I32 nlen; 302 bool do_utf8 = FALSE; 302 if ((sortkeys && !(keys && (I32)i <= av_len(keys))) || !(entry = hv_iternext((HV *)ival))) 7 break; 224 if (i) 146 sv_catpvn(retval, ",", 1); 224 if (sortkeys) { 216 char *key; 216 svp = av_fetch(keys, i, FALSE); 216 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef); 216 key = SvPV(keysv, keylen); 216 svp = hv_fetch((HV*)ival, key, SvUTF8(keysv) ? -(I32)keylen : keylen, 0); 216 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef); } else { 8 keysv = hv_iterkeysv(entry); 8 hval = hv_iterval((HV*)ival, entry); } 224 do_utf8 = DO_UTF8(keysv); 224 key = SvPV(keysv, keylen); 224 klen = keylen; 224 sv_catsv(retval, totpad); 224 sv_catsv(retval, ipad); /* old logic was first to check utf8 flag, and if utf8 always call esc_q_utf8. This caused test to break under -Mutf8, because there even strings like 'c' have utf8 flag on. Hence with quotekeys == 0 the XS code would still '' quote them based on flags, whereas the perl code would not, based on regexps. The perl code is correct. needs_quote() decides that anything that isn't a valid perl identifier needs to be quoted, hence only correctly formed strings with no characters outside [A-Za-z0-9_:] won't need quoting. None of those characters are used in the byte encoding of utf8, so anything with utf8 encoded characters in will need quoting. Hence strings with utf8 encoded characters in will end up inside do_utf8 just like before, but now strings with utf8 flag set but only ascii characters will end up in the unquoted section. 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 common logic out to both sides. */ 224 if (quotekeys || needs_quote(key)) { 118 if (do_utf8) { 4 STRLEN ocur = SvCUR(retval); 4 nlen = esc_q_utf8(aTHX_ retval, key, klen); 4 nkey = SvPVX(retval) + ocur; } else { 114 nticks = num_q(key, klen); 114 New(0, nkey_buffer, klen+nticks+3, char); 114 nkey = nkey_buffer; 114 nkey[0] = '\''; 114 if (nticks) 2 klen += esc_q(nkey+1, key, klen); else 112 (void)Copy(key, nkey+1, klen, char); 114 nkey[++klen] = '\''; 114 nkey[++klen] = '\0'; 114 nlen = klen; 114 sv_catpvn(retval, nkey, klen); } } else { 106 nkey = key; 106 nlen = klen; 106 sv_catpvn(retval, nkey, klen); } 224 sname = newSVsv(iname); 224 sv_catpvn(sname, nkey, nlen); 224 sv_catpvn(sname, "}", 1); 224 sv_catsv(retval, pair); 224 if (indent >= 2) { 38 char *extra; 38 I32 elen = 0; 38 newapad = newSVsv(apad); 38 New(0, extra, klen+4+1, char); 313 while (elen < (klen+4)) 275 extra[elen++] = ' '; 38 extra[elen] = '\0'; 38 sv_catpvn(newapad, extra, elen); 38 Safefree(extra); } else 186 newapad = apad; 224 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); 224 SvREFCNT_dec(sname); 224 Safefree(nkey_buffer); 224 if (indent >= 2) 38 SvREFCNT_dec(newapad); } 78 if (i) { 78 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1); 78 sv_catsv(retval, totpad); 78 sv_catsv(retval, opad); 78 SvREFCNT_dec(opad); } 78 if (name[0] == '%') 8 sv_catpvn(retval, ")", 1); else 70 sv_catpvn(retval, "}", 1); 78 SvREFCNT_dec(iname); 78 SvREFCNT_dec(totpad); } ###### else if (realtype == SVt_PVCV) { ###### sv_catpvn(retval, "sub { \"DUMMY\" }", 15); ###### if (purity) ###### warn("Encountered CODE ref, using dummy placeholder"); } else { ###### warn("cannot handle ref type %ld", realtype); } 238 if (realpack) { /* free blessed allocs */ 4 if (indent >= 2) { 4 SvREFCNT_dec(apad); 4 apad = blesspad; } 4 sv_catpvn(retval, ", '", 3); 4 sv_catpvn(retval, realpack, strlen(realpack)); 4 sv_catpvn(retval, "' )", 3); 4 if (toaster && SvPOK(toaster) && SvCUR(toaster)) { ###### sv_catpvn(retval, "->", 2); ###### sv_catsv(retval, toaster); ###### sv_catpvn(retval, "()", 2); } } 238 SvREFCNT_dec(ipad); 238 (*levelp)--; } else { 1702 STRLEN i; 1702 if (namelen) { 1702 (void) sprintf(id, "0x%"UVxf, PTR2UV(val)); 1702 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv))) { 62 SV *othername; 62 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp) && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0) { 8 sv_catpvn(retval, "${", 2); 8 sv_catsv(retval, othername); 8 sv_catpvn(retval, "}", 1); 8 return 1; } } 1640 else if (val != &PL_sv_undef) { 1640 SV *namesv; 1640 namesv = newSVpvn("\\", 1); 1640 sv_catpvn(namesv, name, namelen); 1640 seenentry = newAV(); 1640 av_push(seenentry, namesv); 1640 av_push(seenentry, newRV_inc(val)); 1640 (void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0); 1640 SvREFCNT_dec(seenentry); } } 1694 if (DD_is_integer(val)) { 762 STRLEN len; 762 if (SvIsUV(val)) 2 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val)); else 760 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); 762 len = strlen(tmpbuf); 762 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. Is this valid on EBCDIC? */ 168 STRLEN pvlen; 168 const char *pv = SvPV(val, pvlen); 168 if (pvlen != len || memNE(pv, tmpbuf, len)) 682 goto integer_came_from_string; } 682 if (len > 10) { /* Looks like we're on a 64 bit system. Make it a string so that if a 32 bit system reads the number it will cope better. */ 4 sv_catpvf(retval, "'%s'", tmpbuf); } else 678 sv_catpvn(retval, tmpbuf, len); } 932 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ 16 c = SvPV(val, i); 16 ++c; --i; /* just get the name */ 16 if (i >= 6 && strncmp(c, "main::", 6) == 0) { 16 c += 4; 16 i -= 4; } 16 if (needs_quote(c)) { ###### sv_grow(retval, SvCUR(retval)+6+2*i); ###### r = SvPVX(retval)+SvCUR(retval); ###### r[0] = '*'; r[1] = '{'; r[2] = '\''; ###### i += esc_q(r+3, c, i); ###### i += 3; ###### r[i++] = '\''; r[i++] = '}'; ###### r[i] = '\0'; } else { 16 sv_grow(retval, SvCUR(retval)+i+2); 16 r = SvPVX(retval)+SvCUR(retval); 16 r[0] = '*'; strcpy(r+1, c); 16 i++; } 16 SvCUR_set(retval, SvCUR(retval)+i); 16 if (purity) { 12 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; 12 static const STRLEN sizes[] = { 8, 7, 6 }; 12 SV *e; 12 SV *nname = newSVpvn("", 0); 12 SV *newapad = newSVpvn("", 0); 12 GV *gv = (GV*)val; 12 I32 j; 48 for (j=0; j<3; j++) { 36 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv)); 36 if (!e) 4 continue; 32 if (j == 0 && !SvOK(e)) ###### continue; { 32 I32 nlevel = 0; 32 SV *postentry = newSVpvn(r,i); 32 sv_setsv(nname, postentry); 32 sv_catpvn(nname, entries[j], sizes[j]); 32 sv_catpvn(postentry, " = ", 3); 32 av_push(postav, postentry); 32 e = newRV_inc(e); 32 SvCUR_set(newapad, 0); 32 if (indent >= 2) 6 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry)); 32 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry, seenhv, postav, &nlevel, indent, pad, xpad, newapad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, sortkeys); 32 SvREFCNT_dec(e); } } 12 SvREFCNT_dec(newapad); 12 SvREFCNT_dec(nname); } } 916 else if (val == &PL_sv_undef || !SvOK(val)) { 14 sv_catpvn(retval, "undef", 5); } else { integer_came_from_string: 982 c = SvPV(val, i); 982 if (DO_UTF8(val)) 8 i += esc_q_utf8(aTHX_ retval, c, i); else { 974 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */ 974 r = SvPVX(retval) + SvCUR(retval); 974 r[0] = '\''; 974 i += esc_q(r+1, c, i); 974 ++i; 974 r[i++] = '\''; 974 r[i] = '\0'; 974 SvCUR_set(retval, SvCUR(retval)+i); } } } 1932 if (idlen) { 1932 if (deepcopy) 26 (void)hv_delete(seenhv, id, idlen, G_DISCARD); 1906 else if (namelen && seenentry) { 1906 SV *mark = *av_fetch(seenentry, 2, TRUE); 1906 sv_setiv(mark,1); } } 1932 return 1; } MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_ # # This is the exact equivalent of Dump. Well, almost. The things that are # different as of now (due to Laziness): # * doesnt do double-quotes yet. # void Data_Dumper_Dumpxs(href, ...) SV *href; PROTOTYPE: $;$$ PPCODE: { 998 HV *hv; 998 SV *retval, *valstr; 998 HV *seenhv = Nullhv; 998 AV *postav, *todumpav, *namesav; 998 I32 level = 0; 998 I32 indent, terse, i, imax, postlen; 998 SV **svp; 998 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname; 998 SV *freezer, *toaster, *bless, *sortkeys; 998 I32 purity, deepcopy, quotekeys, maxdepth = 0; 998 char tmpbuf[1024]; 998 I32 gimme = GIMME; 998 if (!SvROK(href)) { /* call new to get an object first */ 921 if (items < 2) ###### croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])"); 921 ENTER; 921 SAVETMPS; 921 PUSHMARK(sp); 921 XPUSHs(href); 921 XPUSHs(sv_2mortal(newSVsv(ST(1)))); 921 if (items >= 3) 33 XPUSHs(sv_2mortal(newSVsv(ST(2)))); 921 PUTBACK; 921 i = perl_call_method("new", G_SCALAR); 921 SPAGAIN; 921 if (i) 921 href = newSVsv(POPs); 921 PUTBACK; 921 FREETMPS; 921 LEAVE; 921 if (i) 921 (void)sv_2mortal(href); } 998 todumpav = namesav = Nullav; 998 seenhv = Nullhv; 998 val = pad = xpad = apad = sep = pair = varname = freezer = toaster = bless = &PL_sv_undef; 998 name = sv_newmortal(); 998 indent = 2; 998 terse = purity = deepcopy = 0; 998 quotekeys = 1; 998 retval = newSVpvn("", 0); 998 if (SvROK(href) && (hv = (HV*)SvRV((SV*)href)) && SvTYPE(hv) == SVt_PVHV) { 998 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp)) 998 seenhv = (HV*)SvRV(*svp); 998 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp)) 998 todumpav = (AV*)SvRV(*svp); 998 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp)) 998 namesav = (AV*)SvRV(*svp); 998 if ((svp = hv_fetch(hv, "indent", 6, FALSE))) 998 indent = SvIV(*svp); 998 if ((svp = hv_fetch(hv, "purity", 6, FALSE))) 998 purity = SvIV(*svp); 998 if ((svp = hv_fetch(hv, "terse", 5, FALSE))) 998 terse = SvTRUE(*svp); #if 0 /* useqq currently unused */ if ((svp = hv_fetch(hv, "useqq", 5, FALSE))) useqq = SvTRUE(*svp); #endif 998 if ((svp = hv_fetch(hv, "pad", 3, FALSE))) 998 pad = *svp; 998 if ((svp = hv_fetch(hv, "xpad", 4, FALSE))) 998 xpad = *svp; 998 if ((svp = hv_fetch(hv, "apad", 4, FALSE))) 998 apad = *svp; 998 if ((svp = hv_fetch(hv, "sep", 3, FALSE))) 998 sep = *svp; 998 if ((svp = hv_fetch(hv, "pair", 4, FALSE))) 998 pair = *svp; 998 if ((svp = hv_fetch(hv, "varname", 7, FALSE))) 998 varname = *svp; 998 if ((svp = hv_fetch(hv, "freezer", 7, FALSE))) 998 freezer = *svp; 998 if ((svp = hv_fetch(hv, "toaster", 7, FALSE))) 998 toaster = *svp; 998 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE))) 998 deepcopy = SvTRUE(*svp); 998 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE))) 998 quotekeys = SvTRUE(*svp); 998 if ((svp = hv_fetch(hv, "bless", 5, FALSE))) 998 bless = *svp; 998 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) 998 maxdepth = SvIV(*svp); 998 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) { 998 sortkeys = *svp; 998 if (! SvTRUE(sortkeys)) 877 sortkeys = NULL; 121 else if (! (SvROK(sortkeys) && SvTYPE(SvRV(sortkeys)) == SVt_PVCV) ) { /* flag to use qsortsv() for sorting hash keys */ 117 sortkeys = &PL_sv_yes; } } 998 postav = newAV(); 998 if (todumpav) 998 imax = av_len(todumpav); else ###### imax = -1; 998 valstr = newSVpvn("",0); 2646 for (i = 0; i <= imax; ++i) { 1648 SV *newapad; 1648 av_clear(postav); 1648 if ((svp = av_fetch(todumpav, i, FALSE))) 1648 val = *svp; else ###### val = &PL_sv_undef; 1648 if ((svp = av_fetch(namesav, i, TRUE))) { 1648 sv_setsv(name, *svp); 1648 if (SvOK(*svp) && !SvPOK(*svp)) 2 (void)SvPV_nolen_const(name); } else ###### (void)SvOK_off(name); 1648 if (SvPOK(name)) { 147 if ((SvPVX_const(name))[0] == '*') { 70 if (SvROK(val)) { 70 switch (SvTYPE(SvRV(val))) { case SVt_PVAV: 24 (SvPVX(name))[0] = '@'; 24 break; case SVt_PVHV: 34 (SvPVX(name))[0] = '%'; 34 break; case SVt_PVCV: 2 (SvPVX(name))[0] = '*'; 2 break; default: 10 (SvPVX(name))[0] = '$'; 10 break; } } else ###### (SvPVX(name))[0] = '$'; } 77 else if ((SvPVX_const(name))[0] != '$') 77 sv_insert(name, 0, 0, "$", 1); } else { 1501 STRLEN nchars = 0; 1501 sv_setpvn(name, "$", 1); 1501 sv_catsv(name, varname); 1501 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1)); 1501 nchars = strlen(tmpbuf); 1501 sv_catpvn(name, tmpbuf, nchars); } 1648 if (indent >= 2) { 899 SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3); 899 newapad = newSVsv(apad); 899 sv_catsv(newapad, tmpsv); 899 SvREFCNT_dec(tmpsv); } else 749 newapad = apad; 1648 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); 1648 if (indent >= 2) 899 SvREFCNT_dec(newapad); 1648 postlen = av_len(postav); 1648 if (postlen >= 0 || !terse) { 1643 sv_insert(valstr, 0, 0, " = ", 3); 1643 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name)); 1643 sv_catpvn(valstr, ";", 1); } 1648 sv_catsv(retval, pad); 1648 sv_catsv(retval, valstr); 1648 sv_catsv(retval, sep); 1648 if (postlen >= 0) { 26 I32 i; 26 sv_catsv(retval, pad); 128 for (i = 0; i <= postlen; ++i) { 102 SV *elem; 102 svp = av_fetch(postav, i, FALSE); 102 if (svp && (elem = *svp)) { 102 sv_catsv(retval, elem); 102 if (i < postlen) { 76 sv_catpvn(retval, ";", 1); 76 sv_catsv(retval, sep); 76 sv_catsv(retval, pad); } } } 26 sv_catpvn(retval, ";", 1); 26 sv_catsv(retval, sep); } 1648 sv_setpvn(valstr, "", 0); 1648 if (gimme == G_ARRAY) { 1 XPUSHs(sv_2mortal(retval)); 1 if (i < imax) /* not the last time thro ? */ ###### retval = newSVpvn("",0); } } 998 SvREFCNT_dec(postav); 998 SvREFCNT_dec(valstr); } else ###### croak("Call to new() method failed to return HASH ref"); 998 if (gimme == G_SCALAR) 997 XPUSHs(sv_2mortal(retval)); }