perl.c change to use HAS_PROCSELFEXE, also

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

diff --git a/t/test.pl b/t/test.pl
index 6caa865..e4411af 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -5,6 +5,8 @@
 my $test = 1;
 my $planned;
 
+$TODO = 0;
+
 sub plan {
     my $n;
     if (@_ == 1) {
@@ -34,17 +36,27 @@ sub skip_all {
 }
 
 sub _ok {
-    my ($pass, $where, @mess) = @_;
+    my ($pass, $where, $name, @mess) = @_;
     # Do not try to microoptimize by factoring out the "not ".
     # VMS will avenge.
-    if (@mess) {
-       print $pass ? "ok $test - @mess\n" : "not ok $test - @mess\n";
+    my $out;
+    if ($name) {
+       $out = $pass ? "ok $test - $name" : "not ok $test - $name";
     } else {
-       print $pass ? "ok $test\n" : "not ok $test\n";
+       $out = $pass ? "ok $test" : "not ok $test";
     }
+
+    $out .= " # TODO $TODO" if $TODO;
+    print "$out\n";
+
     unless ($pass) {
        print "# Failed $where\n";
     }
+
+    # Ensure that the message is properly escaped.
+    print map { /^#/ ? "$_\n" : "# $_\n" } 
+          map { split /\n/ } @mess if @mess;
+
     $test++;
 
     return $pass;
@@ -56,27 +68,33 @@ sub _where {
 }
 
 sub ok {
-    my ($pass, @mess) = @_;
-    _ok($pass, _where(), @mess);
+    my ($pass, $name, @mess) = @_;
+    _ok($pass, _where(), $name, @mess);
+}
+
+sub _q {
+    my $x = shift;
+    return 'undef' unless defined $x;
+    my $q = $x;
+    $q =~ s/'/\\'/;
+    return "'$q'";
 }
 
 sub is {
-    my ($got, $expected, @mess) = @_;
+    my ($got, $expected, $name, @mess) = @_;
     my $pass = $got eq $expected;
     unless ($pass) {
-       unshift(@mess, "\n",
-               "#      got '$got'\n",
-               "# expected '$expected'\n");
+       unshift(@mess, "#      got "._q($got)."\n",
+                      "# expected "._q($expected)."\n");
     }
-    _ok($pass, _where(), @mess);
+    _ok($pass, _where(), $name, @mess);
 }
 
 sub isnt {
     my ($got, $isnt, $name, @mess) = @_;
     my $pass = $got ne $isnt;
     unless( $pass ) {
-        unshift(@mess, "# It should not be " .
-                      ( defined $got ? $got : "undef" ) . "\n",
+        unshift(@mess, "# it should not be "._q($got)."\n",
                        "# but it is.\n");
     }
     _ok($pass, _where(), $name, @mess);
@@ -84,23 +102,21 @@ sub isnt {
 
 # Note: this isn't quite as fancy as Test::More::like().
 sub like {
-    my ($got, $expected, @mess) = @_;
+    my ($got, $expected, $name, @mess) = @_;
     my $pass;
     if (ref $expected eq 'Regexp') {
        $pass = $got =~ $expected;
        unless ($pass) {
-           unshift(@mess, "\n",
-                   "#      got '$got'\n");
+           unshift(@mess, "#      got '$got'\n");
        }
     } else {
        $pass = $got =~ /$expected/;
        unless ($pass) {
-           unshift(@mess, "\n",
-                   "#      got '$got'\n",
-                   "# expected /$expected/\n");
+           unshift(@mess, "#      got '$got'\n",
+                          "# expected /$expected/\n");
        }
     }
-    _ok($pass, _where(), @mess);
+    _ok($pass, _where(), $name, @mess);
 }
 
 sub pass {
@@ -118,10 +134,11 @@ sub next_test {
 # Note: can't pass multipart messages since we try to
 # be compatible with Test::More::skip().
 sub skip {
-    my $mess = shift;
+    my $why = shift;
     my $n    = @_ ? shift : 1;
     for (1..$n) {
-       ok(1, "# skip:", $mess);
+       print "ok $test # skip: $why\n";
+        $test++;
     }
     local $^W = 0;
     last SKIP;
@@ -152,4 +169,87 @@ USE_OK
     _ok(!$@, _where(), "use $use");
 }
 
+# runperl - Runs a separate perl interpreter.
+# Arguments :
+#   switches => [ command-line switches ]
+#   nolib    => 1 # don't use -I../lib (included by default)
+#   prog     => one-liner (avoid quotes)
+#   progfile => perl script
+#   stdin    => string to feed the stdin
+#   stderr   => redirect stderr to stdout
+#   args     => [ command-line arguments to the perl program ]
+#   verbose  => print the command line
+
+my $is_mswin    = $^O eq 'MSWin32';
+my $is_netware  = $^O eq 'NetWare';
+my $is_macos    = $^O eq 'MacOS';
+my $is_vms      = $^O eq 'VMS';
+
+sub _quote_args {
+    my ($runperl, $args) = @_;
+
+    foreach (@$args) {
+       # In VMS protect with doublequotes because otherwise
+       # DCL will lowercase -- unless already doublequoted.
+       $_ = q(").$_.q(") if $is_vms && !/^\"/;
+       $$runperl .= ' ' . $_;
+    }
+}
+
+sub runperl {
+    my %args = @_;
+    my $runperl = $^X;
+    if ($args{switches}) {
+       _quote_args(\$runperl, $args{switches});
+    }
+    unless ($args{nolib}) {
+       if ($is_macos) {
+           $runperl .= ' -I::lib';
+           # Use UNIX style error messages instead of MPW style.
+           $runperl .= ' -MMac::err=unix' if $args{stderr};
+       }
+       else {
+           $runperl .= ' "-I../lib"'; # doublequotes because of VMS
+       }
+    }
+    if (defined $args{prog}) {
+       if ($is_mswin || $is_netware || $is_vms) {
+           $runperl .= qq( -e ") . $args{prog} . qq(");
+       }
+       else {
+           $runperl .= qq( -e ') . $args{prog} . qq(');
+       }
+    } elsif (defined $args{progfile}) {
+       $runperl .= qq( "$args{progfile}");
+    }
+    if (defined $args{stdin}) {
+        # so we don't try to put literal newlines and crs onto the
+        # command line.
+        $args{stdin} =~ s/\n/\\n/g;
+        $args{stdin} =~ s/\r/\\r/g;
+
+       if ($is_mswin || $is_netware || $is_vms) {
+           $runperl = qq{$^X -e "print qq(} .
+               $args{stdin} . q{)" | } . $runperl;
+       }
+       else {
+           $runperl = qq{$^X -e 'print qq(} .
+               $args{stdin} . q{)' | } . $runperl;
+       }
+    }
+    if (defined $args{args}) {
+       _quote_args(\$runperl, $args{args});
+    }
+    $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
+    $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
+    if ($args{verbose}) {
+       my $runperldisplay = $runperl;
+       $runperldisplay =~ s/\n/\n\#/g;
+       print "# $runperldisplay\n";
+    }
+    my $result = `$runperl`;
+    $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
+    return $result;
+}
+
 1;