ext/Data/Dumper/Dumper.xs

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