Commit | Line | Data |
a798dbf2 |
1 | package B::Debug; |
28b605d8 |
2 | |
93f00e88 |
3 | our $VERSION = '1.06'; |
28b605d8 |
4 | |
a798dbf2 |
5 | use strict; |
6 | use B qw(peekop class walkoptree walkoptree_exec |
93f00e88 |
7 | main_start main_root cstring sv_undef); |
8 | our (@optype, @specialsv_name); |
9 | require B; |
10 | if ($] < 5.009) { |
11 | require B::Asmdata; |
12 | B::Asmdata->import qw(@optype @specialsv_name); |
13 | } else { |
14 | B->import qw(@optype @specialsv_name); |
15 | } |
16 | my $have_B_Flags; |
17 | eval { require B::Flags and $have_B_Flags++ }; |
c1307613 |
18 | BEGIN { |
19 | use Config; |
20 | my $ithreads = $Config{'useithreads'} eq 'define'; |
21 | eval qq{ |
22 | sub ITHREADS() { $ithreads } |
23 | sub VERSION() { $] } |
24 | }; die $@ if $@; |
25 | } |
a798dbf2 |
26 | |
27 | my %done_gv; |
28 | |
c1307613 |
29 | sub _printop { |
30 | my $op = shift; |
31 | my $addr = ${$op} ? $op->ppaddr : ''; |
32 | $addr =~ s/^PL_ppaddr// if $addr; |
33 | return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr; |
34 | } |
35 | |
a798dbf2 |
36 | sub B::OP::debug { |
37 | my ($op) = @_; |
c1307613 |
38 | printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type; |
a798dbf2 |
39 | %s (0x%lx) |
a798dbf2 |
40 | op_ppaddr %s |
c1307613 |
41 | op_next %s |
42 | op_sibling %s |
a798dbf2 |
43 | op_targ %d |
44 | op_type %d |
7252851f |
45 | EOT |
93f00e88 |
46 | if (VERSION > 5.009) { |
85594c31 |
47 | printf <<'EOT', $op->opt; |
2814eb74 |
48 | op_opt %d |
7252851f |
49 | EOT |
50 | } else { |
51 | printf <<'EOT', $op->seq; |
52 | op_seq %d |
53 | EOT |
54 | } |
93f00e88 |
55 | if ($have_B_Flags) { |
56 | printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv; |
57 | op_flags %d %s |
58 | op_private %d %s |
59 | EOT |
60 | } else { |
61 | printf <<'EOT', $op->flags, $op->private; |
a798dbf2 |
62 | op_flags %d |
63 | op_private %d |
64 | EOT |
93f00e88 |
65 | } |
a798dbf2 |
66 | } |
67 | |
68 | sub B::UNOP::debug { |
69 | my ($op) = @_; |
70 | $op->B::OP::debug(); |
c1307613 |
71 | printf "\top_first\t%s\n", _printop($op->first); |
a798dbf2 |
72 | } |
73 | |
74 | sub B::BINOP::debug { |
75 | my ($op) = @_; |
76 | $op->B::UNOP::debug(); |
c1307613 |
77 | printf "\top_last \t%s\n", _printop($op->last); |
a798dbf2 |
78 | } |
79 | |
ee3e756d |
80 | sub B::LOOP::debug { |
81 | my ($op) = @_; |
82 | $op->B::BINOP::debug(); |
c1307613 |
83 | printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop); |
84 | op_redoop %s |
85 | op_nextop %s |
86 | op_lastop %s |
ee3e756d |
87 | EOT |
88 | } |
89 | |
a798dbf2 |
90 | sub B::LOGOP::debug { |
91 | my ($op) = @_; |
92 | $op->B::UNOP::debug(); |
c1307613 |
93 | printf "\top_other\t%s\n", _printop($op->other); |
a798dbf2 |
94 | } |
95 | |
a798dbf2 |
96 | sub B::LISTOP::debug { |
97 | my ($op) = @_; |
98 | $op->B::BINOP::debug(); |
c03c2844 |
99 | printf "\top_children\t%d\n", $op->children; |
a798dbf2 |
100 | } |
101 | |
102 | sub B::PMOP::debug { |
103 | my ($op) = @_; |
104 | $op->B::LISTOP::debug(); |
93f00e88 |
105 | printf "\top_pmreplroot\t0x%x\n", VERSION < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot; |
a798dbf2 |
106 | printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; |
93f00e88 |
107 | printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if VERSION < 5.009005; |
c1307613 |
108 | if (ITHREADS) { |
109 | printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv); |
110 | printf "\top_pmoffset\t%d\n", $op->pmoffset; |
111 | } else { |
112 | printf "\top_pmstash\t%s\n", cstring($op->pmstash); |
113 | } |
93f00e88 |
114 | printf "\top_precomp\t%s\n", cstring($op->precomp); |
a798dbf2 |
115 | printf "\top_pmflags\t0x%x\n", $op->pmflags; |
93f00e88 |
116 | printf "\top_reflags\t0x%x\n", $op->reflags if VERSION >= 5.009; |
117 | printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if VERSION < 5.009; |
118 | printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if VERSION < 5.009; |
119 | $op->pmreplroot->debug if VERSION < 5.008; |
a798dbf2 |
120 | } |
121 | |
122 | sub B::COP::debug { |
123 | my ($op) = @_; |
124 | $op->B::OP::debug(); |
6e6a1aef |
125 | my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; |
127212b2 |
126 | printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io); |
c1307613 |
127 | cop_label "%s" |
128 | cop_stashpv "%s" |
129 | cop_file "%s" |
a798dbf2 |
130 | cop_seq %d |
131 | cop_arybase %d |
132 | cop_line %d |
b295d113 |
133 | cop_warnings 0x%x |
6e6a1aef |
134 | cop_io %s |
a798dbf2 |
135 | EOT |
a798dbf2 |
136 | } |
137 | |
138 | sub B::SVOP::debug { |
139 | my ($op) = @_; |
140 | $op->B::OP::debug(); |
141 | printf "\top_sv\t\t0x%x\n", ${$op->sv}; |
142 | $op->sv->debug; |
143 | } |
144 | |
145 | sub B::PVOP::debug { |
146 | my ($op) = @_; |
147 | $op->B::OP::debug(); |
3267896c |
148 | printf "\top_pv\t\t%s\n", cstring($op->pv); |
a798dbf2 |
149 | } |
150 | |
7934575e |
151 | sub B::PADOP::debug { |
a798dbf2 |
152 | my ($op) = @_; |
153 | $op->B::OP::debug(); |
c1307613 |
154 | printf "\top_padix\t%ld\n", $op->padix; |
a798dbf2 |
155 | } |
156 | |
a798dbf2 |
157 | sub B::NULL::debug { |
158 | my ($sv) = @_; |
159 | if ($$sv == ${sv_undef()}) { |
160 | print "&sv_undef\n"; |
161 | } else { |
162 | printf "NULL (0x%x)\n", $$sv; |
163 | } |
164 | } |
165 | |
166 | sub B::SV::debug { |
167 | my ($sv) = @_; |
168 | if (!$$sv) { |
169 | print class($sv), " = NULL\n"; |
170 | return; |
171 | } |
172 | printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; |
173 | %s (0x%x) |
174 | REFCNT %d |
175 | FLAGS 0x%x |
176 | EOT |
177 | } |
178 | |
3267896c |
179 | sub B::RV::debug { |
180 | my ($rv) = @_; |
181 | B::SV::debug($rv); |
182 | printf <<'EOT', ${$rv->RV}; |
183 | RV 0x%x |
184 | EOT |
185 | $rv->RV->debug; |
186 | } |
187 | |
a798dbf2 |
188 | sub B::PV::debug { |
189 | my ($sv) = @_; |
190 | $sv->B::SV::debug(); |
191 | my $pv = $sv->PV(); |
192 | printf <<'EOT', cstring($pv), length($pv); |
193 | xpv_pv %s |
194 | xpv_cur %d |
195 | EOT |
196 | } |
197 | |
198 | sub B::IV::debug { |
199 | my ($sv) = @_; |
200 | $sv->B::SV::debug(); |
201 | printf "\txiv_iv\t\t%d\n", $sv->IV; |
202 | } |
203 | |
204 | sub B::NV::debug { |
205 | my ($sv) = @_; |
206 | $sv->B::IV::debug(); |
207 | printf "\txnv_nv\t\t%s\n", $sv->NV; |
208 | } |
209 | |
210 | sub B::PVIV::debug { |
211 | my ($sv) = @_; |
212 | $sv->B::PV::debug(); |
213 | printf "\txiv_iv\t\t%d\n", $sv->IV; |
214 | } |
215 | |
216 | sub B::PVNV::debug { |
217 | my ($sv) = @_; |
218 | $sv->B::PVIV::debug(); |
219 | printf "\txnv_nv\t\t%s\n", $sv->NV; |
220 | } |
221 | |
222 | sub B::PVLV::debug { |
223 | my ($sv) = @_; |
224 | $sv->B::PVNV::debug(); |
225 | printf "\txlv_targoff\t%d\n", $sv->TARGOFF; |
226 | printf "\txlv_targlen\t%u\n", $sv->TARGLEN; |
227 | printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); |
228 | } |
229 | |
230 | sub B::BM::debug { |
231 | my ($sv) = @_; |
232 | $sv->B::PVNV::debug(); |
233 | printf "\txbm_useful\t%d\n", $sv->USEFUL; |
234 | printf "\txbm_previous\t%u\n", $sv->PREVIOUS; |
235 | printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); |
236 | } |
237 | |
238 | sub B::CV::debug { |
239 | my ($sv) = @_; |
240 | $sv->B::PVNV::debug(); |
241 | my ($stash) = $sv->STASH; |
242 | my ($start) = $sv->START; |
243 | my ($root) = $sv->ROOT; |
244 | my ($padlist) = $sv->PADLIST; |
57843af0 |
245 | my ($file) = $sv->FILE; |
a798dbf2 |
246 | my ($gv) = $sv->GV; |
a3985cdc |
247 | printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ; |
a798dbf2 |
248 | STASH 0x%x |
249 | START 0x%x |
250 | ROOT 0x%x |
251 | GV 0x%x |
57843af0 |
252 | FILE %s |
a798dbf2 |
253 | DEPTH %d |
7e107e90 |
254 | PADLIST 0x%x |
a798dbf2 |
255 | OUTSIDE 0x%x |
a3985cdc |
256 | OUTSIDE_SEQ %d |
a798dbf2 |
257 | EOT |
258 | $start->debug if $start; |
259 | $root->debug if $root; |
260 | $gv->debug if $gv; |
a798dbf2 |
261 | $padlist->debug if $padlist; |
262 | } |
263 | |
264 | sub B::AV::debug { |
265 | my ($av) = @_; |
266 | $av->B::SV::debug; |
93f00e88 |
267 | # tied arrays may leave out FETCHSIZE |
268 | my (@array) = eval { $av->ARRAY; }; |
a798dbf2 |
269 | print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; |
93f00e88 |
270 | my $fill = eval { scalar(@array) }; |
271 | if (ITHREADS) { |
272 | printf <<'EOT', $fill, $av->MAX, $av->OFF; |
7e107e90 |
273 | FILL %d |
a798dbf2 |
274 | MAX %d |
275 | OFF %d |
a798dbf2 |
276 | EOT |
93f00e88 |
277 | } else { |
278 | printf <<'EOT', $fill, $av->MAX; |
279 | FILL %d |
280 | MAX %d |
281 | EOT |
282 | } |
283 | printf <<'EOT', $av->AvFLAGS if VERSION < 5.009; |
bb7c595b |
284 | AvFLAGS %d |
285 | EOT |
a798dbf2 |
286 | } |
7e107e90 |
287 | |
a798dbf2 |
288 | sub B::GV::debug { |
289 | my ($gv) = @_; |
290 | if ($done_gv{$$gv}++) { |
002b978b |
291 | printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; |
a798dbf2 |
292 | return; |
293 | } |
294 | my ($sv) = $gv->SV; |
295 | my ($av) = $gv->AV; |
296 | my ($cv) = $gv->CV; |
297 | $gv->B::SV::debug; |
002b978b |
298 | printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; |
a798dbf2 |
299 | NAME %s |
300 | STASH %s (0x%x) |
301 | SV 0x%x |
302 | GvREFCNT %d |
303 | FORM 0x%x |
304 | AV 0x%x |
305 | HV 0x%x |
306 | EGV 0x%x |
307 | CV 0x%x |
308 | CVGEN %d |
309 | LINE %d |
b195d487 |
310 | FILE %s |
a798dbf2 |
311 | GvFLAGS 0x%x |
312 | EOT |
313 | $sv->debug if $sv; |
314 | $av->debug if $av; |
315 | $cv->debug if $cv; |
316 | } |
317 | |
318 | sub B::SPECIAL::debug { |
319 | my $sv = shift; |
320 | print $specialsv_name[$$sv], "\n"; |
321 | } |
322 | |
323 | sub compile { |
324 | my $order = shift; |
2b8dc4d2 |
325 | B::clearsym(); |
7ebf56ae |
326 | if ($order && $order eq "exec") { |
a798dbf2 |
327 | return sub { walkoptree_exec(main_start, "debug") } |
328 | } else { |
329 | return sub { walkoptree(main_root, "debug") } |
330 | } |
331 | } |
332 | |
333 | 1; |
7f20e9dd |
334 | |
335 | __END__ |
336 | |
337 | =head1 NAME |
338 | |
339 | B::Debug - Walk Perl syntax tree, printing debug info about ops |
340 | |
341 | =head1 SYNOPSIS |
342 | |
343 | perl -MO=Debug[,OPTIONS] foo.pl |
344 | |
345 | =head1 DESCRIPTION |
346 | |
c1307613 |
347 | See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>. |
348 | |
349 | =head1 OPTIONS |
350 | |
351 | With option -exec, walks tree in execute order, |
352 | otherwise in basic order. |
7f20e9dd |
353 | |
93f00e88 |
354 | =head1 Changes |
355 | |
356 | 1.06 2008-06-11 rurban |
357 | added B::Flags output |
358 | dual-life CPAN as B-Debug-1.06 and CORE |
359 | protect scalar(@array) if tied arrays leave out FETCHSIZE |
360 | |
361 | 1.05_03 2008-04-16 rurban |
362 | ithread fixes in B::AV |
363 | B-C-1.04_?? |
364 | |
365 | B-C-1.04_09 2008-02-24 rurban |
366 | support 5.8 (import Asmdata) |
367 | |
368 | 1.05_02 2008-02-21 rurban |
369 | added _printop |
370 | B-C-1.04_08 and CORE |
371 | |
372 | 1.05_01 2008-02-05 rurban |
373 | 5.10 fix for op->seq |
374 | B-C-1.04_04 |
375 | |
7f20e9dd |
376 | =head1 AUTHOR |
377 | |
378 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
93f00e88 |
379 | Reini Urban C<rurban@cpan.org> |
7f20e9dd |
380 | |
381 | =cut |