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