This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
B-Debug 1.14
[perl5.git] / cpan / B-Debug / Debug.pm
CommitLineData
a798dbf2 1package B::Debug;
28b605d8 2
1cecd13c 3our $VERSION = '1.14';
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
RU
17}
18my $have_B_Flags;
7cd4b8a8
RGS
19if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
20 eval { require B::Flags and $have_B_Flags++ };
c1307613 21}
a798dbf2
MB
22my %done_gv;
23
c1307613
RU
24sub _printop {
25 my $op = shift;
26 my $addr = ${$op} ? $op->ppaddr : '';
27 $addr =~ s/^PL_ppaddr// if $addr;
1cecd13c 28 return sprintf "0x%08x %6s %s", ${$op}, ${$op} ? class($op) : '', $addr;
c1307613
RU
29}
30
a798dbf2
MB
31sub B::OP::debug {
32 my ($op) = @_;
1cecd13c 33 printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
a798dbf2 34%s (0x%lx)
a798dbf2 35 op_ppaddr %s
c1307613
RU
36 op_next %s
37 op_sibling %s
a798dbf2 38 op_targ %d
1cecd13c 39 op_type %d %s
7252851f 40EOT
7cd4b8a8 41 if ($] > 5.009) {
85594c31 42 printf <<'EOT', $op->opt;
2814eb74 43 op_opt %d
7252851f
NC
44EOT
45 } else {
46 printf <<'EOT', $op->seq;
47 op_seq %d
48EOT
49 }
93f00e88
RU
50 if ($have_B_Flags) {
51 printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
52 op_flags %d %s
53 op_private %d %s
54EOT
55 } else {
56 printf <<'EOT', $op->flags, $op->private;
a798dbf2
MB
57 op_flags %d
58 op_private %d
59EOT
93f00e88 60 }
a798dbf2
MB
61}
62
63sub B::UNOP::debug {
64 my ($op) = @_;
65 $op->B::OP::debug();
c1307613 66 printf "\top_first\t%s\n", _printop($op->first);
a798dbf2
MB
67}
68
69sub B::BINOP::debug {
70 my ($op) = @_;
71 $op->B::UNOP::debug();
c1307613 72 printf "\top_last \t%s\n", _printop($op->last);
a798dbf2
MB
73}
74
ee3e756d
RH
75sub B::LOOP::debug {
76 my ($op) = @_;
77 $op->B::BINOP::debug();
c1307613
RU
78 printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
79 op_redoop %s
80 op_nextop %s
81 op_lastop %s
ee3e756d
RH
82EOT
83}
84
a798dbf2
MB
85sub B::LOGOP::debug {
86 my ($op) = @_;
87 $op->B::UNOP::debug();
c1307613 88 printf "\top_other\t%s\n", _printop($op->other);
a798dbf2
MB
89}
90
a798dbf2
MB
91sub B::LISTOP::debug {
92 my ($op) = @_;
93 $op->B::BINOP::debug();
c03c2844 94 printf "\top_children\t%d\n", $op->children;
a798dbf2
MB
95}
96
97sub B::PMOP::debug {
98 my ($op) = @_;
99 $op->B::LISTOP::debug();
7cd4b8a8 100 printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
a798dbf2 101 printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
7cd4b8a8
RGS
102 printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
103 if ($Config{'useithreads'}) {
c1307613
RU
104 printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
105 printf "\top_pmoffset\t%d\n", $op->pmoffset;
106 } else {
107 printf "\top_pmstash\t%s\n", cstring($op->pmstash);
108 }
93f00e88 109 printf "\top_precomp\t%s\n", cstring($op->precomp);
a798dbf2 110 printf "\top_pmflags\t0x%x\n", $op->pmflags;
7cd4b8a8
RGS
111 printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
112 printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
113 printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
114 $op->pmreplroot->debug if $] < 5.008;
a798dbf2
MB
115}
116
117sub B::COP::debug {
118 my ($op) = @_;
119 $op->B::OP::debug();
1cecd13c
RU
120 my $warnings = ref $op->warnings ? ${$op->warnings} : 0;
121 printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, $warnings;
c1307613
RU
122 cop_label "%s"
123 cop_stashpv "%s"
124 cop_file "%s"
a798dbf2
MB
125 cop_seq %d
126 cop_arybase %d
127 cop_line %d
b295d113 128 cop_warnings 0x%x
a798dbf2 129EOT
1cecd13c
RU
130 if ($] >= 5.007 and $] < 5.011) {
131 my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
132 printf(" cop_io %s\n", cstring($cop_io));
133 }
a798dbf2
MB
134}
135
136sub B::SVOP::debug {
137 my ($op) = @_;
138 $op->B::OP::debug();
139 printf "\top_sv\t\t0x%x\n", ${$op->sv};
140 $op->sv->debug;
141}
142
143sub B::PVOP::debug {
144 my ($op) = @_;
145 $op->B::OP::debug();
3267896c 146 printf "\top_pv\t\t%s\n", cstring($op->pv);
a798dbf2
MB
147}
148
7934575e 149sub B::PADOP::debug {
a798dbf2
MB
150 my ($op) = @_;
151 $op->B::OP::debug();
c1307613 152 printf "\top_padix\t%ld\n", $op->padix;
a798dbf2
MB
153}
154
a798dbf2
MB
155sub B::NULL::debug {
156 my ($sv) = @_;
157 if ($$sv == ${sv_undef()}) {
158 print "&sv_undef\n";
159 } else {
160 printf "NULL (0x%x)\n", $$sv;
161 }
162}
163
164sub B::SV::debug {
165 my ($sv) = @_;
166 if (!$$sv) {
167 print class($sv), " = NULL\n";
168 return;
169 }
170 printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
171%s (0x%x)
172 REFCNT %d
173 FLAGS 0x%x
174EOT
175}
176
3267896c
RH
177sub B::RV::debug {
178 my ($rv) = @_;
179 B::SV::debug($rv);
180 printf <<'EOT', ${$rv->RV};
181 RV 0x%x
182EOT
183 $rv->RV->debug;
184}
185
a798dbf2
MB
186sub B::PV::debug {
187 my ($sv) = @_;
188 $sv->B::SV::debug();
189 my $pv = $sv->PV();
190 printf <<'EOT', cstring($pv), length($pv);
191 xpv_pv %s
192 xpv_cur %d
193EOT
194}
195
196sub B::IV::debug {
197 my ($sv) = @_;
198 $sv->B::SV::debug();
1cecd13c 199 printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
a798dbf2
MB
200}
201
202sub B::NV::debug {
203 my ($sv) = @_;
204 $sv->B::IV::debug();
1cecd13c 205 printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
a798dbf2
MB
206}
207
208sub B::PVIV::debug {
209 my ($sv) = @_;
210 $sv->B::PV::debug();
1cecd13c 211 printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
a798dbf2
MB
212}
213
214sub B::PVNV::debug {
215 my ($sv) = @_;
216 $sv->B::PVIV::debug();
1cecd13c 217 printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
a798dbf2
MB
218}
219
220sub B::PVLV::debug {
221 my ($sv) = @_;
222 $sv->B::PVNV::debug();
223 printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
224 printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
225 printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
226}
227
228sub B::BM::debug {
229 my ($sv) = @_;
230 $sv->B::PVNV::debug();
231 printf "\txbm_useful\t%d\n", $sv->USEFUL;
232 printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
233 printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
234}
235
236sub B::CV::debug {
237 my ($sv) = @_;
238 $sv->B::PVNV::debug();
239 my ($stash) = $sv->STASH;
240 my ($start) = $sv->START;
1cecd13c 241 my ($root) = $sv->ROOT;
a798dbf2 242 my ($padlist) = $sv->PADLIST;
57843af0 243 my ($file) = $sv->FILE;
a798dbf2 244 my ($gv) = $sv->GV;
1cecd13c 245 printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
a798dbf2
MB
246 STASH 0x%x
247 START 0x%x
248 ROOT 0x%x
249 GV 0x%x
57843af0 250 FILE %s
a798dbf2 251 DEPTH %d
7e107e90 252 PADLIST 0x%x
a798dbf2
MB
253 OUTSIDE 0x%x
254EOT
1cecd13c 255 printf("\tOUTSIDE_SEQ\t%d\n", , $sv->OUTSIDE_SEQ) if $] > 5.007;
a798dbf2
MB
256 $start->debug if $start;
257 $root->debug if $root;
258 $gv->debug if $gv;
a798dbf2
MB
259 $padlist->debug if $padlist;
260}
261
262sub B::AV::debug {
263 my ($av) = @_;
264 $av->B::SV::debug;
93f00e88
RU
265 # tied arrays may leave out FETCHSIZE
266 my (@array) = eval { $av->ARRAY; };
a798dbf2 267 print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
93f00e88 268 my $fill = eval { scalar(@array) };
7cd4b8a8 269 if ($Config{'useithreads'}) {
93f00e88 270 printf <<'EOT', $fill, $av->MAX, $av->OFF;
7e107e90 271 FILL %d
a798dbf2
MB
272 MAX %d
273 OFF %d
a798dbf2 274EOT
93f00e88
RU
275 } else {
276 printf <<'EOT', $fill, $av->MAX;
277 FILL %d
278 MAX %d
279EOT
280 }
7cd4b8a8 281 printf <<'EOT', $av->AvFLAGS if $] < 5.009;
bb7c595b
NC
282 AvFLAGS %d
283EOT
a798dbf2 284}
7e107e90 285
a798dbf2
MB
286sub B::GV::debug {
287 my ($gv) = @_;
288 if ($done_gv{$$gv}++) {
002b978b 289 printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
a798dbf2
MB
290 return;
291 }
1cecd13c
RU
292 my $sv = $gv->SV;
293 my $av = $gv->AV;
294 my $cv = $gv->CV;
a798dbf2 295 $gv->B::SV::debug;
002b978b 296 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
297 NAME %s
298 STASH %s (0x%x)
299 SV 0x%x
300 GvREFCNT %d
301 FORM 0x%x
302 AV 0x%x
303 HV 0x%x
304 EGV 0x%x
305 CV 0x%x
306 CVGEN %d
307 LINE %d
b195d487 308 FILE %s
a798dbf2
MB
309 GvFLAGS 0x%x
310EOT
311 $sv->debug if $sv;
312 $av->debug if $av;
313 $cv->debug if $cv;
314}
315
316sub B::SPECIAL::debug {
317 my $sv = shift;
1cecd13c
RU
318 my $i = ref $sv ? $$sv : 0;
319 print exists $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
a798dbf2
MB
320}
321
322sub compile {
323 my $order = shift;
2b8dc4d2 324 B::clearsym();
7ebf56ae 325 if ($order && $order eq "exec") {
a798dbf2
MB
326 return sub { walkoptree_exec(main_start, "debug") }
327 } else {
328 return sub { walkoptree(main_root, "debug") }
329 }
330}
331
3321;
7f20e9dd
GS
333
334__END__
335
336=head1 NAME
337
338B::Debug - Walk Perl syntax tree, printing debug info about ops
339
340=head1 SYNOPSIS
341
342 perl -MO=Debug[,OPTIONS] foo.pl
343
344=head1 DESCRIPTION
345
c1307613
RU
346See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
347
348=head1 OPTIONS
349
350With option -exec, walks tree in execute order,
351otherwise in basic order.
7f20e9dd 352
93f00e88
RU
353=head1 Changes
354
1cecd13c
RU
355 1.13 2010-09-09 rurban
356 print name of op_type
357 print ppaddr consistent with other op addr
358 fix cop_io
359 omit cv->OUTSIDE_SEQ for 5.6
360 fix NULL specials
361 fix NV assertion for CV
362 stabilize tests for space in runperl path
363 fix t/debug.t test 7
364
daaaeea5
RU
365 1.12 2010-02-10 rurban
366 remove archlib installation cruft, and use the proper PM rule.
367 By Todd Rinaldo (toddr)
368
7cd4b8a8
RGS
369 1.11 2008-07-14 rurban
370 avoid B::Flags in CORE tests not to crash on old XS in @INC
371
372 1.10 2008-06-28 rurban
373 require 5.006; Test::More not possible in 5.00505
374 our => my
0106d518 375
7cd4b8a8
RGS
376 1.09 2008-06-18 rurban
377 minor META.yml syntax fix
378 5.8.0 ending nextstate test failure: be more tolerant
379 PREREQ_PM Test::More
380
381 1.08 2008-06-17 rurban
382 support 5.00558 - 5.6.2
383
384 1.07 2008-06-16 rurban
385 debug.t: fix strawberry perl quoting issue
386
387 1.06 2008-06-11 rurban
93f00e88
RU
388 added B::Flags output
389 dual-life CPAN as B-Debug-1.06 and CORE
390 protect scalar(@array) if tied arrays leave out FETCHSIZE
391
392 1.05_03 2008-04-16 rurban
393 ithread fixes in B::AV
394 B-C-1.04_??
395
396 B-C-1.04_09 2008-02-24 rurban
397 support 5.8 (import Asmdata)
398
399 1.05_02 2008-02-21 rurban
400 added _printop
401 B-C-1.04_08 and CORE
402
403 1.05_01 2008-02-05 rurban
404 5.10 fix for op->seq
405 B-C-1.04_04
406
7f20e9dd
GS
407=head1 AUTHOR
408
409Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
93f00e88 410Reini Urban C<rurban@cpan.org>
7f20e9dd 411
7cd4b8a8
RGS
412=head1 LICENSE
413
414Copyright (c) 1996, 1997 Malcolm Beattie
415Copyright (c) 2008 Reini Urban
416
417 This program is free software; you can redistribute it and/or modify
418 it under the terms of either:
419
420 a) the GNU General Public License as published by the Free
421 Software Foundation; either version 1, or (at your option) any
422 later version, or
423
424 b) the "Artistic License" which comes with this kit.
425
426 This program is distributed in the hope that it will be useful,
427 but WITHOUT ANY WARRANTY; without even the implied warranty of
428 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
429 the GNU General Public License or the Artistic License for more details.
430
431 You should have received a copy of the Artistic License with this kit,
432 in the file named "Artistic". If not, you can get one from the Perl
433 distribution. You should also have received a copy of the GNU General
434 Public License, in the file named "Copying". If not, you can get one
435 from the Perl distribution or else write to the Free Software Foundation,
436 Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
437
7f20e9dd 438=cut