From: Jarkko Hietaniemi Date: Sat, 13 Jan 2001 01:47:16 +0000 (+0000) Subject: The B::Terse drop-in replacement wasn't quite drop-in. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ad4997d384fb6e1eb82bda01bb2b68d4b15b637d;p=p5sagit%2Fp5-mst-13.2.git The B::Terse drop-in replacement wasn't quite drop-in. p4raw-id: //depot/perl@8427 --- diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm index 2a2806f..a7a071e 100644 --- a/ext/B/B/Terse.pm +++ b/ext/B/B/Terse.pm @@ -1,11 +1,132 @@ package B::Terse; -use B::Concise; +use strict; +use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow + main_start main_root cstring svref_2object); +use B::Asmdata qw(@specialsv_name); + +sub terse { + my ($order, $cvref) = @_; + my $cv = svref_2object($cvref); + if ($order eq "exec") { + walkoptree_exec($cv->START, "terse"); + } else { + walkoptree_slow($cv->ROOT, "terse"); + } +} sub compile { - my @args = @_; - $args[0] = "-exec" if $args[0] eq "exec"; - unshift @args, "-terse"; - B::Concise::compile(@args); + my $order = shift; + my @options = @_; + B::clearsym(); + if (@options) { + return sub { + my $objname; + foreach $objname (@options) { + $objname = "main::$objname" unless $objname =~ /::/; + eval "terse(\$order, \\&$objname)"; + die "terse($order, \\&$objname) failed: $@" if $@; + } + } + } else { + if ($order eq "exec") { + return sub { walkoptree_exec(main_start, "terse") } + } else { + return sub { walkoptree_slow(main_root, "terse") } + } + } +} + +sub indent { + my $level = shift; + return " " x $level; +} + +sub B::OP::terse { + my ($op, $level) = @_; + my $targ = $op->targ; + $targ = ($targ > 0) ? " [$targ]" : ""; + print indent($level), peekop($op), $targ, "\n"; +} + +sub B::SVOP::terse { + my ($op, $level) = @_; + print indent($level), peekop($op), " "; + $op->sv->terse(0); +} + +sub B::PADOP::terse { + my ($op, $level) = @_; + print indent($level), peekop($op), " ", $op->padix, "\n"; +} + +sub B::PMOP::terse { + my ($op, $level) = @_; + my $precomp = $op->precomp; + print indent($level), peekop($op), + defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n"; + +} + +sub B::PVOP::terse { + my ($op, $level) = @_; + print indent($level), peekop($op), " ", cstring($op->pv), "\n"; +} + +sub B::COP::terse { + my ($op, $level) = @_; + my $label = $op->label; + if ($label) { + $label = " label ".cstring($label); + } + print indent($level), peekop($op), $label || "", "\n"; +} + +sub B::PV::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV); +} + +sub B::AV::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL; +} + +sub B::GV::terse { + my ($gv, $level) = @_; + my $stash = $gv->STASH->NAME; + if ($stash eq "main") { + $stash = ""; + } else { + $stash = $stash . "::"; + } + print indent($level); + printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME; +} + +sub B::IV::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV; +} + +sub B::NV::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV; +} + +sub B::NULL::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s (0x%lx)\n", class($sv), $$sv; +} + +sub B::SPECIAL::terse { + my ($sv, $level) = @_; + print indent($level); + printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv]; } 1; @@ -18,18 +139,14 @@ B::Terse - Walk Perl syntax tree, printing terse info about ops =head1 SYNOPSIS - perl -MO=Terse[,OPTIONS] foo.pl + perl -MO=Terse[,OPTIONS] foo.pl =head1 DESCRIPTION -This version of B::Terse is really just a wrapper that calls B::Concise -with the B<-terse> option. It is provided for compatibility with old scripts -(and habits) but using B::Concise directly is now recommended instead. +See F. =head1 AUTHOR -The original version of B::Terse was written by Malcolm Beattie, -C. This wrapper was written by Stephen McCamant, -C. +Malcolm Beattie, C =cut