This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump versions of modules that are currently on "dev" releases in maint.
[perl5.git] / ext / B / B / Debug.pm
1 package B::Debug;
2
3 our $VERSION = '1.03';
4
5 use strict;
6 use B qw(peekop class walkoptree walkoptree_exec
7          main_start main_root cstring sv_undef);
8 use B::Asmdata qw(@specialsv_name);
9
10 my %done_gv;
11
12 sub B::OP::debug {
13     my ($op) = @_;
14     printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type;
15 %s (0x%lx)
16         op_next         0x%x
17         op_sibling      0x%x
18         op_ppaddr       %s
19         op_targ         %d
20         op_type         %d
21 EOT
22     if ($] > 5.009) {
23         printf <<'EOT', $op->opt, $op->static;
24         op_opt          %d
25         op_static       %d
26 EOT
27     } else {
28         printf <<'EOT', $op->seq;
29         op_seq          %d
30 EOT
31     }
32     printf <<'EOT', $op->flags, $op->private;
33         op_flags        %d
34         op_private      %d
35 EOT
36 }
37
38 sub B::UNOP::debug {
39     my ($op) = @_;
40     $op->B::OP::debug();
41     printf "\top_first\t0x%x\n", ${$op->first};
42 }
43
44 sub B::BINOP::debug {
45     my ($op) = @_;
46     $op->B::UNOP::debug();
47     printf "\top_last\t\t0x%x\n", ${$op->last};
48 }
49
50 sub B::LOOP::debug {
51     my ($op) = @_;
52     $op->B::BINOP::debug();
53     printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop};
54         op_redoop       0x%x
55         op_nextop       0x%x
56         op_lastop       0x%x
57 EOT
58 }
59
60 sub B::LOGOP::debug {
61     my ($op) = @_;
62     $op->B::UNOP::debug();
63     printf "\top_other\t0x%x\n", ${$op->other};
64 }
65
66 sub B::LISTOP::debug {
67     my ($op) = @_;
68     $op->B::BINOP::debug();
69     printf "\top_children\t%d\n", $op->children;
70 }
71
72 sub B::PMOP::debug {
73     my ($op) = @_;
74     $op->B::LISTOP::debug();
75     printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
76     printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
77     printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
78     printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
79     printf "\top_pmflags\t0x%x\n", $op->pmflags;
80     $op->pmreplroot->debug;
81 }
82
83 sub B::COP::debug {
84     my ($op) = @_;
85     $op->B::OP::debug();
86     my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
87     printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
88         cop_label       %s
89         cop_stashpv     %s
90         cop_file        %s
91         cop_seq         %d
92         cop_arybase     %d
93         cop_line        %d
94         cop_warnings    0x%x
95         cop_io          %s
96 EOT
97 }
98
99 sub B::SVOP::debug {
100     my ($op) = @_;
101     $op->B::OP::debug();
102     printf "\top_sv\t\t0x%x\n", ${$op->sv};
103     $op->sv->debug;
104 }
105
106 sub B::PVOP::debug {
107     my ($op) = @_;
108     $op->B::OP::debug();
109     printf "\top_pv\t\t%s\n", cstring($op->pv);
110 }
111
112 sub B::PADOP::debug {
113     my ($op) = @_;
114     $op->B::OP::debug();
115     printf "\top_padix\t\t%ld\n", $op->padix;
116 }
117
118 sub B::NULL::debug {
119     my ($sv) = @_;
120     if ($$sv == ${sv_undef()}) {
121         print "&sv_undef\n";
122     } else {
123         printf "NULL (0x%x)\n", $$sv;
124     }
125 }
126
127 sub B::SV::debug {
128     my ($sv) = @_;
129     if (!$$sv) {
130         print class($sv), " = NULL\n";
131         return;
132     }
133     printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
134 %s (0x%x)
135         REFCNT          %d
136         FLAGS           0x%x
137 EOT
138 }
139
140 sub B::RV::debug {
141     my ($rv) = @_;
142     B::SV::debug($rv);
143     printf <<'EOT', ${$rv->RV};
144         RV              0x%x
145 EOT
146     $rv->RV->debug;
147 }
148
149 sub B::PV::debug {
150     my ($sv) = @_;
151     $sv->B::SV::debug();
152     my $pv = $sv->PV();
153     printf <<'EOT', cstring($pv), length($pv);
154         xpv_pv          %s
155         xpv_cur         %d
156 EOT
157 }
158
159 sub B::IV::debug {
160     my ($sv) = @_;
161     $sv->B::SV::debug();
162     printf "\txiv_iv\t\t%d\n", $sv->IV;
163 }
164
165 sub B::NV::debug {
166     my ($sv) = @_;
167     $sv->B::IV::debug();
168     printf "\txnv_nv\t\t%s\n", $sv->NV;
169 }
170
171 sub B::PVIV::debug {
172     my ($sv) = @_;
173     $sv->B::PV::debug();
174     printf "\txiv_iv\t\t%d\n", $sv->IV;
175 }
176
177 sub B::PVNV::debug {
178     my ($sv) = @_;
179     $sv->B::PVIV::debug();
180     printf "\txnv_nv\t\t%s\n", $sv->NV;
181 }
182
183 sub B::PVLV::debug {
184     my ($sv) = @_;
185     $sv->B::PVNV::debug();
186     printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
187     printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
188     printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
189 }
190
191 sub B::BM::debug {
192     my ($sv) = @_;
193     $sv->B::PVNV::debug();
194     printf "\txbm_useful\t%d\n", $sv->USEFUL;
195     printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
196     printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
197 }
198
199 sub B::CV::debug {
200     my ($sv) = @_;
201     $sv->B::PVNV::debug();
202     my ($stash) = $sv->STASH;
203     my ($start) = $sv->START;
204     my ($root) = $sv->ROOT;
205     my ($padlist) = $sv->PADLIST;
206     my ($file) = $sv->FILE;
207     my ($gv) = $sv->GV;
208     printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
209         STASH           0x%x
210         START           0x%x
211         ROOT            0x%x
212         GV              0x%x
213         FILE            %s
214         DEPTH           %d
215         PADLIST         0x%x
216         OUTSIDE         0x%x
217         OUTSIDE_SEQ     %d
218 EOT
219     $start->debug if $start;
220     $root->debug if $root;
221     $gv->debug if $gv;
222     $padlist->debug if $padlist;
223 }
224
225 sub B::AV::debug {
226     my ($av) = @_;
227     $av->B::SV::debug;
228     my(@array) = $av->ARRAY;
229     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
230     printf <<'EOT', scalar(@array), $av->MAX, $av->OFF;
231         FILL            %d
232         MAX             %d
233         OFF             %d
234 EOT
235     printf <<'EOT', $av->AvFLAGS if $] < 5.009;
236         AvFLAGS         %d
237 EOT
238 }
239
240 sub B::GV::debug {
241     my ($gv) = @_;
242     if ($done_gv{$$gv}++) {
243         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
244         return;
245     }
246     my ($sv) = $gv->SV;
247     my ($av) = $gv->AV;
248     my ($cv) = $gv->CV;
249     $gv->B::SV::debug;
250     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;
251         NAME            %s
252         STASH           %s (0x%x)
253         SV              0x%x
254         GvREFCNT        %d
255         FORM            0x%x
256         AV              0x%x
257         HV              0x%x
258         EGV             0x%x
259         CV              0x%x
260         CVGEN           %d
261         LINE            %d
262         FILE            %s
263         GvFLAGS         0x%x
264 EOT
265     $sv->debug if $sv;
266     $av->debug if $av;
267     $cv->debug if $cv;
268 }
269
270 sub B::SPECIAL::debug {
271     my $sv = shift;
272     print $specialsv_name[$$sv], "\n";
273 }
274
275 sub compile {
276     my $order = shift;
277     B::clearsym();
278     if ($order && $order eq "exec") {
279         return sub { walkoptree_exec(main_start, "debug") }
280     } else {
281         return sub { walkoptree(main_root, "debug") }
282     }
283 }
284
285 1;
286
287 __END__
288
289 =head1 NAME
290
291 B::Debug - Walk Perl syntax tree, printing debug info about ops
292
293 =head1 SYNOPSIS
294
295         perl -MO=Debug[,OPTIONS] foo.pl
296
297 =head1 DESCRIPTION
298
299 See F<ext/B/README>.
300
301 =head1 AUTHOR
302
303 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
304
305 =cut