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);
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, register 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, 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(freezer),
272 SvCUR(freezer), -1) != NULL)
274 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
275 XPUSHs(val); PUTBACK;
276 i = perl_call_method(SvPVX(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(othername))[0] == '\\' &&
320 (SvPVX(othername))[1] == name[0]) {
321 sv_catpvn(retval, SvPVX(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(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(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(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(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(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;
617 if ((sortkeys && !(keys && (I32)i <= av_len(keys))) ||
618 !(entry = hv_iternext((HV *)ival)))
622 sv_catpvn(retval, ",", 1);
626 svp = av_fetch(keys, i, FALSE);
627 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
628 key = SvPV(keysv, keylen);
629 svp = hv_fetch((HV*)ival, key,
630 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
631 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
634 keysv = hv_iterkeysv(entry);
635 hval = hv_iterval((HV*)ival, entry);
638 do_utf8 = DO_UTF8(keysv);
639 key = SvPV(keysv, keylen);
642 sv_catsv(retval, totpad);
643 sv_catsv(retval, ipad);
644 /* old logic was first to check utf8 flag, and if utf8 always
645 call esc_q_utf8. This caused test to break under -Mutf8,
646 because there even strings like 'c' have utf8 flag on.
647 Hence with quotekeys == 0 the XS code would still '' quote
648 them based on flags, whereas the perl code would not,
650 The perl code is correct.
651 needs_quote() decides that anything that isn't a valid
652 perl identifier needs to be quoted, hence only correctly
653 formed strings with no characters outside [A-Za-z0-9_:]
654 won't need quoting. None of those characters are used in
655 the byte encoding of utf8, so anything with utf8
656 encoded characters in will need quoting. Hence strings
657 with utf8 encoded characters in will end up inside do_utf8
658 just like before, but now strings with utf8 flag set but
659 only ascii characters will end up in the unquoted section.
661 There should also be less tests for the (probably currently)
662 more common doesn't need quoting case.
663 The code is also smaller (22044 vs 22260) because I've been
664 able to pull the common logic out to both sides. */
665 if (quotekeys || needs_quote(key)) {
667 STRLEN ocur = SvCUR(retval);
668 nlen = esc_q_utf8(aTHX_ retval, key, klen);
669 nkey = SvPVX(retval) + ocur;
672 nticks = num_q(key, klen);
673 New(0, nkey_buffer, klen+nticks+3, char);
677 klen += esc_q(nkey+1, key, klen);
679 (void)Copy(key, nkey+1, klen, char);
683 sv_catpvn(retval, nkey, klen);
689 sv_catpvn(retval, nkey, klen);
691 sname = newSVsv(iname);
692 sv_catpvn(sname, nkey, nlen);
693 sv_catpvn(sname, "}", 1);
695 sv_catsv(retval, pair);
699 newapad = newSVsv(apad);
700 New(0, extra, klen+4+1, char);
701 while (elen < (klen+4))
704 sv_catpvn(newapad, extra, elen);
710 DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
711 postav, levelp, indent, pad, xpad, newapad, sep, pair,
712 freezer, toaster, purity, deepcopy, quotekeys, bless,
715 Safefree(nkey_buffer);
717 SvREFCNT_dec(newapad);
720 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
721 sv_catsv(retval, totpad);
722 sv_catsv(retval, opad);
726 sv_catpvn(retval, ")", 1);
728 sv_catpvn(retval, "}", 1);
730 SvREFCNT_dec(totpad);
732 else if (realtype == SVt_PVCV) {
733 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
735 warn("Encountered CODE ref, using dummy placeholder");
738 warn("cannot handle ref type %ld", realtype);
741 if (realpack) { /* free blessed allocs */
746 sv_catpvn(retval, ", '", 3);
747 sv_catpvn(retval, realpack, strlen(realpack));
748 sv_catpvn(retval, "' )", 3);
749 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
750 sv_catpvn(retval, "->", 2);
751 sv_catsv(retval, toaster);
752 sv_catpvn(retval, "()", 2);
762 (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
763 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
764 (sv = *svp) && SvROK(sv) &&
765 (seenentry = (AV*)SvRV(sv)))
768 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
769 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
771 sv_catpvn(retval, "${", 2);
772 sv_catsv(retval, othername);
773 sv_catpvn(retval, "}", 1);
777 else if (val != &PL_sv_undef) {
779 namesv = newSVpvn("\\", 1);
780 sv_catpvn(namesv, name, namelen);
782 av_push(seenentry, namesv);
783 av_push(seenentry, newRV_inc(val));
784 (void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0);
785 SvREFCNT_dec(seenentry);
789 if (DD_is_integer(val)) {
792 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
794 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
795 len = strlen(tmpbuf);
797 /* Need to check to see if this is a string such as " 0".
798 I'm assuming from sprintf isn't going to clash with utf8.
799 Is this valid on EBCDIC? */
801 const char *pv = SvPV(val, pvlen);
802 if (pvlen != len || memNE(pv, tmpbuf, len))
803 goto integer_came_from_string;
806 /* Looks like we're on a 64 bit system. Make it a string so that
807 if a 32 bit system reads the number it will cope better. */
808 sv_catpvf(retval, "'%s'", tmpbuf);
810 sv_catpvn(retval, tmpbuf, len);
812 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
814 ++c; --i; /* just get the name */
815 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
819 if (needs_quote(c)) {
820 sv_grow(retval, SvCUR(retval)+6+2*i);
821 r = SvPVX(retval)+SvCUR(retval);
822 r[0] = '*'; r[1] = '{'; r[2] = '\'';
823 i += esc_q(r+3, c, i);
825 r[i++] = '\''; r[i++] = '}';
829 sv_grow(retval, SvCUR(retval)+i+2);
830 r = SvPVX(retval)+SvCUR(retval);
831 r[0] = '*'; strcpy(r+1, c);
834 SvCUR_set(retval, SvCUR(retval)+i);
837 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
838 static const STRLEN sizes[] = { 8, 7, 6 };
840 SV *nname = newSVpvn("", 0);
841 SV *newapad = newSVpvn("", 0);
845 for (j=0; j<3; j++) {
846 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
849 if (j == 0 && !SvOK(e))
854 SV *postentry = newSVpvn(r,i);
856 sv_setsv(nname, postentry);
857 sv_catpvn(nname, entries[j], sizes[j]);
858 sv_catpvn(postentry, " = ", 3);
859 av_push(postav, postentry);
862 SvCUR_set(newapad, 0);
864 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
866 DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
867 seenhv, postav, &nlevel, indent, pad, xpad,
868 newapad, sep, pair, freezer, toaster, purity,
869 deepcopy, quotekeys, bless, maxdepth,
875 SvREFCNT_dec(newapad);
879 else if (val == &PL_sv_undef || !SvOK(val)) {
880 sv_catpvn(retval, "undef", 5);
883 integer_came_from_string:
886 i += esc_q_utf8(aTHX_ retval, c, i);
888 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
889 r = SvPVX(retval) + SvCUR(retval);
891 i += esc_q(r+1, c, i);
895 SvCUR_set(retval, SvCUR(retval)+i);
902 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
903 else if (namelen && seenentry) {
904 SV *mark = *av_fetch(seenentry, 2, TRUE);
912 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
915 # This is the exact equivalent of Dump. Well, almost. The things that are
916 # different as of now (due to Laziness):
917 # * doesnt do double-quotes yet.
921 Data_Dumper_Dumpxs(href, ...)
929 AV *postav, *todumpav, *namesav;
931 I32 indent, terse, i, imax, postlen;
933 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
934 SV *freezer, *toaster, *bless, *sortkeys;
935 I32 purity, deepcopy, quotekeys, maxdepth = 0;
939 if (!SvROK(href)) { /* call new to get an object first */
941 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
948 XPUSHs(sv_2mortal(newSVsv(ST(1))));
950 XPUSHs(sv_2mortal(newSVsv(ST(2))));
952 i = perl_call_method("new", G_SCALAR);
955 href = newSVsv(POPs);
961 (void)sv_2mortal(href);
964 todumpav = namesav = Nullav;
966 val = pad = xpad = apad = sep = pair = varname
967 = freezer = toaster = bless = &PL_sv_undef;
968 name = sv_newmortal();
970 terse = purity = deepcopy = 0;
973 retval = newSVpvn("", 0);
975 && (hv = (HV*)SvRV((SV*)href))
976 && SvTYPE(hv) == SVt_PVHV) {
978 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
979 seenhv = (HV*)SvRV(*svp);
980 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
981 todumpav = (AV*)SvRV(*svp);
982 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
983 namesav = (AV*)SvRV(*svp);
984 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
986 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
988 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
989 terse = SvTRUE(*svp);
990 #if 0 /* useqq currently unused */
991 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
992 useqq = SvTRUE(*svp);
994 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
996 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
998 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1000 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1002 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1004 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1006 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1008 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1010 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1011 deepcopy = SvTRUE(*svp);
1012 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1013 quotekeys = SvTRUE(*svp);
1014 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1016 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1017 maxdepth = SvIV(*svp);
1018 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1020 if (! SvTRUE(sortkeys))
1022 else if (! (SvROK(sortkeys) &&
1023 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1025 /* flag to use qsortsv() for sorting hash keys */
1026 sortkeys = &PL_sv_yes;
1032 imax = av_len(todumpav);
1035 valstr = newSVpvn("",0);
1036 for (i = 0; i <= imax; ++i) {
1040 if ((svp = av_fetch(todumpav, i, FALSE)))
1044 if ((svp = av_fetch(namesav, i, TRUE)))
1045 sv_setsv(name, *svp);
1047 (void)SvOK_off(name);
1050 if ((SvPVX(name))[0] == '*') {
1052 switch (SvTYPE(SvRV(val))) {
1054 (SvPVX(name))[0] = '@';
1057 (SvPVX(name))[0] = '%';
1060 (SvPVX(name))[0] = '*';
1063 (SvPVX(name))[0] = '$';
1068 (SvPVX(name))[0] = '$';
1070 else if ((SvPVX(name))[0] != '$')
1071 sv_insert(name, 0, 0, "$", 1);
1075 sv_setpvn(name, "$", 1);
1076 sv_catsv(name, varname);
1077 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1078 nchars = strlen(tmpbuf);
1079 sv_catpvn(name, tmpbuf, nchars);
1083 SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1084 newapad = newSVsv(apad);
1085 sv_catsv(newapad, tmpsv);
1086 SvREFCNT_dec(tmpsv);
1091 DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
1092 postav, &level, indent, pad, xpad, newapad, sep, pair,
1093 freezer, toaster, purity, deepcopy, quotekeys,
1094 bless, maxdepth, sortkeys);
1097 SvREFCNT_dec(newapad);
1099 postlen = av_len(postav);
1100 if (postlen >= 0 || !terse) {
1101 sv_insert(valstr, 0, 0, " = ", 3);
1102 sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
1103 sv_catpvn(valstr, ";", 1);
1105 sv_catsv(retval, pad);
1106 sv_catsv(retval, valstr);
1107 sv_catsv(retval, sep);
1110 sv_catsv(retval, pad);
1111 for (i = 0; i <= postlen; ++i) {
1113 svp = av_fetch(postav, i, FALSE);
1114 if (svp && (elem = *svp)) {
1115 sv_catsv(retval, elem);
1117 sv_catpvn(retval, ";", 1);
1118 sv_catsv(retval, sep);
1119 sv_catsv(retval, pad);
1123 sv_catpvn(retval, ";", 1);
1124 sv_catsv(retval, sep);
1126 sv_setpvn(valstr, "", 0);
1127 if (gimme == G_ARRAY) {
1128 XPUSHs(sv_2mortal(retval));
1129 if (i < imax) /* not the last time thro ? */
1130 retval = newSVpvn("",0);
1133 SvREFCNT_dec(postav);
1134 SvREFCNT_dec(valstr);
1137 croak("Call to new() method failed to return HASH ref");
1138 if (gimme == G_SCALAR)
1139 XPUSHs(sv_2mortal(retval));