1 #define PERL_NO_GET_CONTEXT
8 # define DD_USE_OLD_ID_FORMAT
11 static I32 num_q (const char *s, STRLEN slen);
12 static I32 esc_q (char *dest, const char *src, STRLEN slen);
13 static I32 esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen);
14 static I32 needs_quote(register const char *s);
15 static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
16 static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
17 HV *seenhv, AV *postav, I32 *levelp, I32 indent,
18 SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
19 SV *freezer, SV *toaster,
20 I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
21 I32 maxdepth, SV *sortkeys);
24 #define HvNAME_get HvNAME
27 #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
30 # define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
32 # define UNI_TO_NATIVE(ch) (ch)
36 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
38 const UV uv = utf8_to_uv(s, UTF8_MAXLEN, retlen,
39 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
40 return UNI_TO_NATIVE(uv);
43 # if !defined(PERL_IMPLICIT_CONTEXT)
44 # define utf8_to_uvchr Perl_utf8_to_uvchr
46 # define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
49 #endif /* PERL_VERSION <= 6 */
51 /* Changes in 5.7 series mean that now IOK is only set if scalar is
52 precisely integer but in 5.6 and earlier we need to do a more
55 #define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
57 #define DD_is_integer(sv) SvIOK(sv)
60 /* does a string need to be protected? */
62 needs_quote(register const char *s)
87 /* count the number of "'"s and "\"s in string */
89 num_q(register const char *s, register STRLEN slen)
94 if (*s == '\'' || *s == '\\')
103 /* returns number of chars added to escape "'"s and "\"s in s */
104 /* slen number of characters in s will be escaped */
105 /* destination must be long enough for additional chars */
107 esc_q(register char *d, register const char *s, register STRLEN slen)
109 register I32 ret = 0;
127 esc_q_utf8(pTHX_ SV* sv, register const char *src, register STRLEN slen)
131 const char * const send = src + slen;
132 STRLEN j, cur = SvCUR(sv);
133 /* Could count 128-255 and 256+ in two variables, if we want to
134 be like &qquote and make a distinction. */
135 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
136 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
137 STRLEN backslashes = 0;
138 STRLEN single_quotes = 0;
139 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
142 /* this will need EBCDICification */
143 for (s = src; s < send; s += UTF8SKIP(s)) {
144 const UV k = utf8_to_uvchr((U8*)s, NULL);
147 if (!isprint(k) || k > 256) {
151 /* 4: \x{} then count the number of hex digits. */
152 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
154 8 /* We may allocate a bit more than the minimum here. */
156 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
159 } else if (k == '\\') {
161 } else if (k == '\'') {
163 } else if (k == '"' || k == '$' || k == '@') {
170 /* We have something needing hex. 3 is ""\0 */
171 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
172 + 2*qq_escapables + normal);
173 rstart = r = SvPVX(sv) + cur;
177 for (s = src; s < send; s += UTF8SKIP(s)) {
178 const UV k = utf8_to_uvchr((U8*)s, NULL);
180 if (k == '"' || k == '\\' || k == '$' || k == '@') {
186 if (isprint(k) && k < 256)
192 r = r + my_sprintf(r, "\\x{%"UVxf"}", k);
198 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
199 + qq_escapables + normal);
200 rstart = r = SvPVX(sv) + cur;
202 for (s = src; s < send; s ++) {
204 if (k == '\'' || k == '\\')
212 SvCUR_set(sv, cur + j);
217 /* append a repeated string to an SV */
219 sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
222 sv = newSVpvn("", 0);
225 assert(SvTYPE(sv) >= SVt_PV);
229 SvGROW(sv, len*n + SvCUR(sv) + 1);
231 char * const start = SvPVX(sv) + SvCUR(sv);
232 SvCUR_set(sv, SvCUR(sv) + n);
239 sv_catpvn(sv, str, len);
247 * This ought to be split into smaller functions. (it is one long function since
248 * it exactly parallels the perl version, which was one long thing for
249 * efficiency raisins.) Ugggh!
252 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
253 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
254 SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
255 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
259 char *c, *r, *realpack;
260 #ifdef DD_USE_OLD_ID_FORMAT
264 char *const id = (char *)&id_buffer;
267 SV *sv, *ipad, *ival;
268 SV *blesspad = Nullsv;
269 AV *seenentry = NULL;
271 STRLEN inamelen, idlen = 0;
277 if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 40) {
278 sv_grow(retval, SvCUR(retval) * 1.5);
280 realtype = SvTYPE(val);
286 /* If a freeze method is provided and the object has it, call
287 it. Warn on errors. */
288 if (SvOBJECT(SvRV(val)) && freezer &&
289 SvPOK(freezer) && SvCUR(freezer) &&
290 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
291 SvCUR(freezer), -1) != NULL)
293 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
294 XPUSHs(val); PUTBACK;
295 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
298 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
299 PUTBACK; FREETMPS; LEAVE;
303 realtype = SvTYPE(ival);
304 #ifdef DD_USE_OLD_ID_FORMAT
305 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival));
307 id_buffer = PTR2UV(ival);
308 idlen = sizeof(id_buffer);
311 realpack = HvNAME_get(SvSTASH(ival));
315 /* if it has a name, we need to either look it up, or keep a tab
316 * on it so we know when we hit it later
319 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
320 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
323 if ((svp = av_fetch(seenentry, 0, FALSE))
324 && (othername = *svp))
326 if (purity && *levelp > 0) {
329 if (realtype == SVt_PVHV)
330 sv_catpvn(retval, "{}", 2);
331 else if (realtype == SVt_PVAV)
332 sv_catpvn(retval, "[]", 2);
334 sv_catpvn(retval, "do{my $o}", 9);
335 postentry = newSVpvn(name, namelen);
336 sv_catpvn(postentry, " = ", 3);
337 sv_catsv(postentry, othername);
338 av_push(postav, postentry);
341 if (name[0] == '@' || name[0] == '%') {
342 if ((SvPVX_const(othername))[0] == '\\' &&
343 (SvPVX_const(othername))[1] == name[0]) {
344 sv_catpvn(retval, SvPVX_const(othername)+1,
348 sv_catpvn(retval, name, 1);
349 sv_catpvn(retval, "{", 1);
350 sv_catsv(retval, othername);
351 sv_catpvn(retval, "}", 1);
355 sv_catsv(retval, othername);
360 #ifdef DD_USE_OLD_ID_FORMAT
361 warn("ref name not found for %s", id);
363 warn("ref name not found for 0x%"UVxf, PTR2UV(ival));
368 else { /* store our name and continue */
370 if (name[0] == '@' || name[0] == '%') {
371 namesv = newSVpvn("\\", 1);
372 sv_catpvn(namesv, name, namelen);
374 else if (realtype == SVt_PVCV && name[0] == '*') {
375 namesv = newSVpvn("\\", 2);
376 sv_catpvn(namesv, name, namelen);
377 (SvPVX(namesv))[1] = '&';
380 namesv = newSVpvn(name, namelen);
382 av_push(seenentry, namesv);
383 (void)SvREFCNT_inc(val);
384 av_push(seenentry, val);
385 (void)hv_store(seenhv, id, idlen,
386 newRV_inc((SV*)seenentry), 0);
387 SvREFCNT_dec(seenentry);
391 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
393 const char *rval = SvPV(val, rlen);
394 const char *slash = strchr(rval, '/');
395 sv_catpvn(retval, "qr/", 3);
397 sv_catpvn(retval, rval, slash-rval);
398 sv_catpvn(retval, "\\/", 2);
399 rlen -= slash-rval+1;
401 slash = strchr(rval, '/');
403 sv_catpvn(retval, rval, rlen);
404 sv_catpvn(retval, "/", 1);
408 /* If purity is not set and maxdepth is set, then check depth:
409 * if we have reached maximum depth, return the string
410 * representation of the thing we are currently examining
411 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
413 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
415 const char * const valstr = SvPV(val,vallen);
416 sv_catpvn(retval, "'", 1);
417 sv_catpvn(retval, valstr, vallen);
418 sv_catpvn(retval, "'", 1);
422 if (realpack) { /* we have a blessed ref */
424 const char * const blessstr = SvPV(bless, blesslen);
425 sv_catpvn(retval, blessstr, blesslen);
426 sv_catpvn(retval, "( ", 2);
429 apad = newSVsv(apad);
430 sv_x(aTHX_ apad, " ", 1, blesslen+2);
435 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
437 if (realtype <= SVt_PVBM) { /* scalar ref */
438 SV * const namesv = newSVpvn("${", 2);
439 sv_catpvn(namesv, name, namelen);
440 sv_catpvn(namesv, "}", 1);
441 if (realpack) { /* blessed */
442 sv_catpvn(retval, "do{\\(my $o = ", 13);
443 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
444 postav, levelp, indent, pad, xpad, apad, sep, pair,
445 freezer, toaster, purity, deepcopy, quotekeys, bless,
447 sv_catpvn(retval, ")}", 2);
450 sv_catpvn(retval, "\\", 1);
451 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
452 postav, levelp, indent, pad, xpad, apad, sep, pair,
453 freezer, toaster, purity, deepcopy, quotekeys, bless,
456 SvREFCNT_dec(namesv);
458 else if (realtype == SVt_PVGV) { /* glob ref */
459 SV * const namesv = newSVpvn("*{", 2);
460 sv_catpvn(namesv, name, namelen);
461 sv_catpvn(namesv, "}", 1);
462 sv_catpvn(retval, "\\", 1);
463 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
464 postav, levelp, indent, pad, xpad, apad, sep, pair,
465 freezer, toaster, purity, deepcopy, quotekeys, bless,
467 SvREFCNT_dec(namesv);
469 else if (realtype == SVt_PVAV) {
472 const I32 ixmax = av_len((AV *)ival);
474 SV * const ixsv = newSViv(0);
475 /* allowing for a 24 char wide array index */
476 New(0, iname, namelen+28, char);
477 (void)strcpy(iname, name);
479 if (name[0] == '@') {
480 sv_catpvn(retval, "(", 1);
484 sv_catpvn(retval, "[", 1);
485 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
487 && name[namelen-1] != ']' && name[namelen-1] != '}'
488 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
490 && name[namelen-1] != ']' && name[namelen-1] != '}')
493 || (name[0] == '\\' && name[2] == '{'))))
495 iname[inamelen++] = '-'; iname[inamelen++] = '>';
496 iname[inamelen] = '\0';
499 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
500 (instr(iname+inamelen-8, "{SCALAR}") ||
501 instr(iname+inamelen-7, "{ARRAY}") ||
502 instr(iname+inamelen-6, "{HASH}"))) {
503 iname[inamelen++] = '-'; iname[inamelen++] = '>';
505 iname[inamelen++] = '['; iname[inamelen] = '\0';
506 totpad = newSVsv(sep);
507 sv_catsv(totpad, pad);
508 sv_catsv(totpad, apad);
510 for (ix = 0; ix <= ixmax; ++ix) {
513 svp = av_fetch((AV*)ival, ix, FALSE);
521 ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
522 iname[ilen++] = ']'; iname[ilen] = '\0';
524 sv_catsv(retval, totpad);
525 sv_catsv(retval, ipad);
526 sv_catpvn(retval, "#", 1);
527 sv_catsv(retval, ixsv);
529 sv_catsv(retval, totpad);
530 sv_catsv(retval, ipad);
531 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
532 levelp, indent, pad, xpad, apad, sep, pair,
533 freezer, toaster, purity, deepcopy, quotekeys, bless,
536 sv_catpvn(retval, ",", 1);
539 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
540 sv_catsv(retval, totpad);
541 sv_catsv(retval, opad);
545 sv_catpvn(retval, ")", 1);
547 sv_catpvn(retval, "]", 1);
549 SvREFCNT_dec(totpad);
552 else if (realtype == SVt_PVHV) {
553 SV *totpad, *newapad;
561 SV * const iname = newSVpvn(name, namelen);
562 if (name[0] == '%') {
563 sv_catpvn(retval, "(", 1);
564 (SvPVX(iname))[0] = '$';
567 sv_catpvn(retval, "{", 1);
568 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
570 && name[namelen-1] != ']' && name[namelen-1] != '}')
573 || (name[0] == '\\' && name[2] == '{'))))
575 sv_catpvn(iname, "->", 2);
578 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
579 (instr(name+namelen-8, "{SCALAR}") ||
580 instr(name+namelen-7, "{ARRAY}") ||
581 instr(name+namelen-6, "{HASH}"))) {
582 sv_catpvn(iname, "->", 2);
584 sv_catpvn(iname, "{", 1);
585 totpad = newSVsv(sep);
586 sv_catsv(totpad, pad);
587 sv_catsv(totpad, apad);
589 /* If requested, get a sorted/filtered array of hash keys */
591 if (sortkeys == &PL_sv_yes) {
593 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
596 (void)hv_iterinit((HV*)ival);
597 while ((entry = hv_iternext((HV*)ival))) {
598 sv = hv_iterkeysv(entry);
602 # ifdef USE_LOCALE_NUMERIC
603 sortsv(AvARRAY(keys),
605 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
607 sortsv(AvARRAY(keys),
613 if (sortkeys != &PL_sv_yes) {
614 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
615 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
616 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
620 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
621 keys = (AV*)SvREFCNT_inc(SvRV(sv));
624 warn("Sortkeys subroutine did not return ARRAYREF\n");
625 PUTBACK; FREETMPS; LEAVE;
628 sv_2mortal((SV*)keys);
631 (void)hv_iterinit((HV*)ival);
633 /* foreach (keys %hash) */
634 for (i = 0; 1; i++) {
636 char *nkey_buffer = NULL;
641 bool do_utf8 = FALSE;
644 if (!(keys && (I32)i <= av_len(keys))) break;
646 if (!(entry = hv_iternext((HV *)ival))) break;
650 sv_catpvn(retval, ",", 1);
654 svp = av_fetch(keys, i, FALSE);
655 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
656 key = SvPV(keysv, keylen);
657 svp = hv_fetch((HV*)ival, key,
658 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
659 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
662 keysv = hv_iterkeysv(entry);
663 hval = hv_iterval((HV*)ival, entry);
666 key = SvPV(keysv, keylen);
667 do_utf8 = DO_UTF8(keysv);
670 sv_catsv(retval, totpad);
671 sv_catsv(retval, ipad);
672 /* old logic was first to check utf8 flag, and if utf8 always
673 call esc_q_utf8. This caused test to break under -Mutf8,
674 because there even strings like 'c' have utf8 flag on.
675 Hence with quotekeys == 0 the XS code would still '' quote
676 them based on flags, whereas the perl code would not,
678 The perl code is correct.
679 needs_quote() decides that anything that isn't a valid
680 perl identifier needs to be quoted, hence only correctly
681 formed strings with no characters outside [A-Za-z0-9_:]
682 won't need quoting. None of those characters are used in
683 the byte encoding of utf8, so anything with utf8
684 encoded characters in will need quoting. Hence strings
685 with utf8 encoded characters in will end up inside do_utf8
686 just like before, but now strings with utf8 flag set but
687 only ascii characters will end up in the unquoted section.
689 There should also be less tests for the (probably currently)
690 more common doesn't need quoting case.
691 The code is also smaller (22044 vs 22260) because I've been
692 able to pull the common logic out to both sides. */
693 if (quotekeys || needs_quote(key)) {
695 STRLEN ocur = SvCUR(retval);
696 nlen = esc_q_utf8(aTHX_ retval, key, klen);
697 nkey = SvPVX(retval) + ocur;
700 nticks = num_q(key, klen);
701 New(0, nkey_buffer, klen+nticks+3, char);
705 klen += esc_q(nkey+1, key, klen);
707 (void)Copy(key, nkey+1, klen, char);
711 sv_catpvn(retval, nkey, klen);
717 sv_catpvn(retval, nkey, klen);
719 sname = newSVsv(iname);
720 sv_catpvn(sname, nkey, nlen);
721 sv_catpvn(sname, "}", 1);
723 sv_catsv(retval, pair);
727 newapad = newSVsv(apad);
728 New(0, extra, klen+4+1, char);
729 while (elen < (klen+4))
732 sv_catpvn(newapad, extra, elen);
738 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
739 postav, levelp, indent, pad, xpad, newapad, sep, pair,
740 freezer, toaster, purity, deepcopy, quotekeys, bless,
743 Safefree(nkey_buffer);
745 SvREFCNT_dec(newapad);
748 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
749 sv_catsv(retval, totpad);
750 sv_catsv(retval, opad);
754 sv_catpvn(retval, ")", 1);
756 sv_catpvn(retval, "}", 1);
758 SvREFCNT_dec(totpad);
760 else if (realtype == SVt_PVCV) {
761 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
763 warn("Encountered CODE ref, using dummy placeholder");
766 warn("cannot handle ref type %ld", realtype);
769 if (realpack) { /* free blessed allocs */
774 sv_catpvn(retval, ", '", 3);
775 sv_catpvn(retval, realpack, strlen(realpack));
776 sv_catpvn(retval, "' )", 3);
777 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
778 sv_catpvn(retval, "->", 2);
779 sv_catsv(retval, toaster);
780 sv_catpvn(retval, "()", 2);
790 #ifdef DD_USE_OLD_ID_FORMAT
791 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
793 id_buffer = PTR2UV(val);
794 idlen = sizeof(id_buffer);
796 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
797 (sv = *svp) && SvROK(sv) &&
798 (seenentry = (AV*)SvRV(sv)))
801 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
802 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
804 sv_catpvn(retval, "${", 2);
805 sv_catsv(retval, othername);
806 sv_catpvn(retval, "}", 1);
810 else if (val != &PL_sv_undef) {
811 SV * const namesv = newSVpvn("\\", 1);
812 sv_catpvn(namesv, name, namelen);
814 av_push(seenentry, namesv);
815 av_push(seenentry, newRV_inc(val));
816 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
817 SvREFCNT_dec(seenentry);
821 if (DD_is_integer(val)) {
824 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
826 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
828 /* Need to check to see if this is a string such as " 0".
829 I'm assuming from sprintf isn't going to clash with utf8.
830 Is this valid on EBCDIC? */
832 const char * const pv = SvPV(val, pvlen);
833 if (pvlen != len || memNE(pv, tmpbuf, len))
834 goto integer_came_from_string;
837 /* Looks like we're on a 64 bit system. Make it a string so that
838 if a 32 bit system reads the number it will cope better. */
839 sv_catpvf(retval, "'%s'", tmpbuf);
841 sv_catpvn(retval, tmpbuf, len);
843 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
845 ++c; --i; /* just get the name */
846 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
850 if (needs_quote(c)) {
851 sv_grow(retval, SvCUR(retval)+6+2*i);
852 r = SvPVX(retval)+SvCUR(retval);
853 r[0] = '*'; r[1] = '{'; r[2] = '\'';
854 i += esc_q(r+3, c, i);
856 r[i++] = '\''; r[i++] = '}';
860 sv_grow(retval, SvCUR(retval)+i+2);
861 r = SvPVX(retval)+SvCUR(retval);
862 r[0] = '*'; strcpy(r+1, c);
865 SvCUR_set(retval, SvCUR(retval)+i);
868 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
869 static const STRLEN sizes[] = { 8, 7, 6 };
871 SV * const nname = newSVpvn("", 0);
872 SV * const newapad = newSVpvn("", 0);
873 GV * const gv = (GV*)val;
876 for (j=0; j<3; j++) {
877 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
880 if (j == 0 && !SvOK(e))
885 SV *postentry = newSVpvn(r,i);
887 sv_setsv(nname, postentry);
888 sv_catpvn(nname, entries[j], sizes[j]);
889 sv_catpvn(postentry, " = ", 3);
890 av_push(postav, postentry);
893 SvCUR_set(newapad, 0);
895 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
897 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
898 seenhv, postav, &nlevel, indent, pad, xpad,
899 newapad, sep, pair, freezer, toaster, purity,
900 deepcopy, quotekeys, bless, maxdepth,
906 SvREFCNT_dec(newapad);
910 else if (val == &PL_sv_undef || !SvOK(val)) {
911 sv_catpvn(retval, "undef", 5);
914 integer_came_from_string:
917 i += esc_q_utf8(aTHX_ retval, c, i);
919 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
920 r = SvPVX(retval) + SvCUR(retval);
922 i += esc_q(r+1, c, i);
926 SvCUR_set(retval, SvCUR(retval)+i);
933 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
934 else if (namelen && seenentry) {
935 SV *mark = *av_fetch(seenentry, 2, TRUE);
943 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
946 # This is the exact equivalent of Dump. Well, almost. The things that are
947 # different as of now (due to Laziness):
948 # * doesnt do double-quotes yet.
952 Data_Dumper_Dumpxs(href, ...)
960 AV *postav, *todumpav, *namesav;
962 I32 indent, terse, i, imax, postlen;
964 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
965 SV *freezer, *toaster, *bless, *sortkeys;
966 I32 purity, deepcopy, quotekeys, maxdepth = 0;
970 if (!SvROK(href)) { /* call new to get an object first */
972 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
979 XPUSHs(sv_2mortal(newSVsv(ST(1))));
981 XPUSHs(sv_2mortal(newSVsv(ST(2))));
983 i = perl_call_method("new", G_SCALAR);
986 href = newSVsv(POPs);
992 (void)sv_2mortal(href);
995 todumpav = namesav = NULL;
997 val = pad = xpad = apad = sep = pair = varname
998 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
999 name = sv_newmortal();
1001 terse = purity = deepcopy = 0;
1004 retval = newSVpvn("", 0);
1006 && (hv = (HV*)SvRV((SV*)href))
1007 && SvTYPE(hv) == SVt_PVHV) {
1009 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1010 seenhv = (HV*)SvRV(*svp);
1011 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1012 todumpav = (AV*)SvRV(*svp);
1013 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1014 namesav = (AV*)SvRV(*svp);
1015 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1016 indent = SvIV(*svp);
1017 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1018 purity = SvIV(*svp);
1019 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1020 terse = SvTRUE(*svp);
1021 #if 0 /* useqq currently unused */
1022 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1023 useqq = SvTRUE(*svp);
1025 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1027 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1029 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1031 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1033 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1035 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1037 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1039 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1041 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1042 deepcopy = SvTRUE(*svp);
1043 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1044 quotekeys = SvTRUE(*svp);
1045 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1047 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1048 maxdepth = SvIV(*svp);
1049 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1051 if (! SvTRUE(sortkeys))
1053 else if (! (SvROK(sortkeys) &&
1054 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1056 /* flag to use qsortsv() for sorting hash keys */
1057 sortkeys = &PL_sv_yes;
1063 imax = av_len(todumpav);
1066 valstr = newSVpvn("",0);
1067 for (i = 0; i <= imax; ++i) {
1071 if ((svp = av_fetch(todumpav, i, FALSE)))
1075 if ((svp = av_fetch(namesav, i, TRUE))) {
1076 sv_setsv(name, *svp);
1077 if (SvOK(*svp) && !SvPOK(*svp))
1078 (void)SvPV_nolen_const(name);
1081 (void)SvOK_off(name);
1084 if ((SvPVX_const(name))[0] == '*') {
1086 switch (SvTYPE(SvRV(val))) {
1088 (SvPVX(name))[0] = '@';
1091 (SvPVX(name))[0] = '%';
1094 (SvPVX(name))[0] = '*';
1097 (SvPVX(name))[0] = '$';
1102 (SvPVX(name))[0] = '$';
1104 else if ((SvPVX_const(name))[0] != '$')
1105 sv_insert(name, 0, 0, "$", 1);
1109 sv_setpvn(name, "$", 1);
1110 sv_catsv(name, varname);
1111 nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
1112 sv_catpvn(name, tmpbuf, nchars);
1116 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1117 newapad = newSVsv(apad);
1118 sv_catsv(newapad, tmpsv);
1119 SvREFCNT_dec(tmpsv);
1124 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1125 postav, &level, indent, pad, xpad, newapad, sep, pair,
1126 freezer, toaster, purity, deepcopy, quotekeys,
1127 bless, maxdepth, sortkeys);
1130 SvREFCNT_dec(newapad);
1132 postlen = av_len(postav);
1133 if (postlen >= 0 || !terse) {
1134 sv_insert(valstr, 0, 0, " = ", 3);
1135 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1136 sv_catpvn(valstr, ";", 1);
1138 sv_catsv(retval, pad);
1139 sv_catsv(retval, valstr);
1140 sv_catsv(retval, sep);
1143 sv_catsv(retval, pad);
1144 for (i = 0; i <= postlen; ++i) {
1146 svp = av_fetch(postav, i, FALSE);
1147 if (svp && (elem = *svp)) {
1148 sv_catsv(retval, elem);
1150 sv_catpvn(retval, ";", 1);
1151 sv_catsv(retval, sep);
1152 sv_catsv(retval, pad);
1156 sv_catpvn(retval, ";", 1);
1157 sv_catsv(retval, sep);
1159 sv_setpvn(valstr, "", 0);
1160 if (gimme == G_ARRAY) {
1161 XPUSHs(sv_2mortal(retval));
1162 if (i < imax) /* not the last time thro ? */
1163 retval = newSVpvn("",0);
1166 SvREFCNT_dec(postav);
1167 SvREFCNT_dec(valstr);
1170 croak("Call to new() method failed to return HASH ref");
1171 if (gimme == G_SCALAR)
1172 XPUSHs(sv_2mortal(retval));