This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
segfault on &Internals::* due to missing SvROK()
[perl5.git] / cpan / B-Debug / Debug.pm
CommitLineData
a798dbf2 1package B::Debug;
28b605d8 2
daaaeea5 3our $VERSION = '1.12';
28b605d8 4
a798dbf2 5use strict;
7cd4b8a8 6require 5.006;
a798dbf2 7use B qw(peekop class walkoptree walkoptree_exec
93f00e88 8 main_start main_root cstring sv_undef);
7cd4b8a8
RGS
9use Config;
10my (@optype, @specialsv_name);
93f00e88
RU
11require B;
12if ($] < 5.009) {
13 require B::Asmdata;
14 B::Asmdata->import qw(@optype @specialsv_name);
15} else {
16 B->import qw(@optype @specialsv_name);
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;
28 return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
29}
30
a798dbf2
MB
31sub B::OP::debug {
32 my ($op) = @_;
c1307613 33 printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
a798dbf2 34%s (0x%lx)
a798dbf2 35 op_ppaddr %s
c1307613
RU
36 op_next %s
37 op_sibling %s
a798dbf2
MB
38 op_targ %d
39 op_type %d
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();
6e6a1aef 120 my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
127212b2 121 printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
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
6e6a1aef 129 cop_io %s
a798dbf2 130EOT
a798dbf2
MB
131}
132
133sub B::SVOP::debug {
134 my ($op) = @_;
135 $op->B::OP::debug();
136 printf "\top_sv\t\t0x%x\n", ${$op->sv};
137 $op->sv->debug;
138}
139
140sub B::PVOP::debug {
141 my ($op) = @_;
142 $op->B::OP::debug();
3267896c 143 printf "\top_pv\t\t%s\n", cstring($op->pv);
a798dbf2
MB
144}
145
7934575e 146sub B::PADOP::debug {
a798dbf2
MB
147 my ($op) = @_;
148 $op->B::OP::debug();
c1307613 149 printf "\top_padix\t%ld\n", $op->padix;
a798dbf2
MB
150}
151
a798dbf2
MB
152sub B::NULL::debug {
153 my ($sv) = @_;
154 if ($$sv == ${sv_undef()}) {
155 print "&sv_undef\n";
156 } else {
157 printf "NULL (0x%x)\n", $$sv;
158 }
159}
160
161sub B::SV::debug {
162 my ($sv) = @_;
163 if (!$$sv) {
164 print class($sv), " = NULL\n";
165 return;
166 }
167 printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
168%s (0x%x)
169 REFCNT %d
170 FLAGS 0x%x
171EOT
172}
173
3267896c
RH
174sub B::RV::debug {
175 my ($rv) = @_;
176 B::SV::debug($rv);
177 printf <<'EOT', ${$rv->RV};
178 RV 0x%x
179EOT
180 $rv->RV->debug;
181}
182
a798dbf2
MB
183sub B::PV::debug {
184 my ($sv) = @_;
185 $sv->B::SV::debug();
186 my $pv = $sv->PV();
187 printf <<'EOT', cstring($pv), length($pv);
188 xpv_pv %s
189 xpv_cur %d
190EOT
191}
192
193sub B::IV::debug {
194 my ($sv) = @_;
195 $sv->B::SV::debug();
196 printf "\txiv_iv\t\t%d\n", $sv->IV;
197}
198
199sub B::NV::debug {
200 my ($sv) = @_;
201 $sv->B::IV::debug();
202 printf "\txnv_nv\t\t%s\n", $sv->NV;
203}
204
205sub B::PVIV::debug {
206 my ($sv) = @_;
207 $sv->B::PV::debug();
208 printf "\txiv_iv\t\t%d\n", $sv->IV;
209}
210
211sub B::PVNV::debug {
212 my ($sv) = @_;
213 $sv->B::PVIV::debug();
214 printf "\txnv_nv\t\t%s\n", $sv->NV;
215}
216
217sub B::PVLV::debug {
218 my ($sv) = @_;
219 $sv->B::PVNV::debug();
220 printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
221 printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
222 printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
223}
224
225sub B::BM::debug {
226 my ($sv) = @_;
227 $sv->B::PVNV::debug();
228 printf "\txbm_useful\t%d\n", $sv->USEFUL;
229 printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
230 printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
231}
232
233sub B::CV::debug {
234 my ($sv) = @_;
235 $sv->B::PVNV::debug();
236 my ($stash) = $sv->STASH;
237 my ($start) = $sv->START;
238 my ($root) = $sv->ROOT;
239 my ($padlist) = $sv->PADLIST;
57843af0 240 my ($file) = $sv->FILE;
a798dbf2 241 my ($gv) = $sv->GV;
a3985cdc 242 printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
a798dbf2
MB
243 STASH 0x%x
244 START 0x%x
245 ROOT 0x%x
246 GV 0x%x
57843af0 247 FILE %s
a798dbf2 248 DEPTH %d
7e107e90 249 PADLIST 0x%x
a798dbf2 250 OUTSIDE 0x%x
a3985cdc 251 OUTSIDE_SEQ %d
a798dbf2
MB
252EOT
253 $start->debug if $start;
254 $root->debug if $root;
255 $gv->debug if $gv;
a798dbf2
MB
256 $padlist->debug if $padlist;
257}
258
259sub B::AV::debug {
260 my ($av) = @_;
261 $av->B::SV::debug;
93f00e88
RU
262 # tied arrays may leave out FETCHSIZE
263 my (@array) = eval { $av->ARRAY; };
a798dbf2 264 print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
93f00e88 265 my $fill = eval { scalar(@array) };
7cd4b8a8 266 if ($Config{'useithreads'}) {
93f00e88 267 printf <<'EOT', $fill, $av->MAX, $av->OFF;
7e107e90 268 FILL %d
a798dbf2
MB
269 MAX %d
270 OFF %d
a798dbf2 271EOT
93f00e88
RU
272 } else {
273 printf <<'EOT', $fill, $av->MAX;
274 FILL %d
275 MAX %d
276EOT
277 }
7cd4b8a8 278 printf <<'EOT', $av->AvFLAGS if $] < 5.009;
bb7c595b
NC
279 AvFLAGS %d
280EOT
a798dbf2 281}
7e107e90 282
a798dbf2
MB
283sub B::GV::debug {
284 my ($gv) = @_;
285 if ($done_gv{$$gv}++) {
002b978b 286 printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
a798dbf2
MB
287 return;
288 }
289 my ($sv) = $gv->SV;
290 my ($av) = $gv->AV;
291 my ($cv) = $gv->CV;
292 $gv->B::SV::debug;
002b978b 293 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
294 NAME %s
295 STASH %s (0x%x)
296 SV 0x%x
297 GvREFCNT %d
298 FORM 0x%x
299 AV 0x%x
300 HV 0x%x
301 EGV 0x%x
302 CV 0x%x
303 CVGEN %d
304 LINE %d
b195d487 305 FILE %s
a798dbf2
MB
306 GvFLAGS 0x%x
307EOT
308 $sv->debug if $sv;
309 $av->debug if $av;
310 $cv->debug if $cv;
311}
312
313sub B::SPECIAL::debug {
314 my $sv = shift;
315 print $specialsv_name[$$sv], "\n";
316}
317
318sub compile {
319 my $order = shift;
2b8dc4d2 320 B::clearsym();
7ebf56ae 321 if ($order && $order eq "exec") {
a798dbf2
MB
322 return sub { walkoptree_exec(main_start, "debug") }
323 } else {
324 return sub { walkoptree(main_root, "debug") }
325 }
326}
327
3281;
7f20e9dd
GS
329
330__END__
331
332=head1 NAME
333
334B::Debug - Walk Perl syntax tree, printing debug info about ops
335
336=head1 SYNOPSIS
337
338 perl -MO=Debug[,OPTIONS] foo.pl
339
340=head1 DESCRIPTION
341
c1307613
RU
342See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
343
344=head1 OPTIONS
345
346With option -exec, walks tree in execute order,
347otherwise in basic order.
7f20e9dd 348
93f00e88
RU
349=head1 Changes
350
daaaeea5
RU
351 1.12 2010-02-10 rurban
352 remove archlib installation cruft, and use the proper PM rule.
353 By Todd Rinaldo (toddr)
354
7cd4b8a8
RGS
355 1.11 2008-07-14 rurban
356 avoid B::Flags in CORE tests not to crash on old XS in @INC
357
358 1.10 2008-06-28 rurban
359 require 5.006; Test::More not possible in 5.00505
360 our => my
0106d518 361
7cd4b8a8
RGS
362 1.09 2008-06-18 rurban
363 minor META.yml syntax fix
364 5.8.0 ending nextstate test failure: be more tolerant
365 PREREQ_PM Test::More
366
367 1.08 2008-06-17 rurban
368 support 5.00558 - 5.6.2
369
370 1.07 2008-06-16 rurban
371 debug.t: fix strawberry perl quoting issue
372
373 1.06 2008-06-11 rurban
93f00e88
RU
374 added B::Flags output
375 dual-life CPAN as B-Debug-1.06 and CORE
376 protect scalar(@array) if tied arrays leave out FETCHSIZE
377
378 1.05_03 2008-04-16 rurban
379 ithread fixes in B::AV
380 B-C-1.04_??
381
382 B-C-1.04_09 2008-02-24 rurban
383 support 5.8 (import Asmdata)
384
385 1.05_02 2008-02-21 rurban
386 added _printop
387 B-C-1.04_08 and CORE
388
389 1.05_01 2008-02-05 rurban
390 5.10 fix for op->seq
391 B-C-1.04_04
392
7f20e9dd
GS
393=head1 AUTHOR
394
395Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
93f00e88 396Reini Urban C<rurban@cpan.org>
7f20e9dd 397
7cd4b8a8
RGS
398=head1 LICENSE
399
400Copyright (c) 1996, 1997 Malcolm Beattie
401Copyright (c) 2008 Reini Urban
402
403 This program is free software; you can redistribute it and/or modify
404 it under the terms of either:
405
406 a) the GNU General Public License as published by the Free
407 Software Foundation; either version 1, or (at your option) any
408 later version, or
409
410 b) the "Artistic License" which comes with this kit.
411
412 This program is distributed in the hope that it will be useful,
413 but WITHOUT ANY WARRANTY; without even the implied warranty of
414 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
415 the GNU General Public License or the Artistic License for more details.
416
417 You should have received a copy of the Artistic License with this kit,
418 in the file named "Artistic". If not, you can get one from the Perl
419 distribution. You should also have received a copy of the GNU General
420 Public License, in the file named "Copying". If not, you can get one
421 from the Perl distribution or else write to the Free Software Foundation,
422 Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
423
7f20e9dd 424=cut