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