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