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