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