This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update B-Debug to CPAN version 1.21
[perl5.git] / cpan / B-Debug / Debug.pm
1 package B::Debug;
2
3 our $VERSION = '1.21';
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 EOT
185     printf "\tFLAGS\t\t0x%x", $sv->FLAGS;
186     if ($have_B_Flags) {
187       printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv;
188     }
189     print "\n";
190 }
191
192 sub B::RV::debug {
193     my ($rv) = @_;
194     B::SV::debug($rv);
195     printf <<'EOT', ${$rv->RV};
196         RV              0x%x
197 EOT
198     $rv->RV->debug;
199 }
200
201 sub B::PV::debug {
202     my ($sv) = @_;
203     $sv->B::SV::debug();
204     my $pv = $sv->PV();
205     printf <<'EOT', cstring($pv), $sv->CUR, $sv->LEN;
206         xpv_pv          %s
207         xpv_cur         %d
208         xpv_len         %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;
262         STASH           0x%x
263         START           0x%x
264         ROOT            0x%x
265 EOT
266     if ( $]>5.017 && ($sv->FLAGS & 0x40000)) { #lexsub
267       printf("\tNAME\t%%s\n", $sv->NAME);
268     } else {
269       printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME);
270     }
271     printf <<'EOT', $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
272         FILE            %s
273         DEPTH           %d
274         PADLIST         0x%x
275         OUTSIDE         0x%x
276 EOT
277     printf("\tOUTSIDE_SEQ\t%d\n", $sv->OUTSIDE_SEQ) if $] > 5.007;
278     if ($have_B_Flags) {
279       my $SVt_PVCV = $] < 5.010 ? 12 : 13;
280       printf("\tCvFLAGS\t0x%x\t%s\n", $sv->CvFLAGS,
281              $have_B_Flags_extra ? $sv->flagspv($SVt_PVCV) : $sv->flagspv);
282     } else {
283       printf("\tCvFLAGS\t0x%x\n", $sv->CvFLAGS);
284     }
285     $start->debug if $start;
286     $root->debug if $root;
287     $gv->debug if $gv;
288     $padlist->debug if $padlist;
289 }
290
291 sub B::AV::debug {
292     my ($av) = @_;
293     $av->B::SV::debug;
294     _array_debug($av);
295 }
296
297 sub _array_debug {
298     my ($av) = @_;
299     # tied arrays may leave out FETCHSIZE
300     my (@array) = eval { $av->ARRAY; };
301     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
302     my $fill = eval { scalar(@array) };
303     if ($Config{'useithreads'} && class($av) ne 'PADLIST') {
304       printf <<'EOT', $fill, $av->MAX, $av->OFF;
305         FILL            %d
306         MAX             %d
307         OFF             %d
308 EOT
309     } else {
310       printf <<'EOT', $fill, $av->MAX;
311         FILL            %d
312         MAX             %d
313 EOT
314     }
315     if ($] < 5.009) {
316       if ($have_B_Flags) {
317         printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS,
318                $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv);
319       } else {
320         printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS);
321       }
322     }
323 }
324
325 sub B::GV::debug {
326     my ($gv) = @_;
327     if ($done_gv{$$gv}++) {
328         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
329         return;
330     }
331     my $sv = $gv->SV;
332     my $av = $gv->AV;
333     my $cv = $gv->CV;
334     $gv->B::SV::debug;
335     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;
336         NAME            %s
337         STASH           %s (0x%x)
338         SV              0x%x
339         GvREFCNT        %d
340         FORM            0x%x
341         AV              0x%x
342         HV              0x%x
343         EGV             0x%x
344         CV              0x%x
345         CVGEN           %d
346         LINE            %d
347         FILE            %s
348 EOT
349     if ($have_B_Flags) {
350       my $SVt_PVGV = $] < 5.010 ? 13 : 9;
351       printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS,
352              $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv);
353     } else {
354       printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS);
355     }
356     $sv->debug if $sv;
357     $av->debug if $av;
358     $cv->debug if $cv;
359 }
360
361 sub B::SPECIAL::debug {
362     my $sv = shift;
363     my $i = ref $sv ? $$sv : 0;
364     print defined $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
365 }
366
367 sub B::PADLIST::debug {
368     my ($padlist) = @_;
369     printf <<'EOT', class($padlist), $$padlist, $padlist->REFCNT;
370 %s (0x%x)
371         REFCNT          %d
372 EOT
373     _array_debug($padlist);
374 }
375
376 sub compile {
377     my $order = shift;
378     B::clearsym();
379     if ($order && $order eq "exec") {
380         return sub { walkoptree_exec(main_start, "debug") }
381     } else {
382         return sub { walkoptree(main_root, "debug") }
383     }
384 }
385
386 1;
387
388 __END__
389
390 =head1 NAME
391
392 B::Debug - Walk Perl syntax tree, printing debug info about ops
393
394 =head1 SYNOPSIS
395
396         perl -MO=Debug foo.pl
397         perl -MO=Debug,-exec foo.pl
398
399 =head1 DESCRIPTION
400
401 See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
402
403 =head1 OPTIONS
404
405 With option -exec, walks tree in execute order,
406 otherwise in basic order.
407
408 =head1 AUTHOR
409
410 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
411 Reini Urban C<rurban@cpan.org>
412
413 =head1 LICENSE
414
415 Copyright (c) 1996, 1997 Malcolm Beattie
416 Copyright (c) 2008, 2010, 2013 Reini Urban
417
418         This program is free software; you can redistribute it and/or modify
419         it under the terms of either:
420
421         a) the GNU General Public License as published by the Free
422         Software Foundation; either version 1, or (at your option) any
423         later version, or
424
425         b) the "Artistic License" which comes with this kit.
426
427     This program is distributed in the hope that it will be useful,
428     but WITHOUT ANY WARRANTY; without even the implied warranty of
429     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
430     the GNU General Public License or the Artistic License for more details.
431
432     You should have received a copy of the Artistic License with this kit,
433     in the file named "Artistic".  If not, you can get one from the Perl
434     distribution. You should also have received a copy of the GNU General
435     Public License, in the file named "Copying". If not, you can get one
436     from the Perl distribution or else write to the Free Software Foundation,
437     Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
438
439 =cut
440