X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Ftest.pl;h=32c4a374e5dfeaca47821909207f4c5b2e5f6b40;hb=953f6acfa20ec275ec39a552dfac8124bd93ebdf;hp=b492c777c59fa875c57fde1c0c29d9b40113e52d;hpb=3b6d8381b2a5a9454f136660072d896712c81069;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/test.pl b/t/test.pl index b492c77..32c4a37 100644 --- a/t/test.pl +++ b/t/test.pl @@ -20,10 +20,22 @@ $Level = 1; my $test = 1; my $planned; my $noplan; +my $Perl; # Safer version of $^X set by which_perl() $TODO = 0; $NO_ENDING = 0; +# Use this instead of print to avoid interference while testing globals. +sub _print { + local($\, $", $,) = (undef, ' ', ''); + print STDOUT @_; +} + +sub _print_stderr { + local($\, $", $,) = (undef, ' ', ''); + print STDERR @_; +} + sub plan { my $n; if (@_ == 1) { @@ -36,7 +48,7 @@ sub plan { my %plan = @_; $n = $plan{tests}; } - print STDOUT "1..$n\n" unless $noplan; + _print "1..$n\n" unless $noplan; $planned = $n; } @@ -44,10 +56,10 @@ END { my $ran = $test - 1; if (!$NO_ENDING) { if (defined $planned && $planned != $ran) { - print STDERR + _print_stderr "# Looks like you planned $planned tests but ran $ran.\n"; } elsif ($noplan) { - print "1..$ran\n"; + _print "1..$ran\n"; } } } @@ -58,9 +70,7 @@ sub _diag { return unless @_; my @mess = map { /^#/ ? "$_\n" : "# $_\n" } map { split /\n/ } @_; - my $fh = $TODO ? *STDOUT : *STDERR; - print $fh @mess; - + $TODO ? _print(@mess) : _print_stderr(@mess); } sub diag { @@ -69,9 +79,9 @@ sub diag { sub skip_all { if (@_) { - print STDOUT "1..0 # Skipped: @_\n"; + _print "1..0 # Skip @_\n"; } else { - print STDOUT "1..0\n"; + _print "1..0\n"; } exit(0); } @@ -90,7 +100,7 @@ sub _ok { } $out .= " # TODO $TODO" if $TODO; - print STDOUT "$out\n"; + _print "$out\n"; unless ($pass) { _diag "# Failed $where\n"; @@ -306,7 +316,7 @@ sub skip { my $why = shift; my $n = @_ ? shift : 1; for (1..$n) { - print STDOUT "ok $test # skip: $why\n"; + _print "ok $test # skip $why\n"; $test = $test + 1; } local $^W = 0; @@ -318,7 +328,7 @@ sub todo_skip { my $n = @_ ? shift : 1; for (1..$n) { - print STDOUT "not ok $test # TODO & SKIP: $why\n"; + _print "not ok $test # TODO & SKIP $why\n"; $test = $test + 1; } local $^W = 0; @@ -345,12 +355,12 @@ sub eq_hash { $key = "" . $key; if (exists $orig->{$key}) { if ($orig->{$key} ne $value) { - print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}), + _print "# key ", _qq($key), " was ", _qq($orig->{$key}), " now ", _qq($value), "\n"; $fail = 1; } } else { - print STDOUT "# key ", _qq($key), " is ", _qq($value), + _print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n"; $fail = 1; } @@ -359,7 +369,7 @@ sub eq_hash { # Force a hash recompute if this perl's internals can cache the hash key. $_ = "" . $_; next if (exists $suspect->{$_}); - print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; + _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; $fail = 1; } !$fail; @@ -397,6 +407,7 @@ my $is_mswin = $^O eq 'MSWin32'; my $is_netware = $^O eq 'NetWare'; my $is_macos = $^O eq 'MacOS'; my $is_vms = $^O eq 'VMS'; +my $is_cygwin = $^O eq 'cygwin'; sub _quote_args { my ($runperl, $args) = @_; @@ -411,7 +422,10 @@ sub _quote_args { sub _create_runperl { # Create the string to qx in runperl(). my %args = @_; - my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X; + my $runperl = which_perl(); + if ($runperl =~ m/\s/) { + $runperl = qq{"$runperl"}; + } #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind if ($ENV{PERL_RUNPERL_DEBUG}) { $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; @@ -464,24 +478,24 @@ sub _create_runperl { # Create the string to qx in runperl(). $args{stdin} =~ s/\r/\\r/g; if ($is_mswin || $is_netware || $is_vms) { - $runperl = qq{$^X -e "print qq(} . + $runperl = qq{$Perl -e "print qq(} . $args{stdin} . q{)" | } . $runperl; } elsif ($is_macos) { # MacOS can only do two processes under MPW at once; # the test itself is one; we can't do two more, so # write to temp file - my $stdin = qq{$^X -e 'print qq(} . $args{stdin} . qq{)' > teststdin; }; + my $stdin = qq{$Perl -e 'print qq(} . $args{stdin} . qq{)' > teststdin; }; if ($args{verbose}) { my $stdindisplay = $stdin; $stdindisplay =~ s/\n/\n\#/g; - print STDERR "# $stdindisplay\n"; + _print_stderr "# $stdindisplay\n"; } `$stdin`; $runperl .= q{ < teststdin }; } else { - $runperl = qq{$^X -e 'print qq(} . + $runperl = qq{$Perl -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; } } @@ -493,7 +507,7 @@ sub _create_runperl { # Create the string to qx in runperl(). if ($args{verbose}) { my $runperldisplay = $runperl; $runperldisplay =~ s/\n/\n\#/g; - print STDERR "# $runperldisplay\n"; + _print_stderr "# $runperldisplay\n"; } return $runperl; } @@ -513,12 +527,11 @@ sub runperl { # run a fresh perl, so we'll brute force launder everything for you my $sep; - eval "require Config; Config->import"; - if ($@) { + if (! eval 'require Config; 1') { warn "test.pl had problems loading Config: $@"; $sep = ':'; } else { - $sep = $Config{path_sep}; + $sep = $Config::Config{path_sep}; } my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); @@ -530,6 +543,7 @@ sub runperl { join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } split quotemeta ($sep), $1; + $ENV{PATH} .= "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin $runperl =~ /(.*)/s; $runperl = $1; @@ -545,12 +559,11 @@ sub runperl { *run_perl = \&runperl; # Nice alias. sub DIE { - print STDERR "# @_\n"; + _print_stderr "# @_\n"; exit 1; } # A somewhat safer version of the sometimes wrong $^X. -my $Perl; sub which_perl { unless (defined $Perl) { $Perl = $^X; @@ -559,12 +572,11 @@ sub which_perl { return $Perl if $^O eq 'VMS'; my $exe; - eval "require Config; Config->import"; - if ($@) { + if (! eval 'require Config; 1') { warn "test.pl had problems loading Config: $@"; $exe = ''; } else { - $exe = $Config{_exe}; + $exe = $Config::Config{_exe}; } $exe = '' unless defined $exe; @@ -574,8 +586,7 @@ sub which_perl { if ($Perl =~ /^perl\Q$exe\E$/i) { my $perl = "perl$exe"; - eval "require File::Spec"; - if ($@) { + if (! eval 'require File::Spec; 1') { warn "test.pl had problems loading File::Spec: $@"; $Perl = "./$perl"; } else { @@ -601,14 +612,41 @@ sub which_perl { sub unlink_all { foreach my $file (@_) { 1 while unlink $file; - print STDERR "# Couldn't unlink '$file': $!\n" if -f $file; - } + _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file; + } +} + +my %tmpfiles; +END { unlink_all keys %tmpfiles } + +# A regexp that matches the tempfile names +$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; + +# Avoid ++, avoid ranges, avoid split // +my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); +sub tempfile { + my $count = 0; + do { + my $temp = $count; + my $try = "tmp$$"; + do { + $try .= $letters[$temp % 26]; + $temp = int ($temp / 26); + } while $temp; + # Need to note all the file names we allocated, as a second request may + # come before the first is created. + if (!-e $try && !$tmpfiles{$try}) { + # We have a winner + $tmpfiles{$try}++; + return $try; + } + $count = $count + 1; + } while $count < 26 * 26; + die "Can't find temporary file name starting 'tmp$$'"; } - -my $tmpfile = "misctmp000"; -1 while -f ++$tmpfile; -END { unlink_all $tmpfile } +# This is the temporary file for _fresh_perl +my $tmpfile = tempfile(); # # _fresh_perl @@ -644,8 +682,8 @@ sub _fresh_perl { # 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; + $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; + $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. @@ -768,4 +806,135 @@ WHOA _ok( !$diag, _where(), $name ); } +# Set a watchdog to timeout the entire test file +# NOTE: If the test file uses 'threads', then call the watchdog() function +# _AFTER_ the 'threads' module is loaded. +sub watchdog ($) +{ + my $timeout = shift; + my $timeout_msg = 'Test process timed out - terminating'; + + my $pid_to_kill = $$; # PID for this process + + # Don't use a watchdog process if 'threads' is loaded - + # use a watchdog thread instead + if (! $threads::threads) { + + # On Windows and VMS, try launching a watchdog process + # using system(1, ...) (see perlport.pod) + if (($^O eq 'MSWin32') || ($^O eq 'VMS')) { + # On Windows, try to get the 'real' PID + if ($^O eq 'MSWin32') { + eval { require Win32; }; + if (defined(&Win32::GetCurrentProcessId)) { + $pid_to_kill = Win32::GetCurrentProcessId(); + } + } + + # If we still have a fake PID, we can't use this method at all + return if ($pid_to_kill <= 0); + + # Launch watchdog process + my $watchdog; + eval { + local $SIG{'__WARN__'} = sub { + _diag("Watchdog warning: $_[0]"); + }; + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + $watchdog = system(1, which_perl(), '-e', + "sleep($timeout);" . + "warn('# $timeout_msg\n');" . + "kill($sig, $pid_to_kill);"); + }; + if ($@ || ($watchdog <= 0)) { + _diag('Failed to start watchdog'); + _diag($@) if $@; + undef($watchdog); + return; + } + + # Add END block to parent to terminate and + # clean up watchdog process + eval "END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"; + return; + } + + # Try using fork() to generate a watchdog process + my $watchdog; + eval { $watchdog = fork() }; + if (defined($watchdog)) { + if ($watchdog) { # Parent process + # Add END block to parent to terminate and + # clean up watchdog process + eval "END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"; + return; + } + + ### Watchdog process code + + # Load POSIX if available + eval { require POSIX; }; + + # Execute the timeout + sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 + sleep(2); + + # Kill test process if still running + if (kill(0, $pid_to_kill)) { + _diag($timeout_msg); + kill('KILL', $pid_to_kill); + } + + # Don't execute END block (added at beginning of this file) + $NO_ENDING = 1; + + # Terminate ourself (i.e., the watchdog) + POSIX::_exit(1) if (defined(&POSIX::_exit)); + exit(1); + } + + # fork() failed - fall through and try using a thread + } + + # Use a watchdog thread because either 'threads' is loaded, + # or fork() failed + if (eval 'require threads; 1') { + threads->create(sub { + # Load POSIX if available + eval { require POSIX; }; + + # Execute the timeout + my $time_left = $timeout; + do { + $time_left -= sleep($time_left); + } while ($time_left > 0); + + # Kill the parent (and ourself) + select(STDERR); $| = 1; + _diag($timeout_msg); + POSIX::_exit(1) if (defined(&POSIX::_exit)); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); + })->detach(); + return; + } + + # If everything above fails, then just use an alarm timeout + if (eval { alarm($timeout); 1; }) { + # Load POSIX if available + eval { require POSIX; }; + + # Alarm handler will do the actual 'killing' + $SIG{'ALRM'} = sub { + select(STDERR); $| = 1; + _diag($timeout_msg); + POSIX::_exit(1) if (defined(&POSIX::_exit)); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); + }; + } +} + 1;