Re: optree tests and VMS progress (no really)

Message-ID: <cfe85dfa041105235723398fe2@mail.gmail.com>
Date: Sat, 6 Nov 2004 00:57:13 -0700

p4raw-id: //depot/perl@23481

3 files changed, 161 insertions, 88 deletions

diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm
index fe5d84e9d7..9c5a7e950e 100644
--- a/ext/B/t/OptreeCheck.pm
+++ b/ext/B/t/OptreeCheck.pm
@@ -5,23 +5,31 @@
 
 =head1 NAME
 
-OptreeCheck - check optrees
+OptreeCheck - check optrees as rendered by B::Concise
 
 =head1 SYNOPSIS
 
 OptreeCheck supports regression testing of perl's parser, optimizer,
-bytecode generator, via a single function: checkOptree(%args).'
-
- checkOptree(name   => "your title here", # optional, (synth from others)
-	     bcopts => '-exec',	# $opt or \@opts, passed to BC::compile
-	     code   => sub {my $a},	# coderef, or source (wrapped and evald)
-	     # prog   => 'sort @a',	# run in subprocess, aka -MO=Concise
-	     # skip => 1,		# skips test
-	     # todo => 'excuse',	# anticipated failures
-	     # fail => 1		# fails (by redirecting result)
-	     # debug => 1,		# turns on regex debug for match test !!
-	     # retry => 1		# retry with debug on test failure
-	     expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+bytecode generator, via a single function: checkOptree(%args).  It
+invokes B::Concise upon sample code, and checks that it 'agrees' with
+reference renderings.
+
+  checkOptree (
+    name   => "test-name',	# optional, (synth from others)
+
+    # 2 kinds of code-under-test: must provide 1
+    code   => sub {my $a},	# coderef, or source (wrapped and evald)
+    prog   => 'sort @a',	# run in subprocess, aka -MO=Concise
+
+    bcopts => '-exec',		# $opt or \@opts, passed to BC::compile
+    # errs   => '.*',		# match against any emitted errs, -w warnings
+    # skip => 1,		# skips test
+    # todo => 'excuse',		# anticipated failures
+    # fail => 1			# force fail (by redirecting result)
+    # debug => 1,		# turns on regex debug for match test !!
+    # retry => 1		# retry with debug on test failure
+
+    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' );
  # 1  <;> nextstate(main 45 optree.t:23) v
  # 2  <0> padsv[$a:45,46] M/LVINTRO
  # 3  <1> leavesub[1 ref] K/REFC,1
@@ -33,33 +41,34 @@ bytecode generator, via a single function: checkOptree(%args).'
 
 =head1 checkOptree(%in) Overview
 
-Calls getRendering(), which runs code or prog through B::Concise, and
-captures its rendering.
+optreeCheck() calls getRendering(), which runs code or prog through
+B::Concise, and captures its rendering.
 
-Calls mkCheckRex() to produce a regex which will match the expected
-rendering, and fail when it doesn't match.
+It then calls mkCheckRex() to produce a regex which will match the
+expected rendering, and fail when it doesn't match.
+
+Finally, it compares the 2; like($rendering,/$regex/,$testname).
 
-Also calls like($rendering,/$regex/,$name), and thereby plugs into the
-test.pl framework.
 
 =head1 checkOptree(%Args) API
 
 Accepts %Args, with following requirements and actions:
 
-expect and expect_nt are both: required, not empty, not whitespace.
-It's a fatal error otherwise, because false positives are BAD.
-
 Either code or prog must be present.  prog is some source code, and is
-passed through via runperl, to B::Concise like this: (bcopts are fixed
-up for cmdline)
+passed through via test.pl:runperl, to B::Concise like this: (bcopts
+are fixed up for cmdline)
 
     './perl -w -MO=Concise,$bcopts_massaged -e $src'
 
 code is a subref, or $src, like above.  If it's not a subref, it's
-treated like source, but is wrapped as a subroutine, and passed to
+treated like source-code, is wrapped as a subroutine, and is passed to
 B::Concise::compile().
 
     $subref = eval "sub{$src}";
+    B::Concise::compile($subref).
+
+expect and expect_nt are the reference optree renderings.  Theyre
+required, except when the code/prog compilation fails.
 
 I suppose I should also explain these more, but they seem obvious.
 
@@ -182,8 +191,15 @@ our %gOpts = 	# values are replaced at runtime !!
      help	=> 0,	# 1 ends in die
 
      # array values are one-of selections, with 1st value as default
-     #   tbc: 1st value is help, 2nd is default
      testmode => [qw/ native cross both /],
+
+     # fixup for VMS, cygwin, which dont have stderr b4 stdout
+     #  2nd value is used as help-str, 1st val (still) default
+
+     rxnoorder	=> [1, 'if 1, dont req match on -e lines, and -banner',0],
+     strip	=> [1, 'if 1, catch errs and remove from renderings',0],
+     stripv	=> 'if strip&&1, be verbose about it',
+     errs	=> 'expected compile errs',
     );
 
 
@@ -267,12 +283,13 @@ sub getCmdLine {	# import assistant
 	    # override with 'foo' if 'opt=foo' appears
 	    grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
 	}
-    }
+     }
     print("$0 heres current state:\n", Dumper \%gOpts)
 	if $gOpts{help} or $gOpts{dump};
 
     exit if $gOpts{help};
 }
+# the above arg-handling cruft should be replaced by a Getopt call
 
 ##################################
 # API
@@ -285,9 +302,25 @@ sub checkOptree {
     SKIP: {
 	label(\%in);
 	skip($in{name}, 1) if $in{skip};
+
+	# cpy globals into each test
+	foreach $k (keys %gOpts) {
+	    if ($gOpts{$k}) {
+		$in{$k} = $gOpts{$k} unless $in{$k};
+	    }
+	}
+	#die "no reftext found for $want: $in->{name}" unless $str;
+
 	return runSelftest(\%in) if $gOpts{selftest};
 
-	my $rendering = getRendering(\%in);	# get the actual output
+	my ($rendering,@errs) = getRendering(\%in);	# get the actual output
+
+	if ($in->{errs}) {
+	    if (@errs) {
+		like ("@errs", qr/$in->{errs}\s*/, "$in->{name} - matched expected errs");
+		next;
+	    }
+	}
 	fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ?
 
 	# Test rendering against ..
@@ -397,7 +430,7 @@ sub mylike {
 	    #$got =~ s/($rex)/ate: $1/msg;	# noisy
 	    $got =~ s/($rex)\n//msg;		# remove matches
 	}
-	print "sequentially deconstructed, these are unmatched:\n$got\n";
+	print "these lines not matched:\n$got\n";
     }
 
     if (not $ok and $retry) {
@@ -418,18 +451,20 @@ sub getRendering {
 
     my @opts = get_bcopts($in);
     my $rendering = ''; # suppress "Use of uninitialized value in open"
+    my @errs;		# collect errs via 
+
 
     if ($in->{prog}) {
 	$rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
 			      prog => $in->{prog}, stderr => 1,
-			      ); #verbose => 1);
+			      ); # verbose => 1);
     } else {
 	my $code = $in->{code};
 	unless (ref $code eq 'CODE') {
 	    # treat as source, and wrap
 	    $code = eval "sub { $code }";
-	    die "$@ evaling code 'sub { $in->{code} }'\n"
-		unless ref $code eq 'CODE';
+	    # return errors
+	    push @errs, $@ if $@;
 	}
 	# set walk-output b4 compiling, which writes 'announce' line
 	walk_output(\$rendering);
@@ -443,7 +478,18 @@ sub getRendering {
       B::Concise::reset_sequence();
 	$opwalker->();
     }
-    return $rendering;
+    if ($in->{strip}) {
+	$rendering =~ s/(B::Concise::compile.*?\n)//;
+	print "stripped from rendering <$1>\n" if $1 and $in->{stripv};
+
+	while ($rendering =~ s/^(.*?-e line .*?\n)//g) {
+	    print "stripped <$1>\n" if $in->{stripv};
+	    push @errs, $1;
+	}
+	$rendering =~ s/^(-e syntax OK\n)//ms;
+	$rendering =~ s/^(-e had compilation errors.\n)//ms;
+    }
+    return $rendering, @errs;
 }
 
 sub get_bcopts {
@@ -457,6 +503,33 @@ sub get_bcopts {
     return @opts;
 }
 
+=head1 mkCheckRex
+
+mkCheckRex receives the full testcase object, and constructs a regex.
+1st, it selects a reftxt from either the expect or expect_nt items.
+
+Once selected, the reftext is massaged & converted into a Regex that
+accepts 'good' concise renderings, with appropriate input variations,
+but is otherwise as strict as possible.  For example, it should *not*
+match when opcode flags change, or when optimizations convert an op to
+an ex-op.
+
+selection is driven by platform mostly, but also by test-mode, which
+rather complicates the code.  this is worsened by the potential need
+to make platform specific conversions on the reftext.
+
+=head2 match criteria
+
+Opcode arguments (text within braces) are disregarded for matching
+purposes.  This loses some info in 'add[t5]', but greatly simplifys
+matching 'nextstate(main 22 (eval 10):1)'.  Besides, we are testing
+for regressions, not for complete accuracy.
+
+The regex is anchored by default, but can be suppressed with
+'noanchors', allowing 1-liner tests to succeed if opcode is found.
+
+=cut
+
 # needless complexity due to 'too much info' from B::Concise v.60
 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
 
@@ -469,7 +542,6 @@ sub mkCheckRex {
     my $str = $in->{expect} || $in->{expect_nt};	# standard bias
     $str = $in->{$want} if $want;			# stated pref
 
-    die "no reftext found for $want: $in->{name}" unless $str;
     #fail("rex-str is empty, won't allow false positives") unless $str;
 
     $str =~ s/^\# //mg;		# ease cut-paste testcase authoring
@@ -490,13 +562,18 @@ sub mkCheckRex {
     
     # no 'invisible' failures in debugger
     $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
-    
+    # widened for -terse mode
+    $str =~ s/(?:next|db)state/(?:next|db)state/msg;
+
     # don't care about:
     $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg;		# FAKE line numbers
     $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg;	# match args
     $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg;	# hexnum values
     $str =~ s/".*?"/".*?"/msg;				# quoted strings
 
+    $str =~ s/(\d refs?)/\\d refs?/msg;
+    $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg;	# for -terse
+
     croak "no reftext found for $want: $in->{name}"
 	unless $str =~ /\w+/; # fail unless a real test
 
@@ -505,7 +582,7 @@ sub mkCheckRex {
 
     # allow -eval, banner at beginning of anchored matches
     $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
-	unless $in->{noanchors};
+	unless $in->{noanchors} or $in->{rxnoorder};
     
     eval "use re 'debug'" if $debug;
     my $qr = ($in->{noanchors})	? qr/$str/ms : qr/^$str$/ms ;
@@ -654,27 +731,6 @@ if ($0 =~ /OptreeCheck\.pm/) {
 
 __END__
 
-=head1 mkCheckRex
-
-mkCheckRex receives the full testcase object, and constructs a regex.
-1st, it selects a reftxt from either the expect or expect_nt items.
-
-Once selected, reftext is massaged & converted into a Regex that
-accepts 'good' concise renderings, with appropriate input variations,
-but is otherwise as strict as possible.  For example, it should *not*
-match when opcode flags change, or when optimizations convert an op to
-an ex-op.
-
-=head2 match criteria
-
-Opcode arguments (text within braces) are disregarded for matching
-purposes.  This loses some info in 'add[t5]', but greatly simplifys
-matching 'nextstate(main 22 (eval 10):1)'.  Besides, we are testing
-for regressions, not for complete accuracy.
-
-The regex is anchored by default, but can be suppressed with
-'noanchors', allowing 1-liner tests to succeed if opcode is found.
-
 =head1 TEST DEVELOPMENT SUPPORT
 
 This optree regression testing framework needs tests in order to find
@@ -712,4 +768,10 @@ crosstest, etc selection mechanics.
 improve retry, retrydbg, esp. it's control of eval "use re debug".
 This seems to work part of the time, but isn't stable enough.
 
+=head1 CAVEATS
+
+This code is purely for testing core. While checkOptree feels flexible
+enough to be stable, the whole selftest framework is subject to change
+w/o notice.
+
 =cut
diff --git a/ext/B/t/optree_check.t b/ext/B/t/optree_check.t
index a037a78861..b91da13738 100644
--- a/ext/B/t/optree_check.t
+++ b/ext/B/t/optree_check.t
@@ -118,18 +118,18 @@ if (1) {
 
 pass ("TEST -e \$srcCode");
 
-checkOptree ( name	=> '-w errors seen',
-	      prog	=> 'sort our @a',
-	      noanchors	=> 1, # unanchored match
-	      expect	=> 'Useless use of sort in void context',
-	      expect_nt	=> 'Useless use of sort in void context');
-
-checkOptree ( name	=> "self strict, catch err",
-	      prog	=> 'use strict; bogus',
-	      noanchors	=> 1,
-	      expect	=> 'strict subs',
-	      expect_nt	=> 'strict subs');
-
+checkOptree
+    (  name	=> '-w errors seen',
+       prog	=> 'sort our @a',
+       errs	=> 'Useless use of sort in void context at -e line 1.',
+       );
+    
+checkOptree
+    (  name	=> "self strict, catch err",
+       prog	=> 'use strict; bogus',
+       errs	=> 'Bareword "bogus" not allowed while "strict subs" in use at -e line 1.',
+       );
+    
 checkOptree ( name	=> "sort vK - flag specific search",
 	      prog	=> 'sort our @a',
 	      noanchors	=> 1,
diff --git a/ext/B/t/optree_concise.t b/ext/B/t/optree_concise.t
index efd351a6ad..09a5207bd9 100644
--- a/ext/B/t/optree_concise.t
+++ b/ext/B/t/optree_concise.t
@@ -20,7 +20,7 @@ BEGIN {
 use OptreeCheck;	# ALSO DOES @ARGV HANDLING !!!!!!
 use Config;
 
-plan tests => 23;
+plan tests => 24;
 SKIP: {
 skip "no perlio in this build", 23 unless $Config::Config{useperlio};
 
@@ -249,24 +249,35 @@ EOT_EOT
 # 7  <@> leave[1 ref] vKP/REFC
 EONT_EONT
 
-checkOptree ( name	=> 'cmdline self-strict compile err',
-	      prog	=> 'use strict; sort @a',
-	      bcopts	=> [qw/ -basic -concise -exec /],
-	      noanchors	=> 1,
-	      expect	=> 'compilation errors',
-	      expect_nt	=> 'compilation errors');
-
-checkOptree ( name	=> 'error at -e line 1',
-	      prog	=> 'our @a; sort @a',
-	      bcopts	=> [qw/ -basic -concise -exec /],
-	      noanchors	=> 1,
-	      expect	=> 'at -e line 1',
-	      expect_nt	=> 'at -e line 1');
-
-checkOptree ( name	=> 'cmdline -basic -concise -exec works',
-	      prog	=> 'our @a; sort @a',
-	      bcopts	=> [qw/ -basic -concise -exec /],
-	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+;
+$DB::single=1;
+checkOptree
+    ( name	=> 'cmdline self-strict compile err using prog',
+      prog	=> 'use strict; sort @a',
+      bcopts	=> [qw/ -basic -concise -exec /],
+      errs	=> 'Global symbol "@a" requires explicit package name at .*? line 1.',
+      );
+
+checkOptree
+    ( name	=> 'cmdline self-strict compile err using code',
+      code	=> 'use strict; sort @a',
+      bcopts	=> [qw/ -basic -concise -exec /],
+      #noanchors	=> 1,
+      errs	=> 'Global symbol "@a" requires explicit package name at .*? line 1.',
+      );
+
+checkOptree
+    ( name	=> 'useless use of sort in void context',
+      prog	=> 'our @a; sort @a',
+      bcopts	=> [qw/ -basic -concise -exec /],
+      errs	=> 'Useless use of sort in void context at -e line 1.',
+      );
+
+checkOptree
+    ( name	=> 'cmdline -basic -concise -exec works',
+      prog	=> 'our @a; sort @a',
+      bcopts	=> [qw/ -basic -concise -exec /],
+      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 # 1  <0> enter 
 # 2  <;> nextstate(main 1 -e:1) v
 # 3  <#> gv[*a] s