X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2Ft%2FOptreeCheck.pm;h=47d4a1300273cb4f8e7cab85486fc3a1392973d4;hb=ce5d06123ae0253bf2e33033ffbfba16ce3bb79e;hp=fa1a8252a08c3753a72a8cca480c5155d1345e7c;hpb=3c4b39bee8832007b7e91bfce8701d34cacab411;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm
index fa1a825..47d4a13 100644
--- a/ext/B/t/OptreeCheck.pm
+++ b/ext/B/t/OptreeCheck.pm
@@ -1,14 +1,24 @@
 package OptreeCheck;
 use base 'Exporter';
+use strict;
+use warnings;
+use vars qw(@open_todo $TODO);
 require "test.pl";
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
 # now export checkOptree, and those test.pl functions used by tests
 our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
-		  require_ok runperl );
+		  require_ok runperl @open_todo);
 
 
+# This is a bit of a kludge. Really we need to find a way to encode in the
+# golden results that the hints wll differ because ${^OPEN} is set.
+
+if (((caller 0)[10]||{})->{'open<'}) {
+    @open_todo = (skip => "\${^OPEN} is set");
+}
+
 =head1 NAME
 
 OptreeCheck - check optrees as rendered by B::Concise
@@ -429,7 +439,7 @@ sub checkOptree {
 	$tc->checkErrs();
 
       TODO:
-	foreach $want (@{$modes{$gOpts{testmode}}}) {
+	foreach my $want (@{$modes{$gOpts{testmode}}}) {
 	    local $TODO = $tc->{todo} if $tc->{todo};
 
 	    $tc->{cross} = $msgs{"$want-$thrstat"};
@@ -438,7 +448,7 @@ sub checkOptree {
 	    $tc->mylike();
 	}
     }
-    $res;
+    return;
 }
 
 sub newTestCases {
@@ -449,7 +459,7 @@ sub newTestCases {
     $tc->label();
 
     # cpy globals into each test
-    foreach $k (keys %gOpts) {
+    foreach my $k (keys %gOpts) {
 	if ($gOpts{$k}) {
 	    $tc->{$k} = $gOpts{$k} unless defined $tc->{$k};
 	}
@@ -508,16 +518,17 @@ sub getRendering {
 	    # treat as source, and wrap into subref 
 	    #  in caller's package ( to test arg-fixup, comment next line)
 	    my $pkg = '{ package '.caller(1) .';';
-	    $code = eval "$pkg sub { $code } }";
+	    {
+		no strict;
+		no warnings;
+		$code = eval "$pkg sub { $code } }";
+	    }
 	    # return errors
 	    if ($@) { chomp $@; push @errs, $@ }
 	}
 	# set walk-output b4 compiling, which writes 'announce' line
 	walk_output(\$rendering);
-	if ($tc->{fail}) {
-	    fail("forced failure: stdout follows");
-	    walk_output(\*STDOUT);
-	}
+
 	my $opwalker = B::Concise::compile(@opts, $code);
 	die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
 
@@ -562,6 +573,7 @@ sub checkErrs {
 
     # check for agreement, by hash (order less important)
     my (%goterrs, @got);
+    $tc->{goterrs} ||= [];
     @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}};
     
     foreach my $k (keys %{$tc->{errs}}) {
@@ -576,7 +588,7 @@ sub checkErrs {
     if (%{$tc->{errs}} or %{$tc->{goterrs}}) {
 	$tc->diag_or_fail();
     }
-    fail("FORCED: $tc->{name}:\n$rendering") if $gOpts{fail}; # silly ?
+    fail("FORCED: $tc->{name}:\n") if $gOpts{fail}; # silly ?
 }
 
 sub diag_or_fail {
@@ -662,19 +674,13 @@ sub mkCheckRex {
     }
     $tc->{wantstr} = $str;
 
-    # convert all (args) and [args] to temp forms wo bracing
-    $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
-    $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
-    $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
-    
+    # make targ args wild
+    $str =~ s/\[t\d+\]/[t\\d+]/msg;
+
     # escape bracing, etc.. manual \Q (doesnt escape '+')
     $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
+    # $str =~ s/(?<!\\)([\[\]\(\)*.\$\@\#\|{}])/\\$1/msg;
 
-    # now replace temp forms with original, preserving reference bracing 
-    $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
-    $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
-    $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
-    
     # treat dbstate like nextstate (no in-debugger false reports)
     $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
     # widened for -terse mode
@@ -690,14 +696,9 @@ sub mkCheckRex {
     $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg;	# for -terse
     #$str =~ s/(\s*)\n/\n/msg;				# trailing spaces
     
-    # these fix up pad-slot assignment args
-    if ($] < 5.009 or $tc->{cross}) {
-	$str =~ s/\[t\d+\\]/\[t\\d+\\]/msg;	# pad slot assignments
-    }
-
     croak "no reftext found for $want: $tc->{name}"
 	unless $str =~ /\w+/; # fail unless a real test
-
+    
     # $str = '.*'	if 1;	# sanity test
     # $str .= 'FAIL'	if 1;	# sanity test
 
@@ -705,7 +706,6 @@ sub mkCheckRex {
     $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
 	unless $tc->{noanchors} or $tc->{rxnoorder};
     
-    eval "use re 'debug'" if $debug;
     my $qr = ($tc->{noanchors})	? qr/$str/ms : qr/^$str$/ms ;
     no re 'debug';
 
@@ -893,7 +893,7 @@ sub mydumper {
 	or do{
 	    print "Sorry, Data::Dumper is not available\n";
 	    print "half hearted attempt:\n";
-	    foreach $it (@_) {
+	    foreach my $it (@_) {
 		if (ref $it eq 'HASH') {
 		    print " $_ => $it->{$_}\n" foreach sort keys %$it;
 		}
@@ -977,13 +977,6 @@ sub OptreeCheck::gentest {
 	my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
 	$testcode =~ s/$b4/$af/;
 	
-	my $got;
-	if ($internal_retest) {
-	    $got = runperl( prog => "$preamble $testcode", stderr => 1,
-			    #switches => ["-I../ext/B/t", "-MOptreeCheck"], 
-			    verbose => 1);
-	    print "got: $got\n";
-	}
 	return $testcode;
     }
     return '';
@@ -1001,7 +994,7 @@ sub OptreeCheck::processExamples {
 	$/ = "";
 	my @chunks = <$fh>;
 	print preamble (scalar @chunks);
-	foreach $t (@chunks) {
+	foreach my $t (@chunks) {
 	    print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
 	    print OptreeCheck::gentest ($t);
 	}