ext/Data/Dumper/Dumper.xs

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