From bb4d040fadcb76a8828eaf24b4f0557ec11f44fb Mon Sep 17 00:00:00 2001
From: Paul Smith <psmith@gnu.org>
Date: Sat, 14 Jul 2007 02:57:46 +0000
Subject: Fix Savannah bug #20452.

Add a new feature to the test suite suggested by Icarus Sparry:
set a timer before invoking a test, so that if it loops infinitely we
will wake up and have a chance to kill the process and continue.
---
 tests/test_driver.pl | 54 +++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 37 insertions(+), 17 deletions(-)

(limited to 'tests/test_driver.pl')

diff --git a/tests/test_driver.pl b/tests/test_driver.pl
index 68007ec..bea9816 100644
--- a/tests/test_driver.pl
+++ b/tests/test_driver.pl
@@ -50,6 +50,10 @@ $tests_passed = 0;
 $test_passed = 1;
 
 
+# Timeout in seconds.  If the test takes longer than this we'll fail it.
+$test_timeout = 5;
+
+
 # %makeENV is the cleaned-out environment.
 %makeENV = ();
 
@@ -766,21 +770,43 @@ sub detach_default_output
          || &error ("ddo: $! closing SAVEDOSerr\n", 1);
 }
 
-# run one command (passed as a list of arg 0 - n), returning 0 on success
-# and nonzero on failure.
-
-sub run_command
+# This runs a command without any debugging info.
+sub _run_command
 {
-  local ($code);
+  my $code;
 
   # We reset this before every invocation.  On Windows I think there is only
   # one environment, not one per process, so I think that variables set in
   # test scripts might leak into subsequent tests if this isn't reset--???
   resetENV();
 
+  eval {
+      local $SIG{ALRM} = sub { die "timeout\n"; };
+      alarm $test_timeout;
+      $code = system @_;
+      alarm 0;
+  };
+  if ($@) {
+      # The eval failed.  If it wasn't SIGALRM then die.
+      $@ eq "timeout\n" or die;
+
+      # Timed out.  Resend the alarm to our process group to kill the children.
+      $SIG{ALRM} = 'IGNORE';
+      kill -14, $$;
+      $code = 14;
+  }
+
+  return $code;
+}
+
+# run one command (passed as a list of arg 0 - n), returning 0 on success
+# and nonzero on failure.
+
+sub run_command
+{
   print "\nrun_command: @_\n" if $debug;
-  $code = system @_;
-  print "run_command: \"@_\" returned $code.\n" if $debug;
+  my $code = _run_command(@_);
+  print "run_command returned $code.\n" if $debug;
 
   return $code;
 }
@@ -792,19 +818,13 @@ sub run_command
 
 sub run_command_with_output
 {
-  local ($filename) = shift;
-  local ($code);
-
-  # We reset this before every invocation.  On Windows I think there is only
-  # one environment, not one per process, so I think that variables set in
-  # test scripts might leak into subsequent tests if this isn't reset--???
-  resetENV();
+  my $filename = shift;
 
+  print "\nrun_command_with_output($filename): @_\n" if $debug;
   &attach_default_output ($filename);
-  $code = system @_;
+  my $code = _run_command(@_);
   &detach_default_output;
-
-  print "run_command_with_output: '@_' returned $code.\n" if $debug;
+  print "run_command_with_output returned $code.\n" if $debug;
 
   return $code;
 }
-- 
cgit v1.2.3