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