This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
reference miscount in Devel::Peek that causes debugger to
[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
3967c732 6SV *
cea2e8a9 7DeadCode(pTHX)
3967c732 8{
8ecf7187
GS
9#ifdef PURIFY
10 return Nullsv;
11#else
3967c732
JD
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;
3967c732 117#endif /* !PURIFY */
8ecf7187 118}
3967c732 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
83ee9e09
GS
128#define _CvGV(cv) \
129 (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \
15bcf759 130 ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef)
83ee9e09 131
3967c732
JD
132MODULE = Devel::Peek PACKAGE = Devel::Peek
133
134void
135mstat(str="Devel::Peek::mstat: ")
136char *str
137
138void
139Dump(sv,lim=4)
140SV * sv
141I32 lim
142PPCODE:
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;
bf49b057 149 do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
3967c732
JD
150 PL_dumpindent = save_dumpindent;
151}
152
153void
154DumpArray(lim,...)
155I32 lim
156PPCODE:
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++) {
7b0972df 166 PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i)));
bf49b057 167 do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
3967c732
JD
168 }
169 PL_dumpindent = save_dumpindent;
170}
171
172void
173DumpProg()
174PPCODE:
175{
176 warn("dumpindent is %d", PL_dumpindent);
177 if (PL_main_root)
178 op_dump(PL_main_root);
179}
180
181I32
182SvREFCNT(sv)
183SV * sv
184
185# PPCODE needed since otherwise sv_2mortal is inserted that will kill the value.
186
187SV *
188SvREFCNT_inc(sv)
189SV * sv
190PPCODE:
191{
192 RETVAL = SvREFCNT_inc(sv);
193 PUSHs(RETVAL);
194}
195
196# PPCODE needed since by default it is void
197
198SV *
199SvREFCNT_dec(sv)
200SV * sv
201PPCODE:
202{
203 SvREFCNT_dec(sv);
204 PUSHs(sv);
205}
206
207SV *
208DeadCode()
cea2e8a9
GS
209CODE:
210 RETVAL = DeadCode(aTHX);
211OUTPUT:
212 RETVAL
83ee9e09
GS
213
214MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _
215
216SV *
217_CvGV(cv)
218 SV *cv