Commit 545656e4 authored by simonmar's avatar simonmar
Browse files

[project @ 2005-11-23 11:47:16 by simonmar]

Fix up to compile after recent changes to System.Process.Internals
parent cf037888
...@@ -11,7 +11,7 @@ import System.IO (hPutStrLn, stderr) ...@@ -11,7 +11,7 @@ import System.IO (hPutStrLn, stderr)
import System.Process import System.Process
import Control.Monad (when) import Control.Monad (when)
#if !defined(mingw32_HOST_OS) #if !defined(mingw32_HOST_OS)
import System.Process.Internals (ProcessHandle(ProcessHandle)) import System.Process.Internals (mkProcessHandle)
import System.Posix.Process (forkProcess, createSession) import System.Posix.Process (forkProcess, createSession)
import System.Posix.Signals (installHandler, Handler(Catch), import System.Posix.Signals (installHandler, Handler(Catch),
signalProcessGroup, sigINT, sigTERM, sigKILL ) signalProcessGroup, sigINT, sigTERM, sigKILL )
...@@ -30,36 +30,37 @@ main = do ...@@ -30,36 +30,37 @@ main = do
forkIO (do threadDelay (read secs * 1000000) forkIO (do threadDelay (read secs * 1000000)
putMVar m Nothing putMVar m Nothing
) )
forkIO (do try (do p <- forkProcess $ do forkIO (do try (do pid <- forkProcess $ do
createSession createSession
r <- system cmd r <- system cmd
exitWith r exitWith r
putMVar mp p ph <- mkProcessHandle pid
r <- waitForProcess (ProcessHandle p) putMVar mp (pid,ph)
r <- waitForProcess ph
putMVar m (Just r)) putMVar m (Just r))
return ()) return ())
p <- takeMVar mp (pid,ph) <- takeMVar mp
r <- takeMVar m r <- takeMVar m
case r of case r of
Nothing -> do Nothing -> do
killProcess p killProcess pid ph
exitWith (ExitFailure 99) exitWith (ExitFailure 99)
Just r -> do Just r -> do
exitWith r exitWith r
_other -> do hPutStrLn stderr "timeout: bad arguments" _other -> do hPutStrLn stderr "timeout: bad arguments"
exitWith (ExitFailure 1) exitWith (ExitFailure 1)
killProcess p = do killProcess pid ph = do
try (signalProcessGroup sigTERM p) try (signalProcessGroup sigTERM pid)
checkReallyDead 10 checkReallyDead 10
where where
checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up" checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"
checkReallyDead (n+1) = checkReallyDead (n+1) =
do threadDelay (3*100000) -- 3/10 sec do threadDelay (3*100000) -- 3/10 sec
m <- getProcessExitCode (ProcessHandle p) m <- getProcessExitCode ph
when (isNothing m) $ do when (isNothing m) $ do
try (signalProcessGroup sigKILL p) try (signalProcessGroup sigKILL pid)
checkReallyDead n checkReallyDead n
#else #else
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment