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): %s",
259 PUTBACK; FREETMPS; LEAVE;
261 (void)sv_2mortal(val);
265 realtype = SvTYPE(ival);
266 (void) sprintf(id, "0x%"UVxf, PTR2UV(ival));
269 realpack = HvNAME(SvSTASH(ival));
273 /* if it has a name, we need to either look it up, or keep a tab
274 * on it so we know when we hit it later
277 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
278 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
281 if ((svp = av_fetch(seenentry, 0, FALSE))
282 && (othername = *svp))
284 if (purity && *levelp > 0) {
287 if (realtype == SVt_PVHV)
288 sv_catpvn(retval, "{}", 2);
289 else if (realtype == SVt_PVAV)
290 sv_catpvn(retval, "[]", 2);
292 sv_catpvn(retval, "do{my $o}", 9);
293 postentry = newSVpvn(name, namelen);
294 sv_catpvn(postentry, " = ", 3);
295 sv_catsv(postentry, othername);
296 av_push(postav, postentry);
299 if (name[0] == '@' || name[0] == '%') {
300 if ((SvPVX(othername))[0] == '\\' &&
301 (SvPVX(othername))[1] == name[0]) {
302 sv_catpvn(retval, SvPVX(othername)+1,
306 sv_catpvn(retval, name, 1);
307 sv_catpvn(retval, "{", 1);
308 sv_catsv(retval, othername);
309 sv_catpvn(retval, "}", 1);
313 sv_catsv(retval, othername);
318 warn("ref name not found for %s", id);
322 else { /* store our name and continue */
324 if (name[0] == '@' || name[0] == '%') {
325 namesv = newSVpvn("\\", 1);
326 sv_catpvn(namesv, name, namelen);
328 else if (realtype == SVt_PVCV && name[0] == '*') {
329 namesv = newSVpvn("\\", 2);
330 sv_catpvn(namesv, name, namelen);
331 (SvPVX(namesv))[1] = '&';
334 namesv = newSVpvn(name, namelen);
336 av_push(seenentry, namesv);
337 (void)SvREFCNT_inc(val);
338 av_push(seenentry, val);
339 (void)hv_store(seenhv, id, strlen(id),
340 newRV((SV*)seenentry), 0);
341 SvREFCNT_dec(seenentry);
345 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
347 char *rval = SvPV(val, rlen);
348 char *slash = strchr(rval, '/');
349 sv_catpvn(retval, "qr/", 3);
351 sv_catpvn(retval, rval, slash-rval);
352 sv_catpvn(retval, "\\/", 2);
353 rlen -= slash-rval+1;
355 slash = strchr(rval, '/');
357 sv_catpvn(retval, rval, rlen);
358 sv_catpvn(retval, "/", 1);
362 /* If purity is not set and maxdepth is set, then check depth:
363 * if we have reached maximum depth, return the string
364 * representation of the thing we are currently examining
365 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
367 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
369 char *valstr = SvPV(val,vallen);
370 sv_catpvn(retval, "'", 1);
371 sv_catpvn(retval, valstr, vallen);
372 sv_catpvn(retval, "'", 1);
376 if (realpack) { /* we have a blessed ref */
378 char *blessstr = SvPV(bless, blesslen);
379 sv_catpvn(retval, blessstr, blesslen);
380 sv_catpvn(retval, "( ", 2);
383 apad = newSVsv(apad);
384 sv_x(aTHX_ apad, " ", 1, blesslen+2);
389 ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
391 if (realtype <= SVt_PVBM) { /* scalar ref */
392 SV *namesv = newSVpvn("${", 2);
393 sv_catpvn(namesv, name, namelen);
394 sv_catpvn(namesv, "}", 1);
395 if (realpack) { /* blessed */
396 sv_catpvn(retval, "do{\\(my $o = ", 13);
397 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
398 postav, levelp, indent, pad, xpad, apad, sep,
399 freezer, toaster, purity, deepcopy, quotekeys, bless,
401 sv_catpvn(retval, ")}", 2);
404 sv_catpvn(retval, "\\", 1);
405 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
406 postav, levelp, indent, pad, xpad, apad, sep,
407 freezer, toaster, purity, deepcopy, quotekeys, bless,
410 SvREFCNT_dec(namesv);
412 else if (realtype == SVt_PVGV) { /* glob ref */
413 SV *namesv = newSVpvn("*{", 2);
414 sv_catpvn(namesv, name, namelen);
415 sv_catpvn(namesv, "}", 1);
416 sv_catpvn(retval, "\\", 1);
417 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
418 postav, levelp, indent, pad, xpad, apad, sep,
419 freezer, toaster, purity, deepcopy, quotekeys, bless,
421 SvREFCNT_dec(namesv);
423 else if (realtype == SVt_PVAV) {
426 I32 ixmax = av_len((AV *)ival);
428 SV *ixsv = newSViv(0);
429 /* allowing for a 24 char wide array index */
430 New(0, iname, namelen+28, char);
431 (void)strcpy(iname, name);
433 if (name[0] == '@') {
434 sv_catpvn(retval, "(", 1);
438 sv_catpvn(retval, "[", 1);
439 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
441 && name[namelen-1] != ']' && name[namelen-1] != '}'
442 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
444 && name[namelen-1] != ']' && name[namelen-1] != '}')
447 || (name[0] == '\\' && name[2] == '{'))))
449 iname[inamelen++] = '-'; iname[inamelen++] = '>';
450 iname[inamelen] = '\0';
453 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
454 (instr(iname+inamelen-8, "{SCALAR}") ||
455 instr(iname+inamelen-7, "{ARRAY}") ||
456 instr(iname+inamelen-6, "{HASH}"))) {
457 iname[inamelen++] = '-'; iname[inamelen++] = '>';
459 iname[inamelen++] = '['; iname[inamelen] = '\0';
460 totpad = newSVsv(sep);
461 sv_catsv(totpad, pad);
462 sv_catsv(totpad, apad);
464 for (ix = 0; ix <= ixmax; ++ix) {
467 svp = av_fetch((AV*)ival, ix, FALSE);
475 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
476 ilen = strlen(iname);
477 iname[ilen++] = ']'; iname[ilen] = '\0';
479 sv_catsv(retval, totpad);
480 sv_catsv(retval, ipad);
481 sv_catpvn(retval, "#", 1);
482 sv_catsv(retval, ixsv);
484 sv_catsv(retval, totpad);
485 sv_catsv(retval, ipad);
486 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
487 levelp, indent, pad, xpad, apad, sep,
488 freezer, toaster, purity, deepcopy, quotekeys, bless,
491 sv_catpvn(retval, ",", 1);
494 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
495 sv_catsv(retval, totpad);
496 sv_catsv(retval, opad);
500 sv_catpvn(retval, ")", 1);
502 sv_catpvn(retval, "]", 1);
504 SvREFCNT_dec(totpad);
507 else if (realtype == SVt_PVHV) {
508 SV *totpad, *newapad;
516 iname = newSVpvn(name, namelen);
517 if (name[0] == '%') {
518 sv_catpvn(retval, "(", 1);
519 (SvPVX(iname))[0] = '$';
522 sv_catpvn(retval, "{", 1);
523 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
525 && name[namelen-1] != ']' && name[namelen-1] != '}')
528 || (name[0] == '\\' && name[2] == '{'))))
530 sv_catpvn(iname, "->", 2);
533 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
534 (instr(name+namelen-8, "{SCALAR}") ||
535 instr(name+namelen-7, "{ARRAY}") ||
536 instr(name+namelen-6, "{HASH}"))) {
537 sv_catpvn(iname, "->", 2);
539 sv_catpvn(iname, "{", 1);
540 totpad = newSVsv(sep);
541 sv_catsv(totpad, pad);
542 sv_catsv(totpad, apad);
544 /* If requested, get a sorted/filtered array of hash keys */
546 if (sortkeys == &PL_sv_yes) {
548 (void)hv_iterinit((HV*)ival);
549 while ((entry = hv_iternext((HV*)ival))) {
550 sv = hv_iterkeysv(entry);
554 #ifdef USE_LOCALE_NUMERIC
555 sortsv(AvARRAY(keys),
557 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
559 sortsv(AvARRAY(keys),
565 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
566 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
567 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
571 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
572 keys = (AV*)SvREFCNT_inc(SvRV(sv));
575 warn("Sortkeys subroutine did not return ARRAYREF\n");
576 PUTBACK; FREETMPS; LEAVE;
579 sv_2mortal((SV*)keys);
582 (void)hv_iterinit((HV*)ival);
584 /* foreach (keys %hash) */
585 for (i = 0; 1; i++) {
587 char *nkey_buffer = NULL;
592 bool do_utf8 = FALSE;
594 if ((sortkeys && !(keys && (I32)i <= av_len(keys))) ||
595 !(entry = hv_iternext((HV *)ival)))
599 sv_catpvn(retval, ",", 1);
603 svp = av_fetch(keys, i, FALSE);
604 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
605 key = SvPV(keysv, keylen);
606 svp = hv_fetch((HV*)ival, key,
607 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
608 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
611 keysv = hv_iterkeysv(entry);
612 hval = hv_iterval((HV*)ival, entry);
615 do_utf8 = DO_UTF8(keysv);
616 key = SvPV(keysv, keylen);
619 sv_catsv(retval, totpad);
620 sv_catsv(retval, ipad);
621 /* old logic was first to check utf8 flag, and if utf8 always
622 call esc_q_utf8. This caused test to break under -Mutf8,
623 because there even strings like 'c' have utf8 flag on.
624 Hence with quotekeys == 0 the XS code would still '' quote
625 them based on flags, whereas the perl code would not,
627 The perl code is correct.
628 needs_quote() decides that anything that isn't a valid
629 perl identifier needs to be quoted, hence only correctly
630 formed strings with no characters outside [A-Za-z0-9_:]
631 won't need quoting. None of those characters are used in
632 the byte encoding of utf8, so anything with utf8
633 encoded characters in will need quoting. Hence strings
634 with utf8 encoded characters in will end up inside do_utf8
635 just like before, but now strings with utf8 flag set but
636 only ascii characters will end up in the unquoted section.
638 There should also be less tests for the (probably currently)
639 more common doesn't need quoting case.
640 The code is also smaller (22044 vs 22260) because I've been
641 able to pull the comon logic out to both sides. */
642 if (quotekeys || needs_quote(key)) {
644 STRLEN ocur = SvCUR(retval);
645 nlen = esc_q_utf8(aTHX_ retval, key, klen);
646 nkey = SvPVX(retval) + ocur;
649 nticks = num_q(key, klen);
650 New(0, nkey_buffer, klen+nticks+3, char);
654 klen += esc_q(nkey+1, key, klen);
656 (void)Copy(key, nkey+1, klen, char);
660 sv_catpvn(retval, nkey, klen);
666 sv_catpvn(retval, nkey, klen);
668 sname = newSVsv(iname);
669 sv_catpvn(sname, nkey, nlen);
670 sv_catpvn(sname, "}", 1);
672 sv_catpvn(retval, " => ", 4);
676 newapad = newSVsv(apad);
677 New(0, extra, klen+4+1, char);
678 while (elen < (klen+4))
681 sv_catpvn(newapad, extra, elen);
687 DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
688 postav, levelp, indent, pad, xpad, newapad, sep,
689 freezer, toaster, purity, deepcopy, quotekeys, bless,
692 Safefree(nkey_buffer);
694 SvREFCNT_dec(newapad);
697 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
698 sv_catsv(retval, totpad);
699 sv_catsv(retval, opad);
703 sv_catpvn(retval, ")", 1);
705 sv_catpvn(retval, "}", 1);
707 SvREFCNT_dec(totpad);
709 else if (realtype == SVt_PVCV) {
710 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
712 warn("Encountered CODE ref, using dummy placeholder");
715 warn("cannot handle ref type %ld", realtype);
718 if (realpack) { /* free blessed allocs */
723 sv_catpvn(retval, ", '", 3);
724 sv_catpvn(retval, realpack, strlen(realpack));
725 sv_catpvn(retval, "' )", 3);
726 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
727 sv_catpvn(retval, "->", 2);
728 sv_catsv(retval, toaster);
729 sv_catpvn(retval, "()", 2);
739 (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
740 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
741 (sv = *svp) && SvROK(sv) &&
742 (seenentry = (AV*)SvRV(sv)))
745 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
746 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
748 sv_catpvn(retval, "${", 2);
749 sv_catsv(retval, othername);
750 sv_catpvn(retval, "}", 1);
756 namesv = newSVpvn("\\", 1);
757 sv_catpvn(namesv, name, namelen);
759 av_push(seenentry, namesv);
760 av_push(seenentry, newRV(val));
761 (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
762 SvREFCNT_dec(seenentry);
769 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
771 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
772 len = strlen(tmpbuf);
773 /* For 5.6.x and earlier will need to change this test to check
774 NV if NOK, as there NOK trumps IOK, and NV=3.5,IV=3 is valid.
775 Current code will Dump that as $VAR1 = 3;
776 Changes in 5.7 series mean that now IOK is only set if scalar
777 is precisely integer. */
779 /* Need to check to see if this is a string such as " 0".
780 I'm assuming from sprintf isn't going to clash with utf8.
781 Is this valid on EBCDIC? */
783 const char *pv = SvPV(val, pvlen);
784 if (pvlen != len || memNE(pv, tmpbuf, len))
785 goto integer_came_from_string;
788 /* Looks like we're on a 64 bit system. Make it a string so that
789 if a 32 bit system reads the number it will cope better. */
790 sv_catpvf(retval, "'%s'", tmpbuf);
792 sv_catpvn(retval, tmpbuf, len);
794 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
796 ++c; --i; /* just get the name */
797 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
801 if (needs_quote(c)) {
802 sv_grow(retval, SvCUR(retval)+6+2*i);
803 r = SvPVX(retval)+SvCUR(retval);
804 r[0] = '*'; r[1] = '{'; r[2] = '\'';
805 i += esc_q(r+3, c, i);
807 r[i++] = '\''; r[i++] = '}';
811 sv_grow(retval, SvCUR(retval)+i+2);
812 r = SvPVX(retval)+SvCUR(retval);
813 r[0] = '*'; strcpy(r+1, c);
816 SvCUR_set(retval, SvCUR(retval)+i);
819 static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
820 static STRLEN sizes[] = { 8, 7, 6 };
822 SV *nname = newSVpvn("", 0);
823 SV *newapad = newSVpvn("", 0);
827 for (j=0; j<3; j++) {
828 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
831 if (j == 0 && !SvOK(e))
836 SV *postentry = newSVpvn(r,i);
838 sv_setsv(nname, postentry);
839 sv_catpvn(nname, entries[j], sizes[j]);
840 sv_catpvn(postentry, " = ", 3);
841 av_push(postav, postentry);
846 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
848 DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
849 seenhv, postav, &nlevel, indent, pad, xpad,
850 newapad, sep, freezer, toaster, purity,
851 deepcopy, quotekeys, bless, maxdepth,
857 SvREFCNT_dec(newapad);
861 else if (val == &PL_sv_undef || !SvOK(val)) {
862 sv_catpvn(retval, "undef", 5);
865 integer_came_from_string:
868 i += esc_q_utf8(aTHX_ retval, c, i);
870 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
871 r = SvPVX(retval) + SvCUR(retval);
873 i += esc_q(r+1, c, i);
877 SvCUR_set(retval, SvCUR(retval)+i);
884 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
885 else if (namelen && seenentry) {
886 SV *mark = *av_fetch(seenentry, 2, TRUE);
894 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
897 # This is the exact equivalent of Dump. Well, almost. The things that are
898 # different as of now (due to Laziness):
899 # * doesnt do double-quotes yet.
903 Data_Dumper_Dumpxs(href, ...)
911 AV *postav, *todumpav, *namesav;
913 I32 indent, terse, i, imax, postlen;
915 SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
916 SV *freezer, *toaster, *bless, *sortkeys;
917 I32 purity, deepcopy, quotekeys, maxdepth = 0;
921 if (!SvROK(href)) { /* call new to get an object first */
923 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
930 XPUSHs(sv_2mortal(newSVsv(ST(1))));
932 XPUSHs(sv_2mortal(newSVsv(ST(2))));
934 i = perl_call_method("new", G_SCALAR);
937 href = newSVsv(POPs);
943 (void)sv_2mortal(href);
946 todumpav = namesav = Nullav;
948 val = pad = xpad = apad = sep = varname
949 = freezer = toaster = bless = &PL_sv_undef;
950 name = sv_newmortal();
952 terse = purity = deepcopy = 0;
955 retval = newSVpvn("", 0);
957 && (hv = (HV*)SvRV((SV*)href))
958 && SvTYPE(hv) == SVt_PVHV) {
960 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
961 seenhv = (HV*)SvRV(*svp);
962 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
963 todumpav = (AV*)SvRV(*svp);
964 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
965 namesav = (AV*)SvRV(*svp);
966 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
968 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
970 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
971 terse = SvTRUE(*svp);
972 #if 0 /* useqq currently unused */
973 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
974 useqq = SvTRUE(*svp);
976 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
978 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
980 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
982 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
984 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
986 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
988 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
990 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
991 deepcopy = SvTRUE(*svp);
992 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
993 quotekeys = SvTRUE(*svp);
994 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
996 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
997 maxdepth = SvIV(*svp);
998 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1000 if (! SvTRUE(sortkeys))
1002 else if (! (SvROK(sortkeys) &&
1003 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1005 /* flag to use qsortsv() for sorting hash keys */
1006 sortkeys = &PL_sv_yes;
1012 imax = av_len(todumpav);
1015 valstr = newSVpvn("",0);
1016 for (i = 0; i <= imax; ++i) {
1020 if ((svp = av_fetch(todumpav, i, FALSE)))
1024 if ((svp = av_fetch(namesav, i, TRUE)))
1025 sv_setsv(name, *svp);
1027 (void)SvOK_off(name);
1030 if ((SvPVX(name))[0] == '*') {
1032 switch (SvTYPE(SvRV(val))) {
1034 (SvPVX(name))[0] = '@';
1037 (SvPVX(name))[0] = '%';
1040 (SvPVX(name))[0] = '*';
1043 (SvPVX(name))[0] = '$';
1048 (SvPVX(name))[0] = '$';
1050 else if ((SvPVX(name))[0] != '$')
1051 sv_insert(name, 0, 0, "$", 1);
1055 sv_setpvn(name, "$", 1);
1056 sv_catsv(name, varname);
1057 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1058 nchars = strlen(tmpbuf);
1059 sv_catpvn(name, tmpbuf, nchars);
1063 SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1064 newapad = newSVsv(apad);
1065 sv_catsv(newapad, tmpsv);
1066 SvREFCNT_dec(tmpsv);
1071 DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
1072 postav, &level, indent, pad, xpad, newapad, sep,
1073 freezer, toaster, purity, deepcopy, quotekeys,
1074 bless, maxdepth, sortkeys);
1077 SvREFCNT_dec(newapad);
1079 postlen = av_len(postav);
1080 if (postlen >= 0 || !terse) {
1081 sv_insert(valstr, 0, 0, " = ", 3);
1082 sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
1083 sv_catpvn(valstr, ";", 1);
1085 sv_catsv(retval, pad);
1086 sv_catsv(retval, valstr);
1087 sv_catsv(retval, sep);
1090 sv_catsv(retval, pad);
1091 for (i = 0; i <= postlen; ++i) {
1093 svp = av_fetch(postav, i, FALSE);
1094 if (svp && (elem = *svp)) {
1095 sv_catsv(retval, elem);
1097 sv_catpvn(retval, ";", 1);
1098 sv_catsv(retval, sep);
1099 sv_catsv(retval, pad);
1103 sv_catpvn(retval, ";", 1);
1104 sv_catsv(retval, sep);
1106 sv_setpvn(valstr, "", 0);
1107 if (gimme == G_ARRAY) {
1108 XPUSHs(sv_2mortal(retval));
1109 if (i < imax) /* not the last time thro ? */
1110 retval = newSVpvn("",0);
1113 SvREFCNT_dec(postav);
1114 SvREFCNT_dec(valstr);
1117 croak("Call to new() method failed to return HASH ref");
1118 if (gimme == G_SCALAR)
1119 XPUSHs(sv_2mortal(retval));