Change 34091 by [EMAIL PROTECTED] on 2008/06/28 20:37:32
Subject: [PATCH-revised^6] common test code for timed bail
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Sat, 28 Jun 2008 15:18:48 -0400
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/pod/perltodo.pod#232 edit
... //depot/perl/t/test.pl#79 edit
Differences ...
==== //depot/perl/pod/perltodo.pod#232 (text) ====
Index: perl/pod/perltodo.pod
--- perl/pod/perltodo.pod#231~33896~ 2008-05-21 02:18:00.000000000 -0700
+++ perl/pod/perltodo.pod 2008-06-28 13:37:32.000000000 -0700
@@ -30,12 +30,6 @@
into a file, change it to build an C<%Is> hash and require it. Maybe just put
it into F<test.pl>. Throw in the handy tainting subroutines.
-=head2 common test code for timed bail out
-
-Write portable self destruct code for tests to stop them burning CPU in
-infinite loops. This needs to avoid using alarm, as some of the tests are
-testing alarm/sleep or timers.
-
=head2 POD -E<gt> HTML conversion in the core still sucks
Which is crazy given just how simple POD purports to be, and how simple HTML
==== //depot/perl/t/test.pl#79 (text) ====
Index: perl/t/test.pl
--- perl/t/test.pl#78~32801~ 2008-01-02 04:01:29.000000000 -0800
+++ perl/t/test.pl 2008-06-28 13:37:32.000000000 -0700
@@ -781,4 +781,106 @@
_ok( !$diag, _where(), $name );
}
+# Set a watchdog to timeout the entire test file
+sub watchdog ($)
+{
+ my $timeout = shift;
+ my $timeout_msg = 'Test process timed out - terminating';
+
+ 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();
+ }
+ }
+
+ # 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 the above worked, add END block to parent
+ # to clean up watchdog process
+ if (! $@ && ($watchdog > 0)) {
+ eval "END { 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 clean up watchdog process
+ eval "END { 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);
+ }
+
+ # Terminate ourself (i.e., the watchdog)
+ POSIX::_exit(1) if (defined(&POSIX::_exit));
+ exit(1);
+ }
+
+ # fork() failed - try a thread
+ if (eval { require threads; }) {
+ threads->create(sub {
+ # Load POSIX if available
+ eval { require POSIX; };
+
+ # Execute the timeout
+ sleep($timeout);
+
+ # Kill the parent (and ourself)
+ _diag($timeout_msg);
+ POSIX::_exit(1) if (defined(&POSIX::_exit));
+ kill('KILL', $pid_to_kill);
+ })->detach();
+ return;
+ }
+
+ # Threads failed, too - try use alarm()
+
+ # Try to set the timeout
+ if (eval { alarm($timeout); 1; }) {
+ # Load POSIX if available
+ eval { require POSIX; };
+
+ # Alarm handler will do the actual 'killing'
+ $SIG{'ALRM'} = sub {
+ _diag($timeout_msg);
+ POSIX::_exit(1) if (defined(&POSIX::_exit));
+ kill('KILL', $pid_to_kill);
+ };
+ }
+}
+
1;
End of Patch.
