newHV doesn't need to turn off POK or NOK, as they will default to not

[p5sagit/p5-mst-13.2.git] / ext / B / t / OptreeCheck.pm

diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm
index fa1a825..47d4a13 100644 (file)
--- 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);
        }