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