Re: [perl #21261] B::Terse not outputting correct constants or variable names

Date: Mon, 17 Feb 2003 19:34:36 -0500
Date: Mon, 17 Feb 2003 19:34:36 -0500
Message-ID: <15953.32668.277063.470885@syllepsis.MIT.EDU>

p4raw-id: //depot/perl@18737

5 files changed, 132 insertions, 162 deletions

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 9001031bc1..db7b8d3f04 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -95,7 +95,8 @@ cc_opclass(pTHX_ OP *o)
 	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
 
diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm
index 624bae4f09..35a80ea3c0 100644
--- a/ext/B/B/Bblock.pm
+++ b/ext/B/B/Bblock.pm
@@ -10,7 +10,7 @@ use B qw(peekop walkoptree walkoptree_exec
 	 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;
@@ -64,8 +64,6 @@ sub walk_bblocks {
 	}
 	printf "    %s\n", peekop($lastop);
     }
-    print "-------\n";
-    walkoptree_exec($start, "terse");
 }
 
 sub walk_bblocks_obj {
@@ -140,10 +138,19 @@ sub compile {
 		$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");
+	};
     }
 }
 
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 188c199139..651304edc2 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -8,12 +8,13 @@ use warnings;
 
 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" =>
@@ -51,6 +52,11 @@ sub set_style {
     ($format, $gotofmt, $treefmt) = @_;
 }
 
+sub set_style_standard {
+    my($name) = @_;
+    set_style(@{$style{$name}});
+}
+
 sub add_callback {
     push @callbacks, @_;
 }
@@ -69,6 +75,23 @@ sub concise_cv {
     }
 }
 
+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
 
@@ -85,7 +108,7 @@ my $big_endian = 1;
 
 my $order = "basic";
 
-set_style(@{$style{concise}});
+set_style_standard("concise");
 
 sub compile {
     my @options = grep(/^-/, @_);
@@ -131,19 +154,7 @@ sub compile {
 	}
 	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);
 	}
     }
 }
@@ -216,7 +227,7 @@ sub walk_topdown {
 	    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);
     }
@@ -374,6 +385,8 @@ sub private_flags {
 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;
@@ -395,9 +408,11 @@ sub concise_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};
     }
@@ -438,7 +453,7 @@ sub concise_op {
 	}
 	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 . ")";
@@ -477,6 +492,9 @@ sub concise_op {
 	} 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 "-";
@@ -512,6 +530,30 @@ sub B::OP::concise {
     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;
@@ -1006,11 +1048,14 @@ existing values if you need to.  The level and format are passed in as
 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
diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm
index 3abe6156de..5d568f1269 100644
--- a/ext/B/B/Terse.pm
+++ b/ext/B/B/Terse.pm
@@ -1,42 +1,30 @@
 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 {
@@ -44,102 +32,19 @@ 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 {
@@ -147,7 +52,7 @@ 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);
@@ -168,10 +73,25 @@ B::Terse - Walk Perl syntax tree, printing terse info about ops
 
 =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
diff --git a/ext/B/t/terse.t b/ext/B/t/terse.t
index 1ad61b1768..b11c873176 100644
--- a/ext/B/t/terse.t
+++ b/ext/B/t/terse.t
@@ -5,7 +5,7 @@ BEGIN {
 	@INC = '../lib';
 }
 
-use Test::More tests => 15;
+use Test::More tests => 16;
 
 use_ok( 'B::Terse' );
 
@@ -33,7 +33,7 @@ $sub->();
 # 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
@@ -55,7 +55,9 @@ warn "# didn't find " . join(' ', keys %ops) if keys %ops;
 
 # 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 {
@@ -71,7 +73,7 @@ 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;
 	}
@@ -83,17 +85,12 @@ sub bar {
 	$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;