1 #define PERL_NO_GET_CONTEXT
6 static I32 num_q (const char *s, STRLEN slen);
7 static I32 esc_q (char *dest, const char *src, STRLEN slen);
8 static I32 esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen);
9 static I32 needs_quote(register const char *s);
10 static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
11 static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
12 HV *seenhv, AV *postav, I32 *levelp, I32 indent,
13 SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
14 SV *freezer, SV *toaster,
15 I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
16 I32 maxdepth, SV *sortkeys);
19 #define HvNAME_get HvNAME
22 #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
25 # define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
27 # define UNI_TO_NATIVE(ch) (ch)
31 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
33 const UV uv = utf8_to_uv(s, UTF8_MAXLEN, retlen,
34 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
35 return UNI_TO_NATIVE(uv);
38 # if !defined(PERL_IMPLICIT_CONTEXT)
39 # define utf8_to_uvchr Perl_utf8_to_uvchr
41 # define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
44 #endif /* PERL_VERSION <= 6 */
46 /* Changes in 5.7 series mean that now IOK is only set if scalar is
47 precisely integer but in 5.6 and earlier we need to do a more
50 #define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
52 #define DD_is_integer(sv) SvIOK(sv)
55 /* does a string need to be protected? */
57 needs_quote(register const char *s)
82 /* count the number of "'"s and "\"s in string */
84 num_q(register const char *s, register STRLEN slen)
89 if (*s == '\'' || *s == '\\')
98 /* returns number of chars added to escape "'"s and "\"s in s */
99 /* slen number of characters in s will be escaped */
100 /* destination must be long enough for additional chars */
102 esc_q(register char *d, register const char *s, register STRLEN slen)
104 register I32 ret = 0;
122 esc_q_utf8(pTHX_ SV* sv, register const char *src, register STRLEN slen)
126 const char * const send = src + slen;
127 STRLEN j, cur = SvCUR(sv);
128 /* Could count 128-255 and 256+ in two variables, if we want to
129 be like &qquote and make a distinction. */
130 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
131 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
132 STRLEN backslashes = 0;
133 STRLEN single_quotes = 0;
134 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
137 /* this will need EBCDICification */
138 for (s = src; s < send; s += UTF8SKIP(s)) {
139 const UV k = utf8_to_uvchr((U8*)s, NULL);
142 if (!isprint(k) || k > 256) {
146 /* 4: \x{} then count the number of hex digits. */
147 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
149 8 /* We may allocate a bit more than the minimum here. */
151 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
154 } else if (k == '\\') {
156 } else if (k == '\'') {
158 } else if (k == '"' || k == '$' || k == '@') {
165 /* We have something needing hex. 3 is ""\0 */
166 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
167 + 2*qq_escapables + normal);
168 rstart = r = SvPVX(sv) + cur;
172 for (s = src; s < send; s += UTF8SKIP(s)) {
173 const UV k = utf8_to_uvchr((U8*)s, NULL);
175 if (k == '"' || k == '\\' || k == '$' || k == '@') {
181 if (isprint(k) && k < 256)
187 /* The return value of sprintf() is unportable.
188 * In modern systems it returns (int) the number of characters,
189 * but in older systems it might return (char*) the original
190 * buffer, or it might even be (void). The easiest portable
191 * thing to do is probably use sprintf() in void context and
192 * then strlen(buffer) for the length. The more proper way
193 * would of course be to figure out the prototype of sprintf.
195 sprintf(r, "\\x{%"UVxf"}", k);
202 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
203 + qq_escapables + normal);
204 rstart = r = SvPVX(sv) + cur;
206 for (s = src; s < send; s ++) {
208 if (k == '\'' || k == '\\')
216 SvCUR_set(sv, cur + j);
221 /* append a repeated string to an SV */
223 sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
226 sv = newSVpvn("", 0);
229 assert(SvTYPE(sv) >= SVt_PV);
233 SvGROW(sv, len*n + SvCUR(sv) + 1);
235 char * const start = SvPVX(sv) + SvCUR(sv);
236 SvCUR_set(sv, SvCUR(sv) + n);
243 sv_catpvn(sv, str, len);
251 * This ought to be split into smaller functions. (it is one long function since
252 * it exactly parallels the perl version, which was one long thing for
253 * efficiency raisins.) Ugggh!
256 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
257 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
258 SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
259 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
263 char *c, *r, *realpack, id[128];
265 SV *sv, *ipad, *ival;
266 SV *blesspad = Nullsv;
267 AV *seenentry = NULL;
269 STRLEN inamelen, idlen = 0;
275 realtype = SvTYPE(val);
281 /* If a freeze method is provided and the object has it, call
282 it. Warn on errors. */
283 if (SvOBJECT(SvRV(val)) && freezer &&
284 SvPOK(freezer) && SvCUR(freezer) &&
285 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
286 SvCUR(freezer), -1) != NULL)
288 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
289 XPUSHs(val); PUTBACK;
290 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
293 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
294 PUTBACK; FREETMPS; LEAVE;
298 realtype = SvTYPE(ival);
299 (void) sprintf(id, "0x%"UVxf, PTR2UV(ival));
302 realpack = HvNAME_get(SvSTASH(ival));
306 /* if it has a name, we need to either look it up, or keep a tab
307 * on it so we know when we hit it later
310 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
311 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
314 if ((svp = av_fetch(seenentry, 0, FALSE))
315 && (othername = *svp))
317 if (purity && *levelp > 0) {
320 if (realtype == SVt_PVHV)
321 sv_catpvn(retval, "{}", 2);
322 else if (realtype == SVt_PVAV)
323 sv_catpvn(retval, "[]", 2);
325 sv_catpvn(retval, "do{my $o}", 9);
326 postentry = newSVpvn(name, namelen);
327 sv_catpvn(postentry, " = ", 3);
328 sv_catsv(postentry, othername);
329 av_push(postav, postentry);
332 if (name[0] == '@' || name[0] == '%') {
333 if ((SvPVX_const(othername))[0] == '\\' &&
334 (SvPVX_const(othername))[1] == name[0]) {
335 sv_catpvn(retval, SvPVX_const(othername)+1,
339 sv_catpvn(retval, name, 1);
340 sv_catpvn(retval, "{", 1);
341 sv_catsv(retval, othername);
342 sv_catpvn(retval, "}", 1);
346 sv_catsv(retval, othername);
351 warn("ref name not found for %s", id);
355 else { /* store our name and continue */
357 if (name[0] == '@' || name[0] == '%') {
358 namesv = newSVpvn("\\", 1);
359 sv_catpvn(namesv, name, namelen);
361 else if (realtype == SVt_PVCV && name[0] == '*') {
362 namesv = newSVpvn("\\", 2);
363 sv_catpvn(namesv, name, namelen);
364 (SvPVX(namesv))[1] = '&';
367 namesv = newSVpvn(name, namelen);
369 av_push(seenentry, namesv);
370 (void)SvREFCNT_inc(val);
371 av_push(seenentry, val);
372 (void)hv_store(seenhv, id, strlen(id),
373 newRV_inc((SV*)seenentry), 0);
374 SvREFCNT_dec(seenentry);
378 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
380 const char *rval = SvPV(val, rlen);
381 const char *slash = strchr(rval, '/');
382 sv_catpvn(retval, "qr/", 3);
384 sv_catpvn(retval, rval, slash-rval);
385 sv_catpvn(retval, "\\/", 2);
386 rlen -= slash-rval+1;
388 slash = strchr(rval, '/');
390 sv_catpvn(retval, rval, rlen);
391 sv_catpvn(retval, "/", 1);
395 /* If purity is not set and maxdepth is set, then check depth:
396 * if we have reached maximum depth, return the string
397 * representation of the thing we are currently examining
398 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
400 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
402 const char * const valstr = SvPV(val,vallen);
403 sv_catpvn(retval, "'", 1);
404 sv_catpvn(retval, valstr, vallen);
405 sv_catpvn(retval, "'", 1);
409 if (realpack) { /* we have a blessed ref */
411 const char * const blessstr = SvPV(bless, blesslen);
412 sv_catpvn(retval, blessstr, blesslen);
413 sv_catpvn(retval, "( ", 2);
416 apad = newSVsv(apad);
417 sv_x(aTHX_ apad, " ", 1, blesslen+2);
422 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
424 if (realtype <= SVt_PVBM) { /* scalar ref */
425 SV * const namesv = newSVpvn("${", 2);
426 sv_catpvn(namesv, name, namelen);
427 sv_catpvn(namesv, "}", 1);
428 if (realpack) { /* blessed */
429 sv_catpvn(retval, "do{\\(my $o = ", 13);
430 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
431 postav, levelp, indent, pad, xpad, apad, sep, pair,
432 freezer, toaster, purity, deepcopy, quotekeys, bless,
434 sv_catpvn(retval, ")}", 2);
437 sv_catpvn(retval, "\\", 1);
438 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
439 postav, levelp, indent, pad, xpad, apad, sep, pair,
440 freezer, toaster, purity, deepcopy, quotekeys, bless,
443 SvREFCNT_dec(namesv);
445 else if (realtype == SVt_PVGV) { /* glob ref */
446 SV * const namesv = newSVpvn("*{", 2);
447 sv_catpvn(namesv, name, namelen);
448 sv_catpvn(namesv, "}", 1);
449 sv_catpvn(retval, "\\", 1);
450 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
451 postav, levelp, indent, pad, xpad, apad, sep, pair,
452 freezer, toaster, purity, deepcopy, quotekeys, bless,
454 SvREFCNT_dec(namesv);
456 else if (realtype == SVt_PVAV) {
459 const I32 ixmax = av_len((AV *)ival);
461 SV * const ixsv = newSViv(0);
462 /* allowing for a 24 char wide array index */
463 New(0, iname, namelen+28, char);
464 (void)strcpy(iname, name);
466 if (name[0] == '@') {
467 sv_catpvn(retval, "(", 1);
471 sv_catpvn(retval, "[", 1);
472 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
474 && name[namelen-1] != ']' && name[namelen-1] != '}'
475 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
477 && name[namelen-1] != ']' && name[namelen-1] != '}')
480 || (name[0] == '\\' && name[2] == '{'))))
482 iname[inamelen++] = '-'; iname[inamelen++] = '>';
483 iname[inamelen] = '\0';
486 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
487 (instr(iname+inamelen-8, "{SCALAR}") ||
488 instr(iname+inamelen-7, "{ARRAY}") ||
489 instr(iname+inamelen-6, "{HASH}"))) {
490 iname[inamelen++] = '-'; iname[inamelen++] = '>';
492 iname[inamelen++] = '['; iname[inamelen] = '\0';
493 totpad = newSVsv(sep);
494 sv_catsv(totpad, pad);
495 sv_catsv(totpad, apad);
497 for (ix = 0; ix <= ixmax; ++ix) {
500 svp = av_fetch((AV*)ival, ix, FALSE);
508 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
509 ilen = strlen(iname);
510 iname[ilen++] = ']'; iname[ilen] = '\0';
512 sv_catsv(retval, totpad);
513 sv_catsv(retval, ipad);
514 sv_catpvn(retval, "#", 1);
515 sv_catsv(retval, ixsv);
517 sv_catsv(retval, totpad);
518 sv_catsv(retval, ipad);
519 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
520 levelp, indent, pad, xpad, apad, sep, pair,
521 freezer, toaster, purity, deepcopy, quotekeys, bless,
524 sv_catpvn(retval, ",", 1);
527 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
528 sv_catsv(retval, totpad);
529 sv_catsv(retval, opad);
533 sv_catpvn(retval, ")", 1);
535 sv_catpvn(retval, "]", 1);
537 SvREFCNT_dec(totpad);
540 else if (realtype == SVt_PVHV) {
541 SV *totpad, *newapad;
549 SV * const iname = newSVpvn(name, namelen);
550 if (name[0] == '%') {
551 sv_catpvn(retval, "(", 1);
552 (SvPVX(iname))[0] = '$';
555 sv_catpvn(retval, "{", 1);
556 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
558 && name[namelen-1] != ']' && name[namelen-1] != '}')
561 || (name[0] == '\\' && name[2] == '{'))))
563 sv_catpvn(iname, "->", 2);
566 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
567 (instr(name+namelen-8, "{SCALAR}") ||
568 instr(name+namelen-7, "{ARRAY}") ||
569 instr(name+namelen-6, "{HASH}"))) {
570 sv_catpvn(iname, "->", 2);
572 sv_catpvn(iname, "{", 1);
573 totpad = newSVsv(sep);
574 sv_catsv(totpad, pad);
575 sv_catsv(totpad, apad);
577 /* If requested, get a sorted/filtered array of hash keys */
579 if (sortkeys == &PL_sv_yes) {
581 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
584 (void)hv_iterinit((HV*)ival);
585 while ((entry = hv_iternext((HV*)ival))) {
586 sv = hv_iterkeysv(entry);
590 # ifdef USE_LOCALE_NUMERIC
591 sortsv(AvARRAY(keys),
593 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
595 sortsv(AvARRAY(keys),
601 if (sortkeys != &PL_sv_yes) {
602 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
603 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
604 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
608 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
609 keys = (AV*)SvREFCNT_inc(SvRV(sv));
612 warn("Sortkeys subroutine did not return ARRAYREF\n");
613 PUTBACK; FREETMPS; LEAVE;
616 sv_2mortal((SV*)keys);
619 (void)hv_iterinit((HV*)ival);
621 /* foreach (keys %hash) */
622 for (i = 0; 1; i++) {
624 char *nkey_buffer = NULL;
629 bool do_utf8 = FALSE;
632 if (!(keys && (I32)i <= av_len(keys))) break;
634 if (!(entry = hv_iternext((HV *)ival))) break;
638 sv_catpvn(retval, ",", 1);
642 svp = av_fetch(keys, i, FALSE);
643 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
644 key = SvPV(keysv, keylen);
645 svp = hv_fetch((HV*)ival, key,
646 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
647 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
650 keysv = hv_iterkeysv(entry);
651 hval = hv_iterval((HV*)ival, entry);
654 key = SvPV(keysv, keylen);
655 do_utf8 = DO_UTF8(keysv);
658 sv_catsv(retval, totpad);
659 sv_catsv(retval, ipad);
660 /* old logic was first to check utf8 flag, and if utf8 always
661 call esc_q_utf8. This caused test to break under -Mutf8,
662 because there even strings like 'c' have utf8 flag on.
663 Hence with quotekeys == 0 the XS code would still '' quote
664 them based on flags, whereas the perl code would not,
666 The perl code is correct.
667 needs_quote() decides that anything that isn't a valid
668 perl identifier needs to be quoted, hence only correctly
669 formed strings with no characters outside [A-Za-z0-9_:]
670 won't need quoting. None of those characters are used in
671 the byte encoding of utf8, so anything with utf8
672 encoded characters in will need quoting. Hence strings
673 with utf8 encoded characters in will end up inside do_utf8
674 just like before, but now strings with utf8 flag set but
675 only ascii characters will end up in the unquoted section.
677 There should also be less tests for the (probably currently)
678 more common doesn't need quoting case.
679 The code is also smaller (22044 vs 22260) because I've been
680 able to pull the common logic out to both sides. */
681 if (quotekeys || needs_quote(key)) {
683 STRLEN ocur = SvCUR(retval);
684 nlen = esc_q_utf8(aTHX_ retval, key, klen);
685 nkey = SvPVX(retval) + ocur;
688 nticks = num_q(key, klen);
689 New(0, nkey_buffer, klen+nticks+3, char);
693 klen += esc_q(nkey+1, key, klen);
695 (void)Copy(key, nkey+1, klen, char);
699 sv_catpvn(retval, nkey, klen);
705 sv_catpvn(retval, nkey, klen);
707 sname = newSVsv(iname);
708 sv_catpvn(sname, nkey, nlen);
709 sv_catpvn(sname, "}", 1);
711 sv_catsv(retval, pair);
715 newapad = newSVsv(apad);
716 New(0, extra, klen+4+1, char);
717 while (elen < (klen+4))
720 sv_catpvn(newapad, extra, elen);
726 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
727 postav, levelp, indent, pad, xpad, newapad, sep, pair,
728 freezer, toaster, purity, deepcopy, quotekeys, bless,
731 Safefree(nkey_buffer);
733 SvREFCNT_dec(newapad);
736 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
737 sv_catsv(retval, totpad);
738 sv_catsv(retval, opad);
742 sv_catpvn(retval, ")", 1);
744 sv_catpvn(retval, "}", 1);
746 SvREFCNT_dec(totpad);
748 else if (realtype == SVt_PVCV) {
749 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
751 warn("Encountered CODE ref, using dummy placeholder");
754 warn("cannot handle ref type %ld", realtype);
757 if (realpack) { /* free blessed allocs */
762 sv_catpvn(retval, ", '", 3);
763 sv_catpvn(retval, realpack, strlen(realpack));
764 sv_catpvn(retval, "' )", 3);
765 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
766 sv_catpvn(retval, "->", 2);
767 sv_catsv(retval, toaster);
768 sv_catpvn(retval, "()", 2);
778 (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
779 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
780 (sv = *svp) && SvROK(sv) &&
781 (seenentry = (AV*)SvRV(sv)))
784 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
785 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
787 sv_catpvn(retval, "${", 2);
788 sv_catsv(retval, othername);
789 sv_catpvn(retval, "}", 1);
793 else if (val != &PL_sv_undef) {
794 SV * const namesv = newSVpvn("\\", 1);
795 sv_catpvn(namesv, name, namelen);
797 av_push(seenentry, namesv);
798 av_push(seenentry, newRV_inc(val));
799 (void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0);
800 SvREFCNT_dec(seenentry);
804 if (DD_is_integer(val)) {
807 (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
809 (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
810 len = strlen(tmpbuf);
812 /* Need to check to see if this is a string such as " 0".
813 I'm assuming from sprintf isn't going to clash with utf8.
814 Is this valid on EBCDIC? */
816 const char * const pv = SvPV(val, pvlen);
817 if (pvlen != len || memNE(pv, tmpbuf, len))
818 goto integer_came_from_string;
821 /* Looks like we're on a 64 bit system. Make it a string so that
822 if a 32 bit system reads the number it will cope better. */
823 sv_catpvf(retval, "'%s'", tmpbuf);
825 sv_catpvn(retval, tmpbuf, len);
827 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
829 ++c; --i; /* just get the name */
830 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
834 if (needs_quote(c)) {
835 sv_grow(retval, SvCUR(retval)+6+2*i);
836 r = SvPVX(retval)+SvCUR(retval);
837 r[0] = '*'; r[1] = '{'; r[2] = '\'';
838 i += esc_q(r+3, c, i);
840 r[i++] = '\''; r[i++] = '}';
844 sv_grow(retval, SvCUR(retval)+i+2);
845 r = SvPVX(retval)+SvCUR(retval);
846 r[0] = '*'; strcpy(r+1, c);
849 SvCUR_set(retval, SvCUR(retval)+i);
852 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
853 static const STRLEN sizes[] = { 8, 7, 6 };
855 SV * const nname = newSVpvn("", 0);
856 SV * const newapad = newSVpvn("", 0);
857 GV * const gv = (GV*)val;
860 for (j=0; j<3; j++) {
861 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
864 if (j == 0 && !SvOK(e))
869 SV *postentry = newSVpvn(r,i);
871 sv_setsv(nname, postentry);
872 sv_catpvn(nname, entries[j], sizes[j]);
873 sv_catpvn(postentry, " = ", 3);
874 av_push(postav, postentry);
877 SvCUR_set(newapad, 0);
879 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
881 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
882 seenhv, postav, &nlevel, indent, pad, xpad,
883 newapad, sep, pair, freezer, toaster, purity,
884 deepcopy, quotekeys, bless, maxdepth,
890 SvREFCNT_dec(newapad);
894 else if (val == &PL_sv_undef || !SvOK(val)) {
895 sv_catpvn(retval, "undef", 5);
898 integer_came_from_string:
901 i += esc_q_utf8(aTHX_ retval, c, i);
903 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
904 r = SvPVX(retval) + SvCUR(retval);
906 i += esc_q(r+1, c, i);
910 SvCUR_set(retval, SvCUR(retval)+i);
917 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
918 else if (namelen && seenentry) {
919 SV *mark = *av_fetch(seenentry, 2, TRUE);
927 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
930 # This is the exact equivalent of Dump. Well, almost. The things that are
931 # different as of now (due to Laziness):
932 # * doesnt do double-quotes yet.
936 Data_Dumper_Dumpxs(href, ...)
944 AV *postav, *todumpav, *namesav;
946 I32 indent, terse, i, imax, postlen;
948 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
949 SV *freezer, *toaster, *bless, *sortkeys;
950 I32 purity, deepcopy, quotekeys, maxdepth = 0;
954 if (!SvROK(href)) { /* call new to get an object first */
956 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
963 XPUSHs(sv_2mortal(newSVsv(ST(1))));
965 XPUSHs(sv_2mortal(newSVsv(ST(2))));
967 i = perl_call_method("new", G_SCALAR);
970 href = newSVsv(POPs);
976 (void)sv_2mortal(href);
979 todumpav = namesav = NULL;
981 val = pad = xpad = apad = sep = pair = varname
982 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
983 name = sv_newmortal();
985 terse = purity = deepcopy = 0;
988 retval = newSVpvn("", 0);
990 && (hv = (HV*)SvRV((SV*)href))
991 && SvTYPE(hv) == SVt_PVHV) {
993 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
994 seenhv = (HV*)SvRV(*svp);
995 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
996 todumpav = (AV*)SvRV(*svp);
997 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
998 namesav = (AV*)SvRV(*svp);
999 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1000 indent = SvIV(*svp);
1001 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1002 purity = SvIV(*svp);
1003 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1004 terse = SvTRUE(*svp);
1005 #if 0 /* useqq currently unused */
1006 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1007 useqq = SvTRUE(*svp);
1009 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1011 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1013 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1015 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1017 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1019 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1021 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1023 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1025 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1026 deepcopy = SvTRUE(*svp);
1027 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1028 quotekeys = SvTRUE(*svp);
1029 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1031 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1032 maxdepth = SvIV(*svp);
1033 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1035 if (! SvTRUE(sortkeys))
1037 else if (! (SvROK(sortkeys) &&
1038 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1040 /* flag to use qsortsv() for sorting hash keys */
1041 sortkeys = &PL_sv_yes;
1047 imax = av_len(todumpav);
1050 valstr = newSVpvn("",0);
1051 for (i = 0; i <= imax; ++i) {
1055 if ((svp = av_fetch(todumpav, i, FALSE)))
1059 if ((svp = av_fetch(namesav, i, TRUE))) {
1060 sv_setsv(name, *svp);
1061 if (SvOK(*svp) && !SvPOK(*svp))
1062 (void)SvPV_nolen_const(name);
1065 (void)SvOK_off(name);
1068 if ((SvPVX_const(name))[0] == '*') {
1070 switch (SvTYPE(SvRV(val))) {
1072 (SvPVX(name))[0] = '@';
1075 (SvPVX(name))[0] = '%';
1078 (SvPVX(name))[0] = '*';
1081 (SvPVX(name))[0] = '$';
1086 (SvPVX(name))[0] = '$';
1088 else if ((SvPVX_const(name))[0] != '$')
1089 sv_insert(name, 0, 0, "$", 1);
1093 sv_setpvn(name, "$", 1);
1094 sv_catsv(name, varname);
1095 (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1096 nchars = strlen(tmpbuf);
1097 sv_catpvn(name, tmpbuf, nchars);
1101 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1102 newapad = newSVsv(apad);
1103 sv_catsv(newapad, tmpsv);
1104 SvREFCNT_dec(tmpsv);
1109 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1110 postav, &level, indent, pad, xpad, newapad, sep, pair,
1111 freezer, toaster, purity, deepcopy, quotekeys,
1112 bless, maxdepth, sortkeys);
1115 SvREFCNT_dec(newapad);
1117 postlen = av_len(postav);
1118 if (postlen >= 0 || !terse) {
1119 sv_insert(valstr, 0, 0, " = ", 3);
1120 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1121 sv_catpvn(valstr, ";", 1);
1123 sv_catsv(retval, pad);
1124 sv_catsv(retval, valstr);
1125 sv_catsv(retval, sep);
1128 sv_catsv(retval, pad);
1129 for (i = 0; i <= postlen; ++i) {
1131 svp = av_fetch(postav, i, FALSE);
1132 if (svp && (elem = *svp)) {
1133 sv_catsv(retval, elem);
1135 sv_catpvn(retval, ";", 1);
1136 sv_catsv(retval, sep);
1137 sv_catsv(retval, pad);
1141 sv_catpvn(retval, ";", 1);
1142 sv_catsv(retval, sep);
1144 sv_setpvn(valstr, "", 0);
1145 if (gimme == G_ARRAY) {
1146 XPUSHs(sv_2mortal(retval));
1147 if (i < imax) /* not the last time thro ? */
1148 retval = newSVpvn("",0);
1151 SvREFCNT_dec(postav);
1152 SvREFCNT_dec(valstr);
1155 croak("Call to new() method failed to return HASH ref");
1156 if (gimme == G_SCALAR)
1157 XPUSHs(sv_2mortal(retval));