home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / ext / Devel / Peek / Peek.xs < prev   
Text File  |  2000-03-13  |  5KB  |  219 lines
  1. #define PERL_NO_GET_CONTEXT
  2. #include "EXTERN.h"
  3. #include "perl.h"
  4. #include "XSUB.h"
  5.  
  6. SV *
  7. DeadCode(pTHX)
  8. {
  9. #ifdef PURIFY
  10.     return Nullsv;
  11. #else
  12.     SV* sva;
  13.     SV* sv, *dbg;
  14.     SV* ret = newRV_noinc((SV*)newAV());
  15.     register SV* svend;
  16.     int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
  17.  
  18.     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
  19.     svend = &sva[SvREFCNT(sva)];
  20.     for (sv = sva + 1; sv < svend; ++sv) {
  21.         if (SvTYPE(sv) == SVt_PVCV) {
  22.         CV *cv = (CV*)sv;
  23.         AV* padlist = CvPADLIST(cv), *argav;
  24.         SV** svp;
  25.         SV** pad;
  26.         int i = 0, j, levelm, totm = 0, levelref, totref = 0;
  27.         int levels, tots = 0, levela, tota = 0, levelas, totas = 0;
  28.         int dumpit = 0;
  29.  
  30.         if (CvXSUB(sv)) {
  31.             continue;        /* XSUB */
  32.         }
  33.         if (!CvGV(sv)) {
  34.             continue;        /* file-level scope. */
  35.         }
  36.         if (!CvROOT(cv)) {
  37.             /* PerlIO_printf(Perl_debug_log, "  no root?!\n"); */
  38.             continue;        /* autoloading stub. */
  39.         }
  40.         do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
  41.         if (CvDEPTH(cv)) {
  42.             PerlIO_printf(Perl_debug_log, "  busy\n");
  43.             continue;
  44.         }
  45.         svp = AvARRAY(padlist);
  46.         while (++i <= AvFILL(padlist)) { /* Depth. */
  47.             SV **args;
  48.             
  49.             pad = AvARRAY((AV*)svp[i]);
  50.             argav = (AV*)pad[0];
  51.             if (!argav || (SV*)argav == &PL_sv_undef) {
  52.             PerlIO_printf(Perl_debug_log, "    closure-template\n");
  53.             continue;
  54.             }
  55.             args = AvARRAY(argav);
  56.             levelm = levels = levelref = levelas = 0;
  57.             levela = sizeof(SV*) * (AvMAX(argav) + 1);
  58.             if (AvREAL(argav)) {
  59.             for (j = 0; j < AvFILL(argav); j++) {
  60.                 if (SvROK(args[j])) {
  61.                 PerlIO_printf(Perl_debug_log, "     ref in args!\n");
  62.                 levelref++;
  63.                 }
  64.                 /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
  65.                 else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
  66.                 levelas += SvLEN(args[j])/SvREFCNT(args[j]);
  67.                 }
  68.             }
  69.             }
  70.             for (j = 1; j < AvFILL((AV*)svp[1]); j++) {    /* Vars. */
  71.             if (SvROK(pad[j])) {
  72.                 levelref++;
  73.                 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
  74.                 dumpit = 1;
  75.             }
  76.             /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */
  77.             else if (SvTYPE(pad[j]) >= SVt_PVAV) {
  78.                 if (!SvPADMY(pad[j])) {
  79.                 levelref++;
  80.                 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
  81.                 dumpit = 1;
  82.                 }
  83.             }
  84.             else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
  85.                 int db_len = SvLEN(pad[j]);
  86.                 SV *db_sv = pad[j];
  87.                 levels++;
  88.                 levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
  89.                 /* Dump(pad[j],4); */
  90.             }
  91.             }
  92.             PerlIO_printf(Perl_debug_log, "    level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", 
  93.                 i, levelref, levelm, levels, levela, levelas);
  94.             totm += levelm;
  95.             tota += levela;
  96.             totas += levelas;
  97.             tots += levels;
  98.             totref += levelref;
  99.             if (dumpit)
  100.             do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
  101.         }
  102.         if (AvFILL(padlist) > 1) {
  103.             PerlIO_printf(Perl_debug_log, "  total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", 
  104.                 totref, totm, tots, tota, totas);
  105.         }
  106.         tref += totref;
  107.         tm += totm;
  108.         ts += tots;
  109.         ta += tota;
  110.         tas += totas;
  111.         }
  112.     }
  113.     }
  114.     PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
  115.  
  116.     return ret;
  117. #endif /* !PURIFY */
  118. }
  119.  
  120. #if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \
  121.     || (defined(MYMALLOC) && !defined(PLAIN_MALLOC))
  122. #   define mstat(str) dump_mstats(str)
  123. #else
  124. #   define mstat(str) \
  125.     PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str);
  126. #endif
  127.  
  128. #define _CvGV(cv)                    \
  129.     (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV)    \
  130.      ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef)
  131.  
  132. MODULE = Devel::Peek        PACKAGE = Devel::Peek
  133.  
  134. void
  135. mstat(str="Devel::Peek::mstat: ")
  136. char *str
  137.  
  138. void
  139. Dump(sv,lim=4)
  140. SV *    sv
  141. I32    lim
  142. PPCODE:
  143. {
  144.     SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
  145.     STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
  146.     SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
  147.     I32 save_dumpindent = PL_dumpindent;
  148.     PL_dumpindent = 2;
  149.     do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
  150.     PL_dumpindent = save_dumpindent;
  151. }
  152.  
  153. void
  154. DumpArray(lim,...)
  155. I32    lim
  156. PPCODE:
  157. {
  158.     long i;
  159.     SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
  160.     STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
  161.     SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
  162.     I32 save_dumpindent = PL_dumpindent;
  163.     PL_dumpindent = 2;
  164.  
  165.     for (i=1; i<items; i++) {
  166.     PerlIO_printf(Perl_debug_log, "Elt No. %ld  0x%"UVxf"\n", i - 1, PTR2UV(ST(i)));
  167.     do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
  168.     }
  169.     PL_dumpindent = save_dumpindent;
  170. }
  171.  
  172. void
  173. DumpProg()
  174. PPCODE:
  175. {
  176.     warn("dumpindent is %d", PL_dumpindent);
  177.     if (PL_main_root)
  178.     op_dump(PL_main_root);
  179. }
  180.  
  181. I32
  182. SvREFCNT(sv)
  183. SV *    sv
  184.  
  185. # PPCODE needed since otherwise sv_2mortal is inserted that will kill the value.
  186.  
  187. SV *
  188. SvREFCNT_inc(sv)
  189. SV *    sv
  190. PPCODE:
  191. {
  192.     RETVAL = SvREFCNT_inc(sv);
  193.     PUSHs(RETVAL);
  194. }
  195.  
  196. # PPCODE needed since by default it is void
  197.  
  198. SV *
  199. SvREFCNT_dec(sv)
  200. SV *    sv
  201. PPCODE:
  202. {
  203.     SvREFCNT_dec(sv);
  204.     PUSHs(sv);
  205. }
  206.  
  207. SV *
  208. DeadCode()
  209. CODE:
  210.     RETVAL = DeadCode(aTHX);
  211. OUTPUT:
  212.     RETVAL
  213.  
  214. MODULE = Devel::Peek        PACKAGE = Devel::Peek    PREFIX = _
  215.  
  216. SV *
  217. _CvGV(cv)
  218.     SV *cv
  219.