This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make die/warn and other diagnostics go to wherever STDERR happens
[perl5.git] / ext / Devel / Peek / Peek.xs
CommitLineData
c5be433b 1#define PERL_NO_GET_CONTEXT
3967c732
JD
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
6#ifdef PURIFY
7#define DeadCode() NULL
8#else
9SV *
cea2e8a9 10DeadCode(pTHX)
3967c732
JD
11{
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)) {
bf49b057 37 /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */
3967c732
JD
38 continue; /* autoloading stub. */
39 }
bf49b057 40 do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
3967c732 41 if (CvDEPTH(cv)) {
bf49b057 42 PerlIO_printf(Perl_debug_log, " busy\n");
3967c732
JD
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) {
bf49b057 52 PerlIO_printf(Perl_debug_log, " closure-template\n");
3967c732
JD
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])) {
bf49b057 61 PerlIO_printf(Perl_debug_log, " ref in args!\n");
3967c732
JD
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++;
bf49b057 73 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
3967c732
JD
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++;
bf49b057 80 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
3967c732
JD
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 }
bf49b057 92 PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n",
3967c732
JD
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)
bf49b057 100 do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
3967c732
JD
101 }
102 if (AvFILL(padlist) > 1) {
bf49b057 103 PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n",
3967c732
JD
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 }
bf49b057 114 PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
3967c732
JD
115
116 return ret;
117}
118#endif /* !PURIFY */
119
df1e65fb
IZ
120#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \
121 || (defined(MYMALLOC) && !defined(PLAIN_MALLOC))
3967c732
JD
122# define mstat(str) dump_mstats(str)
123#else
124# define mstat(str) \
bf49b057 125 PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str);
3967c732
JD
126#endif
127
128MODULE = Devel::Peek PACKAGE = Devel::Peek
129
130void
131mstat(str="Devel::Peek::mstat: ")
132char *str
133
134void
135Dump(sv,lim=4)
136SV * sv
137I32 lim
138PPCODE:
139{
140 SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
141 STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
142 SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
143 I32 save_dumpindent = PL_dumpindent;
144 PL_dumpindent = 2;
bf49b057 145 do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
3967c732
JD
146 PL_dumpindent = save_dumpindent;
147}
148
149void
150DumpArray(lim,...)
151I32 lim
152PPCODE:
153{
154 long i;
155 SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
156 STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
157 SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
158 I32 save_dumpindent = PL_dumpindent;
159 PL_dumpindent = 2;
160
161 for (i=1; i<items; i++) {
bf49b057
GS
162 PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%lx\n", i - 1, ST(i));
163 do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
3967c732
JD
164 }
165 PL_dumpindent = save_dumpindent;
166}
167
168void
169DumpProg()
170PPCODE:
171{
172 warn("dumpindent is %d", PL_dumpindent);
173 if (PL_main_root)
174 op_dump(PL_main_root);
175}
176
177I32
178SvREFCNT(sv)
179SV * sv
180
181# PPCODE needed since otherwise sv_2mortal is inserted that will kill the value.
182
183SV *
184SvREFCNT_inc(sv)
185SV * sv
186PPCODE:
187{
188 RETVAL = SvREFCNT_inc(sv);
189 PUSHs(RETVAL);
190}
191
192# PPCODE needed since by default it is void
193
194SV *
195SvREFCNT_dec(sv)
196SV * sv
197PPCODE:
198{
199 SvREFCNT_dec(sv);
200 PUSHs(sv);
201}
202
203SV *
204DeadCode()
cea2e8a9
GS
205CODE:
206 RETVAL = DeadCode(aTHX);
207OUTPUT:
208 RETVAL