ext/Data/Dumper/Dumper.xs

   1 #define PERL_NO_GET_CONTEXT
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 #ifndef PERL_VERSION
   7 #include "patchlevel.h"
   8 #define PERL_VERSION PATCHLEVEL
   9 #endif
  10
  11 #if PERL_VERSION < 5
  12 #  ifndef PL_sv_undef
  13 #    define PL_sv_undef sv_undef
  14 #  endif
  15 #  ifndef ERRSV
  16 #    define ERRSV       GvSV(errgv)
  17 #  endif
  18 #  ifndef newSVpvn
  19 #    define newSVpvn    newSVpv
  20 #  endif
  21 #endif
  22
  23 static I32 num_q (char *s, STRLEN slen);
  24 static I32 esc_q (char *dest, char *src, STRLEN slen);
  25 static I32 esc_q_utf8 (pTHX_ SV *sv, char *src, STRLEN slen);
  26 static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n);
  27 static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
  28                     HV *seenhv, AV *postav, I32 *levelp, I32 indent,
  29                     SV *pad, SV *xpad, SV *apad, SV *sep,
  30                     SV *freezer, SV *toaster,
  31                     I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
  32                     I32 maxdepth, SV *sortkeys);
  33
  34 /* does a string need to be protected? */
  35 static I32
  36 needs_quote(register char *s)
  37 {
  38 TOP:
  39     if (s[0] == ':') {
  40         if (*++s) {
  41             if (*s++ != ':')
  42                 return 1;
  43         }
  44         else
  45             return 1;
  46     }
  47     if (isIDFIRST(*s)) {
  48         while (*++s)
  49             if (!isALNUM(*s)) {
  50                 if (*s == ':')
  51                     goto TOP;
  52                 else
  53                     return 1;
  54             }
  55     }
  56     else
  57         return 1;
  58     return 0;
  59 }
  60
  61 /* count the number of "'"s and "\"s in string */
  62 static I32
  63 num_q(register char *s, register STRLEN slen)
  64 {
  65     register I32 ret = 0;
  66
  67     while (slen > 0) {
  68         if (*s == '\'' || *s == '\\')
  69             ++ret;
  70         ++s;
  71         --slen;
  72     }
  73     return ret;
  74 }
  75
  76
  77 /* returns number of chars added to escape "'"s and "\"s in s */
  78 /* slen number of characters in s will be escaped */
  79 /* destination must be long enough for additional chars */
  80 static I32
  81 esc_q(register char *d, register char *s, register STRLEN slen)
  82 {
  83     register I32 ret = 0;
  84
  85     while (slen > 0) {
  86         switch (*s) {
  87         case '\'':
  88         case '\\':
  89             *d = '\\';
  90             ++d; ++ret;
  91         default:
  92             *d = *s;
  93             ++d; ++s; --slen;
  94             break;
  95         }
  96     }
  97     return ret;
  98 }
  99
 100 static I32
 101 esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen)
 102 {
 103     char *s, *send, *r, *rstart;
 104     STRLEN j, cur = SvCUR(sv);
 105     /* Could count 128-255 and 256+ in two variables, if we want to
 106        be like &qquote and make a distinction.  */
 107     STRLEN grow = 0;    /* bytes needed to represent chars 128+ */
 108     /* STRLEN topbit_grow = 0;  bytes needed to represent chars 128-255 */
 109     STRLEN backslashes = 0;
 110     STRLEN single_quotes = 0;
 111     STRLEN qq_escapables = 0;   /* " $ @ will need a \ in "" strings.  */
 112     STRLEN normal = 0;
 113
 114     /* this will need EBCDICification */
 115     for (s = src, send = src + slen; s < send; s += UTF8SKIP(s)) {
 116         UV k = utf8_to_uvchr((U8*)s, NULL);
 117
 118         if (k > 127) {
 119             /* 4: \x{} then count the number of hex digits.  */
 120             grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
 121 #if UVSIZE == 4
 122                 8 /* We may allocate a bit more than the minimum here.  */
 123 #else
 124                 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
 125 #endif
 126                 );
 127         } else if (k == '\\') {
 128             backslashes++;
 129         } else if (k == '\'') {
 130             single_quotes++;
 131         } else if (k == '"' || k == '$' || k == '@') {
 132             qq_escapables++;
 133         } else {
 134             normal++;
 135         }
 136     }
 137     if (grow) {
 138         /* We have something needing hex. 3 is ""\0 */
 139         sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
 140                 + 2*qq_escapables + normal);
 141         rstart = r = SvPVX(sv) + cur;
 142
 143         *r++ = '"';
 144
 145         for (s = src; s < send; s += UTF8SKIP(s)) {
 146             UV k = utf8_to_uvchr((U8*)s, NULL);
 147
 148             if (k == '"' || k == '\\' || k == '$' || k == '@') {
 149                 *r++ = '\\';
 150                 *r++ = k;
 151             }
 152             else if (k < 0x80)
 153                 *r++ = k;
 154             else {
 155                 r += sprintf(r, "\\x{%"UVxf"}", k);
 156             }
 157         }
 158         *r++ = '"';
 159     } else {
 160         /* Single quotes.  */
 161         sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
 162                 + qq_escapables + normal);
 163         rstart = r = SvPVX(sv) + cur;
 164         *r++ = '\'';
 165         for (s = src; s < send; s ++) {
 166             char k = *s;
 167             if (k == '\'' || k == '\\')
 168                 *r++ = '\\';
 169             *r++ = k;
 170         }
 171         *r++ = '\'';
 172     }
 173     *r = '\0';
 174     j = r - rstart;
 175     SvCUR_set(sv, cur + j);
 176
 177     return j;
 178 }
 179
 180 /* append a repeated string to an SV */
 181 static SV *
 182 sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n)
 183 {
 184     if (sv == Nullsv)
 185         sv = newSVpvn("", 0);
 186     else
 187         assert(SvTYPE(sv) >= SVt_PV);
 188
 189     if (n > 0) {
 190         SvGROW(sv, len*n + SvCUR(sv) + 1);
 191         if (len == 1) {
 192             char *start = SvPVX(sv) + SvCUR(sv);
 193             SvCUR(sv) += n;
 194             start[n] = '\0';
 195             while (n > 0)
 196                 start[--n] = str[0];
 197         }
 198         else
 199             while (n > 0) {
 200                 sv_catpvn(sv, str, len);
 201                 --n;
 202             }
 203     }
 204     return sv;
 205 }
 206
 207 /*
 208  * This ought to be split into smaller functions. (it is one long function since
 209  * it exactly parallels the perl version, which was one long thing for
 210  * efficiency raisins.)  Ugggh!
 211  */
 212 static I32
 213 DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 214         AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
 215         SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
 216         I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
 217 {
 218     char tmpbuf[128];
 219     U32 i;
 220     char *c, *r, *realpack, id[128];
 221     SV **svp;
 222     SV *sv, *ipad, *ival;
 223     SV *blesspad = Nullsv;
 224     AV *seenentry = Nullav;
 225     char *iname;
 226     STRLEN inamelen, idlen = 0;
 227     U32 realtype;
 228
 229     if (!val)
 230         return 0;
 231
 232     realtype = SvTYPE(val);
 233
 234     if (SvGMAGICAL(val))
 235         mg_get(val);
 236     if (SvROK(val)) {
 237
 238         if (SvOBJECT(SvRV(val)) && freezer &&
 239             SvPOK(freezer) && SvCUR(freezer))
 240         {
 241             dSP; ENTER; SAVETMPS; PUSHMARK(sp);
 242             XPUSHs(val); PUTBACK;
 243             i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
 244             SPAGAIN;
 245             if (SvTRUE(ERRSV))
 246                 warn("WARNING(Freezer method call failed): %s",
 247                      SvPVX(ERRSV));
 248             else if (i)
 249                 val = newSVsv(POPs);
 250             PUTBACK; FREETMPS; LEAVE;
 251             if (i)
 252                 (void)sv_2mortal(val);
 253         }
 254
 255         ival = SvRV(val);
 256         realtype = SvTYPE(ival);
 257         (void) sprintf(id, "0x%lx", (unsigned long)ival);
 258         idlen = strlen(id);
 259         if (SvOBJECT(ival))
 260             realpack = HvNAME(SvSTASH(ival));
 261         else
 262             realpack = Nullch;
 263
 264         /* if it has a name, we need to either look it up, or keep a tab
 265          * on it so we know when we hit it later
 266          */
 267         if (namelen) {
 268             if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
 269                 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
 270             {
 271                 SV *othername;
 272                 if ((svp = av_fetch(seenentry, 0, FALSE))
 273                     && (othername = *svp))
 274                 {
 275                     if (purity && *levelp > 0) {
 276                         SV *postentry;
 277
 278                         if (realtype == SVt_PVHV)
 279                             sv_catpvn(retval, "{}", 2);
 280                         else if (realtype == SVt_PVAV)
 281                             sv_catpvn(retval, "[]", 2);
 282                         else
 283                             sv_catpvn(retval, "do{my $o}", 9);
 284                         postentry = newSVpvn(name, namelen);
 285                         sv_catpvn(postentry, " = ", 3);
 286                         sv_catsv(postentry, othername);
 287                         av_push(postav, postentry);
 288                     }
 289                     else {
 290                         if (name[0] == '@' || name[0] == '%') {
 291                             if ((SvPVX(othername))[0] == '\\' &&
 292                                 (SvPVX(othername))[1] == name[0]) {
 293                                 sv_catpvn(retval, SvPVX(othername)+1,
 294                                           SvCUR(othername)-1);
 295                             }
 296                             else {
 297                                 sv_catpvn(retval, name, 1);
 298                                 sv_catpvn(retval, "{", 1);
 299                                 sv_catsv(retval, othername);
 300                                 sv_catpvn(retval, "}", 1);
 301                             }
 302                         }
 303                         else
 304                             sv_catsv(retval, othername);
 305                     }
 306                     return 1;
 307                 }
 308                 else {
 309                     warn("ref name not found for %s", id);
 310                     return 0;
 311                 }
 312             }
 313             else {   /* store our name and continue */
 314                 SV *namesv;
 315                 if (name[0] == '@' || name[0] == '%') {
 316                     namesv = newSVpvn("\\", 1);
 317                     sv_catpvn(namesv, name, namelen);
 318                 }
 319                 else if (realtype == SVt_PVCV && name[0] == '*') {
 320                     namesv = newSVpvn("\\", 2);
 321                     sv_catpvn(namesv, name, namelen);
 322                     (SvPVX(namesv))[1] = '&';
 323                 }
 324                 else
 325                     namesv = newSVpvn(name, namelen);
 326                 seenentry = newAV();
 327                 av_push(seenentry, namesv);
 328                 (void)SvREFCNT_inc(val);
 329                 av_push(seenentry, val);
 330                 (void)hv_store(seenhv, id, strlen(id),
 331                                newRV((SV*)seenentry), 0);
 332                 SvREFCNT_dec(seenentry);
 333             }
 334         }
 335
 336         if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
 337             STRLEN rlen;
 338             char *rval = SvPV(val, rlen);
 339             char *slash = strchr(rval, '/');
 340             sv_catpvn(retval, "qr/", 3);
 341             while (slash) {
 342                 sv_catpvn(retval, rval, slash-rval);
 343                 sv_catpvn(retval, "\\/", 2);
 344                 rlen -= slash-rval+1;
 345                 rval = slash+1;
 346                 slash = strchr(rval, '/');
 347             }
 348             sv_catpvn(retval, rval, rlen);
 349             sv_catpvn(retval, "/", 1);
 350             return 1;
 351         }
 352
 353         /* If purity is not set and maxdepth is set, then check depth:
 354          * if we have reached maximum depth, return the string
 355          * representation of the thing we are currently examining
 356          * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
 357          */
 358         if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
 359             STRLEN vallen;
 360             char *valstr = SvPV(val,vallen);
 361             sv_catpvn(retval, "'", 1);
 362             sv_catpvn(retval, valstr, vallen);
 363             sv_catpvn(retval, "'", 1);
 364             return 1;
 365         }
 366
 367         if (realpack) {                         /* we have a blessed ref */
 368             STRLEN blesslen;
 369             char *blessstr = SvPV(bless, blesslen);
 370             sv_catpvn(retval, blessstr, blesslen);
 371             sv_catpvn(retval, "( ", 2);
 372             if (indent >= 2) {
 373                 blesspad = apad;
 374                 apad = newSVsv(apad);
 375                 sv_x(aTHX_ apad, " ", 1, blesslen+2);
 376             }
 377         }
 378
 379         (*levelp)++;
 380         ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
 381
 382         if (realtype <= SVt_PVBM) {                          /* scalar ref */
 383             SV *namesv = newSVpvn("${", 2);
 384             sv_catpvn(namesv, name, namelen);
 385             sv_catpvn(namesv, "}", 1);
 386             if (realpack) {                                  /* blessed */
 387                 sv_catpvn(retval, "do{\\(my $o = ", 13);
 388                 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 389                         postav, levelp, indent, pad, xpad, apad, sep,
 390                         freezer, toaster, purity, deepcopy, quotekeys, bless,
 391                         maxdepth, sortkeys);
 392                 sv_catpvn(retval, ")}", 2);
 393             }                                                /* plain */
 394             else {
 395                 sv_catpvn(retval, "\\", 1);
 396                 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 397                         postav, levelp, indent, pad, xpad, apad, sep,
 398                         freezer, toaster, purity, deepcopy, quotekeys, bless,
 399                         maxdepth, sortkeys);
 400             }
 401             SvREFCNT_dec(namesv);
 402         }
 403         else if (realtype == SVt_PVGV) {                     /* glob ref */
 404             SV *namesv = newSVpvn("*{", 2);
 405             sv_catpvn(namesv, name, namelen);
 406             sv_catpvn(namesv, "}", 1);
 407             sv_catpvn(retval, "\\", 1);
 408             DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 409                     postav, levelp,     indent, pad, xpad, apad, sep,
 410                     freezer, toaster, purity, deepcopy, quotekeys, bless,
 411                     maxdepth, sortkeys);
 412             SvREFCNT_dec(namesv);
 413         }
 414         else if (realtype == SVt_PVAV) {
 415             SV *totpad;
 416             I32 ix = 0;
 417             I32 ixmax = av_len((AV *)ival);
 418
 419             SV *ixsv = newSViv(0);
 420             /* allowing for a 24 char wide array index */
 421             New(0, iname, namelen+28, char);
 422             (void)strcpy(iname, name);
 423             inamelen = namelen;
 424             if (name[0] == '@') {
 425                 sv_catpvn(retval, "(", 1);
 426                 iname[0] = '$';
 427             }
 428             else {
 429                 sv_catpvn(retval, "[", 1);
 430                 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
 431                 /*if (namelen > 0
 432                     && name[namelen-1] != ']' && name[namelen-1] != '}'
 433                     && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
 434                 if ((namelen > 0
 435                      && name[namelen-1] != ']' && name[namelen-1] != '}')
 436                     || (namelen > 4
 437                         && (name[1] == '{'
 438                             || (name[0] == '\\' && name[2] == '{'))))
 439                 {
 440                     iname[inamelen++] = '-'; iname[inamelen++] = '>';
 441                     iname[inamelen] = '\0';
 442                 }
 443             }
 444             if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
 445                 (instr(iname+inamelen-8, "{SCALAR}") ||
 446                  instr(iname+inamelen-7, "{ARRAY}") ||
 447                  instr(iname+inamelen-6, "{HASH}"))) {
 448                 iname[inamelen++] = '-'; iname[inamelen++] = '>';
 449             }
 450             iname[inamelen++] = '['; iname[inamelen] = '\0';
 451             totpad = newSVsv(sep);
 452             sv_catsv(totpad, pad);
 453             sv_catsv(totpad, apad);
 454
 455             for (ix = 0; ix <= ixmax; ++ix) {
 456                 STRLEN ilen;
 457                 SV *elem;
 458                 svp = av_fetch((AV*)ival, ix, FALSE);
 459                 if (svp)
 460                     elem = *svp;
 461                 else
 462                     elem = &PL_sv_undef;
 463
 464                 ilen = inamelen;
 465                 sv_setiv(ixsv, ix);
 466                 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
 467                 ilen = strlen(iname);
 468                 iname[ilen++] = ']'; iname[ilen] = '\0';
 469                 if (indent >= 3) {
 470                     sv_catsv(retval, totpad);
 471                     sv_catsv(retval, ipad);
 472                     sv_catpvn(retval, "#", 1);
 473                     sv_catsv(retval, ixsv);
 474                 }
 475                 sv_catsv(retval, totpad);
 476                 sv_catsv(retval, ipad);
 477                 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
 478                         levelp, indent, pad, xpad, apad, sep,
 479                         freezer, toaster, purity, deepcopy, quotekeys, bless,
 480                         maxdepth, sortkeys);
 481                 if (ix < ixmax)
 482                     sv_catpvn(retval, ",", 1);
 483             }
 484             if (ixmax >= 0) {
 485                 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
 486                 sv_catsv(retval, totpad);
 487                 sv_catsv(retval, opad);
 488                 SvREFCNT_dec(opad);
 489             }
 490             if (name[0] == '@')
 491                 sv_catpvn(retval, ")", 1);
 492             else
 493                 sv_catpvn(retval, "]", 1);
 494             SvREFCNT_dec(ixsv);
 495             SvREFCNT_dec(totpad);
 496             Safefree(iname);
 497         }
 498         else if (realtype == SVt_PVHV) {
 499             SV *totpad, *newapad;
 500             SV *iname, *sname;
 501             HE *entry;
 502             char *key;
 503             I32 klen;
 504             SV *hval;
 505             AV *keys = Nullav;
 506
 507             iname = newSVpvn(name, namelen);
 508             if (name[0] == '%') {
 509                 sv_catpvn(retval, "(", 1);
 510                 (SvPVX(iname))[0] = '$';
 511             }
 512             else {
 513                 sv_catpvn(retval, "{", 1);
 514                 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
 515                 if ((namelen > 0
 516                      && name[namelen-1] != ']' && name[namelen-1] != '}')
 517                     || (namelen > 4
 518                         && (name[1] == '{'
 519                             || (name[0] == '\\' && name[2] == '{'))))
 520                 {
 521                     sv_catpvn(iname, "->", 2);
 522                 }
 523             }
 524             if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
 525                 (instr(name+namelen-8, "{SCALAR}") ||
 526                  instr(name+namelen-7, "{ARRAY}") ||
 527                  instr(name+namelen-6, "{HASH}"))) {
 528                 sv_catpvn(iname, "->", 2);
 529             }
 530             sv_catpvn(iname, "{", 1);
 531             totpad = newSVsv(sep);
 532             sv_catsv(totpad, pad);
 533             sv_catsv(totpad, apad);
 534
 535             /* If requested, get a sorted/filtered array of hash keys */
 536             if (sortkeys) {
 537                 if (sortkeys == &PL_sv_yes) {
 538                     keys = newAV();
 539                     (void)hv_iterinit((HV*)ival);
 540                     while ((entry = hv_iternext((HV*)ival))) {
 541                         sv = hv_iterkeysv(entry);
 542                         SvREFCNT_inc(sv);
 543                         av_push(keys, sv);
 544                     }
 545 #ifdef USE_LOCALE_NUMERIC
 546                     sortsv(AvARRAY(keys),
 547                            av_len(keys)+1,
 548                            IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
 549 #else
 550                     sortsv(AvARRAY(keys),
 551                            av_len(keys)+1,
 552                            Perl_sv_cmp);
 553 #endif
 554                 }
 555                 else {
 556                     dSP; ENTER; SAVETMPS; PUSHMARK(sp);
 557                     XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
 558                     i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
 559                     SPAGAIN;
 560                     if (i) {
 561                         sv = POPs;
 562                         if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
 563                             keys = (AV*)SvREFCNT_inc(SvRV(sv));
 564                     }
 565                     if (! keys)
 566                         warn("Sortkeys subroutine did not return ARRAYREF\n");
 567                     PUTBACK; FREETMPS; LEAVE;
 568                 }
 569                 if (keys)
 570                     sv_2mortal((SV*)keys);
 571             }
 572             else
 573                 (void)hv_iterinit((HV*)ival);
 574
 575             /* foreach (keys %hash) */
 576             for (i = 0; 1; i++) {
 577                 char *nkey = NULL;
 578                 I32 nticks = 0;
 579                 SV* keysv;
 580                 STRLEN keylen;
 581                 bool do_utf8 = FALSE;
 582
 583                 if ((sortkeys && !(keys && i <= av_len(keys))) ||
 584                     !(entry = hv_iternext((HV *)ival)))
 585                     break;
 586
 587                 if (i)
 588                     sv_catpvn(retval, ",", 1);
 589
 590                 if (sortkeys) {
 591                     char *key;
 592                     svp = av_fetch(keys, i, FALSE);
 593                     keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
 594                     key = SvPV(keysv, keylen);
 595                     svp = hv_fetch((HV*)ival, key, keylen, 0);
 596                     hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
 597                 }
 598                 else {
 599                     keysv = hv_iterkeysv(entry);
 600                     hval = hv_iterval((HV*)ival, entry);
 601                 }
 602
 603                 do_utf8 = DO_UTF8(keysv);
 604                 key = SvPV(keysv, keylen);
 605                 klen = keylen;
 606
 607                 if (do_utf8) {
 608                     char *okey = SvPVX(retval) + SvCUR(retval);
 609                     I32 nlen;
 610
 611                     sv_catsv(retval, totpad);
 612                     sv_catsv(retval, ipad);
 613                     nlen = esc_q_utf8(aTHX_ retval, key, klen);
 614
 615                     sname = newSVsv(iname);
 616                     sv_catpvn(sname, okey, nlen);
 617                     sv_catpvn(sname, "}", 1);
 618                 }
 619                 else {
 620                     if (quotekeys || needs_quote(key)) {
 621                         nticks = num_q(key, klen);
 622                         New(0, nkey, klen+nticks+3, char);
 623                         nkey[0] = '\'';
 624                         if (nticks)
 625                             klen += esc_q(nkey+1, key, klen);
 626                         else
 627                             (void)Copy(key, nkey+1, klen, char);
 628                         nkey[++klen] = '\'';
 629                         nkey[++klen] = '\0';
 630                     }
 631                     else {
 632                         New(0, nkey, klen, char);
 633                         (void)Copy(key, nkey, klen, char);
 634                     }
 635
 636                     sname = newSVsv(iname);
 637                     sv_catpvn(sname, nkey, klen);
 638                     sv_catpvn(sname, "}", 1);
 639
 640                     sv_catsv(retval, totpad);
 641                     sv_catsv(retval, ipad);
 642                     sv_catpvn(retval, nkey, klen);
 643                 }
 644                 sv_catpvn(retval, " => ", 4);
 645                 if (indent >= 2) {
 646                     char *extra;
 647                     I32 elen = 0;
 648                     newapad = newSVsv(apad);
 649                     New(0, extra, klen+4+1, char);
 650                     while (elen < (klen+4))
 651                         extra[elen++] = ' ';
 652                     extra[elen] = '\0';
 653                     sv_catpvn(newapad, extra, elen);
 654                     Safefree(extra);
 655                 }
 656                 else
 657                     newapad = apad;
 658
 659                 DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
 660                         postav, levelp, indent, pad, xpad, newapad, sep,
 661                         freezer, toaster, purity, deepcopy, quotekeys, bless,
 662                         maxdepth, sortkeys);
 663                 SvREFCNT_dec(sname);
 664                 Safefree(nkey);
 665                 if (indent >= 2)
 666                     SvREFCNT_dec(newapad);
 667             }
 668             if (i) {
 669                 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
 670                 sv_catsv(retval, totpad);
 671                 sv_catsv(retval, opad);
 672                 SvREFCNT_dec(opad);
 673             }
 674             if (name[0] == '%')
 675                 sv_catpvn(retval, ")", 1);
 676             else
 677                 sv_catpvn(retval, "}", 1);
 678             SvREFCNT_dec(iname);
 679             SvREFCNT_dec(totpad);
 680         }
 681         else if (realtype == SVt_PVCV) {
 682             sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
 683             if (purity)
 684                 warn("Encountered CODE ref, using dummy placeholder");
 685         }
 686         else {
 687             warn("cannot handle ref type %ld", realtype);
 688         }
 689
 690         if (realpack) {  /* free blessed allocs */
 691             if (indent >= 2) {
 692                 SvREFCNT_dec(apad);
 693                 apad = blesspad;
 694             }
 695             sv_catpvn(retval, ", '", 3);
 696             sv_catpvn(retval, realpack, strlen(realpack));
 697             sv_catpvn(retval, "' )", 3);
 698             if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
 699                 sv_catpvn(retval, "->", 2);
 700                 sv_catsv(retval, toaster);
 701                 sv_catpvn(retval, "()", 2);
 702             }
 703         }
 704         SvREFCNT_dec(ipad);
 705         (*levelp)--;
 706     }
 707     else {
 708         STRLEN i;
 709
 710         if (namelen) {
 711             (void) sprintf(id, "0x%lx", (unsigned long)val);
 712             if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
 713                 (sv = *svp) && SvROK(sv) &&
 714                 (seenentry = (AV*)SvRV(sv)))
 715             {
 716                 SV *othername;
 717                 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
 718                     && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
 719                 {
 720                     sv_catpvn(retval, "${", 2);
 721                     sv_catsv(retval, othername);
 722                     sv_catpvn(retval, "}", 1);
 723                     return 1;
 724                 }
 725             }
 726             else {
 727                 SV *namesv;
 728                 namesv = newSVpvn("\\", 1);
 729                 sv_catpvn(namesv, name, namelen);
 730                 seenentry = newAV();
 731                 av_push(seenentry, namesv);
 732                 av_push(seenentry, newRV(val));
 733                 (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
 734                 SvREFCNT_dec(seenentry);
 735             }
 736         }
 737
 738         if (SvIOK(val)) {
 739             STRLEN len;
 740             if (SvIsUV(val))
 741               (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
 742             else
 743               (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
 744             len = strlen(tmpbuf);
 745             /* For 5.6.x and earlier will need to change this test to check
 746                NV if NOK, as there NOK trumps IOK, and NV=3.5,IV=3 is valid.
 747                Current code will Dump that as $VAR1 = 3;
 748                Changes in 5.7 series mean that now IOK is only set if scalar
 749                is precisely integer.  */
 750             if (SvPOK(val)) {
 751               /* Need to check to see if this is a string such as " 0".
 752                  I'm assuming from sprintf isn't going to clash with utf8.
 753                  Is this valid on EBCDIC?  */
 754               STRLEN pvlen;
 755               const char *pv = SvPV(val, pvlen);
 756               if (pvlen != len || memNE(pv, tmpbuf, len))
 757                 goto integer_came_from_string;
 758             }
 759             if (len > 10) {
 760               /* Looks like we're on a 64 bit system.  Make it a string so that
 761                  if a 32 bit system reads the number it will cope better.  */
 762               sv_catpvf(retval, "'%s'", tmpbuf);
 763             } else
 764               sv_catpvn(retval, tmpbuf, len);
 765         }
 766         else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
 767             c = SvPV(val, i);
 768             ++c; --i;                   /* just get the name */
 769             if (i >= 6 && strncmp(c, "main::", 6) == 0) {
 770                 c += 4;
 771                 i -= 4;
 772             }
 773             if (needs_quote(c)) {
 774                 sv_grow(retval, SvCUR(retval)+6+2*i);
 775                 r = SvPVX(retval)+SvCUR(retval);
 776                 r[0] = '*'; r[1] = '{'; r[2] = '\'';
 777                 i += esc_q(r+3, c, i);
 778                 i += 3;
 779                 r[i++] = '\''; r[i++] = '}';
 780                 r[i] = '\0';
 781             }
 782             else {
 783                 sv_grow(retval, SvCUR(retval)+i+2);
 784                 r = SvPVX(retval)+SvCUR(retval);
 785                 r[0] = '*'; strcpy(r+1, c);
 786                 i++;
 787             }
 788             SvCUR_set(retval, SvCUR(retval)+i);
 789
 790             if (purity) {
 791                 static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
 792                 static STRLEN sizes[] = { 8, 7, 6 };
 793                 SV *e;
 794                 SV *nname = newSVpvn("", 0);
 795                 SV *newapad = newSVpvn("", 0);
 796                 GV *gv = (GV*)val;
 797                 I32 j;
 798
 799                 for (j=0; j<3; j++) {
 800                     e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
 801                     if (!e)
 802                         continue;
 803                     if (j == 0 && !SvOK(e))
 804                         continue;
 805
 806                     {
 807                         I32 nlevel = 0;
 808                         SV *postentry = newSVpvn(r,i);
 809
 810                         sv_setsv(nname, postentry);
 811                         sv_catpvn(nname, entries[j], sizes[j]);
 812                         sv_catpvn(postentry, " = ", 3);
 813                         av_push(postav, postentry);
 814                         e = newRV(e);
 815
 816                         SvCUR(newapad) = 0;
 817                         if (indent >= 2)
 818                             (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
 819
 820                         DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
 821                                 seenhv, postav, &nlevel, indent, pad, xpad,
 822                                 newapad, sep, freezer, toaster, purity,
 823                                 deepcopy, quotekeys, bless, maxdepth,
 824                                 sortkeys);
 825                         SvREFCNT_dec(e);
 826                     }
 827                 }
 828
 829                 SvREFCNT_dec(newapad);
 830                 SvREFCNT_dec(nname);
 831             }
 832         }
 833         else if (val == &PL_sv_undef || !SvOK(val)) {
 834             sv_catpvn(retval, "undef", 5);
 835         }
 836         else {
 837         integer_came_from_string:
 838             c = SvPV(val, i);
 839             if (DO_UTF8(val))
 840                 i += esc_q_utf8(aTHX_ retval, c, i);
 841             else {
 842                 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
 843                 r = SvPVX(retval) + SvCUR(retval);
 844                 r[0] = '\'';
 845                 i += esc_q(r+1, c, i);
 846                 ++i;
 847                 r[i++] = '\'';
 848                 r[i] = '\0';
 849                 SvCUR_set(retval, SvCUR(retval)+i);
 850             }
 851         }
 852     }
 853
 854     if (idlen) {
 855         if (deepcopy)
 856             (void)hv_delete(seenhv, id, idlen, G_DISCARD);
 857         else if (namelen && seenentry) {
 858             SV *mark = *av_fetch(seenentry, 2, TRUE);
 859             sv_setiv(mark,1);
 860         }
 861     }
 862     return 1;
 863 }
 864
 865
 866 MODULE = Data::Dumper           PACKAGE = Data::Dumper         PREFIX = Data_Dumper_
 867
 868 #
 869 # This is the exact equivalent of Dump.  Well, almost. The things that are
 870 # different as of now (due to Laziness):
 871 #   * doesnt do double-quotes yet.
 872 #
 873
 874 void
 875 Data_Dumper_Dumpxs(href, ...)
 876         SV      *href;
 877         PROTOTYPE: $;$$
 878         PPCODE:
 879         {
 880             HV *hv;
 881             SV *retval, *valstr;
 882             HV *seenhv = Nullhv;
 883             AV *postav, *todumpav, *namesav;
 884             I32 level = 0;
 885             I32 indent, terse, i, imax, postlen;
 886             SV **svp;
 887             SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
 888             SV *freezer, *toaster, *bless, *sortkeys;
 889             I32 purity, deepcopy, quotekeys, maxdepth = 0;
 890             char tmpbuf[1024];
 891             I32 gimme = GIMME;
 892
 893             if (!SvROK(href)) {         /* call new to get an object first */
 894                 if (items < 2)
 895                     croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
 896
 897                 ENTER;
 898                 SAVETMPS;
 899
 900                 PUSHMARK(sp);
 901                 XPUSHs(href);
 902                 XPUSHs(sv_2mortal(newSVsv(ST(1))));
 903                 if (items >= 3)
 904                     XPUSHs(sv_2mortal(newSVsv(ST(2))));
 905                 PUTBACK;
 906                 i = perl_call_method("new", G_SCALAR);
 907                 SPAGAIN;
 908                 if (i)
 909                     href = newSVsv(POPs);
 910
 911                 PUTBACK;
 912                 FREETMPS;
 913                 LEAVE;
 914                 if (i)
 915                     (void)sv_2mortal(href);
 916             }
 917
 918             todumpav = namesav = Nullav;
 919             seenhv = Nullhv;
 920             val = pad = xpad = apad = sep = varname
 921                 = freezer = toaster = bless = &PL_sv_undef;
 922             name = sv_newmortal();
 923             indent = 2;
 924             terse = purity = deepcopy = 0;
 925             quotekeys = 1;
 926
 927             retval = newSVpvn("", 0);
 928             if (SvROK(href)
 929                 && (hv = (HV*)SvRV((SV*)href))
 930                 && SvTYPE(hv) == SVt_PVHV)              {
 931
 932                 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
 933                     seenhv = (HV*)SvRV(*svp);
 934                 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
 935                     todumpav = (AV*)SvRV(*svp);
 936                 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
 937                     namesav = (AV*)SvRV(*svp);
 938                 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
 939                     indent = SvIV(*svp);
 940                 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
 941                     purity = SvIV(*svp);
 942                 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
 943                     terse = SvTRUE(*svp);
 944 #if 0 /* useqq currently unused */
 945                 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
 946                     useqq = SvTRUE(*svp);
 947 #endif
 948                 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
 949                     pad = *svp;
 950                 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
 951                     xpad = *svp;
 952                 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
 953                     apad = *svp;
 954                 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
 955                     sep = *svp;
 956                 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
 957                     varname = *svp;
 958                 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
 959                     freezer = *svp;
 960                 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
 961                     toaster = *svp;
 962                 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
 963                     deepcopy = SvTRUE(*svp);
 964                 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
 965                     quotekeys = SvTRUE(*svp);
 966                 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
 967                     bless = *svp;
 968                 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
 969                     maxdepth = SvIV(*svp);
 970                 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
 971                     sortkeys = *svp;
 972                     if (! SvTRUE(sortkeys))
 973                         sortkeys = NULL;
 974                     else if (! (SvROK(sortkeys) &&
 975                                 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
 976                     {
 977                         /* flag to use qsortsv() for sorting hash keys */
 978                         sortkeys = &PL_sv_yes;
 979                     }
 980                 }
 981                 postav = newAV();
 982
 983                 if (todumpav)
 984                     imax = av_len(todumpav);
 985                 else
 986                     imax = -1;
 987                 valstr = newSVpvn("",0);
 988                 for (i = 0; i <= imax; ++i) {
 989                     SV *newapad;
 990
 991                     av_clear(postav);
 992                     if ((svp = av_fetch(todumpav, i, FALSE)))
 993                         val = *svp;
 994                     else
 995                         val = &PL_sv_undef;
 996                     if ((svp = av_fetch(namesav, i, TRUE)))
 997                         sv_setsv(name, *svp);
 998                     else
 999                         (void)SvOK_off(name);
1000
1001                     if (SvOK(name)) {
1002                         if ((SvPVX(name))[0] == '*') {
1003                             if (SvROK(val)) {
1004                                 switch (SvTYPE(SvRV(val))) {
1005                                 case SVt_PVAV:
1006                                     (SvPVX(name))[0] = '@';
1007                                     break;
1008                                 case SVt_PVHV:
1009                                     (SvPVX(name))[0] = '%';
1010                                     break;
1011                                 case SVt_PVCV:
1012                                     (SvPVX(name))[0] = '*';
1013                                     break;
1014                                 default:
1015                                     (SvPVX(name))[0] = '$';
1016                                     break;
1017                                 }
1018                             }
1019                             else
1020                                 (SvPVX(name))[0] = '$';
1021                         }
1022                         else if ((SvPVX(name))[0] != '$')
1023                             sv_insert(name, 0, 0, "$", 1);
1024                     }
1025                     else {
1026                         STRLEN nchars = 0;
1027                         sv_setpvn(name, "$", 1);
1028                         sv_catsv(name, varname);
1029                         (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1030                         nchars = strlen(tmpbuf);
1031                         sv_catpvn(name, tmpbuf, nchars);
1032                     }
1033
1034                     if (indent >= 2) {
1035                         SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1036                         newapad = newSVsv(apad);
1037                         sv_catsv(newapad, tmpsv);
1038                         SvREFCNT_dec(tmpsv);
1039                     }
1040                     else
1041                         newapad = apad;
1042
1043                     DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
1044                             postav, &level, indent, pad, xpad, newapad, sep,
1045                             freezer, toaster, purity, deepcopy, quotekeys,
1046                             bless, maxdepth, sortkeys);
1047
1048                     if (indent >= 2)
1049                         SvREFCNT_dec(newapad);
1050
1051                     postlen = av_len(postav);
1052                     if (postlen >= 0 || !terse) {
1053                         sv_insert(valstr, 0, 0, " = ", 3);
1054                         sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
1055                         sv_catpvn(valstr, ";", 1);
1056                     }
1057                     sv_catsv(retval, pad);
1058                     sv_catsv(retval, valstr);
1059                     sv_catsv(retval, sep);
1060                     if (postlen >= 0) {
1061                         I32 i;
1062                         sv_catsv(retval, pad);
1063                         for (i = 0; i <= postlen; ++i) {
1064                             SV *elem;
1065                             svp = av_fetch(postav, i, FALSE);
1066                             if (svp && (elem = *svp)) {
1067                                 sv_catsv(retval, elem);
1068                                 if (i < postlen) {
1069                                     sv_catpvn(retval, ";", 1);
1070                                     sv_catsv(retval, sep);
1071                                     sv_catsv(retval, pad);
1072                                 }
1073                             }
1074                         }
1075                         sv_catpvn(retval, ";", 1);
1076                             sv_catsv(retval, sep);
1077                     }
1078                     sv_setpvn(valstr, "", 0);
1079                     if (gimme == G_ARRAY) {
1080                         XPUSHs(sv_2mortal(retval));
1081                         if (i < imax)   /* not the last time thro ? */
1082                             retval = newSVpvn("",0);
1083                     }
1084                 }
1085                 SvREFCNT_dec(postav);
1086                 SvREFCNT_dec(valstr);
1087             }
1088             else
1089                 croak("Call to new() method failed to return HASH ref");
1090             if (gimme == G_SCALAR)
1091                 XPUSHs(sv_2mortal(retval));
1092         }