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