ext/Data/Dumper/Dumper.xs

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