This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Compression modules to version 2.012
[perl5.git] / ext / B / B / Debug.pm
CommitLineData
a798dbf2 1package B::Debug;
28b605d8 2
93f00e88 3our $VERSION = '1.06';
28b605d8 4
a798dbf2
MB
5use strict;
6use B qw(peekop class walkoptree walkoptree_exec
93f00e88
RU
7 main_start main_root cstring sv_undef);
8our (@optype, @specialsv_name);
9require B;
10if ($] < 5.009) {
11 require B::Asmdata;
12 B::Asmdata->import qw(@optype @specialsv_name);
13} else {
14 B->import qw(@optype @specialsv_name);
15}
16my $have_B_Flags;
17eval { require B::Flags and $have_B_Flags++ };
c1307613
RU
18BEGIN {
19 use Config;
20 my $ithreads = $Config{'useithreads'} eq 'define';
21 eval qq{
22 sub ITHREADS() { $ithreads }
23 sub VERSION() { $] }
24 }; die $@ if $@;
25}
a798dbf2
MB
26
27my %done_gv;
28
c1307613
RU
29sub _printop {
30 my $op = shift;
31 my $addr = ${$op} ? $op->ppaddr : '';
32 $addr =~ s/^PL_ppaddr// if $addr;
33 return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
34}
35
a798dbf2
MB
36sub B::OP::debug {
37 my ($op) = @_;
c1307613 38 printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
a798dbf2 39%s (0x%lx)
a798dbf2 40 op_ppaddr %s
c1307613
RU
41 op_next %s
42 op_sibling %s
a798dbf2
MB
43 op_targ %d
44 op_type %d
7252851f 45EOT
93f00e88 46 if (VERSION > 5.009) {
85594c31 47 printf <<'EOT', $op->opt;
2814eb74 48 op_opt %d
7252851f
NC
49EOT
50 } else {
51 printf <<'EOT', $op->seq;
52 op_seq %d
53EOT
54 }
93f00e88
RU
55 if ($have_B_Flags) {
56 printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
57 op_flags %d %s
58 op_private %d %s
59EOT
60 } else {
61 printf <<'EOT', $op->flags, $op->private;
a798dbf2
MB
62 op_flags %d
63 op_private %d
64EOT
93f00e88 65 }
a798dbf2
MB
66}
67
68sub B::UNOP::debug {
69 my ($op) = @_;
70 $op->B::OP::debug();
c1307613 71 printf "\top_first\t%s\n", _printop($op->first);
a798dbf2
MB
72}
73
74sub B::BINOP::debug {
75 my ($op) = @_;
76 $op->B::UNOP::debug();
c1307613 77 printf "\top_last \t%s\n", _printop($op->last);
a798dbf2
MB
78}
79
ee3e756d
RH
80sub B::LOOP::debug {
81 my ($op) = @_;
82 $op->B::BINOP::debug();
c1307613
RU
83 printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
84 op_redoop %s
85 op_nextop %s
86 op_lastop %s
ee3e756d
RH
87EOT
88}
89
a798dbf2
MB
90sub B::LOGOP::debug {
91 my ($op) = @_;
92 $op->B::UNOP::debug();
c1307613 93 printf "\top_other\t%s\n", _printop($op->other);
a798dbf2
MB
94}
95
a798dbf2
MB
96sub B::LISTOP::debug {
97 my ($op) = @_;
98 $op->B::BINOP::debug();
c03c2844 99 printf "\top_children\t%d\n", $op->children;
a798dbf2
MB
100}
101
102sub B::PMOP::debug {
103 my ($op) = @_;
104 $op->B::LISTOP::debug();
93f00e88 105 printf "\top_pmreplroot\t0x%x\n", VERSION < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
a798dbf2 106 printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
93f00e88 107 printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if VERSION < 5.009005;
c1307613
RU
108 if (ITHREADS) {
109 printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
110 printf "\top_pmoffset\t%d\n", $op->pmoffset;
111 } else {
112 printf "\top_pmstash\t%s\n", cstring($op->pmstash);
113 }
93f00e88 114 printf "\top_precomp\t%s\n", cstring($op->precomp);
a798dbf2 115 printf "\top_pmflags\t0x%x\n", $op->pmflags;
93f00e88
RU
116 printf "\top_reflags\t0x%x\n", $op->reflags if VERSION >= 5.009;
117 printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if VERSION < 5.009;
118 printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if VERSION < 5.009;
119 $op->pmreplroot->debug if VERSION < 5.008;
a798dbf2
MB
120}
121
122sub B::COP::debug {
123 my ($op) = @_;
124 $op->B::OP::debug();
6e6a1aef 125 my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
127212b2 126 printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
c1307613
RU
127 cop_label "%s"
128 cop_stashpv "%s"
129 cop_file "%s"
a798dbf2
MB
130 cop_seq %d
131 cop_arybase %d
132 cop_line %d
b295d113 133 cop_warnings 0x%x
6e6a1aef 134 cop_io %s
a798dbf2 135EOT
a798dbf2
MB
136}
137
138sub B::SVOP::debug {
139 my ($op) = @_;
140 $op->B::OP::debug();
141 printf "\top_sv\t\t0x%x\n", ${$op->sv};
142 $op->sv->debug;
143}
144
145sub B::PVOP::debug {
146 my ($op) = @_;
147 $op->B::OP::debug();
3267896c 148 printf "\top_pv\t\t%s\n", cstring($op->pv);
a798dbf2
MB
149}
150
7934575e 151sub B::PADOP::debug {
a798dbf2
MB
152 my ($op) = @_;
153 $op->B::OP::debug();
c1307613 154 printf "\top_padix\t%ld\n", $op->padix;
a798dbf2
MB
155}
156
a798dbf2
MB
157sub B::NULL::debug {
158 my ($sv) = @_;
159 if ($$sv == ${sv_undef()}) {
160 print "&sv_undef\n";
161 } else {
162 printf "NULL (0x%x)\n", $$sv;
163 }
164}
165
166sub B::SV::debug {
167 my ($sv) = @_;
168 if (!$$sv) {
169 print class($sv), " = NULL\n";
170 return;
171 }
172 printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
173%s (0x%x)
174 REFCNT %d
175 FLAGS 0x%x
176EOT
177}
178
3267896c
RH
179sub B::RV::debug {
180 my ($rv) = @_;
181 B::SV::debug($rv);
182 printf <<'EOT', ${$rv->RV};
183 RV 0x%x
184EOT
185 $rv->RV->debug;
186}
187
a798dbf2
MB
188sub B::PV::debug {
189 my ($sv) = @_;
190 $sv->B::SV::debug();
191 my $pv = $sv->PV();
192 printf <<'EOT', cstring($pv), length($pv);
193 xpv_pv %s
194 xpv_cur %d
195EOT
196}
197
198sub B::IV::debug {
199 my ($sv) = @_;
200 $sv->B::SV::debug();
201 printf "\txiv_iv\t\t%d\n", $sv->IV;
202}
203
204sub B::NV::debug {
205 my ($sv) = @_;
206 $sv->B::IV::debug();
207 printf "\txnv_nv\t\t%s\n", $sv->NV;
208}
209
210sub B::PVIV::debug {
211 my ($sv) = @_;
212 $sv->B::PV::debug();
213 printf "\txiv_iv\t\t%d\n", $sv->IV;
214}
215
216sub B::PVNV::debug {
217 my ($sv) = @_;
218 $sv->B::PVIV::debug();
219 printf "\txnv_nv\t\t%s\n", $sv->NV;
220}
221
222sub B::PVLV::debug {
223 my ($sv) = @_;
224 $sv->B::PVNV::debug();
225 printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
226 printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
227 printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
228}
229
230sub B::BM::debug {
231 my ($sv) = @_;
232 $sv->B::PVNV::debug();
233 printf "\txbm_useful\t%d\n", $sv->USEFUL;
234 printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
235 printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
236}
237
238sub B::CV::debug {
239 my ($sv) = @_;
240 $sv->B::PVNV::debug();
241 my ($stash) = $sv->STASH;
242 my ($start) = $sv->START;
243 my ($root) = $sv->ROOT;
244 my ($padlist) = $sv->PADLIST;
57843af0 245 my ($file) = $sv->FILE;
a798dbf2 246 my ($gv) = $sv->GV;
a3985cdc 247 printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
a798dbf2
MB
248 STASH 0x%x
249 START 0x%x
250 ROOT 0x%x
251 GV 0x%x
57843af0 252 FILE %s
a798dbf2 253 DEPTH %d
7e107e90 254 PADLIST 0x%x
a798dbf2 255 OUTSIDE 0x%x
a3985cdc 256 OUTSIDE_SEQ %d
a798dbf2
MB
257EOT
258 $start->debug if $start;
259 $root->debug if $root;
260 $gv->debug if $gv;
a798dbf2
MB
261 $padlist->debug if $padlist;
262}
263
264sub B::AV::debug {
265 my ($av) = @_;
266 $av->B::SV::debug;
93f00e88
RU
267 # tied arrays may leave out FETCHSIZE
268 my (@array) = eval { $av->ARRAY; };
a798dbf2 269 print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
93f00e88
RU
270 my $fill = eval { scalar(@array) };
271 if (ITHREADS) {
272 printf <<'EOT', $fill, $av->MAX, $av->OFF;
7e107e90 273 FILL %d
a798dbf2
MB
274 MAX %d
275 OFF %d
a798dbf2 276EOT
93f00e88
RU
277 } else {
278 printf <<'EOT', $fill, $av->MAX;
279 FILL %d
280 MAX %d
281EOT
282 }
283 printf <<'EOT', $av->AvFLAGS if VERSION < 5.009;
bb7c595b
NC
284 AvFLAGS %d
285EOT
a798dbf2 286}
7e107e90 287
a798dbf2
MB
288sub B::GV::debug {
289 my ($gv) = @_;
290 if ($done_gv{$$gv}++) {
002b978b 291 printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
a798dbf2
MB
292 return;
293 }
294 my ($sv) = $gv->SV;
295 my ($av) = $gv->AV;
296 my ($cv) = $gv->CV;
297 $gv->B::SV::debug;
002b978b 298 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
299 NAME %s
300 STASH %s (0x%x)
301 SV 0x%x
302 GvREFCNT %d
303 FORM 0x%x
304 AV 0x%x
305 HV 0x%x
306 EGV 0x%x
307 CV 0x%x
308 CVGEN %d
309 LINE %d
b195d487 310 FILE %s
a798dbf2
MB
311 GvFLAGS 0x%x
312EOT
313 $sv->debug if $sv;
314 $av->debug if $av;
315 $cv->debug if $cv;
316}
317
318sub B::SPECIAL::debug {
319 my $sv = shift;
320 print $specialsv_name[$$sv], "\n";
321}
322
323sub compile {
324 my $order = shift;
2b8dc4d2 325 B::clearsym();
7ebf56ae 326 if ($order && $order eq "exec") {
a798dbf2
MB
327 return sub { walkoptree_exec(main_start, "debug") }
328 } else {
329 return sub { walkoptree(main_root, "debug") }
330 }
331}
332
3331;
7f20e9dd
GS
334
335__END__
336
337=head1 NAME
338
339B::Debug - Walk Perl syntax tree, printing debug info about ops
340
341=head1 SYNOPSIS
342
343 perl -MO=Debug[,OPTIONS] foo.pl
344
345=head1 DESCRIPTION
346
c1307613
RU
347See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
348
349=head1 OPTIONS
350
351With option -exec, walks tree in execute order,
352otherwise in basic order.
7f20e9dd 353
93f00e88
RU
354=head1 Changes
355
356 1.06 2008-06-11 rurban
357 added B::Flags output
358 dual-life CPAN as B-Debug-1.06 and CORE
359 protect scalar(@array) if tied arrays leave out FETCHSIZE
360
361 1.05_03 2008-04-16 rurban
362 ithread fixes in B::AV
363 B-C-1.04_??
364
365 B-C-1.04_09 2008-02-24 rurban
366 support 5.8 (import Asmdata)
367
368 1.05_02 2008-02-21 rurban
369 added _printop
370 B-C-1.04_08 and CORE
371
372 1.05_01 2008-02-05 rurban
373 5.10 fix for op->seq
374 B-C-1.04_04
375
7f20e9dd
GS
376=head1 AUTHOR
377
378Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
93f00e88 379Reini Urban C<rurban@cpan.org>
7f20e9dd
GS
380
381=cut