1 #define PERL_NO_GET_CONTEXT
7 # include <patchlevel.h>
8 # if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
9 # include <could_not_find_Perl_patchlevel.h>
11 # define PERL_VERSION PATCHLEVEL
16 # define PL_sv_undef sv_undef
19 # define ERRSV GvSV(errgv)
22 # define newSVpvn newSVpv
26 static I32 num_q (char *s, STRLEN slen);
27 static I32 esc_q (char *dest, char *src, STRLEN slen);
28 static I32 esc_q_utf8 (pTHX_ SV *sv, char *src, STRLEN slen);
29 static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n);
30 static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
31 HV *seenhv, AV *postav, I32 *levelp, I32 indent,
32 SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
33 SV *freezer, SV *toaster,
34 I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
35 I32 maxdepth, SV *sortkeys);
37 /* does a string need to be protected? */
39 needs_quote(register char *s)
64 /* count the number of "'"s and "\"s in string */
66 num_q(register char *s, register STRLEN slen)
71 if (*s == '\'' || *s == '\\')
80 /* returns number of chars added to escape "'"s and "\"s in s */
81 /* slen number of characters in s will be escaped */
82 /* destination must be long enough for additional chars */
84 esc_q(register char *d, register char *s, register STRLEN slen)
104 esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen)
106 char *s, *send, *r, *rstart;
107 STRLEN j, cur = SvCUR(sv);
108 /* Could count 128-255 and 256+ in two variables, if we want to
109 be like &qquote and make a distinction. */
110 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
111 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
112 STRLEN backslashes = 0;
113 STRLEN single_quotes = 0;
114 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
117 /* this will need EBCDICification */
118 for (s = src, send = src + slen; s < send; s += UTF8SKIP(s)) {
119 UV k = utf8_to_uvchr((U8*)s, NULL);
122 /* 4: \x{} then count the number of hex digits. */
123 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
125 8 /* We may allocate a bit more than the minimum here. */
127 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
130 } else if (k == '\\') {
132 } else if (k == '\'') {
134 } else if (k == '"' || k == '$' || k == '@') {
141 /* We have something needing hex. 3 is ""\0 */
142 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
143 + 2*qq_escapables + normal);
144 rstart = r = SvPVX(sv) + cur;
148 for (s = src; s < send; s += UTF8SKIP(s)) {
149 UV k = utf8_to_uvchr((U8*)s, NULL);
151 if (k == '"' || k == '\\' || k == '$' || k == '@') {
158 /* The return value of sprintf() is unportable.
159 * In modern systems it returns (int) the number of characters,
160 * but in older systems it might return (char*) the original
161 * buffer, or it might even be (void). The easiest portable
162 * thing to do is probably use sprintf() in void context and
163 * then strlen(buffer) for the length. The more proper way
164 * would of course be to figure out the prototype of sprintf.
166 sprintf(r, "\\x{%"UVxf"}", k);
173 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
174 + qq_escapables + normal);
175 rstart = r = SvPVX(sv) + cur;
177 for (s = src; s < send; s ++) {
179 if (k == '\'' || k == '\\')
187 SvCUR_set(sv, cur + j);
192 /* append a repeated string to an SV */
194 sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n)
197 sv = newSVpvn("", 0);
199 assert(SvTYPE(sv) >= SVt_PV);
202 SvGROW(sv, len*n + SvCUR(sv) + 1);
204 char *start = SvPVX(sv) + SvCUR(sv);
212 sv_catpvn(sv, str, len);
220 * This ought to be split into smaller functions. (it is one long function since
221 * it exactly parallels the perl version, which was one long thing for
222 * efficiency raisins.) Ugggh!
225 DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
226 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
227 SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
228 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
232 char *c, *r, *realpack, id[128];
234 SV *sv, *ipad, *ival;
235 SV *blesspad = Nullsv;
236 AV *seenentry = Nullav;
238 STRLEN inamelen, idlen = 0;
244 realtype = SvTYPE(val);
250 if (SvOBJECT(SvRV(val)) && freezer &&
251 SvPOK(freezer) && SvCUR(freezer))
253 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
254 XPUSHs(val); PUTBACK;
255 i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
258 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
261 PUTBACK; FREETMPS; LEAVE;
263 (void)sv_2mortal(val);
267 realtype = SvTYPE(ival);
268 (void) sprintf(id, "0x%"UVxf, PTR2UV(ival));
271 realpack = HvNAME(SvSTASH(ival));
275 /* if it has a name, we need to either look it up, or keep a tab
276 * on it so we know when we hit it later
279 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
280 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
283 if ((svp = av_fetch(seenentry, 0, FALSE))
284 && (othername = *svp))
286 if (purity && *levelp > 0) {
289 if (realtype == SVt_PVHV)
290 sv_catpvn(retval, "{}", 2);
291 else if (realtype == SVt_PVAV)
292 sv_catpvn(retval, "[]", 2);
294 sv_catpvn(retval, "do{my $o}", 9);
295 postentry = newSVpvn(name, namelen);
296 sv_catpvn(postentry, " = ", 3);
297 sv_catsv(postentry, othername);
298 av_push(postav, postentry);
301 if (name[0] == '@' || name[0] == '%') {
302 if ((SvPVX(othername))[0] == '\\' &&
303 (SvPVX(othername))[1] == name[0]) {
304 sv_catpvn(retval, SvPVX(othername)+1,
308 sv_catpvn(retval, name, 1);
309 sv_catpvn(retval, "{", 1);
310 sv_catsv(retval, othername);
311 sv_catpvn(retval, "}", 1);
315 sv_catsv(retval, othername);
320 warn("ref name not found for %s", id);
324 else { /* store our name and continue */
326 if (name[0] == '@' || name[0] == '%') {
327 namesv = newSVpvn("\\", 1);
328 sv_catpvn(namesv, name, namelen);
330 else if (realtype == SVt_PVCV && name[0] == '*') {
331 namesv = newSVpvn("\\", 2);
332 sv_catpvn(namesv, name, namelen);
333 (SvPVX(namesv))[1] = '&';
336 namesv = newSVpvn(name, namelen);
338 av_push(seenentry, namesv);
339 (void)SvREFCNT_inc(val);
340 av_push(seenentry, val);
341 (void)hv_store(seenhv, id, strlen(id),
342 newRV((SV*)seenentry), 0);
343 SvREFCNT_dec(seenentry);
347 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
349 char *rval = SvPV(val, rlen);
350 char *slash = strchr(rval, '/');
351 sv_catpvn(retval, "qr/", 3);
353 sv_catpvn(retval, rval, slash-rval);
354 sv_catpvn(retval, "\\/", 2);
355 rlen -= slash-rval+1;
357 slash = strchr(rval, '/');
359 sv_catpvn(retval, rval, rlen);
360 sv_catpvn(retval, "/", 1);
364 /* If purity is not set and maxdepth is set, then check depth:
365 * if we have reached maximum depth, return the string
366 * representation of the thing we are currently examining
367 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
369 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
371 char *valstr = SvPV(val,vallen);
372 sv_catpvn(retval, "'", 1);
373 sv_catpvn(retval, valstr, vallen);
374 sv_catpvn(retval, "'", 1);
378 if (realpack) { /* we have a blessed ref */
380 char *blessstr = SvPV(bless, blesslen);
381 sv_catpvn(retval, blessstr, blesslen);
382 sv_catpvn(retval, "( ", 2);
385 apad = newSVsv(apad);
386 sv_x(aTHX_ apad, " ", 1, blesslen+2);
391 ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
393 if (realtype <= SVt_PVBM) { /* scalar ref */
394 SV *namesv = newSVpvn("${", 2);
395 sv_catpvn(namesv, name, namelen);
396 sv_catpvn(namesv, "}", 1);
397 if (realpack) { /* blessed */
398 sv_catpvn(retval, "do{\\(my $o = ", 13);
399 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
400 postav, levelp, indent, pad, xpad, apad, sep, pair,
401 freezer, toaster, purity, deepcopy, quotekeys, bless,
403 sv_catpvn(retval, ")}", 2);
406 sv_catpvn(retval, "\\", 1);
407 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
408 postav, levelp, indent, pad, xpad, apad, sep, pair,
409 freezer, toaster, purity, deepcopy, quotekeys, bless,
412 SvREFCNT_dec(namesv);
414 else if (realtype == SVt_PVGV) { /* glob ref */
415 SV *namesv = newSVpvn("*{", 2);
416 sv_catpvn(namesv, name, namelen);
417 sv_catpvn(namesv, "}", 1);
418 sv_catpvn(retval, "\\", 1);
419 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
420 postav, levelp, indent, pad, xpad, apad, sep, pair,
421 freezer, toaster, purity, deepcopy, quotekeys, bless,
423 SvREFCNT_dec(namesv);
425 else if (realtype == SVt_PVAV) {
428 I32 ixmax = av_len((AV *)ival);
430 SV *ixsv = newSViv(0);
431 /* allowing for a 24 char wide array index */
432 New(0, iname, namelen+28, char);
433 (void)strcpy(iname, name);
435 if (name[0] == '@') {
436 sv_catpvn(retval, "(", 1);
440 sv_catpvn(retval, "[", 1);
441 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
443 && name[namelen-1] != ']' && name[namelen-1] != '}'
444 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
446 && name[namelen-1] != ']' && name[namelen-1] != '}')
449 || (name[0] == '\\' && name[2] == '{'))))
451 iname[inamelen++] = '-'; iname[inamelen++] = '>';
452 iname[inamelen] = '\0';
455 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
456 (instr(iname+inamelen-8, "{SCALAR}") ||
457 instr(iname+inamelen-7, "{ARRAY}") ||
458 instr(iname+inamelen-6, "{HASH}"))) {
459 iname[inamelen++] = '-'; iname[inamelen++] = '>';
461 iname[inamelen++] = '['; iname[inamelen] = '\0';
462 totpad = newSVsv(sep);
463 sv_catsv(totpad, pad);
464 sv_catsv(totpad, apad);
466 for (ix = 0; ix <= ixmax; ++ix) {
469 svp = av_fetch((AV*)ival, ix, FALSE);
477 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
478 ilen = strlen(iname);
479 iname[ilen++] = ']'; iname[ilen] = '\0';
481 sv_catsv(retval, totpad);
482 sv_catsv(retval, ipad);
483 sv_catpvn(retval, "#", 1);
484 sv_catsv(retval, ixsv);
486 sv_catsv(retval, totpad);
487 sv_catsv(retval, ipad);
488 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
489 levelp, indent, pad, xpad, apad, sep, pair,
490 freezer, toaster, purity, deepcopy, quotekeys, bless,
493 sv_catpvn(retval, ",", 1);
496 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
497 sv_catsv(retval, totpad);
498 sv_catsv(retval, opad);
502 sv_catpvn(retval, ")", 1);
504 sv_catpvn(retval, "]", 1);
506 SvREFCNT_dec(totpad);
509 else if (realtype == SVt_PVHV) {
510 SV *totpad, *newapad;
518 iname = newSVpvn(name, namelen);
519 if (name[0] == '%') {
520 sv_catpvn(retval, "(", 1);
521 (SvPVX(iname))[0] = '$';
524 sv_catpvn(retval, "{", 1);
525 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
527 && name[namelen-1] != ']' && name[namelen-1] != '}')
530 || (name[0] == '\\' && name[2] == '{'))))
532 sv_catpvn(iname, "->", 2);
535 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
536 (instr(name+namelen-8, "{SCALAR}") ||
537 instr(name+namelen-7, "{ARRAY}") ||
538 instr(name+namelen-6, "{HASH}"))) {
539 sv_catpvn(iname, "->", 2);
541 sv_catpvn(iname, "{", 1);
542 totpad = newSVsv(sep);
543 sv_catsv(totpad, pad);
544 sv_catsv(totpad, apad);
546 /* If requested, get a sorted/filtered array of hash keys */
548 if (sortkeys == &PL_sv_yes) {
550 (void)hv_iterinit((HV*)ival);
551 while ((entry = hv_iternext((HV*)ival))) {
552 sv = hv_iterkeysv(entry);
556 #ifdef USE_LOCALE_NUMERIC
557 sortsv(AvARRAY(keys),
559 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
561 sortsv(AvARRAY(keys),
567 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
568 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
569 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
573 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
574 keys = (AV*)SvREFCNT_inc(SvRV(sv));
577 warn("Sortkeys subroutine did not return ARRAYREF\n");
578 PUTBACK; FREETMPS; LEAVE;
581 sv_2mortal((SV*)keys);
584 (void)hv_iterinit((HV*)ival);
586 /* foreach (keys %hash) */
587 for (i = 0; 1; i++) {
589 char *nkey_buffer = NULL;
594 bool do_utf8 = FALSE;
596 if ((sortkeys && !(keys && (I32)i <= av_len(keys))) ||
597 !(entry = hv_iternext((HV *)ival)))
601 sv_catpvn(retval, ",", 1);
605 svp = av_fetch(keys, i, FALSE);
606 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
607 key = SvPV(keysv, keylen);
608 svp = hv_fetch((HV*)ival, key,
609 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
610 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
613 keysv = hv_iterkeysv(entry);
614 hval = hv_iterval((HV*)ival, entry);
617 do_utf8 = DO_UTF8(keysv);
618 key = SvPV(keysv, keylen);
621 sv_catsv(retval, totpad);
622 sv_catsv(retval, ipad);
623 /* old logic was first to check utf8 flag, and if utf8 always
624 call esc_q_utf8. This caused test to break under -Mutf8,
625 because there even strings like 'c' have utf8 flag on.
626 Hence with quotekeys == 0 the XS code would still '' quote
627 them based on flags, whereas the perl code would not,
629 The perl code is correct.
630 needs_quote() decides that anything that isn't a valid
631 perl identifier needs to be quoted, hence only correctly
632 formed strings with no characters outside [A-Za-z0-9_:]
633 won't need quoting. None of those characters are used in
634 the byte encoding of utf8, so anything with utf8
635 encoded characters in will need quoting. Hence strings
636 with utf8 encoded characters in will end up inside do_utf8
637 just like before, but now strings with utf8 flag set but
638 only ascii characters will end up in the unquoted section.
640 There should also be less tests for the (probably currently)
641 more common doesn't need quoting case.
642 The code is also smaller (22044 vs 22260) because I've been
643 able to pull the common logic out to both sides. */
644 if (quotekeys || needs_quote(key)) {
646 STRLEN ocur = SvCUR(retval);
647 nlen = esc_q_utf8(aTHX_ retval, key, klen);
648 nkey = SvPVX(retval) + ocur;
651 nticks = num_q(key, klen);
652 New(0, nkey_buffer, klen+nticks+3, char);
656 klen += esc_q(nkey+1, key, klen);
658 (void)Copy(key, nkey+1, klen, char);
662 sv_catpvn(retval, nkey, klen);
668 sv_catpvn(retval, nkey, klen);
670 sname = newSVsv(iname);
671 sv_catpvn(sname, nkey, nlen);
672 sv_catpvn(sname, "}", 1);
674 sv_catsv(retval, pair);
678 newapad = newSVsv(apad);
679 New(0, extra, klen+4+1, char);
680 while (elen < (klen+4))
683 sv_catpvn(newapad, extra, elen);
689 DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
690 postav, levelp, indent, pad, xpad, newapad, sep, pair,
691 freezer, toaster, purity, deepcopy, quotekeys, bless,
694 Safefree(nkey_buffer);
696 SvREFCNT_dec(newapad);
699 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
700 sv_catsv(retval, totpad);
701 sv_catsv(retval, opad);
705 sv_catpvn(retval, ")", 1);
707 sv_catpvn(retval, "}", 1);
709 SvREFCNT_dec(totpad);
711 else if (realtype == SVt_PVCV) {
712 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
714 warn("Encountered CODE ref, using dummy placeholder");
717 warn("cannot handle ref type %ld", realtype);
720 if (realpack) { /* free blessed allocs */
725 sv_catpvn(retval, ", '", 3);
726 sv_catpvn(retval, realpack, strlen(realpack));
727 sv_catpvn(retval, "' )", 3);
728 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
729 sv_catpvn(retval, "->", 2);
730 sv_catsv(retval, toaster);
731 sv_catpvn(retval, "()", 2);
741 (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
742 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
743 (sv = *svp) && SvROK(sv) &&
744 (seenentry = (AV*)SvRV(sv)))
747 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
748 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
750 sv_catpvn(retval, "${", 2);
751 sv_catsv(retval, othername);
752 sv_catpvn(retval, "}", 1);
756 else if (val != &PL_sv_undef) {
758 namesv = newSVpvn("\\", 1);
759 sv_catpvn(namesv, name, namelen);
761 av_push(seenentry, namesv);
762 av_push(seenentry, newRV(val));
763 (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
764 SvREFCNT_dec(seenentry);
771 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
773 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
774 len = strlen(tmpbuf);
775 /* For 5.6.x and earlier will need to change this test to check
776 NV if NOK, as there NOK trumps IOK, and NV=3.5,IV=3 is valid.
777 Current code will Dump that as $VAR1 = 3;
778 Changes in 5.7 series mean that now IOK is only set if scalar
779 is precisely integer. */
781 /* Need to check to see if this is a string such as " 0".
782 I'm assuming from sprintf isn't going to clash with utf8.
783 Is this valid on EBCDIC? */
785 const char *pv = SvPV(val, pvlen);
786 if (pvlen != len || memNE(pv, tmpbuf, len))
787 goto integer_came_from_string;
790 /* Looks like we're on a 64 bit system. Make it a string so that
791 if a 32 bit system reads the number it will cope better. */
792 sv_catpvf(retval, "'%s'", tmpbuf);
794 sv_catpvn(retval, tmpbuf, len);
796 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
798 ++c; --i; /* just get the name */
799 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
803 if (needs_quote(c)) {
804 sv_grow(retval, SvCUR(retval)+6+2*i);
805 r = SvPVX(retval)+SvCUR(retval);
806 r[0] = '*'; r[1] = '{'; r[2] = '\'';
807 i += esc_q(r+3, c, i);
809 r[i++] = '\''; r[i++] = '}';
813 sv_grow(retval, SvCUR(retval)+i+2);
814 r = SvPVX(retval)+SvCUR(retval);
815 r[0] = '*'; strcpy(r+1, c);
818 SvCUR_set(retval, SvCUR(retval)+i);
821 static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
822 static STRLEN sizes[] = { 8, 7, 6 };
824 SV *nname = newSVpvn("", 0);
825 SV *newapad = newSVpvn("", 0);
829 for (j=0; j<3; j++) {
830 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
833 if (j == 0 && !SvOK(e))
838 SV *postentry = newSVpvn(r,i);
840 sv_setsv(nname, postentry);
841 sv_catpvn(nname, entries[j], sizes[j]);
842 sv_catpvn(postentry, " = ", 3);
843 av_push(postav, postentry);
848 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
850 DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
851 seenhv, postav, &nlevel, indent, pad, xpad,
852 newapad, sep, pair, freezer, toaster, purity,
853 deepcopy, quotekeys, bless, maxdepth,
859 SvREFCNT_dec(newapad);
863 else if (val == &PL_sv_undef || !SvOK(val)) {
864 sv_catpvn(retval, "undef", 5);
867 integer_came_from_string:
870 i += esc_q_utf8(aTHX_ retval, c, i);
872 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
873 r = SvPVX(retval) + SvCUR(retval);
875 i += esc_q(r+1, c, i);
879 SvCUR_set(retval, SvCUR(retval)+i);
886 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
887 else if (namelen && seenentry) {
888 SV *mark = *av_fetch(seenentry, 2, TRUE);
896 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
899 # This is the exact equivalent of Dump. Well, almost. The things that are
900 # different as of now (due to Laziness):
901 # * doesnt do double-quotes yet.
905 Data_Dumper_Dumpxs(href, ...)
913 AV *postav, *todumpav, *namesav;
915 I32 indent, terse, i, imax, postlen;
917 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
918 SV *freezer, *toaster, *bless, *sortkeys;
919 I32 purity, deepcopy, quotekeys, maxdepth = 0;
923 if (!SvROK(href)) { /* call new to get an object first */
925 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
932 XPUSHs(sv_2mortal(newSVsv(ST(1))));
934 XPUSHs(sv_2mortal(newSVsv(ST(2))));
936 i = perl_call_method("new", G_SCALAR);
939 href = newSVsv(POPs);
945 (void)sv_2mortal(href);
948 todumpav = namesav = Nullav;
950 val = pad = xpad = apad = sep = pair = varname
951 = freezer = toaster = bless = &PL_sv_undef;
952 name = sv_newmortal();
954 terse = purity = deepcopy = 0;
957 retval = newSVpvn("", 0);
959 && (hv = (HV*)SvRV((SV*)href))
960 && SvTYPE(hv) == SVt_PVHV) {
962 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
963 seenhv = (HV*)SvRV(*svp);
964 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
965 todumpav = (AV*)SvRV(*svp);
966 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
967 namesav = (AV*)SvRV(*svp);
968 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
970 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
972 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
973 terse = SvTRUE(*svp);
974 #if 0 /* useqq currently unused */
975 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
976 useqq = SvTRUE(*svp);
978 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
980 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
982 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
984 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
986 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
988 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
990 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
992 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
994 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
995 deepcopy = SvTRUE(*svp);
996 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
997 quotekeys = SvTRUE(*svp);
998 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1000 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1001 maxdepth = SvIV(*svp);
1002 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1004 if (! SvTRUE(sortkeys))
1006 else if (! (SvROK(sortkeys) &&
1007 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1009 /* flag to use qsortsv() for sorting hash keys */
1010 sortkeys = &PL_sv_yes;
1016 imax = av_len(todumpav);
1019 valstr = newSVpvn("",0);
1020 for (i = 0; i <= imax; ++i) {
1024 if ((svp = av_fetch(todumpav, i, FALSE)))
1028 if ((svp = av_fetch(namesav, i, TRUE)))
1029 sv_setsv(name, *svp);
1031 (void)SvOK_off(name);
1034 if ((SvPVX(name))[0] == '*') {
1036 switch (SvTYPE(SvRV(val))) {
1038 (SvPVX(name))[0] = '@';
1041 (SvPVX(name))[0] = '%';
1044 (SvPVX(name))[0] = '*';
1047 (SvPVX(name))[0] = '$';
1052 (SvPVX(name))[0] = '$';
1054 else if ((SvPVX(name))[0] != '$')
1055 sv_insert(name, 0, 0, "$", 1);
1059 sv_setpvn(name, "$", 1);
1060 sv_catsv(name, varname);
1061 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1062 nchars = strlen(tmpbuf);
1063 sv_catpvn(name, tmpbuf, nchars);
1067 SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1068 newapad = newSVsv(apad);
1069 sv_catsv(newapad, tmpsv);
1070 SvREFCNT_dec(tmpsv);
1075 DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
1076 postav, &level, indent, pad, xpad, newapad, sep, pair,
1077 freezer, toaster, purity, deepcopy, quotekeys,
1078 bless, maxdepth, sortkeys);
1081 SvREFCNT_dec(newapad);
1083 postlen = av_len(postav);
1084 if (postlen >= 0 || !terse) {
1085 sv_insert(valstr, 0, 0, " = ", 3);
1086 sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
1087 sv_catpvn(valstr, ";", 1);
1089 sv_catsv(retval, pad);
1090 sv_catsv(retval, valstr);
1091 sv_catsv(retval, sep);
1094 sv_catsv(retval, pad);
1095 for (i = 0; i <= postlen; ++i) {
1097 svp = av_fetch(postav, i, FALSE);
1098 if (svp && (elem = *svp)) {
1099 sv_catsv(retval, elem);
1101 sv_catpvn(retval, ";", 1);
1102 sv_catsv(retval, sep);
1103 sv_catsv(retval, pad);
1107 sv_catpvn(retval, ";", 1);
1108 sv_catsv(retval, sep);
1110 sv_setpvn(valstr, "", 0);
1111 if (gimme == G_ARRAY) {
1112 XPUSHs(sv_2mortal(retval));
1113 if (i < imax) /* not the last time thro ? */
1114 retval = newSVpvn("",0);
1117 SvREFCNT_dec(postav);
1118 SvREFCNT_dec(valstr);
1121 croak("Call to new() method failed to return HASH ref");
1122 if (gimme == G_SCALAR)
1123 XPUSHs(sv_2mortal(retval));