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