This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Data::Dumper: Fix to use with earlier Perls
[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 /* 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(register 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 (!isALNUM(*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(register const char *s, register STRLEN slen)
121 {
122     register 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(register char *d, register const char *s, register STRLEN slen)
139 {
140     register 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, register const char *src, register 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);
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                 XPUSHs(href);
1125                 XPUSHs(sv_2mortal(newSVsv(ST(1))));
1126                 if (items >= 3)
1127                     XPUSHs(sv_2mortal(newSVsv(ST(2))));
1128                 PUTBACK;
1129                 i = perl_call_method("new", G_SCALAR);
1130                 SPAGAIN;
1131                 if (i)
1132                     href = newSVsv(POPs);
1133
1134                 PUTBACK;
1135                 FREETMPS;
1136                 LEAVE;
1137                 if (i)
1138                     (void)sv_2mortal(href);
1139             }
1140
1141             todumpav = namesav = NULL;
1142             seenhv = NULL;
1143             val = pad = xpad = apad = sep = pair = varname
1144                 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
1145             name = sv_newmortal();
1146             indent = 2;
1147             terse = purity = deepcopy = 0;
1148             quotekeys = 1;
1149         
1150             retval = newSVpvn("", 0);
1151             if (SvROK(href)
1152                 && (hv = (HV*)SvRV((SV*)href))
1153                 && SvTYPE(hv) == SVt_PVHV)              {
1154
1155                 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1156                     seenhv = (HV*)SvRV(*svp);
1157                 else
1158                     use_sparse_seen_hash = 1;
1159                 if ((svp = hv_fetch(hv, "noseen", 6, FALSE)))
1160                     use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0);
1161                 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1162                     todumpav = (AV*)SvRV(*svp);
1163                 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1164                     namesav = (AV*)SvRV(*svp);
1165                 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1166                     indent = SvIV(*svp);
1167                 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1168                     purity = SvIV(*svp);
1169                 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1170                     terse = SvTRUE(*svp);
1171 #if 0 /* useqq currently unused */
1172                 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1173                     useqq = SvTRUE(*svp);
1174 #endif
1175                 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1176                     pad = *svp;
1177                 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1178                     xpad = *svp;
1179                 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1180                     apad = *svp;
1181                 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1182                     sep = *svp;
1183                 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1184                     pair = *svp;
1185                 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1186                     varname = *svp;
1187                 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1188                     freezer = *svp;
1189                 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1190                     toaster = *svp;
1191                 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1192                     deepcopy = SvTRUE(*svp);
1193                 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1194                     quotekeys = SvTRUE(*svp);
1195                 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1196                     bless = *svp;
1197                 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1198                     maxdepth = SvIV(*svp);
1199                 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1200                     sortkeys = *svp;
1201                     if (! SvTRUE(sortkeys))
1202                         sortkeys = NULL;
1203                     else if (! (SvROK(sortkeys) &&
1204                                 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1205                     {
1206                         /* flag to use qsortsv() for sorting hash keys */       
1207                         sortkeys = &PL_sv_yes; 
1208                     }
1209                 }
1210                 postav = newAV();
1211
1212                 if (todumpav)
1213                     imax = av_len(todumpav);
1214                 else
1215                     imax = -1;
1216                 valstr = newSVpvn("",0);
1217                 for (i = 0; i <= imax; ++i) {
1218                     SV *newapad;
1219                 
1220                     av_clear(postav);
1221                     if ((svp = av_fetch(todumpav, i, FALSE)))
1222                         val = *svp;
1223                     else
1224                         val = &PL_sv_undef;
1225                     if ((svp = av_fetch(namesav, i, TRUE))) {
1226                         sv_setsv(name, *svp);
1227                         if (SvOK(*svp) && !SvPOK(*svp))
1228                             (void)SvPV_nolen_const(name);
1229                     }
1230                     else
1231                         (void)SvOK_off(name);
1232                 
1233                     if (SvPOK(name)) {
1234                         if ((SvPVX_const(name))[0] == '*') {
1235                             if (SvROK(val)) {
1236                                 switch (SvTYPE(SvRV(val))) {
1237                                 case SVt_PVAV:
1238                                     (SvPVX(name))[0] = '@';
1239                                     break;
1240                                 case SVt_PVHV:
1241                                     (SvPVX(name))[0] = '%';
1242                                     break;
1243                                 case SVt_PVCV:
1244                                     (SvPVX(name))[0] = '*';
1245                                     break;
1246                                 default:
1247                                     (SvPVX(name))[0] = '$';
1248                                     break;
1249                                 }
1250                             }
1251                             else
1252                                 (SvPVX(name))[0] = '$';
1253                         }
1254                         else if ((SvPVX_const(name))[0] != '$')
1255                             sv_insert(name, 0, 0, "$", 1);
1256                     }
1257                     else {
1258                         STRLEN nchars;
1259                         sv_setpvn(name, "$", 1);
1260                         sv_catsv(name, varname);
1261                         nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
1262                         sv_catpvn(name, tmpbuf, nchars);
1263                     }
1264                 
1265                     if (indent >= 2 && !terse) {
1266                         SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1267                         newapad = newSVsv(apad);
1268                         sv_catsv(newapad, tmpsv);
1269                         SvREFCNT_dec(tmpsv);
1270                     }
1271                     else
1272                         newapad = apad;
1273                 
1274                     PUTBACK;
1275                     DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1276                             postav, &level, indent, pad, xpad, newapad, sep, pair,
1277                             freezer, toaster, purity, deepcopy, quotekeys,
1278                             bless, maxdepth, sortkeys, use_sparse_seen_hash);
1279                     SPAGAIN;
1280                 
1281                     if (indent >= 2 && !terse)
1282                         SvREFCNT_dec(newapad);
1283
1284                     postlen = av_len(postav);
1285                     if (postlen >= 0 || !terse) {
1286                         sv_insert(valstr, 0, 0, " = ", 3);
1287                         sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1288                         sv_catpvn(valstr, ";", 1);
1289                     }
1290                     sv_catsv(retval, pad);
1291                     sv_catsv(retval, valstr);
1292                     sv_catsv(retval, sep);
1293                     if (postlen >= 0) {
1294                         I32 i;
1295                         sv_catsv(retval, pad);
1296                         for (i = 0; i <= postlen; ++i) {
1297                             SV *elem;
1298                             svp = av_fetch(postav, i, FALSE);
1299                             if (svp && (elem = *svp)) {
1300                                 sv_catsv(retval, elem);
1301                                 if (i < postlen) {
1302                                     sv_catpvn(retval, ";", 1);
1303                                     sv_catsv(retval, sep);
1304                                     sv_catsv(retval, pad);
1305                                 }
1306                             }
1307                         }
1308                         sv_catpvn(retval, ";", 1);
1309                             sv_catsv(retval, sep);
1310                     }
1311                     sv_setpvn(valstr, "", 0);
1312                     if (gimme == G_ARRAY) {
1313                         XPUSHs(sv_2mortal(retval));
1314                         if (i < imax)   /* not the last time thro ? */
1315                             retval = newSVpvn("",0);
1316                     }
1317                 }
1318                 SvREFCNT_dec(postav);
1319                 SvREFCNT_dec(valstr);
1320             }
1321             else
1322                 croak("Call to new() method failed to return HASH ref");
1323             if (gimme == G_SCALAR)
1324                 XPUSHs(sv_2mortal(retval));
1325         }
1326
1327 SV *
1328 Data_Dumper__vstring(sv)
1329         SV      *sv;
1330         PROTOTYPE: $
1331         CODE:
1332         {
1333 #ifdef SvVOK
1334             const MAGIC *mg;
1335             RETVAL =
1336                 SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))
1337                  ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len)
1338                  : &PL_sv_undef;
1339 #else
1340             RETVAL = &PL_sv_undef;
1341 #endif
1342         }
1343         OUTPUT: RETVAL