This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
B-Debug 1.14
[perl5.git] / cpan / B-Debug / Debug.pm
1 package B::Debug;
2
3 our $VERSION = '1.14';
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 SVf_NOK SVf_IOK);
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%08x %6s %s", ${$op}, ${$op} ? class($op) : '', $addr;
29 }
30
31 sub B::OP::debug {
32     my ($op) = @_;
33     printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
34 %s (0x%lx)
35         op_ppaddr       %s
36         op_next         %s
37         op_sibling      %s
38         op_targ         %d
39         op_type         %d      %s
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 $warnings = ref $op->warnings ? ${$op->warnings} : 0;
121     printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, $warnings;
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 EOT
130   if ($] >= 5.007 and $] < 5.011) {
131     my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
132     printf("    cop_io          %s\n", cstring($cop_io));
133   }
134 }
135
136 sub B::SVOP::debug {
137     my ($op) = @_;
138     $op->B::OP::debug();
139     printf "\top_sv\t\t0x%x\n", ${$op->sv};
140     $op->sv->debug;
141 }
142
143 sub B::PVOP::debug {
144     my ($op) = @_;
145     $op->B::OP::debug();
146     printf "\top_pv\t\t%s\n", cstring($op->pv);
147 }
148
149 sub B::PADOP::debug {
150     my ($op) = @_;
151     $op->B::OP::debug();
152     printf "\top_padix\t%ld\n", $op->padix;
153 }
154
155 sub B::NULL::debug {
156     my ($sv) = @_;
157     if ($$sv == ${sv_undef()}) {
158         print "&sv_undef\n";
159     } else {
160         printf "NULL (0x%x)\n", $$sv;
161     }
162 }
163
164 sub B::SV::debug {
165     my ($sv) = @_;
166     if (!$$sv) {
167         print class($sv), " = NULL\n";
168         return;
169     }
170     printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
171 %s (0x%x)
172         REFCNT          %d
173         FLAGS           0x%x
174 EOT
175 }
176
177 sub B::RV::debug {
178     my ($rv) = @_;
179     B::SV::debug($rv);
180     printf <<'EOT', ${$rv->RV};
181         RV              0x%x
182 EOT
183     $rv->RV->debug;
184 }
185
186 sub B::PV::debug {
187     my ($sv) = @_;
188     $sv->B::SV::debug();
189     my $pv = $sv->PV();
190     printf <<'EOT', cstring($pv), length($pv);
191         xpv_pv          %s
192         xpv_cur         %d
193 EOT
194 }
195
196 sub B::IV::debug {
197     my ($sv) = @_;
198     $sv->B::SV::debug();
199     printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
200 }
201
202 sub B::NV::debug {
203     my ($sv) = @_;
204     $sv->B::IV::debug();
205     printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
206 }
207
208 sub B::PVIV::debug {
209     my ($sv) = @_;
210     $sv->B::PV::debug();
211     printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
212 }
213
214 sub B::PVNV::debug {
215     my ($sv) = @_;
216     $sv->B::PVIV::debug();
217     printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
218 }
219
220 sub B::PVLV::debug {
221     my ($sv) = @_;
222     $sv->B::PVNV::debug();
223     printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
224     printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
225     printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
226 }
227
228 sub B::BM::debug {
229     my ($sv) = @_;
230     $sv->B::PVNV::debug();
231     printf "\txbm_useful\t%d\n", $sv->USEFUL;
232     printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
233     printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
234 }
235
236 sub B::CV::debug {
237     my ($sv) = @_;
238     $sv->B::PVNV::debug();
239     my ($stash) = $sv->STASH;
240     my ($start) = $sv->START;
241     my ($root)  = $sv->ROOT;
242     my ($padlist) = $sv->PADLIST;
243     my ($file) = $sv->FILE;
244     my ($gv) = $sv->GV;
245     printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
246         STASH           0x%x
247         START           0x%x
248         ROOT            0x%x
249         GV              0x%x
250         FILE            %s
251         DEPTH           %d
252         PADLIST         0x%x
253         OUTSIDE         0x%x
254 EOT
255     printf("\tOUTSIDE_SEQ\t%d\n", , $sv->OUTSIDE_SEQ) if $] > 5.007;
256     $start->debug if $start;
257     $root->debug if $root;
258     $gv->debug if $gv;
259     $padlist->debug if $padlist;
260 }
261
262 sub B::AV::debug {
263     my ($av) = @_;
264     $av->B::SV::debug;
265     # tied arrays may leave out FETCHSIZE
266     my (@array) = eval { $av->ARRAY; };
267     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
268     my $fill = eval { scalar(@array) };
269     if ($Config{'useithreads'}) {
270       printf <<'EOT', $fill, $av->MAX, $av->OFF;
271         FILL            %d
272         MAX             %d
273         OFF             %d
274 EOT
275     } else {
276       printf <<'EOT', $fill, $av->MAX;
277         FILL            %d
278         MAX             %d
279 EOT
280     }
281     printf <<'EOT', $av->AvFLAGS if $] < 5.009;
282         AvFLAGS         %d
283 EOT
284 }
285
286 sub B::GV::debug {
287     my ($gv) = @_;
288     if ($done_gv{$$gv}++) {
289         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
290         return;
291     }
292     my $sv = $gv->SV;
293     my $av = $gv->AV;
294     my $cv = $gv->CV;
295     $gv->B::SV::debug;
296     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;
297         NAME            %s
298         STASH           %s (0x%x)
299         SV              0x%x
300         GvREFCNT        %d
301         FORM            0x%x
302         AV              0x%x
303         HV              0x%x
304         EGV             0x%x
305         CV              0x%x
306         CVGEN           %d
307         LINE            %d
308         FILE            %s
309         GvFLAGS         0x%x
310 EOT
311     $sv->debug if $sv;
312     $av->debug if $av;
313     $cv->debug if $cv;
314 }
315
316 sub B::SPECIAL::debug {
317     my $sv = shift;
318     my $i = ref $sv ? $$sv : 0;
319     print exists $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
320 }
321
322 sub compile {
323     my $order = shift;
324     B::clearsym();
325     if ($order && $order eq "exec") {
326         return sub { walkoptree_exec(main_start, "debug") }
327     } else {
328         return sub { walkoptree(main_root, "debug") }
329     }
330 }
331
332 1;
333
334 __END__
335
336 =head1 NAME
337
338 B::Debug - Walk Perl syntax tree, printing debug info about ops
339
340 =head1 SYNOPSIS
341
342         perl -MO=Debug[,OPTIONS] foo.pl
343
344 =head1 DESCRIPTION
345
346 See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
347
348 =head1 OPTIONS
349
350 With option -exec, walks tree in execute order,
351 otherwise in basic order.
352
353 =head1 Changes
354
355   1.13 2010-09-09 rurban
356         print name of op_type
357         print ppaddr consistent with other op addr
358         fix cop_io
359         omit cv->OUTSIDE_SEQ for 5.6
360         fix NULL specials
361         fix NV assertion for CV
362         stabilize tests for space in runperl path
363         fix t/debug.t test 7
364
365   1.12 2010-02-10 rurban
366         remove archlib installation cruft, and use the proper PM rule.
367         By Todd Rinaldo (toddr)
368
369   1.11 2008-07-14 rurban
370         avoid B::Flags in CORE tests not to crash on old XS in @INC
371
372   1.10 2008-06-28 rurban
373         require 5.006; Test::More not possible in 5.00505
374         our => my
375         
376   1.09 2008-06-18 rurban
377         minor META.yml syntax fix
378         5.8.0 ending nextstate test failure: be more tolerant
379         PREREQ_PM Test::More
380
381   1.08 2008-06-17 rurban
382         support 5.00558 - 5.6.2
383
384   1.07 2008-06-16 rurban
385         debug.t: fix strawberry perl quoting issue
386
387   1.06 2008-06-11 rurban
388         added B::Flags output
389         dual-life CPAN as B-Debug-1.06 and CORE
390         protect scalar(@array) if tied arrays leave out FETCHSIZE
391
392   1.05_03 2008-04-16 rurban
393         ithread fixes in B::AV
394         B-C-1.04_??
395
396   B-C-1.04_09 2008-02-24 rurban
397         support 5.8 (import Asmdata)
398
399   1.05_02 2008-02-21 rurban
400         added _printop
401         B-C-1.04_08 and CORE
402
403   1.05_01 2008-02-05 rurban
404         5.10 fix for op->seq
405         B-C-1.04_04
406
407 =head1 AUTHOR
408
409 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
410 Reini Urban C<rurban@cpan.org>
411
412 =head1 LICENSE
413
414 Copyright (c) 1996, 1997 Malcolm Beattie
415 Copyright (c) 2008 Reini Urban
416
417         This program is free software; you can redistribute it and/or modify
418         it under the terms of either:
419
420         a) the GNU General Public License as published by the Free
421         Software Foundation; either version 1, or (at your option) any
422         later version, or
423
424         b) the "Artistic License" which comes with this kit.
425
426     This program is distributed in the hope that it will be useful,
427     but WITHOUT ANY WARRANTY; without even the implied warranty of
428     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
429     the GNU General Public License or the Artistic License for more details.
430
431     You should have received a copy of the Artistic License with this kit,
432     in the file named "Artistic".  If not, you can get one from the Perl
433     distribution. You should also have received a copy of the GNU General
434     Public License, in the file named "Copying". If not, you can get one
435     from the Perl distribution or else write to the Free Software Foundation,
436     Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
437
438 =cut