1 #define PERL_NO_GET_CONTEXT
8 # define DD_USE_OLD_ID_FORMAT
11 static I32 num_q (const char *s, STRLEN slen);
12 static I32 esc_q (char *dest, const char *src, STRLEN slen);
13 static I32 esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen);
14 static I32 needs_quote(register const char *s);
15 static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
16 static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
17 HV *seenhv, AV *postav, I32 *levelp, I32 indent,
18 SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
19 SV *freezer, SV *toaster,
20 I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
21 I32 maxdepth, SV *sortkeys);
24 #define HvNAME_get HvNAME
27 #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
30 # define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
32 # define UNI_TO_NATIVE(ch) (ch)
36 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
38 const UV uv = utf8_to_uv(s, UTF8_MAXLEN, retlen,
39 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
40 return UNI_TO_NATIVE(uv);
43 # if !defined(PERL_IMPLICIT_CONTEXT)
44 # define utf8_to_uvchr Perl_utf8_to_uvchr
46 # define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
49 #endif /* PERL_VERSION <= 6 */
51 /* Changes in 5.7 series mean that now IOK is only set if scalar is
52 precisely integer but in 5.6 and earlier we need to do a more
55 #define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
57 #define DD_is_integer(sv) SvIOK(sv)
60 /* does a string need to be protected? */
62 needs_quote(register const char *s)
87 /* count the number of "'"s and "\"s in string */
89 num_q(register const char *s, register STRLEN slen)
94 if (*s == '\'' || *s == '\\')
103 /* returns number of chars added to escape "'"s and "\"s in s */
104 /* slen number of characters in s will be escaped */
105 /* destination must be long enough for additional chars */
107 esc_q(register char *d, register const char *s, register STRLEN slen)
109 register I32 ret = 0;
127 esc_q_utf8(pTHX_ SV* sv, register const char *src, register STRLEN slen)
131 const char * const send = src + slen;
132 STRLEN j, cur = SvCUR(sv);
133 /* Could count 128-255 and 256+ in two variables, if we want to
134 be like &qquote and make a distinction. */
135 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
136 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
137 STRLEN backslashes = 0;
138 STRLEN single_quotes = 0;
139 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
142 /* this will need EBCDICification */
143 for (s = src; s < send; s += UTF8SKIP(s)) {
144 const UV k = utf8_to_uvchr((U8*)s, NULL);
147 if (!isprint(k) || k > 256) {
151 /* 4: \x{} then count the number of hex digits. */
152 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
154 8 /* We may allocate a bit more than the minimum here. */
156 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
159 } else if (k == '\\') {
161 } else if (k == '\'') {
163 } else if (k == '"' || k == '$' || k == '@') {
170 /* We have something needing hex. 3 is ""\0 */
171 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
172 + 2*qq_escapables + normal);
173 rstart = r = SvPVX(sv) + cur;
177 for (s = src; s < send; s += UTF8SKIP(s)) {
178 const UV k = utf8_to_uvchr((U8*)s, NULL);
180 if (k == '"' || k == '\\' || k == '$' || k == '@') {
186 if (isprint(k) && k < 256)
192 r = r + my_sprintf(r, "\\x{%"UVxf"}", k);
198 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
199 + qq_escapables + normal);
200 rstart = r = SvPVX(sv) + cur;
202 for (s = src; s < send; s ++) {
204 if (k == '\'' || k == '\\')
212 SvCUR_set(sv, cur + j);
217 /* append a repeated string to an SV */
219 sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
222 sv = newSVpvn("", 0);
225 assert(SvTYPE(sv) >= SVt_PV);
229 SvGROW(sv, len*n + SvCUR(sv) + 1);
231 char * const start = SvPVX(sv) + SvCUR(sv);
232 SvCUR_set(sv, SvCUR(sv) + n);
239 sv_catpvn(sv, str, len);
247 * This ought to be split into smaller functions. (it is one long function since
248 * it exactly parallels the perl version, which was one long thing for
249 * efficiency raisins.) Ugggh!
252 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
253 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
254 SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
255 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
259 char *c, *r, *realpack;
260 #ifdef DD_USE_OLD_ID_FORMAT
264 char *const id = (char *)&id_buffer;
267 SV *sv, *ipad, *ival;
268 SV *blesspad = Nullsv;
269 AV *seenentry = NULL;
271 STRLEN inamelen, idlen = 0;
277 /* If the ouput buffer has less than some arbitary amount of space
278 remaining, then enlarge it. For the test case (25M of output),
279 *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is
280 deemed to be good enough. */
281 if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) {
282 sv_grow(retval, SvCUR(retval) * 3 / 2);
285 realtype = SvTYPE(val);
291 /* If a freeze method is provided and the object has it, call
292 it. Warn on errors. */
293 if (SvOBJECT(SvRV(val)) && freezer &&
294 SvPOK(freezer) && SvCUR(freezer) &&
295 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
296 SvCUR(freezer), -1) != NULL)
298 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
299 XPUSHs(val); PUTBACK;
300 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
303 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
304 PUTBACK; FREETMPS; LEAVE;
308 realtype = SvTYPE(ival);
309 #ifdef DD_USE_OLD_ID_FORMAT
310 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival));
312 id_buffer = PTR2UV(ival);
313 idlen = sizeof(id_buffer);
316 realpack = HvNAME_get(SvSTASH(ival));
320 /* if it has a name, we need to either look it up, or keep a tab
321 * on it so we know when we hit it later
324 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
325 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
328 if ((svp = av_fetch(seenentry, 0, FALSE))
329 && (othername = *svp))
331 if (purity && *levelp > 0) {
334 if (realtype == SVt_PVHV)
335 sv_catpvn(retval, "{}", 2);
336 else if (realtype == SVt_PVAV)
337 sv_catpvn(retval, "[]", 2);
339 sv_catpvn(retval, "do{my $o}", 9);
340 postentry = newSVpvn(name, namelen);
341 sv_catpvn(postentry, " = ", 3);
342 sv_catsv(postentry, othername);
343 av_push(postav, postentry);
346 if (name[0] == '@' || name[0] == '%') {
347 if ((SvPVX_const(othername))[0] == '\\' &&
348 (SvPVX_const(othername))[1] == name[0]) {
349 sv_catpvn(retval, SvPVX_const(othername)+1,
353 sv_catpvn(retval, name, 1);
354 sv_catpvn(retval, "{", 1);
355 sv_catsv(retval, othername);
356 sv_catpvn(retval, "}", 1);
360 sv_catsv(retval, othername);
365 #ifdef DD_USE_OLD_ID_FORMAT
366 warn("ref name not found for %s", id);
368 warn("ref name not found for 0x%"UVxf, PTR2UV(ival));
373 else { /* store our name and continue */
375 if (name[0] == '@' || name[0] == '%') {
376 namesv = newSVpvn("\\", 1);
377 sv_catpvn(namesv, name, namelen);
379 else if (realtype == SVt_PVCV && name[0] == '*') {
380 namesv = newSVpvn("\\", 2);
381 sv_catpvn(namesv, name, namelen);
382 (SvPVX(namesv))[1] = '&';
385 namesv = newSVpvn(name, namelen);
387 av_push(seenentry, namesv);
388 (void)SvREFCNT_inc(val);
389 av_push(seenentry, val);
390 (void)hv_store(seenhv, id, idlen,
391 newRV_inc((SV*)seenentry), 0);
392 SvREFCNT_dec(seenentry);
396 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
398 const char *rval = SvPV(val, rlen);
399 const char *slash = strchr(rval, '/');
400 sv_catpvn(retval, "qr/", 3);
402 sv_catpvn(retval, rval, slash-rval);
403 sv_catpvn(retval, "\\/", 2);
404 rlen -= slash-rval+1;
406 slash = strchr(rval, '/');
408 sv_catpvn(retval, rval, rlen);
409 sv_catpvn(retval, "/", 1);
413 /* If purity is not set and maxdepth is set, then check depth:
414 * if we have reached maximum depth, return the string
415 * representation of the thing we are currently examining
416 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
418 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
420 const char * const valstr = SvPV(val,vallen);
421 sv_catpvn(retval, "'", 1);
422 sv_catpvn(retval, valstr, vallen);
423 sv_catpvn(retval, "'", 1);
427 if (realpack) { /* we have a blessed ref */
429 const char * const blessstr = SvPV(bless, blesslen);
430 sv_catpvn(retval, blessstr, blesslen);
431 sv_catpvn(retval, "( ", 2);
434 apad = newSVsv(apad);
435 sv_x(aTHX_ apad, " ", 1, blesslen+2);
440 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
449 SV * const namesv = newSVpvn("${", 2);
450 sv_catpvn(namesv, name, namelen);
451 sv_catpvn(namesv, "}", 1);
452 if (realpack) { /* blessed */
453 sv_catpvn(retval, "do{\\(my $o = ", 13);
454 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
455 postav, levelp, indent, pad, xpad, apad, sep, pair,
456 freezer, toaster, purity, deepcopy, quotekeys, bless,
458 sv_catpvn(retval, ")}", 2);
461 sv_catpvn(retval, "\\", 1);
462 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
463 postav, levelp, indent, pad, xpad, apad, sep, pair,
464 freezer, toaster, purity, deepcopy, quotekeys, bless,
467 SvREFCNT_dec(namesv);
469 else if (realtype == SVt_PVGV) { /* glob ref */
470 SV * const namesv = newSVpvn("*{", 2);
471 sv_catpvn(namesv, name, namelen);
472 sv_catpvn(namesv, "}", 1);
473 sv_catpvn(retval, "\\", 1);
474 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
475 postav, levelp, indent, pad, xpad, apad, sep, pair,
476 freezer, toaster, purity, deepcopy, quotekeys, bless,
478 SvREFCNT_dec(namesv);
480 else if (realtype == SVt_PVAV) {
483 const I32 ixmax = av_len((AV *)ival);
485 SV * const ixsv = newSViv(0);
486 /* allowing for a 24 char wide array index */
487 New(0, iname, namelen+28, char);
488 (void)strcpy(iname, name);
490 if (name[0] == '@') {
491 sv_catpvn(retval, "(", 1);
495 sv_catpvn(retval, "[", 1);
496 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
498 && name[namelen-1] != ']' && name[namelen-1] != '}'
499 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
501 && name[namelen-1] != ']' && name[namelen-1] != '}')
504 || (name[0] == '\\' && name[2] == '{'))))
506 iname[inamelen++] = '-'; iname[inamelen++] = '>';
507 iname[inamelen] = '\0';
510 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
511 (instr(iname+inamelen-8, "{SCALAR}") ||
512 instr(iname+inamelen-7, "{ARRAY}") ||
513 instr(iname+inamelen-6, "{HASH}"))) {
514 iname[inamelen++] = '-'; iname[inamelen++] = '>';
516 iname[inamelen++] = '['; iname[inamelen] = '\0';
517 totpad = newSVsv(sep);
518 sv_catsv(totpad, pad);
519 sv_catsv(totpad, apad);
521 for (ix = 0; ix <= ixmax; ++ix) {
524 svp = av_fetch((AV*)ival, ix, FALSE);
532 ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
533 iname[ilen++] = ']'; iname[ilen] = '\0';
535 sv_catsv(retval, totpad);
536 sv_catsv(retval, ipad);
537 sv_catpvn(retval, "#", 1);
538 sv_catsv(retval, ixsv);
540 sv_catsv(retval, totpad);
541 sv_catsv(retval, ipad);
542 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
543 levelp, indent, pad, xpad, apad, sep, pair,
544 freezer, toaster, purity, deepcopy, quotekeys, bless,
547 sv_catpvn(retval, ",", 1);
550 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
551 sv_catsv(retval, totpad);
552 sv_catsv(retval, opad);
556 sv_catpvn(retval, ")", 1);
558 sv_catpvn(retval, "]", 1);
560 SvREFCNT_dec(totpad);
563 else if (realtype == SVt_PVHV) {
564 SV *totpad, *newapad;
572 SV * const iname = newSVpvn(name, namelen);
573 if (name[0] == '%') {
574 sv_catpvn(retval, "(", 1);
575 (SvPVX(iname))[0] = '$';
578 sv_catpvn(retval, "{", 1);
579 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
581 && name[namelen-1] != ']' && name[namelen-1] != '}')
584 || (name[0] == '\\' && name[2] == '{'))))
586 sv_catpvn(iname, "->", 2);
589 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
590 (instr(name+namelen-8, "{SCALAR}") ||
591 instr(name+namelen-7, "{ARRAY}") ||
592 instr(name+namelen-6, "{HASH}"))) {
593 sv_catpvn(iname, "->", 2);
595 sv_catpvn(iname, "{", 1);
596 totpad = newSVsv(sep);
597 sv_catsv(totpad, pad);
598 sv_catsv(totpad, apad);
600 /* If requested, get a sorted/filtered array of hash keys */
602 if (sortkeys == &PL_sv_yes) {
604 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
607 (void)hv_iterinit((HV*)ival);
608 while ((entry = hv_iternext((HV*)ival))) {
609 sv = hv_iterkeysv(entry);
613 # ifdef USE_LOCALE_NUMERIC
614 sortsv(AvARRAY(keys),
616 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
618 sortsv(AvARRAY(keys),
624 if (sortkeys != &PL_sv_yes) {
625 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
626 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
627 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
631 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
632 keys = (AV*)SvREFCNT_inc(SvRV(sv));
635 warn("Sortkeys subroutine did not return ARRAYREF\n");
636 PUTBACK; FREETMPS; LEAVE;
639 sv_2mortal((SV*)keys);
642 (void)hv_iterinit((HV*)ival);
644 /* foreach (keys %hash) */
645 for (i = 0; 1; i++) {
647 char *nkey_buffer = NULL;
652 bool do_utf8 = FALSE;
655 if (!(keys && (I32)i <= av_len(keys))) break;
657 if (!(entry = hv_iternext((HV *)ival))) break;
661 sv_catpvn(retval, ",", 1);
665 svp = av_fetch(keys, i, FALSE);
666 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
667 key = SvPV(keysv, keylen);
668 svp = hv_fetch((HV*)ival, key,
669 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
670 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
673 keysv = hv_iterkeysv(entry);
674 hval = hv_iterval((HV*)ival, entry);
677 key = SvPV(keysv, keylen);
678 do_utf8 = DO_UTF8(keysv);
681 sv_catsv(retval, totpad);
682 sv_catsv(retval, ipad);
683 /* old logic was first to check utf8 flag, and if utf8 always
684 call esc_q_utf8. This caused test to break under -Mutf8,
685 because there even strings like 'c' have utf8 flag on.
686 Hence with quotekeys == 0 the XS code would still '' quote
687 them based on flags, whereas the perl code would not,
689 The perl code is correct.
690 needs_quote() decides that anything that isn't a valid
691 perl identifier needs to be quoted, hence only correctly
692 formed strings with no characters outside [A-Za-z0-9_:]
693 won't need quoting. None of those characters are used in
694 the byte encoding of utf8, so anything with utf8
695 encoded characters in will need quoting. Hence strings
696 with utf8 encoded characters in will end up inside do_utf8
697 just like before, but now strings with utf8 flag set but
698 only ascii characters will end up in the unquoted section.
700 There should also be less tests for the (probably currently)
701 more common doesn't need quoting case.
702 The code is also smaller (22044 vs 22260) because I've been
703 able to pull the common logic out to both sides. */
704 if (quotekeys || needs_quote(key)) {
706 STRLEN ocur = SvCUR(retval);
707 nlen = esc_q_utf8(aTHX_ retval, key, klen);
708 nkey = SvPVX(retval) + ocur;
711 nticks = num_q(key, klen);
712 New(0, nkey_buffer, klen+nticks+3, char);
716 klen += esc_q(nkey+1, key, klen);
718 (void)Copy(key, nkey+1, klen, char);
722 sv_catpvn(retval, nkey, klen);
728 sv_catpvn(retval, nkey, klen);
730 sname = newSVsv(iname);
731 sv_catpvn(sname, nkey, nlen);
732 sv_catpvn(sname, "}", 1);
734 sv_catsv(retval, pair);
738 newapad = newSVsv(apad);
739 New(0, extra, klen+4+1, char);
740 while (elen < (klen+4))
743 sv_catpvn(newapad, extra, elen);
749 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
750 postav, levelp, indent, pad, xpad, newapad, sep, pair,
751 freezer, toaster, purity, deepcopy, quotekeys, bless,
754 Safefree(nkey_buffer);
756 SvREFCNT_dec(newapad);
759 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
760 sv_catsv(retval, totpad);
761 sv_catsv(retval, opad);
765 sv_catpvn(retval, ")", 1);
767 sv_catpvn(retval, "}", 1);
769 SvREFCNT_dec(totpad);
771 else if (realtype == SVt_PVCV) {
772 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
774 warn("Encountered CODE ref, using dummy placeholder");
777 warn("cannot handle ref type %ld", realtype);
780 if (realpack) { /* free blessed allocs */
785 sv_catpvn(retval, ", '", 3);
786 sv_catpvn(retval, realpack, strlen(realpack));
787 sv_catpvn(retval, "' )", 3);
788 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
789 sv_catpvn(retval, "->", 2);
790 sv_catsv(retval, toaster);
791 sv_catpvn(retval, "()", 2);
801 #ifdef DD_USE_OLD_ID_FORMAT
802 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
804 id_buffer = PTR2UV(val);
805 idlen = sizeof(id_buffer);
807 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
808 (sv = *svp) && SvROK(sv) &&
809 (seenentry = (AV*)SvRV(sv)))
812 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
813 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
815 sv_catpvn(retval, "${", 2);
816 sv_catsv(retval, othername);
817 sv_catpvn(retval, "}", 1);
821 else if (val != &PL_sv_undef) {
822 SV * const namesv = newSVpvn("\\", 1);
823 sv_catpvn(namesv, name, namelen);
825 av_push(seenentry, namesv);
826 av_push(seenentry, newRV_inc(val));
827 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
828 SvREFCNT_dec(seenentry);
832 if (DD_is_integer(val)) {
835 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
837 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
839 /* Need to check to see if this is a string such as " 0".
840 I'm assuming from sprintf isn't going to clash with utf8.
841 Is this valid on EBCDIC? */
843 const char * const pv = SvPV(val, pvlen);
844 if (pvlen != len || memNE(pv, tmpbuf, len))
845 goto integer_came_from_string;
848 /* Looks like we're on a 64 bit system. Make it a string so that
849 if a 32 bit system reads the number it will cope better. */
850 sv_catpvf(retval, "'%s'", tmpbuf);
852 sv_catpvn(retval, tmpbuf, len);
854 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
856 ++c; --i; /* just get the name */
857 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
861 if (needs_quote(c)) {
862 sv_grow(retval, SvCUR(retval)+6+2*i);
863 r = SvPVX(retval)+SvCUR(retval);
864 r[0] = '*'; r[1] = '{'; r[2] = '\'';
865 i += esc_q(r+3, c, i);
867 r[i++] = '\''; r[i++] = '}';
871 sv_grow(retval, SvCUR(retval)+i+2);
872 r = SvPVX(retval)+SvCUR(retval);
873 r[0] = '*'; strcpy(r+1, c);
876 SvCUR_set(retval, SvCUR(retval)+i);
879 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
880 static const STRLEN sizes[] = { 8, 7, 6 };
882 SV * const nname = newSVpvn("", 0);
883 SV * const newapad = newSVpvn("", 0);
884 GV * const gv = (GV*)val;
887 for (j=0; j<3; j++) {
888 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
891 if (j == 0 && !SvOK(e))
896 SV *postentry = newSVpvn(r,i);
898 sv_setsv(nname, postentry);
899 sv_catpvn(nname, entries[j], sizes[j]);
900 sv_catpvn(postentry, " = ", 3);
901 av_push(postav, postentry);
904 SvCUR_set(newapad, 0);
906 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
908 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
909 seenhv, postav, &nlevel, indent, pad, xpad,
910 newapad, sep, pair, freezer, toaster, purity,
911 deepcopy, quotekeys, bless, maxdepth,
917 SvREFCNT_dec(newapad);
921 else if (val == &PL_sv_undef || !SvOK(val)) {
922 sv_catpvn(retval, "undef", 5);
925 integer_came_from_string:
928 i += esc_q_utf8(aTHX_ retval, c, i);
930 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
931 r = SvPVX(retval) + SvCUR(retval);
933 i += esc_q(r+1, c, i);
937 SvCUR_set(retval, SvCUR(retval)+i);
944 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
945 else if (namelen && seenentry) {
946 SV *mark = *av_fetch(seenentry, 2, TRUE);
954 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
957 # This is the exact equivalent of Dump. Well, almost. The things that are
958 # different as of now (due to Laziness):
959 # * doesnt do double-quotes yet.
963 Data_Dumper_Dumpxs(href, ...)
971 AV *postav, *todumpav, *namesav;
973 I32 indent, terse, i, imax, postlen;
975 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
976 SV *freezer, *toaster, *bless, *sortkeys;
977 I32 purity, deepcopy, quotekeys, maxdepth = 0;
981 if (!SvROK(href)) { /* call new to get an object first */
983 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
990 XPUSHs(sv_2mortal(newSVsv(ST(1))));
992 XPUSHs(sv_2mortal(newSVsv(ST(2))));
994 i = perl_call_method("new", G_SCALAR);
997 href = newSVsv(POPs);
1003 (void)sv_2mortal(href);
1006 todumpav = namesav = NULL;
1008 val = pad = xpad = apad = sep = pair = varname
1009 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
1010 name = sv_newmortal();
1012 terse = purity = deepcopy = 0;
1015 retval = newSVpvn("", 0);
1017 && (hv = (HV*)SvRV((SV*)href))
1018 && SvTYPE(hv) == SVt_PVHV) {
1020 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1021 seenhv = (HV*)SvRV(*svp);
1022 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1023 todumpav = (AV*)SvRV(*svp);
1024 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1025 namesav = (AV*)SvRV(*svp);
1026 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1027 indent = SvIV(*svp);
1028 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1029 purity = SvIV(*svp);
1030 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1031 terse = SvTRUE(*svp);
1032 #if 0 /* useqq currently unused */
1033 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1034 useqq = SvTRUE(*svp);
1036 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1038 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1040 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1042 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1044 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1046 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1048 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1050 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1052 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1053 deepcopy = SvTRUE(*svp);
1054 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1055 quotekeys = SvTRUE(*svp);
1056 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1058 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1059 maxdepth = SvIV(*svp);
1060 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1062 if (! SvTRUE(sortkeys))
1064 else if (! (SvROK(sortkeys) &&
1065 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1067 /* flag to use qsortsv() for sorting hash keys */
1068 sortkeys = &PL_sv_yes;
1074 imax = av_len(todumpav);
1077 valstr = newSVpvn("",0);
1078 for (i = 0; i <= imax; ++i) {
1082 if ((svp = av_fetch(todumpav, i, FALSE)))
1086 if ((svp = av_fetch(namesav, i, TRUE))) {
1087 sv_setsv(name, *svp);
1088 if (SvOK(*svp) && !SvPOK(*svp))
1089 (void)SvPV_nolen_const(name);
1092 (void)SvOK_off(name);
1095 if ((SvPVX_const(name))[0] == '*') {
1097 switch (SvTYPE(SvRV(val))) {
1099 (SvPVX(name))[0] = '@';
1102 (SvPVX(name))[0] = '%';
1105 (SvPVX(name))[0] = '*';
1108 (SvPVX(name))[0] = '$';
1113 (SvPVX(name))[0] = '$';
1115 else if ((SvPVX_const(name))[0] != '$')
1116 sv_insert(name, 0, 0, "$", 1);
1120 sv_setpvn(name, "$", 1);
1121 sv_catsv(name, varname);
1122 nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
1123 sv_catpvn(name, tmpbuf, nchars);
1127 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1128 newapad = newSVsv(apad);
1129 sv_catsv(newapad, tmpsv);
1130 SvREFCNT_dec(tmpsv);
1135 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1136 postav, &level, indent, pad, xpad, newapad, sep, pair,
1137 freezer, toaster, purity, deepcopy, quotekeys,
1138 bless, maxdepth, sortkeys);
1141 SvREFCNT_dec(newapad);
1143 postlen = av_len(postav);
1144 if (postlen >= 0 || !terse) {
1145 sv_insert(valstr, 0, 0, " = ", 3);
1146 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1147 sv_catpvn(valstr, ";", 1);
1149 sv_catsv(retval, pad);
1150 sv_catsv(retval, valstr);
1151 sv_catsv(retval, sep);
1154 sv_catsv(retval, pad);
1155 for (i = 0; i <= postlen; ++i) {
1157 svp = av_fetch(postav, i, FALSE);
1158 if (svp && (elem = *svp)) {
1159 sv_catsv(retval, elem);
1161 sv_catpvn(retval, ";", 1);
1162 sv_catsv(retval, sep);
1163 sv_catsv(retval, pad);
1167 sv_catpvn(retval, ";", 1);
1168 sv_catsv(retval, sep);
1170 sv_setpvn(valstr, "", 0);
1171 if (gimme == G_ARRAY) {
1172 XPUSHs(sv_2mortal(retval));
1173 if (i < imax) /* not the last time thro ? */
1174 retval = newSVpvn("",0);
1177 SvREFCNT_dec(postav);
1178 SvREFCNT_dec(valstr);
1181 croak("Call to new() method failed to return HASH ref");
1182 if (gimme == G_SCALAR)
1183 XPUSHs(sv_2mortal(retval));