[RFC] common test code for timed bail out

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

The attached patch contains my proposal for addressing 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.

Here's the code to be added to test.pl:

# Forks a child process that kills the parent if the timeout is reached
sub timeout ($)
{
    my $timeout = shift;

    my $child_pid;
    eval { $child_pid = fork() };
    return if (! defined($child_pid));   # Fork failed

    # Child process
    if ($child_pid == 0) {
        my $ppid = getppid();
        exit(0) if (! $ppid);   # Failed getting parent PID

        sleep($timeout - 2) if ($timeout > 2);   # Workaround for perlbug #49073
        sleep(2);

        # Kill parent if it still exists
        if (kill(0, $ppid)) {
            _diag("Test process (PID=$$) timed out");
            kill('KILL', $ppid);
        }
        exit(0);
    }

    # Add END block to parent to clean up child process
    eval "END { kill('KILL', $child_pid) if (kill(0, $child_pid)); }";
}

Also, please comment on which core test files should be
patched to use this (if and when it is incorporated).
diff -urN perl-current/pod/perltodo.pod perl-patch/pod/perltodo.pod
--- perl-current/pod/perltodo.pod	2008-06-26 11:25:15.183368500 -0400
+++ perl-patch/pod/perltodo.pod	2008-06-26 11:23:59.092902200 -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.951636300 -0400
+++ perl-patch/t/test.pl	2008-06-26 11:22:19.006713700 -0400
@@ -781,4 +781,33 @@
     _ok( !$diag, _where(), $name );
 }
 
+# Forks a child process that kills the parent if the timeout is reached
+sub timeout ($)
+{
+    my $timeout = shift;
+
+    my $child_pid;
+    eval { $child_pid = fork() };
+    return if (! defined($child_pid));   # Fork failed
+
+    # Child process
+    if ($child_pid == 0) {
+        my $ppid = getppid();
+        exit(0) if (! $ppid);   # Failed getting parent PID
+
+        sleep($timeout - 2) if ($timeout > 2);   # Workaround for perlbug #49073
+        sleep(2);
+
+        # Kill parent if it still exists
+        if (kill(0, $ppid)) {
+            _diag("Test process (PID=$$) timed out");
+            kill('KILL', $ppid);
+        }
+        exit(0);
+    }
+
+    # Add END block to parent to clean up child process
+    eval "END { kill('KILL', $child_pid) if (kill(0, $child_pid)); }";
+}
+
 1;

---

Follow-Ups from:

"Dintelmann, Peter" <Peter.Dintelmann@Dresdner-Bank.com>
Nicholas Clark <nick@ccl4.org>

---

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

---