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