This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2bcfb436d81e97deeb1e74ce0f1e76b6711d4436
[perl5.git] / cpan / B-Debug / Debug.pm
1 package B::Debug;
2
3 our $VERSION = '1.11';
4
5 use strict;
6 require 5.006;
7 use B qw(peekop class walkoptree walkoptree_exec
8          main_start main_root cstring sv_undef);
9 use Config;
10 my (@optype, @specialsv_name);
11 require B;
12 if ($] < 5.009) {
13   require B::Asmdata;
14   B::Asmdata->import qw(@optype @specialsv_name);
15 } else {
16   B->import qw(@optype @specialsv_name);
17 }
18 my $have_B_Flags;
19 if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
20   eval { require B::Flags and $have_B_Flags++ };
21 }
22 my %done_gv;
23
24 sub _printop {
25   my $op = shift;
26   my $addr = ${$op} ? $op->ppaddr : '';
27   $addr =~ s/^PL_ppaddr// if $addr;
28   return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
29 }
30
31 sub B::OP::debug {
32     my ($op) = @_;
33     printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
34 %s (0x%lx)
35         op_ppaddr       %s
36         op_next         %s
37         op_sibling      %s
38         op_targ         %d
39         op_type         %d
40 EOT
41     if ($] > 5.009) {
42         printf <<'EOT', $op->opt;
43         op_opt          %d
44 EOT
45     } else {
46         printf <<'EOT', $op->seq;
47         op_seq          %d
48 EOT
49     }
50     if ($have_B_Flags) {
51         printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
52         op_flags        %d      %s
53         op_private      %d      %s
54 EOT
55     } else {
56         printf <<'EOT', $op->flags, $op->private;
57         op_flags        %d
58         op_private      %d
59 EOT
60     }
61 }
62
63 sub B::UNOP::debug {
64     my ($op) = @_;
65     $op->B::OP::debug();
66     printf "\top_first\t%s\n", _printop($op->first);
67 }
68
69 sub B::BINOP::debug {
70     my ($op) = @_;
71     $op->B::UNOP::debug();
72     printf "\top_last \t%s\n", _printop($op->last);
73 }
74
75 sub B::LOOP::debug {
76     my ($op) = @_;
77     $op->B::BINOP::debug();
78     printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
79         op_redoop       %s
80         op_nextop       %s
81         op_lastop       %s
82 EOT
83 }
84
85 sub B::LOGOP::debug {
86     my ($op) = @_;
87     $op->B::UNOP::debug();
88     printf "\top_other\t%s\n", _printop($op->other);
89 }
90
91 sub B::LISTOP::debug {
92     my ($op) = @_;
93     $op->B::BINOP::debug();
94     printf "\top_children\t%d\n", $op->children;
95 }
96
97 sub B::PMOP::debug {
98     my ($op) = @_;
99     $op->B::LISTOP::debug();
100     printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
101     printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
102     printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
103     if ($Config{'useithreads'}) {
104       printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
105       printf "\top_pmoffset\t%d\n", $op->pmoffset;
106     } else {
107       printf "\top_pmstash\t%s\n", cstring($op->pmstash);
108     }
109     printf "\top_precomp\t%s\n", cstring($op->precomp);
110     printf "\top_pmflags\t0x%x\n", $op->pmflags;
111     printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
112     printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
113     printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
114     $op->pmreplroot->debug if $] < 5.008;
115 }
116
117 sub B::COP::debug {
118     my ($op) = @_;
119     $op->B::OP::debug();
120     my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
121     printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
122         cop_label       "%s"
123         cop_stashpv     "%s"
124         cop_file        "%s"
125         cop_seq         %d
126         cop_arybase     %d
127         cop_line        %d
128         cop_warnings    0x%x
129         cop_io          %s
130 EOT
131 }
132
133 sub B::SVOP::debug {
134     my ($op) = @_;
135     $op->B::OP::debug();
136     printf "\top_sv\t\t0x%x\n", ${$op->sv};
137     $op->sv->debug;
138 }
139
140 sub B::PVOP::debug {
141     my ($op) = @_;
142     $op->B::OP::debug();
143     printf "\top_pv\t\t%s\n", cstring($op->pv);
144 }
145
146 sub B::PADOP::debug {
147     my ($op) = @_;
148     $op->B::OP::debug();
149     printf "\top_padix\t%ld\n", $op->padix;
150 }
151
152 sub B::NULL::debug {
153     my ($sv) = @_;
154     if ($$sv == ${sv_undef()}) {
155         print "&sv_undef\n";
156     } else {
157         printf "NULL (0x%x)\n", $$sv;
158     }
159 }
160
161 sub B::SV::debug {
162     my ($sv) = @_;
163     if (!$$sv) {
164         print class($sv), " = NULL\n";
165         return;
166     }
167     printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
168 %s (0x%x)
169         REFCNT          %d
170         FLAGS           0x%x
171 EOT
172 }
173
174 sub B::RV::debug {
175     my ($rv) = @_;
176     B::SV::debug($rv);
177     printf <<'EOT', ${$rv->RV};
178         RV              0x%x
179 EOT
180     $rv->RV->debug;
181 }
182
183 sub B::PV::debug {
184     my ($sv) = @_;
185     $sv->B::SV::debug();
186     my $pv = $sv->PV();
187     printf <<'EOT', cstring($pv), length($pv);
188         xpv_pv          %s
189         xpv_cur         %d
190 EOT
191 }
192
193 sub B::IV::debug {
194     my ($sv) = @_;
195     $sv->B::SV::debug();
196     printf "\txiv_iv\t\t%d\n", $sv->IV;
197 }
198
199 sub B::NV::debug {
200     my ($sv) = @_;
201     $sv->B::IV::debug();
202     printf "\txnv_nv\t\t%s\n", $sv->NV;
203 }
204
205 sub B::PVIV::debug {
206     my ($sv) = @_;
207     $sv->B::PV::debug();
208     printf "\txiv_iv\t\t%d\n", $sv->IV;
209 }
210
211 sub B::PVNV::debug {
212     my ($sv) = @_;
213     $sv->B::PVIV::debug();
214     printf "\txnv_nv\t\t%s\n", $sv->NV;
215 }
216
217 sub B::PVLV::debug {
218     my ($sv) = @_;
219     $sv->B::PVNV::debug();
220     printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
221     printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
222     printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
223 }
224
225 sub B::BM::debug {
226     my ($sv) = @_;
227     $sv->B::PVNV::debug();
228     printf "\txbm_useful\t%d\n", $sv->USEFUL;
229     printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
230     printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
231 }
232
233 sub B::CV::debug {
234     my ($sv) = @_;
235     $sv->B::PVNV::debug();
236     my ($stash) = $sv->STASH;
237     my ($start) = $sv->START;
238     my ($root) = $sv->ROOT;
239     my ($padlist) = $sv->PADLIST;
240     my ($file) = $sv->FILE;
241     my ($gv) = $sv->GV;
242     printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
243         STASH           0x%x
244         START           0x%x
245         ROOT            0x%x
246         GV              0x%x
247         FILE            %s
248         DEPTH           %d
249         PADLIST         0x%x
250         OUTSIDE         0x%x
251         OUTSIDE_SEQ     %d
252 EOT
253     $start->debug if $start;
254     $root->debug if $root;
255     $gv->debug if $gv;
256     $padlist->debug if $padlist;
257 }
258
259 sub B::AV::debug {
260     my ($av) = @_;
261     $av->B::SV::debug;
262     # tied arrays may leave out FETCHSIZE
263     my (@array) = eval { $av->ARRAY; };
264     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
265     my $fill = eval { scalar(@array) };
266     if ($Config{'useithreads'}) {
267       printf <<'EOT', $fill, $av->MAX, $av->OFF;
268         FILL            %d
269         MAX             %d
270         OFF             %d
271 EOT
272     } else {
273       printf <<'EOT', $fill, $av->MAX;
274         FILL            %d
275         MAX             %d
276 EOT
277     }
278     printf <<'EOT', $av->AvFLAGS if $] < 5.009;
279         AvFLAGS         %d
280 EOT
281 }
282
283 sub B::GV::debug {
284     my ($gv) = @_;
285     if ($done_gv{$$gv}++) {
286         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
287         return;
288     }
289     my ($sv) = $gv->SV;
290     my ($av) = $gv->AV;
291     my ($cv) = $gv->CV;
292     $gv->B::SV::debug;
293     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;
294         NAME            %s
295         STASH           %s (0x%x)
296         SV              0x%x
297         GvREFCNT        %d
298         FORM            0x%x
299         AV              0x%x
300         HV              0x%x
301         EGV             0x%x
302         CV              0x%x
303         CVGEN           %d
304         LINE            %d
305         FILE            %s
306         GvFLAGS         0x%x
307 EOT
308     $sv->debug if $sv;
309     $av->debug if $av;
310     $cv->debug if $cv;
311 }
312
313 sub B::SPECIAL::debug {
314     my $sv = shift;
315     print $specialsv_name[$$sv], "\n";
316 }
317
318 sub compile {
319     my $order = shift;
320     B::clearsym();
321     if ($order && $order eq "exec") {
322         return sub { walkoptree_exec(main_start, "debug") }
323     } else {
324         return sub { walkoptree(main_root, "debug") }
325     }
326 }
327
328 1;
329
330 __END__
331
332 =head1 NAME
333
334 B::Debug - Walk Perl syntax tree, printing debug info about ops
335
336 =head1 SYNOPSIS
337
338         perl -MO=Debug[,OPTIONS] foo.pl
339
340 =head1 DESCRIPTION
341
342 See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
343
344 =head1 OPTIONS
345
346 With option -exec, walks tree in execute order,
347 otherwise in basic order.
348
349 =head1 Changes
350
351   1.11 2008-07-14 rurban
352         avoid B::Flags in CORE tests not to crash on old XS in @INC
353
354   1.10 2008-06-28 rurban
355         require 5.006; Test::More not possible in 5.00505
356         our => my
357         
358   1.09 2008-06-18 rurban
359         minor META.yml syntax fix
360         5.8.0 ending nextstate test failure: be more tolerant
361         PREREQ_PM Test::More
362
363   1.08 2008-06-17 rurban
364         support 5.00558 - 5.6.2
365
366   1.07 2008-06-16 rurban
367         debug.t: fix strawberry perl quoting issue
368
369   1.06 2008-06-11 rurban
370         added B::Flags output
371         dual-life CPAN as B-Debug-1.06 and CORE
372         protect scalar(@array) if tied arrays leave out FETCHSIZE
373
374   1.05_03 2008-04-16 rurban
375         ithread fixes in B::AV
376         B-C-1.04_??
377
378   B-C-1.04_09 2008-02-24 rurban
379         support 5.8 (import Asmdata)
380
381   1.05_02 2008-02-21 rurban
382         added _printop
383         B-C-1.04_08 and CORE
384
385   1.05_01 2008-02-05 rurban
386         5.10 fix for op->seq
387         B-C-1.04_04
388
389 =head1 AUTHOR
390
391 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
392 Reini Urban C<rurban@cpan.org>
393
394 =head1 LICENSE
395
396 Copyright (c) 1996, 1997 Malcolm Beattie
397 Copyright (c) 2008 Reini Urban
398
399         This program is free software; you can redistribute it and/or modify
400         it under the terms of either:
401
402         a) the GNU General Public License as published by the Free
403         Software Foundation; either version 1, or (at your option) any
404         later version, or
405
406         b) the "Artistic License" which comes with this kit.
407
408     This program is distributed in the hope that it will be useful,
409     but WITHOUT ANY WARRANTY; without even the implied warranty of
410     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
411     the GNU General Public License or the Artistic License for more details.
412
413     You should have received a copy of the Artistic License with this kit,
414     in the file named "Artistic".  If not, you can get one from the Perl
415     distribution. You should also have received a copy of the GNU General
416     Public License, in the file named "Copying". If not, you can get one
417     from the Perl distribution or else write to the Free Software Foundation,
418     Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
419
420 =cut