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 /* The return value of sprintf() is unportable.
156 * In modern systems it returns (int) the number of characters,
157 * but in older systems it might return (char*) the original
158 * buffer, or it might even be (void). The easiest portable
159 * thing to do is probably use sprintf() in void context and
160 * then strlen(buffer) for the length. The more proper way
161 * would of course be to figure out the prototype of sprintf.
163 sprintf(r, "\\x{%"UVxf"}", k);
170 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
171 + qq_escapables + normal);
172 rstart = r = SvPVX(sv) + cur;
174 for (s = src; s < send; s ++) {
176 if (k == '\'' || k == '\\')
184 SvCUR_set(sv, cur + j);
189 /* append a repeated string to an SV */
191 sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n)
194 sv = newSVpvn("", 0);
196 assert(SvTYPE(sv) >= SVt_PV);
199 SvGROW(sv, len*n + SvCUR(sv) + 1);
201 char *start = SvPVX(sv) + SvCUR(sv);
209 sv_catpvn(sv, str, len);
217 * This ought to be split into smaller functions. (it is one long function since
218 * it exactly parallels the perl version, which was one long thing for
219 * efficiency raisins.) Ugggh!
222 DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
223 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
224 SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
225 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
229 char *c, *r, *realpack, id[128];
231 SV *sv, *ipad, *ival;
232 SV *blesspad = Nullsv;
233 AV *seenentry = Nullav;
235 STRLEN inamelen, idlen = 0;
241 realtype = SvTYPE(val);
247 if (SvOBJECT(SvRV(val)) && freezer &&
248 SvPOK(freezer) && SvCUR(freezer))
250 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
251 XPUSHs(val); PUTBACK;
252 i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
255 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
258 PUTBACK; FREETMPS; LEAVE;
260 (void)sv_2mortal(val);
264 realtype = SvTYPE(ival);
265 (void) sprintf(id, "0x%"UVxf, PTR2UV(ival));
268 realpack = HvNAME(SvSTASH(ival));
272 /* if it has a name, we need to either look it up, or keep a tab
273 * on it so we know when we hit it later
276 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
277 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
280 if ((svp = av_fetch(seenentry, 0, FALSE))
281 && (othername = *svp))
283 if (purity && *levelp > 0) {
286 if (realtype == SVt_PVHV)
287 sv_catpvn(retval, "{}", 2);
288 else if (realtype == SVt_PVAV)
289 sv_catpvn(retval, "[]", 2);
291 sv_catpvn(retval, "do{my $o}", 9);
292 postentry = newSVpvn(name, namelen);
293 sv_catpvn(postentry, " = ", 3);
294 sv_catsv(postentry, othername);
295 av_push(postav, postentry);
298 if (name[0] == '@' || name[0] == '%') {
299 if ((SvPVX(othername))[0] == '\\' &&
300 (SvPVX(othername))[1] == name[0]) {
301 sv_catpvn(retval, SvPVX(othername)+1,
305 sv_catpvn(retval, name, 1);
306 sv_catpvn(retval, "{", 1);
307 sv_catsv(retval, othername);
308 sv_catpvn(retval, "}", 1);
312 sv_catsv(retval, othername);
317 warn("ref name not found for %s", id);
321 else { /* store our name and continue */
323 if (name[0] == '@' || name[0] == '%') {
324 namesv = newSVpvn("\\", 1);
325 sv_catpvn(namesv, name, namelen);
327 else if (realtype == SVt_PVCV && name[0] == '*') {
328 namesv = newSVpvn("\\", 2);
329 sv_catpvn(namesv, name, namelen);
330 (SvPVX(namesv))[1] = '&';
333 namesv = newSVpvn(name, namelen);
335 av_push(seenentry, namesv);
336 (void)SvREFCNT_inc(val);
337 av_push(seenentry, val);
338 (void)hv_store(seenhv, id, strlen(id),
339 newRV((SV*)seenentry), 0);
340 SvREFCNT_dec(seenentry);
344 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
346 char *rval = SvPV(val, rlen);
347 char *slash = strchr(rval, '/');
348 sv_catpvn(retval, "qr/", 3);
350 sv_catpvn(retval, rval, slash-rval);
351 sv_catpvn(retval, "\\/", 2);
352 rlen -= slash-rval+1;
354 slash = strchr(rval, '/');
356 sv_catpvn(retval, rval, rlen);
357 sv_catpvn(retval, "/", 1);
361 /* If purity is not set and maxdepth is set, then check depth:
362 * if we have reached maximum depth, return the string
363 * representation of the thing we are currently examining
364 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
366 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
368 char *valstr = SvPV(val,vallen);
369 sv_catpvn(retval, "'", 1);
370 sv_catpvn(retval, valstr, vallen);
371 sv_catpvn(retval, "'", 1);
375 if (realpack) { /* we have a blessed ref */
377 char *blessstr = SvPV(bless, blesslen);
378 sv_catpvn(retval, blessstr, blesslen);
379 sv_catpvn(retval, "( ", 2);
382 apad = newSVsv(apad);
383 sv_x(aTHX_ apad, " ", 1, blesslen+2);
388 ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
390 if (realtype <= SVt_PVBM) { /* scalar ref */
391 SV *namesv = newSVpvn("${", 2);
392 sv_catpvn(namesv, name, namelen);
393 sv_catpvn(namesv, "}", 1);
394 if (realpack) { /* blessed */
395 sv_catpvn(retval, "do{\\(my $o = ", 13);
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,
400 sv_catpvn(retval, ")}", 2);
403 sv_catpvn(retval, "\\", 1);
404 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
405 postav, levelp, indent, pad, xpad, apad, sep,
406 freezer, toaster, purity, deepcopy, quotekeys, bless,
409 SvREFCNT_dec(namesv);
411 else if (realtype == SVt_PVGV) { /* glob ref */
412 SV *namesv = newSVpvn("*{", 2);
413 sv_catpvn(namesv, name, namelen);
414 sv_catpvn(namesv, "}", 1);
415 sv_catpvn(retval, "\\", 1);
416 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
417 postav, levelp, indent, pad, xpad, apad, sep,
418 freezer, toaster, purity, deepcopy, quotekeys, bless,
420 SvREFCNT_dec(namesv);
422 else if (realtype == SVt_PVAV) {
425 I32 ixmax = av_len((AV *)ival);
427 SV *ixsv = newSViv(0);
428 /* allowing for a 24 char wide array index */
429 New(0, iname, namelen+28, char);
430 (void)strcpy(iname, name);
432 if (name[0] == '@') {
433 sv_catpvn(retval, "(", 1);
437 sv_catpvn(retval, "[", 1);
438 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
440 && name[namelen-1] != ']' && name[namelen-1] != '}'
441 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
443 && name[namelen-1] != ']' && name[namelen-1] != '}')
446 || (name[0] == '\\' && name[2] == '{'))))
448 iname[inamelen++] = '-'; iname[inamelen++] = '>';
449 iname[inamelen] = '\0';
452 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
453 (instr(iname+inamelen-8, "{SCALAR}") ||
454 instr(iname+inamelen-7, "{ARRAY}") ||
455 instr(iname+inamelen-6, "{HASH}"))) {
456 iname[inamelen++] = '-'; iname[inamelen++] = '>';
458 iname[inamelen++] = '['; iname[inamelen] = '\0';
459 totpad = newSVsv(sep);
460 sv_catsv(totpad, pad);
461 sv_catsv(totpad, apad);
463 for (ix = 0; ix <= ixmax; ++ix) {
466 svp = av_fetch((AV*)ival, ix, FALSE);
474 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
475 ilen = strlen(iname);
476 iname[ilen++] = ']'; iname[ilen] = '\0';
478 sv_catsv(retval, totpad);
479 sv_catsv(retval, ipad);
480 sv_catpvn(retval, "#", 1);
481 sv_catsv(retval, ixsv);
483 sv_catsv(retval, totpad);
484 sv_catsv(retval, ipad);
485 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
486 levelp, indent, pad, xpad, apad, sep,
487 freezer, toaster, purity, deepcopy, quotekeys, bless,
490 sv_catpvn(retval, ",", 1);
493 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
494 sv_catsv(retval, totpad);
495 sv_catsv(retval, opad);
499 sv_catpvn(retval, ")", 1);
501 sv_catpvn(retval, "]", 1);
503 SvREFCNT_dec(totpad);
506 else if (realtype == SVt_PVHV) {
507 SV *totpad, *newapad;
515 iname = newSVpvn(name, namelen);
516 if (name[0] == '%') {
517 sv_catpvn(retval, "(", 1);
518 (SvPVX(iname))[0] = '$';
521 sv_catpvn(retval, "{", 1);
522 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
524 && name[namelen-1] != ']' && name[namelen-1] != '}')
527 || (name[0] == '\\' && name[2] == '{'))))
529 sv_catpvn(iname, "->", 2);
532 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
533 (instr(name+namelen-8, "{SCALAR}") ||
534 instr(name+namelen-7, "{ARRAY}") ||
535 instr(name+namelen-6, "{HASH}"))) {
536 sv_catpvn(iname, "->", 2);
538 sv_catpvn(iname, "{", 1);
539 totpad = newSVsv(sep);
540 sv_catsv(totpad, pad);
541 sv_catsv(totpad, apad);
543 /* If requested, get a sorted/filtered array of hash keys */
545 if (sortkeys == &PL_sv_yes) {
547 (void)hv_iterinit((HV*)ival);
548 while ((entry = hv_iternext((HV*)ival))) {
549 sv = hv_iterkeysv(entry);
553 #ifdef USE_LOCALE_NUMERIC
554 sortsv(AvARRAY(keys),
556 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
558 sortsv(AvARRAY(keys),
564 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
565 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
566 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
570 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
571 keys = (AV*)SvREFCNT_inc(SvRV(sv));
574 warn("Sortkeys subroutine did not return ARRAYREF\n");
575 PUTBACK; FREETMPS; LEAVE;
578 sv_2mortal((SV*)keys);
581 (void)hv_iterinit((HV*)ival);
583 /* foreach (keys %hash) */
584 for (i = 0; 1; i++) {
586 char *nkey_buffer = NULL;
591 bool do_utf8 = FALSE;
593 if ((sortkeys && !(keys && (I32)i <= av_len(keys))) ||
594 !(entry = hv_iternext((HV *)ival)))
598 sv_catpvn(retval, ",", 1);
602 svp = av_fetch(keys, i, FALSE);
603 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
604 key = SvPV(keysv, keylen);
605 svp = hv_fetch((HV*)ival, key,
606 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
607 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
610 keysv = hv_iterkeysv(entry);
611 hval = hv_iterval((HV*)ival, entry);
614 do_utf8 = DO_UTF8(keysv);
615 key = SvPV(keysv, keylen);
618 sv_catsv(retval, totpad);
619 sv_catsv(retval, ipad);
620 /* old logic was first to check utf8 flag, and if utf8 always
621 call esc_q_utf8. This caused test to break under -Mutf8,
622 because there even strings like 'c' have utf8 flag on.
623 Hence with quotekeys == 0 the XS code would still '' quote
624 them based on flags, whereas the perl code would not,
626 The perl code is correct.
627 needs_quote() decides that anything that isn't a valid
628 perl identifier needs to be quoted, hence only correctly
629 formed strings with no characters outside [A-Za-z0-9_:]
630 won't need quoting. None of those characters are used in
631 the byte encoding of utf8, so anything with utf8
632 encoded characters in will need quoting. Hence strings
633 with utf8 encoded characters in will end up inside do_utf8
634 just like before, but now strings with utf8 flag set but
635 only ascii characters will end up in the unquoted section.
637 There should also be less tests for the (probably currently)
638 more common doesn't need quoting case.
639 The code is also smaller (22044 vs 22260) because I've been
640 able to pull the comon logic out to both sides. */
641 if (quotekeys || needs_quote(key)) {
643 STRLEN ocur = SvCUR(retval);
644 nlen = esc_q_utf8(aTHX_ retval, key, klen);
645 nkey = SvPVX(retval) + ocur;
648 nticks = num_q(key, klen);
649 New(0, nkey_buffer, klen+nticks+3, char);
653 klen += esc_q(nkey+1, key, klen);
655 (void)Copy(key, nkey+1, klen, char);
659 sv_catpvn(retval, nkey, klen);
665 sv_catpvn(retval, nkey, klen);
667 sname = newSVsv(iname);
668 sv_catpvn(sname, nkey, nlen);
669 sv_catpvn(sname, "}", 1);
671 sv_catpvn(retval, " => ", 4);
675 newapad = newSVsv(apad);
676 New(0, extra, klen+4+1, char);
677 while (elen < (klen+4))
680 sv_catpvn(newapad, extra, elen);
686 DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
687 postav, levelp, indent, pad, xpad, newapad, sep,
688 freezer, toaster, purity, deepcopy, quotekeys, bless,
691 Safefree(nkey_buffer);
693 SvREFCNT_dec(newapad);
696 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
697 sv_catsv(retval, totpad);
698 sv_catsv(retval, opad);
702 sv_catpvn(retval, ")", 1);
704 sv_catpvn(retval, "}", 1);
706 SvREFCNT_dec(totpad);
708 else if (realtype == SVt_PVCV) {
709 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
711 warn("Encountered CODE ref, using dummy placeholder");
714 warn("cannot handle ref type %ld", realtype);
717 if (realpack) { /* free blessed allocs */
722 sv_catpvn(retval, ", '", 3);
723 sv_catpvn(retval, realpack, strlen(realpack));
724 sv_catpvn(retval, "' )", 3);
725 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
726 sv_catpvn(retval, "->", 2);
727 sv_catsv(retval, toaster);
728 sv_catpvn(retval, "()", 2);
738 (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
739 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
740 (sv = *svp) && SvROK(sv) &&
741 (seenentry = (AV*)SvRV(sv)))
744 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
745 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
747 sv_catpvn(retval, "${", 2);
748 sv_catsv(retval, othername);
749 sv_catpvn(retval, "}", 1);
755 namesv = newSVpvn("\\", 1);
756 sv_catpvn(namesv, name, namelen);
758 av_push(seenentry, namesv);
759 av_push(seenentry, newRV(val));
760 (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
761 SvREFCNT_dec(seenentry);
768 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
770 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
771 len = strlen(tmpbuf);
772 /* For 5.6.x and earlier will need to change this test to check
773 NV if NOK, as there NOK trumps IOK, and NV=3.5,IV=3 is valid.
774 Current code will Dump that as $VAR1 = 3;
775 Changes in 5.7 series mean that now IOK is only set if scalar
776 is precisely integer. */
778 /* Need to check to see if this is a string such as " 0".
779 I'm assuming from sprintf isn't going to clash with utf8.
780 Is this valid on EBCDIC? */
782 const char *pv = SvPV(val, pvlen);
783 if (pvlen != len || memNE(pv, tmpbuf, len))
784 goto integer_came_from_string;
787 /* Looks like we're on a 64 bit system. Make it a string so that
788 if a 32 bit system reads the number it will cope better. */
789 sv_catpvf(retval, "'%s'", tmpbuf);
791 sv_catpvn(retval, tmpbuf, len);
793 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
795 ++c; --i; /* just get the name */
796 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
800 if (needs_quote(c)) {
801 sv_grow(retval, SvCUR(retval)+6+2*i);
802 r = SvPVX(retval)+SvCUR(retval);
803 r[0] = '*'; r[1] = '{'; r[2] = '\'';
804 i += esc_q(r+3, c, i);
806 r[i++] = '\''; r[i++] = '}';
810 sv_grow(retval, SvCUR(retval)+i+2);
811 r = SvPVX(retval)+SvCUR(retval);
812 r[0] = '*'; strcpy(r+1, c);
815 SvCUR_set(retval, SvCUR(retval)+i);
818 static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
819 static STRLEN sizes[] = { 8, 7, 6 };
821 SV *nname = newSVpvn("", 0);
822 SV *newapad = newSVpvn("", 0);
826 for (j=0; j<3; j++) {
827 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
830 if (j == 0 && !SvOK(e))
835 SV *postentry = newSVpvn(r,i);
837 sv_setsv(nname, postentry);
838 sv_catpvn(nname, entries[j], sizes[j]);
839 sv_catpvn(postentry, " = ", 3);
840 av_push(postav, postentry);
845 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
847 DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
848 seenhv, postav, &nlevel, indent, pad, xpad,
849 newapad, sep, freezer, toaster, purity,
850 deepcopy, quotekeys, bless, maxdepth,
856 SvREFCNT_dec(newapad);
860 else if (val == &PL_sv_undef || !SvOK(val)) {
861 sv_catpvn(retval, "undef", 5);
864 integer_came_from_string:
867 i += esc_q_utf8(aTHX_ retval, c, i);
869 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
870 r = SvPVX(retval) + SvCUR(retval);
872 i += esc_q(r+1, c, i);
876 SvCUR_set(retval, SvCUR(retval)+i);
883 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
884 else if (namelen && seenentry) {
885 SV *mark = *av_fetch(seenentry, 2, TRUE);
893 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
896 # This is the exact equivalent of Dump. Well, almost. The things that are
897 # different as of now (due to Laziness):
898 # * doesnt do double-quotes yet.
902 Data_Dumper_Dumpxs(href, ...)
910 AV *postav, *todumpav, *namesav;
912 I32 indent, terse, i, imax, postlen;
914 SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
915 SV *freezer, *toaster, *bless, *sortkeys;
916 I32 purity, deepcopy, quotekeys, maxdepth = 0;
920 if (!SvROK(href)) { /* call new to get an object first */
922 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
929 XPUSHs(sv_2mortal(newSVsv(ST(1))));
931 XPUSHs(sv_2mortal(newSVsv(ST(2))));
933 i = perl_call_method("new", G_SCALAR);
936 href = newSVsv(POPs);
942 (void)sv_2mortal(href);
945 todumpav = namesav = Nullav;
947 val = pad = xpad = apad = sep = varname
948 = freezer = toaster = bless = &PL_sv_undef;
949 name = sv_newmortal();
951 terse = purity = deepcopy = 0;
954 retval = newSVpvn("", 0);
956 && (hv = (HV*)SvRV((SV*)href))
957 && SvTYPE(hv) == SVt_PVHV) {
959 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
960 seenhv = (HV*)SvRV(*svp);
961 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
962 todumpav = (AV*)SvRV(*svp);
963 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
964 namesav = (AV*)SvRV(*svp);
965 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
967 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
969 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
970 terse = SvTRUE(*svp);
971 #if 0 /* useqq currently unused */
972 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
973 useqq = SvTRUE(*svp);
975 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
977 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
979 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
981 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
983 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
985 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
987 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
989 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
990 deepcopy = SvTRUE(*svp);
991 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
992 quotekeys = SvTRUE(*svp);
993 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
995 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
996 maxdepth = SvIV(*svp);
997 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
999 if (! SvTRUE(sortkeys))
1001 else if (! (SvROK(sortkeys) &&
1002 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1004 /* flag to use qsortsv() for sorting hash keys */
1005 sortkeys = &PL_sv_yes;
1011 imax = av_len(todumpav);
1014 valstr = newSVpvn("",0);
1015 for (i = 0; i <= imax; ++i) {
1019 if ((svp = av_fetch(todumpav, i, FALSE)))
1023 if ((svp = av_fetch(namesav, i, TRUE)))
1024 sv_setsv(name, *svp);
1026 (void)SvOK_off(name);
1029 if ((SvPVX(name))[0] == '*') {
1031 switch (SvTYPE(SvRV(val))) {
1033 (SvPVX(name))[0] = '@';
1036 (SvPVX(name))[0] = '%';
1039 (SvPVX(name))[0] = '*';
1042 (SvPVX(name))[0] = '$';
1047 (SvPVX(name))[0] = '$';
1049 else if ((SvPVX(name))[0] != '$')
1050 sv_insert(name, 0, 0, "$", 1);
1054 sv_setpvn(name, "$", 1);
1055 sv_catsv(name, varname);
1056 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1057 nchars = strlen(tmpbuf);
1058 sv_catpvn(name, tmpbuf, nchars);
1062 SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1063 newapad = newSVsv(apad);
1064 sv_catsv(newapad, tmpsv);
1065 SvREFCNT_dec(tmpsv);
1070 DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
1071 postav, &level, indent, pad, xpad, newapad, sep,
1072 freezer, toaster, purity, deepcopy, quotekeys,
1073 bless, maxdepth, sortkeys);
1076 SvREFCNT_dec(newapad);
1078 postlen = av_len(postav);
1079 if (postlen >= 0 || !terse) {
1080 sv_insert(valstr, 0, 0, " = ", 3);
1081 sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
1082 sv_catpvn(valstr, ";", 1);
1084 sv_catsv(retval, pad);
1085 sv_catsv(retval, valstr);
1086 sv_catsv(retval, sep);
1089 sv_catsv(retval, pad);
1090 for (i = 0; i <= postlen; ++i) {
1092 svp = av_fetch(postav, i, FALSE);
1093 if (svp && (elem = *svp)) {
1094 sv_catsv(retval, elem);
1096 sv_catpvn(retval, ";", 1);
1097 sv_catsv(retval, sep);
1098 sv_catsv(retval, pad);
1102 sv_catpvn(retval, ";", 1);
1103 sv_catsv(retval, sep);
1105 sv_setpvn(valstr, "", 0);
1106 if (gimme == G_ARRAY) {
1107 XPUSHs(sv_2mortal(retval));
1108 if (i < imax) /* not the last time thro ? */
1109 retval = newSVpvn("",0);
1112 SvREFCNT_dec(postav);
1113 SvREFCNT_dec(valstr);
1116 croak("Call to new() method failed to return HASH ref");
1117 if (gimme == G_SCALAR)
1118 XPUSHs(sv_2mortal(retval));