7 use B qw(peekop class walkoptree walkoptree_exec
8 main_start main_root cstring sv_undef SVf_NOK SVf_IOK);
10 my (@optype, @specialsv_name);
14 B::Asmdata->import (qw(@optype @specialsv_name));
16 B->import (qw(@optype @specialsv_name));
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;
28 my ($have_B_Flags, $have_B_Flags_extra);
29 if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
30 eval { require B::Flags and $have_B_Flags++ };
31 $have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03';
37 my $addr = ${$op} ? $op->ppaddr : '';
38 $addr =~ s/^PL_ppaddr// if $addr;
39 return sprintf "0x%08x %6s %s", ${$op}, ${$op} ? class($op) : '', $addr;
44 printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
53 printf <<'EOT', $op->opt;
57 printf <<'EOT', $op->seq;
62 printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
67 printf <<'EOT', $op->flags, $op->private;
77 printf "\top_first\t%s\n", _printop($op->first);
82 $op->B::UNOP::debug();
83 printf "\top_last \t%s\n", _printop($op->last);
88 $op->B::BINOP::debug();
89 printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
98 $op->B::UNOP::debug();
99 printf "\top_other\t%s\n", _printop($op->other);
102 sub B::LISTOP::debug {
104 $op->B::BINOP::debug();
105 printf "\top_children\t%d\n", $op->children;
110 $op->B::LISTOP::debug();
111 printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
112 printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
113 printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
114 if ($Config{'useithreads'}) {
115 printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
116 printf "\top_pmoffset\t%d\n", $op->pmoffset;
118 printf "\top_pmstash\t%s\n", cstring($op->pmstash);
120 printf "\top_precomp\t%s\n", cstring($op->precomp);
121 printf "\top_pmflags\t0x%x\n", $op->pmflags;
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;
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;
141 if ($] > 5.008 and $] < 5.011) {
142 my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
143 printf(" cop_io %s\n", cstring($cop_io));
150 printf "\top_sv\t\t0x%x\n", ${$op->sv};
157 printf "\top_pv\t\t%s\n", cstring($op->pv);
160 sub B::PADOP::debug {
163 printf "\top_padix\t%ld\n", $op->padix;
168 if ($$sv == ${sv_undef()}) {
171 printf "NULL (0x%x)\n", $$sv;
178 print class($sv), " = NULL\n";
181 printf <<'EOT', class($sv), $$sv, $sv->REFCNT;
186 printf "\tFLAGS\t\t0x%x", $sv->FLAGS;
188 printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv;
196 printf <<'EOT', ${$rv->RV};
206 printf <<'EOT', cstring($pv), length($pv);
215 printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
221 printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
227 printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
232 $sv->B::PVIV::debug();
233 printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
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));
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));
254 $sv->B::PVNV::debug();
255 my ($stash) = $sv->STASH;
256 my ($start) = $sv->START;
257 my ($root) = $sv->ROOT;
258 my ($padlist) = $sv->PADLIST;
259 my ($file) = $sv->FILE;
261 printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
271 printf("\tOUTSIDE_SEQ\t%d\n", , $sv->OUTSIDE_SEQ) if $] > 5.007;
273 my $SVt_PVCV = $] < 5.010 ? 12 : 13;
274 printf("\tCvFLAGS\t0x%x\t%s\n", $sv->CvFLAGS,
275 $have_B_Flags_extra ? $sv->flagspv($SVt_PVCV) : $sv->flagspv);
277 printf("\tCvFLAGS\t0x%x\n", $sv->CvFLAGS);
279 $start->debug if $start;
280 $root->debug if $root;
282 $padlist->debug if $padlist;
293 # tied arrays may leave out FETCHSIZE
294 my (@array) = eval { $av->ARRAY; };
295 print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
296 my $fill = eval { scalar(@array) };
297 if ($Config{'useithreads'} && class($av) ne 'PADLIST') {
298 printf <<'EOT', $fill, $av->MAX, $av->OFF;
304 printf <<'EOT', $fill, $av->MAX;
311 printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS,
312 $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv);
314 printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS);
321 if ($done_gv{$$gv}++) {
322 printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
329 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;
344 my $SVt_PVGV = $] < 5.010 ? 13 : 9;
345 printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS,
346 $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv);
348 printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS);
355 sub B::SPECIAL::debug {
357 my $i = ref $sv ? $$sv : 0;
358 print exists $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
361 sub B::PADLIST::debug {
363 printf <<'EOT', class($padlist), $$padlist, $padlist->REFCNT;
367 _array_debug($padlist);
373 if ($order && $order eq "exec") {
374 return sub { walkoptree_exec(main_start, "debug") }
376 return sub { walkoptree(main_root, "debug") }
386 B::Debug - Walk Perl syntax tree, printing debug info about ops
390 perl -MO=Debug foo.pl
391 perl -MO=Debug,-exec foo.pl
395 See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
399 With option -exec, walks tree in execute order,
400 otherwise in basic order.
404 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
405 Reini Urban C<rurban@cpan.org>
409 Copyright (c) 1996, 1997 Malcolm Beattie
410 Copyright (c) 2008, 2010 Reini Urban
412 This program is free software; you can redistribute it and/or modify
413 it under the terms of either:
415 a) the GNU General Public License as published by the Free
416 Software Foundation; either version 1, or (at your option) any
419 b) the "Artistic License" which comes with this kit.
421 This program is distributed in the hope that it will be useful,
422 but WITHOUT ANY WARRANTY; without even the implied warranty of
423 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
424 the GNU General Public License or the Artistic License for more details.
426 You should have received a copy of the Artistic License with this kit,
427 in the file named "Artistic". If not, you can get one from the Perl
428 distribution. You should also have received a copy of the GNU General
429 Public License, in the file named "Copying". If not, you can get one
430 from the Perl distribution or else write to the Free Software Foundation,
431 Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.