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