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