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