This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Data::Dumper: Comment on previous optimization
[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              * Note that we'd have to check for weak-refs, too, but this is
893              * already the branch for non-refs only. */
894             else if (val != &PL_sv_undef && (!use_sparse_seen_hash || SvREFCNT(val) > 1)) {
895                 SV * const namesv = newSVpvn("\\", 1);
896                 sv_catpvn(namesv, name, namelen);
897                 seenentry = newAV();
898                 av_push(seenentry, namesv);
899                 av_push(seenentry, newRV_inc(val));
900                 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
901                 SvREFCNT_dec(seenentry);
902             }
903         }
904
905         if (DD_is_integer(val)) {
906             STRLEN len;
907             if (SvIsUV(val))
908               len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
909             else
910               len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
911             if (SvPOK(val)) {
912               /* Need to check to see if this is a string such as " 0".
913                  I'm assuming from sprintf isn't going to clash with utf8.
914                  Is this valid on EBCDIC?  */
915               STRLEN pvlen;
916               const char * const pv = SvPV(val, pvlen);
917               if (pvlen != len || memNE(pv, tmpbuf, len))
918                 goto integer_came_from_string;
919             }
920             if (len > 10) {
921               /* Looks like we're on a 64 bit system.  Make it a string so that
922                  if a 32 bit system reads the number it will cope better.  */
923               sv_catpvf(retval, "'%s'", tmpbuf);
924             } else
925               sv_catpvn(retval, tmpbuf, len);
926         }
927         else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
928             c = SvPV(val, i);
929             if(i) ++c, --i;                     /* just get the name */
930             if (i >= 6 && strncmp(c, "main::", 6) == 0) {
931                 c += 4;
932 #if PERL_VERSION < 7
933                 if (i == 6 || (i == 7 && c[6] == '\0'))
934 #else
935                 if (i == 6)
936 #endif
937                     i = 0; else i -= 4;
938             }
939             if (needs_quote(c,i)) {
940 #ifdef GvNAMEUTF8
941               if (GvNAMEUTF8(val)) {
942                 sv_grow(retval, SvCUR(retval)+2);
943                 r = SvPVX(retval)+SvCUR(retval);
944                 r[0] = '*'; r[1] = '{';
945                 SvCUR_set(retval, SvCUR(retval)+2);
946                 esc_q_utf8(aTHX_ retval, c, i);
947                 sv_grow(retval, SvCUR(retval)+2);
948                 r = SvPVX(retval)+SvCUR(retval);
949                 r[0] = '}'; r[1] = '\0';
950                 i = 1;
951               }
952               else
953 #endif
954               {
955                 sv_grow(retval, SvCUR(retval)+6+2*i);
956                 r = SvPVX(retval)+SvCUR(retval);
957                 r[0] = '*'; r[1] = '{'; r[2] = '\'';
958                 i += esc_q(r+3, c, i);
959                 i += 3;
960                 r[i++] = '\''; r[i++] = '}';
961                 r[i] = '\0';
962               }
963             }
964             else {
965                 sv_grow(retval, SvCUR(retval)+i+2);
966                 r = SvPVX(retval)+SvCUR(retval);
967                 r[0] = '*'; strcpy(r+1, c);
968                 i++;
969             }
970             SvCUR_set(retval, SvCUR(retval)+i);
971
972             if (purity) {
973                 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
974                 static const STRLEN sizes[] = { 8, 7, 6 };
975                 SV *e;
976                 SV * const nname = newSVpvn("", 0);
977                 SV * const newapad = newSVpvn("", 0);
978                 GV * const gv = (GV*)val;
979                 I32 j;
980                 
981                 for (j=0; j<3; j++) {
982                     e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
983                     if (!e)
984                         continue;
985                     if (j == 0 && !SvOK(e))
986                         continue;
987
988                     {
989                         I32 nlevel = 0;
990                         SV *postentry = newSVpvn(r,i);
991                         
992                         sv_setsv(nname, postentry);
993                         sv_catpvn(nname, entries[j], sizes[j]);
994                         sv_catpvn(postentry, " = ", 3);
995                         av_push(postav, postentry);
996                         e = newRV_inc(e);
997                         
998                         SvCUR_set(newapad, 0);
999                         if (indent >= 2)
1000                             (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
1001                         
1002                         DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
1003                                 seenhv, postav, &nlevel, indent, pad, xpad,
1004                                 newapad, sep, pair, freezer, toaster, purity,
1005                                 deepcopy, quotekeys, bless, maxdepth, 
1006                                 sortkeys, use_sparse_seen_hash);
1007                         SvREFCNT_dec(e);
1008                     }
1009                 }
1010                 
1011                 SvREFCNT_dec(newapad);
1012                 SvREFCNT_dec(nname);
1013             }
1014         }
1015         else if (val == &PL_sv_undef || !SvOK(val)) {
1016             sv_catpvn(retval, "undef", 5);
1017         }
1018 #ifdef SvVOK
1019         else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) {
1020 # if !defined(PL_vtbl_vstring) && PERL_VERSION < 17
1021             SV * const vecsv = sv_newmortal();
1022 #  if PERL_VERSION < 10
1023             scan_vstring(mg->mg_ptr, vecsv);
1024 #  else
1025             scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
1026 #  endif
1027             if (!sv_eq(vecsv, val)) goto integer_came_from_string;
1028 # endif
1029             sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len);
1030         }
1031 #endif
1032         else {
1033         integer_came_from_string:
1034             c = SvPV(val, i);
1035             if (DO_UTF8(val))
1036                 i += esc_q_utf8(aTHX_ retval, c, i);
1037             else {
1038                 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
1039                 r = SvPVX(retval) + SvCUR(retval);
1040                 r[0] = '\'';
1041                 i += esc_q(r+1, c, i);
1042                 ++i;
1043                 r[i++] = '\'';
1044                 r[i] = '\0';
1045                 SvCUR_set(retval, SvCUR(retval)+i);
1046             }
1047         }
1048     }
1049
1050     if (idlen) {
1051         if (deepcopy)
1052             (void)hv_delete(seenhv, id, idlen, G_DISCARD);
1053         else if (namelen && seenentry) {
1054             SV *mark = *av_fetch(seenentry, 2, TRUE);
1055             sv_setiv(mark,1);
1056         }
1057     }
1058     return 1;
1059 }
1060
1061
1062 MODULE = Data::Dumper           PACKAGE = Data::Dumper         PREFIX = Data_Dumper_
1063
1064 #
1065 # This is the exact equivalent of Dump.  Well, almost. The things that are
1066 # different as of now (due to Laziness):
1067 #   * doesn't do double-quotes yet.
1068 #
1069
1070 void
1071 Data_Dumper_Dumpxs(href, ...)
1072         SV      *href;
1073         PROTOTYPE: $;$$
1074         PPCODE:
1075         {
1076             HV *hv;
1077             SV *retval, *valstr;
1078             HV *seenhv = NULL;
1079             AV *postav, *todumpav, *namesav;
1080             I32 level = 0;
1081             I32 indent, terse, i, imax, postlen;
1082             SV **svp;
1083             SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
1084             SV *freezer, *toaster, *bless, *sortkeys;
1085             I32 purity, deepcopy, quotekeys, maxdepth = 0;
1086             char tmpbuf[1024];
1087             I32 gimme = GIMME;
1088             int use_sparse_seen_hash = 0;
1089
1090             if (!SvROK(href)) {         /* call new to get an object first */
1091                 if (items < 2)
1092                     croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
1093                 
1094                 ENTER;
1095                 SAVETMPS;
1096                 
1097                 PUSHMARK(sp);
1098                 XPUSHs(href);
1099                 XPUSHs(sv_2mortal(newSVsv(ST(1))));
1100                 if (items >= 3)
1101                     XPUSHs(sv_2mortal(newSVsv(ST(2))));
1102                 PUTBACK;
1103                 i = perl_call_method("new", G_SCALAR);
1104                 SPAGAIN;
1105                 if (i)
1106                     href = newSVsv(POPs);
1107
1108                 PUTBACK;
1109                 FREETMPS;
1110                 LEAVE;
1111                 if (i)
1112                     (void)sv_2mortal(href);
1113             }
1114
1115             todumpav = namesav = NULL;
1116             seenhv = NULL;
1117             val = pad = xpad = apad = sep = pair = varname
1118                 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
1119             name = sv_newmortal();
1120             indent = 2;
1121             terse = purity = deepcopy = 0;
1122             quotekeys = 1;
1123         
1124             retval = newSVpvn("", 0);
1125             if (SvROK(href)
1126                 && (hv = (HV*)SvRV((SV*)href))
1127                 && SvTYPE(hv) == SVt_PVHV)              {
1128
1129                 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1130                     seenhv = (HV*)SvRV(*svp);
1131                 else
1132                     use_sparse_seen_hash = 1;
1133                 if ((svp = hv_fetch(hv, "noseen", 6, FALSE)))
1134                     use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0);
1135                 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1136                     todumpav = (AV*)SvRV(*svp);
1137                 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1138                     namesav = (AV*)SvRV(*svp);
1139                 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1140                     indent = SvIV(*svp);
1141                 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1142                     purity = SvIV(*svp);
1143                 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1144                     terse = SvTRUE(*svp);
1145 #if 0 /* useqq currently unused */
1146                 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1147                     useqq = SvTRUE(*svp);
1148 #endif
1149                 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1150                     pad = *svp;
1151                 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1152                     xpad = *svp;
1153                 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1154                     apad = *svp;
1155                 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1156                     sep = *svp;
1157                 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1158                     pair = *svp;
1159                 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1160                     varname = *svp;
1161                 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1162                     freezer = *svp;
1163                 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1164                     toaster = *svp;
1165                 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1166                     deepcopy = SvTRUE(*svp);
1167                 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1168                     quotekeys = SvTRUE(*svp);
1169                 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1170                     bless = *svp;
1171                 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1172                     maxdepth = SvIV(*svp);
1173                 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1174                     sortkeys = *svp;
1175                     if (! SvTRUE(sortkeys))
1176                         sortkeys = NULL;
1177                     else if (! (SvROK(sortkeys) &&
1178                                 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1179                     {
1180                         /* flag to use qsortsv() for sorting hash keys */       
1181                         sortkeys = &PL_sv_yes; 
1182                     }
1183                 }
1184                 postav = newAV();
1185
1186                 if (todumpav)
1187                     imax = av_len(todumpav);
1188                 else
1189                     imax = -1;
1190                 valstr = newSVpvn("",0);
1191                 for (i = 0; i <= imax; ++i) {
1192                     SV *newapad;
1193                 
1194                     av_clear(postav);
1195                     if ((svp = av_fetch(todumpav, i, FALSE)))
1196                         val = *svp;
1197                     else
1198                         val = &PL_sv_undef;
1199                     if ((svp = av_fetch(namesav, i, TRUE))) {
1200                         sv_setsv(name, *svp);
1201                         if (SvOK(*svp) && !SvPOK(*svp))
1202                             (void)SvPV_nolen_const(name);
1203                     }
1204                     else
1205                         (void)SvOK_off(name);
1206                 
1207                     if (SvPOK(name)) {
1208                         if ((SvPVX_const(name))[0] == '*') {
1209                             if (SvROK(val)) {
1210                                 switch (SvTYPE(SvRV(val))) {
1211                                 case SVt_PVAV:
1212                                     (SvPVX(name))[0] = '@';
1213                                     break;
1214                                 case SVt_PVHV:
1215                                     (SvPVX(name))[0] = '%';
1216                                     break;
1217                                 case SVt_PVCV:
1218                                     (SvPVX(name))[0] = '*';
1219                                     break;
1220                                 default:
1221                                     (SvPVX(name))[0] = '$';
1222                                     break;
1223                                 }
1224                             }
1225                             else
1226                                 (SvPVX(name))[0] = '$';
1227                         }
1228                         else if ((SvPVX_const(name))[0] != '$')
1229                             sv_insert(name, 0, 0, "$", 1);
1230                     }
1231                     else {
1232                         STRLEN nchars;
1233                         sv_setpvn(name, "$", 1);
1234                         sv_catsv(name, varname);
1235                         nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
1236                         sv_catpvn(name, tmpbuf, nchars);
1237                     }
1238                 
1239                     if (indent >= 2 && !terse) {
1240                         SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1241                         newapad = newSVsv(apad);
1242                         sv_catsv(newapad, tmpsv);
1243                         SvREFCNT_dec(tmpsv);
1244                     }
1245                     else
1246                         newapad = apad;
1247                 
1248                     PUTBACK;
1249                     DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1250                             postav, &level, indent, pad, xpad, newapad, sep, pair,
1251                             freezer, toaster, purity, deepcopy, quotekeys,
1252                             bless, maxdepth, sortkeys, use_sparse_seen_hash);
1253                     SPAGAIN;
1254                 
1255                     if (indent >= 2 && !terse)
1256                         SvREFCNT_dec(newapad);
1257
1258                     postlen = av_len(postav);
1259                     if (postlen >= 0 || !terse) {
1260                         sv_insert(valstr, 0, 0, " = ", 3);
1261                         sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1262                         sv_catpvn(valstr, ";", 1);
1263                     }
1264                     sv_catsv(retval, pad);
1265                     sv_catsv(retval, valstr);
1266                     sv_catsv(retval, sep);
1267                     if (postlen >= 0) {
1268                         I32 i;
1269                         sv_catsv(retval, pad);
1270                         for (i = 0; i <= postlen; ++i) {
1271                             SV *elem;
1272                             svp = av_fetch(postav, i, FALSE);
1273                             if (svp && (elem = *svp)) {
1274                                 sv_catsv(retval, elem);
1275                                 if (i < postlen) {
1276                                     sv_catpvn(retval, ";", 1);
1277                                     sv_catsv(retval, sep);
1278                                     sv_catsv(retval, pad);
1279                                 }
1280                             }
1281                         }
1282                         sv_catpvn(retval, ";", 1);
1283                             sv_catsv(retval, sep);
1284                     }
1285                     sv_setpvn(valstr, "", 0);
1286                     if (gimme == G_ARRAY) {
1287                         XPUSHs(sv_2mortal(retval));
1288                         if (i < imax)   /* not the last time thro ? */
1289                             retval = newSVpvn("",0);
1290                     }
1291                 }
1292                 SvREFCNT_dec(postav);
1293                 SvREFCNT_dec(valstr);
1294             }
1295             else
1296                 croak("Call to new() method failed to return HASH ref");
1297             if (gimme == G_SCALAR)
1298                 XPUSHs(sv_2mortal(retval));
1299         }
1300
1301 SV *
1302 Data_Dumper__vstring(sv)
1303         SV      *sv;
1304         PROTOTYPE: $
1305         CODE:
1306         {
1307 #ifdef SvVOK
1308             const MAGIC *mg;
1309             RETVAL =
1310                 SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))
1311                  ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len)
1312                  : &PL_sv_undef;
1313 #else
1314             RETVAL = &PL_sv_undef;
1315 #endif
1316         }
1317         OUTPUT: RETVAL