diff options
Diffstat (limited to 'testsuite/timeout')
| -rw-r--r-- | testsuite/timeout/WinCBindings.hsc | 3 | ||||
| -rw-r--r-- | testsuite/timeout/timeout.hs | 55 |
2 files changed, 32 insertions, 26 deletions
diff --git a/testsuite/timeout/WinCBindings.hsc b/testsuite/timeout/WinCBindings.hsc index a72cdcfafb..36379301a4 100644 --- a/testsuite/timeout/WinCBindings.hsc +++ b/testsuite/timeout/WinCBindings.hsc @@ -260,9 +260,6 @@ type JOBOBJECTINFOCLASS = CInt type PVOID = Ptr () type PULONG_PTR = Ptr ULONG_PTR -#if !MIN_VERSION_Win32(2,5,0) -type ULONG_PTR = CUIntPtr -#endif jobObjectExtendedLimitInformation :: JOBOBJECTINFOCLASS jobObjectExtendedLimitInformation = #const JobObjectExtendedLimitInformation diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs index f72efe30ae..9f3044f36d 100644 --- a/testsuite/timeout/timeout.hs +++ b/testsuite/timeout/timeout.hs @@ -1,4 +1,5 @@ {-# OPTIONS -cpp #-} +{-# LANGUAGE LambdaCase #-} module Main where import Control.Concurrent (forkIO, threadDelay) @@ -21,6 +22,7 @@ import WinCBindings import Foreign import System.Win32.DebugApi import System.Win32.Types +import System.Win32.Console.CtrlHandler #endif main :: IO () @@ -129,28 +131,35 @@ run secs cmd = let handleInterrupt action = action `onException` terminateJobObject job 99 - - handleInterrupt $ do - resumeThread (piThread pi) - -- The program is now running - let handle = piProcess pi - let millisecs = secs * 1000 - rc <- waitForJobCompletion job ioPort (fromIntegral millisecs) - closeHandle ioPort - - if not rc - then do terminateJobObject job 99 - closeHandle job - exitWith (ExitFailure 99) - else alloca $ \p_exitCode -> - do terminateJobObject job 0 -- Ensure it's all really dead. - closeHandle job - r <- getExitCodeProcess handle p_exitCode - if r then do ec <- peek p_exitCode - let ec' = if ec == 0 - then ExitSuccess - else ExitFailure $ fromIntegral ec - exitWith ec' - else errorWin "getExitCodeProcess" + handleCtrl _ = do + terminateJobObject job 99 + closeHandle ioPort + closeHandle job + exitWith (ExitFailure 99) + return True + + withConsoleCtrlHandler handleCtrl $ + handleInterrupt $ do + resumeThread (piThread pi) + -- The program is now running + let handle = piProcess pi + let millisecs = secs * 1000 + rc <- waitForJobCompletion job ioPort (fromIntegral millisecs) + closeHandle ioPort + + if not rc + then do terminateJobObject job 99 + closeHandle job + exitWith (ExitFailure 99) + else alloca $ \p_exitCode -> + do terminateJobObject job 0 + -- Ensured it's all really dead. + closeHandle job + r <- getExitCodeProcess handle p_exitCode + if r + then peek p_exitCode >>= \case + 0 -> exitWith ExitSuccess + e -> exitWith $ ExitFailure (fromIntegral e) + else errorWin "getExitCodeProcess" #endif |