1 #define PERL_NO_GET_CONTEXT
7 #include "patchlevel.h"
8 #define PERL_VERSION PATCHLEVEL
13 # define PL_sv_undef sv_undef
16 # define ERRSV GvSV(errgv)
19 # define newSVpvn newSVpv
23 static I32 num_q (char *s, STRLEN slen);
24 static I32 esc_q (char *dest, char *src, STRLEN slen);
25 static I32 esc_q_utf8 (pTHX_ SV *sv, char *src, STRLEN slen);
26 static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n);
27 static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
28 HV *seenhv, AV *postav, I32 *levelp, I32 indent,
29 SV *pad, SV *xpad, SV *apad, SV *sep,
30 SV *freezer, SV *toaster,
31 I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
32 I32 maxdepth, SV *sortkeys);
34 /* does a string need to be protected? */
36 needs_quote(register char *s)
61 /* count the number of "'"s and "\"s in string */
63 num_q(register char *s, register STRLEN slen)
68 if (*s == '\'' || *s == '\\')
77 /* returns number of chars added to escape "'"s and "\"s in s */
78 /* slen number of characters in s will be escaped */
79 /* destination must be long enough for additional chars */
81 esc_q(register char *d, register char *s, register STRLEN slen)
101 esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen)
103 char *s, *send, *r, *rstart;
104 STRLEN j, cur = SvCUR(sv);
105 /* Could count 128-255 and 256+ in two variables, if we want to
106 be like &qquote and make a distinction. */
107 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
108 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
109 STRLEN backslashes = 0;
110 STRLEN single_quotes = 0;
111 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
114 /* this will need EBCDICification */
115 for (s = src, send = src + slen; s < send; s += UTF8SKIP(s)) {
116 UV k = utf8_to_uvchr((U8*)s, NULL);
119 /* 4: \x{} then count the number of hex digits. */
120 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
122 8 /* We may allocate a bit more than the minimum here. */
124 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
127 } else if (k == '\\') {
129 } else if (k == '\'') {
131 } else if (k == '"' || k == '$' || k == '@') {
138 /* We have something needing hex. 3 is ""\0 */
139 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
140 + 2*qq_escapables + normal);
141 rstart = r = SvPVX(sv) + cur;
145 for (s = src; s < send; s += UTF8SKIP(s)) {
146 UV k = utf8_to_uvchr((U8*)s, NULL);
148 if (k == '"' || k == '\\' || k == '$' || k == '@') {
155 r += sprintf(r, "\\x{%"UVxf"}", k);
161 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
162 + qq_escapables + normal);
163 rstart = r = SvPVX(sv) + cur;
165 for (s = src; s < send; s ++) {
167 if (k == '\'' || k == '\\')
175 SvCUR_set(sv, cur + j);
180 /* append a repeated string to an SV */
182 sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n)
185 sv = newSVpvn("", 0);
187 assert(SvTYPE(sv) >= SVt_PV);
190 SvGROW(sv, len*n + SvCUR(sv) + 1);
192 char *start = SvPVX(sv) + SvCUR(sv);
200 sv_catpvn(sv, str, len);
208 * This ought to be split into smaller functions. (it is one long function since
209 * it exactly parallels the perl version, which was one long thing for
210 * efficiency raisins.) Ugggh!
213 DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
214 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
215 SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
216 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
220 char *c, *r, *realpack, id[128];
222 SV *sv, *ipad, *ival;
223 SV *blesspad = Nullsv;
224 AV *seenentry = Nullav;
226 STRLEN inamelen, idlen = 0;
232 realtype = SvTYPE(val);
238 if (SvOBJECT(SvRV(val)) && freezer &&
239 SvPOK(freezer) && SvCUR(freezer))
241 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
242 XPUSHs(val); PUTBACK;
243 i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
246 warn("WARNING(Freezer method call failed): %s",
250 PUTBACK; FREETMPS; LEAVE;
252 (void)sv_2mortal(val);
256 realtype = SvTYPE(ival);
257 (void) sprintf(id, "0x%"UVxf, PTR2UV(ival));
260 realpack = HvNAME(SvSTASH(ival));
264 /* if it has a name, we need to either look it up, or keep a tab
265 * on it so we know when we hit it later
268 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
269 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
272 if ((svp = av_fetch(seenentry, 0, FALSE))
273 && (othername = *svp))
275 if (purity && *levelp > 0) {
278 if (realtype == SVt_PVHV)
279 sv_catpvn(retval, "{}", 2);
280 else if (realtype == SVt_PVAV)
281 sv_catpvn(retval, "[]", 2);
283 sv_catpvn(retval, "do{my $o}", 9);
284 postentry = newSVpvn(name, namelen);
285 sv_catpvn(postentry, " = ", 3);
286 sv_catsv(postentry, othername);
287 av_push(postav, postentry);
290 if (name[0] == '@' || name[0] == '%') {
291 if ((SvPVX(othername))[0] == '\\' &&
292 (SvPVX(othername))[1] == name[0]) {
293 sv_catpvn(retval, SvPVX(othername)+1,
297 sv_catpvn(retval, name, 1);
298 sv_catpvn(retval, "{", 1);
299 sv_catsv(retval, othername);
300 sv_catpvn(retval, "}", 1);
304 sv_catsv(retval, othername);
309 warn("ref name not found for %s", id);
313 else { /* store our name and continue */
315 if (name[0] == '@' || name[0] == '%') {
316 namesv = newSVpvn("\\", 1);
317 sv_catpvn(namesv, name, namelen);
319 else if (realtype == SVt_PVCV && name[0] == '*') {
320 namesv = newSVpvn("\\", 2);
321 sv_catpvn(namesv, name, namelen);
322 (SvPVX(namesv))[1] = '&';
325 namesv = newSVpvn(name, namelen);
327 av_push(seenentry, namesv);
328 (void)SvREFCNT_inc(val);
329 av_push(seenentry, val);
330 (void)hv_store(seenhv, id, strlen(id),
331 newRV((SV*)seenentry), 0);
332 SvREFCNT_dec(seenentry);
336 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
338 char *rval = SvPV(val, rlen);
339 char *slash = strchr(rval, '/');
340 sv_catpvn(retval, "qr/", 3);
342 sv_catpvn(retval, rval, slash-rval);
343 sv_catpvn(retval, "\\/", 2);
344 rlen -= slash-rval+1;
346 slash = strchr(rval, '/');
348 sv_catpvn(retval, rval, rlen);
349 sv_catpvn(retval, "/", 1);
353 /* If purity is not set and maxdepth is set, then check depth:
354 * if we have reached maximum depth, return the string
355 * representation of the thing we are currently examining
356 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
358 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
360 char *valstr = SvPV(val,vallen);
361 sv_catpvn(retval, "'", 1);
362 sv_catpvn(retval, valstr, vallen);
363 sv_catpvn(retval, "'", 1);
367 if (realpack) { /* we have a blessed ref */
369 char *blessstr = SvPV(bless, blesslen);
370 sv_catpvn(retval, blessstr, blesslen);
371 sv_catpvn(retval, "( ", 2);
374 apad = newSVsv(apad);
375 sv_x(aTHX_ apad, " ", 1, blesslen+2);
380 ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
382 if (realtype <= SVt_PVBM) { /* scalar ref */
383 SV *namesv = newSVpvn("${", 2);
384 sv_catpvn(namesv, name, namelen);
385 sv_catpvn(namesv, "}", 1);
386 if (realpack) { /* blessed */
387 sv_catpvn(retval, "do{\\(my $o = ", 13);
388 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
389 postav, levelp, indent, pad, xpad, apad, sep,
390 freezer, toaster, purity, deepcopy, quotekeys, bless,
392 sv_catpvn(retval, ")}", 2);
395 sv_catpvn(retval, "\\", 1);
396 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
397 postav, levelp, indent, pad, xpad, apad, sep,
398 freezer, toaster, purity, deepcopy, quotekeys, bless,
401 SvREFCNT_dec(namesv);
403 else if (realtype == SVt_PVGV) { /* glob ref */
404 SV *namesv = newSVpvn("*{", 2);
405 sv_catpvn(namesv, name, namelen);
406 sv_catpvn(namesv, "}", 1);
407 sv_catpvn(retval, "\\", 1);
408 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
409 postav, levelp, indent, pad, xpad, apad, sep,
410 freezer, toaster, purity, deepcopy, quotekeys, bless,
412 SvREFCNT_dec(namesv);
414 else if (realtype == SVt_PVAV) {
417 I32 ixmax = av_len((AV *)ival);
419 SV *ixsv = newSViv(0);
420 /* allowing for a 24 char wide array index */
421 New(0, iname, namelen+28, char);
422 (void)strcpy(iname, name);
424 if (name[0] == '@') {
425 sv_catpvn(retval, "(", 1);
429 sv_catpvn(retval, "[", 1);
430 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
432 && name[namelen-1] != ']' && name[namelen-1] != '}'
433 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
435 && name[namelen-1] != ']' && name[namelen-1] != '}')
438 || (name[0] == '\\' && name[2] == '{'))))
440 iname[inamelen++] = '-'; iname[inamelen++] = '>';
441 iname[inamelen] = '\0';
444 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
445 (instr(iname+inamelen-8, "{SCALAR}") ||
446 instr(iname+inamelen-7, "{ARRAY}") ||
447 instr(iname+inamelen-6, "{HASH}"))) {
448 iname[inamelen++] = '-'; iname[inamelen++] = '>';
450 iname[inamelen++] = '['; iname[inamelen] = '\0';
451 totpad = newSVsv(sep);
452 sv_catsv(totpad, pad);
453 sv_catsv(totpad, apad);
455 for (ix = 0; ix <= ixmax; ++ix) {
458 svp = av_fetch((AV*)ival, ix, FALSE);
466 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
467 ilen = strlen(iname);
468 iname[ilen++] = ']'; iname[ilen] = '\0';
470 sv_catsv(retval, totpad);
471 sv_catsv(retval, ipad);
472 sv_catpvn(retval, "#", 1);
473 sv_catsv(retval, ixsv);
475 sv_catsv(retval, totpad);
476 sv_catsv(retval, ipad);
477 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
478 levelp, indent, pad, xpad, apad, sep,
479 freezer, toaster, purity, deepcopy, quotekeys, bless,
482 sv_catpvn(retval, ",", 1);
485 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
486 sv_catsv(retval, totpad);
487 sv_catsv(retval, opad);
491 sv_catpvn(retval, ")", 1);
493 sv_catpvn(retval, "]", 1);
495 SvREFCNT_dec(totpad);
498 else if (realtype == SVt_PVHV) {
499 SV *totpad, *newapad;
507 iname = newSVpvn(name, namelen);
508 if (name[0] == '%') {
509 sv_catpvn(retval, "(", 1);
510 (SvPVX(iname))[0] = '$';
513 sv_catpvn(retval, "{", 1);
514 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
516 && name[namelen-1] != ']' && name[namelen-1] != '}')
519 || (name[0] == '\\' && name[2] == '{'))))
521 sv_catpvn(iname, "->", 2);
524 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
525 (instr(name+namelen-8, "{SCALAR}") ||
526 instr(name+namelen-7, "{ARRAY}") ||
527 instr(name+namelen-6, "{HASH}"))) {
528 sv_catpvn(iname, "->", 2);
530 sv_catpvn(iname, "{", 1);
531 totpad = newSVsv(sep);
532 sv_catsv(totpad, pad);
533 sv_catsv(totpad, apad);
535 /* If requested, get a sorted/filtered array of hash keys */
537 if (sortkeys == &PL_sv_yes) {
539 (void)hv_iterinit((HV*)ival);
540 while ((entry = hv_iternext((HV*)ival))) {
541 sv = hv_iterkeysv(entry);
545 #ifdef USE_LOCALE_NUMERIC
546 sortsv(AvARRAY(keys),
548 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
550 sortsv(AvARRAY(keys),
556 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
557 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
558 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
562 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
563 keys = (AV*)SvREFCNT_inc(SvRV(sv));
566 warn("Sortkeys subroutine did not return ARRAYREF\n");
567 PUTBACK; FREETMPS; LEAVE;
570 sv_2mortal((SV*)keys);
573 (void)hv_iterinit((HV*)ival);
575 /* foreach (keys %hash) */
576 for (i = 0; 1; i++) {
578 char *nkey_buffer = NULL;
583 bool do_utf8 = FALSE;
585 if ((sortkeys && !(keys && (I32)i <= av_len(keys))) ||
586 !(entry = hv_iternext((HV *)ival)))
590 sv_catpvn(retval, ",", 1);
594 svp = av_fetch(keys, i, FALSE);
595 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
596 key = SvPV(keysv, keylen);
597 svp = hv_fetch((HV*)ival, key,
598 SvUTF8(keysv) ? -keylen : keylen, 0);
599 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
602 keysv = hv_iterkeysv(entry);
603 hval = hv_iterval((HV*)ival, entry);
606 do_utf8 = DO_UTF8(keysv);
607 key = SvPV(keysv, keylen);
610 sv_catsv(retval, totpad);
611 sv_catsv(retval, ipad);
612 /* old logic was first to check utf8 flag, and if utf8 always
613 call esc_q_utf8. This caused test to break under -Mutf8,
614 because there even strings like 'c' have utf8 flag on.
615 Hence with quotekeys == 0 the XS code would still '' quote
616 them based on flags, whereas the perl code would not,
618 The perl code is correct.
619 needs_quote() decides that anything that isn't a valid
620 perl identifier needs to be quoted, hence only correctly
621 formed strings with no characters outside [A-Za-z0-9_:]
622 won't need quoting. None of those characters are used in
623 the byte encoding of utf8, so anything with utf8
624 encoded characters in will need quoting. Hence strings
625 with utf8 encoded characters in will end up inside do_utf8
626 just like before, but now strings with utf8 flag set but
627 only ascii characters will end up in the unquoted section.
629 There should also be less tests for the (probably currently)
630 more common doesn't need quoting case.
631 The code is also smaller (22044 vs 22260) because I've been
632 able to pull the comon logic out to both sides. */
633 if (quotekeys || needs_quote(key)) {
635 STRLEN ocur = SvCUR(retval);
636 nlen = esc_q_utf8(aTHX_ retval, key, klen);
637 nkey = SvPVX(retval) + ocur;
640 nticks = num_q(key, klen);
641 New(0, nkey_buffer, klen+nticks+3, char);
645 klen += esc_q(nkey+1, key, klen);
647 (void)Copy(key, nkey+1, klen, char);
651 sv_catpvn(retval, nkey, klen);
657 sv_catpvn(retval, nkey, klen);
659 sname = newSVsv(iname);
660 sv_catpvn(sname, nkey, nlen);
661 sv_catpvn(sname, "}", 1);
663 sv_catpvn(retval, " => ", 4);
667 newapad = newSVsv(apad);
668 New(0, extra, klen+4+1, char);
669 while (elen < (klen+4))
672 sv_catpvn(newapad, extra, elen);
678 DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
679 postav, levelp, indent, pad, xpad, newapad, sep,
680 freezer, toaster, purity, deepcopy, quotekeys, bless,
683 Safefree(nkey_buffer);
685 SvREFCNT_dec(newapad);
688 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
689 sv_catsv(retval, totpad);
690 sv_catsv(retval, opad);
694 sv_catpvn(retval, ")", 1);
696 sv_catpvn(retval, "}", 1);
698 SvREFCNT_dec(totpad);
700 else if (realtype == SVt_PVCV) {
701 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
703 warn("Encountered CODE ref, using dummy placeholder");
706 warn("cannot handle ref type %ld", realtype);
709 if (realpack) { /* free blessed allocs */
714 sv_catpvn(retval, ", '", 3);
715 sv_catpvn(retval, realpack, strlen(realpack));
716 sv_catpvn(retval, "' )", 3);
717 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
718 sv_catpvn(retval, "->", 2);
719 sv_catsv(retval, toaster);
720 sv_catpvn(retval, "()", 2);
730 (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
731 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
732 (sv = *svp) && SvROK(sv) &&
733 (seenentry = (AV*)SvRV(sv)))
736 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
737 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
739 sv_catpvn(retval, "${", 2);
740 sv_catsv(retval, othername);
741 sv_catpvn(retval, "}", 1);
747 namesv = newSVpvn("\\", 1);
748 sv_catpvn(namesv, name, namelen);
750 av_push(seenentry, namesv);
751 av_push(seenentry, newRV(val));
752 (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
753 SvREFCNT_dec(seenentry);
760 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
762 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
763 len = strlen(tmpbuf);
764 /* For 5.6.x and earlier will need to change this test to check
765 NV if NOK, as there NOK trumps IOK, and NV=3.5,IV=3 is valid.
766 Current code will Dump that as $VAR1 = 3;
767 Changes in 5.7 series mean that now IOK is only set if scalar
768 is precisely integer. */
770 /* Need to check to see if this is a string such as " 0".
771 I'm assuming from sprintf isn't going to clash with utf8.
772 Is this valid on EBCDIC? */
774 const char *pv = SvPV(val, pvlen);
775 if (pvlen != len || memNE(pv, tmpbuf, len))
776 goto integer_came_from_string;
779 /* Looks like we're on a 64 bit system. Make it a string so that
780 if a 32 bit system reads the number it will cope better. */
781 sv_catpvf(retval, "'%s'", tmpbuf);
783 sv_catpvn(retval, tmpbuf, len);
785 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
787 ++c; --i; /* just get the name */
788 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
792 if (needs_quote(c)) {
793 sv_grow(retval, SvCUR(retval)+6+2*i);
794 r = SvPVX(retval)+SvCUR(retval);
795 r[0] = '*'; r[1] = '{'; r[2] = '\'';
796 i += esc_q(r+3, c, i);
798 r[i++] = '\''; r[i++] = '}';
802 sv_grow(retval, SvCUR(retval)+i+2);
803 r = SvPVX(retval)+SvCUR(retval);
804 r[0] = '*'; strcpy(r+1, c);
807 SvCUR_set(retval, SvCUR(retval)+i);
810 static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
811 static STRLEN sizes[] = { 8, 7, 6 };
813 SV *nname = newSVpvn("", 0);
814 SV *newapad = newSVpvn("", 0);
818 for (j=0; j<3; j++) {
819 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
822 if (j == 0 && !SvOK(e))
827 SV *postentry = newSVpvn(r,i);
829 sv_setsv(nname, postentry);
830 sv_catpvn(nname, entries[j], sizes[j]);
831 sv_catpvn(postentry, " = ", 3);
832 av_push(postav, postentry);
837 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
839 DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
840 seenhv, postav, &nlevel, indent, pad, xpad,
841 newapad, sep, freezer, toaster, purity,
842 deepcopy, quotekeys, bless, maxdepth,
848 SvREFCNT_dec(newapad);
852 else if (val == &PL_sv_undef || !SvOK(val)) {
853 sv_catpvn(retval, "undef", 5);
856 integer_came_from_string:
859 i += esc_q_utf8(aTHX_ retval, c, i);
861 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
862 r = SvPVX(retval) + SvCUR(retval);
864 i += esc_q(r+1, c, i);
868 SvCUR_set(retval, SvCUR(retval)+i);
875 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
876 else if (namelen && seenentry) {
877 SV *mark = *av_fetch(seenentry, 2, TRUE);
885 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
888 # This is the exact equivalent of Dump. Well, almost. The things that are
889 # different as of now (due to Laziness):
890 # * doesnt do double-quotes yet.
894 Data_Dumper_Dumpxs(href, ...)
902 AV *postav, *todumpav, *namesav;
904 I32 indent, terse, i, imax, postlen;
906 SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
907 SV *freezer, *toaster, *bless, *sortkeys;
908 I32 purity, deepcopy, quotekeys, maxdepth = 0;
912 if (!SvROK(href)) { /* call new to get an object first */
914 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
921 XPUSHs(sv_2mortal(newSVsv(ST(1))));
923 XPUSHs(sv_2mortal(newSVsv(ST(2))));
925 i = perl_call_method("new", G_SCALAR);
928 href = newSVsv(POPs);
934 (void)sv_2mortal(href);
937 todumpav = namesav = Nullav;
939 val = pad = xpad = apad = sep = varname
940 = freezer = toaster = bless = &PL_sv_undef;
941 name = sv_newmortal();
943 terse = purity = deepcopy = 0;
946 retval = newSVpvn("", 0);
948 && (hv = (HV*)SvRV((SV*)href))
949 && SvTYPE(hv) == SVt_PVHV) {
951 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
952 seenhv = (HV*)SvRV(*svp);
953 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
954 todumpav = (AV*)SvRV(*svp);
955 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
956 namesav = (AV*)SvRV(*svp);
957 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
959 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
961 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
962 terse = SvTRUE(*svp);
963 #if 0 /* useqq currently unused */
964 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
965 useqq = SvTRUE(*svp);
967 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
969 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
971 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
973 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
975 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
977 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
979 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
981 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
982 deepcopy = SvTRUE(*svp);
983 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
984 quotekeys = SvTRUE(*svp);
985 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
987 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
988 maxdepth = SvIV(*svp);
989 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
991 if (! SvTRUE(sortkeys))
993 else if (! (SvROK(sortkeys) &&
994 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
996 /* flag to use qsortsv() for sorting hash keys */
997 sortkeys = &PL_sv_yes;
1003 imax = av_len(todumpav);
1006 valstr = newSVpvn("",0);
1007 for (i = 0; i <= imax; ++i) {
1011 if ((svp = av_fetch(todumpav, i, FALSE)))
1015 if ((svp = av_fetch(namesav, i, TRUE)))
1016 sv_setsv(name, *svp);
1018 (void)SvOK_off(name);
1021 if ((SvPVX(name))[0] == '*') {
1023 switch (SvTYPE(SvRV(val))) {
1025 (SvPVX(name))[0] = '@';
1028 (SvPVX(name))[0] = '%';
1031 (SvPVX(name))[0] = '*';
1034 (SvPVX(name))[0] = '$';
1039 (SvPVX(name))[0] = '$';
1041 else if ((SvPVX(name))[0] != '$')
1042 sv_insert(name, 0, 0, "$", 1);
1046 sv_setpvn(name, "$", 1);
1047 sv_catsv(name, varname);
1048 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1049 nchars = strlen(tmpbuf);
1050 sv_catpvn(name, tmpbuf, nchars);
1054 SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1055 newapad = newSVsv(apad);
1056 sv_catsv(newapad, tmpsv);
1057 SvREFCNT_dec(tmpsv);
1062 DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
1063 postav, &level, indent, pad, xpad, newapad, sep,
1064 freezer, toaster, purity, deepcopy, quotekeys,
1065 bless, maxdepth, sortkeys);
1068 SvREFCNT_dec(newapad);
1070 postlen = av_len(postav);
1071 if (postlen >= 0 || !terse) {
1072 sv_insert(valstr, 0, 0, " = ", 3);
1073 sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
1074 sv_catpvn(valstr, ";", 1);
1076 sv_catsv(retval, pad);
1077 sv_catsv(retval, valstr);
1078 sv_catsv(retval, sep);
1081 sv_catsv(retval, pad);
1082 for (i = 0; i <= postlen; ++i) {
1084 svp = av_fetch(postav, i, FALSE);
1085 if (svp && (elem = *svp)) {
1086 sv_catsv(retval, elem);
1088 sv_catpvn(retval, ";", 1);
1089 sv_catsv(retval, sep);
1090 sv_catsv(retval, pad);
1094 sv_catpvn(retval, ";", 1);
1095 sv_catsv(retval, sep);
1097 sv_setpvn(valstr, "", 0);
1098 if (gimme == G_ARRAY) {
1099 XPUSHs(sv_2mortal(retval));
1100 if (i < imax) /* not the last time thro ? */
1101 retval = newSVpvn("",0);
1104 SvREFCNT_dec(postav);
1105 SvREFCNT_dec(valstr);
1108 croak("Call to new() method failed to return HASH ref");
1109 if (gimme == G_SCALAR)
1110 XPUSHs(sv_2mortal(retval));