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