As long ago promised, here's a patch to pull the logic out of
t/run/kill_perl.t and make it into a t/test.pl function.
This means its no longer necessary to pile segfault checks into
t/run/kill_perl.t. They can be placed in the appropriate test file
like so:
kill_perl(<<PROG, <<EXPECT, {}, 'segfault in 5.6.1 within peep()' );
@a = (1..9);
@b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a;
print join '', @a, "\n";
PROG
123456789
EXPECT
Give or take the fancy here-doc idiom.
The name of the function and order of arguments are all up for
discussion.
Next step is to move the existing tests in kill_perl.t into their
rightful files.
PS There was also a bug in runperl(). All switches were being lost.
--- t/test.pl 2002/01/11 08:41:48 1.1
+++ t/test.pl 2002/01/11 09:17:19
@@ -280,7 +280,7 @@
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 @@
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;
--- t/run/kill_perl.t 2002/01/11 08:42:45 1.1
+++ t/run/kill_perl.t 2002/01/11 09:24:36
@@ -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 @@
$prgs[-1][0] .= $_;
}
}
-print "1..", scalar @prgs, "\n";
-
-my $tmpfile = "misctmp000";
-1 while -f ++$tmpfile;
-END { while($tmpfile && unlink $tmpfile){} }
+plan tests => scalar @prgs;
-my $test = 1;
foreach my $prog (@prgs) {
my($raw_prog, $name) = @$prog;
@@ -57,57 +52,7 @@
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__
--
Michael G. Schwern <[EMAIL PROTECTED]> http://www.pobox.com/~schwern/
Perl Quality Assurance <[EMAIL PROTECTED]> Kwalitee Is Job One
It should indeed be said that notwithstanding the fact that I make
ambulatory progress through the umbragious inter-hill mortality slot,
terror sensations will no be initiated in me, due to para-etical phenomena.
