1 #define PERL_NO_GET_CONTEXT
6 static I32 num_q (char *s, STRLEN slen);
7 static I32 esc_q (char *dest, char *src, STRLEN slen);
8 static I32 esc_q_utf8 (pTHX_ SV *sv, char *src, STRLEN slen);
9 static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
10 static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
11 HV *seenhv, AV *postav, I32 *levelp, I32 indent,
12 SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
13 SV *freezer, SV *toaster,
14 I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
15 I32 maxdepth, SV *sortkeys);
18 #define HvNAME_get HvNAME
21 #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
24 # define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
26 # define UNI_TO_NATIVE(ch) (ch)
30 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
32 UV uv = utf8_to_uv(s, UTF8_MAXLEN, retlen,
33 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
34 return UNI_TO_NATIVE(uv);
37 # if !defined(PERL_IMPLICIT_CONTEXT)
38 # define utf8_to_uvchr Perl_utf8_to_uvchr
40 # define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
43 #endif /* PERL_VERSION <= 6 */
45 /* Changes in 5.7 series mean that now IOK is only set if scalar is
46 precisely integer but in 5.6 and earlier we need to do a more
49 #define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
51 #define DD_is_integer(sv) SvIOK(sv)
54 /* does a string need to be protected? */
56 needs_quote(register char *s)
81 /* count the number of "'"s and "\"s in string */
83 num_q(register char *s, register STRLEN slen)
88 if (*s == '\'' || *s == '\\')
97 /* returns number of chars added to escape "'"s and "\"s in s */
98 /* slen number of characters in s will be escaped */
99 /* destination must be long enough for additional chars */
101 esc_q(register char *d, register char *s, register STRLEN slen)
103 register I32 ret = 0;
121 esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen)
123 char *s, *send, *r, *rstart;
124 STRLEN j, cur = SvCUR(sv);
125 /* Could count 128-255 and 256+ in two variables, if we want to
126 be like &qquote and make a distinction. */
127 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
128 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
129 STRLEN backslashes = 0;
130 STRLEN single_quotes = 0;
131 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
134 /* this will need EBCDICification */
135 for (s = src, send = src + slen; s < send; s += UTF8SKIP(s)) {
136 UV k = utf8_to_uvchr((U8*)s, NULL);
139 /* 4: \x{} then count the number of hex digits. */
140 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
142 8 /* We may allocate a bit more than the minimum here. */
144 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
147 } else if (k == '\\') {
149 } else if (k == '\'') {
151 } else if (k == '"' || k == '$' || k == '@') {
158 /* We have something needing hex. 3 is ""\0 */
159 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
160 + 2*qq_escapables + normal);
161 rstart = r = SvPVX(sv) + cur;
165 for (s = src; s < send; s += UTF8SKIP(s)) {
166 UV k = utf8_to_uvchr((U8*)s, NULL);
168 if (k == '"' || k == '\\' || k == '$' || k == '@') {
175 /* The return value of sprintf() is unportable.
176 * In modern systems it returns (int) the number of characters,
177 * but in older systems it might return (char*) the original
178 * buffer, or it might even be (void). The easiest portable
179 * thing to do is probably use sprintf() in void context and
180 * then strlen(buffer) for the length. The more proper way
181 * would of course be to figure out the prototype of sprintf.
183 sprintf(r, "\\x{%"UVxf"}", k);
190 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
191 + qq_escapables + normal);
192 rstart = r = SvPVX(sv) + cur;
194 for (s = src; s < send; s ++) {
196 if (k == '\'' || k == '\\')
204 SvCUR_set(sv, cur + j);
209 /* append a repeated string to an SV */
211 sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
214 sv = newSVpvn("", 0);
216 assert(SvTYPE(sv) >= SVt_PV);
219 SvGROW(sv, len*n + SvCUR(sv) + 1);
221 char *start = SvPVX(sv) + SvCUR(sv);
222 SvCUR_set(sv, SvCUR(sv) + n);
229 sv_catpvn(sv, str, len);
237 * This ought to be split into smaller functions. (it is one long function since
238 * it exactly parallels the perl version, which was one long thing for
239 * efficiency raisins.) Ugggh!
242 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
243 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
244 SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
245 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
249 char *c, *r, *realpack, id[128];
251 SV *sv, *ipad, *ival;
252 SV *blesspad = Nullsv;
253 AV *seenentry = Nullav;
255 STRLEN inamelen, idlen = 0;
261 realtype = SvTYPE(val);
267 /* If a freeze method is provided and the object has it, call
268 it. Warn on errors. */
269 if (SvOBJECT(SvRV(val)) && freezer &&
270 SvPOK(freezer) && SvCUR(freezer) &&
271 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
272 SvCUR(freezer), -1) != NULL)
274 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
275 XPUSHs(val); PUTBACK;
276 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
279 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
280 PUTBACK; FREETMPS; LEAVE;
284 realtype = SvTYPE(ival);
285 (void) sprintf(id, "0x%"UVxf, PTR2UV(ival));
288 realpack = HvNAME_get(SvSTASH(ival));
292 /* if it has a name, we need to either look it up, or keep a tab
293 * on it so we know when we hit it later
296 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
297 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
300 if ((svp = av_fetch(seenentry, 0, FALSE))
301 && (othername = *svp))
303 if (purity && *levelp > 0) {
306 if (realtype == SVt_PVHV)
307 sv_catpvn(retval, "{}", 2);
308 else if (realtype == SVt_PVAV)
309 sv_catpvn(retval, "[]", 2);
311 sv_catpvn(retval, "do{my $o}", 9);
312 postentry = newSVpvn(name, namelen);
313 sv_catpvn(postentry, " = ", 3);
314 sv_catsv(postentry, othername);
315 av_push(postav, postentry);
318 if (name[0] == '@' || name[0] == '%') {
319 if ((SvPVX_const(othername))[0] == '\\' &&
320 (SvPVX_const(othername))[1] == name[0]) {
321 sv_catpvn(retval, SvPVX_const(othername)+1,
325 sv_catpvn(retval, name, 1);
326 sv_catpvn(retval, "{", 1);
327 sv_catsv(retval, othername);
328 sv_catpvn(retval, "}", 1);
332 sv_catsv(retval, othername);
337 warn("ref name not found for %s", id);
341 else { /* store our name and continue */
343 if (name[0] == '@' || name[0] == '%') {
344 namesv = newSVpvn("\\", 1);
345 sv_catpvn(namesv, name, namelen);
347 else if (realtype == SVt_PVCV && name[0] == '*') {
348 namesv = newSVpvn("\\", 2);
349 sv_catpvn(namesv, name, namelen);
350 (SvPVX(namesv))[1] = '&';
353 namesv = newSVpvn(name, namelen);
355 av_push(seenentry, namesv);
356 (void)SvREFCNT_inc(val);
357 av_push(seenentry, val);
358 (void)hv_store(seenhv, id, strlen(id),
359 newRV_inc((SV*)seenentry), 0);
360 SvREFCNT_dec(seenentry);
364 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
366 char *rval = SvPV(val, rlen);
367 char *slash = strchr(rval, '/');
368 sv_catpvn(retval, "qr/", 3);
370 sv_catpvn(retval, rval, slash-rval);
371 sv_catpvn(retval, "\\/", 2);
372 rlen -= slash-rval+1;
374 slash = strchr(rval, '/');
376 sv_catpvn(retval, rval, rlen);
377 sv_catpvn(retval, "/", 1);
381 /* If purity is not set and maxdepth is set, then check depth:
382 * if we have reached maximum depth, return the string
383 * representation of the thing we are currently examining
384 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
386 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
388 char *valstr = SvPV(val,vallen);
389 sv_catpvn(retval, "'", 1);
390 sv_catpvn(retval, valstr, vallen);
391 sv_catpvn(retval, "'", 1);
395 if (realpack) { /* we have a blessed ref */
397 char *blessstr = SvPV(bless, blesslen);
398 sv_catpvn(retval, blessstr, blesslen);
399 sv_catpvn(retval, "( ", 2);
402 apad = newSVsv(apad);
403 sv_x(aTHX_ apad, " ", 1, blesslen+2);
408 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
410 if (realtype <= SVt_PVBM) { /* scalar ref */
411 SV *namesv = newSVpvn("${", 2);
412 sv_catpvn(namesv, name, namelen);
413 sv_catpvn(namesv, "}", 1);
414 if (realpack) { /* blessed */
415 sv_catpvn(retval, "do{\\(my $o = ", 13);
416 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
417 postav, levelp, indent, pad, xpad, apad, sep, pair,
418 freezer, toaster, purity, deepcopy, quotekeys, bless,
420 sv_catpvn(retval, ")}", 2);
423 sv_catpvn(retval, "\\", 1);
424 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
425 postav, levelp, indent, pad, xpad, apad, sep, pair,
426 freezer, toaster, purity, deepcopy, quotekeys, bless,
429 SvREFCNT_dec(namesv);
431 else if (realtype == SVt_PVGV) { /* glob ref */
432 SV *namesv = newSVpvn("*{", 2);
433 sv_catpvn(namesv, name, namelen);
434 sv_catpvn(namesv, "}", 1);
435 sv_catpvn(retval, "\\", 1);
436 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
437 postav, levelp, indent, pad, xpad, apad, sep, pair,
438 freezer, toaster, purity, deepcopy, quotekeys, bless,
440 SvREFCNT_dec(namesv);
442 else if (realtype == SVt_PVAV) {
445 I32 ixmax = av_len((AV *)ival);
447 SV *ixsv = newSViv(0);
448 /* allowing for a 24 char wide array index */
449 New(0, iname, namelen+28, char);
450 (void)strcpy(iname, name);
452 if (name[0] == '@') {
453 sv_catpvn(retval, "(", 1);
457 sv_catpvn(retval, "[", 1);
458 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
460 && name[namelen-1] != ']' && name[namelen-1] != '}'
461 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
463 && name[namelen-1] != ']' && name[namelen-1] != '}')
466 || (name[0] == '\\' && name[2] == '{'))))
468 iname[inamelen++] = '-'; iname[inamelen++] = '>';
469 iname[inamelen] = '\0';
472 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
473 (instr(iname+inamelen-8, "{SCALAR}") ||
474 instr(iname+inamelen-7, "{ARRAY}") ||
475 instr(iname+inamelen-6, "{HASH}"))) {
476 iname[inamelen++] = '-'; iname[inamelen++] = '>';
478 iname[inamelen++] = '['; iname[inamelen] = '\0';
479 totpad = newSVsv(sep);
480 sv_catsv(totpad, pad);
481 sv_catsv(totpad, apad);
483 for (ix = 0; ix <= ixmax; ++ix) {
486 svp = av_fetch((AV*)ival, ix, FALSE);
494 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
495 ilen = strlen(iname);
496 iname[ilen++] = ']'; iname[ilen] = '\0';
498 sv_catsv(retval, totpad);
499 sv_catsv(retval, ipad);
500 sv_catpvn(retval, "#", 1);
501 sv_catsv(retval, ixsv);
503 sv_catsv(retval, totpad);
504 sv_catsv(retval, ipad);
505 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
506 levelp, indent, pad, xpad, apad, sep, pair,
507 freezer, toaster, purity, deepcopy, quotekeys, bless,
510 sv_catpvn(retval, ",", 1);
513 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
514 sv_catsv(retval, totpad);
515 sv_catsv(retval, opad);
519 sv_catpvn(retval, ")", 1);
521 sv_catpvn(retval, "]", 1);
523 SvREFCNT_dec(totpad);
526 else if (realtype == SVt_PVHV) {
527 SV *totpad, *newapad;
535 iname = newSVpvn(name, namelen);
536 if (name[0] == '%') {
537 sv_catpvn(retval, "(", 1);
538 (SvPVX(iname))[0] = '$';
541 sv_catpvn(retval, "{", 1);
542 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
544 && name[namelen-1] != ']' && name[namelen-1] != '}')
547 || (name[0] == '\\' && name[2] == '{'))))
549 sv_catpvn(iname, "->", 2);
552 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
553 (instr(name+namelen-8, "{SCALAR}") ||
554 instr(name+namelen-7, "{ARRAY}") ||
555 instr(name+namelen-6, "{HASH}"))) {
556 sv_catpvn(iname, "->", 2);
558 sv_catpvn(iname, "{", 1);
559 totpad = newSVsv(sep);
560 sv_catsv(totpad, pad);
561 sv_catsv(totpad, apad);
563 /* If requested, get a sorted/filtered array of hash keys */
565 if (sortkeys == &PL_sv_yes) {
567 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
570 (void)hv_iterinit((HV*)ival);
571 while ((entry = hv_iternext((HV*)ival))) {
572 sv = hv_iterkeysv(entry);
576 # ifdef USE_LOCALE_NUMERIC
577 sortsv(AvARRAY(keys),
579 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
581 sortsv(AvARRAY(keys),
587 if (sortkeys != &PL_sv_yes) {
588 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
589 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
590 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
594 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
595 keys = (AV*)SvREFCNT_inc(SvRV(sv));
598 warn("Sortkeys subroutine did not return ARRAYREF\n");
599 PUTBACK; FREETMPS; LEAVE;
602 sv_2mortal((SV*)keys);
605 (void)hv_iterinit((HV*)ival);
607 /* foreach (keys %hash) */
608 for (i = 0; 1; i++) {
610 char *nkey_buffer = NULL;
615 bool do_utf8 = FALSE;
618 if (!(keys && (I32)i <= av_len(keys))) break;
620 if (!(entry = hv_iternext((HV *)ival))) break;
624 sv_catpvn(retval, ",", 1);
628 svp = av_fetch(keys, i, FALSE);
629 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
630 key = SvPV(keysv, keylen);
631 svp = hv_fetch((HV*)ival, key,
632 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
633 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
636 keysv = hv_iterkeysv(entry);
637 hval = hv_iterval((HV*)ival, entry);
640 do_utf8 = DO_UTF8(keysv);
641 key = SvPV(keysv, keylen);
644 sv_catsv(retval, totpad);
645 sv_catsv(retval, ipad);
646 /* old logic was first to check utf8 flag, and if utf8 always
647 call esc_q_utf8. This caused test to break under -Mutf8,
648 because there even strings like 'c' have utf8 flag on.
649 Hence with quotekeys == 0 the XS code would still '' quote
650 them based on flags, whereas the perl code would not,
652 The perl code is correct.
653 needs_quote() decides that anything that isn't a valid
654 perl identifier needs to be quoted, hence only correctly
655 formed strings with no characters outside [A-Za-z0-9_:]
656 won't need quoting. None of those characters are used in
657 the byte encoding of utf8, so anything with utf8
658 encoded characters in will need quoting. Hence strings
659 with utf8 encoded characters in will end up inside do_utf8
660 just like before, but now strings with utf8 flag set but
661 only ascii characters will end up in the unquoted section.
663 There should also be less tests for the (probably currently)
664 more common doesn't need quoting case.
665 The code is also smaller (22044 vs 22260) because I've been
666 able to pull the common logic out to both sides. */
667 if (quotekeys || needs_quote(key)) {
669 STRLEN ocur = SvCUR(retval);
670 nlen = esc_q_utf8(aTHX_ retval, key, klen);
671 nkey = SvPVX(retval) + ocur;
674 nticks = num_q(key, klen);
675 New(0, nkey_buffer, klen+nticks+3, char);
679 klen += esc_q(nkey+1, key, klen);
681 (void)Copy(key, nkey+1, klen, char);
685 sv_catpvn(retval, nkey, klen);
691 sv_catpvn(retval, nkey, klen);
693 sname = newSVsv(iname);
694 sv_catpvn(sname, nkey, nlen);
695 sv_catpvn(sname, "}", 1);
697 sv_catsv(retval, pair);
701 newapad = newSVsv(apad);
702 New(0, extra, klen+4+1, char);
703 while (elen < (klen+4))
706 sv_catpvn(newapad, extra, elen);
712 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
713 postav, levelp, indent, pad, xpad, newapad, sep, pair,
714 freezer, toaster, purity, deepcopy, quotekeys, bless,
717 Safefree(nkey_buffer);
719 SvREFCNT_dec(newapad);
722 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
723 sv_catsv(retval, totpad);
724 sv_catsv(retval, opad);
728 sv_catpvn(retval, ")", 1);
730 sv_catpvn(retval, "}", 1);
732 SvREFCNT_dec(totpad);
734 else if (realtype == SVt_PVCV) {
735 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
737 warn("Encountered CODE ref, using dummy placeholder");
740 warn("cannot handle ref type %ld", realtype);
743 if (realpack) { /* free blessed allocs */
748 sv_catpvn(retval, ", '", 3);
749 sv_catpvn(retval, realpack, strlen(realpack));
750 sv_catpvn(retval, "' )", 3);
751 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
752 sv_catpvn(retval, "->", 2);
753 sv_catsv(retval, toaster);
754 sv_catpvn(retval, "()", 2);
764 (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
765 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
766 (sv = *svp) && SvROK(sv) &&
767 (seenentry = (AV*)SvRV(sv)))
770 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
771 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
773 sv_catpvn(retval, "${", 2);
774 sv_catsv(retval, othername);
775 sv_catpvn(retval, "}", 1);
779 else if (val != &PL_sv_undef) {
781 namesv = newSVpvn("\\", 1);
782 sv_catpvn(namesv, name, namelen);
784 av_push(seenentry, namesv);
785 av_push(seenentry, newRV_inc(val));
786 (void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0);
787 SvREFCNT_dec(seenentry);
791 if (DD_is_integer(val)) {
794 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
796 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
797 len = strlen(tmpbuf);
799 /* Need to check to see if this is a string such as " 0".
800 I'm assuming from sprintf isn't going to clash with utf8.
801 Is this valid on EBCDIC? */
803 const char *pv = SvPV(val, pvlen);
804 if (pvlen != len || memNE(pv, tmpbuf, len))
805 goto integer_came_from_string;
808 /* Looks like we're on a 64 bit system. Make it a string so that
809 if a 32 bit system reads the number it will cope better. */
810 sv_catpvf(retval, "'%s'", tmpbuf);
812 sv_catpvn(retval, tmpbuf, len);
814 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
816 ++c; --i; /* just get the name */
817 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
821 if (needs_quote(c)) {
822 sv_grow(retval, SvCUR(retval)+6+2*i);
823 r = SvPVX(retval)+SvCUR(retval);
824 r[0] = '*'; r[1] = '{'; r[2] = '\'';
825 i += esc_q(r+3, c, i);
827 r[i++] = '\''; r[i++] = '}';
831 sv_grow(retval, SvCUR(retval)+i+2);
832 r = SvPVX(retval)+SvCUR(retval);
833 r[0] = '*'; strcpy(r+1, c);
836 SvCUR_set(retval, SvCUR(retval)+i);
839 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
840 static const STRLEN sizes[] = { 8, 7, 6 };
842 SV *nname = newSVpvn("", 0);
843 SV *newapad = newSVpvn("", 0);
847 for (j=0; j<3; j++) {
848 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
851 if (j == 0 && !SvOK(e))
856 SV *postentry = newSVpvn(r,i);
858 sv_setsv(nname, postentry);
859 sv_catpvn(nname, entries[j], sizes[j]);
860 sv_catpvn(postentry, " = ", 3);
861 av_push(postav, postentry);
864 SvCUR_set(newapad, 0);
866 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
868 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
869 seenhv, postav, &nlevel, indent, pad, xpad,
870 newapad, sep, pair, freezer, toaster, purity,
871 deepcopy, quotekeys, bless, maxdepth,
877 SvREFCNT_dec(newapad);
881 else if (val == &PL_sv_undef || !SvOK(val)) {
882 sv_catpvn(retval, "undef", 5);
885 integer_came_from_string:
888 i += esc_q_utf8(aTHX_ retval, c, i);
890 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
891 r = SvPVX(retval) + SvCUR(retval);
893 i += esc_q(r+1, c, i);
897 SvCUR_set(retval, SvCUR(retval)+i);
904 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
905 else if (namelen && seenentry) {
906 SV *mark = *av_fetch(seenentry, 2, TRUE);
914 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
917 # This is the exact equivalent of Dump. Well, almost. The things that are
918 # different as of now (due to Laziness):
919 # * doesnt do double-quotes yet.
923 Data_Dumper_Dumpxs(href, ...)
931 AV *postav, *todumpav, *namesav;
933 I32 indent, terse, i, imax, postlen;
935 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
936 SV *freezer, *toaster, *bless, *sortkeys;
937 I32 purity, deepcopy, quotekeys, maxdepth = 0;
941 if (!SvROK(href)) { /* call new to get an object first */
943 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
950 XPUSHs(sv_2mortal(newSVsv(ST(1))));
952 XPUSHs(sv_2mortal(newSVsv(ST(2))));
954 i = perl_call_method("new", G_SCALAR);
957 href = newSVsv(POPs);
963 (void)sv_2mortal(href);
966 todumpav = namesav = Nullav;
968 val = pad = xpad = apad = sep = pair = varname
969 = freezer = toaster = bless = &PL_sv_undef;
970 name = sv_newmortal();
972 terse = purity = deepcopy = 0;
975 retval = newSVpvn("", 0);
977 && (hv = (HV*)SvRV((SV*)href))
978 && SvTYPE(hv) == SVt_PVHV) {
980 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
981 seenhv = (HV*)SvRV(*svp);
982 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
983 todumpav = (AV*)SvRV(*svp);
984 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
985 namesav = (AV*)SvRV(*svp);
986 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
988 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
990 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
991 terse = SvTRUE(*svp);
992 #if 0 /* useqq currently unused */
993 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
994 useqq = SvTRUE(*svp);
996 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
998 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1000 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1002 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1004 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1006 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1008 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1010 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1012 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1013 deepcopy = SvTRUE(*svp);
1014 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1015 quotekeys = SvTRUE(*svp);
1016 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1018 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1019 maxdepth = SvIV(*svp);
1020 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1022 if (! SvTRUE(sortkeys))
1024 else if (! (SvROK(sortkeys) &&
1025 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1027 /* flag to use qsortsv() for sorting hash keys */
1028 sortkeys = &PL_sv_yes;
1034 imax = av_len(todumpav);
1037 valstr = newSVpvn("",0);
1038 for (i = 0; i <= imax; ++i) {
1042 if ((svp = av_fetch(todumpav, i, FALSE)))
1046 if ((svp = av_fetch(namesav, i, TRUE))) {
1047 sv_setsv(name, *svp);
1048 if (SvOK(*svp) && !SvPOK(*svp))
1049 (void)SvPV_nolen_const(name);
1052 (void)SvOK_off(name);
1055 if ((SvPVX_const(name))[0] == '*') {
1057 switch (SvTYPE(SvRV(val))) {
1059 (SvPVX(name))[0] = '@';
1062 (SvPVX(name))[0] = '%';
1065 (SvPVX(name))[0] = '*';
1068 (SvPVX(name))[0] = '$';
1073 (SvPVX(name))[0] = '$';
1075 else if ((SvPVX_const(name))[0] != '$')
1076 sv_insert(name, 0, 0, "$", 1);
1080 sv_setpvn(name, "$", 1);
1081 sv_catsv(name, varname);
1082 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1083 nchars = strlen(tmpbuf);
1084 sv_catpvn(name, tmpbuf, nchars);
1088 SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1089 newapad = newSVsv(apad);
1090 sv_catsv(newapad, tmpsv);
1091 SvREFCNT_dec(tmpsv);
1096 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1097 postav, &level, indent, pad, xpad, newapad, sep, pair,
1098 freezer, toaster, purity, deepcopy, quotekeys,
1099 bless, maxdepth, sortkeys);
1102 SvREFCNT_dec(newapad);
1104 postlen = av_len(postav);
1105 if (postlen >= 0 || !terse) {
1106 sv_insert(valstr, 0, 0, " = ", 3);
1107 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1108 sv_catpvn(valstr, ";", 1);
1110 sv_catsv(retval, pad);
1111 sv_catsv(retval, valstr);
1112 sv_catsv(retval, sep);
1115 sv_catsv(retval, pad);
1116 for (i = 0; i <= postlen; ++i) {
1118 svp = av_fetch(postav, i, FALSE);
1119 if (svp && (elem = *svp)) {
1120 sv_catsv(retval, elem);
1122 sv_catpvn(retval, ";", 1);
1123 sv_catsv(retval, sep);
1124 sv_catsv(retval, pad);
1128 sv_catpvn(retval, ";", 1);
1129 sv_catsv(retval, sep);
1131 sv_setpvn(valstr, "", 0);
1132 if (gimme == G_ARRAY) {
1133 XPUSHs(sv_2mortal(retval));
1134 if (i < imax) /* not the last time thro ? */
1135 retval = newSVpvn("",0);
1138 SvREFCNT_dec(postav);
1139 SvREFCNT_dec(valstr);
1142 croak("Call to new() method failed to return HASH ref");
1143 if (gimme == G_SCALAR)
1144 XPUSHs(sv_2mortal(retval));