Schwern's wallet is a bit more loose.

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

diff --git a/t/test.pl b/t/test.pl
index 379e136..91daf1a 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -77,6 +77,7 @@ sub _where {
     return "at $caller[1] line $caller[2]";
 }
 
+# DON'T use this for matches. Use like() instead.
 sub ok {
     my ($pass, $name, @mess) = @_;
     _ok($pass, _where(), $name, @mess);
@@ -147,6 +148,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) = @_;
@@ -271,7 +336,7 @@ sub _quote_args {
     foreach (@$args) {
        # In VMS protect with doublequotes because otherwise
        # DCL will lowercase -- unless already doublequoted.
-       $_ = q(").$_.q(") if $is_vms && !/^\"/;
+       $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0;
        $$runperl .= ' ' . $_;
     }
 }
@@ -396,8 +461,16 @@ my $tmpfile = "misctmp000";
 1 while -f ++$tmpfile;
 END { unlink_all $tmpfile }
 
-sub kill_perl {
-    my($prog, $expected, $runperl_args, $name) = @_;
+#
+# _fresh_perl
+#
+# The $resolve must be a subref that tests the first argument
+# for success, or returns the definition of success (e.g. the
+# expected scalar) if given no arguments.
+#
+
+sub _fresh_perl {
+    my($prog, $resolve, $runperl_args, $name) = @_;
 
     $runperl_args ||= {};
     $runperl_args->{progfile} = $tmpfile;
@@ -437,19 +510,49 @@ sub kill_perl {
         $results =~ s/\n\n/\n/g;
     }
 
-    $expected =~ s/\n+$//;
-
-    my $pass = $results eq $expected;
+    my $pass = $resolve->($results);
     unless ($pass) {
         print STDERR "# PROG: $switch\n$prog\n";
-        print STDERR "# EXPECTED:\n$expected\n";
+        print STDERR "# EXPECTED:\n", $resolve->(), "\n";
         print STDERR "# GOT:\n$results\n";
         print STDERR "# STATUS: $status\n";
     }
 
-    ($name) = $prog =~ /^(.{1,35})/ unless $name;
+    # Use the first line of the program as a name if none was given
+    unless( $name ) {
+        ($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
+        $name .= '...' if length $first_line > length $name;
+    }
+
+    _ok($pass, _where(), "fresh_perl - $name");
+}
 
-    _ok($pass, _where(), "kill_perl - $name");
+#
+# run_perl_is
+#
+# Combination of run_perl() and is().
+#
+
+sub fresh_perl_is {
+    my($prog, $expected, $runperl_args, $name) = @_;
+    _fresh_perl($prog,
+               sub { @_ ? $_[0] eq $expected : $expected },
+               $runperl_args, $name);
+}
+
+#
+# run_perl_like
+#
+# Combination of run_perl() and like().
+#
+
+sub fresh_perl_like {
+    my($prog, $expected, $runperl_args, $name) = @_;
+    _fresh_perl($prog,
+               sub { @_ ?
+                         $_[0] =~ (ref $expected ? $expected : /$expected/) :
+                         $expected },
+               $runperl_args, $name);
 }
 
 1;