[project @ 2005-11-11 12:02:40 by simonmar]

Make it work on Windows again.

1 files changed, 34 insertions, 5 deletions

diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs
index 904ea93506..3ac9dfb463 100644
--- a/testsuite/timeout/timeout.hs
+++ b/testsuite/timeout/timeout.hs
@@ -8,24 +8,25 @@ import System.Cmd (system)
 import System.Environment (getArgs)

 import System.Exit (exitWith, ExitCode(ExitFailure))

 import System.IO (hPutStrLn, stderr)

-import System.Process (waitForProcess, getProcessExitCode)

-#if !defined(mingw32_HOST_OS)

+import System.Process

 import Control.Monad (when)

+#if !defined(mingw32_HOST_OS)

 import System.Process.Internals (ProcessHandle(ProcessHandle))

 import System.Posix.Process (forkProcess, createSession)

 import System.Posix.Signals (installHandler, Handler(Catch),

                              signalProcessGroup, sigINT, sigTERM, sigKILL )

 #endif

 

+

+

+#if !defined(mingw32_HOST_OS)

 main = do

   args <- getArgs

   case args of 

     [secs,cmd] -> do

         m <- newEmptyMVar

         mp <- newEmptyMVar

-#if !defined(mingw32_HOST_OS)

         installHandler sigINT (Catch (putMVar m Nothing)) Nothing

-#endif

         forkIO (do threadDelay (read secs * 1000000)

                    putMVar m Nothing

                )

@@ -37,6 +38,7 @@ main = do
                            r <- waitForProcess (ProcessHandle p)

                            putMVar m (Just r))

                    return ())

+

         p <- takeMVar mp

         r <- takeMVar m

         case r of

@@ -48,7 +50,6 @@ main = do
     _other -> do hPutStrLn stderr "timeout: bad arguments"

                  exitWith (ExitFailure 1)

 

-#if !defined(mingw32_HOST_OS)

 killProcess p = do

   try (signalProcessGroup sigTERM p)

   checkReallyDead 10

@@ -60,10 +61,38 @@ killProcess p = do
          when (isNothing m) $ do

              try (signalProcessGroup sigKILL p)

              checkReallyDead n

+

 #else

+

+main = do

+  args <- getArgs

+  case args of 

+    [secs,cmd] -> do

+        m <- newEmptyMVar

+        mp <- newEmptyMVar

+        forkIO (do threadDelay (read secs * 1000000)

+                   putMVar m Nothing

+               )

+        forkIO (do p <- runCommand cmd

+		   putMVar mp p

+		   r <- waitForProcess p

+		   putMVar m (Just r))

+	p <- takeMVar mp

+        r <- takeMVar m

+        case r of

+          Nothing -> do

+                killProcess p

+                exitWith (ExitFailure 99)

+          Just r -> do

+                exitWith r

+    _other -> do hPutStrLn stderr "timeout: bad arguments"

+                 exitWith (ExitFailure 1)

+

 killProcess p = do

   terminateProcess p

+  -- ToDo: we should kill the process and its descendents on Win32

   threadDelay (3*100000) -- 3/10 sec

   m <- getProcessExitCode p

   when (isNothing m) $ killProcess p

+

 #endif