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 the ouput buffer has less than some arbitary amount of space
278 remaining, then enlarge it. For the test case (25M of output),
279 *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is
280 deemed to be good enough. */
281 if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) {
282 sv_grow(retval, SvCUR(retval) * 3 / 2);
285 realtype = SvTYPE(val);
291 /* If a freeze method is provided and the object has it, call
292 it. Warn on errors. */
293 if (SvOBJECT(SvRV(val)) && freezer &&
294 SvPOK(freezer) && SvCUR(freezer) &&
295 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
296 SvCUR(freezer), -1) != NULL)
298 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
299 XPUSHs(val); PUTBACK;
300 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
303 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
304 PUTBACK; FREETMPS; LEAVE;
308 realtype = SvTYPE(ival);
309 #ifdef DD_USE_OLD_ID_FORMAT
310 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival));
312 id_buffer = PTR2UV(ival);
313 idlen = sizeof(id_buffer);
316 realpack = HvNAME_get(SvSTASH(ival));
320 /* if it has a name, we need to either look it up, or keep a tab
321 * on it so we know when we hit it later
324 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
325 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
328 if ((svp = av_fetch(seenentry, 0, FALSE))
329 && (othername = *svp))
331 if (purity && *levelp > 0) {
334 if (realtype == SVt_PVHV)
335 sv_catpvn(retval, "{}", 2);
336 else if (realtype == SVt_PVAV)
337 sv_catpvn(retval, "[]", 2);
339 sv_catpvn(retval, "do{my $o}", 9);
340 postentry = newSVpvn(name, namelen);
341 sv_catpvn(postentry, " = ", 3);
342 sv_catsv(postentry, othername);
343 av_push(postav, postentry);
346 if (name[0] == '@' || name[0] == '%') {
347 if ((SvPVX_const(othername))[0] == '\\' &&
348 (SvPVX_const(othername))[1] == name[0]) {
349 sv_catpvn(retval, SvPVX_const(othername)+1,
353 sv_catpvn(retval, name, 1);
354 sv_catpvn(retval, "{", 1);
355 sv_catsv(retval, othername);
356 sv_catpvn(retval, "}", 1);
360 sv_catsv(retval, othername);
365 #ifdef DD_USE_OLD_ID_FORMAT
366 warn("ref name not found for %s", id);
368 warn("ref name not found for 0x%"UVxf, PTR2UV(ival));
373 else { /* store our name and continue */
375 if (name[0] == '@' || name[0] == '%') {
376 namesv = newSVpvn("\\", 1);
377 sv_catpvn(namesv, name, namelen);
379 else if (realtype == SVt_PVCV && name[0] == '*') {
380 namesv = newSVpvn("\\", 2);
381 sv_catpvn(namesv, name, namelen);
382 (SvPVX(namesv))[1] = '&';
385 namesv = newSVpvn(name, namelen);
387 av_push(seenentry, namesv);
388 (void)SvREFCNT_inc(val);
389 av_push(seenentry, val);
390 (void)hv_store(seenhv, id, idlen,
391 newRV_inc((SV*)seenentry), 0);
392 SvREFCNT_dec(seenentry);
396 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
398 const char *rval = SvPV(val, rlen);
399 const char *slash = strchr(rval, '/');
400 sv_catpvn(retval, "qr/", 3);
402 sv_catpvn(retval, rval, slash-rval);
403 sv_catpvn(retval, "\\/", 2);
404 rlen -= slash-rval+1;
406 slash = strchr(rval, '/');
408 sv_catpvn(retval, rval, rlen);
409 sv_catpvn(retval, "/", 1);
413 /* If purity is not set and maxdepth is set, then check depth:
414 * if we have reached maximum depth, return the string
415 * representation of the thing we are currently examining
416 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
418 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
420 const char * const valstr = SvPV(val,vallen);
421 sv_catpvn(retval, "'", 1);
422 sv_catpvn(retval, valstr, vallen);
423 sv_catpvn(retval, "'", 1);
427 if (realpack) { /* we have a blessed ref */
429 const char * const blessstr = SvPV(bless, blesslen);
430 sv_catpvn(retval, blessstr, blesslen);
431 sv_catpvn(retval, "( ", 2);
434 apad = newSVsv(apad);
435 sv_x(aTHX_ apad, " ", 1, blesslen+2);
440 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
442 if (realtype <= SVt_PVBM) { /* scalar ref */
443 SV * const namesv = newSVpvn("${", 2);
444 sv_catpvn(namesv, name, namelen);
445 sv_catpvn(namesv, "}", 1);
446 if (realpack) { /* blessed */
447 sv_catpvn(retval, "do{\\(my $o = ", 13);
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,
452 sv_catpvn(retval, ")}", 2);
455 sv_catpvn(retval, "\\", 1);
456 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
457 postav, levelp, indent, pad, xpad, apad, sep, pair,
458 freezer, toaster, purity, deepcopy, quotekeys, bless,
461 SvREFCNT_dec(namesv);
463 else if (realtype == SVt_PVGV) { /* glob ref */
464 SV * const namesv = newSVpvn("*{", 2);
465 sv_catpvn(namesv, name, namelen);
466 sv_catpvn(namesv, "}", 1);
467 sv_catpvn(retval, "\\", 1);
468 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
469 postav, levelp, indent, pad, xpad, apad, sep, pair,
470 freezer, toaster, purity, deepcopy, quotekeys, bless,
472 SvREFCNT_dec(namesv);
474 else if (realtype == SVt_PVAV) {
477 const I32 ixmax = av_len((AV *)ival);
479 SV * const ixsv = newSViv(0);
480 /* allowing for a 24 char wide array index */
481 New(0, iname, namelen+28, char);
482 (void)strcpy(iname, name);
484 if (name[0] == '@') {
485 sv_catpvn(retval, "(", 1);
489 sv_catpvn(retval, "[", 1);
490 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
492 && name[namelen-1] != ']' && name[namelen-1] != '}'
493 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
495 && name[namelen-1] != ']' && name[namelen-1] != '}')
498 || (name[0] == '\\' && name[2] == '{'))))
500 iname[inamelen++] = '-'; iname[inamelen++] = '>';
501 iname[inamelen] = '\0';
504 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
505 (instr(iname+inamelen-8, "{SCALAR}") ||
506 instr(iname+inamelen-7, "{ARRAY}") ||
507 instr(iname+inamelen-6, "{HASH}"))) {
508 iname[inamelen++] = '-'; iname[inamelen++] = '>';
510 iname[inamelen++] = '['; iname[inamelen] = '\0';
511 totpad = newSVsv(sep);
512 sv_catsv(totpad, pad);
513 sv_catsv(totpad, apad);
515 for (ix = 0; ix <= ixmax; ++ix) {
518 svp = av_fetch((AV*)ival, ix, FALSE);
526 ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
527 iname[ilen++] = ']'; iname[ilen] = '\0';
529 sv_catsv(retval, totpad);
530 sv_catsv(retval, ipad);
531 sv_catpvn(retval, "#", 1);
532 sv_catsv(retval, ixsv);
534 sv_catsv(retval, totpad);
535 sv_catsv(retval, ipad);
536 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
537 levelp, indent, pad, xpad, apad, sep, pair,
538 freezer, toaster, purity, deepcopy, quotekeys, bless,
541 sv_catpvn(retval, ",", 1);
544 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
545 sv_catsv(retval, totpad);
546 sv_catsv(retval, opad);
550 sv_catpvn(retval, ")", 1);
552 sv_catpvn(retval, "]", 1);
554 SvREFCNT_dec(totpad);
557 else if (realtype == SVt_PVHV) {
558 SV *totpad, *newapad;
566 SV * const iname = newSVpvn(name, namelen);
567 if (name[0] == '%') {
568 sv_catpvn(retval, "(", 1);
569 (SvPVX(iname))[0] = '$';
572 sv_catpvn(retval, "{", 1);
573 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
575 && name[namelen-1] != ']' && name[namelen-1] != '}')
578 || (name[0] == '\\' && name[2] == '{'))))
580 sv_catpvn(iname, "->", 2);
583 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
584 (instr(name+namelen-8, "{SCALAR}") ||
585 instr(name+namelen-7, "{ARRAY}") ||
586 instr(name+namelen-6, "{HASH}"))) {
587 sv_catpvn(iname, "->", 2);
589 sv_catpvn(iname, "{", 1);
590 totpad = newSVsv(sep);
591 sv_catsv(totpad, pad);
592 sv_catsv(totpad, apad);
594 /* If requested, get a sorted/filtered array of hash keys */
596 if (sortkeys == &PL_sv_yes) {
598 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
601 (void)hv_iterinit((HV*)ival);
602 while ((entry = hv_iternext((HV*)ival))) {
603 sv = hv_iterkeysv(entry);
607 # ifdef USE_LOCALE_NUMERIC
608 sortsv(AvARRAY(keys),
610 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
612 sortsv(AvARRAY(keys),
618 if (sortkeys != &PL_sv_yes) {
619 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
620 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
621 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
625 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
626 keys = (AV*)SvREFCNT_inc(SvRV(sv));
629 warn("Sortkeys subroutine did not return ARRAYREF\n");
630 PUTBACK; FREETMPS; LEAVE;
633 sv_2mortal((SV*)keys);
636 (void)hv_iterinit((HV*)ival);
638 /* foreach (keys %hash) */
639 for (i = 0; 1; i++) {
641 char *nkey_buffer = NULL;
646 bool do_utf8 = FALSE;
649 if (!(keys && (I32)i <= av_len(keys))) break;
651 if (!(entry = hv_iternext((HV *)ival))) break;
655 sv_catpvn(retval, ",", 1);
659 svp = av_fetch(keys, i, FALSE);
660 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
661 key = SvPV(keysv, keylen);
662 svp = hv_fetch((HV*)ival, key,
663 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
664 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
667 keysv = hv_iterkeysv(entry);
668 hval = hv_iterval((HV*)ival, entry);
671 key = SvPV(keysv, keylen);
672 do_utf8 = DO_UTF8(keysv);
675 sv_catsv(retval, totpad);
676 sv_catsv(retval, ipad);
677 /* old logic was first to check utf8 flag, and if utf8 always
678 call esc_q_utf8. This caused test to break under -Mutf8,
679 because there even strings like 'c' have utf8 flag on.
680 Hence with quotekeys == 0 the XS code would still '' quote
681 them based on flags, whereas the perl code would not,
683 The perl code is correct.
684 needs_quote() decides that anything that isn't a valid
685 perl identifier needs to be quoted, hence only correctly
686 formed strings with no characters outside [A-Za-z0-9_:]
687 won't need quoting. None of those characters are used in
688 the byte encoding of utf8, so anything with utf8
689 encoded characters in will need quoting. Hence strings
690 with utf8 encoded characters in will end up inside do_utf8
691 just like before, but now strings with utf8 flag set but
692 only ascii characters will end up in the unquoted section.
694 There should also be less tests for the (probably currently)
695 more common doesn't need quoting case.
696 The code is also smaller (22044 vs 22260) because I've been
697 able to pull the common logic out to both sides. */
698 if (quotekeys || needs_quote(key)) {
700 STRLEN ocur = SvCUR(retval);
701 nlen = esc_q_utf8(aTHX_ retval, key, klen);
702 nkey = SvPVX(retval) + ocur;
705 nticks = num_q(key, klen);
706 New(0, nkey_buffer, klen+nticks+3, char);
710 klen += esc_q(nkey+1, key, klen);
712 (void)Copy(key, nkey+1, klen, char);
716 sv_catpvn(retval, nkey, klen);
722 sv_catpvn(retval, nkey, klen);
724 sname = newSVsv(iname);
725 sv_catpvn(sname, nkey, nlen);
726 sv_catpvn(sname, "}", 1);
728 sv_catsv(retval, pair);
732 newapad = newSVsv(apad);
733 New(0, extra, klen+4+1, char);
734 while (elen < (klen+4))
737 sv_catpvn(newapad, extra, elen);
743 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
744 postav, levelp, indent, pad, xpad, newapad, sep, pair,
745 freezer, toaster, purity, deepcopy, quotekeys, bless,
748 Safefree(nkey_buffer);
750 SvREFCNT_dec(newapad);
753 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
754 sv_catsv(retval, totpad);
755 sv_catsv(retval, opad);
759 sv_catpvn(retval, ")", 1);
761 sv_catpvn(retval, "}", 1);
763 SvREFCNT_dec(totpad);
765 else if (realtype == SVt_PVCV) {
766 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
768 warn("Encountered CODE ref, using dummy placeholder");
771 warn("cannot handle ref type %ld", realtype);
774 if (realpack) { /* free blessed allocs */
779 sv_catpvn(retval, ", '", 3);
780 sv_catpvn(retval, realpack, strlen(realpack));
781 sv_catpvn(retval, "' )", 3);
782 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
783 sv_catpvn(retval, "->", 2);
784 sv_catsv(retval, toaster);
785 sv_catpvn(retval, "()", 2);
795 #ifdef DD_USE_OLD_ID_FORMAT
796 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
798 id_buffer = PTR2UV(val);
799 idlen = sizeof(id_buffer);
801 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
802 (sv = *svp) && SvROK(sv) &&
803 (seenentry = (AV*)SvRV(sv)))
806 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
807 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
809 sv_catpvn(retval, "${", 2);
810 sv_catsv(retval, othername);
811 sv_catpvn(retval, "}", 1);
815 else if (val != &PL_sv_undef) {
816 SV * const namesv = newSVpvn("\\", 1);
817 sv_catpvn(namesv, name, namelen);
819 av_push(seenentry, namesv);
820 av_push(seenentry, newRV_inc(val));
821 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
822 SvREFCNT_dec(seenentry);
826 if (DD_is_integer(val)) {
829 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
831 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
833 /* Need to check to see if this is a string such as " 0".
834 I'm assuming from sprintf isn't going to clash with utf8.
835 Is this valid on EBCDIC? */
837 const char * const pv = SvPV(val, pvlen);
838 if (pvlen != len || memNE(pv, tmpbuf, len))
839 goto integer_came_from_string;
842 /* Looks like we're on a 64 bit system. Make it a string so that
843 if a 32 bit system reads the number it will cope better. */
844 sv_catpvf(retval, "'%s'", tmpbuf);
846 sv_catpvn(retval, tmpbuf, len);
848 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
850 ++c; --i; /* just get the name */
851 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
855 if (needs_quote(c)) {
856 sv_grow(retval, SvCUR(retval)+6+2*i);
857 r = SvPVX(retval)+SvCUR(retval);
858 r[0] = '*'; r[1] = '{'; r[2] = '\'';
859 i += esc_q(r+3, c, i);
861 r[i++] = '\''; r[i++] = '}';
865 sv_grow(retval, SvCUR(retval)+i+2);
866 r = SvPVX(retval)+SvCUR(retval);
867 r[0] = '*'; strcpy(r+1, c);
870 SvCUR_set(retval, SvCUR(retval)+i);
873 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
874 static const STRLEN sizes[] = { 8, 7, 6 };
876 SV * const nname = newSVpvn("", 0);
877 SV * const newapad = newSVpvn("", 0);
878 GV * const gv = (GV*)val;
881 for (j=0; j<3; j++) {
882 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
885 if (j == 0 && !SvOK(e))
890 SV *postentry = newSVpvn(r,i);
892 sv_setsv(nname, postentry);
893 sv_catpvn(nname, entries[j], sizes[j]);
894 sv_catpvn(postentry, " = ", 3);
895 av_push(postav, postentry);
898 SvCUR_set(newapad, 0);
900 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
902 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
903 seenhv, postav, &nlevel, indent, pad, xpad,
904 newapad, sep, pair, freezer, toaster, purity,
905 deepcopy, quotekeys, bless, maxdepth,
911 SvREFCNT_dec(newapad);
915 else if (val == &PL_sv_undef || !SvOK(val)) {
916 sv_catpvn(retval, "undef", 5);
919 integer_came_from_string:
922 i += esc_q_utf8(aTHX_ retval, c, i);
924 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
925 r = SvPVX(retval) + SvCUR(retval);
927 i += esc_q(r+1, c, i);
931 SvCUR_set(retval, SvCUR(retval)+i);
938 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
939 else if (namelen && seenentry) {
940 SV *mark = *av_fetch(seenentry, 2, TRUE);
948 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
951 # This is the exact equivalent of Dump. Well, almost. The things that are
952 # different as of now (due to Laziness):
953 # * doesnt do double-quotes yet.
957 Data_Dumper_Dumpxs(href, ...)
965 AV *postav, *todumpav, *namesav;
967 I32 indent, terse, i, imax, postlen;
969 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
970 SV *freezer, *toaster, *bless, *sortkeys;
971 I32 purity, deepcopy, quotekeys, maxdepth = 0;
975 if (!SvROK(href)) { /* call new to get an object first */
977 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
984 XPUSHs(sv_2mortal(newSVsv(ST(1))));
986 XPUSHs(sv_2mortal(newSVsv(ST(2))));
988 i = perl_call_method("new", G_SCALAR);
991 href = newSVsv(POPs);
997 (void)sv_2mortal(href);
1000 todumpav = namesav = NULL;
1002 val = pad = xpad = apad = sep = pair = varname
1003 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
1004 name = sv_newmortal();
1006 terse = purity = deepcopy = 0;
1009 retval = newSVpvn("", 0);
1011 && (hv = (HV*)SvRV((SV*)href))
1012 && SvTYPE(hv) == SVt_PVHV) {
1014 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1015 seenhv = (HV*)SvRV(*svp);
1016 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1017 todumpav = (AV*)SvRV(*svp);
1018 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1019 namesav = (AV*)SvRV(*svp);
1020 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1021 indent = SvIV(*svp);
1022 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1023 purity = SvIV(*svp);
1024 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1025 terse = SvTRUE(*svp);
1026 #if 0 /* useqq currently unused */
1027 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1028 useqq = SvTRUE(*svp);
1030 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1032 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1034 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1036 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1038 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1040 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1042 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1044 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1046 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1047 deepcopy = SvTRUE(*svp);
1048 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1049 quotekeys = SvTRUE(*svp);
1050 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1052 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1053 maxdepth = SvIV(*svp);
1054 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1056 if (! SvTRUE(sortkeys))
1058 else if (! (SvROK(sortkeys) &&
1059 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1061 /* flag to use qsortsv() for sorting hash keys */
1062 sortkeys = &PL_sv_yes;
1068 imax = av_len(todumpav);
1071 valstr = newSVpvn("",0);
1072 for (i = 0; i <= imax; ++i) {
1076 if ((svp = av_fetch(todumpav, i, FALSE)))
1080 if ((svp = av_fetch(namesav, i, TRUE))) {
1081 sv_setsv(name, *svp);
1082 if (SvOK(*svp) && !SvPOK(*svp))
1083 (void)SvPV_nolen_const(name);
1086 (void)SvOK_off(name);
1089 if ((SvPVX_const(name))[0] == '*') {
1091 switch (SvTYPE(SvRV(val))) {
1093 (SvPVX(name))[0] = '@';
1096 (SvPVX(name))[0] = '%';
1099 (SvPVX(name))[0] = '*';
1102 (SvPVX(name))[0] = '$';
1107 (SvPVX(name))[0] = '$';
1109 else if ((SvPVX_const(name))[0] != '$')
1110 sv_insert(name, 0, 0, "$", 1);
1114 sv_setpvn(name, "$", 1);
1115 sv_catsv(name, varname);
1116 nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
1117 sv_catpvn(name, tmpbuf, nchars);
1121 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1122 newapad = newSVsv(apad);
1123 sv_catsv(newapad, tmpsv);
1124 SvREFCNT_dec(tmpsv);
1129 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1130 postav, &level, indent, pad, xpad, newapad, sep, pair,
1131 freezer, toaster, purity, deepcopy, quotekeys,
1132 bless, maxdepth, sortkeys);
1135 SvREFCNT_dec(newapad);
1137 postlen = av_len(postav);
1138 if (postlen >= 0 || !terse) {
1139 sv_insert(valstr, 0, 0, " = ", 3);
1140 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1141 sv_catpvn(valstr, ";", 1);
1143 sv_catsv(retval, pad);
1144 sv_catsv(retval, valstr);
1145 sv_catsv(retval, sep);
1148 sv_catsv(retval, pad);
1149 for (i = 0; i <= postlen; ++i) {
1151 svp = av_fetch(postav, i, FALSE);
1152 if (svp && (elem = *svp)) {
1153 sv_catsv(retval, elem);
1155 sv_catpvn(retval, ";", 1);
1156 sv_catsv(retval, sep);
1157 sv_catsv(retval, pad);
1161 sv_catpvn(retval, ";", 1);
1162 sv_catsv(retval, sep);
1164 sv_setpvn(valstr, "", 0);
1165 if (gimme == G_ARRAY) {
1166 XPUSHs(sv_2mortal(retval));
1167 if (i < imax) /* not the last time thro ? */
1168 retval = newSVpvn("",0);
1171 SvREFCNT_dec(postav);
1172 SvREFCNT_dec(valstr);
1175 croak("Call to new() method failed to return HASH ref");
1176 if (gimme == G_SCALAR)
1177 XPUSHs(sv_2mortal(retval));