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