This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump versions of modules that are currently on "dev" releases in maint.
[perl5.git] / ext / B / B / Debug.pm
CommitLineData
a798dbf2 1package B::Debug;
28b605d8 2
828888e0 3our $VERSION = '1.03';
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) = @_;
7252851f 14 printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type;
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
7252851f
NC
21EOT
22 if ($] > 5.009) {
23 printf <<'EOT', $op->opt, $op->static;
2814eb74
PJ
24 op_opt %d
25 op_static %d
7252851f
NC
26EOT
27 } else {
28 printf <<'EOT', $op->seq;
29 op_seq %d
30EOT
31 }
32 printf <<'EOT', $op->flags, $op->private;
a798dbf2
MB
33 op_flags %d
34 op_private %d
35EOT
36}
37
38sub B::UNOP::debug {
39 my ($op) = @_;
40 $op->B::OP::debug();
41 printf "\top_first\t0x%x\n", ${$op->first};
42}
43
44sub B::BINOP::debug {
45 my ($op) = @_;
46 $op->B::UNOP::debug();
47 printf "\top_last\t\t0x%x\n", ${$op->last};
48}
49
ee3e756d
RH
50sub B::LOOP::debug {
51 my ($op) = @_;
52 $op->B::BINOP::debug();
53 printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop};
7e107e90
RGS
54 op_redoop 0x%x
55 op_nextop 0x%x
56 op_lastop 0x%x
ee3e756d
RH
57EOT
58}
59
a798dbf2
MB
60sub B::LOGOP::debug {
61 my ($op) = @_;
62 $op->B::UNOP::debug();
63 printf "\top_other\t0x%x\n", ${$op->other};
64}
65
a798dbf2
MB
66sub B::LISTOP::debug {
67 my ($op) = @_;
68 $op->B::BINOP::debug();
c03c2844 69 printf "\top_children\t%d\n", $op->children;
a798dbf2
MB
70}
71
72sub 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;
a798dbf2
MB
80 $op->pmreplroot->debug;
81}
82
83sub B::COP::debug {
84 my ($op) = @_;
85 $op->B::OP::debug();
6e6a1aef 86 my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
127212b2 87 printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
a798dbf2 88 cop_label %s
11faa288 89 cop_stashpv %s
57843af0 90 cop_file %s
a798dbf2
MB
91 cop_seq %d
92 cop_arybase %d
93 cop_line %d
b295d113 94 cop_warnings 0x%x
6e6a1aef 95 cop_io %s
a798dbf2 96EOT
a798dbf2
MB
97}
98
99sub 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
106sub B::PVOP::debug {
107 my ($op) = @_;
108 $op->B::OP::debug();
3267896c 109 printf "\top_pv\t\t%s\n", cstring($op->pv);
a798dbf2
MB
110}
111
7934575e 112sub B::PADOP::debug {
a798dbf2
MB
113 my ($op) = @_;
114 $op->B::OP::debug();
7934575e 115 printf "\top_padix\t\t%ld\n", $op->padix;
a798dbf2
MB
116}
117
a798dbf2
MB
118sub 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
127sub 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
137EOT
138}
139
3267896c
RH
140sub B::RV::debug {
141 my ($rv) = @_;
142 B::SV::debug($rv);
143 printf <<'EOT', ${$rv->RV};
144 RV 0x%x
145EOT
146 $rv->RV->debug;
147}
148
a798dbf2
MB
149sub 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
156EOT
157}
158
159sub B::IV::debug {
160 my ($sv) = @_;
161 $sv->B::SV::debug();
162 printf "\txiv_iv\t\t%d\n", $sv->IV;
163}
164
165sub B::NV::debug {
166 my ($sv) = @_;
167 $sv->B::IV::debug();
168 printf "\txnv_nv\t\t%s\n", $sv->NV;
169}
170
171sub B::PVIV::debug {
172 my ($sv) = @_;
173 $sv->B::PV::debug();
174 printf "\txiv_iv\t\t%d\n", $sv->IV;
175}
176
177sub B::PVNV::debug {
178 my ($sv) = @_;
179 $sv->B::PVIV::debug();
180 printf "\txnv_nv\t\t%s\n", $sv->NV;
181}
182
183sub 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
191sub 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
199sub 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;
57843af0 206 my ($file) = $sv->FILE;
a798dbf2 207 my ($gv) = $sv->GV;
a3985cdc 208 printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
a798dbf2
MB
209 STASH 0x%x
210 START 0x%x
211 ROOT 0x%x
212 GV 0x%x
57843af0 213 FILE %s
a798dbf2 214 DEPTH %d
7e107e90 215 PADLIST 0x%x
a798dbf2 216 OUTSIDE 0x%x
a3985cdc 217 OUTSIDE_SEQ %d
a798dbf2
MB
218EOT
219 $start->debug if $start;
220 $root->debug if $root;
221 $gv->debug if $gv;
a798dbf2
MB
222 $padlist->debug if $padlist;
223}
224
225sub 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";
11ca45c0 230 printf <<'EOT', scalar(@array), $av->MAX, $av->OFF;
7e107e90 231 FILL %d
a798dbf2
MB
232 MAX %d
233 OFF %d
a798dbf2 234EOT
bb7c595b
NC
235 printf <<'EOT', $av->AvFLAGS if $] < 5.009;
236 AvFLAGS %d
237EOT
a798dbf2 238}
7e107e90 239
a798dbf2
MB
240sub B::GV::debug {
241 my ($gv) = @_;
242 if ($done_gv{$$gv}++) {
002b978b 243 printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
a798dbf2
MB
244 return;
245 }
246 my ($sv) = $gv->SV;
247 my ($av) = $gv->AV;
248 my ($cv) = $gv->CV;
249 $gv->B::SV::debug;
002b978b 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;
a798dbf2
MB
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
b195d487 262 FILE %s
a798dbf2
MB
263 GvFLAGS 0x%x
264EOT
265 $sv->debug if $sv;
266 $av->debug if $av;
267 $cv->debug if $cv;
268}
269
270sub B::SPECIAL::debug {
271 my $sv = shift;
272 print $specialsv_name[$$sv], "\n";
273}
274
275sub compile {
276 my $order = shift;
2b8dc4d2 277 B::clearsym();
7ebf56ae 278 if ($order && $order eq "exec") {
a798dbf2
MB
279 return sub { walkoptree_exec(main_start, "debug") }
280 } else {
281 return sub { walkoptree(main_root, "debug") }
282 }
283}
284
2851;
7f20e9dd
GS
286
287__END__
288
289=head1 NAME
290
291B::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
299See F<ext/B/README>.
300
301=head1 AUTHOR
302
303Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
304
305=cut