From: Michael G. Schwern <schwern@pobox.com>
Date: Fri, 11 Jan 2002 04:26:27 +0000 (-0500)
Subject: Seperating kill_perl()
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=eeabcb2d450d30a3ba37aefb26967f94b18242c5;p=p5sagit%2Fp5-mst-13.2.git

Seperating kill_perl()
Message-ID: <20020111092626.GA16544@blackrider>

p4raw-id: //depot/perl@14183
---

diff --git a/t/run/kill_perl.t b/t/run/kill_perl.t
index ca982d1..9d3a641 100644
--- a/t/run/kill_perl.t
+++ b/t/run/kill_perl.t
@@ -1,5 +1,9 @@
 #!./perl
 
+# ** DO NOT ADD ANY MORE TESTS HERE **
+# Instead, put the test in the appropriate test file and use the 
+# kill_perl() function in t/test.pl.
+
 # This is for tests that will normally cause segfaults, and other nasty
 # errors that might kill the interpreter and for some reason you can't
 # use an eval().
@@ -14,10 +18,6 @@
 # to test that the code "($a, b) = (1,2)" causes the appropriate syntax
 # error, rather than just segfaulting as reported in perlbug ID
 # 20020831.001
-#
-#
-# NOTE: Please don't add tests to this file unless they *need* to be
-# run in separate executable and can't simply use eval.
 
 BEGIN {
     chdir 't' if -d 't';
@@ -40,13 +40,8 @@ while(<DATA>) {
         $prgs[-1][0] .= $_;
     }
 }
-print "1..", scalar @prgs, "\n";
+plan tests => scalar @prgs;
 
-my $tmpfile = "misctmp000";
-1 while -f ++$tmpfile;
-END { while($tmpfile && unlink $tmpfile){} }
-
-my $test = 1;
 foreach my $prog (@prgs) {
     my($raw_prog, $name) = @$prog;
 
@@ -57,57 +52,7 @@ foreach my $prog (@prgs) {
 
     my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog);
 
-    open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
-
-    # VMS adjustments
-    if( $^O eq 'VMS' ) {
-        $prog =~ s#/dev/null#NL:#;
-
-        # VMS file locking 
-        $prog =~ s{if \(-e _ and -f _ and -r _\)}
-                  {if (-e _ and -f _)}
-    }
-
-    print TEST $prog, "\n";
-    close TEST or die "Cannot close $tmpfile: $!";
-
-    my $results;
-    if ($^O eq 'MacOS') {
-        $results = `$Perl -I::lib -MMac::err=unix $switch $tmpfile`;
-    }
-    else {
-        $results = `$Perl "-I../lib" $switch $tmpfile 2>&1`;
-    }
-    my $status = $?;
-
-    # Clean up the results into something a bit more predictable.
-    $results =~ s/\n+$//;
-    $results =~ s/at\s+misctmp\d+\s+line/at - line/g;
-    $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g;
-
-    # bison says 'parse error' instead of 'syntax error',
-    # various yaccs may or may not capitalize 'syntax'.
-    $results =~ s/^(syntax|parse) error/syntax error/mig;
-
-    if ($^O eq 'VMS') {
-        # some tests will trigger VMS messages that won't be expected
-        $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
-
-        # pipes double these sometimes
-        $results =~ s/\n\n/\n/g;
-    }
-
-    $expected =~ s/\n+$//;
-    my $ok = $results eq $expected;
-
-    unless( $ok ) {
-        print STDERR "# PROG: $switch\n$prog\n";
-        print STDERR "# EXPECTED:\n$expected\n";
-        print STDERR "# GOT:\n$results\n";
-    }
-    printf "%sok %d%s\n", ($ok ? '' : "not "), $test, 
-                          length $name ? " - $name" : $name;
-    $test++;
+    kill_perl($prog, $expected, { switches => $switch }, $name);
 }
 
 __END__
diff --git a/t/test.pl b/t/test.pl
index 14d5334..d4b52c5 100644
--- a/t/test.pl
+++ b/t/test.pl
@@ -280,7 +280,7 @@ sub runperl {
     my %args = @_;
     my $runperl = $^X;
     if ($args{switches}) {
-	_quote_args(\$runperl, $args{switches});
+	_quote_args(\$runperl, [$args{switches}]);
     }
     unless ($args{nolib}) {
 	if ($is_macos) {
@@ -390,4 +390,66 @@ sub unlink_all {
         print STDERR "# Couldn't unlink '$file': $!\n" if -f $file;
     }
 }
+
+
+my $tmpfile = "misctmp000";
+1 while -f ++$tmpfile;
+END { unlink_all $tmpfile }
+
+sub kill_perl {
+    my($prog, $expected, $runperl_args, $name) = @_;
+
+    $runperl_args ||= {};
+    $runperl_args->{progfile} = $tmpfile;
+    $runperl_args->{stderr} = 1;
+
+    open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
+
+    # VMS adjustments
+    if( $^O eq 'VMS' ) {
+        $prog =~ s#/dev/null#NL:#;
+
+        # VMS file locking 
+        $prog =~ s{if \(-e _ and -f _ and -r _\)}
+                  {if (-e _ and -f _)}
+    }
+
+    print TEST $prog, "\n";
+    close TEST or die "Cannot close $tmpfile: $!";
+
+    my $results = runperl(%$runperl_args);
+    my $status = $?;
+
+    # Clean up the results into something a bit more predictable.
+    $results =~ s/\n+$//;
+    $results =~ s/at\s+misctmp\d+\s+line/at - line/g;
+    $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g;
+
+    # bison says 'parse error' instead of 'syntax error',
+    # various yaccs may or may not capitalize 'syntax'.
+    $results =~ s/^(syntax|parse) error/syntax error/mig;
+
+    if ($^O eq 'VMS') {
+        # some tests will trigger VMS messages that won't be expected
+        $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
+
+        # pipes double these sometimes
+        $results =~ s/\n\n/\n/g;
+    }
+
+    $expected =~ s/\n+$//;
+
+    my $pass = $results eq $expected;
+    unless ($pass) {
+        print STDERR "# PROG: $switch\n$prog\n";
+        print STDERR "# EXPECTED:\n$expected\n";
+        print STDERR "# GOT:\n$results\n";
+        print STDERR "# STATUS: $status\n";
+    }
+
+    ($name) = $prog =~ /^(.{1,35})/ unless $name;
+
+    _ok($pass, _where(), "kill_perl - $name");
+}
+
 1;