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 SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n);
  26 static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
  27                     HV *seenhv, AV *postav, I32 *levelp, I32 indent,
  28                     SV *pad, SV *xpad, SV *apad, SV *sep,
  29                     SV *freezer, SV *toaster,
  30                     I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
  31                     I32 maxdepth);
  32
  33 /* does a string need to be protected? */
  34 static I32
  35 needs_quote(register char *s)
  36 {
  37 TOP:
  38     if (s[0] == ':') {
  39         if (*++s) {
  40             if (*s++ != ':')
  41                 return 1;
  42         }
  43         else
  44             return 1;
  45     }
  46     if (isIDFIRST(*s)) {
  47         while (*++s)
  48             if (!isALNUM(*s)) {
  49                 if (*s == ':')
  50                     goto TOP;
  51                 else
  52                     return 1;
  53             }
  54     }
  55     else
  56         return 1;
  57     return 0;
  58 }
  59
  60 /* count the number of "'"s and "\"s in string */
  61 static I32
  62 num_q(register char *s, register STRLEN slen)
  63 {
  64     register I32 ret = 0;
  65
  66     while (slen > 0) {
  67         if (*s == '\'' || *s == '\\')
  68             ++ret;
  69         ++s;
  70         --slen;
  71     }
  72     return ret;
  73 }
  74
  75
  76 /* returns number of chars added to escape "'"s and "\"s in s */
  77 /* slen number of characters in s will be escaped */
  78 /* destination must be long enough for additional chars */
  79 static I32
  80 esc_q(register char *d, register char *s, register STRLEN slen)
  81 {
  82     register I32 ret = 0;
  83
  84     while (slen > 0) {
  85         switch (*s) {
  86         case '\'':
  87         case '\\':
  88             *d = '\\';
  89             ++d; ++ret;
  90         default:
  91             *d = *s;
  92             ++d; ++s; --slen;
  93             break;
  94         }
  95     }
  96     return ret;
  97 }
  98
  99 /* append a repeated string to an SV */
 100 static SV *
 101 sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n)
 102 {
 103     if (sv == Nullsv)
 104         sv = newSVpvn("", 0);
 105     else
 106         assert(SvTYPE(sv) >= SVt_PV);
 107
 108     if (n > 0) {
 109         SvGROW(sv, len*n + SvCUR(sv) + 1);
 110         if (len == 1) {
 111             char *start = SvPVX(sv) + SvCUR(sv);
 112             SvCUR(sv) += n;
 113             start[n] = '\0';
 114             while (n > 0)
 115                 start[--n] = str[0];
 116         }
 117         else
 118             while (n > 0) {
 119                 sv_catpvn(sv, str, len);
 120                 --n;
 121             }
 122     }
 123     return sv;
 124 }
 125
 126 /*
 127  * This ought to be split into smaller functions. (it is one long function since
 128  * it exactly parallels the perl version, which was one long thing for
 129  * efficiency raisins.)  Ugggh!
 130  */
 131 static I32
 132 DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 133         AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
 134         SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
 135         I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth)
 136 {
 137     char tmpbuf[128];
 138     U32 i;
 139     char *c, *r, *realpack, id[128];
 140     SV **svp;
 141     SV *sv, *ipad, *ival;
 142     SV *blesspad = Nullsv;
 143     AV *seenentry = Nullav;
 144     char *iname;
 145     STRLEN inamelen, idlen = 0;
 146     U32 flags;
 147     U32 realtype;
 148
 149     if (!val)
 150         return 0;
 151
 152     flags = SvFLAGS(val);
 153     realtype = SvTYPE(val);
 154
 155     if (SvGMAGICAL(val))
 156         mg_get(val);
 157     if (SvROK(val)) {
 158
 159         if (SvOBJECT(SvRV(val)) && freezer &&
 160             SvPOK(freezer) && SvCUR(freezer))
 161         {
 162             dSP; ENTER; SAVETMPS; PUSHMARK(sp);
 163             XPUSHs(val); PUTBACK;
 164             i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
 165             SPAGAIN;
 166             if (SvTRUE(ERRSV))
 167                 warn("WARNING(Freezer method call failed): %s",
 168                      SvPVX(ERRSV));
 169             else if (i)
 170                 val = newSVsv(POPs);
 171             PUTBACK; FREETMPS; LEAVE;
 172             if (i)
 173                 (void)sv_2mortal(val);
 174         }
 175
 176         ival = SvRV(val);
 177         flags = SvFLAGS(ival);
 178         realtype = SvTYPE(ival);
 179         (void) sprintf(id, "0x%lx", (unsigned long)ival);
 180         idlen = strlen(id);
 181         if (SvOBJECT(ival))
 182             realpack = HvNAME(SvSTASH(ival));
 183         else
 184             realpack = Nullch;
 185
 186         /* if it has a name, we need to either look it up, or keep a tab
 187          * on it so we know when we hit it later
 188          */
 189         if (namelen) {
 190             if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
 191                 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
 192             {
 193                 SV *othername;
 194                 if ((svp = av_fetch(seenentry, 0, FALSE))
 195                     && (othername = *svp))
 196                 {
 197                     if (purity && *levelp > 0) {
 198                         SV *postentry;
 199
 200                         if (realtype == SVt_PVHV)
 201                             sv_catpvn(retval, "{}", 2);
 202                         else if (realtype == SVt_PVAV)
 203                             sv_catpvn(retval, "[]", 2);
 204                         else
 205                             sv_catpvn(retval, "do{my $o}", 9);
 206                         postentry = newSVpvn(name, namelen);
 207                         sv_catpvn(postentry, " = ", 3);
 208                         sv_catsv(postentry, othername);
 209                         av_push(postav, postentry);
 210                     }
 211                     else {
 212                         if (name[0] == '@' || name[0] == '%') {
 213                             if ((SvPVX(othername))[0] == '\\' &&
 214                                 (SvPVX(othername))[1] == name[0]) {
 215                                 sv_catpvn(retval, SvPVX(othername)+1,
 216                                           SvCUR(othername)-1);
 217                             }
 218                             else {
 219                                 sv_catpvn(retval, name, 1);
 220                                 sv_catpvn(retval, "{", 1);
 221                                 sv_catsv(retval, othername);
 222                                 sv_catpvn(retval, "}", 1);
 223                             }
 224                         }
 225                         else
 226                             sv_catsv(retval, othername);
 227                     }
 228                     return 1;
 229                 }
 230                 else {
 231                     warn("ref name not found for %s", id);
 232                     return 0;
 233                 }
 234             }
 235             else {   /* store our name and continue */
 236                 SV *namesv;
 237                 if (name[0] == '@' || name[0] == '%') {
 238                     namesv = newSVpvn("\\", 1);
 239                     sv_catpvn(namesv, name, namelen);
 240                 }
 241                 else if (realtype == SVt_PVCV && name[0] == '*') {
 242                     namesv = newSVpvn("\\", 2);
 243                     sv_catpvn(namesv, name, namelen);
 244                     (SvPVX(namesv))[1] = '&';
 245                 }
 246                 else
 247                     namesv = newSVpvn(name, namelen);
 248                 seenentry = newAV();
 249                 av_push(seenentry, namesv);
 250                 (void)SvREFCNT_inc(val);
 251                 av_push(seenentry, val);
 252                 (void)hv_store(seenhv, id, strlen(id),
 253                                newRV((SV*)seenentry), 0);
 254                 SvREFCNT_dec(seenentry);
 255             }
 256         }
 257
 258         if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
 259             STRLEN rlen;
 260             char *rval = SvPV(val, rlen);
 261             char *slash = strchr(rval, '/');
 262             sv_catpvn(retval, "qr/", 3);
 263             while (slash) {
 264                 sv_catpvn(retval, rval, slash-rval);
 265                 sv_catpvn(retval, "\\/", 2);
 266                 rlen -= slash-rval+1;
 267                 rval = slash+1;
 268                 slash = strchr(rval, '/');
 269             }
 270             sv_catpvn(retval, rval, rlen);
 271             sv_catpvn(retval, "/", 1);
 272             return 1;
 273         }
 274
 275         /* If purity is not set and maxdepth is set, then check depth:
 276          * if we have reached maximum depth, return the string
 277          * representation of the thing we are currently examining
 278          * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
 279          */
 280         if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
 281             STRLEN vallen;
 282             char *valstr = SvPV(val,vallen);
 283             sv_catpvn(retval, "'", 1);
 284             sv_catpvn(retval, valstr, vallen);
 285             sv_catpvn(retval, "'", 1);
 286             return 1;
 287         }
 288
 289         if (realpack) {                         /* we have a blessed ref */
 290             STRLEN blesslen;
 291             char *blessstr = SvPV(bless, blesslen);
 292             sv_catpvn(retval, blessstr, blesslen);
 293             sv_catpvn(retval, "( ", 2);
 294             if (indent >= 2) {
 295                 blesspad = apad;
 296                 apad = newSVsv(apad);
 297                 sv_x(aTHX_ apad, " ", 1, blesslen+2);
 298             }
 299         }
 300
 301         (*levelp)++;
 302         ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
 303
 304         if (realtype <= SVt_PVBM) {                          /* scalar ref */
 305             SV *namesv = newSVpvn("${", 2);
 306             sv_catpvn(namesv, name, namelen);
 307             sv_catpvn(namesv, "}", 1);
 308             if (realpack) {                                  /* blessed */
 309                 sv_catpvn(retval, "do{\\(my $o = ", 13);
 310                 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 311                         postav, levelp, indent, pad, xpad, apad, sep,
 312                         freezer, toaster, purity, deepcopy, quotekeys, bless,
 313                         maxdepth);
 314                 sv_catpvn(retval, ")}", 2);
 315             }                                                /* plain */
 316             else {
 317                 sv_catpvn(retval, "\\", 1);
 318                 DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 319                         postav, levelp, indent, pad, xpad, apad, sep,
 320                         freezer, toaster, purity, deepcopy, quotekeys, bless,
 321                         maxdepth);
 322             }
 323             SvREFCNT_dec(namesv);
 324         }
 325         else if (realtype == SVt_PVGV) {                     /* glob ref */
 326             SV *namesv = newSVpvn("*{", 2);
 327             sv_catpvn(namesv, name, namelen);
 328             sv_catpvn(namesv, "}", 1);
 329             sv_catpvn(retval, "\\", 1);
 330             DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 331                     postav, levelp,     indent, pad, xpad, apad, sep,
 332                     freezer, toaster, purity, deepcopy, quotekeys, bless,
 333                     maxdepth);
 334             SvREFCNT_dec(namesv);
 335         }
 336         else if (realtype == SVt_PVAV) {
 337             SV *totpad;
 338             I32 ix = 0;
 339             I32 ixmax = av_len((AV *)ival);
 340
 341             SV *ixsv = newSViv(0);
 342             /* allowing for a 24 char wide array index */
 343             New(0, iname, namelen+28, char);
 344             (void)strcpy(iname, name);
 345             inamelen = namelen;
 346             if (name[0] == '@') {
 347                 sv_catpvn(retval, "(", 1);
 348                 iname[0] = '$';
 349             }
 350             else {
 351                 sv_catpvn(retval, "[", 1);
 352                 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
 353                 /*if (namelen > 0
 354                     && name[namelen-1] != ']' && name[namelen-1] != '}'
 355                     && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
 356                 if ((namelen > 0
 357                      && name[namelen-1] != ']' && name[namelen-1] != '}')
 358                     || (namelen > 4
 359                         && (name[1] == '{'
 360                             || (name[0] == '\\' && name[2] == '{'))))
 361                 {
 362                     iname[inamelen++] = '-'; iname[inamelen++] = '>';
 363                     iname[inamelen] = '\0';
 364                 }
 365             }
 366             if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
 367                 (instr(iname+inamelen-8, "{SCALAR}") ||
 368                  instr(iname+inamelen-7, "{ARRAY}") ||
 369                  instr(iname+inamelen-6, "{HASH}"))) {
 370                 iname[inamelen++] = '-'; iname[inamelen++] = '>';
 371             }
 372             iname[inamelen++] = '['; iname[inamelen] = '\0';
 373             totpad = newSVsv(sep);
 374             sv_catsv(totpad, pad);
 375             sv_catsv(totpad, apad);
 376
 377             for (ix = 0; ix <= ixmax; ++ix) {
 378                 STRLEN ilen;
 379                 SV *elem;
 380                 svp = av_fetch((AV*)ival, ix, FALSE);
 381                 if (svp)
 382                     elem = *svp;
 383                 else
 384                     elem = &PL_sv_undef;
 385
 386                 ilen = inamelen;
 387                 sv_setiv(ixsv, ix);
 388                 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
 389                 ilen = strlen(iname);
 390                 iname[ilen++] = ']'; iname[ilen] = '\0';
 391                 if (indent >= 3) {
 392                     sv_catsv(retval, totpad);
 393                     sv_catsv(retval, ipad);
 394                     sv_catpvn(retval, "#", 1);
 395                     sv_catsv(retval, ixsv);
 396                 }
 397                 sv_catsv(retval, totpad);
 398                 sv_catsv(retval, ipad);
 399                 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
 400                         levelp, indent, pad, xpad, apad, sep,
 401                         freezer, toaster, purity, deepcopy, quotekeys, bless,
 402                         maxdepth);
 403                 if (ix < ixmax)
 404                     sv_catpvn(retval, ",", 1);
 405             }
 406             if (ixmax >= 0) {
 407                 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
 408                 sv_catsv(retval, totpad);
 409                 sv_catsv(retval, opad);
 410                 SvREFCNT_dec(opad);
 411             }
 412             if (name[0] == '@')
 413                 sv_catpvn(retval, ")", 1);
 414             else
 415                 sv_catpvn(retval, "]", 1);
 416             SvREFCNT_dec(ixsv);
 417             SvREFCNT_dec(totpad);
 418             Safefree(iname);
 419         }
 420         else if (realtype == SVt_PVHV) {
 421             SV *totpad, *newapad;
 422             SV *iname, *sname;
 423             HE *entry;
 424             char *key;
 425             I32 klen;
 426             SV *hval;
 427
 428             iname = newSVpvn(name, namelen);
 429             if (name[0] == '%') {
 430                 sv_catpvn(retval, "(", 1);
 431                 (SvPVX(iname))[0] = '$';
 432             }
 433             else {
 434                 sv_catpvn(retval, "{", 1);
 435                 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
 436                 if ((namelen > 0
 437                      && name[namelen-1] != ']' && name[namelen-1] != '}')
 438                     || (namelen > 4
 439                         && (name[1] == '{'
 440                             || (name[0] == '\\' && name[2] == '{'))))
 441                 {
 442                     sv_catpvn(iname, "->", 2);
 443                 }
 444             }
 445             if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
 446                 (instr(name+namelen-8, "{SCALAR}") ||
 447                  instr(name+namelen-7, "{ARRAY}") ||
 448                  instr(name+namelen-6, "{HASH}"))) {
 449                 sv_catpvn(iname, "->", 2);
 450             }
 451             sv_catpvn(iname, "{", 1);
 452             totpad = newSVsv(sep);
 453             sv_catsv(totpad, pad);
 454             sv_catsv(totpad, apad);
 455
 456             (void)hv_iterinit((HV*)ival);
 457             i = 0;
 458             while ((entry = hv_iternext((HV*)ival)))  {
 459                 char *nkey;
 460                 I32 nticks = 0;
 461
 462                 if (i)
 463                     sv_catpvn(retval, ",", 1);
 464                 i++;
 465                 key = hv_iterkey(entry, &klen);
 466                 hval = hv_iterval((HV*)ival, entry);
 467
 468                 if (quotekeys || needs_quote(key)) {
 469                     nticks = num_q(key, klen);
 470                     New(0, nkey, klen+nticks+3, char);
 471                     nkey[0] = '\'';
 472                     if (nticks)
 473                         klen += esc_q(nkey+1, key, klen);
 474                     else
 475                         (void)Copy(key, nkey+1, klen, char);
 476                     nkey[++klen] = '\'';
 477                     nkey[++klen] = '\0';
 478                 }
 479                 else {
 480                     New(0, nkey, klen, char);
 481                     (void)Copy(key, nkey, klen, char);
 482                 }
 483
 484                 sname = newSVsv(iname);
 485                 sv_catpvn(sname, nkey, klen);
 486                 sv_catpvn(sname, "}", 1);
 487
 488                 sv_catsv(retval, totpad);
 489                 sv_catsv(retval, ipad);
 490                 sv_catpvn(retval, nkey, klen);
 491                 sv_catpvn(retval, " => ", 4);
 492                 if (indent >= 2) {
 493                     char *extra;
 494                     I32 elen = 0;
 495                     newapad = newSVsv(apad);
 496                     New(0, extra, klen+4+1, char);
 497                     while (elen < (klen+4))
 498                         extra[elen++] = ' ';
 499                     extra[elen] = '\0';
 500                     sv_catpvn(newapad, extra, elen);
 501                     Safefree(extra);
 502                 }
 503                 else
 504                     newapad = apad;
 505
 506                 DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
 507                         postav, levelp, indent, pad, xpad, newapad, sep,
 508                         freezer, toaster, purity, deepcopy, quotekeys, bless,
 509                         maxdepth);
 510                 SvREFCNT_dec(sname);
 511                 Safefree(nkey);
 512                 if (indent >= 2)
 513                     SvREFCNT_dec(newapad);
 514             }
 515             if (i) {
 516                 SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
 517                 sv_catsv(retval, totpad);
 518                 sv_catsv(retval, opad);
 519                 SvREFCNT_dec(opad);
 520             }
 521             if (name[0] == '%')
 522                 sv_catpvn(retval, ")", 1);
 523             else
 524                 sv_catpvn(retval, "}", 1);
 525             SvREFCNT_dec(iname);
 526             SvREFCNT_dec(totpad);
 527         }
 528         else if (realtype == SVt_PVCV) {
 529             sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
 530             if (purity)
 531                 warn("Encountered CODE ref, using dummy placeholder");
 532         }
 533         else {
 534             warn("cannot handle ref type %ld", realtype);
 535         }
 536
 537         if (realpack) {  /* free blessed allocs */
 538             if (indent >= 2) {
 539                 SvREFCNT_dec(apad);
 540                 apad = blesspad;
 541             }
 542             sv_catpvn(retval, ", '", 3);
 543             sv_catpvn(retval, realpack, strlen(realpack));
 544             sv_catpvn(retval, "' )", 3);
 545             if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
 546                 sv_catpvn(retval, "->", 2);
 547                 sv_catsv(retval, toaster);
 548                 sv_catpvn(retval, "()", 2);
 549             }
 550         }
 551         SvREFCNT_dec(ipad);
 552         (*levelp)--;
 553     }
 554     else {
 555         STRLEN i;
 556
 557         if (namelen) {
 558             (void) sprintf(id, "0x%lx", (unsigned long)val);
 559             if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
 560                 (sv = *svp) && SvROK(sv) &&
 561                 (seenentry = (AV*)SvRV(sv)))
 562             {
 563                 SV *othername;
 564                 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
 565                     && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
 566                 {
 567                     sv_catpvn(retval, "${", 2);
 568                     sv_catsv(retval, othername);
 569                     sv_catpvn(retval, "}", 1);
 570                     return 1;
 571                 }
 572             }
 573             else {
 574                 SV *namesv;
 575                 namesv = newSVpvn("\\", 1);
 576                 sv_catpvn(namesv, name, namelen);
 577                 seenentry = newAV();
 578                 av_push(seenentry, namesv);
 579                 av_push(seenentry, newRV(val));
 580                 (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
 581                 SvREFCNT_dec(seenentry);
 582             }
 583         }
 584
 585         if (SvIOK(val)) {
 586             STRLEN len;
 587             if (SvIsUV(val))
 588               (void) sprintf(tmpbuf, "%"UVdf, SvUV(val));
 589             else
 590               (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
 591             len = strlen(tmpbuf);
 592             sv_catpvn(retval, tmpbuf, len);
 593         }
 594         else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
 595             c = SvPV(val, i);
 596             ++c; --i;                   /* just get the name */
 597             if (i >= 6 && strncmp(c, "main::", 6) == 0) {
 598                 c += 4;
 599                 i -= 4;
 600             }
 601             if (needs_quote(c)) {
 602                 sv_grow(retval, SvCUR(retval)+6+2*i);
 603                 r = SvPVX(retval)+SvCUR(retval);
 604                 r[0] = '*'; r[1] = '{'; r[2] = '\'';
 605                 i += esc_q(r+3, c, i);
 606                 i += 3;
 607                 r[i++] = '\''; r[i++] = '}';
 608                 r[i] = '\0';
 609             }
 610             else {
 611                 sv_grow(retval, SvCUR(retval)+i+2);
 612                 r = SvPVX(retval)+SvCUR(retval);
 613                 r[0] = '*'; strcpy(r+1, c);
 614                 i++;
 615             }
 616             SvCUR_set(retval, SvCUR(retval)+i);
 617
 618             if (purity) {
 619                 static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
 620                 static STRLEN sizes[] = { 8, 7, 6 };
 621                 SV *e;
 622                 SV *nname = newSVpvn("", 0);
 623                 SV *newapad = newSVpvn("", 0);
 624                 GV *gv = (GV*)val;
 625                 I32 j;
 626
 627                 for (j=0; j<3; j++) {
 628                     e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
 629                     if (!e)
 630                         continue;
 631                     if (j == 0 && !SvOK(e))
 632                         continue;
 633
 634                     {
 635                         I32 nlevel = 0;
 636                         SV *postentry = newSVpvn(r,i);
 637
 638                         sv_setsv(nname, postentry);
 639                         sv_catpvn(nname, entries[j], sizes[j]);
 640                         sv_catpvn(postentry, " = ", 3);
 641                         av_push(postav, postentry);
 642                         e = newRV(e);
 643
 644                         SvCUR(newapad) = 0;
 645                         if (indent >= 2)
 646                             (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
 647
 648                         DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
 649                                 seenhv, postav, &nlevel, indent, pad, xpad,
 650                                 newapad, sep, freezer, toaster, purity,
 651                                 deepcopy, quotekeys, bless, maxdepth);
 652                         SvREFCNT_dec(e);
 653                     }
 654                 }
 655
 656                 SvREFCNT_dec(newapad);
 657                 SvREFCNT_dec(nname);
 658             }
 659         }
 660         else if (val == &PL_sv_undef || !SvOK(val)) {
 661             sv_catpvn(retval, "undef", 5);
 662         }
 663         else {
 664             c = SvPV(val, i);
 665             sv_grow(retval, SvCUR(retval)+3+2*i);
 666             r = SvPVX(retval)+SvCUR(retval);
 667             r[0] = '\'';
 668             i += esc_q(r+1, c, i);
 669             ++i;
 670             r[i++] = '\'';
 671             r[i] = '\0';
 672             SvCUR_set(retval, SvCUR(retval)+i);
 673         }
 674     }
 675
 676     if (idlen) {
 677         if (deepcopy)
 678             (void)hv_delete(seenhv, id, idlen, G_DISCARD);
 679         else if (namelen && seenentry) {
 680             SV *mark = *av_fetch(seenentry, 2, TRUE);
 681             sv_setiv(mark,1);
 682         }
 683     }
 684     return 1;
 685 }
 686
 687
 688 MODULE = Data::Dumper           PACKAGE = Data::Dumper         PREFIX = Data_Dumper_
 689
 690 #
 691 # This is the exact equivalent of Dump.  Well, almost. The things that are
 692 # different as of now (due to Laziness):
 693 #   * doesnt do double-quotes yet.
 694 #
 695
 696 void
 697 Data_Dumper_Dumpxs(href, ...)
 698         SV      *href;
 699         PROTOTYPE: $;$$
 700         PPCODE:
 701         {
 702             HV *hv;
 703             SV *retval, *valstr;
 704             HV *seenhv = Nullhv;
 705             AV *postav, *todumpav, *namesav;
 706             I32 level = 0;
 707             I32 indent, terse, useqq, i, imax, postlen;
 708             SV **svp;
 709             SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname;
 710             SV *freezer, *toaster, *bless;
 711             I32 purity, deepcopy, quotekeys, maxdepth = 0;
 712             char tmpbuf[1024];
 713             I32 gimme = GIMME;
 714
 715             if (!SvROK(href)) {         /* call new to get an object first */
 716                 if (items < 2)
 717                     croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
 718
 719                 ENTER;
 720                 SAVETMPS;
 721
 722                 PUSHMARK(sp);
 723                 XPUSHs(href);
 724                 XPUSHs(sv_2mortal(newSVsv(ST(1))));
 725                 if (items >= 3)
 726                     XPUSHs(sv_2mortal(newSVsv(ST(2))));
 727                 PUTBACK;
 728                 i = perl_call_method("new", G_SCALAR);
 729                 SPAGAIN;
 730                 if (i)
 731                     href = newSVsv(POPs);
 732
 733                 PUTBACK;
 734                 FREETMPS;
 735                 LEAVE;
 736                 if (i)
 737                     (void)sv_2mortal(href);
 738             }
 739
 740             todumpav = namesav = Nullav;
 741             seenhv = Nullhv;
 742             val = pad = xpad = apad = sep = tmp = varname
 743                 = freezer = toaster = bless = &PL_sv_undef;
 744             name = sv_newmortal();
 745             indent = 2;
 746             terse = useqq = purity = deepcopy = 0;
 747             quotekeys = 1;
 748
 749             retval = newSVpvn("", 0);
 750             if (SvROK(href)
 751                 && (hv = (HV*)SvRV((SV*)href))
 752                 && SvTYPE(hv) == SVt_PVHV)              {
 753
 754                 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
 755                     seenhv = (HV*)SvRV(*svp);
 756                 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
 757                     todumpav = (AV*)SvRV(*svp);
 758                 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
 759                     namesav = (AV*)SvRV(*svp);
 760                 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
 761                     indent = SvIV(*svp);
 762                 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
 763                     purity = SvIV(*svp);
 764                 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
 765                     terse = SvTRUE(*svp);
 766                 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
 767                     useqq = SvTRUE(*svp);
 768                 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
 769                     pad = *svp;
 770                 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
 771                     xpad = *svp;
 772                 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
 773                     apad = *svp;
 774                 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
 775                     sep = *svp;
 776                 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
 777                     varname = *svp;
 778                 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
 779                     freezer = *svp;
 780                 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
 781                     toaster = *svp;
 782                 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
 783                     deepcopy = SvTRUE(*svp);
 784                 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
 785                     quotekeys = SvTRUE(*svp);
 786                 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
 787                     bless = *svp;
 788                 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
 789                     maxdepth = SvIV(*svp);
 790                 postav = newAV();
 791
 792                 if (todumpav)
 793                     imax = av_len(todumpav);
 794                 else
 795                     imax = -1;
 796                 valstr = newSVpvn("",0);
 797                 for (i = 0; i <= imax; ++i) {
 798                     SV *newapad;
 799
 800                     av_clear(postav);
 801                     if ((svp = av_fetch(todumpav, i, FALSE)))
 802                         val = *svp;
 803                     else
 804                         val = &PL_sv_undef;
 805                     if ((svp = av_fetch(namesav, i, TRUE)))
 806                         sv_setsv(name, *svp);
 807                     else
 808                         SvOK_off(name);
 809
 810                     if (SvOK(name)) {
 811                         if ((SvPVX(name))[0] == '*') {
 812                             if (SvROK(val)) {
 813                                 switch (SvTYPE(SvRV(val))) {
 814                                 case SVt_PVAV:
 815                                     (SvPVX(name))[0] = '@';
 816                                     break;
 817                                 case SVt_PVHV:
 818                                     (SvPVX(name))[0] = '%';
 819                                     break;
 820                                 case SVt_PVCV:
 821                                     (SvPVX(name))[0] = '*';
 822                                     break;
 823                                 default:
 824                                     (SvPVX(name))[0] = '$';
 825                                     break;
 826                                 }
 827                             }
 828                             else
 829                                 (SvPVX(name))[0] = '$';
 830                         }
 831                         else if ((SvPVX(name))[0] != '$')
 832                             sv_insert(name, 0, 0, "$", 1);
 833                     }
 834                     else {
 835                         STRLEN nchars = 0;
 836                         sv_setpvn(name, "$", 1);
 837                         sv_catsv(name, varname);
 838                         (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
 839                         nchars = strlen(tmpbuf);
 840                         sv_catpvn(name, tmpbuf, nchars);
 841                     }
 842
 843                     if (indent >= 2) {
 844                         SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
 845                         newapad = newSVsv(apad);
 846                         sv_catsv(newapad, tmpsv);
 847                         SvREFCNT_dec(tmpsv);
 848                     }
 849                     else
 850                         newapad = apad;
 851
 852                     DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
 853                             postav, &level, indent, pad, xpad, newapad, sep,
 854                             freezer, toaster, purity, deepcopy, quotekeys,
 855                             bless, maxdepth);
 856
 857                     if (indent >= 2)
 858                         SvREFCNT_dec(newapad);
 859
 860                     postlen = av_len(postav);
 861                     if (postlen >= 0 || !terse) {
 862                         sv_insert(valstr, 0, 0, " = ", 3);
 863                         sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
 864                         sv_catpvn(valstr, ";", 1);
 865                     }
 866                     sv_catsv(retval, pad);
 867                     sv_catsv(retval, valstr);
 868                     sv_catsv(retval, sep);
 869                     if (postlen >= 0) {
 870                         I32 i;
 871                         sv_catsv(retval, pad);
 872                         for (i = 0; i <= postlen; ++i) {
 873                             SV *elem;
 874                             svp = av_fetch(postav, i, FALSE);
 875                             if (svp && (elem = *svp)) {
 876                                 sv_catsv(retval, elem);
 877                                 if (i < postlen) {
 878                                     sv_catpvn(retval, ";", 1);
 879                                     sv_catsv(retval, sep);
 880                                     sv_catsv(retval, pad);
 881                                 }
 882                             }
 883                         }
 884                         sv_catpvn(retval, ";", 1);
 885                             sv_catsv(retval, sep);
 886                     }
 887                     sv_setpvn(valstr, "", 0);
 888                     if (gimme == G_ARRAY) {
 889                         XPUSHs(sv_2mortal(retval));
 890                         if (i < imax)   /* not the last time thro ? */
 891                             retval = newSVpvn("",0);
 892                     }
 893                 }
 894                 SvREFCNT_dec(postav);
 895                 SvREFCNT_dec(valstr);
 896             }
 897             else
 898                 croak("Call to new() method failed to return HASH ref");
 899             if (gimme == G_SCALAR)
 900                 XPUSHs(sv_2mortal(retval));
 901         }