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