X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Ftest.pl;h=7550b490e5642f1818ac2bcdac574c73cf7d045b;hb=5c144d81801caa5e8317f6a38b40eb08257c47ea;hp=81605f59585573d84edadf996746126d1cb85ac4;hpb=c3029c660c41826954b460e82523f3ba1f91d479;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/test.pl b/t/test.pl
index 81605f5..7550b49 100644
--- a/t/test.pl
+++ b/t/test.pl
@@ -2,8 +2,10 @@
 # t/test.pl - most of Test::More functionality without the fuss
 #
 
+$Level = 1;
 my $test = 1;
 my $planned;
+my $noplan;
 
 $TODO = 0;
 $NO_ENDING = 0;
@@ -12,18 +14,27 @@ sub plan {
     my $n;
     if (@_ == 1) {
 	$n = shift;
+	if ($n eq 'no_plan') {
+	  undef $n;
+	  $noplan = 1;
+	}
     } else {
 	my %plan = @_;
 	$n = $plan{tests}; 
     }
-    print STDOUT "1..$n\n";
+    print STDOUT "1..$n\n" unless $noplan;
     $planned = $n;
 }
 
 END {
     my $ran = $test - 1;
-    if (!$NO_ENDING && defined $planned && $planned != $ran) {
-        print STDERR "# Looks like you planned $planned tests but ran $ran.\n";
+    if (!$NO_ENDING) {
+	if (defined $planned && $planned != $ran) {
+	    print STDERR
+		"# Looks like you planned $planned tests but ran $ran.\n";
+	} elsif ($noplan) {
+	    print "1..$ran\n";
+	}
     }
 }
 
@@ -76,7 +87,7 @@ sub _ok {
 }
 
 sub _where {
-    my @caller = caller(1);
+    my @caller = caller($Level);
     return "at $caller[1] line $caller[2]";
 }
 
@@ -90,8 +101,8 @@ sub _q {
     my $x = shift;
     return 'undef' unless defined $x;
     my $q = $x;
-    $q =~ s/\\/\\\\/;
-    $q =~ s/'/\\'/;
+    $q =~ s/\\/\\\\/g;
+    $q =~ s/'/\\'/g;
     return "'$q'";
 }
 
@@ -234,21 +245,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);
 }
@@ -283,10 +291,25 @@ sub skip {
     last SKIP;
 }
 
+sub todo_skip {
+    my $why = shift;
+    my $n   = @_ ? shift : 1;
+
+    for (1..$n) {
+        print STDOUT "ok $test # TODO & SKIP: $why\n";
+        $test++;
+    }
+    local $^W = 0;
+    last TODO;
+}
+
 sub eq_array {
     my ($ra, $rb) = @_;
     return 0 unless $#$ra == $#$rb;
     for my $i (0..$#$ra) {
+	next     if !defined $ra->[$i] && !defined $rb->[$i]; 
+	return 0 if !defined $ra->[$i];
+	return 0 if !defined $rb->[$i];
 	return 0 unless $ra->[$i] eq $rb->[$i];
     }
     return 1;
@@ -378,12 +401,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" );
@@ -394,6 +424,12 @@ sub _create_runperl { # Create the string to qx in runperl().
         }
     } elsif (defined $args{progfile}) {
 	$runperl .= qq( "$args{progfile}");
+    } else {
+	# You probaby didn't want to be sucking in from the upstream stdin
+	die "test.pl:runperl(): none of prog, progs, progfile, args, "
+	    . " switches or stdin specified"
+	    unless defined $args{args} or defined $args{switches}
+		or defined $args{stdin};
     }
     if (defined $args{stdin}) {
 	# so we don't try to put literal newlines and crs onto the
@@ -437,6 +473,8 @@ sub _create_runperl { # Create the string to qx in runperl().
 }
 
 sub runperl {
+    die "test.pl:runperl() does not take a hashref"
+	if ref $_[0] and ref $_[0] eq 'HASH';
     my $runperl = &_create_runperl;
     my $result = `$runperl`;
     $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
@@ -578,26 +616,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/) :