diff --git a/t/io/closepid.t b/t/io/closepid.t index cdc6d256e44a..c05ef8c12f06 100644 --- a/t/io/closepid.t +++ b/t/io/closepid.t @@ -42,5 +42,3 @@ SKIP: kill $killsig, $pid; open STDIN, "<&", $savein; } - -watchdog(0); diff --git a/t/io/openpid.t b/t/io/openpid.t index 5b92ab01de71..0f6f9d47dcab 100644 --- a/t/io/openpid.t +++ b/t/io/openpid.t @@ -101,5 +101,3 @@ next_test(); print "# waiting for process $pid4 to exit\n"; $reap_pid = waitpid $pid4, 0; is( $reap_pid, $pid4, 'fourth process reaped' ); - -watchdog(0); diff --git a/t/op/sigdispatch.t b/t/op/sigdispatch.t index 30fdb26ae47c..242fb8ec5846 100644 --- a/t/op/sigdispatch.t +++ b/t/op/sigdispatch.t @@ -167,5 +167,3 @@ like $@, qr/No such hook: __DIE__\\0whoops at/; is($int_called, 1); is($@, "died"); } - -watchdog(0); diff --git a/t/op/signame_canonical.t b/t/op/signame_canonical.t index 009817887a34..49fb13762c4e 100644 --- a/t/op/signame_canonical.t +++ b/t/op/signame_canonical.t @@ -72,6 +72,3 @@ foreach my $dupe (@duplicate_signals) { is( $SIG{$dupe}, undef, "The signal $dupe is cleared after local goes out of scope." ); is( $SIG{$canonical_name}, undef, "The signal $canonical_name is cleared after local goes out of scope." ); } - -watchdog(0); - diff --git a/t/op/study.t b/t/op/study.t index 8f7b63002396..c84724962f95 100644 --- a/t/op/study.t +++ b/t/op/study.t @@ -158,5 +158,3 @@ TODO: { push @got, $_ foreach $a =~ /[^x]d(?{$a .= ''})[^x]d/g; is("@got", 'ydyd ydyd', '#92696 $a .= \'\' inside (?{}), $a studied'); } - -watchdog(0); diff --git a/t/op/time.t b/t/op/time.t index d9e06d40dd3b..9fdc7b8cf6ab 100644 --- a/t/op/time.t +++ b/t/op/time.t @@ -248,5 +248,3 @@ SKIP: { is scalar gmtime("NaN"), undef, '[perl #123495] gmtime(NaN)'; is scalar localtime("NaN"), undef, 'localtime(NaN)'; } - -watchdog(0); diff --git a/t/op/time_loop.t b/t/op/time_loop.t index 710b01ee9179..6f4acdc1f952 100644 --- a/t/op/time_loop.t +++ b/t/op/time_loop.t @@ -14,5 +14,3 @@ watchdog(2); local $SIG{__WARN__} = sub {}; is gmtime(2**69), undef; is localtime(2**69), undef; - -watchdog(0); diff --git a/t/op/waitpid.t b/t/op/waitpid.t index d3b8806d6390..497fc26cb688 100644 --- a/t/op/waitpid.t +++ b/t/op/waitpid.t @@ -35,6 +35,5 @@ watchdog(10); pass("didn't block on waitpid(0, ...)"); } -watchdog(0); done_testing(); diff --git a/t/perf/speed.t b/t/perf/speed.t index 7df4b4e9a96f..bab29d441a44 100644 --- a/t/perf/speed.t +++ b/t/perf/speed.t @@ -42,6 +42,4 @@ SKIP: { pass("COW 1Mb strings"); } -watchdog(0); - 1; diff --git a/t/perf/taint.t b/t/perf/taint.t index d69f1746f7a3..275611897f58 100644 --- a/t/perf/taint.t +++ b/t/perf/taint.t @@ -61,6 +61,4 @@ my $taint = substr($ENV{PATH}, 0, 0); # and empty tainted string pass("RT #130584 pos on tainted utf8 string"); } -watchdog(0); - 1; diff --git a/t/re/fold_grind.pl b/t/re/fold_grind.pl index 7e00dfee36b8..2922b25dc57c 100644 --- a/t/re/fold_grind.pl +++ b/t/re/fold_grind.pl @@ -1101,7 +1101,6 @@ (@) } } -watchdog(0); plan($count); 1 diff --git a/t/test.pl b/t/test.pl index e498038cd618..0dae2e9d0117 100644 --- a/t/test.pl +++ b/t/test.pl @@ -38,6 +38,7 @@ our $TODO = 0; our $NO_ENDING = 0; our $Tests_Are_Passing = 1; +our @watchdog_threads_; # Use this instead of print to avoid interference while testing globals. sub _print { @@ -1834,8 +1835,7 @@ 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_thread; + my $cancel_string; sub watchdog ($;$) { @@ -1844,29 +1844,18 @@ ($;$) # 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); - } - + eval $cancel_string if defined $cancel_string; return; } - # Make sure these aren't defined. - undef $watchdog; - undef $watchdog_thread; - my $method = shift || ""; my $timeout_msg = 'Test process timed out - terminating'; + # Common to all cancellation types; HERE gets replaced below by the + # individual code + $cancel_string = 'local $! = 0; local $? = 0; HERE; undef $cancel_string'; + # Accept either spelling my $timeout_factor = $ENV{PERL_TEST_TIME_OUT_FACTOR} || $ENV{PERL_TEST_TIMEOUT_FACTOR} @@ -1888,9 +1877,13 @@ ($;$) # 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") + { + my $watchdog; # On Windows and VMS, try launching a watchdog process # using system(1, ...) (see perlport.pod). system() returns @@ -1909,7 +1902,6 @@ ($;$) return if ($pid_to_kill <= 0); # Launch watchdog process - undef $watchdog; eval { local $SIG{'__WARN__'} = sub { _diag("Watchdog warning: $_[0]"); @@ -1950,22 +1942,21 @@ ($;$) return; } - # Add END block to parent to terminate and - # clean up watchdog process - eval("END { local \$! = 0; local \$? = 0; - wait() if kill('KILL', $watchdog); };"); + # Add END block to parent to terminate and clean up watchdog + # process + $cancel_string =~ s/HERE/wait() if kill('KILL', $watchdog)/; + eval("END { $cancel_string };"); 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); };"; + # Add END block to parent to terminate and clean up watchdog + # process + $cancel_string =~ s/HERE/wait() if kill('KILL', $watchdog)/; + eval("END { $cancel_string };"); return; } @@ -2000,10 +1991,12 @@ ($;$) # 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 { + + # Use an array so can handle multiple timers + push @watchdog_threads_, 'threads'->create(sub { # Load POSIX if available eval { require POSIX; }; @@ -2027,12 +2020,16 @@ ($;$) kill($sig, $pid_to_kill); }); + #my $index = scalar @watchd + $cancel_string =~ s/HERE/\$watchdog_threads_[$#watchdog_threads_]->kill('KILL')/; + eval "END { $cancel_string }"; + # Don't proceed until the watchdog has set up its signal handler. # (Otherwise there is a possibility that we will exit with threads # running.) The watchdog tells us that the handler is set by # detaching itself. (The 'is_running()' is a fail-safe.) - while ( $watchdog_thread->is_running() - && ! $watchdog_thread->is_detached()) + while ( $watchdog_threads_[-1]->is_running() + && ! $watchdog_threads_[-1]->is_detached()) { 'threads'->yield(); } @@ -2040,7 +2037,8 @@ ($;$) return; } - # If everything above fails, then just use an alarm timeout + # If everything above fails, then just use an alarm timeout. There can + # only be one in effect at a time. This cancels any previous one. WATCHDOG_VIA_ALARM: if (eval { alarm($timeout); 1; }) { # Load POSIX if available @@ -2054,6 +2052,9 @@ ($;$) my $sig = $is_vms ? 'TERM' : 'KILL'; kill($sig, $pid_to_kill); }; + + $cancel_string =~ s/HERE/alarm(0)/; + eval "END { $cancel_string }"; } } } # End closure diff --git a/t/win32/popen.t b/t/win32/popen.t index a0c72a9eceac..07ac390a51bb 100644 --- a/t/win32/popen.t +++ b/t/win32/popen.t @@ -24,6 +24,4 @@ for(1..100) { } PERL -watchdog(0); - done_testing();