Supporess spurious warnings for @+ and and @-

[p5sagit/p5-mst-13.2.git] / t / test.pl

diff --git a/t/test.pl b/t/test.pl
index 351963a..877e5a6 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -30,8 +30,12 @@ END {
 # Use this instead of "print STDERR" when outputing failure diagnostic 
 # messages
 sub _diag {
+    return unless @_;
+    my @mess = map { /^#/ ? "$_\n" : "# $_\n" } 
+               map { split /\n/ } @_;
     my $fh = $TODO ? *STDOUT : *STDERR;
-    print $fh @_;
+    print $fh @mess;
+
 }
 
 sub skip_all {
@@ -64,8 +68,7 @@ sub _ok {
     }
 
     # Ensure that the message is properly escaped.
-    _diag map { /^#/ ? "$_\n" : "# $_\n" } 
-          map { split /\n/ } @mess if @mess;
+    _diag @mess;
 
     $test++;
 
@@ -148,6 +151,70 @@ sub isnt {
     _ok($pass, _where(), $name, @mess);
 }
 
+sub cmp_ok {
+    my($got, $type, $expected, $name, @mess) = @_;
+
+    my $pass;
+    {
+        local $^W = 0;
+        local($@,$!);   # don't interfere with $@
+                        # eval() sometimes resets $!
+        $pass = eval "\$got $type \$expected";
+    }
+    unless ($pass) {
+        # It seems Irix long doubles can have 2147483648 and 2147483648
+        # that stringify to the same thing but are acutally numerically
+        # different. Display the numbers if $type isn't a string operator,
+        # and the numbers are stringwise the same.
+        # (all string operators have alphabetic names, so tr/a-z// is true)
+        # This will also show numbers for some uneeded cases, but will
+        # definately be helpful for things such as == and <= that fail
+        if ($got eq $expected and $type !~ tr/a-z//) {
+            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
+        }
+        unshift(@mess, "#      got "._q($got)."\n",
+                       "# expected $type "._q($expected)."\n");
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
+# Check that $got is within $range of $expected
+# if $range is 0, then check it's exact
+# else if $expected is 0, then $range is an absolute value
+# otherwise $range is a fractional error.
+# Here $range must be numeric, >= 0
+# Non numeric ranges might be a useful future extension. (eg %)
+sub within {
+    my ($got, $expected, $range, $name, @mess) = @_;
+    my $pass;
+    if (!defined $got or !defined $expected or !defined $range) {
+        # This is a fail, but doesn't need extra diagnostics
+    } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) {
+        # This is a fail
+        unshift @mess, "# got, expected and range must be numeric\n";
+    } elsif ($range < 0) {
+        # This is also a fail
+        unshift @mess, "# range must not be negative\n";
+    } elsif ($range == 0) {
+        # Within 0 is ==
+        $pass = $got == $expected;
+    } elsif ($expected == 0) {
+        # If expected is 0, treat range as absolute
+        $pass = ($got <= $range) && ($got >= - $range);
+    } else {
+        my $diff = $got - $expected;
+        $pass = abs ($diff / $expected) < $range;
+    }
+    unless ($pass) {
+        if ($got eq $expected) {
+            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
+        }
+       unshift@mess, "#      got "._q($got)."\n",
+                     "# expected "._q($expected)." (within "._q($range).")\n";
+    }
+    _ok($pass, _where(), $name, @mess);
+}
+
 # Note: this isn't quite as fancy as Test::More::like().
 sub like {
     my ($got, $expected, $name, @mess) = @_;
@@ -177,11 +244,12 @@ sub fail {
 }
 
 sub curr_test {
+    $test = shift if @_;
     return $test;
 }
 
 sub next_test {
-    $test++
+  $test++;
 }
 
 # Note: can't pass multipart messages since we try to
@@ -333,6 +401,7 @@ sub runperl {
     return $result;
 }
 
+*run_perl = \&runperl; # Nice alias.
 
 sub DIE {
     print STDERR "# @_\n";
@@ -448,10 +517,10 @@ sub _fresh_perl {
 
     my $pass = $resolve->($results);
     unless ($pass) {
-        print STDERR "# PROG: $switch\n$prog\n";
-        print STDERR "# EXPECTED:\n", $resolve->(), "\n";
-        print STDERR "# GOT:\n$results\n";
-        print STDERR "# STATUS: $status\n";
+        _diag "# PROG: \n$prog\n";
+        _diag "# EXPECTED:\n", $resolve->(), "\n";
+        _diag "# GOT:\n$results\n";
+        _diag "# STATUS: $status\n";
     }
 
     # Use the first line of the program as a name if none was given