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, char *str, STRLEN len, I32 n);
10 static I32 DD_dump (pTHX_ SV *val, 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);
17 #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
20 # define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
22 # define UNI_TO_NATIVE(ch) (ch)
26 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
28 UV uv = utf8_to_uv(s, UTF8_MAXLEN, retlen,
29 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
30 return UNI_TO_NATIVE(uv);
33 # if !defined(PERL_IMPLICIT_CONTEXT)
34 # define utf8_to_uvchr Perl_utf8_to_uvchr
36 # define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
39 #endif /* PERL_VERSION <= 6 */
41 /* Changes in 5.7 series mean that now IOK is only set if scalar is
42 precisely integer but in 5.6 and earlier we need to do a more
45 #define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
47 #define DD_is_integer(sv) SvIOK(sv)
50 /* does a string need to be protected? */
52 needs_quote(register char *s)
77 /* count the number of "'"s and "\"s in string */
79 num_q(register char *s, register STRLEN slen)
84 if (*s == '\'' || *s == '\\')
93 /* returns number of chars added to escape "'"s and "\"s in s */
94 /* slen number of characters in s will be escaped */
95 /* destination must be long enough for additional chars */
97 esc_q(register char *d, register char *s, register STRLEN slen)
117 esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen)
119 char *s, *send, *r, *rstart;
120 STRLEN j, cur = SvCUR(sv);
121 /* Could count 128-255 and 256+ in two variables, if we want to
122 be like &qquote and make a distinction. */
123 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
124 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
125 STRLEN backslashes = 0;
126 STRLEN single_quotes = 0;
127 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
130 /* this will need EBCDICification */
131 for (s = src, send = src + slen; s < send; s += UTF8SKIP(s)) {
132 UV k = utf8_to_uvchr((U8*)s, NULL);
135 /* 4: \x{} then count the number of hex digits. */
136 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
138 8 /* We may allocate a bit more than the minimum here. */
140 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
143 } else if (k == '\\') {
145 } else if (k == '\'') {
147 } else if (k == '"' || k == '$' || k == '@') {
154 /* We have something needing hex. 3 is ""\0 */
155 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
156 + 2*qq_escapables + normal);
157 rstart = r = SvPVX(sv) + cur;
161 for (s = src; s < send; s += UTF8SKIP(s)) {
162 UV k = utf8_to_uvchr((U8*)s, NULL);
164 if (k == '"' || k == '\\' || k == '$' || k == '@') {
171 /* The return value of sprintf() is unportable.
172 * In modern systems it returns (int) the number of characters,
173 * but in older systems it might return (char*) the original
174 * buffer, or it might even be (void). The easiest portable
175 * thing to do is probably use sprintf() in void context and
176 * then strlen(buffer) for the length. The more proper way
177 * would of course be to figure out the prototype of sprintf.
179 sprintf(r, "\\x{%"UVxf"}", k);
186 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
187 + qq_escapables + normal);
188 rstart = r = SvPVX(sv) + cur;
190 for (s = src; s < send; s ++) {
192 if (k == '\'' || k == '\\')
200 SvCUR_set(sv, cur + j);
205 /* append a repeated string to an SV */
207 sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n)
210 sv = newSVpvn("", 0);
212 assert(SvTYPE(sv) >= SVt_PV);
215 SvGROW(sv, len*n + SvCUR(sv) + 1);
217 char *start = SvPVX(sv) + SvCUR(sv);
218 SvCUR_set(sv, SvCUR(sv) + n);
225 sv_catpvn(sv, str, len);
233 * This ought to be split into smaller functions. (it is one long function since
234 * it exactly parallels the perl version, which was one long thing for
235 * efficiency raisins.) Ugggh!
238 DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
239 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
240 SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
241 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
245 char *c, *r, *realpack, id[128];
247 SV *sv, *ipad, *ival;
248 SV *blesspad = Nullsv;
249 AV *seenentry = Nullav;
251 STRLEN inamelen, idlen = 0;
257 realtype = SvTYPE(val);
263 /* If a freeze method is provided and the object has it, call
264 it. Warn on errors. */
265 if (SvOBJECT(SvRV(val)) && freezer &&
266 SvPOK(freezer) && SvCUR(freezer) &&
267 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX(freezer),
268 SvCUR(freezer), -1) != NULL)
270 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
271 XPUSHs(val); PUTBACK;
272 i = perl_call_method(SvPVX(freezer), G_EVAL|G_VOID);
275 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
276 PUTBACK; FREETMPS; LEAVE;
280 realtype = SvTYPE(ival);
281 (void) sprintf(id, "0x%"UVxf, PTR2UV(ival));
284 realpack = HvNAME(SvSTASH(ival));
288 /* if it has a name, we need to either look it up, or keep a tab
289 * on it so we know when we hit it later
292 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
293 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
296 if ((svp = av_fetch(seenentry, 0, FALSE))
297 && (othername = *svp))
299 if (purity && *levelp > 0) {
302 if (realtype == SVt_PVHV)
303 sv_catpvn(retval, "{}", 2);
304 else if (realtype == SVt_PVAV)
305 sv_catpvn(retval, "[]", 2);
307 sv_catpvn(retval, "do{my $o}", 9);
308 postentry = newSVpvn(name, namelen);
309 sv_catpvn(postentry, " = ", 3);
310 sv_catsv(postentry, othername);
311 av_push(postav, postentry);
314 if (name[0] == '@' || name[0] == '%') {
315 if ((SvPVX(othername))[0] == '\\' &&
316 (SvPVX(othername))[1] == name[0]) {
317 sv_catpvn(retval, SvPVX(othername)+1,
321 sv_catpvn(retval, name, 1);
322 sv_catpvn(retval, "{", 1);
323 sv_catsv(retval, othername);
324 sv_catpvn(retval, "}", 1);
328 sv_catsv(retval, othername);
333 warn("ref name not found for %s", id);
337 else { /* store our name and continue */
339 if (name[0] == '@' || name[0] == '%') {
340 namesv = newSVpvn("\\", 1);
341 sv_catpvn(namesv, name, namelen);
343 else if (realtype == SVt_PVCV && name[0] == '*') {
344 namesv = newSVpvn("\\", 2);
345 sv_catpvn(namesv, name, namelen);
346 (SvPVX(namesv))[1] = '&';
349 namesv = newSVpvn(name, namelen);
351 av_push(seenentry, namesv);
352 (void)SvREFCNT_inc(val);
353 av_push(seenentry, val);
354 (void)hv_store(seenhv, id, strlen(id),
355 newRV_inc((SV*)seenentry), 0);
356 SvREFCNT_dec(seenentry);
360 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
362 char *rval = SvPV(val, rlen);
363 char *slash = strchr(rval, '/');
364 sv_catpvn(retval, "qr/", 3);
366 sv_catpvn(retval, rval, slash-rval);
367 sv_catpvn(retval, "\\/", 2);
368 rlen -= slash-rval+1;
370 slash = strchr(rval, '/');
372 sv_catpvn(retval, rval, rlen);
373 sv_catpvn(retval, "/", 1);
377 /* If purity is not set and maxdepth is set, then check depth:
378 * if we have reached maximum depth, return the string
379 * representation of the thing we are currently examining
380 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
382 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
384 char *valstr = SvPV(val,vallen);
385 sv_catpvn(retval, "'", 1);
386 sv_catpvn(retval, valstr, vallen);
387 sv_catpvn(retval, "'", 1);
391 if (realpack) { /* we have a blessed ref */
393 char *blessstr = SvPV(bless, blesslen);
394 sv_catpvn(retval, blessstr, blesslen);
395 sv_catpvn(retval, "( ", 2);
398 apad = newSVsv(apad);
399 sv_x(aTHX_ apad, " ", 1, blesslen+2);
404 ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
406 if (realtype <= SVt_PVBM) { /* scalar ref */
407 SV *namesv = newSVpvn("${", 2);
408 sv_catpvn(namesv, name, namelen);
409 sv_catpvn(namesv, "}", 1);
410 if (realpack) { /* blessed */
411 sv_catpvn(retval, "do{\\(my $o = ", 13);
412 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
413 postav, levelp, indent, pad, xpad, apad, sep, pair,
414 freezer, toaster, purity, deepcopy, quotekeys, bless,
416 sv_catpvn(retval, ")}", 2);
419 sv_catpvn(retval, "\\", 1);
420 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
421 postav, levelp, indent, pad, xpad, apad, sep, pair,
422 freezer, toaster, purity, deepcopy, quotekeys, bless,
425 SvREFCNT_dec(namesv);
427 else if (realtype == SVt_PVGV) { /* glob ref */
428 SV *namesv = newSVpvn("*{", 2);
429 sv_catpvn(namesv, name, namelen);
430 sv_catpvn(namesv, "}", 1);
431 sv_catpvn(retval, "\\", 1);
432 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
433 postav, levelp, indent, pad, xpad, apad, sep, pair,
434 freezer, toaster, purity, deepcopy, quotekeys, bless,
436 SvREFCNT_dec(namesv);
438 else if (realtype == SVt_PVAV) {
441 I32 ixmax = av_len((AV *)ival);
443 SV *ixsv = newSViv(0);
444 /* allowing for a 24 char wide array index */
445 New(0, iname, namelen+28, char);
446 (void)strcpy(iname, name);
448 if (name[0] == '@') {
449 sv_catpvn(retval, "(", 1);
453 sv_catpvn(retval, "[", 1);
454 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
456 && name[namelen-1] != ']' && name[namelen-1] != '}'
457 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
459 && name[namelen-1] != ']' && name[namelen-1] != '}')
462 || (name[0] == '\\' && name[2] == '{'))))
464 iname[inamelen++] = '-'; iname[inamelen++] = '>';
465 iname[inamelen] = '\0';
468 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
469 (instr(iname+inamelen-8, "{SCALAR}") ||
470 instr(iname+inamelen-7, "{ARRAY}") ||
471 instr(iname+inamelen-6, "{HASH}"))) {
472 iname[inamelen++] = '-'; iname[inamelen++] = '>';
474 iname[inamelen++] = '['; iname[inamelen] = '\0';
475 totpad = newSVsv(sep);
476 sv_catsv(totpad, pad);
477 sv_catsv(totpad, apad);
479 for (ix = 0; ix <= ixmax; ++ix) {
482 svp = av_fetch((AV*)ival, ix, FALSE);
490 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
491 ilen = strlen(iname);
492 iname[ilen++] = ']'; iname[ilen] = '\0';
494 sv_catsv(retval, totpad);
495 sv_catsv(retval, ipad);
496 sv_catpvn(retval, "#", 1);
497 sv_catsv(retval, ixsv);
499 sv_catsv(retval, totpad);
500 sv_catsv(retval, ipad);
501 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
502 levelp, indent, pad, xpad, apad, sep, pair,
503 freezer, toaster, purity, deepcopy, quotekeys, bless,
506 sv_catpvn(retval, ",", 1);
509 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
510 sv_catsv(retval, totpad);
511 sv_catsv(retval, opad);
515 sv_catpvn(retval, ")", 1);
517 sv_catpvn(retval, "]", 1);
519 SvREFCNT_dec(totpad);
522 else if (realtype == SVt_PVHV) {
523 SV *totpad, *newapad;
531 iname = newSVpvn(name, namelen);
532 if (name[0] == '%') {
533 sv_catpvn(retval, "(", 1);
534 (SvPVX(iname))[0] = '$';
537 sv_catpvn(retval, "{", 1);
538 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
540 && name[namelen-1] != ']' && name[namelen-1] != '}')
543 || (name[0] == '\\' && name[2] == '{'))))
545 sv_catpvn(iname, "->", 2);
548 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
549 (instr(name+namelen-8, "{SCALAR}") ||
550 instr(name+namelen-7, "{ARRAY}") ||
551 instr(name+namelen-6, "{HASH}"))) {
552 sv_catpvn(iname, "->", 2);
554 sv_catpvn(iname, "{", 1);
555 totpad = newSVsv(sep);
556 sv_catsv(totpad, pad);
557 sv_catsv(totpad, apad);
559 /* If requested, get a sorted/filtered array of hash keys */
561 if (sortkeys == &PL_sv_yes) {
563 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
566 (void)hv_iterinit((HV*)ival);
567 while ((entry = hv_iternext((HV*)ival))) {
568 sv = hv_iterkeysv(entry);
572 # ifdef USE_LOCALE_NUMERIC
573 sortsv(AvARRAY(keys),
575 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
577 sortsv(AvARRAY(keys),
583 if (sortkeys != &PL_sv_yes) {
584 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
585 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
586 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
590 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
591 keys = (AV*)SvREFCNT_inc(SvRV(sv));
594 warn("Sortkeys subroutine did not return ARRAYREF\n");
595 PUTBACK; FREETMPS; LEAVE;
598 sv_2mortal((SV*)keys);
601 (void)hv_iterinit((HV*)ival);
603 /* foreach (keys %hash) */
604 for (i = 0; 1; i++) {
606 char *nkey_buffer = NULL;
611 bool do_utf8 = FALSE;
613 if ((sortkeys && !(keys && (I32)i <= av_len(keys))) ||
614 !(entry = hv_iternext((HV *)ival)))
618 sv_catpvn(retval, ",", 1);
622 svp = av_fetch(keys, i, FALSE);
623 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
624 key = SvPV(keysv, keylen);
625 svp = hv_fetch((HV*)ival, key,
626 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
627 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
630 keysv = hv_iterkeysv(entry);
631 hval = hv_iterval((HV*)ival, entry);
634 do_utf8 = DO_UTF8(keysv);
635 key = SvPV(keysv, keylen);
638 sv_catsv(retval, totpad);
639 sv_catsv(retval, ipad);
640 /* old logic was first to check utf8 flag, and if utf8 always
641 call esc_q_utf8. This caused test to break under -Mutf8,
642 because there even strings like 'c' have utf8 flag on.
643 Hence with quotekeys == 0 the XS code would still '' quote
644 them based on flags, whereas the perl code would not,
646 The perl code is correct.
647 needs_quote() decides that anything that isn't a valid
648 perl identifier needs to be quoted, hence only correctly
649 formed strings with no characters outside [A-Za-z0-9_:]
650 won't need quoting. None of those characters are used in
651 the byte encoding of utf8, so anything with utf8
652 encoded characters in will need quoting. Hence strings
653 with utf8 encoded characters in will end up inside do_utf8
654 just like before, but now strings with utf8 flag set but
655 only ascii characters will end up in the unquoted section.
657 There should also be less tests for the (probably currently)
658 more common doesn't need quoting case.
659 The code is also smaller (22044 vs 22260) because I've been
660 able to pull the common logic out to both sides. */
661 if (quotekeys || needs_quote(key)) {
663 STRLEN ocur = SvCUR(retval);
664 nlen = esc_q_utf8(aTHX_ retval, key, klen);
665 nkey = SvPVX(retval) + ocur;
668 nticks = num_q(key, klen);
669 New(0, nkey_buffer, klen+nticks+3, char);
673 klen += esc_q(nkey+1, key, klen);
675 (void)Copy(key, nkey+1, klen, char);
679 sv_catpvn(retval, nkey, klen);
685 sv_catpvn(retval, nkey, klen);
687 sname = newSVsv(iname);
688 sv_catpvn(sname, nkey, nlen);
689 sv_catpvn(sname, "}", 1);
691 sv_catsv(retval, pair);
695 newapad = newSVsv(apad);
696 New(0, extra, klen+4+1, char);
697 while (elen < (klen+4))
700 sv_catpvn(newapad, extra, elen);
706 DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
707 postav, levelp, indent, pad, xpad, newapad, sep, pair,
708 freezer, toaster, purity, deepcopy, quotekeys, bless,
711 Safefree(nkey_buffer);
713 SvREFCNT_dec(newapad);
716 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
717 sv_catsv(retval, totpad);
718 sv_catsv(retval, opad);
722 sv_catpvn(retval, ")", 1);
724 sv_catpvn(retval, "}", 1);
726 SvREFCNT_dec(totpad);
728 else if (realtype == SVt_PVCV) {
729 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
731 warn("Encountered CODE ref, using dummy placeholder");
734 warn("cannot handle ref type %ld", realtype);
737 if (realpack) { /* free blessed allocs */
742 sv_catpvn(retval, ", '", 3);
743 sv_catpvn(retval, realpack, strlen(realpack));
744 sv_catpvn(retval, "' )", 3);
745 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
746 sv_catpvn(retval, "->", 2);
747 sv_catsv(retval, toaster);
748 sv_catpvn(retval, "()", 2);
758 (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
759 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
760 (sv = *svp) && SvROK(sv) &&
761 (seenentry = (AV*)SvRV(sv)))
764 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
765 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
767 sv_catpvn(retval, "${", 2);
768 sv_catsv(retval, othername);
769 sv_catpvn(retval, "}", 1);
773 else if (val != &PL_sv_undef) {
775 namesv = newSVpvn("\\", 1);
776 sv_catpvn(namesv, name, namelen);
778 av_push(seenentry, namesv);
779 av_push(seenentry, newRV_inc(val));
780 (void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0);
781 SvREFCNT_dec(seenentry);
785 if (DD_is_integer(val)) {
788 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
790 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
791 len = strlen(tmpbuf);
793 /* Need to check to see if this is a string such as " 0".
794 I'm assuming from sprintf isn't going to clash with utf8.
795 Is this valid on EBCDIC? */
797 const char *pv = SvPV(val, pvlen);
798 if (pvlen != len || memNE(pv, tmpbuf, len))
799 goto integer_came_from_string;
802 /* Looks like we're on a 64 bit system. Make it a string so that
803 if a 32 bit system reads the number it will cope better. */
804 sv_catpvf(retval, "'%s'", tmpbuf);
806 sv_catpvn(retval, tmpbuf, len);
808 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
810 ++c; --i; /* just get the name */
811 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
815 if (needs_quote(c)) {
816 sv_grow(retval, SvCUR(retval)+6+2*i);
817 r = SvPVX(retval)+SvCUR(retval);
818 r[0] = '*'; r[1] = '{'; r[2] = '\'';
819 i += esc_q(r+3, c, i);
821 r[i++] = '\''; r[i++] = '}';
825 sv_grow(retval, SvCUR(retval)+i+2);
826 r = SvPVX(retval)+SvCUR(retval);
827 r[0] = '*'; strcpy(r+1, c);
830 SvCUR_set(retval, SvCUR(retval)+i);
833 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
834 static const STRLEN sizes[] = { 8, 7, 6 };
836 SV *nname = newSVpvn("", 0);
837 SV *newapad = newSVpvn("", 0);
841 for (j=0; j<3; j++) {
842 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
845 if (j == 0 && !SvOK(e))
850 SV *postentry = newSVpvn(r,i);
852 sv_setsv(nname, postentry);
853 sv_catpvn(nname, entries[j], sizes[j]);
854 sv_catpvn(postentry, " = ", 3);
855 av_push(postav, postentry);
858 SvCUR_set(newapad, 0);
860 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
862 DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
863 seenhv, postav, &nlevel, indent, pad, xpad,
864 newapad, sep, pair, freezer, toaster, purity,
865 deepcopy, quotekeys, bless, maxdepth,
871 SvREFCNT_dec(newapad);
875 else if (val == &PL_sv_undef || !SvOK(val)) {
876 sv_catpvn(retval, "undef", 5);
879 integer_came_from_string:
882 i += esc_q_utf8(aTHX_ retval, c, i);
884 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
885 r = SvPVX(retval) + SvCUR(retval);
887 i += esc_q(r+1, c, i);
891 SvCUR_set(retval, SvCUR(retval)+i);
898 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
899 else if (namelen && seenentry) {
900 SV *mark = *av_fetch(seenentry, 2, TRUE);
908 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
911 # This is the exact equivalent of Dump. Well, almost. The things that are
912 # different as of now (due to Laziness):
913 # * doesnt do double-quotes yet.
917 Data_Dumper_Dumpxs(href, ...)
925 AV *postav, *todumpav, *namesav;
927 I32 indent, terse, i, imax, postlen;
929 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
930 SV *freezer, *toaster, *bless, *sortkeys;
931 I32 purity, deepcopy, quotekeys, maxdepth = 0;
935 if (!SvROK(href)) { /* call new to get an object first */
937 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
944 XPUSHs(sv_2mortal(newSVsv(ST(1))));
946 XPUSHs(sv_2mortal(newSVsv(ST(2))));
948 i = perl_call_method("new", G_SCALAR);
951 href = newSVsv(POPs);
957 (void)sv_2mortal(href);
960 todumpav = namesav = Nullav;
962 val = pad = xpad = apad = sep = pair = varname
963 = freezer = toaster = bless = &PL_sv_undef;
964 name = sv_newmortal();
966 terse = purity = deepcopy = 0;
969 retval = newSVpvn("", 0);
971 && (hv = (HV*)SvRV((SV*)href))
972 && SvTYPE(hv) == SVt_PVHV) {
974 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
975 seenhv = (HV*)SvRV(*svp);
976 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
977 todumpav = (AV*)SvRV(*svp);
978 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
979 namesav = (AV*)SvRV(*svp);
980 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
982 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
984 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
985 terse = SvTRUE(*svp);
986 #if 0 /* useqq currently unused */
987 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
988 useqq = SvTRUE(*svp);
990 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
992 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
994 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
996 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
998 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1000 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1002 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1004 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1006 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1007 deepcopy = SvTRUE(*svp);
1008 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1009 quotekeys = SvTRUE(*svp);
1010 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1012 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1013 maxdepth = SvIV(*svp);
1014 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1016 if (! SvTRUE(sortkeys))
1018 else if (! (SvROK(sortkeys) &&
1019 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1021 /* flag to use qsortsv() for sorting hash keys */
1022 sortkeys = &PL_sv_yes;
1028 imax = av_len(todumpav);
1031 valstr = newSVpvn("",0);
1032 for (i = 0; i <= imax; ++i) {
1036 if ((svp = av_fetch(todumpav, i, FALSE)))
1040 if ((svp = av_fetch(namesav, i, TRUE)))
1041 sv_setsv(name, *svp);
1043 (void)SvOK_off(name);
1046 if ((SvPVX(name))[0] == '*') {
1048 switch (SvTYPE(SvRV(val))) {
1050 (SvPVX(name))[0] = '@';
1053 (SvPVX(name))[0] = '%';
1056 (SvPVX(name))[0] = '*';
1059 (SvPVX(name))[0] = '$';
1064 (SvPVX(name))[0] = '$';
1066 else if ((SvPVX(name))[0] != '$')
1067 sv_insert(name, 0, 0, "$", 1);
1071 sv_setpvn(name, "$", 1);
1072 sv_catsv(name, varname);
1073 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1074 nchars = strlen(tmpbuf);
1075 sv_catpvn(name, tmpbuf, nchars);
1079 SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1080 newapad = newSVsv(apad);
1081 sv_catsv(newapad, tmpsv);
1082 SvREFCNT_dec(tmpsv);
1087 DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
1088 postav, &level, indent, pad, xpad, newapad, sep, pair,
1089 freezer, toaster, purity, deepcopy, quotekeys,
1090 bless, maxdepth, sortkeys);
1093 SvREFCNT_dec(newapad);
1095 postlen = av_len(postav);
1096 if (postlen >= 0 || !terse) {
1097 sv_insert(valstr, 0, 0, " = ", 3);
1098 sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
1099 sv_catpvn(valstr, ";", 1);
1101 sv_catsv(retval, pad);
1102 sv_catsv(retval, valstr);
1103 sv_catsv(retval, sep);
1106 sv_catsv(retval, pad);
1107 for (i = 0; i <= postlen; ++i) {
1109 svp = av_fetch(postav, i, FALSE);
1110 if (svp && (elem = *svp)) {
1111 sv_catsv(retval, elem);
1113 sv_catpvn(retval, ";", 1);
1114 sv_catsv(retval, sep);
1115 sv_catsv(retval, pad);
1119 sv_catpvn(retval, ";", 1);
1120 sv_catsv(retval, sep);
1122 sv_setpvn(valstr, "", 0);
1123 if (gimme == G_ARRAY) {
1124 XPUSHs(sv_2mortal(retval));
1125 if (i < imax) /* not the last time thro ? */
1126 retval = newSVpvn("",0);
1129 SvREFCNT_dec(postav);
1130 SvREFCNT_dec(valstr);
1133 croak("Call to new() method failed to return HASH ref");
1134 if (gimme == G_SCALAR)
1135 XPUSHs(sv_2mortal(retval));