From 5fe9b82b31adfe8909464d39a881e33ad498d384 Mon Sep 17 00:00:00 2001 From: "Jerry D. Hedden" Date: Mon, 7 Jul 2008 09:29:14 -0400 Subject: test.pl fix From: "Jerry D. Hedden" Message-ID: <1ff86f510807071029q5931f03ud506f06b7d1f72af@mail.gmail.com> p4raw-id: //depot/perl@34109 --- t/test.pl | 137 +++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 81 insertions(+), 56 deletions(-) (limited to 't') diff --git a/t/test.pl b/t/test.pl index d697f77789..e310f61945 100644 --- a/t/test.pl +++ b/t/test.pl @@ -20,6 +20,7 @@ $Level = 1; my $test = 1; my $planned; my $noplan; +my $Perl; # Safer version of $^X set by which_perl() $TODO = 0; $NO_ENDING = 0; @@ -421,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"; @@ -474,14 +478,14 @@ 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; @@ -491,7 +495,7 @@ sub _create_runperl { # Create the string to qx in runperl(). $runperl .= q{ < teststdin }; } else { - $runperl = qq{$^X -e 'print qq(} . + $runperl = qq{$Perl -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; } } @@ -561,7 +565,6 @@ sub DIE { } # A somewhat safer version of the sometimes wrong $^X. -my $Perl; sub which_perl { unless (defined $Perl) { $Perl = $^X; @@ -780,6 +783,8 @@ WHOA } # 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; @@ -787,68 +792,88 @@ sub watchdog ($) my $pid_to_kill = $$; # PID for this process - # 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(); + # 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 {}; - $watchdog = system(1, $^X, '-e', "sleep($timeout);" . - "kill('KILL', $pid_to_kill);"); - }; + # 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]"); + }; + $watchdog = system(1, which_perl(), '-e', + "sleep($timeout);" . + "kill('KILL', $pid_to_kill);"); + }; + if ($@ || ($watchdog <= 0)) { + _diag('Failed to start watchdog'); + _diag($@) if $@; + undef($watchdog); + return; + } - # If the above worked, add END block to parent - # to clean up watchdog process - if (! $@ && ($watchdog > 0)) { - eval "END { kill('KILL', $watchdog); }"; + # Add END block to parent to terminate and + # clean up watchdog process + eval "END { local \$!; local \$?; + wait() if kill('KILL', $watchdog); }"; + return; } - 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 \$!; local \$?; + wait() if kill('KILL', $watchdog); }"; + return; + } + + ### Watchdog process code - # 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 clean up watchdog process - eval "END { kill('KILL', $watchdog); }"; - return; - } + # Load POSIX if available + eval { require POSIX; }; - ### Watchdog process code + # Execute the timeout + sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 + sleep(2); - # Load POSIX if available - eval { require POSIX; }; + # Kill test process if still running + if (kill(0, $pid_to_kill)) { + _diag($timeout_msg); + kill('KILL', $pid_to_kill); + } - # Execute the timeout - sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 - sleep(2); + # Don't execute END block (added at beginning of this file) + $NO_ENDING = 1; - # Kill test process if still running - if (kill(0, $pid_to_kill)) { - _diag($timeout_msg); - kill('KILL', $pid_to_kill); + # Terminate ourself (i.e., the watchdog) + POSIX::_exit(1) if (defined(&POSIX::_exit)); + exit(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 } - # fork() failed - try a thread + # Use a watchdog thread because either 'threads' is loaded, + # or fork() failed if (eval { require threads; }) { threads->create(sub { # Load POSIX if available @@ -858,6 +883,7 @@ sub watchdog ($) sleep($timeout); # Kill the parent (and ourself) + select(STDERR); $| = 1; _diag($timeout_msg); POSIX::_exit(1) if (defined(&POSIX::_exit)); kill('KILL', $pid_to_kill); @@ -865,15 +891,14 @@ sub watchdog ($) return; } - # Threads failed, too - try use alarm() - - # Try to set the timeout + # 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)); kill('KILL', $pid_to_kill); -- cgit v1.2.1