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