line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
#define PERL_NO_GET_CONTEXT |
2
|
|
|
|
|
|
#include "EXTERN.h" |
3
|
|
|
|
|
|
#include "perl.h" |
4
|
|
|
|
|
|
#include "XSUB.h" |
5
|
|
|
|
|
|
|
6
|
|
|
|
|
|
static bool |
7
|
|
|
|
|
|
_runops_debug(int flag) |
8
|
|
|
|
|
|
{ |
9
|
|
|
|
|
|
dTHX; |
10
|
0
|
|
|
|
|
const bool d = PL_runops == Perl_runops_debug; |
11
|
|
|
|
|
|
|
12
|
0
|
|
|
|
|
if (flag >= 0) |
13
|
0
|
|
|
|
|
PL_runops = flag ? Perl_runops_debug : Perl_runops_standard; |
14
|
|
|
|
|
|
return d; |
15
|
|
|
|
|
|
} |
16
|
|
|
|
|
|
|
17
|
|
|
|
|
|
static SV * |
18
|
0
|
|
|
|
|
DeadCode(pTHX) |
19
|
|
|
|
|
|
{ |
20
|
|
|
|
|
|
#ifdef PURIFY |
21
|
|
|
|
|
|
return Nullsv; |
22
|
|
|
|
|
|
#else |
23
|
|
|
|
|
|
SV* sva; |
24
|
|
|
|
|
|
SV* sv; |
25
|
0
|
|
|
|
|
SV* ret = newRV_noinc((SV*)newAV()); |
26
|
|
|
|
|
|
SV* svend; |
27
|
|
|
|
|
|
int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; |
28
|
|
|
|
|
|
|
29
|
0
|
|
|
|
|
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { |
30
|
0
|
|
|
|
|
svend = &sva[SvREFCNT(sva)]; |
31
|
0
|
|
|
|
|
for (sv = sva + 1; sv < svend; ++sv) { |
32
|
0
|
|
|
|
|
if (SvTYPE(sv) == SVt_PVCV) { |
33
|
|
|
|
|
|
CV *cv = (CV*)sv; |
34
|
0
|
|
|
|
|
PADLIST* padlist = CvPADLIST(cv); |
35
|
|
|
|
|
|
AV *argav; |
36
|
|
|
|
|
|
SV** svp; |
37
|
|
|
|
|
|
SV** pad; |
38
|
|
|
|
|
|
int i = 0, j, levelm, totm = 0, levelref, totref = 0; |
39
|
|
|
|
|
|
int levels, tots = 0, levela, tota = 0, levelas, totas = 0; |
40
|
|
|
|
|
|
int dumpit = 0; |
41
|
|
|
|
|
|
|
42
|
0
|
|
|
|
|
if (CvISXSUB(sv)) { |
43
|
0
|
|
|
|
|
continue; /* XSUB */ |
44
|
|
|
|
|
|
} |
45
|
0
|
|
|
|
|
if (!CvGV(sv)) { |
46
|
0
|
|
|
|
|
continue; /* file-level scope. */ |
47
|
|
|
|
|
|
} |
48
|
0
|
|
|
|
|
if (!CvROOT(cv)) { |
49
|
|
|
|
|
|
/* PerlIO_printf(Perl_debug_log, " no root?!\n"); */ |
50
|
0
|
|
|
|
|
continue; /* autoloading stub. */ |
51
|
|
|
|
|
|
} |
52
|
0
|
|
|
|
|
do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv)); |
53
|
0
|
|
|
|
|
if (CvDEPTH(cv)) { |
54
|
0
|
|
|
|
|
PerlIO_printf(Perl_debug_log, " busy\n"); |
55
|
0
|
|
|
|
|
continue; |
56
|
|
|
|
|
|
} |
57
|
0
|
|
|
|
|
svp = (SV**) PadlistARRAY(padlist); |
58
|
0
|
|
|
|
|
while (++i <= PadlistMAX(padlist)) { /* Depth. */ |
59
|
|
|
|
|
|
SV **args; |
60
|
|
|
|
|
|
|
61
|
0
|
|
|
|
|
if (!svp[i]) continue; |
62
|
0
|
|
|
|
|
pad = AvARRAY((AV*)svp[i]); |
63
|
0
|
|
|
|
|
argav = (AV*)pad[0]; |
64
|
0
|
|
|
|
|
if (!argav || (SV*)argav == &PL_sv_undef) { |
65
|
0
|
|
|
|
|
PerlIO_printf(Perl_debug_log, " closure-template\n"); |
66
|
0
|
|
|
|
|
continue; |
67
|
|
|
|
|
|
} |
68
|
0
|
|
|
|
|
args = AvARRAY(argav); |
69
|
|
|
|
|
|
levelm = levels = levelref = levelas = 0; |
70
|
0
|
|
|
|
|
levela = sizeof(SV*) * (AvMAX(argav) + 1); |
71
|
0
|
|
|
|
|
if (AvREAL(argav)) { |
72
|
0
|
|
|
|
|
for (j = 0; j < AvFILL(argav); j++) { |
73
|
0
|
|
|
|
|
if (SvROK(args[j])) { |
74
|
0
|
|
|
|
|
PerlIO_printf(Perl_debug_log, " ref in args!\n"); |
75
|
0
|
|
|
|
|
levelref++; |
76
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
/* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ |
78
|
0
|
|
|
|
|
else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { |
79
|
0
|
|
|
|
|
levelas += SvLEN(args[j])/SvREFCNT(args[j]); |
80
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
} |
83
|
0
|
|
|
|
|
for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ |
84
|
0
|
|
|
|
|
if (!pad[j]) continue; |
85
|
0
|
|
|
|
|
if (SvROK(pad[j])) { |
86
|
0
|
|
|
|
|
levelref++; |
87
|
0
|
|
|
|
|
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); |
88
|
|
|
|
|
|
dumpit = 1; |
89
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
/* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ |
91
|
0
|
|
|
|
|
else if (SvTYPE(pad[j]) >= SVt_PVAV) { |
92
|
0
|
|
|
|
|
if (!SvPADMY(pad[j])) { |
93
|
0
|
|
|
|
|
levelref++; |
94
|
0
|
|
|
|
|
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); |
95
|
|
|
|
|
|
dumpit = 1; |
96
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
} |
98
|
0
|
|
|
|
|
else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { |
99
|
0
|
|
|
|
|
levels++; |
100
|
0
|
|
|
|
|
levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); |
101
|
|
|
|
|
|
/* Dump(pad[j],4); */ |
102
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
} |
104
|
0
|
|
|
|
|
PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", |
105
|
|
|
|
|
|
i, levelref, levelm, levels, levela, levelas); |
106
|
0
|
|
|
|
|
totm += levelm; |
107
|
0
|
|
|
|
|
tota += levela; |
108
|
0
|
|
|
|
|
totas += levelas; |
109
|
0
|
|
|
|
|
tots += levels; |
110
|
0
|
|
|
|
|
totref += levelref; |
111
|
0
|
|
|
|
|
if (dumpit) |
112
|
0
|
|
|
|
|
do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); |
113
|
|
|
|
|
|
} |
114
|
0
|
|
|
|
|
if (PadlistMAX(padlist) > 1) { |
115
|
0
|
|
|
|
|
PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", |
116
|
|
|
|
|
|
totref, totm, tots, tota, totas); |
117
|
|
|
|
|
|
} |
118
|
0
|
|
|
|
|
tref += totref; |
119
|
0
|
|
|
|
|
tm += totm; |
120
|
0
|
|
|
|
|
ts += tots; |
121
|
0
|
|
|
|
|
ta += tota; |
122
|
0
|
|
|
|
|
tas += totas; |
123
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
} |
126
|
0
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); |
127
|
|
|
|
|
|
|
128
|
0
|
|
|
|
|
return ret; |
129
|
|
|
|
|
|
#endif /* !PURIFY */ |
130
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
132
|
|
|
|
|
|
#if defined(MYMALLOC) |
133
|
|
|
|
|
|
# define mstat(str) dump_mstats(str) |
134
|
|
|
|
|
|
#else |
135
|
|
|
|
|
|
# define mstat(str) \ |
136
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "%s: perl not compiled with MYMALLOC\n",str); |
137
|
|
|
|
|
|
#endif |
138
|
|
|
|
|
|
|
139
|
|
|
|
|
|
#if defined(MYMALLOC) |
140
|
|
|
|
|
|
|
141
|
|
|
|
|
|
/* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ |
142
|
|
|
|
|
|
# define _NBUCKETS (2*8*IVSIZE+1) |
143
|
|
|
|
|
|
|
144
|
|
|
|
|
|
struct mstats_buffer |
145
|
|
|
|
|
|
{ |
146
|
|
|
|
|
|
perl_mstats_t buffer; |
147
|
|
|
|
|
|
UV buf[_NBUCKETS*4]; |
148
|
|
|
|
|
|
}; |
149
|
|
|
|
|
|
|
150
|
|
|
|
|
|
static void |
151
|
|
|
|
|
|
_fill_mstats(struct mstats_buffer *b, int level) |
152
|
|
|
|
|
|
{ |
153
|
|
|
|
|
|
dTHX; |
154
|
|
|
|
|
|
b->buffer.nfree = b->buf; |
155
|
|
|
|
|
|
b->buffer.ntotal = b->buf + _NBUCKETS; |
156
|
|
|
|
|
|
b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; |
157
|
|
|
|
|
|
b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; |
158
|
|
|
|
|
|
Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); |
159
|
|
|
|
|
|
get_mstats(&(b->buffer), _NBUCKETS, level); |
160
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
162
|
|
|
|
|
|
static void |
163
|
|
|
|
|
|
fill_mstats(SV *sv, int level) |
164
|
|
|
|
|
|
{ |
165
|
|
|
|
|
|
dTHX; |
166
|
|
|
|
|
|
|
167
|
|
|
|
|
|
if (SvREADONLY(sv)) |
168
|
|
|
|
|
|
croak("Cannot modify a readonly value"); |
169
|
|
|
|
|
|
sv_grow(sv, sizeof(struct mstats_buffer)+1); |
170
|
|
|
|
|
|
_fill_mstats((struct mstats_buffer*)SvPVX(sv),level); |
171
|
|
|
|
|
|
SvCUR_set(sv, sizeof(struct mstats_buffer)); |
172
|
|
|
|
|
|
*SvEND(sv) = '\0'; |
173
|
|
|
|
|
|
SvPOK_only(sv); |
174
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
176
|
|
|
|
|
|
static void |
177
|
|
|
|
|
|
_mstats_to_hv(HV *hv, const struct mstats_buffer *b, int level) |
178
|
|
|
|
|
|
{ |
179
|
|
|
|
|
|
dTHX; |
180
|
|
|
|
|
|
SV **svp; |
181
|
|
|
|
|
|
int type; |
182
|
|
|
|
|
|
|
183
|
|
|
|
|
|
svp = hv_fetch(hv, "topbucket", 9, 1); |
184
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.topbucket); |
185
|
|
|
|
|
|
|
186
|
|
|
|
|
|
svp = hv_fetch(hv, "topbucket_ev", 12, 1); |
187
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.topbucket_ev); |
188
|
|
|
|
|
|
|
189
|
|
|
|
|
|
svp = hv_fetch(hv, "topbucket_odd", 13, 1); |
190
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.topbucket_odd); |
191
|
|
|
|
|
|
|
192
|
|
|
|
|
|
svp = hv_fetch(hv, "totfree", 7, 1); |
193
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.totfree); |
194
|
|
|
|
|
|
|
195
|
|
|
|
|
|
svp = hv_fetch(hv, "total", 5, 1); |
196
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.total); |
197
|
|
|
|
|
|
|
198
|
|
|
|
|
|
svp = hv_fetch(hv, "total_chain", 11, 1); |
199
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.total_chain); |
200
|
|
|
|
|
|
|
201
|
|
|
|
|
|
svp = hv_fetch(hv, "total_sbrk", 10, 1); |
202
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.total_sbrk); |
203
|
|
|
|
|
|
|
204
|
|
|
|
|
|
svp = hv_fetch(hv, "sbrks", 5, 1); |
205
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.sbrks); |
206
|
|
|
|
|
|
|
207
|
|
|
|
|
|
svp = hv_fetch(hv, "sbrk_good", 9, 1); |
208
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.sbrk_good); |
209
|
|
|
|
|
|
|
210
|
|
|
|
|
|
svp = hv_fetch(hv, "sbrk_slack", 10, 1); |
211
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.sbrk_slack); |
212
|
|
|
|
|
|
|
213
|
|
|
|
|
|
svp = hv_fetch(hv, "start_slack", 11, 1); |
214
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.start_slack); |
215
|
|
|
|
|
|
|
216
|
|
|
|
|
|
svp = hv_fetch(hv, "sbrked_remains", 14, 1); |
217
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.sbrked_remains); |
218
|
|
|
|
|
|
|
219
|
|
|
|
|
|
svp = hv_fetch(hv, "minbucket", 9, 1); |
220
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.minbucket); |
221
|
|
|
|
|
|
|
222
|
|
|
|
|
|
svp = hv_fetch(hv, "nbuckets", 8, 1); |
223
|
|
|
|
|
|
sv_setiv(*svp, b->buffer.nbuckets); |
224
|
|
|
|
|
|
|
225
|
|
|
|
|
|
if (_NBUCKETS < b->buffer.nbuckets) |
226
|
|
|
|
|
|
warn("FIXME: internal mstats buffer too short"); |
227
|
|
|
|
|
|
|
228
|
|
|
|
|
|
for (type = 0; type < (level ? 4 : 2); type++) { |
229
|
|
|
|
|
|
UV *p = 0, *p1 = 0, i; |
230
|
|
|
|
|
|
AV *av; |
231
|
|
|
|
|
|
static const char *types[4] = { |
232
|
|
|
|
|
|
"free", "used", "mem_size", "available_size" |
233
|
|
|
|
|
|
}; |
234
|
|
|
|
|
|
|
235
|
|
|
|
|
|
svp = hv_fetch(hv, types[type], strlen(types[type]), 1); |
236
|
|
|
|
|
|
|
237
|
|
|
|
|
|
if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) |
238
|
|
|
|
|
|
croak("Unexpected value for the key '%s' in the mstats hash", types[type]); |
239
|
|
|
|
|
|
if (!SvOK(*svp)) { |
240
|
|
|
|
|
|
av = newAV(); |
241
|
|
|
|
|
|
(void)SvUPGRADE(*svp, SVt_RV); |
242
|
|
|
|
|
|
SvRV_set(*svp, (SV*)av); |
243
|
|
|
|
|
|
SvROK_on(*svp); |
244
|
|
|
|
|
|
} else |
245
|
|
|
|
|
|
av = (AV*)SvRV(*svp); |
246
|
|
|
|
|
|
|
247
|
|
|
|
|
|
av_extend(av, b->buffer.nbuckets - 1); |
248
|
|
|
|
|
|
/* XXXX What is the official way to reduce the size of the array? */ |
249
|
|
|
|
|
|
switch (type) { |
250
|
|
|
|
|
|
case 0: |
251
|
|
|
|
|
|
p = b->buffer.nfree; |
252
|
|
|
|
|
|
break; |
253
|
|
|
|
|
|
case 1: |
254
|
|
|
|
|
|
p = b->buffer.ntotal; |
255
|
|
|
|
|
|
p1 = b->buffer.nfree; |
256
|
|
|
|
|
|
break; |
257
|
|
|
|
|
|
case 2: |
258
|
|
|
|
|
|
p = b->buffer.bucket_mem_size; |
259
|
|
|
|
|
|
break; |
260
|
|
|
|
|
|
case 3: |
261
|
|
|
|
|
|
p = b->buffer.bucket_available_size; |
262
|
|
|
|
|
|
break; |
263
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
for (i = 0; i < b->buffer.nbuckets; i++) { |
265
|
|
|
|
|
|
svp = av_fetch(av, i, 1); |
266
|
|
|
|
|
|
if (type == 1) |
267
|
|
|
|
|
|
sv_setiv(*svp, p[i]-p1[i]); |
268
|
|
|
|
|
|
else |
269
|
|
|
|
|
|
sv_setuv(*svp, p[i]); |
270
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
274
|
|
|
|
|
|
static void |
275
|
|
|
|
|
|
mstats_fillhash(SV *sv, int level) |
276
|
|
|
|
|
|
{ |
277
|
|
|
|
|
|
struct mstats_buffer buf; |
278
|
|
|
|
|
|
|
279
|
|
|
|
|
|
if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) |
280
|
|
|
|
|
|
croak("Not a hash reference"); |
281
|
|
|
|
|
|
_fill_mstats(&buf, level); |
282
|
|
|
|
|
|
_mstats_to_hv((HV *)SvRV(sv), &buf, level); |
283
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
285
|
|
|
|
|
|
static void |
286
|
|
|
|
|
|
mstats2hash(SV *sv, SV *rv, int level) |
287
|
|
|
|
|
|
{ |
288
|
|
|
|
|
|
if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV)) |
289
|
|
|
|
|
|
croak("Not a hash reference"); |
290
|
|
|
|
|
|
if (!SvPOK(sv)) |
291
|
|
|
|
|
|
croak("Undefined value when expecting mstats buffer"); |
292
|
|
|
|
|
|
if (SvCUR(sv) != sizeof(struct mstats_buffer)) |
293
|
|
|
|
|
|
croak("Wrong size for a value with a mstats buffer"); |
294
|
|
|
|
|
|
_mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level); |
295
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
#else /* defined(MYMALLOC) */ |
297
|
|
|
|
|
|
static void |
298
|
0
|
|
|
|
|
fill_mstats(SV *sv, int level) |
299
|
|
|
|
|
|
{ |
300
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
301
|
|
|
|
|
|
PERL_UNUSED_ARG(level); |
302
|
0
|
|
|
|
|
croak("Cannot report mstats without Perl malloc"); |
303
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
305
|
|
|
|
|
|
static void |
306
|
0
|
|
|
|
|
mstats_fillhash(SV *sv, int level) |
307
|
|
|
|
|
|
{ |
308
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
309
|
|
|
|
|
|
PERL_UNUSED_ARG(level); |
310
|
0
|
|
|
|
|
croak("Cannot report mstats without Perl malloc"); |
311
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
313
|
|
|
|
|
|
static void |
314
|
0
|
|
|
|
|
mstats2hash(SV *sv, SV *rv, int level) |
315
|
|
|
|
|
|
{ |
316
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
317
|
|
|
|
|
|
PERL_UNUSED_ARG(rv); |
318
|
|
|
|
|
|
PERL_UNUSED_ARG(level); |
319
|
0
|
|
|
|
|
croak("Cannot report mstats without Perl malloc"); |
320
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
#endif /* defined(MYMALLOC) */ |
322
|
|
|
|
|
|
|
323
|
|
|
|
|
|
#define _CvGV(cv) \ |
324
|
|
|
|
|
|
(SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ |
325
|
|
|
|
|
|
? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) |
326
|
|
|
|
|
|
|
327
|
|
|
|
|
|
static void |
328
|
56
|
|
|
|
|
S_do_dump(pTHX_ SV *const sv, I32 lim) |
329
|
|
|
|
|
|
{ |
330
|
|
|
|
|
|
dVAR; |
331
|
56
|
|
|
|
|
SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0); |
332
|
56
|
|
|
|
|
const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; |
333
|
56
|
|
|
|
|
SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0); |
334
|
56
|
|
|
|
|
const U16 save_dumpindent = PL_dumpindent; |
335
|
56
|
|
|
|
|
PL_dumpindent = 2; |
336
|
56
|
|
|
|
|
do_sv_dump(0, Perl_debug_log, sv, 0, lim, |
337
|
|
|
|
|
|
(bool)(dumpop && SvTRUE(dumpop)), pv_lim); |
338
|
56
|
|
|
|
|
PL_dumpindent = save_dumpindent; |
339
|
56
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
341
|
|
|
|
|
|
static OP * |
342
|
56
|
|
|
|
|
S_pp_dump(pTHX) |
343
|
|
|
|
|
|
{ |
344
|
56
|
|
|
|
|
dSP; |
345
|
56
|
|
|
|
|
const I32 lim = PL_op->op_private == 2 ? (I32)POPi : 4; |
346
|
56
|
|
|
|
|
dPOPss; |
347
|
56
|
|
|
|
|
S_do_dump(aTHX_ sv, lim); |
348
|
56
|
|
|
|
|
RETPUSHUNDEF; |
349
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
351
|
|
|
|
|
|
static OP * |
352
|
6
|
|
|
|
|
S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) |
353
|
|
|
|
|
|
{ |
354
|
|
|
|
|
|
OP *aop, *prev, *first, *second = NULL; |
355
|
|
|
|
|
|
BINOP *newop; |
356
|
|
|
|
|
|
size_t arg = 0; |
357
|
|
|
|
|
|
|
358
|
6
|
|
|
|
|
ck_entersub_args_proto(entersubop, namegv, |
359
|
|
|
|
|
|
newSVpvn_flags("$;$", 3, SVs_TEMP)); |
360
|
|
|
|
|
|
|
361
|
6
|
|
|
|
|
aop = cUNOPx(entersubop)->op_first; |
362
|
6
|
|
|
|
|
if (!aop->op_sibling) |
363
|
6
|
|
|
|
|
aop = cUNOPx(aop)->op_first; |
364
|
|
|
|
|
|
prev = aop; |
365
|
6
|
|
|
|
|
aop = aop->op_sibling; |
366
|
|
|
|
|
|
while (PL_madskills && aop->op_type == OP_STUB) { |
367
|
|
|
|
|
|
prev = aop; |
368
|
|
|
|
|
|
aop = aop->op_sibling; |
369
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
if (PL_madskills && aop->op_type == OP_NULL) { |
371
|
|
|
|
|
|
first = ((UNOP*)aop)->op_first; |
372
|
|
|
|
|
|
((UNOP*)aop)->op_first = NULL; |
373
|
|
|
|
|
|
prev = aop; |
374
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
else { |
376
|
|
|
|
|
|
first = aop; |
377
|
6
|
|
|
|
|
prev->op_sibling = first->op_sibling; |
378
|
|
|
|
|
|
} |
379
|
6
|
|
|
|
|
if (first->op_type == OP_RV2AV || |
380
|
6
|
|
|
|
|
first->op_type == OP_PADAV || |
381
|
12
|
|
|
|
|
first->op_type == OP_RV2HV || |
382
|
6
|
|
|
|
|
first->op_type == OP_PADHV |
383
|
|
|
|
|
|
) |
384
|
0
|
|
|
|
|
first->op_flags |= OPf_REF; |
385
|
|
|
|
|
|
else |
386
|
6
|
|
|
|
|
first->op_flags &= ~OPf_MOD; |
387
|
6
|
|
|
|
|
aop = aop->op_sibling; |
388
|
|
|
|
|
|
while (PL_madskills && aop->op_type == OP_STUB) { |
389
|
|
|
|
|
|
prev = aop; |
390
|
|
|
|
|
|
aop = aop->op_sibling; |
391
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
/* aop now points to the second arg if there is one, the cvop otherwise |
393
|
|
|
|
|
|
*/ |
394
|
6
|
|
|
|
|
if (aop->op_sibling) { |
395
|
0
|
|
|
|
|
prev->op_sibling = aop->op_sibling; |
396
|
|
|
|
|
|
second = aop; |
397
|
0
|
|
|
|
|
second->op_sibling = NULL; |
398
|
|
|
|
|
|
} |
399
|
6
|
|
|
|
|
first->op_sibling = second; |
400
|
|
|
|
|
|
|
401
|
6
|
|
|
|
|
op_free(entersubop); |
402
|
|
|
|
|
|
|
403
|
6
|
|
|
|
|
NewOp(1234, newop, 1, BINOP); |
404
|
6
|
|
|
|
|
newop->op_type = OP_CUSTOM; |
405
|
6
|
|
|
|
|
newop->op_ppaddr = S_pp_dump; |
406
|
6
|
|
|
|
|
newop->op_first = first; |
407
|
6
|
|
|
|
|
newop->op_last = second; |
408
|
6
|
|
|
|
|
newop->op_private= second ? 2 : 1; |
409
|
6
|
|
|
|
|
newop->op_flags = OPf_KIDS|OPf_WANT_SCALAR; |
410
|
|
|
|
|
|
|
411
|
6
|
|
|
|
|
return (OP *)newop; |
412
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
414
|
|
|
|
|
|
static XOP my_xop; |
415
|
|
|
|
|
|
|
416
|
|
|
|
|
|
MODULE = Devel::Peek PACKAGE = Devel::Peek |
417
|
|
|
|
|
|
|
418
|
|
|
|
|
|
void |
419
|
|
|
|
|
|
mstat(str="Devel::Peek::mstat: ") |
420
|
|
|
|
|
|
const char *str |
421
|
|
|
|
|
|
|
422
|
|
|
|
|
|
void |
423
|
|
|
|
|
|
fill_mstats(SV *sv, int level = 0) |
424
|
|
|
|
|
|
|
425
|
|
|
|
|
|
void |
426
|
|
|
|
|
|
mstats_fillhash(SV *sv, int level = 0) |
427
|
|
|
|
|
|
PROTOTYPE: \%;$ |
428
|
|
|
|
|
|
|
429
|
|
|
|
|
|
void |
430
|
|
|
|
|
|
mstats2hash(SV *sv, SV *rv, int level = 0) |
431
|
|
|
|
|
|
PROTOTYPE: $\%;$ |
432
|
|
|
|
|
|
|
433
|
|
|
|
|
|
void |
434
|
|
|
|
|
|
Dump(sv,lim=4) |
435
|
|
|
|
|
|
SV * sv |
436
|
|
|
|
|
|
I32 lim |
437
|
|
|
|
|
|
PPCODE: |
438
|
|
|
|
|
|
{ |
439
|
0
|
|
|
|
|
S_do_dump(aTHX_ sv, lim); |
440
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
442
|
|
|
|
|
|
BOOT: |
443
|
|
|
|
|
|
{ |
444
|
8
|
|
|
|
|
CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0); |
445
|
8
|
|
|
|
|
cv_set_call_checker(cv, S_ck_dump, (SV *)cv); |
446
|
|
|
|
|
|
|
447
|
8
|
|
|
|
|
XopENTRY_set(&my_xop, xop_name, "Dump"); |
448
|
8
|
|
|
|
|
XopENTRY_set(&my_xop, xop_desc, "Dump"); |
449
|
8
|
|
|
|
|
XopENTRY_set(&my_xop, xop_class, OA_BINOP); |
450
|
8
|
|
|
|
|
Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop); |
451
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
453
|
|
|
|
|
|
void |
454
|
|
|
|
|
|
DumpArray(lim,...) |
455
|
|
|
|
|
|
I32 lim |
456
|
|
|
|
|
|
PPCODE: |
457
|
|
|
|
|
|
{ |
458
|
|
|
|
|
|
long i; |
459
|
0
|
|
|
|
|
SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0); |
460
|
0
|
|
|
|
|
const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; |
461
|
0
|
|
|
|
|
SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0); |
462
|
0
|
|
|
|
|
const U16 save_dumpindent = PL_dumpindent; |
463
|
0
|
|
|
|
|
PL_dumpindent = 2; |
464
|
|
|
|
|
|
|
465
|
0
|
|
|
|
|
for (i=1; i
|
466
|
0
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); |
467
|
0
|
|
|
|
|
do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, |
468
|
|
|
|
|
|
(bool)(dumpop && SvTRUE(dumpop)), pv_lim); |
469
|
|
|
|
|
|
} |
470
|
0
|
|
|
|
|
PL_dumpindent = save_dumpindent; |
471
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
473
|
|
|
|
|
|
void |
474
|
|
|
|
|
|
DumpProg() |
475
|
|
|
|
|
|
PPCODE: |
476
|
|
|
|
|
|
{ |
477
|
0
|
|
|
|
|
warn("dumpindent is %d", (int)PL_dumpindent); |
478
|
0
|
|
|
|
|
if (PL_main_root) |
479
|
0
|
|
|
|
|
op_dump(PL_main_root); |
480
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
482
|
|
|
|
|
|
U32 |
483
|
|
|
|
|
|
SvREFCNT(sv) |
484
|
|
|
|
|
|
SV * sv |
485
|
|
|
|
|
|
PROTOTYPE: \[$@%&*] |
486
|
|
|
|
|
|
CODE: |
487
|
0
|
|
|
|
|
RETVAL = SvREFCNT(SvRV(sv)) - 1; /* -1 because our ref doesn't count */ |
488
|
|
|
|
|
|
OUTPUT: |
489
|
|
|
|
|
|
RETVAL |
490
|
|
|
|
|
|
|
491
|
|
|
|
|
|
SV * |
492
|
|
|
|
|
|
DeadCode() |
493
|
|
|
|
|
|
CODE: |
494
|
0
|
|
|
|
|
RETVAL = DeadCode(aTHX); |
495
|
|
|
|
|
|
OUTPUT: |
496
|
|
|
|
|
|
RETVAL |
497
|
|
|
|
|
|
|
498
|
|
|
|
|
|
MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ |
499
|
|
|
|
|
|
|
500
|
|
|
|
|
|
SV * |
501
|
|
|
|
|
|
_CvGV(cv) |
502
|
|
|
|
|
|
SV *cv |
503
|
|
|
|
|
|
|
504
|
|
|
|
|
|
bool |
505
|
|
|
|
|
|
_runops_debug(int flag = -1) |