1 #define PERL_NO_GET_CONTEXT
6 # define NEED_my_snprintf
11 # define DD_USE_OLD_ID_FORMAT
14 static I32 num_q (const char *s, STRLEN slen);
15 static I32 esc_q (char *dest, const char *src, STRLEN slen);
16 static I32 esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen);
17 static I32 needs_quote(register const char *s);
18 static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
19 static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
20 HV *seenhv, AV *postav, I32 *levelp, I32 indent,
21 SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
22 SV *freezer, SV *toaster,
23 I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
24 I32 maxdepth, SV *sortkeys);
27 #define HvNAME_get HvNAME
30 #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
33 # define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
35 # define UNI_TO_NATIVE(ch) (ch)
39 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
41 const UV uv = utf8_to_uv(s, UTF8_MAXLEN, retlen,
42 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
43 return UNI_TO_NATIVE(uv);
46 # if !defined(PERL_IMPLICIT_CONTEXT)
47 # define utf8_to_uvchr Perl_utf8_to_uvchr
49 # define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
52 #endif /* PERL_VERSION <= 6 */
54 /* Changes in 5.7 series mean that now IOK is only set if scalar is
55 precisely integer but in 5.6 and earlier we need to do a more
58 #define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
60 #define DD_is_integer(sv) SvIOK(sv)
63 /* does a string need to be protected? */
65 needs_quote(register const char *s)
90 /* count the number of "'"s and "\"s in string */
92 num_q(register const char *s, register STRLEN slen)
97 if (*s == '\'' || *s == '\\')
106 /* returns number of chars added to escape "'"s and "\"s in s */
107 /* slen number of characters in s will be escaped */
108 /* destination must be long enough for additional chars */
110 esc_q(register char *d, register const char *s, register STRLEN slen)
112 register I32 ret = 0;
130 esc_q_utf8(pTHX_ SV* sv, register const char *src, register STRLEN slen)
134 const char * const send = src + slen;
135 STRLEN j, cur = SvCUR(sv);
136 /* Could count 128-255 and 256+ in two variables, if we want to
137 be like &qquote and make a distinction. */
138 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
139 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
140 STRLEN backslashes = 0;
141 STRLEN single_quotes = 0;
142 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
145 /* this will need EBCDICification */
146 for (s = src; s < send; s += UTF8SKIP(s)) {
147 const UV k = utf8_to_uvchr((U8*)s, NULL);
150 if (!isprint(k) || k > 256) {
154 /* 4: \x{} then count the number of hex digits. */
155 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
157 8 /* We may allocate a bit more than the minimum here. */
159 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
162 } else if (k == '\\') {
164 } else if (k == '\'') {
166 } else if (k == '"' || k == '$' || k == '@') {
173 /* We have something needing hex. 3 is ""\0 */
174 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
175 + 2*qq_escapables + normal);
176 rstart = r = SvPVX(sv) + cur;
180 for (s = src; s < send; s += UTF8SKIP(s)) {
181 const UV k = utf8_to_uvchr((U8*)s, NULL);
183 if (k == '"' || k == '\\' || k == '$' || k == '@') {
189 if (isprint(k) && k < 256)
195 #if PERL_VERSION < 10
196 sprintf(r, "\\x{%"UVxf"}", k);
198 /* my_sprintf is not supported by ppport.h */
200 r = r + my_sprintf(r, "\\x{%"UVxf"}", k);
207 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
208 + qq_escapables + normal);
209 rstart = r = SvPVX(sv) + cur;
211 for (s = src; s < send; s ++) {
213 if (k == '\'' || k == '\\')
221 SvCUR_set(sv, cur + j);
226 /* append a repeated string to an SV */
228 sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
231 sv = newSVpvn("", 0);
234 assert(SvTYPE(sv) >= SVt_PV);
238 SvGROW(sv, len*n + SvCUR(sv) + 1);
240 char * const start = SvPVX(sv) + SvCUR(sv);
241 SvCUR_set(sv, SvCUR(sv) + n);
248 sv_catpvn(sv, str, len);
256 * This ought to be split into smaller functions. (it is one long function since
257 * it exactly parallels the perl version, which was one long thing for
258 * efficiency raisins.) Ugggh!
261 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
262 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
263 SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
264 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
268 char *c, *r, *realpack;
269 #ifdef DD_USE_OLD_ID_FORMAT
273 char *const id = (char *)&id_buffer;
276 SV *sv, *ipad, *ival;
277 SV *blesspad = Nullsv;
278 AV *seenentry = NULL;
280 STRLEN inamelen, idlen = 0;
282 bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it.
283 in later perls we should actually check the classname of the
284 engine. this gets tricky as it involves lexical issues that arent so
286 bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */
291 /* If the ouput buffer has less than some arbitary amount of space
292 remaining, then enlarge it. For the test case (25M of output),
293 *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is
294 deemed to be good enough. */
295 if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) {
296 sv_grow(retval, SvCUR(retval) * 3 / 2);
299 realtype = SvTYPE(val);
305 /* If a freeze method is provided and the object has it, call
306 it. Warn on errors. */
307 if (SvOBJECT(SvRV(val)) && freezer &&
308 SvPOK(freezer) && SvCUR(freezer) &&
309 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
310 SvCUR(freezer), -1) != NULL)
312 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
313 XPUSHs(val); PUTBACK;
314 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
317 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
318 PUTBACK; FREETMPS; LEAVE;
322 realtype = SvTYPE(ival);
323 #ifdef DD_USE_OLD_ID_FORMAT
324 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival));
326 id_buffer = PTR2UV(ival);
327 idlen = sizeof(id_buffer);
330 realpack = HvNAME_get(SvSTASH(ival));
334 /* if it has a name, we need to either look it up, or keep a tab
335 * on it so we know when we hit it later
338 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
339 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
342 if ((svp = av_fetch(seenentry, 0, FALSE))
343 && (othername = *svp))
345 if (purity && *levelp > 0) {
348 if (realtype == SVt_PVHV)
349 sv_catpvn(retval, "{}", 2);
350 else if (realtype == SVt_PVAV)
351 sv_catpvn(retval, "[]", 2);
353 sv_catpvn(retval, "do{my $o}", 9);
354 postentry = newSVpvn(name, namelen);
355 sv_catpvn(postentry, " = ", 3);
356 sv_catsv(postentry, othername);
357 av_push(postav, postentry);
360 if (name[0] == '@' || name[0] == '%') {
361 if ((SvPVX_const(othername))[0] == '\\' &&
362 (SvPVX_const(othername))[1] == name[0]) {
363 sv_catpvn(retval, SvPVX_const(othername)+1,
367 sv_catpvn(retval, name, 1);
368 sv_catpvn(retval, "{", 1);
369 sv_catsv(retval, othername);
370 sv_catpvn(retval, "}", 1);
374 sv_catsv(retval, othername);
379 #ifdef DD_USE_OLD_ID_FORMAT
380 warn("ref name not found for %s", id);
382 warn("ref name not found for 0x%"UVxf, PTR2UV(ival));
387 else { /* store our name and continue */
389 if (name[0] == '@' || name[0] == '%') {
390 namesv = newSVpvn("\\", 1);
391 sv_catpvn(namesv, name, namelen);
393 else if (realtype == SVt_PVCV && name[0] == '*') {
394 namesv = newSVpvn("\\", 2);
395 sv_catpvn(namesv, name, namelen);
396 (SvPVX(namesv))[1] = '&';
399 namesv = newSVpvn(name, namelen);
401 av_push(seenentry, namesv);
402 (void)SvREFCNT_inc(val);
403 av_push(seenentry, val);
404 (void)hv_store(seenhv, id, idlen,
405 newRV_inc((SV*)seenentry), 0);
406 SvREFCNT_dec(seenentry);
409 /* regexps dont have to be blessed into package "Regexp"
410 * they can be blessed into any package.
413 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp"))
414 #elif PERL_VERSION < 11
415 if (realpack && realtype == SVt_PVMG && mg_find(ival, PERL_MAGIC_qr))
417 if (realpack && realtype == SVt_REGEXP)
421 if (strEQ(realpack, "Regexp"))
427 /* If purity is not set and maxdepth is set, then check depth:
428 * if we have reached maximum depth, return the string
429 * representation of the thing we are currently examining
430 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
432 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
434 const char * const valstr = SvPV(val,vallen);
435 sv_catpvn(retval, "'", 1);
436 sv_catpvn(retval, valstr, vallen);
437 sv_catpvn(retval, "'", 1);
441 if (realpack && !no_bless) { /* we have a blessed ref */
443 const char * const blessstr = SvPV(bless, blesslen);
444 sv_catpvn(retval, blessstr, blesslen);
445 sv_catpvn(retval, "( ", 2);
448 apad = newSVsv(apad);
449 sv_x(aTHX_ apad, " ", 1, blesslen+2);
454 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
459 const char *rval = SvPV(val, rlen);
460 const char *slash = strchr(rval, '/');
461 sv_catpvn(retval, "qr/", 3);
463 sv_catpvn(retval, rval, slash-rval);
464 sv_catpvn(retval, "\\/", 2);
465 rlen -= slash-rval+1;
467 slash = strchr(rval, '/');
469 sv_catpvn(retval, rval, rlen);
470 sv_catpvn(retval, "/", 1);
479 SV * const namesv = newSVpvn("${", 2);
480 sv_catpvn(namesv, name, namelen);
481 sv_catpvn(namesv, "}", 1);
482 if (realpack) { /* blessed */
483 sv_catpvn(retval, "do{\\(my $o = ", 13);
484 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
485 postav, levelp, indent, pad, xpad, apad, sep, pair,
486 freezer, toaster, purity, deepcopy, quotekeys, bless,
488 sv_catpvn(retval, ")}", 2);
491 sv_catpvn(retval, "\\", 1);
492 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
493 postav, levelp, indent, pad, xpad, apad, sep, pair,
494 freezer, toaster, purity, deepcopy, quotekeys, bless,
497 SvREFCNT_dec(namesv);
499 else if (realtype == SVt_PVGV) { /* glob ref */
500 SV * const namesv = newSVpvn("*{", 2);
501 sv_catpvn(namesv, name, namelen);
502 sv_catpvn(namesv, "}", 1);
503 sv_catpvn(retval, "\\", 1);
504 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
505 postav, levelp, indent, pad, xpad, apad, sep, pair,
506 freezer, toaster, purity, deepcopy, quotekeys, bless,
508 SvREFCNT_dec(namesv);
510 else if (realtype == SVt_PVAV) {
513 const I32 ixmax = av_len((AV *)ival);
515 SV * const ixsv = newSViv(0);
516 /* allowing for a 24 char wide array index */
517 New(0, iname, namelen+28, char);
518 (void)strcpy(iname, name);
520 if (name[0] == '@') {
521 sv_catpvn(retval, "(", 1);
525 sv_catpvn(retval, "[", 1);
526 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
528 && name[namelen-1] != ']' && name[namelen-1] != '}'
529 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
531 && name[namelen-1] != ']' && name[namelen-1] != '}')
534 || (name[0] == '\\' && name[2] == '{'))))
536 iname[inamelen++] = '-'; iname[inamelen++] = '>';
537 iname[inamelen] = '\0';
540 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
541 (instr(iname+inamelen-8, "{SCALAR}") ||
542 instr(iname+inamelen-7, "{ARRAY}") ||
543 instr(iname+inamelen-6, "{HASH}"))) {
544 iname[inamelen++] = '-'; iname[inamelen++] = '>';
546 iname[inamelen++] = '['; iname[inamelen] = '\0';
547 totpad = newSVsv(sep);
548 sv_catsv(totpad, pad);
549 sv_catsv(totpad, apad);
551 for (ix = 0; ix <= ixmax; ++ix) {
554 svp = av_fetch((AV*)ival, ix, FALSE);
562 #if PERL_VERSION < 10
563 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
564 ilen = strlen(iname);
566 ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
568 iname[ilen++] = ']'; iname[ilen] = '\0';
570 sv_catsv(retval, totpad);
571 sv_catsv(retval, ipad);
572 sv_catpvn(retval, "#", 1);
573 sv_catsv(retval, ixsv);
575 sv_catsv(retval, totpad);
576 sv_catsv(retval, ipad);
577 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
578 levelp, indent, pad, xpad, apad, sep, pair,
579 freezer, toaster, purity, deepcopy, quotekeys, bless,
582 sv_catpvn(retval, ",", 1);
585 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
586 sv_catsv(retval, totpad);
587 sv_catsv(retval, opad);
591 sv_catpvn(retval, ")", 1);
593 sv_catpvn(retval, "]", 1);
595 SvREFCNT_dec(totpad);
598 else if (realtype == SVt_PVHV) {
599 SV *totpad, *newapad;
607 SV * const iname = newSVpvn(name, namelen);
608 if (name[0] == '%') {
609 sv_catpvn(retval, "(", 1);
610 (SvPVX(iname))[0] = '$';
613 sv_catpvn(retval, "{", 1);
614 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
616 && name[namelen-1] != ']' && name[namelen-1] != '}')
619 || (name[0] == '\\' && name[2] == '{'))))
621 sv_catpvn(iname, "->", 2);
624 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
625 (instr(name+namelen-8, "{SCALAR}") ||
626 instr(name+namelen-7, "{ARRAY}") ||
627 instr(name+namelen-6, "{HASH}"))) {
628 sv_catpvn(iname, "->", 2);
630 sv_catpvn(iname, "{", 1);
631 totpad = newSVsv(sep);
632 sv_catsv(totpad, pad);
633 sv_catsv(totpad, apad);
635 /* If requested, get a sorted/filtered array of hash keys */
637 if (sortkeys == &PL_sv_yes) {
639 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
642 (void)hv_iterinit((HV*)ival);
643 while ((entry = hv_iternext((HV*)ival))) {
644 sv = hv_iterkeysv(entry);
648 # ifdef USE_LOCALE_NUMERIC
649 sortsv(AvARRAY(keys),
651 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
653 sortsv(AvARRAY(keys),
659 if (sortkeys != &PL_sv_yes) {
660 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
661 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
662 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
666 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
667 keys = (AV*)SvREFCNT_inc(SvRV(sv));
670 warn("Sortkeys subroutine did not return ARRAYREF\n");
671 PUTBACK; FREETMPS; LEAVE;
674 sv_2mortal((SV*)keys);
677 (void)hv_iterinit((HV*)ival);
679 /* foreach (keys %hash) */
680 for (i = 0; 1; i++) {
682 char *nkey_buffer = NULL;
687 bool do_utf8 = FALSE;
690 if (!(keys && (I32)i <= av_len(keys))) break;
692 if (!(entry = hv_iternext((HV *)ival))) break;
696 sv_catpvn(retval, ",", 1);
700 svp = av_fetch(keys, i, FALSE);
701 keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
702 key = SvPV(keysv, keylen);
703 svp = hv_fetch((HV*)ival, key,
704 SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
705 hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
708 keysv = hv_iterkeysv(entry);
709 hval = hv_iterval((HV*)ival, entry);
712 key = SvPV(keysv, keylen);
713 do_utf8 = DO_UTF8(keysv);
716 sv_catsv(retval, totpad);
717 sv_catsv(retval, ipad);
718 /* old logic was first to check utf8 flag, and if utf8 always
719 call esc_q_utf8. This caused test to break under -Mutf8,
720 because there even strings like 'c' have utf8 flag on.
721 Hence with quotekeys == 0 the XS code would still '' quote
722 them based on flags, whereas the perl code would not,
724 The perl code is correct.
725 needs_quote() decides that anything that isn't a valid
726 perl identifier needs to be quoted, hence only correctly
727 formed strings with no characters outside [A-Za-z0-9_:]
728 won't need quoting. None of those characters are used in
729 the byte encoding of utf8, so anything with utf8
730 encoded characters in will need quoting. Hence strings
731 with utf8 encoded characters in will end up inside do_utf8
732 just like before, but now strings with utf8 flag set but
733 only ascii characters will end up in the unquoted section.
735 There should also be less tests for the (probably currently)
736 more common doesn't need quoting case.
737 The code is also smaller (22044 vs 22260) because I've been
738 able to pull the common logic out to both sides. */
739 if (quotekeys || needs_quote(key)) {
741 STRLEN ocur = SvCUR(retval);
742 nlen = esc_q_utf8(aTHX_ retval, key, klen);
743 nkey = SvPVX(retval) + ocur;
746 nticks = num_q(key, klen);
747 New(0, nkey_buffer, klen+nticks+3, char);
751 klen += esc_q(nkey+1, key, klen);
753 (void)Copy(key, nkey+1, klen, char);
757 sv_catpvn(retval, nkey, klen);
763 sv_catpvn(retval, nkey, klen);
765 sname = newSVsv(iname);
766 sv_catpvn(sname, nkey, nlen);
767 sv_catpvn(sname, "}", 1);
769 sv_catsv(retval, pair);
773 newapad = newSVsv(apad);
774 New(0, extra, klen+4+1, char);
775 while (elen < (klen+4))
778 sv_catpvn(newapad, extra, elen);
784 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
785 postav, levelp, indent, pad, xpad, newapad, sep, pair,
786 freezer, toaster, purity, deepcopy, quotekeys, bless,
789 Safefree(nkey_buffer);
791 SvREFCNT_dec(newapad);
794 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
795 sv_catsv(retval, totpad);
796 sv_catsv(retval, opad);
800 sv_catpvn(retval, ")", 1);
802 sv_catpvn(retval, "}", 1);
804 SvREFCNT_dec(totpad);
806 else if (realtype == SVt_PVCV) {
807 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
809 warn("Encountered CODE ref, using dummy placeholder");
812 warn("cannot handle ref type %ld", realtype);
815 if (realpack && !no_bless) { /* free blessed allocs */
823 sv_catpvn(retval, ", '", 3);
825 plen = strlen(realpack);
826 pticks = num_q(realpack, plen);
827 if (pticks) { /* needs escaping */
829 char *npack_buffer = NULL;
831 New(0, npack_buffer, plen+pticks+1, char);
832 npack = npack_buffer;
833 plen += esc_q(npack, realpack, plen);
836 sv_catpvn(retval, npack, plen);
837 Safefree(npack_buffer);
840 sv_catpvn(retval, realpack, strlen(realpack));
842 sv_catpvn(retval, "' )", 3);
843 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
844 sv_catpvn(retval, "->", 2);
845 sv_catsv(retval, toaster);
846 sv_catpvn(retval, "()", 2);
856 #ifdef DD_USE_OLD_ID_FORMAT
857 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
859 id_buffer = PTR2UV(val);
860 idlen = sizeof(id_buffer);
862 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
863 (sv = *svp) && SvROK(sv) &&
864 (seenentry = (AV*)SvRV(sv)))
867 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
868 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
870 sv_catpvn(retval, "${", 2);
871 sv_catsv(retval, othername);
872 sv_catpvn(retval, "}", 1);
876 else if (val != &PL_sv_undef) {
877 SV * const namesv = newSVpvn("\\", 1);
878 sv_catpvn(namesv, name, namelen);
880 av_push(seenentry, namesv);
881 av_push(seenentry, newRV_inc(val));
882 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
883 SvREFCNT_dec(seenentry);
887 if (DD_is_integer(val)) {
890 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
892 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
894 /* Need to check to see if this is a string such as " 0".
895 I'm assuming from sprintf isn't going to clash with utf8.
896 Is this valid on EBCDIC? */
898 const char * const pv = SvPV(val, pvlen);
899 if (pvlen != len || memNE(pv, tmpbuf, len))
900 goto integer_came_from_string;
903 /* Looks like we're on a 64 bit system. Make it a string so that
904 if a 32 bit system reads the number it will cope better. */
905 sv_catpvf(retval, "'%s'", tmpbuf);
907 sv_catpvn(retval, tmpbuf, len);
909 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
911 ++c; --i; /* just get the name */
912 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
916 if (needs_quote(c)) {
917 sv_grow(retval, SvCUR(retval)+6+2*i);
918 r = SvPVX(retval)+SvCUR(retval);
919 r[0] = '*'; r[1] = '{'; r[2] = '\'';
920 i += esc_q(r+3, c, i);
922 r[i++] = '\''; r[i++] = '}';
926 sv_grow(retval, SvCUR(retval)+i+2);
927 r = SvPVX(retval)+SvCUR(retval);
928 r[0] = '*'; strcpy(r+1, c);
931 SvCUR_set(retval, SvCUR(retval)+i);
934 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
935 static const STRLEN sizes[] = { 8, 7, 6 };
937 SV * const nname = newSVpvn("", 0);
938 SV * const newapad = newSVpvn("", 0);
939 GV * const gv = (GV*)val;
942 for (j=0; j<3; j++) {
943 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
946 if (j == 0 && !SvOK(e))
951 SV *postentry = newSVpvn(r,i);
953 sv_setsv(nname, postentry);
954 sv_catpvn(nname, entries[j], sizes[j]);
955 sv_catpvn(postentry, " = ", 3);
956 av_push(postav, postentry);
959 SvCUR_set(newapad, 0);
961 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
963 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
964 seenhv, postav, &nlevel, indent, pad, xpad,
965 newapad, sep, pair, freezer, toaster, purity,
966 deepcopy, quotekeys, bless, maxdepth,
972 SvREFCNT_dec(newapad);
976 else if (val == &PL_sv_undef || !SvOK(val)) {
977 sv_catpvn(retval, "undef", 5);
980 integer_came_from_string:
983 i += esc_q_utf8(aTHX_ retval, c, i);
985 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
986 r = SvPVX(retval) + SvCUR(retval);
988 i += esc_q(r+1, c, i);
992 SvCUR_set(retval, SvCUR(retval)+i);
999 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
1000 else if (namelen && seenentry) {
1001 SV *mark = *av_fetch(seenentry, 2, TRUE);
1009 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
1012 # This is the exact equivalent of Dump. Well, almost. The things that are
1013 # different as of now (due to Laziness):
1014 # * doesnt do double-quotes yet.
1018 Data_Dumper_Dumpxs(href, ...)
1024 SV *retval, *valstr;
1026 AV *postav, *todumpav, *namesav;
1028 I32 indent, terse, i, imax, postlen;
1030 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
1031 SV *freezer, *toaster, *bless, *sortkeys;
1032 I32 purity, deepcopy, quotekeys, maxdepth = 0;
1036 if (!SvROK(href)) { /* call new to get an object first */
1038 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
1045 XPUSHs(sv_2mortal(newSVsv(ST(1))));
1047 XPUSHs(sv_2mortal(newSVsv(ST(2))));
1049 i = perl_call_method("new", G_SCALAR);
1052 href = newSVsv(POPs);
1058 (void)sv_2mortal(href);
1061 todumpav = namesav = NULL;
1063 val = pad = xpad = apad = sep = pair = varname
1064 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
1065 name = sv_newmortal();
1067 terse = purity = deepcopy = 0;
1070 retval = newSVpvn("", 0);
1072 && (hv = (HV*)SvRV((SV*)href))
1073 && SvTYPE(hv) == SVt_PVHV) {
1075 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1076 seenhv = (HV*)SvRV(*svp);
1077 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1078 todumpav = (AV*)SvRV(*svp);
1079 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1080 namesav = (AV*)SvRV(*svp);
1081 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1082 indent = SvIV(*svp);
1083 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1084 purity = SvIV(*svp);
1085 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1086 terse = SvTRUE(*svp);
1087 #if 0 /* useqq currently unused */
1088 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1089 useqq = SvTRUE(*svp);
1091 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1093 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1095 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1097 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1099 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1101 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1103 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1105 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1107 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1108 deepcopy = SvTRUE(*svp);
1109 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1110 quotekeys = SvTRUE(*svp);
1111 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1113 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1114 maxdepth = SvIV(*svp);
1115 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1117 if (! SvTRUE(sortkeys))
1119 else if (! (SvROK(sortkeys) &&
1120 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1122 /* flag to use qsortsv() for sorting hash keys */
1123 sortkeys = &PL_sv_yes;
1129 imax = av_len(todumpav);
1132 valstr = newSVpvn("",0);
1133 for (i = 0; i <= imax; ++i) {
1137 if ((svp = av_fetch(todumpav, i, FALSE)))
1141 if ((svp = av_fetch(namesav, i, TRUE))) {
1142 sv_setsv(name, *svp);
1143 if (SvOK(*svp) && !SvPOK(*svp))
1144 (void)SvPV_nolen_const(name);
1147 (void)SvOK_off(name);
1150 if ((SvPVX_const(name))[0] == '*') {
1152 switch (SvTYPE(SvRV(val))) {
1154 (SvPVX(name))[0] = '@';
1157 (SvPVX(name))[0] = '%';
1160 (SvPVX(name))[0] = '*';
1163 (SvPVX(name))[0] = '$';
1168 (SvPVX(name))[0] = '$';
1170 else if ((SvPVX_const(name))[0] != '$')
1171 sv_insert(name, 0, 0, "$", 1);
1175 sv_setpvn(name, "$", 1);
1176 sv_catsv(name, varname);
1177 nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
1178 sv_catpvn(name, tmpbuf, nchars);
1182 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1183 newapad = newSVsv(apad);
1184 sv_catsv(newapad, tmpsv);
1185 SvREFCNT_dec(tmpsv);
1190 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1191 postav, &level, indent, pad, xpad, newapad, sep, pair,
1192 freezer, toaster, purity, deepcopy, quotekeys,
1193 bless, maxdepth, sortkeys);
1196 SvREFCNT_dec(newapad);
1198 postlen = av_len(postav);
1199 if (postlen >= 0 || !terse) {
1200 sv_insert(valstr, 0, 0, " = ", 3);
1201 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1202 sv_catpvn(valstr, ";", 1);
1204 sv_catsv(retval, pad);
1205 sv_catsv(retval, valstr);
1206 sv_catsv(retval, sep);
1209 sv_catsv(retval, pad);
1210 for (i = 0; i <= postlen; ++i) {
1212 svp = av_fetch(postav, i, FALSE);
1213 if (svp && (elem = *svp)) {
1214 sv_catsv(retval, elem);
1216 sv_catpvn(retval, ";", 1);
1217 sv_catsv(retval, sep);
1218 sv_catsv(retval, pad);
1222 sv_catpvn(retval, ";", 1);
1223 sv_catsv(retval, sep);
1225 sv_setpvn(valstr, "", 0);
1226 if (gimme == G_ARRAY) {
1227 XPUSHs(sv_2mortal(retval));
1228 if (i < imax) /* not the last time thro ? */
1229 retval = newSVpvn("",0);
1232 SvREFCNT_dec(postav);
1233 SvREFCNT_dec(valstr);
1236 croak("Call to new() method failed to return HASH ref");
1237 if (gimme == G_SCALAR)
1238 XPUSHs(sv_2mortal(retval));