ext/Data/Dumper/Dumper.xs

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