Better diagnostics by removing an && from an ok() and converting it to

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

diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t
index fe601b1..7aeb159 100644 (file)
--- a/ext/B/t/deparse.t
+++ b/ext/B/t/deparse.t
@@ -19,33 +19,56 @@ BEGIN {
     }
 }
 
-$|  = 1;
 use warnings;
 use strict;
-use Config;
-
-print "1..43\n";
+BEGIN {
+    # BEGIN block is acutally a subroutine :-)
+    return unless $] > 5.009;
+    require feature;
+    feature->import(':5.10');
+}
+use Test::More tests => 57;
 
 use B::Deparse;
-my $deparse = B::Deparse->new() or print "not ";
-my $i=1;
-print "ok " . $i++ . "\n";
-
+my $deparse = B::Deparse->new();
+ok($deparse);
 
 # Tell B::Deparse about our ambient pragmas
-{ my ($hint_bits, $warning_bits);
- BEGIN { ($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS}); }
+{ my ($hint_bits, $warning_bits, $hinthash);
+ BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); }
  $deparse->ambient_pragmas (
      hint_bits    => $hint_bits,
      warning_bits => $warning_bits,
-     '$['         => 0 + $[
+     '$['         => 0 + $[,
+     '%^H'       => $hinthash,
  );
 }
 
 $/ = "\n####\n";
 while (<DATA>) {
     chomp;
-    s/#.*$//mg;
+    # This code is pinched from the t/lib/common.pl for TODO.
+    # It's not clear how to avoid duplication
+    my ($skip, $skip_reason);
+    s/^#\s*SKIP\s*(.*)\n//m and $skip_reason = $1;
+    # If the SKIP reason starts ? then it's taken as a code snippet to evaluate
+    # This provides the flexibility to have conditional SKIPs
+    if ($skip_reason && $skip_reason =~ s/^\?//) {
+       my $temp = eval $skip_reason;
+       if ($@) {
+           die "# In SKIP code reason:\n# $skip_reason\n$@";
+       }
+       $skip_reason = $temp;
+    }
+
+    s/#\s*(.*)$//mg;
+    my ($num, $testname) = $1 =~ m/(\d+)\s*(.*)/;
+
+    if ($skip_reason) {
+       # Like this to avoid needing a label SKIP:
+       Test::More->builder->skip($skip_reason);
+       next;
+    }
 
     my ($input, $expected);
     if (/(.*)\n>>>>\n(.*)/s) {
@@ -58,8 +81,8 @@ while (<DATA>) {
     my $coderef = eval "sub {$input}";
 
     if ($@) {
-       print "not ok " . $i++ . "\n";
-       print "# $@";
+       diag("$num deparsed: $@");
+       ok(0, $testname);
     }
     else {
        my $deparsed = $deparse->coderef2text( $coderef );
@@ -67,37 +90,22 @@ while (<DATA>) {
        $regex =~ s/(\S+)/\Q$1/g;
        $regex =~ s/\s+/\\s+/g;
        $regex = '^\{\s*' . $regex . '\s*\}$';
-
-       my $ok = ($deparsed =~ /$regex/);
-       print (($ok ? "ok " : "not ok ") . $i++ . "\n");
-       if (!$ok) {
-           print "# EXPECTED:\n";
-           $regex =~ s/^/# /mg;
-           print "$regex\n";
-
-           print "\n# GOT: \n";
-           $deparsed =~ s/^/# /mg;
-           print "$deparsed\n";
-       }
+        like($deparsed, qr/$regex/, $testname);
     }
 }
 
 use constant 'c', 'stuff';
-print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
-print "ok " . $i++ . "\n";
+is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff');
 
-$a = 0;
-print "not " if "{\n    (-1) ** \$a;\n}"
-               ne $deparse->coderef2text(sub{(-1) ** $a });
-print "ok " . $i++ . "\n";
+my $a = 0;
+is("{\n    (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a }));
 
 use constant cr => ['hello'];
 my $string = "sub " . $deparse->coderef2text(\&cr);
-my $val = (eval $string)->();
-print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
-print "ok " . $i++ . "\n";
+my $val = (eval $string)->() or diag $string;
+is(ref($val), 'ARRAY');
+is($val->[0], 'hello');
 
-my $a;
 my $Is_VMS = $^O eq 'VMS';
 my $Is_MacOS = $^O eq 'MacOS';
 
@@ -126,8 +134,7 @@ $b =~ s/(LINE:)/sub BEGIN {
     'XL'->bootstrap;
 }
 $1/ if $Is_MacOS;
-print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
-print "ok " . $i++ . "\n";
+is($a, $b);
 
 #Re: perlbug #35857, patch #24505
 #handle warnings::register-ed packages properly.
@@ -146,7 +153,7 @@ use warnings;
 sub test {
    my $val = shift;
    my $res = B::Deparse::Wrapper::getcode($val);
-   print $res =~ /use warnings/ ? '' : 'not ', 'ok ', $i++, "\n";
+   like( $res, qr/use warnings/);
 }
 my ($q,$p);
 my $x=sub { ++$q,++$p };
@@ -268,7 +275,7 @@ my $i;
 while ($i) { my $z = 1; } continue { $i = 99; }
 ####
 # 23
-foreach $i (1, 2) {
+foreach my $i (1, 2) {
     my $z = 1;
 }
 ####
@@ -334,3 +341,57 @@ do { my $x = 1; $x };
 my $f = sub {
     +{[]};
 } ;
+####
+# 38 (bug #43010)
+'!@$%'->();
+####
+# 39 (ibid.)
+::();
+####
+# 40 (ibid.)
+'::::'->();
+####
+# 41 (ibid.)
+&::::;
+####
+# 42
+my $bar;
+'Foo'->$bar('orz');
+####
+# 43
+'Foo'->bar('orz');
+####
+# 44
+'Foo'->bar;
+####
+# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
+# 45 say
+say 'foo';
+####
+# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
+# 46 state vars
+state $x = 42;
+####
+# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
+# 47 state var assignment
+{
+    my $y = (state $x = 42);
+}
+####
+# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
+# 48 state vars in anoymous subroutines
+$a = sub {
+    state $x;
+    return $x++;
+}
+;
+####
+# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
+# 49 each @array;
+each @ARGV;
+each @$a;
+####
+# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
+# 50 keys @array; values @array
+keys @$a if keys @ARGV;
+values @ARGV if values @$a;