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