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