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
CommitLineData
a798dbf2 1package B::Debug;
28b605d8 2
438f0014 3our $VERSION = '1.21';
28b605d8 4
a798dbf2 5use strict;
7cd4b8a8 6require 5.006;
a798dbf2 7use B qw(peekop class walkoptree walkoptree_exec
1cecd13c 8 main_start main_root cstring sv_undef SVf_NOK SVf_IOK);
7cd4b8a8
RGS
9use Config;
10my (@optype, @specialsv_name);
93f00e88
RU
11require B;
12if ($] < 5.009) {
13 require B::Asmdata;
1cecd13c 14 B::Asmdata->import (qw(@optype @specialsv_name));
93f00e88 15} else {
1cecd13c 16 B->import (qw(@optype @specialsv_name));
93f00e88 17}
e86c8c9d
SH
18
19if ($] < 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
28my ($have_B_Flags, $have_B_Flags_extra);
7cd4b8a8
RGS
29if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
30 eval { require B::Flags and $have_B_Flags++ };
e86c8c9d 31 $have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03';
c1307613 32}
a798dbf2
MB
33my %done_gv;
34
c1307613
RU
35sub _printop {
36 my $op = shift;
37 my $addr = ${$op} ? $op->ppaddr : '';
38 $addr =~ s/^PL_ppaddr// if $addr;
1cecd13c 39 return sprintf "0x%08x %6s %s", ${$op}, ${$op} ? class($op) : '', $addr;
c1307613
RU
40}
41
a798dbf2
MB
42sub B::OP::debug {
43 my ($op) = @_;
1cecd13c 44 printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
a798dbf2 45%s (0x%lx)
a798dbf2 46 op_ppaddr %s
c1307613
RU
47 op_next %s
48 op_sibling %s
a798dbf2 49 op_targ %d
1cecd13c 50 op_type %d %s
7252851f 51EOT
7cd4b8a8 52 if ($] > 5.009) {
85594c31 53 printf <<'EOT', $op->opt;
2814eb74 54 op_opt %d
7252851f
NC
55EOT
56 } else {
57 printf <<'EOT', $op->seq;
58 op_seq %d
59EOT
60 }
93f00e88
RU
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
65EOT
66 } else {
67 printf <<'EOT', $op->flags, $op->private;
a798dbf2
MB
68 op_flags %d
69 op_private %d
70EOT
93f00e88 71 }
a798dbf2
MB
72}
73
74sub B::UNOP::debug {
75 my ($op) = @_;
76 $op->B::OP::debug();
c1307613 77 printf "\top_first\t%s\n", _printop($op->first);
a798dbf2
MB
78}
79
80sub B::BINOP::debug {
81 my ($op) = @_;
82 $op->B::UNOP::debug();
c1307613 83 printf "\top_last \t%s\n", _printop($op->last);
a798dbf2
MB
84}
85
ee3e756d
RH
86sub B::LOOP::debug {
87 my ($op) = @_;
88 $op->B::BINOP::debug();
c1307613
RU
89 printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
90 op_redoop %s
91 op_nextop %s
92 op_lastop %s
ee3e756d
RH
93EOT
94}
95
a798dbf2
MB
96sub B::LOGOP::debug {
97 my ($op) = @_;
98 $op->B::UNOP::debug();
c1307613 99 printf "\top_other\t%s\n", _printop($op->other);
a798dbf2
MB
100}
101
a798dbf2
MB
102sub B::LISTOP::debug {
103 my ($op) = @_;
104 $op->B::BINOP::debug();
c03c2844 105 printf "\top_children\t%d\n", $op->children;
a798dbf2
MB
106}
107
108sub B::PMOP::debug {
109 my ($op) = @_;
110 $op->B::LISTOP::debug();
7cd4b8a8 111 printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
a798dbf2 112 printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
7cd4b8a8
RGS
113 printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
114 if ($Config{'useithreads'}) {
c1307613
RU
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 }
93f00e88 120 printf "\top_precomp\t%s\n", cstring($op->precomp);
a798dbf2 121 printf "\top_pmflags\t0x%x\n", $op->pmflags;
7cd4b8a8
RGS
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;
a798dbf2
MB
126}
127
128sub B::COP::debug {
129 my ($op) = @_;
130 $op->B::OP::debug();
1cecd13c
RU
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;
c1307613
RU
133 cop_label "%s"
134 cop_stashpv "%s"
135 cop_file "%s"
a798dbf2
MB
136 cop_seq %d
137 cop_arybase %d
138 cop_line %d
b295d113 139 cop_warnings 0x%x
a798dbf2 140EOT
e86c8c9d 141 if ($] > 5.008 and $] < 5.011) {
1cecd13c
RU
142 my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
143 printf(" cop_io %s\n", cstring($cop_io));
144 }
a798dbf2
MB
145}
146
147sub 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
154sub B::PVOP::debug {
155 my ($op) = @_;
156 $op->B::OP::debug();
3267896c 157 printf "\top_pv\t\t%s\n", cstring($op->pv);
a798dbf2
MB
158}
159
7934575e 160sub B::PADOP::debug {
a798dbf2
MB
161 my ($op) = @_;
162 $op->B::OP::debug();
c1307613 163 printf "\top_padix\t%ld\n", $op->padix;
a798dbf2
MB
164}
165
a798dbf2
MB
166sub 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
175sub B::SV::debug {
176 my ($sv) = @_;
177 if (!$$sv) {
178 print class($sv), " = NULL\n";
179 return;
180 }
e86c8c9d 181 printf <<'EOT', class($sv), $$sv, $sv->REFCNT;
a798dbf2
MB
182%s (0x%x)
183 REFCNT %d
a798dbf2 184EOT
e86c8c9d
SH
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";
a798dbf2
MB
190}
191
3267896c
RH
192sub B::RV::debug {
193 my ($rv) = @_;
194 B::SV::debug($rv);
195 printf <<'EOT', ${$rv->RV};
196 RV 0x%x
197EOT
198 $rv->RV->debug;
199}
200
a798dbf2
MB
201sub B::PV::debug {
202 my ($sv) = @_;
203 $sv->B::SV::debug();
204 my $pv = $sv->PV();
b8e5d789 205 printf <<'EOT', cstring($pv), $sv->CUR, $sv->LEN;
a798dbf2
MB
206 xpv_pv %s
207 xpv_cur %d
b8e5d789 208 xpv_len %d
a798dbf2
MB
209EOT
210}
211
212sub B::IV::debug {
213 my ($sv) = @_;
214 $sv->B::SV::debug();
1cecd13c 215 printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
a798dbf2
MB
216}
217
218sub B::NV::debug {
219 my ($sv) = @_;
220 $sv->B::IV::debug();
1cecd13c 221 printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
a798dbf2
MB
222}
223
224sub B::PVIV::debug {
225 my ($sv) = @_;
226 $sv->B::PV::debug();
1cecd13c 227 printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
a798dbf2
MB
228}
229
230sub B::PVNV::debug {
231 my ($sv) = @_;
232 $sv->B::PVIV::debug();
1cecd13c 233 printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
a798dbf2
MB
234}
235
236sub 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
244sub 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
252sub B::CV::debug {
253 my ($sv) = @_;
254 $sv->B::PVNV::debug();
255 my ($stash) = $sv->STASH;
256 my ($start) = $sv->START;
1cecd13c 257 my ($root) = $sv->ROOT;
a798dbf2 258 my ($padlist) = $sv->PADLIST;
57843af0 259 my ($file) = $sv->FILE;
a798dbf2 260 my ($gv) = $sv->GV;
b8e5d789 261 printf <<'EOT', $$stash, $$start, $$root;
a798dbf2
MB
262 STASH 0x%x
263 START 0x%x
264 ROOT 0x%x
b8e5d789
CBW
265EOT
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};
57843af0 272 FILE %s
a798dbf2 273 DEPTH %d
7e107e90 274 PADLIST 0x%x
a798dbf2
MB
275 OUTSIDE 0x%x
276EOT
b8e5d789 277 printf("\tOUTSIDE_SEQ\t%d\n", $sv->OUTSIDE_SEQ) if $] > 5.007;
e86c8c9d
SH
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 }
a798dbf2
MB
285 $start->debug if $start;
286 $root->debug if $root;
287 $gv->debug if $gv;
a798dbf2
MB
288 $padlist->debug if $padlist;
289}
290
291sub B::AV::debug {
292 my ($av) = @_;
293 $av->B::SV::debug;
9d2d23d9
SH
294 _array_debug($av);
295}
296
297sub _array_debug {
298 my ($av) = @_;
93f00e88
RU
299 # tied arrays may leave out FETCHSIZE
300 my (@array) = eval { $av->ARRAY; };
a798dbf2 301 print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
93f00e88 302 my $fill = eval { scalar(@array) };
9d2d23d9 303 if ($Config{'useithreads'} && class($av) ne 'PADLIST') {
93f00e88 304 printf <<'EOT', $fill, $av->MAX, $av->OFF;
7e107e90 305 FILL %d
a798dbf2
MB
306 MAX %d
307 OFF %d
a798dbf2 308EOT
93f00e88
RU
309 } else {
310 printf <<'EOT', $fill, $av->MAX;
311 FILL %d
312 MAX %d
313EOT
314 }
e86c8c9d
SH
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 }
a798dbf2 323}
7e107e90 324
a798dbf2
MB
325sub B::GV::debug {
326 my ($gv) = @_;
327 if ($done_gv{$$gv}++) {
002b978b 328 printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
a798dbf2
MB
329 return;
330 }
1cecd13c
RU
331 my $sv = $gv->SV;
332 my $av = $gv->AV;
333 my $cv = $gv->CV;
a798dbf2 334 $gv->B::SV::debug;
002b978b 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;
a798dbf2
MB
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
b195d487 347 FILE %s
a798dbf2 348EOT
e86c8c9d
SH
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 }
a798dbf2
MB
356 $sv->debug if $sv;
357 $av->debug if $av;
358 $cv->debug if $cv;
359}
360
361sub B::SPECIAL::debug {
362 my $sv = shift;
1cecd13c 363 my $i = ref $sv ? $$sv : 0;
ce7ce097 364 print defined $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
a798dbf2
MB
365}
366
9d2d23d9
SH
367sub B::PADLIST::debug {
368 my ($padlist) = @_;
369 printf <<'EOT', class($padlist), $$padlist, $padlist->REFCNT;
370%s (0x%x)
371 REFCNT %d
372EOT
373 _array_debug($padlist);
374}
375
a798dbf2
MB
376sub compile {
377 my $order = shift;
2b8dc4d2 378 B::clearsym();
7ebf56ae 379 if ($order && $order eq "exec") {
a798dbf2
MB
380 return sub { walkoptree_exec(main_start, "debug") }
381 } else {
382 return sub { walkoptree(main_root, "debug") }
383 }
384}
385
3861;
7f20e9dd
GS
387
388__END__
389
390=head1 NAME
391
392B::Debug - Walk Perl syntax tree, printing debug info about ops
393
394=head1 SYNOPSIS
395
e86c8c9d
SH
396 perl -MO=Debug foo.pl
397 perl -MO=Debug,-exec foo.pl
7f20e9dd
GS
398
399=head1 DESCRIPTION
400
c1307613
RU
401See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
402
403=head1 OPTIONS
404
405With option -exec, walks tree in execute order,
406otherwise in basic order.
7f20e9dd
GS
407
408=head1 AUTHOR
409
410Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
93f00e88 411Reini Urban C<rurban@cpan.org>
7f20e9dd 412
7cd4b8a8
RGS
413=head1 LICENSE
414
415Copyright (c) 1996, 1997 Malcolm Beattie
b8e5d789 416Copyright (c) 2008, 2010, 2013 Reini Urban
7cd4b8a8
RGS
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,
8cea0f87 437 Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
7cd4b8a8 438
7f20e9dd 439=cut
9d2d23d9 440