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<[email protected]>
|
---|
304 |
|
---|
305 | =cut
|
---|