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