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