From: Nicholas Clark <nick@ccl4.org>
Date: Fri, 16 Feb 2007 23:54:33 +0000 (+0000)
Subject: Move all the cut&paste open TODO logic into OptreeCheck.pm, where it
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3feb66e7ea0f57a1105b8fea88e024b00c92a8a0;p=p5sagit%2Fp5-mst-13.2.git

Move all the cut&paste open TODO logic into OptreeCheck.pm, where it
should have been in the first place. Apply strict and warnings to
OptreeCheck.pm, and remove dead code they show up.

p4raw-id: //depot/perl@30333
---

diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm
index a3dd3e0..68a6247 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,7 +518,11 @@ 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, $@ }
 	}
@@ -559,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}}) {
@@ -573,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 {
@@ -691,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';
 
@@ -879,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;
 		}
@@ -963,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 '';
@@ -987,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);
 	}
diff --git a/ext/B/t/optree_check.t b/ext/B/t/optree_check.t
index b603ec9..5128b45 100644
--- a/ext/B/t/optree_check.t
+++ b/ext/B/t/optree_check.t
@@ -36,13 +36,6 @@ SKIP: {
     skip "no perlio in this build", $tests
     unless $Config::Config{useperlio};
 
-my @open_todo;
-sub open_todo {
-    if (((caller 0)[10]||{})->{open}) {
-	@open_todo = (skip => "\$^OPEN is set");
-    }
-}
-open_todo;
 
 pass("REGEX TEST HARNESS SELFTEST");
 
diff --git a/ext/B/t/optree_concise.t b/ext/B/t/optree_concise.t
index d37c06b..c7166c9 100644
--- a/ext/B/t/optree_concise.t
+++ b/ext/B/t/optree_concise.t
@@ -32,14 +32,6 @@ $SIG{__WARN__} = sub {
 #################################
 pass("CANONICAL B::Concise EXAMPLE");
 
-my @open_todo;
-sub open_todo {
-    if (((caller 0)[10]||{})->{open}) {
-	@open_todo = (skip => "\$^OPEN is set");
-    }
-}
-open_todo;
-
 checkOptree ( name	=> 'canonical example w -basic',
 	      bcopts	=> '-basic',
 	      code	=>  sub{$a=$b+42},
diff --git a/ext/B/t/optree_constants.t b/ext/B/t/optree_constants.t
index b8ea287..5ae18b6 100644
--- a/ext/B/t/optree_constants.t
+++ b/ext/B/t/optree_constants.t
@@ -24,14 +24,6 @@ plan tests => $tests;
 SKIP: {
 skip "no perlio in this build", $tests unless $Config::Config{useperlio};
 
-my @open_todo;
-sub open_todo {
-    if (((caller 0)[10]||{})->{open}) {
-	@open_todo = (skip => "\$^OPEN is set");
-    }
-}
-open_todo;
-
 #################################
 
 use constant {		# see also t/op/gv.t line 282
diff --git a/ext/B/t/optree_misc.t b/ext/B/t/optree_misc.t
index 32e75dc..1c7a53d 100644
--- a/ext/B/t/optree_misc.t
+++ b/ext/B/t/optree_misc.t
@@ -21,14 +21,6 @@ plan tests => 1;
 SKIP: {
 skip "no perlio in this build", 1 unless $Config::Config{useperlio};
 
-my @open_todo;
-sub open_todo {
-    if (((caller 0)[10]||{})->{open}) {
-	@open_todo = (skip => "\$^OPEN is set");
-    }
-}
-open_todo;
-
 # The regression this is testing is that the first aelemfast, derived
 # from a lexical array, is supposed to be a BASEOP "<0>", while the
 # second, from a global, is an SVOP "<$>" or a PADOP "<#>" depending
diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t
index 874e6db..d198c59 100644
--- a/ext/B/t/optree_samples.t
+++ b/ext/B/t/optree_samples.t
@@ -25,14 +25,6 @@ pass("GENERAL OPTREE EXAMPLES");
 
 pass("IF,THEN,ELSE, ?:");
 
-my @open_todo;
-sub open_todo {
-    if (((caller 0)[10]||{})->{open}) {
-	@open_todo = (skip => "\$^OPEN is set");
-    }
-}
-open_todo;
-
 checkOptree ( name	=> '-basic sub {if shift print then,else}',
 	      bcopts	=> '-basic',
 	      code	=> sub { if (shift) { print "then" }
diff --git a/ext/B/t/optree_sort.t b/ext/B/t/optree_sort.t
index 8776e4f..62068e1 100644
--- a/ext/B/t/optree_sort.t
+++ b/ext/B/t/optree_sort.t
@@ -24,14 +24,6 @@ skip "no perlio in this build", 11 unless $Config::Config{useperlio};
 
 pass("SORT OPTIMIZATION");
 
-my @open_todo;
-sub open_todo {
-    if (((caller 0)[10]||{})->{open}) {
-	@open_todo = (skip => "\$^OPEN is set");
-    }
-}
-open_todo;
-
 checkOptree ( name	=> 'sub {sort @a}',
 	      code	=> sub {sort @a},
 	      bcopts	=> '-exec',
diff --git a/ext/B/t/optree_specials.t b/ext/B/t/optree_specials.t
index 9d2a36e..5db9d02 100644
--- a/ext/B/t/optree_specials.t
+++ b/ext/B/t/optree_specials.t
@@ -47,14 +47,6 @@ my @warnings_todo;
    . "propagated to 5.8.x")
     if $] < 5.009;
 
-my @open_todo;
-sub open_todo {
-    if (((caller 0)[10]||{})->{open}) {
-	@open_todo = (skip => "\$^OPEN is set");
-    }
-}
-open_todo;
-
 checkOptree ( name	=> 'BEGIN',
 	      bcopts	=> 'BEGIN',
 	      prog	=> $src,
diff --git a/ext/B/t/optree_varinit.t b/ext/B/t/optree_varinit.t
index e25447d..040757b 100644
--- a/ext/B/t/optree_varinit.t
+++ b/ext/B/t/optree_varinit.t
@@ -23,14 +23,6 @@ skip "no perlio in this build", 22 unless $Config::Config{useperlio};
 
 pass("OPTIMIZER TESTS - VAR INITIALIZATION");
 
-my @open_todo;
-sub open_todo {
-    if (((caller 0)[10]||{})->{open}) {
-	@open_todo = (skip => "\$^OPEN is set");
-    }
-}
-open_todo;
-
 checkOptree ( name	=> 'sub {my $a}',
 	      bcopts	=> '-exec',
 	      code	=> sub {my $a},