Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | package B::Debug; |
2 | ||
3 | our $VERSION = '1.02_01'; | |
4 | ||
5 | use strict; | |
6 | use B qw(peekop class walkoptree walkoptree_exec | |
7 | main_start main_root cstring sv_undef); | |
8 | use B::Asmdata qw(@specialsv_name); | |
9 | ||
10 | my %done_gv; | |
11 | ||
12 | sub B::OP::debug { | |
13 | my ($op) = @_; | |
14 | printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type; | |
15 | %s (0x%lx) | |
16 | op_next 0x%x | |
17 | op_sibling 0x%x | |
18 | op_ppaddr %s | |
19 | op_targ %d | |
20 | op_type %d | |
21 | EOT | |
22 | if ($] > 5.009) { | |
23 | printf <<'EOT', $op->opt, $op->static; | |
24 | op_opt %d | |
25 | op_static %d | |
26 | EOT | |
27 | } else { | |
28 | printf <<'EOT', $op->seq; | |
29 | op_seq %d | |
30 | EOT | |
31 | } | |
32 | printf <<'EOT', $op->flags, $op->private; | |
33 | op_flags %d | |
34 | op_private %d | |
35 | EOT | |
36 | } | |
37 | ||
38 | sub B::UNOP::debug { | |
39 | my ($op) = @_; | |
40 | $op->B::OP::debug(); | |
41 | printf "\top_first\t0x%x\n", ${$op->first}; | |
42 | } | |
43 | ||
44 | sub B::BINOP::debug { | |
45 | my ($op) = @_; | |
46 | $op->B::UNOP::debug(); | |
47 | printf "\top_last\t\t0x%x\n", ${$op->last}; | |
48 | } | |
49 | ||
50 | sub B::LOOP::debug { | |
51 | my ($op) = @_; | |
52 | $op->B::BINOP::debug(); | |
53 | printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop}; | |
54 | op_redoop 0x%x | |
55 | op_nextop 0x%x | |
56 | op_lastop 0x%x | |
57 | EOT | |
58 | } | |
59 | ||
60 | sub B::LOGOP::debug { | |
61 | my ($op) = @_; | |
62 | $op->B::UNOP::debug(); | |
63 | printf "\top_other\t0x%x\n", ${$op->other}; | |
64 | } | |
65 | ||
66 | sub B::LISTOP::debug { | |
67 | my ($op) = @_; | |
68 | $op->B::BINOP::debug(); | |
69 | printf "\top_children\t%d\n", $op->children; | |
70 | } | |
71 | ||
72 | sub B::PMOP::debug { | |
73 | my ($op) = @_; | |
74 | $op->B::LISTOP::debug(); | |
75 | printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot}; | |
76 | printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; | |
77 | printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; | |
78 | printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); | |
79 | printf "\top_pmflags\t0x%x\n", $op->pmflags; | |
80 | $op->pmreplroot->debug; | |
81 | } | |
82 | ||
83 | sub B::COP::debug { | |
84 | my ($op) = @_; | |
85 | $op->B::OP::debug(); | |
86 | my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; | |
87 | printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io); | |
88 | cop_label %s | |
89 | cop_stashpv %s | |
90 | cop_file %s | |
91 | cop_seq %d | |
92 | cop_arybase %d | |
93 | cop_line %d | |
94 | cop_warnings 0x%x | |
95 | cop_io %s | |
96 | EOT | |
97 | } | |
98 | ||
99 | sub B::SVOP::debug { | |
100 | my ($op) = @_; | |
101 | $op->B::OP::debug(); | |
102 | printf "\top_sv\t\t0x%x\n", ${$op->sv}; | |
103 | $op->sv->debug; | |
104 | } | |
105 | ||
106 | sub B::PVOP::debug { | |
107 | my ($op) = @_; | |
108 | $op->B::OP::debug(); | |
109 | printf "\top_pv\t\t%s\n", cstring($op->pv); | |
110 | } | |
111 | ||
112 | sub B::PADOP::debug { | |
113 | my ($op) = @_; | |
114 | $op->B::OP::debug(); | |
115 | printf "\top_padix\t\t%ld\n", $op->padix; | |
116 | } | |
117 | ||
118 | sub B::NULL::debug { | |
119 | my ($sv) = @_; | |
120 | if ($$sv == ${sv_undef()}) { | |
121 | print "&sv_undef\n"; | |
122 | } else { | |
123 | printf "NULL (0x%x)\n", $$sv; | |
124 | } | |
125 | } | |
126 | ||
127 | sub B::SV::debug { | |
128 | my ($sv) = @_; | |
129 | if (!$$sv) { | |
130 | print class($sv), " = NULL\n"; | |
131 | return; | |
132 | } | |
133 | printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; | |
134 | %s (0x%x) | |
135 | REFCNT %d | |
136 | FLAGS 0x%x | |
137 | EOT | |
138 | } | |
139 | ||
140 | sub B::RV::debug { | |
141 | my ($rv) = @_; | |
142 | B::SV::debug($rv); | |
143 | printf <<'EOT', ${$rv->RV}; | |
144 | RV 0x%x | |
145 | EOT | |
146 | $rv->RV->debug; | |
147 | } | |
148 | ||
149 | sub B::PV::debug { | |
150 | my ($sv) = @_; | |
151 | $sv->B::SV::debug(); | |
152 | my $pv = $sv->PV(); | |
153 | printf <<'EOT', cstring($pv), length($pv); | |
154 | xpv_pv %s | |
155 | xpv_cur %d | |
156 | EOT | |
157 | } | |
158 | ||
159 | sub B::IV::debug { | |
160 | my ($sv) = @_; | |
161 | $sv->B::SV::debug(); | |
162 | printf "\txiv_iv\t\t%d\n", $sv->IV; | |
163 | } | |
164 | ||
165 | sub B::NV::debug { | |
166 | my ($sv) = @_; | |
167 | $sv->B::IV::debug(); | |
168 | printf "\txnv_nv\t\t%s\n", $sv->NV; | |
169 | } | |
170 | ||
171 | sub B::PVIV::debug { | |
172 | my ($sv) = @_; | |
173 | $sv->B::PV::debug(); | |
174 | printf "\txiv_iv\t\t%d\n", $sv->IV; | |
175 | } | |
176 | ||
177 | sub B::PVNV::debug { | |
178 | my ($sv) = @_; | |
179 | $sv->B::PVIV::debug(); | |
180 | printf "\txnv_nv\t\t%s\n", $sv->NV; | |
181 | } | |
182 | ||
183 | sub B::PVLV::debug { | |
184 | my ($sv) = @_; | |
185 | $sv->B::PVNV::debug(); | |
186 | printf "\txlv_targoff\t%d\n", $sv->TARGOFF; | |
187 | printf "\txlv_targlen\t%u\n", $sv->TARGLEN; | |
188 | printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); | |
189 | } | |
190 | ||
191 | sub B::BM::debug { | |
192 | my ($sv) = @_; | |
193 | $sv->B::PVNV::debug(); | |
194 | printf "\txbm_useful\t%d\n", $sv->USEFUL; | |
195 | printf "\txbm_previous\t%u\n", $sv->PREVIOUS; | |
196 | printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); | |
197 | } | |
198 | ||
199 | sub B::CV::debug { | |
200 | my ($sv) = @_; | |
201 | $sv->B::PVNV::debug(); | |
202 | my ($stash) = $sv->STASH; | |
203 | my ($start) = $sv->START; | |
204 | my ($root) = $sv->ROOT; | |
205 | my ($padlist) = $sv->PADLIST; | |
206 | my ($file) = $sv->FILE; | |
207 | my ($gv) = $sv->GV; | |
208 | printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ; | |
209 | STASH 0x%x | |
210 | START 0x%x | |
211 | ROOT 0x%x | |
212 | GV 0x%x | |
213 | FILE %s | |
214 | DEPTH %d | |
215 | PADLIST 0x%x | |
216 | OUTSIDE 0x%x | |
217 | OUTSIDE_SEQ %d | |
218 | EOT | |
219 | $start->debug if $start; | |
220 | $root->debug if $root; | |
221 | $gv->debug if $gv; | |
222 | $padlist->debug if $padlist; | |
223 | } | |
224 | ||
225 | sub B::AV::debug { | |
226 | my ($av) = @_; | |
227 | $av->B::SV::debug; | |
228 | my(@array) = $av->ARRAY; | |
229 | print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; | |
230 | printf <<'EOT', scalar(@array), $av->MAX, $av->OFF; | |
231 | FILL %d | |
232 | MAX %d | |
233 | OFF %d | |
234 | EOT | |
235 | printf <<'EOT', $av->AvFLAGS if $] < 5.009; | |
236 | AvFLAGS %d | |
237 | EOT | |
238 | } | |
239 | ||
240 | sub B::GV::debug { | |
241 | my ($gv) = @_; | |
242 | if ($done_gv{$$gv}++) { | |
243 | printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; | |
244 | return; | |
245 | } | |
246 | my ($sv) = $gv->SV; | |
247 | my ($av) = $gv->AV; | |
248 | my ($cv) = $gv->CV; | |
249 | $gv->B::SV::debug; | |
250 | 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; | |
251 | NAME %s | |
252 | STASH %s (0x%x) | |
253 | SV 0x%x | |
254 | GvREFCNT %d | |
255 | FORM 0x%x | |
256 | AV 0x%x | |
257 | HV 0x%x | |
258 | EGV 0x%x | |
259 | CV 0x%x | |
260 | CVGEN %d | |
261 | LINE %d | |
262 | FILE %s | |
263 | GvFLAGS 0x%x | |
264 | EOT | |
265 | $sv->debug if $sv; | |
266 | $av->debug if $av; | |
267 | $cv->debug if $cv; | |
268 | } | |
269 | ||
270 | sub B::SPECIAL::debug { | |
271 | my $sv = shift; | |
272 | print $specialsv_name[$$sv], "\n"; | |
273 | } | |
274 | ||
275 | sub compile { | |
276 | my $order = shift; | |
277 | B::clearsym(); | |
278 | if ($order && $order eq "exec") { | |
279 | return sub { walkoptree_exec(main_start, "debug") } | |
280 | } else { | |
281 | return sub { walkoptree(main_root, "debug") } | |
282 | } | |
283 | } | |
284 | ||
285 | 1; | |
286 | ||
287 | __END__ | |
288 | ||
289 | =head1 NAME | |
290 | ||
291 | B::Debug - Walk Perl syntax tree, printing debug info about ops | |
292 | ||
293 | =head1 SYNOPSIS | |
294 | ||
295 | perl -MO=Debug[,OPTIONS] foo.pl | |
296 | ||
297 | =head1 DESCRIPTION | |
298 | ||
299 | See F<ext/B/README>. | |
300 | ||
301 | =head1 AUTHOR | |
302 | ||
303 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> | |
304 | ||
305 | =cut |