Update IPC-Cmd to CPAN version 0.76
[perl.git] / cpan / B-Debug / Debug.pm
1 package B::Debug;
2
3 our $VERSION = '1.17';
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     # tied arrays may leave out FETCHSIZE
289     my (@array) = eval { $av->ARRAY; };
290     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
291     my $fill = eval { scalar(@array) };
292     if ($Config{'useithreads'}) {
293       printf <<'EOT', $fill, $av->MAX, $av->OFF;
294         FILL            %d
295         MAX             %d
296         OFF             %d
297 EOT
298     } else {
299       printf <<'EOT', $fill, $av->MAX;
300         FILL            %d
301         MAX             %d
302 EOT
303     }
304     if ($] < 5.009) {
305       if ($have_B_Flags) {
306         printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS,
307                $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv);
308       } else {
309         printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS);
310       }
311     }
312 }
313
314 sub B::GV::debug {
315     my ($gv) = @_;
316     if ($done_gv{$$gv}++) {
317         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
318         return;
319     }
320     my $sv = $gv->SV;
321     my $av = $gv->AV;
322     my $cv = $gv->CV;
323     $gv->B::SV::debug;
324     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;
325         NAME            %s
326         STASH           %s (0x%x)
327         SV              0x%x
328         GvREFCNT        %d
329         FORM            0x%x
330         AV              0x%x
331         HV              0x%x
332         EGV             0x%x
333         CV              0x%x
334         CVGEN           %d
335         LINE            %d
336         FILE            %s
337 EOT
338     if ($have_B_Flags) {
339       my $SVt_PVGV = $] < 5.010 ? 13 : 9;
340       printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS,
341              $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv);
342     } else {
343       printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS);
344     }
345     $sv->debug if $sv;
346     $av->debug if $av;
347     $cv->debug if $cv;
348 }
349
350 sub B::SPECIAL::debug {
351     my $sv = shift;
352     my $i = ref $sv ? $$sv : 0;
353     print exists $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
354 }
355
356 sub compile {
357     my $order = shift;
358     B::clearsym();
359     if ($order && $order eq "exec") {
360         return sub { walkoptree_exec(main_start, "debug") }
361     } else {
362         return sub { walkoptree(main_root, "debug") }
363     }
364 }
365
366 1;
367
368 __END__
369
370 =head1 NAME
371
372 B::Debug - Walk Perl syntax tree, printing debug info about ops
373
374 =head1 SYNOPSIS
375
376         perl -MO=Debug foo.pl
377         perl -MO=Debug,-exec foo.pl
378
379 =head1 DESCRIPTION
380
381 See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
382
383 =head1 OPTIONS
384
385 With option -exec, walks tree in execute order,
386 otherwise in basic order.
387
388 =head1 AUTHOR
389
390 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
391 Reini Urban C<rurban@cpan.org>
392
393 =head1 LICENSE
394
395 Copyright (c) 1996, 1997 Malcolm Beattie
396 Copyright (c) 2008, 2010 Reini Urban
397
398         This program is free software; you can redistribute it and/or modify
399         it under the terms of either:
400
401         a) the GNU General Public License as published by the Free
402         Software Foundation; either version 1, or (at your option) any
403         later version, or
404
405         b) the "Artistic License" which comes with this kit.
406
407     This program is distributed in the hope that it will be useful,
408     but WITHOUT ANY WARRANTY; without even the implied warranty of
409     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
410     the GNU General Public License or the Artistic License for more details.
411
412     You should have received a copy of the Artistic License with this kit,
413     in the file named "Artistic".  If not, you can get one from the Perl
414     distribution. You should also have received a copy of the GNU General
415     Public License, in the file named "Copying". If not, you can get one
416     from the Perl distribution or else write to the Free Software Foundation,
417     Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
418
419 =cut