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