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);
217 assert(SvTYPE(sv) >= SVt_PV);
221 SvGROW(sv, len*n + SvCUR(sv) + 1);
223 char *start = SvPVX(sv) + SvCUR(sv);
224 SvCUR_set(sv, SvCUR(sv) + n);
231 sv_catpvn(sv, str, len);
239 * This ought to be split into smaller functions. (it is one long function since
240 * it exactly parallels the perl version, which was one long thing for
241 * efficiency raisins.) Ugggh!
244 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
245 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
246 SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
247 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
251 char *c, *r, *realpack, id[128];
253 SV *sv, *ipad, *ival;
254 SV *blesspad = Nullsv;
255 AV *seenentry = NULL;
257 STRLEN inamelen, idlen = 0;
263 realtype = SvTYPE(val);
269 /* If a freeze method is provided and the object has it, call
270 it. Warn on errors. */
271 if (SvOBJECT(SvRV(val)) && freezer &&
272 SvPOK(freezer) && SvCUR(freezer) &&
273 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
274 SvCUR(freezer), -1) != NULL)
276 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
277 XPUSHs(val); PUTBACK;
278 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
281 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
282 PUTBACK; FREETMPS; LEAVE;
286 realtype = SvTYPE(ival);
287 (void) sprintf(id, "0x%"UVxf, PTR2UV(ival));
290 realpack = HvNAME_get(SvSTASH(ival));
294 /* if it has a name, we need to either look it up, or keep a tab
295 * on it so we know when we hit it later
298 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
299 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
302 if ((svp = av_fetch(seenentry, 0, FALSE))
303 && (othername = *svp))
305 if (purity && *levelp > 0) {
308 if (realtype == SVt_PVHV)
309 sv_catpvn(retval, "{}", 2);
310 else if (realtype == SVt_PVAV)
311 sv_catpvn(retval, "[]", 2);
313 sv_catpvn(retval, "do{my $o}", 9);
314 postentry = newSVpvn(name, namelen);
315 sv_catpvn(postentry, " = ", 3);
316 sv_catsv(postentry, othername);
317 av_push(postav, postentry);
320 if (name[0] == '@' || name[0] == '%') {
321 if ((SvPVX_const(othername))[0] == '\\' &&
322 (SvPVX_const(othername))[1] == name[0]) {
323 sv_catpvn(retval, SvPVX_const(othername)+1,
327 sv_catpvn(retval, name, 1);
328 sv_catpvn(retval, "{", 1);
329 sv_catsv(retval, othername);
330 sv_catpvn(retval, "}", 1);
334 sv_catsv(retval, othername);
339 warn("ref name not found for %s", id);
343 else { /* store our name and continue */
345 if (name[0] == '@' || name[0] == '%') {
346 namesv = newSVpvn("\\", 1);
347 sv_catpvn(namesv, name, namelen);
349 else if (realtype == SVt_PVCV && name[0] == '*') {
350 namesv = newSVpvn("\\", 2);
351 sv_catpvn(namesv, name, namelen);
352 (SvPVX(namesv))[1] = '&';
355 namesv = newSVpvn(name, namelen);
357 av_push(seenentry, namesv);
358 (void)SvREFCNT_inc(val);
359 av_push(seenentry, val);
360 (void)hv_store(seenhv, id, strlen(id),
361 newRV_inc((SV*)seenentry), 0);
362 SvREFCNT_dec(seenentry);
366 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
368 char *rval = SvPV(val, rlen);
369 char *slash = strchr(rval, '/');
370 sv_catpvn(retval, "qr/", 3);
372 sv_catpvn(retval, rval, slash-rval);
373 sv_catpvn(retval, "\\/", 2);
374 rlen -= slash-rval+1;
376 slash = strchr(rval, '/');
378 sv_catpvn(retval, rval, rlen);
379 sv_catpvn(retval, "/", 1);
383 /* If purity is not set and maxdepth is set, then check depth:
384 * if we have reached maximum depth, return the string
385 * representation of the thing we are currently examining
386 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
388 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
390 char *valstr = SvPV(val,vallen);
391 sv_catpvn(retval, "'", 1);
392 sv_catpvn(retval, valstr, vallen);
393 sv_catpvn(retval, "'", 1);
397 if (realpack) { /* we have a blessed ref */
399 char *blessstr = SvPV(bless, blesslen);
400 sv_catpvn(retval, blessstr, blesslen);
401 sv_catpvn(retval, "( ", 2);
404 apad = newSVsv(apad);
405 sv_x(aTHX_ apad, " ", 1, blesslen+2);
410 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
412 if (realtype <= SVt_PVBM) { /* scalar ref */
413 SV *namesv = newSVpvn("${", 2);
414 sv_catpvn(namesv, name, namelen);
415 sv_catpvn(namesv, "}", 1);
416 if (realpack) { /* blessed */
417 sv_catpvn(retval, "do{\\(my $o = ", 13);
418 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
419 postav, levelp, indent, pad, xpad, apad, sep, pair,
420 freezer, toaster, purity, deepcopy, quotekeys, bless,
422 sv_catpvn(retval, ")}", 2);
425 sv_catpvn(retval, "\\", 1);
426 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
427 postav, levelp, indent, pad, xpad, apad, sep, pair,
428 freezer, toaster, purity, deepcopy, quotekeys, bless,
431 SvREFCNT_dec(namesv);
433 else if (realtype == SVt_PVGV) { /* glob ref */
434 SV *namesv = newSVpvn("*{", 2);
435 sv_catpvn(namesv, name, namelen);
436 sv_catpvn(namesv, "}", 1);
437 sv_catpvn(retval, "\\", 1);
438 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
439 postav, levelp, indent, pad, xpad, apad, sep, pair,
440 freezer, toaster, purity, deepcopy, quotekeys, bless,
442 SvREFCNT_dec(namesv);
444 else if (realtype == SVt_PVAV) {
447 I32 ixmax = av_len((AV *)ival);
449 SV *ixsv = newSViv(0);
450 /* allowing for a 24 char wide array index */
451 New(0, iname, namelen+28, char);
452 (void)strcpy(iname, name);
454 if (name[0] == '@') {
455 sv_catpvn(retval, "(", 1);
459 sv_catpvn(retval, "[", 1);
460 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
462 && name[namelen-1] != ']' && name[namelen-1] != '}'
463 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
465 && name[namelen-1] != ']' && name[namelen-1] != '}')
468 || (name[0] == '\\' && name[2] == '{'))))
470 iname[inamelen++] = '-'; iname[inamelen++] = '>';
471 iname[inamelen] = '\0';
474 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
475 (instr(iname+inamelen-8, "{SCALAR}") ||
476 instr(iname+inamelen-7, "{ARRAY}") ||
477 instr(iname+inamelen-6, "{HASH}"))) {
478 iname[inamelen++] = '-'; iname[inamelen++] = '>';
480 iname[inamelen++] = '['; iname[inamelen] = '\0';
481 totpad = newSVsv(sep);
482 sv_catsv(totpad, pad);
483 sv_catsv(totpad, apad);
485 for (ix = 0; ix <= ixmax; ++ix) {
488 svp = av_fetch((AV*)ival, ix, FALSE);
496 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
497 ilen = strlen(iname);
498 iname[ilen++] = ']'; iname[ilen] = '\0';
500 sv_catsv(retval, totpad);
501 sv_catsv(retval, ipad);
502 sv_catpvn(retval, "#", 1);
503 sv_catsv(retval, ixsv);
505 sv_catsv(retval, totpad);
506 sv_catsv(retval, ipad);
507 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
508 levelp, indent, pad, xpad, apad, sep, pair,
509 freezer, toaster, purity, deepcopy, quotekeys, bless,
512 sv_catpvn(retval, ",", 1);
515 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
516 sv_catsv(retval, totpad);
517 sv_catsv(retval, opad);
521 sv_catpvn(retval, ")", 1);
523 sv_catpvn(retval, "]", 1);
525 SvREFCNT_dec(totpad);
528 else if (realtype == SVt_PVHV) {
529 SV *totpad, *newapad;
537 iname = newSVpvn(name, namelen);
538 if (name[0] == '%') {
539 sv_catpvn(retval, "(", 1);
540 (SvPVX(iname))[0] = '$';
543 sv_catpvn(retval, "{", 1);
544 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
546 && name[namelen-1] != ']' && name[namelen-1] != '}')
549 || (name[0] == '\\' && name[2] == '{'))))
551 sv_catpvn(iname, "->", 2);
554 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
555 (instr(name+namelen-8, "{SCALAR}") ||
556 instr(name+namelen-7, "{ARRAY}") ||
557 instr(name+namelen-6, "{HASH}"))) {
558 sv_catpvn(iname, "->", 2);
560 sv_catpvn(iname, "{", 1);
561 totpad = newSVsv(sep);
562 sv_catsv(totpad, pad);
563 sv_catsv(totpad, apad);
565 /* If requested, get a sorted/filtered array of hash keys */
567 if (sortkeys == &PL_sv_yes) {
569 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
572 (void)hv_iterinit((HV*)ival);
573 while ((entry = hv_iternext((HV*)ival))) {
574 sv = hv_iterkeysv(entry);
578 # ifdef USE_LOCALE_NUMERIC
579 sortsv(AvARRAY(keys),
581 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
583 sortsv(AvARRAY(keys),
589 if (sortkeys != &PL_sv_yes) {
590 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
591 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
592 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
596 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
597 keys = (AV*)SvREFCNT_inc(SvRV(sv));
600 warn("Sortkeys subroutine did not return ARRAYREF\n");
601 PUTBACK; FREETMPS; LEAVE;
604 sv_2mortal((SV*)keys);
607 (void)hv_iterinit((HV*)ival);
609 /* foreach (keys %hash) */
610 for (i = 0; 1; i++) {
612 char *nkey_buffer = NULL;
617 bool do_utf8 = FALSE;
620 if (!(keys && (I32)i <= av_len(keys))) break;
622 if (!(entry = hv_iternext((HV *)ival))) break;
626 sv_catpvn(retval, ",", 1);
630 svp = av_fetch(keys, i, FALSE);
631 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
632 key = SvPV(keysv, keylen);
633 svp = hv_fetch((HV*)ival, key,
634 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
635 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
638 keysv = hv_iterkeysv(entry);
639 hval = hv_iterval((HV*)ival, entry);
642 do_utf8 = DO_UTF8(keysv);
643 key = SvPV(keysv, keylen);
646 sv_catsv(retval, totpad);
647 sv_catsv(retval, ipad);
648 /* old logic was first to check utf8 flag, and if utf8 always
649 call esc_q_utf8. This caused test to break under -Mutf8,
650 because there even strings like 'c' have utf8 flag on.
651 Hence with quotekeys == 0 the XS code would still '' quote
652 them based on flags, whereas the perl code would not,
654 The perl code is correct.
655 needs_quote() decides that anything that isn't a valid
656 perl identifier needs to be quoted, hence only correctly
657 formed strings with no characters outside [A-Za-z0-9_:]
658 won't need quoting. None of those characters are used in
659 the byte encoding of utf8, so anything with utf8
660 encoded characters in will need quoting. Hence strings
661 with utf8 encoded characters in will end up inside do_utf8
662 just like before, but now strings with utf8 flag set but
663 only ascii characters will end up in the unquoted section.
665 There should also be less tests for the (probably currently)
666 more common doesn't need quoting case.
667 The code is also smaller (22044 vs 22260) because I've been
668 able to pull the common logic out to both sides. */
669 if (quotekeys || needs_quote(key)) {
671 STRLEN ocur = SvCUR(retval);
672 nlen = esc_q_utf8(aTHX_ retval, key, klen);
673 nkey = SvPVX(retval) + ocur;
676 nticks = num_q(key, klen);
677 New(0, nkey_buffer, klen+nticks+3, char);
681 klen += esc_q(nkey+1, key, klen);
683 (void)Copy(key, nkey+1, klen, char);
687 sv_catpvn(retval, nkey, klen);
693 sv_catpvn(retval, nkey, klen);
695 sname = newSVsv(iname);
696 sv_catpvn(sname, nkey, nlen);
697 sv_catpvn(sname, "}", 1);
699 sv_catsv(retval, pair);
703 newapad = newSVsv(apad);
704 New(0, extra, klen+4+1, char);
705 while (elen < (klen+4))
708 sv_catpvn(newapad, extra, elen);
714 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
715 postav, levelp, indent, pad, xpad, newapad, sep, pair,
716 freezer, toaster, purity, deepcopy, quotekeys, bless,
719 Safefree(nkey_buffer);
721 SvREFCNT_dec(newapad);
724 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
725 sv_catsv(retval, totpad);
726 sv_catsv(retval, opad);
730 sv_catpvn(retval, ")", 1);
732 sv_catpvn(retval, "}", 1);
734 SvREFCNT_dec(totpad);
736 else if (realtype == SVt_PVCV) {
737 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
739 warn("Encountered CODE ref, using dummy placeholder");
742 warn("cannot handle ref type %ld", realtype);
745 if (realpack) { /* free blessed allocs */
750 sv_catpvn(retval, ", '", 3);
751 sv_catpvn(retval, realpack, strlen(realpack));
752 sv_catpvn(retval, "' )", 3);
753 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
754 sv_catpvn(retval, "->", 2);
755 sv_catsv(retval, toaster);
756 sv_catpvn(retval, "()", 2);
766 (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
767 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
768 (sv = *svp) && SvROK(sv) &&
769 (seenentry = (AV*)SvRV(sv)))
772 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
773 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
775 sv_catpvn(retval, "${", 2);
776 sv_catsv(retval, othername);
777 sv_catpvn(retval, "}", 1);
781 else if (val != &PL_sv_undef) {
783 namesv = newSVpvn("\\", 1);
784 sv_catpvn(namesv, name, namelen);
786 av_push(seenentry, namesv);
787 av_push(seenentry, newRV_inc(val));
788 (void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0);
789 SvREFCNT_dec(seenentry);
793 if (DD_is_integer(val)) {
796 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
798 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
799 len = strlen(tmpbuf);
801 /* Need to check to see if this is a string such as " 0".
802 I'm assuming from sprintf isn't going to clash with utf8.
803 Is this valid on EBCDIC? */
805 const char *pv = SvPV(val, pvlen);
806 if (pvlen != len || memNE(pv, tmpbuf, len))
807 goto integer_came_from_string;
810 /* Looks like we're on a 64 bit system. Make it a string so that
811 if a 32 bit system reads the number it will cope better. */
812 sv_catpvf(retval, "'%s'", tmpbuf);
814 sv_catpvn(retval, tmpbuf, len);
816 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
818 ++c; --i; /* just get the name */
819 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
823 if (needs_quote(c)) {
824 sv_grow(retval, SvCUR(retval)+6+2*i);
825 r = SvPVX(retval)+SvCUR(retval);
826 r[0] = '*'; r[1] = '{'; r[2] = '\'';
827 i += esc_q(r+3, c, i);
829 r[i++] = '\''; r[i++] = '}';
833 sv_grow(retval, SvCUR(retval)+i+2);
834 r = SvPVX(retval)+SvCUR(retval);
835 r[0] = '*'; strcpy(r+1, c);
838 SvCUR_set(retval, SvCUR(retval)+i);
841 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
842 static const STRLEN sizes[] = { 8, 7, 6 };
844 SV *nname = newSVpvn("", 0);
845 SV *newapad = newSVpvn("", 0);
849 for (j=0; j<3; j++) {
850 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
853 if (j == 0 && !SvOK(e))
858 SV *postentry = newSVpvn(r,i);
860 sv_setsv(nname, postentry);
861 sv_catpvn(nname, entries[j], sizes[j]);
862 sv_catpvn(postentry, " = ", 3);
863 av_push(postav, postentry);
866 SvCUR_set(newapad, 0);
868 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
870 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
871 seenhv, postav, &nlevel, indent, pad, xpad,
872 newapad, sep, pair, freezer, toaster, purity,
873 deepcopy, quotekeys, bless, maxdepth,
879 SvREFCNT_dec(newapad);
883 else if (val == &PL_sv_undef || !SvOK(val)) {
884 sv_catpvn(retval, "undef", 5);
887 integer_came_from_string:
890 i += esc_q_utf8(aTHX_ retval, c, i);
892 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
893 r = SvPVX(retval) + SvCUR(retval);
895 i += esc_q(r+1, c, i);
899 SvCUR_set(retval, SvCUR(retval)+i);
906 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
907 else if (namelen && seenentry) {
908 SV *mark = *av_fetch(seenentry, 2, TRUE);
916 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
919 # This is the exact equivalent of Dump. Well, almost. The things that are
920 # different as of now (due to Laziness):
921 # * doesnt do double-quotes yet.
925 Data_Dumper_Dumpxs(href, ...)
933 AV *postav, *todumpav, *namesav;
935 I32 indent, terse, i, imax, postlen;
937 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
938 SV *freezer, *toaster, *bless, *sortkeys;
939 I32 purity, deepcopy, quotekeys, maxdepth = 0;
943 if (!SvROK(href)) { /* call new to get an object first */
945 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
952 XPUSHs(sv_2mortal(newSVsv(ST(1))));
954 XPUSHs(sv_2mortal(newSVsv(ST(2))));
956 i = perl_call_method("new", G_SCALAR);
959 href = newSVsv(POPs);
965 (void)sv_2mortal(href);
968 todumpav = namesav = NULL;
970 val = pad = xpad = apad = sep = pair = varname
971 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
972 name = sv_newmortal();
974 terse = purity = deepcopy = 0;
977 retval = newSVpvn("", 0);
979 && (hv = (HV*)SvRV((SV*)href))
980 && SvTYPE(hv) == SVt_PVHV) {
982 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
983 seenhv = (HV*)SvRV(*svp);
984 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
985 todumpav = (AV*)SvRV(*svp);
986 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
987 namesav = (AV*)SvRV(*svp);
988 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
990 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
992 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
993 terse = SvTRUE(*svp);
994 #if 0 /* useqq currently unused */
995 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
996 useqq = SvTRUE(*svp);
998 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1000 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1002 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1004 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1006 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1008 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1010 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1012 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1014 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1015 deepcopy = SvTRUE(*svp);
1016 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1017 quotekeys = SvTRUE(*svp);
1018 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1020 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1021 maxdepth = SvIV(*svp);
1022 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1024 if (! SvTRUE(sortkeys))
1026 else if (! (SvROK(sortkeys) &&
1027 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1029 /* flag to use qsortsv() for sorting hash keys */
1030 sortkeys = &PL_sv_yes;
1036 imax = av_len(todumpav);
1039 valstr = newSVpvn("",0);
1040 for (i = 0; i <= imax; ++i) {
1044 if ((svp = av_fetch(todumpav, i, FALSE)))
1048 if ((svp = av_fetch(namesav, i, TRUE))) {
1049 sv_setsv(name, *svp);
1050 if (SvOK(*svp) && !SvPOK(*svp))
1051 (void)SvPV_nolen_const(name);
1054 (void)SvOK_off(name);
1057 if ((SvPVX_const(name))[0] == '*') {
1059 switch (SvTYPE(SvRV(val))) {
1061 (SvPVX(name))[0] = '@';
1064 (SvPVX(name))[0] = '%';
1067 (SvPVX(name))[0] = '*';
1070 (SvPVX(name))[0] = '$';
1075 (SvPVX(name))[0] = '$';
1077 else if ((SvPVX_const(name))[0] != '$')
1078 sv_insert(name, 0, 0, "$", 1);
1082 sv_setpvn(name, "$", 1);
1083 sv_catsv(name, varname);
1084 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1085 nchars = strlen(tmpbuf);
1086 sv_catpvn(name, tmpbuf, nchars);
1090 SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1091 newapad = newSVsv(apad);
1092 sv_catsv(newapad, tmpsv);
1093 SvREFCNT_dec(tmpsv);
1098 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1099 postav, &level, indent, pad, xpad, newapad, sep, pair,
1100 freezer, toaster, purity, deepcopy, quotekeys,
1101 bless, maxdepth, sortkeys);
1104 SvREFCNT_dec(newapad);
1106 postlen = av_len(postav);
1107 if (postlen >= 0 || !terse) {
1108 sv_insert(valstr, 0, 0, " = ", 3);
1109 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1110 sv_catpvn(valstr, ";", 1);
1112 sv_catsv(retval, pad);
1113 sv_catsv(retval, valstr);
1114 sv_catsv(retval, sep);
1117 sv_catsv(retval, pad);
1118 for (i = 0; i <= postlen; ++i) {
1120 svp = av_fetch(postav, i, FALSE);
1121 if (svp && (elem = *svp)) {
1122 sv_catsv(retval, elem);
1124 sv_catpvn(retval, ";", 1);
1125 sv_catsv(retval, sep);
1126 sv_catsv(retval, pad);
1130 sv_catpvn(retval, ";", 1);
1131 sv_catsv(retval, sep);
1133 sv_setpvn(valstr, "", 0);
1134 if (gimme == G_ARRAY) {
1135 XPUSHs(sv_2mortal(retval));
1136 if (i < imax) /* not the last time thro ? */
1137 retval = newSVpvn("",0);
1140 SvREFCNT_dec(postav);
1141 SvREFCNT_dec(valstr);
1144 croak("Call to new() method failed to return HASH ref");
1145 if (gimme == G_SCALAR)
1146 XPUSHs(sv_2mortal(retval));