This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Data::Dumper: Option to avoid building much of the seen hash
[perl5.git] / dist / Data-Dumper / Dumper.xs
1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5 #ifdef USE_PPPORT_H
6 #  define NEED_my_snprintf
7 #  define NEED_sv_2pv_flags
8 #  include "ppport.h"
9 #endif
10
11 #if PERL_VERSION < 8
12 #  define DD_USE_OLD_ID_FORMAT
13 #endif
14
15 static I32 num_q (const char *s, STRLEN slen);
16 static I32 esc_q (char *dest, const char *src, STRLEN slen);
17 static I32 esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen);
18 static I32 needs_quote(register const char *s, STRLEN len);
19 static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
20 static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
21                     HV *seenhv, AV *postav, I32 *levelp, I32 indent,
22                     SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
23                     SV *freezer, SV *toaster,
24                     I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
25                     I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash);
26
27 #ifndef HvNAME_get
28 #define HvNAME_get HvNAME
29 #endif
30
31 #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
32
33 # ifdef EBCDIC
34 #  define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
35 # else
36 #  define UNI_TO_NATIVE(ch) (ch)
37 # endif
38
39 UV
40 Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen)
41 {
42     const UV uv = utf8_to_uv(s, send - s, retlen,
43                     ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
44     return UNI_TO_NATIVE(uv);
45 }
46
47 # if !defined(PERL_IMPLICIT_CONTEXT)
48 #  define utf8_to_uvchr_buf          Perl_utf8_to_uvchr_buf
49 # else
50 #  define utf8_to_uvchr_buf(a,b) Perl_utf8_to_uvchr_buf(aTHX_ a,b)
51 # endif
52
53 #endif /* PERL_VERSION <= 6 */
54
55 /* Changes in 5.7 series mean that now IOK is only set if scalar is
56    precisely integer but in 5.6 and earlier we need to do a more
57    complex test  */
58 #if PERL_VERSION <= 6
59 #define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
60 #else
61 #define DD_is_integer(sv) SvIOK(sv)
62 #endif
63
64 /* does a string need to be protected? */
65 static I32
66 needs_quote(register const char *s, STRLEN len)
67 {
68     const char *send = s+len;
69 TOP:
70     if (s[0] == ':') {
71         if (++s<send) {
72             if (*s++ != ':')
73                 return 1;
74         }
75         else
76             return 1;
77     }
78     if (isIDFIRST(*s)) {
79         while (++s<send)
80             if (!isALNUM(*s)) {
81                 if (*s == ':')
82                     goto TOP;
83                 else
84                     return 1;
85             }
86     }
87     else
88         return 1;
89     return 0;
90 }
91
92 /* count the number of "'"s and "\"s in string */
93 static I32
94 num_q(register const char *s, register STRLEN slen)
95 {
96     register I32 ret = 0;
97
98     while (slen > 0) {
99         if (*s == '\'' || *s == '\\')
100             ++ret;
101         ++s;
102         --slen;
103     }
104     return ret;
105 }
106
107
108 /* returns number of chars added to escape "'"s and "\"s in s */
109 /* slen number of characters in s will be escaped */
110 /* destination must be long enough for additional chars */
111 static I32
112 esc_q(register char *d, register const char *s, register STRLEN slen)
113 {
114     register I32 ret = 0;
115
116     while (slen > 0) {
117         switch (*s) {
118         case '\'':
119         case '\\':
120             *d = '\\';
121             ++d; ++ret;
122         default:
123             *d = *s;
124             ++d; ++s; --slen;
125             break;
126         }
127     }
128     return ret;
129 }
130
131 static I32
132 esc_q_utf8(pTHX_ SV* sv, register const char *src, register STRLEN slen)
133 {
134     char *r, *rstart;
135     const char *s = src;
136     const char * const send = src + slen;
137     STRLEN j, cur = SvCUR(sv);
138     /* Could count 128-255 and 256+ in two variables, if we want to
139        be like &qquote and make a distinction.  */
140     STRLEN grow = 0;    /* bytes needed to represent chars 128+ */
141     /* STRLEN topbit_grow = 0;  bytes needed to represent chars 128-255 */
142     STRLEN backslashes = 0;
143     STRLEN single_quotes = 0;
144     STRLEN qq_escapables = 0;   /* " $ @ will need a \ in "" strings.  */
145     STRLEN normal = 0;
146     int increment;
147
148     /* this will need EBCDICification */
149     for (s = src; s < send; s += increment) {
150         const UV k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL);
151
152         /* check for invalid utf8 */
153         increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s);
154
155 #ifdef EBCDIC
156         if (!isprint(k) || k > 256) {
157 #else
158         if (k > 127) {
159 #endif
160             /* 4: \x{} then count the number of hex digits.  */
161             grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
162 #if UVSIZE == 4
163                 8 /* We may allocate a bit more than the minimum here.  */
164 #else
165                 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
166 #endif
167                 );
168         } else if (k == '\\') {
169             backslashes++;
170         } else if (k == '\'') {
171             single_quotes++;
172         } else if (k == '"' || k == '$' || k == '@') {
173             qq_escapables++;
174         } else {
175             normal++;
176         }
177     }
178     if (grow) {
179         /* We have something needing hex. 3 is ""\0 */
180         sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
181                 + 2*qq_escapables + normal);
182         rstart = r = SvPVX(sv) + cur;
183
184         *r++ = '"';
185
186         for (s = src; s < send; s += UTF8SKIP(s)) {
187             const UV k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL);
188
189             if (k == '"' || k == '\\' || k == '$' || k == '@') {
190                 *r++ = '\\';
191                 *r++ = (char)k;
192             }
193             else
194 #ifdef EBCDIC
195               if (isprint(k) && k < 256)
196 #else
197               if (k < 0x80)
198 #endif
199                 *r++ = (char)k;
200             else {
201 #if PERL_VERSION < 10
202                 sprintf(r, "\\x{%"UVxf"}", k);
203                 r += strlen(r);
204                 /* my_sprintf is not supported by ppport.h */
205 #else
206                 r = r + my_sprintf(r, "\\x{%"UVxf"}", k);
207 #endif
208             }
209         }
210         *r++ = '"';
211     } else {
212         /* Single quotes.  */
213         sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
214                 + qq_escapables + normal);
215         rstart = r = SvPVX(sv) + cur;
216         *r++ = '\'';
217         for (s = src; s < send; s ++) {
218             const char k = *s;
219             if (k == '\'' || k == '\\')
220                 *r++ = '\\';
221             *r++ = k;
222         }
223         *r++ = '\'';
224     }
225     *r = '\0';
226     j = r - rstart;
227     SvCUR_set(sv, cur + j);
228
229     return j;
230 }
231
232 /* append a repeated string to an SV */
233 static SV *
234 sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
235 {
236     if (!sv)
237         sv = newSVpvn("", 0);
238 #ifdef DEBUGGING
239     else
240         assert(SvTYPE(sv) >= SVt_PV);
241 #endif
242
243     if (n > 0) {
244         SvGROW(sv, len*n + SvCUR(sv) + 1);
245         if (len == 1) {
246             char * const start = SvPVX(sv) + SvCUR(sv);
247             SvCUR_set(sv, SvCUR(sv) + n);
248             start[n] = '\0';
249             while (n > 0)
250                 start[--n] = str[0];
251         }
252         else
253             while (n > 0) {
254                 sv_catpvn(sv, str, len);
255                 --n;
256             }
257     }
258     return sv;
259 }
260
261 /*
262  * This ought to be split into smaller functions. (it is one long function since
263  * it exactly parallels the perl version, which was one long thing for
264  * efficiency raisins.)  Ugggh!
265  */
266 static I32
267 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
268         AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
269         SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
270         I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys,
271         int use_sparse_seen_hash)
272 {
273     char tmpbuf[128];
274     U32 i;
275     char *c, *r, *realpack;
276 #ifdef DD_USE_OLD_ID_FORMAT
277     char id[128];
278 #else
279     UV id_buffer;
280     char *const id = (char *)&id_buffer;
281 #endif
282     SV **svp;
283     SV *sv, *ipad, *ival;
284     SV *blesspad = Nullsv;
285     AV *seenentry = NULL;
286     char *iname;
287     STRLEN inamelen, idlen = 0;
288     U32 realtype;
289     bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it.
290                           in later perls we should actually check the classname of the 
291                           engine. this gets tricky as it involves lexical issues that arent so
292                           easy to resolve */
293     bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */
294
295     if (!val)
296         return 0;
297
298     /* If the ouput buffer has less than some arbitrary amount of space
299        remaining, then enlarge it. For the test case (25M of output),
300        *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is
301         deemed to be good enough.  */
302     if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) {
303         sv_grow(retval, SvCUR(retval) * 3 / 2);
304     }
305
306     realtype = SvTYPE(val);
307
308     if (SvGMAGICAL(val))
309         mg_get(val);
310     if (SvROK(val)) {
311
312         /* If a freeze method is provided and the object has it, call
313            it.  Warn on errors. */
314         if (SvOBJECT(SvRV(val)) && freezer &&
315             SvPOK(freezer) && SvCUR(freezer) &&
316             gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer), 
317                          SvCUR(freezer), -1) != NULL)
318         {
319             dSP; ENTER; SAVETMPS; PUSHMARK(sp);
320             XPUSHs(val); PUTBACK;
321             i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
322             SPAGAIN;
323             if (SvTRUE(ERRSV))
324                 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
325             PUTBACK; FREETMPS; LEAVE;
326         }
327         
328         ival = SvRV(val);
329         realtype = SvTYPE(ival);
330 #ifdef DD_USE_OLD_ID_FORMAT
331         idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival));
332 #else
333         id_buffer = PTR2UV(ival);
334         idlen = sizeof(id_buffer);
335 #endif
336         if (SvOBJECT(ival))
337             realpack = HvNAME_get(SvSTASH(ival));
338         else
339             realpack = NULL;
340
341         /* if it has a name, we need to either look it up, or keep a tab
342          * on it so we know when we hit it later
343          */
344         if (namelen) {
345             if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
346                 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
347             {
348                 SV *othername;
349                 if ((svp = av_fetch(seenentry, 0, FALSE))
350                     && (othername = *svp))
351                 {
352                     if (purity && *levelp > 0) {
353                         SV *postentry;
354                         
355                         if (realtype == SVt_PVHV)
356                             sv_catpvn(retval, "{}", 2);
357                         else if (realtype == SVt_PVAV)
358                             sv_catpvn(retval, "[]", 2);
359                         else
360                             sv_catpvn(retval, "do{my $o}", 9);
361                         postentry = newSVpvn(name, namelen);
362                         sv_catpvn(postentry, " = ", 3);
363                         sv_catsv(postentry, othername);
364                         av_push(postav, postentry);
365                     }
366                     else {
367                         if (name[0] == '@' || name[0] == '%') {
368                             if ((SvPVX_const(othername))[0] == '\\' &&
369                                 (SvPVX_const(othername))[1] == name[0]) {
370                                 sv_catpvn(retval, SvPVX_const(othername)+1,
371                                           SvCUR(othername)-1);
372                             }
373                             else {
374                                 sv_catpvn(retval, name, 1);
375                                 sv_catpvn(retval, "{", 1);
376                                 sv_catsv(retval, othername);
377                                 sv_catpvn(retval, "}", 1);
378                             }
379                         }
380                         else
381                             sv_catsv(retval, othername);
382                     }
383                     return 1;
384                 }
385                 else {
386 #ifdef DD_USE_OLD_ID_FORMAT
387                     warn("ref name not found for %s", id);
388 #else
389                     warn("ref name not found for 0x%"UVxf, PTR2UV(ival));
390 #endif
391                     return 0;
392                 }
393             }
394             else {   /* store our name and continue */
395                 SV *namesv;
396                 if (name[0] == '@' || name[0] == '%') {
397                     namesv = newSVpvn("\\", 1);
398                     sv_catpvn(namesv, name, namelen);
399                 }
400                 else if (realtype == SVt_PVCV && name[0] == '*') {
401                     namesv = newSVpvn("\\", 2);
402                     sv_catpvn(namesv, name, namelen);
403                     (SvPVX(namesv))[1] = '&';
404                 }
405                 else
406                     namesv = newSVpvn(name, namelen);
407                 seenentry = newAV();
408                 av_push(seenentry, namesv);
409                 (void)SvREFCNT_inc(val);
410                 av_push(seenentry, val);
411                 (void)hv_store(seenhv, id, idlen,
412                                newRV_inc((SV*)seenentry), 0);
413                 SvREFCNT_dec(seenentry);
414             }
415         }
416         /* regexps dont have to be blessed into package "Regexp"
417          * they can be blessed into any package. 
418          */
419 #if PERL_VERSION < 8
420         if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) 
421 #elif PERL_VERSION < 11
422         if (realpack && realtype == SVt_PVMG && mg_find(ival, PERL_MAGIC_qr))
423 #else        
424         if (realpack && realtype == SVt_REGEXP) 
425 #endif
426         {
427             is_regex = 1;
428             if (strEQ(realpack, "Regexp")) 
429                 no_bless = 1;
430             else
431                 no_bless = 0;
432         }
433
434         /* If purity is not set and maxdepth is set, then check depth:
435          * if we have reached maximum depth, return the string
436          * representation of the thing we are currently examining
437          * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
438          */
439         if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
440             STRLEN vallen;
441             const char * const valstr = SvPV(val,vallen);
442             sv_catpvn(retval, "'", 1);
443             sv_catpvn(retval, valstr, vallen);
444             sv_catpvn(retval, "'", 1);
445             return 1;
446         }
447
448         if (realpack && !no_bless) {                            /* we have a blessed ref */
449             STRLEN blesslen;
450             const char * const blessstr = SvPV(bless, blesslen);
451             sv_catpvn(retval, blessstr, blesslen);
452             sv_catpvn(retval, "( ", 2);
453             if (indent >= 2) {
454                 blesspad = apad;
455                 apad = newSVsv(apad);
456                 sv_x(aTHX_ apad, " ", 1, blesslen+2);
457             }
458         }
459
460         (*levelp)++;
461         ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
462
463         if (is_regex) 
464         {
465             STRLEN rlen;
466             const char *rval = SvPV(val, rlen);
467             const char * const rend = rval+rlen;
468             const char *slash = rval;
469             sv_catpvn(retval, "qr/", 3);
470             for (;slash < rend; slash++) {
471               if (*slash == '\\') { ++slash; continue; }
472               if (*slash == '/') {    
473                 sv_catpvn(retval, rval, slash-rval);
474                 sv_catpvn(retval, "\\/", 2);
475                 rlen -= slash-rval+1;
476                 rval = slash+1;
477               }
478             }
479             sv_catpvn(retval, rval, rlen);
480             sv_catpvn(retval, "/", 1);
481         } 
482         else if (
483 #if PERL_VERSION < 9
484                 realtype <= SVt_PVBM
485 #else
486                 realtype <= SVt_PVMG
487 #endif
488         ) {                          /* scalar ref */
489             SV * const namesv = newSVpvn("${", 2);
490             sv_catpvn(namesv, name, namelen);
491             sv_catpvn(namesv, "}", 1);
492             if (realpack) {                                  /* blessed */
493                 sv_catpvn(retval, "do{\\(my $o = ", 13);
494                 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
495                         postav, levelp, indent, pad, xpad, apad, sep, pair,
496                         freezer, toaster, purity, deepcopy, quotekeys, bless,
497                         maxdepth, sortkeys, use_sparse_seen_hash);
498                 sv_catpvn(retval, ")}", 2);
499             }                                                /* plain */
500             else {
501                 sv_catpvn(retval, "\\", 1);
502                 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
503                         postav, levelp, indent, pad, xpad, apad, sep, pair,
504                         freezer, toaster, purity, deepcopy, quotekeys, bless,
505                         maxdepth, sortkeys, use_sparse_seen_hash);
506             }
507             SvREFCNT_dec(namesv);
508         }
509         else if (realtype == SVt_PVGV) {                     /* glob ref */
510             SV * const namesv = newSVpvn("*{", 2);
511             sv_catpvn(namesv, name, namelen);
512             sv_catpvn(namesv, "}", 1);
513             sv_catpvn(retval, "\\", 1);
514             DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
515                     postav, levelp,     indent, pad, xpad, apad, sep, pair,
516                     freezer, toaster, purity, deepcopy, quotekeys, bless,
517                     maxdepth, sortkeys, use_sparse_seen_hash);
518             SvREFCNT_dec(namesv);
519         }
520         else if (realtype == SVt_PVAV) {
521             SV *totpad;
522             I32 ix = 0;
523             const I32 ixmax = av_len((AV *)ival);
524         
525             SV * const ixsv = newSViv(0);
526             /* allowing for a 24 char wide array index */
527             New(0, iname, namelen+28, char);
528             (void)strcpy(iname, name);
529             inamelen = namelen;
530             if (name[0] == '@') {
531                 sv_catpvn(retval, "(", 1);
532                 iname[0] = '$';
533             }
534             else {
535                 sv_catpvn(retval, "[", 1);
536                 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
537                 /*if (namelen > 0
538                     && name[namelen-1] != ']' && name[namelen-1] != '}'
539                     && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
540                 if ((namelen > 0
541                      && name[namelen-1] != ']' && name[namelen-1] != '}')
542                     || (namelen > 4
543                         && (name[1] == '{'
544                             || (name[0] == '\\' && name[2] == '{'))))
545                 {
546                     iname[inamelen++] = '-'; iname[inamelen++] = '>';
547                     iname[inamelen] = '\0';
548                 }
549             }
550             if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
551                 (instr(iname+inamelen-8, "{SCALAR}") ||
552                  instr(iname+inamelen-7, "{ARRAY}") ||
553                  instr(iname+inamelen-6, "{HASH}"))) {
554                 iname[inamelen++] = '-'; iname[inamelen++] = '>';
555             }
556             iname[inamelen++] = '['; iname[inamelen] = '\0';
557             totpad = newSVsv(sep);
558             sv_catsv(totpad, pad);
559             sv_catsv(totpad, apad);
560
561             for (ix = 0; ix <= ixmax; ++ix) {
562                 STRLEN ilen;
563                 SV *elem;
564                 svp = av_fetch((AV*)ival, ix, FALSE);
565                 if (svp)
566                     elem = *svp;
567                 else
568                     elem = &PL_sv_undef;
569                 
570                 ilen = inamelen;
571                 sv_setiv(ixsv, ix);
572 #if PERL_VERSION < 10
573                 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
574                 ilen = strlen(iname);
575 #else
576                 ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
577 #endif
578                 iname[ilen++] = ']'; iname[ilen] = '\0';
579                 if (indent >= 3) {
580                     sv_catsv(retval, totpad);
581                     sv_catsv(retval, ipad);
582                     sv_catpvn(retval, "#", 1);
583                     sv_catsv(retval, ixsv);
584                 }
585                 sv_catsv(retval, totpad);
586                 sv_catsv(retval, ipad);
587                 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
588                         levelp, indent, pad, xpad, apad, sep, pair,
589                         freezer, toaster, purity, deepcopy, quotekeys, bless,
590                         maxdepth, sortkeys, use_sparse_seen_hash);
591                 if (ix < ixmax)
592                     sv_catpvn(retval, ",", 1);
593             }
594             if (ixmax >= 0) {
595                 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
596                 sv_catsv(retval, totpad);
597                 sv_catsv(retval, opad);
598                 SvREFCNT_dec(opad);
599             }
600             if (name[0] == '@')
601                 sv_catpvn(retval, ")", 1);
602             else
603                 sv_catpvn(retval, "]", 1);
604             SvREFCNT_dec(ixsv);
605             SvREFCNT_dec(totpad);
606             Safefree(iname);
607         }
608         else if (realtype == SVt_PVHV) {
609             SV *totpad, *newapad;
610             SV *sname;
611             HE *entry;
612             char *key;
613             I32 klen;
614             SV *hval;
615             AV *keys = NULL;
616         
617             SV * const iname = newSVpvn(name, namelen);
618             if (name[0] == '%') {
619                 sv_catpvn(retval, "(", 1);
620                 (SvPVX(iname))[0] = '$';
621             }
622             else {
623                 sv_catpvn(retval, "{", 1);
624                 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
625                 if ((namelen > 0
626                      && name[namelen-1] != ']' && name[namelen-1] != '}')
627                     || (namelen > 4
628                         && (name[1] == '{'
629                             || (name[0] == '\\' && name[2] == '{'))))
630                 {
631                     sv_catpvn(iname, "->", 2);
632                 }
633             }
634             if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
635                 (instr(name+namelen-8, "{SCALAR}") ||
636                  instr(name+namelen-7, "{ARRAY}") ||
637                  instr(name+namelen-6, "{HASH}"))) {
638                 sv_catpvn(iname, "->", 2);
639             }
640             sv_catpvn(iname, "{", 1);
641             totpad = newSVsv(sep);
642             sv_catsv(totpad, pad);
643             sv_catsv(totpad, apad);
644         
645             /* If requested, get a sorted/filtered array of hash keys */
646             if (sortkeys) {
647                 if (sortkeys == &PL_sv_yes) {
648 #if PERL_VERSION < 8
649                     sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
650 #else
651                     keys = newAV();
652                     (void)hv_iterinit((HV*)ival);
653                     while ((entry = hv_iternext((HV*)ival))) {
654                         sv = hv_iterkeysv(entry);
655                         (void)SvREFCNT_inc(sv);
656                         av_push(keys, sv);
657                     }
658 # ifdef USE_LOCALE_NUMERIC
659                     sortsv(AvARRAY(keys), 
660                            av_len(keys)+1, 
661                            IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
662 # else
663                     sortsv(AvARRAY(keys), 
664                            av_len(keys)+1, 
665                            Perl_sv_cmp);
666 # endif
667 #endif
668                 }
669                 if (sortkeys != &PL_sv_yes) {
670                     dSP; ENTER; SAVETMPS; PUSHMARK(sp);
671                     XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
672                     i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
673                     SPAGAIN;
674                     if (i) {
675                         sv = POPs;
676                         if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
677                             keys = (AV*)SvREFCNT_inc(SvRV(sv));
678                     }
679                     if (! keys)
680                         warn("Sortkeys subroutine did not return ARRAYREF\n");
681                     PUTBACK; FREETMPS; LEAVE;
682                 }
683                 if (keys)
684                     sv_2mortal((SV*)keys);
685             }
686             else
687                 (void)hv_iterinit((HV*)ival);
688
689             /* foreach (keys %hash) */
690             for (i = 0; 1; i++) {
691                 char *nkey;
692                 char *nkey_buffer = NULL;
693                 I32 nticks = 0;
694                 SV* keysv;
695                 STRLEN keylen;
696                 I32 nlen;
697                 bool do_utf8 = FALSE;
698
699                if (sortkeys) {
700                    if (!(keys && (I32)i <= av_len(keys))) break;
701                } else {
702                    if (!(entry = hv_iternext((HV *)ival))) break;
703                }
704
705                 if (i)
706                     sv_catpvn(retval, ",", 1);
707
708                 if (sortkeys) {
709                     char *key;
710                     svp = av_fetch(keys, i, FALSE);
711                     keysv = svp ? *svp : sv_newmortal();
712                     key = SvPV(keysv, keylen);
713                     svp = hv_fetch((HV*)ival, key,
714                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0);
715                     hval = svp ? *svp : sv_newmortal();
716                 }
717                 else {
718                     keysv = hv_iterkeysv(entry);
719                     hval = hv_iterval((HV*)ival, entry);
720                 }
721
722                 key = SvPV(keysv, keylen);
723                 do_utf8 = DO_UTF8(keysv);
724                 klen = keylen;
725
726                 sv_catsv(retval, totpad);
727                 sv_catsv(retval, ipad);
728                 /* old logic was first to check utf8 flag, and if utf8 always
729                    call esc_q_utf8.  This caused test to break under -Mutf8,
730                    because there even strings like 'c' have utf8 flag on.
731                    Hence with quotekeys == 0 the XS code would still '' quote
732                    them based on flags, whereas the perl code would not,
733                    based on regexps.
734                    The perl code is correct.
735                    needs_quote() decides that anything that isn't a valid
736                    perl identifier needs to be quoted, hence only correctly
737                    formed strings with no characters outside [A-Za-z0-9_:]
738                    won't need quoting.  None of those characters are used in
739                    the byte encoding of utf8, so anything with utf8
740                    encoded characters in will need quoting. Hence strings
741                    with utf8 encoded characters in will end up inside do_utf8
742                    just like before, but now strings with utf8 flag set but
743                    only ascii characters will end up in the unquoted section.
744
745                    There should also be less tests for the (probably currently)
746                    more common doesn't need quoting case.
747                    The code is also smaller (22044 vs 22260) because I've been
748                    able to pull the common logic out to both sides.  */
749                 if (quotekeys || needs_quote(key,keylen)) {
750                     if (do_utf8) {
751                         STRLEN ocur = SvCUR(retval);
752                         nlen = esc_q_utf8(aTHX_ retval, key, klen);
753                         nkey = SvPVX(retval) + ocur;
754                     }
755                     else {
756                         nticks = num_q(key, klen);
757                         New(0, nkey_buffer, klen+nticks+3, char);
758                         nkey = nkey_buffer;
759                         nkey[0] = '\'';
760                         if (nticks)
761                             klen += esc_q(nkey+1, key, klen);
762                         else
763                             (void)Copy(key, nkey+1, klen, char);
764                         nkey[++klen] = '\'';
765                         nkey[++klen] = '\0';
766                         nlen = klen;
767                         sv_catpvn(retval, nkey, klen);
768                     }
769                 }
770                 else {
771                     nkey = key;
772                     nlen = klen;
773                     sv_catpvn(retval, nkey, klen);
774                 }
775                 sname = newSVsv(iname);
776                 sv_catpvn(sname, nkey, nlen);
777                 sv_catpvn(sname, "}", 1);
778
779                 sv_catsv(retval, pair);
780                 if (indent >= 2) {
781                     char *extra;
782                     I32 elen = 0;
783                     newapad = newSVsv(apad);
784                     New(0, extra, klen+4+1, char);
785                     while (elen < (klen+4))
786                         extra[elen++] = ' ';
787                     extra[elen] = '\0';
788                     sv_catpvn(newapad, extra, elen);
789                     Safefree(extra);
790                 }
791                 else
792                     newapad = apad;
793
794                 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
795                         postav, levelp, indent, pad, xpad, newapad, sep, pair,
796                         freezer, toaster, purity, deepcopy, quotekeys, bless,
797                         maxdepth, sortkeys, use_sparse_seen_hash);
798                 SvREFCNT_dec(sname);
799                 Safefree(nkey_buffer);
800                 if (indent >= 2)
801                     SvREFCNT_dec(newapad);
802             }
803             if (i) {
804                 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
805                 sv_catsv(retval, totpad);
806                 sv_catsv(retval, opad);
807                 SvREFCNT_dec(opad);
808             }
809             if (name[0] == '%')
810                 sv_catpvn(retval, ")", 1);
811             else
812                 sv_catpvn(retval, "}", 1);
813             SvREFCNT_dec(iname);
814             SvREFCNT_dec(totpad);
815         }
816         else if (realtype == SVt_PVCV) {
817             sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
818             if (purity)
819                 warn("Encountered CODE ref, using dummy placeholder");
820         }
821         else {
822             warn("cannot handle ref type %d", (int)realtype);
823         }
824
825         if (realpack && !no_bless) {  /* free blessed allocs */
826             I32 plen;
827             I32 pticks;
828
829             if (indent >= 2) {
830                 SvREFCNT_dec(apad);
831                 apad = blesspad;
832             }
833             sv_catpvn(retval, ", '", 3);
834
835             plen = strlen(realpack);
836             pticks = num_q(realpack, plen);
837             if (pticks) { /* needs escaping */
838                 char *npack;
839                 char *npack_buffer = NULL;
840
841                 New(0, npack_buffer, plen+pticks+1, char);
842                 npack = npack_buffer;
843                 plen += esc_q(npack, realpack, plen);
844                 npack[plen] = '\0';
845
846                 sv_catpvn(retval, npack, plen);
847                 Safefree(npack_buffer);
848             }
849             else {
850                 sv_catpvn(retval, realpack, strlen(realpack));
851             }
852             sv_catpvn(retval, "' )", 3);
853             if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
854                 sv_catpvn(retval, "->", 2);
855                 sv_catsv(retval, toaster);
856                 sv_catpvn(retval, "()", 2);
857             }
858         }
859         SvREFCNT_dec(ipad);
860         (*levelp)--;
861     }
862     else {
863         STRLEN i;
864         const MAGIC *mg;
865         
866         if (namelen) {
867 #ifdef DD_USE_OLD_ID_FORMAT
868             idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
869 #else
870             id_buffer = PTR2UV(val);
871             idlen = sizeof(id_buffer);
872 #endif
873             if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
874                 (sv = *svp) && SvROK(sv) &&
875                 (seenentry = (AV*)SvRV(sv)))
876             {
877                 SV *othername;
878                 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
879                     && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
880                 {
881                     sv_catpvn(retval, "${", 2);
882                     sv_catsv(retval, othername);
883                     sv_catpvn(retval, "}", 1);
884                     return 1;
885                 }
886             }
887             /* If we're allowed to keep only a sparse "seen" hash
888              * (IOW, the user does not expect it to contain everything
889              * after the dump, then only store in seen hash if the SV
890              * ref count is larger than 1. If it's 1, then we know that
891              * there is no other reference, duh. This is an optimization. */
892             else if (val != &PL_sv_undef && (!use_sparse_seen_hash || SvREFCNT(val) > 1)) {
893                 SV * const namesv = newSVpvn("\\", 1);
894                 sv_catpvn(namesv, name, namelen);
895                 seenentry = newAV();
896                 av_push(seenentry, namesv);
897                 av_push(seenentry, newRV_inc(val));
898                 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
899                 SvREFCNT_dec(seenentry);
900             }
901         }
902
903         if (DD_is_integer(val)) {
904             STRLEN len;
905             if (SvIsUV(val))
906               len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
907             else
908               len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
909             if (SvPOK(val)) {
910               /* Need to check to see if this is a string such as " 0".
911                  I'm assuming from sprintf isn't going to clash with utf8.
912                  Is this valid on EBCDIC?  */
913               STRLEN pvlen;
914               const char * const pv = SvPV(val, pvlen);
915               if (pvlen != len || memNE(pv, tmpbuf, len))
916                 goto integer_came_from_string;
917             }
918             if (len > 10) {
919               /* Looks like we're on a 64 bit system.  Make it a string so that
920                  if a 32 bit system reads the number it will cope better.  */
921               sv_catpvf(retval, "'%s'", tmpbuf);
922             } else
923               sv_catpvn(retval, tmpbuf, len);
924         }
925         else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
926             c = SvPV(val, i);
927             if(i) ++c, --i;                     /* just get the name */
928             if (i >= 6 && strncmp(c, "main::", 6) == 0) {
929                 c += 4;
930 #if PERL_VERSION < 7
931                 if (i == 6 || (i == 7 && c[6] == '\0'))
932 #else
933                 if (i == 6)
934 #endif
935                     i = 0; else i -= 4;
936             }
937             if (needs_quote(c,i)) {
938 #ifdef GvNAMEUTF8
939               if (GvNAMEUTF8(val)) {
940                 sv_grow(retval, SvCUR(retval)+2);
941                 r = SvPVX(retval)+SvCUR(retval);
942                 r[0] = '*'; r[1] = '{';
943                 SvCUR_set(retval, SvCUR(retval)+2);
944                 esc_q_utf8(aTHX_ retval, c, i);
945                 sv_grow(retval, SvCUR(retval)+2);
946                 r = SvPVX(retval)+SvCUR(retval);
947                 r[0] = '}'; r[1] = '\0';
948                 i = 1;
949               }
950               else
951 #endif
952               {
953                 sv_grow(retval, SvCUR(retval)+6+2*i);
954                 r = SvPVX(retval)+SvCUR(retval);
955                 r[0] = '*'; r[1] = '{'; r[2] = '\'';
956                 i += esc_q(r+3, c, i);
957                 i += 3;
958                 r[i++] = '\''; r[i++] = '}';
959                 r[i] = '\0';
960               }
961             }
962             else {
963                 sv_grow(retval, SvCUR(retval)+i+2);
964                 r = SvPVX(retval)+SvCUR(retval);
965                 r[0] = '*'; strcpy(r+1, c);
966                 i++;
967             }
968             SvCUR_set(retval, SvCUR(retval)+i);
969
970             if (purity) {
971                 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
972                 static const STRLEN sizes[] = { 8, 7, 6 };
973                 SV *e;
974                 SV * const nname = newSVpvn("", 0);
975                 SV * const newapad = newSVpvn("", 0);
976                 GV * const gv = (GV*)val;
977                 I32 j;
978                 
979                 for (j=0; j<3; j++) {
980                     e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
981                     if (!e)
982                         continue;
983                     if (j == 0 && !SvOK(e))
984                         continue;
985
986                     {
987                         I32 nlevel = 0;
988                         SV *postentry = newSVpvn(r,i);
989                         
990                         sv_setsv(nname, postentry);
991                         sv_catpvn(nname, entries[j], sizes[j]);
992                         sv_catpvn(postentry, " = ", 3);
993                         av_push(postav, postentry);
994                         e = newRV_inc(e);
995                         
996                         SvCUR_set(newapad, 0);
997                         if (indent >= 2)
998                             (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
999                         
1000                         DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
1001                                 seenhv, postav, &nlevel, indent, pad, xpad,
1002                                 newapad, sep, pair, freezer, toaster, purity,
1003                                 deepcopy, quotekeys, bless, maxdepth, 
1004                                 sortkeys, use_sparse_seen_hash);
1005                         SvREFCNT_dec(e);
1006                     }
1007                 }
1008                 
1009                 SvREFCNT_dec(newapad);
1010                 SvREFCNT_dec(nname);
1011             }
1012         }
1013         else if (val == &PL_sv_undef || !SvOK(val)) {
1014             sv_catpvn(retval, "undef", 5);
1015         }
1016 #ifdef SvVOK
1017         else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) {
1018 # if !defined(PL_vtbl_vstring) && PERL_VERSION < 17
1019             SV * const vecsv = sv_newmortal();
1020 #  if PERL_VERSION < 10
1021             scan_vstring(mg->mg_ptr, vecsv);
1022 #  else
1023             scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
1024 #  endif
1025             if (!sv_eq(vecsv, val)) goto integer_came_from_string;
1026 # endif
1027             sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len);
1028         }
1029 #endif
1030         else {
1031         integer_came_from_string:
1032             c = SvPV(val, i);
1033             if (DO_UTF8(val))
1034                 i += esc_q_utf8(aTHX_ retval, c, i);
1035             else {
1036                 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
1037                 r = SvPVX(retval) + SvCUR(retval);
1038                 r[0] = '\'';
1039                 i += esc_q(r+1, c, i);
1040                 ++i;
1041                 r[i++] = '\'';
1042                 r[i] = '\0';
1043                 SvCUR_set(retval, SvCUR(retval)+i);
1044             }
1045         }
1046     }
1047
1048     if (idlen) {
1049         if (deepcopy)
1050             (void)hv_delete(seenhv, id, idlen, G_DISCARD);
1051         else if (namelen && seenentry) {
1052             SV *mark = *av_fetch(seenentry, 2, TRUE);
1053             sv_setiv(mark,1);
1054         }
1055     }
1056     return 1;
1057 }
1058
1059
1060 MODULE = Data::Dumper           PACKAGE = Data::Dumper         PREFIX = Data_Dumper_
1061
1062 #
1063 # This is the exact equivalent of Dump.  Well, almost. The things that are
1064 # different as of now (due to Laziness):
1065 #   * doesn't do double-quotes yet.
1066 #
1067
1068 void
1069 Data_Dumper_Dumpxs(href, ...)
1070         SV      *href;
1071         PROTOTYPE: $;$$
1072         PPCODE:
1073         {
1074             HV *hv;
1075             SV *retval, *valstr;
1076             HV *seenhv = NULL;
1077             AV *postav, *todumpav, *namesav;
1078             I32 level = 0;
1079             I32 indent, terse, i, imax, postlen;
1080             SV **svp;
1081             SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
1082             SV *freezer, *toaster, *bless, *sortkeys;
1083             I32 purity, deepcopy, quotekeys, maxdepth = 0;
1084             char tmpbuf[1024];
1085             I32 gimme = GIMME;
1086             int use_sparse_seen_hash = 0;
1087
1088             if (!SvROK(href)) {         /* call new to get an object first */
1089                 if (items < 2)
1090                     croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
1091                 
1092                 ENTER;
1093                 SAVETMPS;
1094                 
1095                 PUSHMARK(sp);
1096                 XPUSHs(href);
1097                 XPUSHs(sv_2mortal(newSVsv(ST(1))));
1098                 if (items >= 3)
1099                     XPUSHs(sv_2mortal(newSVsv(ST(2))));
1100                 PUTBACK;
1101                 i = perl_call_method("new", G_SCALAR);
1102                 SPAGAIN;
1103                 if (i)
1104                     href = newSVsv(POPs);
1105
1106                 PUTBACK;
1107                 FREETMPS;
1108                 LEAVE;
1109                 if (i)
1110                     (void)sv_2mortal(href);
1111             }
1112
1113             todumpav = namesav = NULL;
1114             seenhv = NULL;
1115             val = pad = xpad = apad = sep = pair = varname
1116                 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
1117             name = sv_newmortal();
1118             indent = 2;
1119             terse = purity = deepcopy = 0;
1120             quotekeys = 1;
1121         
1122             retval = newSVpvn("", 0);
1123             if (SvROK(href)
1124                 && (hv = (HV*)SvRV((SV*)href))
1125                 && SvTYPE(hv) == SVt_PVHV)              {
1126
1127                 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1128                     seenhv = (HV*)SvRV(*svp);
1129                 else
1130                     use_sparse_seen_hash = 1;
1131                 if ((svp = hv_fetch(hv, "noseen", 6, FALSE)))
1132                     use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0);
1133                 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1134                     todumpav = (AV*)SvRV(*svp);
1135                 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1136                     namesav = (AV*)SvRV(*svp);
1137                 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1138                     indent = SvIV(*svp);
1139                 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1140                     purity = SvIV(*svp);
1141                 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1142                     terse = SvTRUE(*svp);
1143 #if 0 /* useqq currently unused */
1144                 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1145                     useqq = SvTRUE(*svp);
1146 #endif
1147                 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1148                     pad = *svp;
1149                 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1150                     xpad = *svp;
1151                 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1152                     apad = *svp;
1153                 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1154                     sep = *svp;
1155                 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1156                     pair = *svp;
1157                 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1158                     varname = *svp;
1159                 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1160                     freezer = *svp;
1161                 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1162                     toaster = *svp;
1163                 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1164                     deepcopy = SvTRUE(*svp);
1165                 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1166                     quotekeys = SvTRUE(*svp);
1167                 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1168                     bless = *svp;
1169                 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1170                     maxdepth = SvIV(*svp);
1171                 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1172                     sortkeys = *svp;
1173                     if (! SvTRUE(sortkeys))
1174                         sortkeys = NULL;
1175                     else if (! (SvROK(sortkeys) &&
1176                                 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1177                     {
1178                         /* flag to use qsortsv() for sorting hash keys */       
1179                         sortkeys = &PL_sv_yes; 
1180                     }
1181                 }
1182                 postav = newAV();
1183
1184                 if (todumpav)
1185                     imax = av_len(todumpav);
1186                 else
1187                     imax = -1;
1188                 valstr = newSVpvn("",0);
1189                 for (i = 0; i <= imax; ++i) {
1190                     SV *newapad;
1191                 
1192                     av_clear(postav);
1193                     if ((svp = av_fetch(todumpav, i, FALSE)))
1194                         val = *svp;
1195                     else
1196                         val = &PL_sv_undef;
1197                     if ((svp = av_fetch(namesav, i, TRUE))) {
1198                         sv_setsv(name, *svp);
1199                         if (SvOK(*svp) && !SvPOK(*svp))
1200                             (void)SvPV_nolen_const(name);
1201                     }
1202                     else
1203                         (void)SvOK_off(name);
1204                 
1205                     if (SvPOK(name)) {
1206                         if ((SvPVX_const(name))[0] == '*') {
1207                             if (SvROK(val)) {
1208                                 switch (SvTYPE(SvRV(val))) {
1209                                 case SVt_PVAV:
1210                                     (SvPVX(name))[0] = '@';
1211                                     break;
1212                                 case SVt_PVHV:
1213                                     (SvPVX(name))[0] = '%';
1214                                     break;
1215                                 case SVt_PVCV:
1216                                     (SvPVX(name))[0] = '*';
1217                                     break;
1218                                 default:
1219                                     (SvPVX(name))[0] = '$';
1220                                     break;
1221                                 }
1222                             }
1223                             else
1224                                 (SvPVX(name))[0] = '$';
1225                         }
1226                         else if ((SvPVX_const(name))[0] != '$')
1227                             sv_insert(name, 0, 0, "$", 1);
1228                     }
1229                     else {
1230                         STRLEN nchars;
1231                         sv_setpvn(name, "$", 1);
1232                         sv_catsv(name, varname);
1233                         nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
1234                         sv_catpvn(name, tmpbuf, nchars);
1235                     }
1236                 
1237                     if (indent >= 2 && !terse) {
1238                         SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1239                         newapad = newSVsv(apad);
1240                         sv_catsv(newapad, tmpsv);
1241                         SvREFCNT_dec(tmpsv);
1242                     }
1243                     else
1244                         newapad = apad;
1245                 
1246                     PUTBACK;
1247                     DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1248                             postav, &level, indent, pad, xpad, newapad, sep, pair,
1249                             freezer, toaster, purity, deepcopy, quotekeys,
1250                             bless, maxdepth, sortkeys, use_sparse_seen_hash);
1251                     SPAGAIN;
1252                 
1253                     if (indent >= 2 && !terse)
1254                         SvREFCNT_dec(newapad);
1255
1256                     postlen = av_len(postav);
1257                     if (postlen >= 0 || !terse) {
1258                         sv_insert(valstr, 0, 0, " = ", 3);
1259                         sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1260                         sv_catpvn(valstr, ";", 1);
1261                     }
1262                     sv_catsv(retval, pad);
1263                     sv_catsv(retval, valstr);
1264                     sv_catsv(retval, sep);
1265                     if (postlen >= 0) {
1266                         I32 i;
1267                         sv_catsv(retval, pad);
1268                         for (i = 0; i <= postlen; ++i) {
1269                             SV *elem;
1270                             svp = av_fetch(postav, i, FALSE);
1271                             if (svp && (elem = *svp)) {
1272                                 sv_catsv(retval, elem);
1273                                 if (i < postlen) {
1274                                     sv_catpvn(retval, ";", 1);
1275                                     sv_catsv(retval, sep);
1276                                     sv_catsv(retval, pad);
1277                                 }
1278                             }
1279                         }
1280                         sv_catpvn(retval, ";", 1);
1281                             sv_catsv(retval, sep);
1282                     }
1283                     sv_setpvn(valstr, "", 0);
1284                     if (gimme == G_ARRAY) {
1285                         XPUSHs(sv_2mortal(retval));
1286                         if (i < imax)   /* not the last time thro ? */
1287                             retval = newSVpvn("",0);
1288                     }
1289                 }
1290                 SvREFCNT_dec(postav);
1291                 SvREFCNT_dec(valstr);
1292             }
1293             else
1294                 croak("Call to new() method failed to return HASH ref");
1295             if (gimme == G_SCALAR)
1296                 XPUSHs(sv_2mortal(retval));
1297         }
1298
1299 SV *
1300 Data_Dumper__vstring(sv)
1301         SV      *sv;
1302         PROTOTYPE: $
1303         CODE:
1304         {
1305 #ifdef SvVOK
1306             const MAGIC *mg;
1307             RETVAL =
1308                 SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))
1309                  ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len)
1310                  : &PL_sv_undef;
1311 #else
1312             RETVAL = &PL_sv_undef;
1313 #endif
1314         }
1315         OUTPUT: RETVAL