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