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