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