return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
#ifdef USE_ITHREADS
- if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
+ if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
+ o->op_type == OP_AELEMFAST || o->op_type == OP_RCATLINE)
return OPc_PADOP;
#endif
main_root main_start svref_2object
OPf_SPECIAL OPf_STACKED );
-use B::Terse;
+use B::Concise qw(concise_cv concise_main set_style_standard);
use strict;
my $bblock;
}
printf " %s\n", peekop($lastop);
}
- print "-------\n";
- walkoptree_exec($start, "terse");
}
sub walk_bblocks_obj {
$objname = "main::$objname" unless $objname =~ /::/;
eval "walk_bblocks_obj(\\&$objname)";
die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
+ print "-------\n";
+ set_style_standard("terse");
+ eval "concise_cv('exec', \\&$objname)";
+ die "concise_cv('exec', \\&$objname) failed: $@" if $@;
}
}
} else {
- return sub { walk_bblocks(main_root, main_start) };
+ return sub {
+ walk_bblocks(main_root, main_start);
+ print "-------\n";
+ set_style_standard("terse");
+ concise_main("exec");
+ };
}
}
use Exporter ();
-our $VERSION = "0.54";
+our $VERSION = "0.55";
our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(set_style add_callback);
+our @EXPORT_OK = qw(set_style set_style_standard add_callback
+ concise_cv concise_main);
use B qw(class ppname main_start main_root main_cv cstring svref_2object
- SVf_IOK SVf_NOK SVf_POK OPf_KIDS);
+ SVf_IOK SVf_NOK SVf_POK SVf_IVisUV OPf_KIDS);
my %style =
("terse" =>
($format, $gotofmt, $treefmt) = @_;
}
+sub set_style_standard {
+ my($name) = @_;
+ set_style(@{$style{$name}});
+}
+
sub add_callback {
push @callbacks, @_;
}
}
}
+sub concise_main {
+ my($order) = @_;
+ sequence(main_start);
+ $curcv = main_cv;
+ if ($order eq "exec") {
+ return if class(main_start) eq "NULL";
+ walk_exec(main_start);
+ } elsif ($order eq "tree") {
+ return if class(main_root) eq "NULL";
+ print tree(main_root, 0);
+ } elsif ($order eq "basic") {
+ return if class(main_root) eq "NULL";
+ walk_topdown(main_root,
+ sub { $_[0]->concise($_[1]) }, 0);
+ }
+}
+
my $start_sym = "\e(0"; # "\cN" sometimes also works
my $end_sym = "\e(B"; # "\cO" respectively
my $order = "basic";
-set_style(@{$style{concise}});
+set_style_standard("concise");
sub compile {
my @options = grep(/^-/, @_);
}
if (!@args or $do_main) {
print "main program:\n" if $do_main;
- sequence(main_start);
- $curcv = main_cv;
- if ($order eq "exec") {
- return if class(main_start) eq "NULL";
- walk_exec(main_start);
- } elsif ($order eq "tree") {
- return if class(main_root) eq "NULL";
- print tree(main_root, 0);
- } elsif ($order eq "basic") {
- return if class(main_root) eq "NULL";
- walk_topdown(main_root,
- sub { $_[0]->concise($_[1]) }, 0);
- }
+ concise_main($order);
}
}
}
walk_topdown($kid, $sub, $level + 1);
}
}
- if (class($op) eq "PMOP" and $ {$op->pmreplroot}
+ if (class($op) eq "PMOP" and $op->pmreplroot and $ {$op->pmreplroot}
and $op->pmreplroot->isa("B::OP")) {
walk_topdown($op->pmreplroot, $sub, $level + 1);
}
sub concise_sv {
my($sv, $hr) = @_;
$hr->{svclass} = class($sv);
+ $hr->{svclass} = "UV"
+ if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
$hr->{svaddr} = sprintf("%#x", $$sv);
if ($hr->{svclass} eq "GV") {
my $gv = $sv;
} elsif ($sv->FLAGS & SVf_NOK) {
$hr->{svval} .= $sv->NV;
} elsif ($sv->FLAGS & SVf_IOK) {
- $hr->{svval} .= $sv->IV;
+ $hr->{svval} .= $sv->int_value;
} elsif ($sv->FLAGS & SVf_POK) {
$hr->{svval} .= cstring($sv->PV);
+ } elsif (class($sv) eq "HV") {
+ $hr->{svval} .= 'HASH';
}
return $hr->{svclass} . " " . $hr->{svval};
}
}
my $pmreplroot = $op->pmreplroot;
my $pmreplstart;
- if ($$pmreplroot && $pmreplroot->isa("B::GV")) {
+ if ($pmreplroot && $$pmreplroot && $pmreplroot->isa("B::GV")) {
# with C<@stash_array = split(/pat/, str);>,
# *stash_array is stored in pmreplroot.
$h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
} else {
$h{arg} = "(" . concise_sv($op->sv, \%h) . ")";
}
+ } elsif ($h{class} eq "PADOP") {
+ my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
+ $h{arg} = "[" . concise_sv($sv, \%h) . "]";
}
$h{seq} = $h{hyphseq} = seq($op);
$h{seq} = "" if $h{seq} eq "-";
print concise_op($op, $level, $format);
}
+# B::OP::terse (see Terse.pm) now just calls this
+sub b_terse {
+ my($op, $level) = @_;
+
+ # This isn't necessarily right, but there's no easy way to get
+ # from an OP to the right CV. This is a limitation of the
+ # ->terse() interface style, and there isn't much to do about
+ # it. In particular, we can die in concise_op if the main pad
+ # isn't long enough, or has the wrong kind of entries, compared to
+ # the pad a sub was compiled with. The fix for that would be to
+ # make a backwards compatible "terse" format that never even
+ # looked at the pad, just like the old B::Terse. I don't think
+ # that's worth the effort, though.
+ $curcv = main_cv unless $curcv;
+
+ if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext)};
+ print fmt_line($h, $style{"terse"}[1], $level+1);
+ }
+ $lastnext = $op->next;
+ print concise_op($op, $level, $style{"terse"}[0]);
+}
+
sub tree {
my $op = shift;
my $level = shift;
references to scalars, but it is unlikely that they will need to be
changed or even used.
+To switch back to one of the standard styles like C<concise> or
+C<terse>, use C<set_style_standard>.
+
To see the output, call the subroutine returned by B<compile> in the
same way that B<O> does.
=head1 AUTHOR
-Stephen McCamant, C<smcc@CSUA.Berkeley.EDU>
+Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
=cut
package B::Terse;
-our $VERSION = '1.00';
+our $VERSION = '1.01';
use strict;
-use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow
- main_start main_root cstring svref_2object SVf_IVisUV);
+use B qw(class);
use B::Asmdata qw(@specialsv_name);
+use B::Concise qw(concise_cv set_style_standard);
+use Carp;
sub terse {
my ($order, $cvref) = @_;
- my $cv = svref_2object($cvref);
+ set_style_standard("terse");
if ($order eq "exec") {
- walkoptree_exec($cv->START, "terse");
+ concise_cv('exec', $cvref);
} else {
- walkoptree_slow($cv->ROOT, "terse");
+ concise_cv('basic', $cvref);
}
+
}
sub compile {
- 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") }
- }
- }
+ my @args = @_;
+ my $order = @args ? shift(@args) : "";
+ $order = "-exec" if $order eq "exec";
+ unshift @args, $order if $order ne "";
+ B::Concise::compile("-terse", @args);
}
sub indent {
return " " x $level;
}
+# Don't use this, at least on OPs in subroutines: it has no way of
+# getting to the pad, and will give wrong answers or crash.
sub B::OP::terse {
- my ($op, $level) = @_;
- my $targ = $op->targ;
- $targ = ($targ > 0) ? " [$targ]" : "";
- print indent($level), peekop($op), $targ, "\n";
+ carp "B::OP::terse is deprecated; use B::Concise instead";
+ B::Concise::b_terse(@_);
}
-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->SAFENAME;
-}
-
-sub B::IV::terse {
- my ($sv, $level) = @_;
- print indent($level);
- my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d";
- printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value;
-}
-
-sub B::NV::terse {
- my ($sv, $level) = @_;
- print indent($level);
- printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
-}
-
-sub B::RV::terse {
- my ($rv, $level) = @_;
- print indent($level);
- printf "%s (0x%lx) %s\n", class($rv), $$rv, printref($rv);
-}
-
-sub printref {
- my $rv = shift;
- my $rcl = class($rv->RV);
- if ($rcl eq 'PV') {
- return "\\" . cstring($rv->RV->$rcl);
- } elsif ($rcl eq 'NV') {
- return "\\" . $rv->RV->$rcl;
- } elsif ($rcl eq 'IV') {
- return sprintf "\\%" . ($rv->RV->FLAGS & SVf_IVisUV ? "u" : "d"),
- $rv->RV->int_value;
- } elsif ($rcl eq 'RV') {
- return "\\" . printref($rv->RV);
- }
+sub B::SV::terse {
+ my($sv, $level) = (@_, 0);
+ my %info;
+ B::Concise::concise_sv($sv, \%info);
+ my $s = B::Concise::fmt_line(\%info, "#svclass~(?((#svaddr))?)~#svval", 0);
+ print indent($level), $s, "\n";
}
sub B::NULL::terse {
print indent($level);
printf "%s (0x%lx)\n", class($sv), $$sv;
}
-
+
sub B::SPECIAL::terse {
my ($sv, $level) = @_;
print indent($level);
=head1 DESCRIPTION
-See F<ext/B/README>.
+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.
+
+For compatiblilty with the old B::Terse, this module also adds a
+method named C<terse> to B::OP and B::SV objects. The B::SV method is
+largely compatible with the old one, though authors of new software
+might be advised to choose a more user-friendly output format. The
+B::OP C<terse> method, however, doesn't work well. Since B::Terse was
+first written, much more information in OPs has migrated to the
+scratchpad datastructure, but the C<terse> interface doesn't have any
+way of getting to the correct pad. As a kludge, the new version will
+always use the pad for the main program, but for OPs in subroutines
+this will give the wrong answer or crash.
=head1 AUTHOR
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+The original version of B::Terse was written by Malcolm Beattie,
+E<lt>mbeattie@sable.ox.ac.ukE<gt>. This wrapper was written by Stephen
+McCamant, E<lt>smcc@MIT.EDUE<gt>.
=cut
@INC = '../lib';
}
-use Test::More tests => 15;
+use Test::More tests => 16;
use_ok( 'B::Terse' );
# now build some regexes that should match the dumped ops
my ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+');
my %ops = map { $_ => qr/$_ $hex$op/ }
- qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP );
+ qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP PVOP );
# split up the output lines into individual ops (terse is, well, terse!)
# use an array here so $_ is modifiable
# XXX:
# this tries to get at all tersified optypes in B::Terse
-# if you add AV, NULL, PADOP, PVOP, or SPECIAL, add it to the regex above too
+# if you can think of a way to produce AV, NULL, PADOP, or SPECIAL,
+# add it to the regex above too. (PADOPs are currently only produced
+# under ithreads, though).
#
use vars qw( $a $b );
sub bar {
# this is awful, but it gives a PMOP
my $boo = split('', $foo);
- # PMOP
+ # PVOP, LOOP
LOOP: for (1 .. 10) {
last LOOP if $_ % 2;
}
$foo =~ s/(a)/$1/;
}
-SKIP: {
- use Config;
- skip("- B::Terse won't grok RVs under ithreads yet", 1)
- if $Config{useithreads};
- # Schwern's example of finding an RV
- my $path = join " ", map { qq["-I$_"] } @INC;
- $path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
- my $redir = $^O eq 'MacOS' ? '' : "2>&1";
- my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
- like( $items, qr/RV $hex \\42/, 'RV' );
-}
+# Schwern's example of finding an RV
+my $path = join " ", map { qq["-I$_"] } @INC;
+$path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
+my $redir = $^O eq 'MacOS' ? '' : "2>&1";
+my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
+like( $items, qr/RV $hex \\42/, 'RV' );
package TieOut;
projects / platform / upstream / perl.git / commitdiff