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