[PATCH-revised^6] common test code for timed bail

["Jerry D. Hedden" <jdhedden@cpan.org>]

The attached patch addresses the following Perl TODO:

=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.

(Typo correction)
diff -urN perl-current/pod/perltodo.pod perl-patch/pod/perltodo.pod
--- perl-current/pod/perltodo.pod	2008-06-26 11:25:15.000000000 -0400
+++ perl-patch/pod/perltodo.pod	2008-06-26 11:23:59.000000000 -0400
@@ -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
diff -urN perl-current/t/test.pl perl-patch/t/test.pl
--- perl-current/t/test.pl	2008-06-26 11:25:23.000000000 -0400
+++ perl-patch/t/test.pl	2008-06-28 15:17:15.768875000 -0400
@@ -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;

---

Follow-Ups from:

"Rafael Garcia-Suarez" <rgarciasuarez@gmail.com>

---

[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]

---