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