7 use B qw(peekop class walkoptree walkoptree_exec
8 main_start main_root cstring sv_undef);
10 my (@optype, @specialsv_name);
14 B::Asmdata->import qw(@optype @specialsv_name);
16 B->import qw(@optype @specialsv_name);
19 if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
20 eval { require B::Flags and $have_B_Flags++ };
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;
33 printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
42 printf <<'EOT', $op->opt;
46 printf <<'EOT', $op->seq;
51 printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
56 printf <<'EOT', $op->flags, $op->private;
66 printf "\top_first\t%s\n", _printop($op->first);
71 $op->B::UNOP::debug();
72 printf "\top_last \t%s\n", _printop($op->last);
77 $op->B::BINOP::debug();
78 printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
87 $op->B::UNOP::debug();
88 printf "\top_other\t%s\n", _printop($op->other);
91 sub B::LISTOP::debug {
93 $op->B::BINOP::debug();
94 printf "\top_children\t%d\n", $op->children;
99 $op->B::LISTOP::debug();
100 printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
101 printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
102 printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
103 if ($Config{'useithreads'}) {
104 printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
105 printf "\top_pmoffset\t%d\n", $op->pmoffset;
107 printf "\top_pmstash\t%s\n", cstring($op->pmstash);
109 printf "\top_precomp\t%s\n", cstring($op->precomp);
110 printf "\top_pmflags\t0x%x\n", $op->pmflags;
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;
120 my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
121 printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
136 printf "\top_sv\t\t0x%x\n", ${$op->sv};
143 printf "\top_pv\t\t%s\n", cstring($op->pv);
146 sub B::PADOP::debug {
149 printf "\top_padix\t%ld\n", $op->padix;
154 if ($$sv == ${sv_undef()}) {
157 printf "NULL (0x%x)\n", $$sv;
164 print class($sv), " = NULL\n";
167 printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
177 printf <<'EOT', ${$rv->RV};
187 printf <<'EOT', cstring($pv), length($pv);
196 printf "\txiv_iv\t\t%d\n", $sv->IV;
202 printf "\txnv_nv\t\t%s\n", $sv->NV;
208 printf "\txiv_iv\t\t%d\n", $sv->IV;
213 $sv->B::PVIV::debug();
214 printf "\txnv_nv\t\t%s\n", $sv->NV;
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));
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));
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;
240 my ($file) = $sv->FILE;
242 printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
253 $start->debug if $start;
254 $root->debug if $root;
256 $padlist->debug if $padlist;
262 # tied arrays may leave out FETCHSIZE
263 my (@array) = eval { $av->ARRAY; };
264 print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
265 my $fill = eval { scalar(@array) };
266 if ($Config{'useithreads'}) {
267 printf <<'EOT', $fill, $av->MAX, $av->OFF;
273 printf <<'EOT', $fill, $av->MAX;
278 printf <<'EOT', $av->AvFLAGS if $] < 5.009;
285 if ($done_gv{$$gv}++) {
286 printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
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;
313 sub B::SPECIAL::debug {
315 print $specialsv_name[$$sv], "\n";
321 if ($order && $order eq "exec") {
322 return sub { walkoptree_exec(main_start, "debug") }
324 return sub { walkoptree(main_root, "debug") }
334 B::Debug - Walk Perl syntax tree, printing debug info about ops
338 perl -MO=Debug[,OPTIONS] foo.pl
342 See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
346 With option -exec, walks tree in execute order,
347 otherwise in basic order.
351 1.11 2008-07-14 rurban
352 avoid B::Flags in CORE tests not to crash on old XS in @INC
354 1.10 2008-06-28 rurban
355 require 5.006; Test::More not possible in 5.00505
358 1.09 2008-06-18 rurban
359 minor META.yml syntax fix
360 5.8.0 ending nextstate test failure: be more tolerant
363 1.08 2008-06-17 rurban
364 support 5.00558 - 5.6.2
366 1.07 2008-06-16 rurban
367 debug.t: fix strawberry perl quoting issue
369 1.06 2008-06-11 rurban
370 added B::Flags output
371 dual-life CPAN as B-Debug-1.06 and CORE
372 protect scalar(@array) if tied arrays leave out FETCHSIZE
374 1.05_03 2008-04-16 rurban
375 ithread fixes in B::AV
378 B-C-1.04_09 2008-02-24 rurban
379 support 5.8 (import Asmdata)
381 1.05_02 2008-02-21 rurban
385 1.05_01 2008-02-05 rurban
391 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
392 Reini Urban C<rurban@cpan.org>
396 Copyright (c) 1996, 1997 Malcolm Beattie
397 Copyright (c) 2008 Reini Urban
399 This program is free software; you can redistribute it and/or modify
400 it under the terms of either:
402 a) the GNU General Public License as published by the Free
403 Software Foundation; either version 1, or (at your option) any
406 b) the "Artistic License" which comes with this kit.
408 This program is distributed in the hope that it will be useful,
409 but WITHOUT ANY WARRANTY; without even the implied warranty of
410 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
411 the GNU General Public License or the Artistic License for more details.
413 You should have received a copy of the Artistic License with this kit,
414 in the file named "Artistic". If not, you can get one from the Perl
415 distribution. You should also have received a copy of the GNU General
416 Public License, in the file named "Copying". If not, you can get one
417 from the Perl distribution or else write to the Free Software Foundation,
418 Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.