X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Ftest.pl;h=94071292715269d190e94d292cd732f22d609968;hb=724aa791452d3e96e29ba14db12e3f5d43f03348;hp=8eefe874c87b5f2a9c1120e24434f7461b15e5de;hpb=4cd2bd1f390724a103e72b993d7f67fb405628ad;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/test.pl b/t/test.pl
index 8eefe87..9407129 100644
--- a/t/test.pl
+++ b/t/test.pl
@@ -2,6 +2,7 @@
 # t/test.pl - most of Test::More functionality without the fuss
 #
 
+$Level = 1;
 my $test = 1;
 my $planned;
 
@@ -76,12 +77,12 @@ sub _ok {
 }
 
 sub _where {
-    my @caller = caller(1);
+    my @caller = caller($Level);
     return "at $caller[1] line $caller[2]";
 }
 
 # DON'T use this for matches. Use like() instead.
-sub ok {
+sub ok ($@) {
     my ($pass, $name, @mess) = @_;
     _ok($pass, _where(), $name, @mess);
 }
@@ -131,7 +132,7 @@ sub display {
     return @result;
 }
 
-sub is {
+sub is ($$@) {
     my ($got, $expected, $name, @mess) = @_;
 
     my $pass;
@@ -150,7 +151,7 @@ sub is {
     _ok($pass, _where(), $name, @mess);
 }
 
-sub isnt {
+sub isnt ($$@) {
     my ($got, $isnt, $name, @mess) = @_;
 
     my $pass;
@@ -169,7 +170,7 @@ sub isnt {
     _ok($pass, _where(), $name, @mess);
 }
 
-sub cmp_ok {
+sub cmp_ok ($$$@) {
     my($got, $type, $expected, $name, @mess) = @_;
 
     my $pass;
@@ -202,7 +203,7 @@ sub cmp_ok {
 # otherwise $range is a fractional error.
 # Here $range must be numeric, >= 0
 # Non numeric ranges might be a useful future extension. (eg %)
-sub within {
+sub within ($$$@) {
     my ($got, $expected, $range, $name, @mess) = @_;
     my $pass;
     if (!defined $got or !defined $expected or !defined $range) {
@@ -234,21 +235,18 @@ sub within {
 }
 
 # Note: this isn't quite as fancy as Test::More::like().
-sub like {
-    my ($got, $expected, $name, @mess) = @_;
+
+sub like   ($$@) { like_yn (0,@_) }; # 0 for -
+sub unlike ($$@) { like_yn (1,@_) }; # 1 for un-
+
+sub like_yn ($$$@) {
+    my ($flip, $got, $expected, $name, @mess) = @_;
     my $pass;
-    if (ref $expected eq 'Regexp') {
-	$pass = $got =~ $expected;
-	unless ($pass) {
-	    unshift(@mess, "#      got '$got'\n",
-		           "# expected /$expected/\n");
-	}
-    } else {
-	$pass = $got =~ /$expected/;
-	unless ($pass) {
-	    unshift(@mess, "#      got '$got'\n",
-		           "# expected /$expected/\n");
-	}
+    $pass = $got =~ /$expected/ if !$flip;
+    $pass = $got !~ /$expected/ if $flip;
+    unless ($pass) {
+	unshift(@mess, "#      got '$got'\n",
+		"# expected /$expected/\n");
     }
     _ok($pass, _where(), $name, @mess);
 }
@@ -320,7 +318,7 @@ sub eq_hash {
   !$fail;
 }
 
-sub require_ok {
+sub require_ok ($) {
     my ($require) = @_;
     eval <<REQUIRE_OK;
 require $require;
@@ -328,7 +326,7 @@ REQUIRE_OK
     _ok(!$@, _where(), "require $require");
 }
 
-sub use_ok {
+sub use_ok ($) {
     my ($use) = @_;
     eval <<USE_OK;
 use $use;
@@ -366,7 +364,7 @@ sub _quote_args {
 
 sub _create_runperl { # Create the string to qx in runperl().
     my %args = @_;
-    my $runperl = $^X;
+    my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
     unless ($args{nolib}) {
 	if ($is_macos) {
 	    $runperl .= ' -I::lib';
@@ -378,12 +376,19 @@ sub _create_runperl { # Create the string to qx in runperl().
 	}
     }
     if ($args{switches}) {
+	local $Level = 2;
+	die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where()
+	    unless ref $args{switches} eq "ARRAY";
 	_quote_args(\$runperl, $args{switches});
     }
     if (defined $args{prog}) {
+	die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where()
+	    if defined $args{progs};
         $args{progs} = [$args{prog}]
     }
     if (defined $args{progs}) {
+	die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where()
+	    unless ref $args{progs} eq "ARRAY";
         foreach my $prog (@{$args{progs}}) {
             if ($is_mswin || $is_netware || $is_vms) {
                 $runperl .= qq ( -e "$prog" );
@@ -578,26 +583,28 @@ sub _fresh_perl {
 }
 
 #
-# run_perl_is
+# fresh_perl_is
 #
 # Combination of run_perl() and is().
 #
 
 sub fresh_perl_is {
     my($prog, $expected, $runperl_args, $name) = @_;
+    local $Level = 2;
     _fresh_perl($prog,
 		sub { @_ ? $_[0] eq $expected : $expected },
 		$runperl_args, $name);
 }
 
 #
-# run_perl_like
+# fresh_perl_like
 #
 # Combination of run_perl() and like().
 #
 
 sub fresh_perl_like {
     my($prog, $expected, $runperl_args, $name) = @_;
+    local $Level = 2;
     _fresh_perl($prog,
 		sub { @_ ?
 			  $_[0] =~ (ref $expected ? $expected : /$expected/) :