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