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