diff --git a/t/test.pl b/t/test.pl index 1810f662fa92..4f20d0b24e78 100644 --- a/t/test.pl +++ b/t/test.pl @@ -1836,34 +1836,35 @@ sub warning_like { # NOTE: If the test file uses 'threads', then call the watchdog() function # _AFTER_ the 'threads' module is loaded. { # Closure - my $watchdog; + my $watchdog_process; my $watchdog_thread; + my $watchdog_alarm; + + # Add END block to terminate and clean up any watchdog + END { watchdog(0); }; sub watchdog ($;$) { my $timeout = shift; - # If cancelling, use the state variables to know which method was used to - # create the watchdog. - if ($timeout == 0) { - if ($watchdog_thread) { - $watchdog_thread->kill('KILL'); - undef $watchdog_thread; - } - elsif ($watchdog) { - kill('KILL', $watchdog); - undef $watchdog; - } - else { - alarm(0); - } - - return; + # Cancel any existing timer, so the caller can set multiple ones without + # cancelling first. For safety, handle the case where somehow more than + # one type of watchdog got set. + if ($watchdog_thread) { + $watchdog_thread->kill('KILL'); + undef $watchdog_thread; + } + if ($watchdog_process) { + kill('KILL', $watchdog_process); + undef $watchdog_process; + } + if ($watchdog_alarm) { + alarm(0); + undef $watchdog_alarm; } - # Make sure these aren't defined. - undef $watchdog; - undef $watchdog_thread; + # We are done if this call was just to cancel + return if $timeout == 0; my $method = shift || ""; @@ -1890,10 +1891,12 @@ ($;$) # shut up use only once warning my $threads_on = $threads::threads && $threads::threads; - # Don't use a watchdog process if 'threads' is loaded - - # use a watchdog thread instead - if (!$threads_on || $method eq "process") { - + # Use a watchdog process unless 'threads' is loaded and is killable by a + # signal + if ( ! $threads_on + || (defined $ENV{PERL_SIGNALS} && $ENV{PERL_SIGNALS} eq "unsafe") + || $method eq "process") + { # On Windows and VMS, try launching a watchdog process # using system(1, ...) (see perlport.pod). system() returns # immediately on these platforms with effectively a pid of the new @@ -1911,12 +1914,11 @@ ($;$) return if ($pid_to_kill <= 0); # Launch watchdog process - undef $watchdog; eval { local $SIG{'__WARN__'} = sub { - _diag("Watchdog warning: $_[0]"); - }; - my $sig = $is_vms ? 'TERM' : 'KILL'; + _diag("Watchdog warning: $_[0]"); + }; + my $sig = ($is_vms) ? 'TERM' : 'KILL'; my $prog = "sleep($timeout);" . "warn qq/# $timeout_msg" . '\n/;' . "kill(q/$sig/, $pid_to_kill);"; @@ -1938,38 +1940,29 @@ ($;$) if ($runperl =~ m/\s/) { $runperl = qq{"$runperl"}; } - $watchdog = system({ $runperl } 1, $runperl, '-e', $prog); + $watchdog_process = + system({ $runperl } 1, $runperl, '-e', $prog); } else { my $cmd = _create_runperl(prog => $prog); - $watchdog = system(1, $cmd); + $watchdog_process = system(1, $cmd); } }; - if ($@ || ($watchdog <= 0)) { - _diag('Failed to start watchdog'); - _diag($@) if $@; - undef($watchdog); - return; + + if ($@ || $watchdog_process <= 0) { + $@ = "\n$@" if $@; + _diag("Failed to start watchdog$@\nTrying alternate method"); + undef($watchdog_process); + goto WATCHDOG_VIA_ALARM; } - # 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 - undef $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; - } + eval { $watchdog_process = fork() }; + if (defined($watchdog_process)) { + return if $watchdog_process; # Parent process ### Watchdog process code @@ -2002,8 +1995,8 @@ ($;$) # fork() failed - fall through and try using a thread } - # Use a watchdog thread because either 'threads' is loaded, - # or fork() failed + # Use a watchdog thread because either 'threads' is loaded, or fork() + # failed if (eval {require threads; 1}) { $watchdog_thread = 'threads'->create(sub { # Load POSIX if available @@ -2042,7 +2035,7 @@ ($;$) return; } - # If everything above fails, then just use an alarm timeout + # If everything above fails, then just use an alarm timeout. WATCHDOG_VIA_ALARM: if (eval { alarm($timeout); 1; }) { # Load POSIX if available @@ -2050,12 +2043,13 @@ ($;$) # 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 = $is_vms ? 'TERM' : 'KILL'; - kill($sig, $pid_to_kill); - }; + select(STDERR); $| = 1; + _diag($timeout_msg); + POSIX::_exit(1) if (defined(&POSIX::_exit)); + my $sig = ($is_vms) ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); + }; + $watchdog_alarm = 1; } } } # End closure diff --git a/t/test_pl.pod b/t/test_pl.pod index 02660deac16b..1ee5e01dbff5 100644 --- a/t/test_pl.pod +++ b/t/test_pl.pod @@ -489,8 +489,8 @@ Note: currently only used by F itself. =item watchdog($timeout, $method); -Start a watchdog timer for C<$timeout> seconds. If C<$timeout> is -zero then disables any existing watchdog timer. +Start a watchdog timer for C<$timeout> seconds, while disabling any +existing one. If C<$timeout> is zero no new timer is created. The timeout may be scaled by setting C or C in the environment. If C