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 realtype = SvTYPE(val);
283 /* If a freeze method is provided and the object has it, call
284 it. Warn on errors. */
285 if (SvOBJECT(SvRV(val)) && freezer &&
286 SvPOK(freezer) && SvCUR(freezer) &&
287 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
288 SvCUR(freezer), -1) != NULL)
290 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
291 XPUSHs(val); PUTBACK;
292 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
295 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
296 PUTBACK; FREETMPS; LEAVE;
300 realtype = SvTYPE(ival);
301 #ifdef DD_USE_OLD_ID_FORMAT
302 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival));
304 id_buffer = PTR2UV(ival);
305 idlen = sizeof(id_buffer);
308 realpack = HvNAME_get(SvSTASH(ival));
312 /* if it has a name, we need to either look it up, or keep a tab
313 * on it so we know when we hit it later
316 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
317 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
320 if ((svp = av_fetch(seenentry, 0, FALSE))
321 && (othername = *svp))
323 if (purity && *levelp > 0) {
326 if (realtype == SVt_PVHV)
327 sv_catpvn(retval, "{}", 2);
328 else if (realtype == SVt_PVAV)
329 sv_catpvn(retval, "[]", 2);
331 sv_catpvn(retval, "do{my $o}", 9);
332 postentry = newSVpvn(name, namelen);
333 sv_catpvn(postentry, " = ", 3);
334 sv_catsv(postentry, othername);
335 av_push(postav, postentry);
338 if (name[0] == '@' || name[0] == '%') {
339 if ((SvPVX_const(othername))[0] == '\\' &&
340 (SvPVX_const(othername))[1] == name[0]) {
341 sv_catpvn(retval, SvPVX_const(othername)+1,
345 sv_catpvn(retval, name, 1);
346 sv_catpvn(retval, "{", 1);
347 sv_catsv(retval, othername);
348 sv_catpvn(retval, "}", 1);
352 sv_catsv(retval, othername);
357 #ifdef DD_USE_OLD_ID_FORMAT
358 warn("ref name not found for %s", id);
360 warn("ref name not found for 0x%"UVxf, PTR2UV(ival));
365 else { /* store our name and continue */
367 if (name[0] == '@' || name[0] == '%') {
368 namesv = newSVpvn("\\", 1);
369 sv_catpvn(namesv, name, namelen);
371 else if (realtype == SVt_PVCV && name[0] == '*') {
372 namesv = newSVpvn("\\", 2);
373 sv_catpvn(namesv, name, namelen);
374 (SvPVX(namesv))[1] = '&';
377 namesv = newSVpvn(name, namelen);
379 av_push(seenentry, namesv);
380 (void)SvREFCNT_inc(val);
381 av_push(seenentry, val);
382 (void)hv_store(seenhv, id, idlen,
383 newRV_inc((SV*)seenentry), 0);
384 SvREFCNT_dec(seenentry);
388 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
390 const char *rval = SvPV(val, rlen);
391 const char *slash = strchr(rval, '/');
392 sv_catpvn(retval, "qr/", 3);
394 sv_catpvn(retval, rval, slash-rval);
395 sv_catpvn(retval, "\\/", 2);
396 rlen -= slash-rval+1;
398 slash = strchr(rval, '/');
400 sv_catpvn(retval, rval, rlen);
401 sv_catpvn(retval, "/", 1);
405 /* If purity is not set and maxdepth is set, then check depth:
406 * if we have reached maximum depth, return the string
407 * representation of the thing we are currently examining
408 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
410 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
412 const char * const valstr = SvPV(val,vallen);
413 sv_catpvn(retval, "'", 1);
414 sv_catpvn(retval, valstr, vallen);
415 sv_catpvn(retval, "'", 1);
419 if (realpack) { /* we have a blessed ref */
421 const char * const blessstr = SvPV(bless, blesslen);
422 sv_catpvn(retval, blessstr, blesslen);
423 sv_catpvn(retval, "( ", 2);
426 apad = newSVsv(apad);
427 sv_x(aTHX_ apad, " ", 1, blesslen+2);
432 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
434 if (realtype <= SVt_PVBM) { /* scalar ref */
435 SV * const namesv = newSVpvn("${", 2);
436 sv_catpvn(namesv, name, namelen);
437 sv_catpvn(namesv, "}", 1);
438 if (realpack) { /* blessed */
439 sv_catpvn(retval, "do{\\(my $o = ", 13);
440 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
441 postav, levelp, indent, pad, xpad, apad, sep, pair,
442 freezer, toaster, purity, deepcopy, quotekeys, bless,
444 sv_catpvn(retval, ")}", 2);
447 sv_catpvn(retval, "\\", 1);
448 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
449 postav, levelp, indent, pad, xpad, apad, sep, pair,
450 freezer, toaster, purity, deepcopy, quotekeys, bless,
453 SvREFCNT_dec(namesv);
455 else if (realtype == SVt_PVGV) { /* glob ref */
456 SV * const namesv = newSVpvn("*{", 2);
457 sv_catpvn(namesv, name, namelen);
458 sv_catpvn(namesv, "}", 1);
459 sv_catpvn(retval, "\\", 1);
460 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
461 postav, levelp, indent, pad, xpad, apad, sep, pair,
462 freezer, toaster, purity, deepcopy, quotekeys, bless,
464 SvREFCNT_dec(namesv);
466 else if (realtype == SVt_PVAV) {
469 const I32 ixmax = av_len((AV *)ival);
471 SV * const ixsv = newSViv(0);
472 /* allowing for a 24 char wide array index */
473 New(0, iname, namelen+28, char);
474 (void)strcpy(iname, name);
476 if (name[0] == '@') {
477 sv_catpvn(retval, "(", 1);
481 sv_catpvn(retval, "[", 1);
482 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
484 && name[namelen-1] != ']' && name[namelen-1] != '}'
485 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
487 && name[namelen-1] != ']' && name[namelen-1] != '}')
490 || (name[0] == '\\' && name[2] == '{'))))
492 iname[inamelen++] = '-'; iname[inamelen++] = '>';
493 iname[inamelen] = '\0';
496 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
497 (instr(iname+inamelen-8, "{SCALAR}") ||
498 instr(iname+inamelen-7, "{ARRAY}") ||
499 instr(iname+inamelen-6, "{HASH}"))) {
500 iname[inamelen++] = '-'; iname[inamelen++] = '>';
502 iname[inamelen++] = '['; iname[inamelen] = '\0';
503 totpad = newSVsv(sep);
504 sv_catsv(totpad, pad);
505 sv_catsv(totpad, apad);
507 for (ix = 0; ix <= ixmax; ++ix) {
510 svp = av_fetch((AV*)ival, ix, FALSE);
518 ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
519 iname[ilen++] = ']'; iname[ilen] = '\0';
521 sv_catsv(retval, totpad);
522 sv_catsv(retval, ipad);
523 sv_catpvn(retval, "#", 1);
524 sv_catsv(retval, ixsv);
526 sv_catsv(retval, totpad);
527 sv_catsv(retval, ipad);
528 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
529 levelp, indent, pad, xpad, apad, sep, pair,
530 freezer, toaster, purity, deepcopy, quotekeys, bless,
533 sv_catpvn(retval, ",", 1);
536 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
537 sv_catsv(retval, totpad);
538 sv_catsv(retval, opad);
542 sv_catpvn(retval, ")", 1);
544 sv_catpvn(retval, "]", 1);
546 SvREFCNT_dec(totpad);
549 else if (realtype == SVt_PVHV) {
550 SV *totpad, *newapad;
558 SV * const iname = newSVpvn(name, namelen);
559 if (name[0] == '%') {
560 sv_catpvn(retval, "(", 1);
561 (SvPVX(iname))[0] = '$';
564 sv_catpvn(retval, "{", 1);
565 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
567 && name[namelen-1] != ']' && name[namelen-1] != '}')
570 || (name[0] == '\\' && name[2] == '{'))))
572 sv_catpvn(iname, "->", 2);
575 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
576 (instr(name+namelen-8, "{SCALAR}") ||
577 instr(name+namelen-7, "{ARRAY}") ||
578 instr(name+namelen-6, "{HASH}"))) {
579 sv_catpvn(iname, "->", 2);
581 sv_catpvn(iname, "{", 1);
582 totpad = newSVsv(sep);
583 sv_catsv(totpad, pad);
584 sv_catsv(totpad, apad);
586 /* If requested, get a sorted/filtered array of hash keys */
588 if (sortkeys == &PL_sv_yes) {
590 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
593 (void)hv_iterinit((HV*)ival);
594 while ((entry = hv_iternext((HV*)ival))) {
595 sv = hv_iterkeysv(entry);
599 # ifdef USE_LOCALE_NUMERIC
600 sortsv(AvARRAY(keys),
602 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
604 sortsv(AvARRAY(keys),
610 if (sortkeys != &PL_sv_yes) {
611 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
612 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
613 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
617 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
618 keys = (AV*)SvREFCNT_inc(SvRV(sv));
621 warn("Sortkeys subroutine did not return ARRAYREF\n");
622 PUTBACK; FREETMPS; LEAVE;
625 sv_2mortal((SV*)keys);
628 (void)hv_iterinit((HV*)ival);
630 /* foreach (keys %hash) */
631 for (i = 0; 1; i++) {
633 char *nkey_buffer = NULL;
638 bool do_utf8 = FALSE;
641 if (!(keys && (I32)i <= av_len(keys))) break;
643 if (!(entry = hv_iternext((HV *)ival))) break;
647 sv_catpvn(retval, ",", 1);
651 svp = av_fetch(keys, i, FALSE);
652 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
653 key = SvPV(keysv, keylen);
654 svp = hv_fetch((HV*)ival, key,
655 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
656 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
659 keysv = hv_iterkeysv(entry);
660 hval = hv_iterval((HV*)ival, entry);
663 key = SvPV(keysv, keylen);
664 do_utf8 = DO_UTF8(keysv);
667 sv_catsv(retval, totpad);
668 sv_catsv(retval, ipad);
669 /* old logic was first to check utf8 flag, and if utf8 always
670 call esc_q_utf8. This caused test to break under -Mutf8,
671 because there even strings like 'c' have utf8 flag on.
672 Hence with quotekeys == 0 the XS code would still '' quote
673 them based on flags, whereas the perl code would not,
675 The perl code is correct.
676 needs_quote() decides that anything that isn't a valid
677 perl identifier needs to be quoted, hence only correctly
678 formed strings with no characters outside [A-Za-z0-9_:]
679 won't need quoting. None of those characters are used in
680 the byte encoding of utf8, so anything with utf8
681 encoded characters in will need quoting. Hence strings
682 with utf8 encoded characters in will end up inside do_utf8
683 just like before, but now strings with utf8 flag set but
684 only ascii characters will end up in the unquoted section.
686 There should also be less tests for the (probably currently)
687 more common doesn't need quoting case.
688 The code is also smaller (22044 vs 22260) because I've been
689 able to pull the common logic out to both sides. */
690 if (quotekeys || needs_quote(key)) {
692 STRLEN ocur = SvCUR(retval);
693 nlen = esc_q_utf8(aTHX_ retval, key, klen);
694 nkey = SvPVX(retval) + ocur;
697 nticks = num_q(key, klen);
698 New(0, nkey_buffer, klen+nticks+3, char);
702 klen += esc_q(nkey+1, key, klen);
704 (void)Copy(key, nkey+1, klen, char);
708 sv_catpvn(retval, nkey, klen);
714 sv_catpvn(retval, nkey, klen);
716 sname = newSVsv(iname);
717 sv_catpvn(sname, nkey, nlen);
718 sv_catpvn(sname, "}", 1);
720 sv_catsv(retval, pair);
724 newapad = newSVsv(apad);
725 New(0, extra, klen+4+1, char);
726 while (elen < (klen+4))
729 sv_catpvn(newapad, extra, elen);
735 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
736 postav, levelp, indent, pad, xpad, newapad, sep, pair,
737 freezer, toaster, purity, deepcopy, quotekeys, bless,
740 Safefree(nkey_buffer);
742 SvREFCNT_dec(newapad);
745 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
746 sv_catsv(retval, totpad);
747 sv_catsv(retval, opad);
751 sv_catpvn(retval, ")", 1);
753 sv_catpvn(retval, "}", 1);
755 SvREFCNT_dec(totpad);
757 else if (realtype == SVt_PVCV) {
758 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
760 warn("Encountered CODE ref, using dummy placeholder");
763 warn("cannot handle ref type %ld", realtype);
766 if (realpack) { /* free blessed allocs */
771 sv_catpvn(retval, ", '", 3);
772 sv_catpvn(retval, realpack, strlen(realpack));
773 sv_catpvn(retval, "' )", 3);
774 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
775 sv_catpvn(retval, "->", 2);
776 sv_catsv(retval, toaster);
777 sv_catpvn(retval, "()", 2);
787 #ifdef DD_USE_OLD_ID_FORMAT
788 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
790 id_buffer = PTR2UV(val);
791 idlen = sizeof(id_buffer);
793 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
794 (sv = *svp) && SvROK(sv) &&
795 (seenentry = (AV*)SvRV(sv)))
798 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
799 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
801 sv_catpvn(retval, "${", 2);
802 sv_catsv(retval, othername);
803 sv_catpvn(retval, "}", 1);
807 else if (val != &PL_sv_undef) {
808 SV * const namesv = newSVpvn("\\", 1);
809 sv_catpvn(namesv, name, namelen);
811 av_push(seenentry, namesv);
812 av_push(seenentry, newRV_inc(val));
813 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
814 SvREFCNT_dec(seenentry);
818 if (DD_is_integer(val)) {
821 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
823 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
825 /* Need to check to see if this is a string such as " 0".
826 I'm assuming from sprintf isn't going to clash with utf8.
827 Is this valid on EBCDIC? */
829 const char * const pv = SvPV(val, pvlen);
830 if (pvlen != len || memNE(pv, tmpbuf, len))
831 goto integer_came_from_string;
834 /* Looks like we're on a 64 bit system. Make it a string so that
835 if a 32 bit system reads the number it will cope better. */
836 sv_catpvf(retval, "'%s'", tmpbuf);
838 sv_catpvn(retval, tmpbuf, len);
840 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
842 ++c; --i; /* just get the name */
843 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
847 if (needs_quote(c)) {
848 sv_grow(retval, SvCUR(retval)+6+2*i);
849 r = SvPVX(retval)+SvCUR(retval);
850 r[0] = '*'; r[1] = '{'; r[2] = '\'';
851 i += esc_q(r+3, c, i);
853 r[i++] = '\''; r[i++] = '}';
857 sv_grow(retval, SvCUR(retval)+i+2);
858 r = SvPVX(retval)+SvCUR(retval);
859 r[0] = '*'; strcpy(r+1, c);
862 SvCUR_set(retval, SvCUR(retval)+i);
865 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
866 static const STRLEN sizes[] = { 8, 7, 6 };
868 SV * const nname = newSVpvn("", 0);
869 SV * const newapad = newSVpvn("", 0);
870 GV * const gv = (GV*)val;
873 for (j=0; j<3; j++) {
874 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
877 if (j == 0 && !SvOK(e))
882 SV *postentry = newSVpvn(r,i);
884 sv_setsv(nname, postentry);
885 sv_catpvn(nname, entries[j], sizes[j]);
886 sv_catpvn(postentry, " = ", 3);
887 av_push(postav, postentry);
890 SvCUR_set(newapad, 0);
892 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
894 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
895 seenhv, postav, &nlevel, indent, pad, xpad,
896 newapad, sep, pair, freezer, toaster, purity,
897 deepcopy, quotekeys, bless, maxdepth,
903 SvREFCNT_dec(newapad);
907 else if (val == &PL_sv_undef || !SvOK(val)) {
908 sv_catpvn(retval, "undef", 5);
911 integer_came_from_string:
914 i += esc_q_utf8(aTHX_ retval, c, i);
916 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
917 r = SvPVX(retval) + SvCUR(retval);
919 i += esc_q(r+1, c, i);
923 SvCUR_set(retval, SvCUR(retval)+i);
930 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
931 else if (namelen && seenentry) {
932 SV *mark = *av_fetch(seenentry, 2, TRUE);
940 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
943 # This is the exact equivalent of Dump. Well, almost. The things that are
944 # different as of now (due to Laziness):
945 # * doesnt do double-quotes yet.
949 Data_Dumper_Dumpxs(href, ...)
957 AV *postav, *todumpav, *namesav;
959 I32 indent, terse, i, imax, postlen;
961 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
962 SV *freezer, *toaster, *bless, *sortkeys;
963 I32 purity, deepcopy, quotekeys, maxdepth = 0;
967 if (!SvROK(href)) { /* call new to get an object first */
969 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
976 XPUSHs(sv_2mortal(newSVsv(ST(1))));
978 XPUSHs(sv_2mortal(newSVsv(ST(2))));
980 i = perl_call_method("new", G_SCALAR);
983 href = newSVsv(POPs);
989 (void)sv_2mortal(href);
992 todumpav = namesav = NULL;
994 val = pad = xpad = apad = sep = pair = varname
995 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
996 name = sv_newmortal();
998 terse = purity = deepcopy = 0;
1001 retval = newSVpvn("", 0);
1003 && (hv = (HV*)SvRV((SV*)href))
1004 && SvTYPE(hv) == SVt_PVHV) {
1006 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1007 seenhv = (HV*)SvRV(*svp);
1008 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1009 todumpav = (AV*)SvRV(*svp);
1010 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1011 namesav = (AV*)SvRV(*svp);
1012 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1013 indent = SvIV(*svp);
1014 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1015 purity = SvIV(*svp);
1016 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1017 terse = SvTRUE(*svp);
1018 #if 0 /* useqq currently unused */
1019 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1020 useqq = SvTRUE(*svp);
1022 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1024 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1026 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1028 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1030 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1032 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1034 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1036 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1038 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1039 deepcopy = SvTRUE(*svp);
1040 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1041 quotekeys = SvTRUE(*svp);
1042 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1044 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1045 maxdepth = SvIV(*svp);
1046 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1048 if (! SvTRUE(sortkeys))
1050 else if (! (SvROK(sortkeys) &&
1051 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1053 /* flag to use qsortsv() for sorting hash keys */
1054 sortkeys = &PL_sv_yes;
1060 imax = av_len(todumpav);
1063 valstr = newSVpvn("",0);
1064 for (i = 0; i <= imax; ++i) {
1068 if ((svp = av_fetch(todumpav, i, FALSE)))
1072 if ((svp = av_fetch(namesav, i, TRUE))) {
1073 sv_setsv(name, *svp);
1074 if (SvOK(*svp) && !SvPOK(*svp))
1075 (void)SvPV_nolen_const(name);
1078 (void)SvOK_off(name);
1081 if ((SvPVX_const(name))[0] == '*') {
1083 switch (SvTYPE(SvRV(val))) {
1085 (SvPVX(name))[0] = '@';
1088 (SvPVX(name))[0] = '%';
1091 (SvPVX(name))[0] = '*';
1094 (SvPVX(name))[0] = '$';
1099 (SvPVX(name))[0] = '$';
1101 else if ((SvPVX_const(name))[0] != '$')
1102 sv_insert(name, 0, 0, "$", 1);
1106 sv_setpvn(name, "$", 1);
1107 sv_catsv(name, varname);
1108 nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
1109 sv_catpvn(name, tmpbuf, nchars);
1113 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1114 newapad = newSVsv(apad);
1115 sv_catsv(newapad, tmpsv);
1116 SvREFCNT_dec(tmpsv);
1121 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1122 postav, &level, indent, pad, xpad, newapad, sep, pair,
1123 freezer, toaster, purity, deepcopy, quotekeys,
1124 bless, maxdepth, sortkeys);
1127 SvREFCNT_dec(newapad);
1129 postlen = av_len(postav);
1130 if (postlen >= 0 || !terse) {
1131 sv_insert(valstr, 0, 0, " = ", 3);
1132 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1133 sv_catpvn(valstr, ";", 1);
1135 sv_catsv(retval, pad);
1136 sv_catsv(retval, valstr);
1137 sv_catsv(retval, sep);
1140 sv_catsv(retval, pad);
1141 for (i = 0; i <= postlen; ++i) {
1143 svp = av_fetch(postav, i, FALSE);
1144 if (svp && (elem = *svp)) {
1145 sv_catsv(retval, elem);
1147 sv_catpvn(retval, ";", 1);
1148 sv_catsv(retval, sep);
1149 sv_catsv(retval, pad);
1153 sv_catpvn(retval, ";", 1);
1154 sv_catsv(retval, sep);
1156 sv_setpvn(valstr, "", 0);
1157 if (gimme == G_ARRAY) {
1158 XPUSHs(sv_2mortal(retval));
1159 if (i < imax) /* not the last time thro ? */
1160 retval = newSVpvn("",0);
1163 SvREFCNT_dec(postav);
1164 SvREFCNT_dec(valstr);
1167 croak("Call to new() method failed to return HASH ref");
1168 if (gimme == G_SCALAR)
1169 XPUSHs(sv_2mortal(retval));