This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ad3c215a2887d72137e674f90972e9388217500d
[perl5.git] / ext / B / B / Debug.pm
1 package B::Debug;
2
3 our $VERSION = '1.06';
4
5 use strict;
6 use B qw(peekop class walkoptree walkoptree_exec
7          main_start main_root cstring sv_undef);
8 our (@optype, @specialsv_name);
9 require B;
10 if ($] < 5.009) {
11   require B::Asmdata;
12   B::Asmdata->import qw(@optype @specialsv_name);
13 } else {
14   B->import qw(@optype @specialsv_name);
15 }
16 my $have_B_Flags;
17 eval { require B::Flags and $have_B_Flags++ };
18 BEGIN {
19     use Config;
20     my $ithreads = $Config{'useithreads'} eq 'define';
21     eval qq{
22         sub ITHREADS() { $ithreads }
23         sub VERSION() { $] }
24     }; die $@ if $@;
25 }
26
27 my %done_gv;
28
29 sub _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
36 sub B::OP::debug {
37     my ($op) = @_;
38     printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
39 %s (0x%lx)
40         op_ppaddr       %s
41         op_next         %s
42         op_sibling      %s
43         op_targ         %d
44         op_type         %d
45 EOT
46     if (VERSION > 5.009) {
47         printf <<'EOT', $op->opt;
48         op_opt          %d
49 EOT
50     } else {
51         printf <<'EOT', $op->seq;
52         op_seq          %d
53 EOT
54     }
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
59 EOT
60     } else {
61         printf <<'EOT', $op->flags, $op->private;
62         op_flags        %d
63         op_private      %d
64 EOT
65     }
66 }
67
68 sub B::UNOP::debug {
69     my ($op) = @_;
70     $op->B::OP::debug();
71     printf "\top_first\t%s\n", _printop($op->first);
72 }
73
74 sub B::BINOP::debug {
75     my ($op) = @_;
76     $op->B::UNOP::debug();
77     printf "\top_last \t%s\n", _printop($op->last);
78 }
79
80 sub B::LOOP::debug {
81     my ($op) = @_;
82     $op->B::BINOP::debug();
83     printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
84         op_redoop       %s
85         op_nextop       %s
86         op_lastop       %s
87 EOT
88 }
89
90 sub B::LOGOP::debug {
91     my ($op) = @_;
92     $op->B::UNOP::debug();
93     printf "\top_other\t%s\n", _printop($op->other);
94 }
95
96 sub B::LISTOP::debug {
97     my ($op) = @_;
98     $op->B::BINOP::debug();
99     printf "\top_children\t%d\n", $op->children;
100 }
101
102 sub B::PMOP::debug {
103     my ($op) = @_;
104     $op->B::LISTOP::debug();
105     printf "\top_pmreplroot\t0x%x\n", VERSION < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
106     printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
107     printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if VERSION < 5.009005;
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     }
114     printf "\top_precomp\t%s\n", cstring($op->precomp);
115     printf "\top_pmflags\t0x%x\n", $op->pmflags;
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;
120 }
121
122 sub B::COP::debug {
123     my ($op) = @_;
124     $op->B::OP::debug();
125     my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
126     printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
127         cop_label       "%s"
128         cop_stashpv     "%s"
129         cop_file        "%s"
130         cop_seq         %d
131         cop_arybase     %d
132         cop_line        %d
133         cop_warnings    0x%x
134         cop_io          %s
135 EOT
136 }
137
138 sub 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
145 sub B::PVOP::debug {
146     my ($op) = @_;
147     $op->B::OP::debug();
148     printf "\top_pv\t\t%s\n", cstring($op->pv);
149 }
150
151 sub B::PADOP::debug {
152     my ($op) = @_;
153     $op->B::OP::debug();
154     printf "\top_padix\t%ld\n", $op->padix;
155 }
156
157 sub 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
166 sub 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
176 EOT
177 }
178
179 sub B::RV::debug {
180     my ($rv) = @_;
181     B::SV::debug($rv);
182     printf <<'EOT', ${$rv->RV};
183         RV              0x%x
184 EOT
185     $rv->RV->debug;
186 }
187
188 sub 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
195 EOT
196 }
197
198 sub B::IV::debug {
199     my ($sv) = @_;
200     $sv->B::SV::debug();
201     printf "\txiv_iv\t\t%d\n", $sv->IV;
202 }
203
204 sub B::NV::debug {
205     my ($sv) = @_;
206     $sv->B::IV::debug();
207     printf "\txnv_nv\t\t%s\n", $sv->NV;
208 }
209
210 sub B::PVIV::debug {
211     my ($sv) = @_;
212     $sv->B::PV::debug();
213     printf "\txiv_iv\t\t%d\n", $sv->IV;
214 }
215
216 sub B::PVNV::debug {
217     my ($sv) = @_;
218     $sv->B::PVIV::debug();
219     printf "\txnv_nv\t\t%s\n", $sv->NV;
220 }
221
222 sub 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
230 sub 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
238 sub 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;
245     my ($file) = $sv->FILE;
246     my ($gv) = $sv->GV;
247     printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
248         STASH           0x%x
249         START           0x%x
250         ROOT            0x%x
251         GV              0x%x
252         FILE            %s
253         DEPTH           %d
254         PADLIST         0x%x
255         OUTSIDE         0x%x
256         OUTSIDE_SEQ     %d
257 EOT
258     $start->debug if $start;
259     $root->debug if $root;
260     $gv->debug if $gv;
261     $padlist->debug if $padlist;
262 }
263
264 sub B::AV::debug {
265     my ($av) = @_;
266     $av->B::SV::debug;
267     # tied arrays may leave out FETCHSIZE
268     my (@array) = eval { $av->ARRAY; };
269     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
270     my $fill = eval { scalar(@array) };
271     if (ITHREADS) {
272       printf <<'EOT', $fill, $av->MAX, $av->OFF;
273         FILL            %d
274         MAX             %d
275         OFF             %d
276 EOT
277     } else {
278       printf <<'EOT', $fill, $av->MAX;
279         FILL            %d
280         MAX             %d
281 EOT
282     }
283     printf <<'EOT', $av->AvFLAGS if VERSION < 5.009;
284         AvFLAGS         %d
285 EOT
286 }
287
288 sub B::GV::debug {
289     my ($gv) = @_;
290     if ($done_gv{$$gv}++) {
291         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
292         return;
293     }
294     my ($sv) = $gv->SV;
295     my ($av) = $gv->AV;
296     my ($cv) = $gv->CV;
297     $gv->B::SV::debug;
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;
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
310         FILE            %s
311         GvFLAGS         0x%x
312 EOT
313     $sv->debug if $sv;
314     $av->debug if $av;
315     $cv->debug if $cv;
316 }
317
318 sub B::SPECIAL::debug {
319     my $sv = shift;
320     print $specialsv_name[$$sv], "\n";
321 }
322
323 sub compile {
324     my $order = shift;
325     B::clearsym();
326     if ($order && $order eq "exec") {
327         return sub { walkoptree_exec(main_start, "debug") }
328     } else {
329         return sub { walkoptree(main_root, "debug") }
330     }
331 }
332
333 1;
334
335 __END__
336
337 =head1 NAME
338
339 B::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
347 See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
348
349 =head1 OPTIONS
350
351 With option -exec, walks tree in execute order,
352 otherwise in basic order.
353
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
376 =head1 AUTHOR
377
378 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
379 Reini Urban C<rurban@cpan.org>
380
381 =cut