Commit 1b1f18b8 authored by Duncan Coutts's avatar Duncan Coutts Committed by Herbert Valerio Riedel
Browse files

Add tests for the delegated control-C handling (#2301)


Authored-by: Duncan Coutts's avatarDuncan Coutts <duncan@well-typed.com>
Signed-off-by: Herbert Valerio Riedel's avatarHerbert Valerio Riedel <hvr@gnu.org>
parent a0467f3e
......@@ -32,5 +32,6 @@ test('T4889', normal, compile_and_run, [''])
test('process009', when(opsys('mingw32'), skip), compile_and_run, [''])
test('process010', normal, compile_and_run, [''])
test('process011', when(opsys('mingw32'), skip), compile_and_run, [''])
test('T8343', normal, compile_and_run, [''])
import System.Process
import System.IO
import Control.Exception
import Control.Concurrent
import Data.List
-- Test control-C delegation (#2301)
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
putStrLn "===================== test 1"
-- shell kills itself with SIGINT,
-- delegation off, exit code (death by signal) reported as normal
do let script = intercalate "; "
[ "kill -INT $$"
, "exit 42" ]
(_,_,_,p) <- createProcess (shell script) { delegate_ctlc = False }
waitForProcess p >>= print
putStrLn "===================== test 2"
-- shell kills itself with SIGINT,
-- delegation on, so expect to throw UserInterrupt
do let script = intercalate "; "
[ "kill -INT $$"
, "exit 42" ]
(_,_,_,p) <- createProcess (shell script) { delegate_ctlc = True }
(waitForProcess p >>= print)
`catchUserInterrupt` \e -> putStrLn $ "caught: " ++ show e
putStrLn "===================== test 3"
-- shell sends itself SIGINT but traps it,
-- delegation on, but the shell terminates normally so just normal exit code
do let script = intercalate "; "
[ "trap 'echo shell trapped SIGINT' INT"
, "kill -INT $$"
, "exit 42" ]
(_,_,_,p) <- createProcess (shell script) { delegate_ctlc = True }
waitForProcess p >>= print
putStrLn "===================== test 4"
-- shell sends us SIGINT.
-- delegation on, so we should not get the SIGINT ourselves
-- shell terminates normally so just normal exit code
do let script = intercalate "; "
[ "kill -INT $PPID"
, "kill -INT $PPID"
, "exit 42" ]
(_,_,_,p) <- createProcess (shell script) { delegate_ctlc = True }
waitForProcess p >>= print
putStrLn "===================== test 5"
-- shell sends us SIGINT.
-- delegation off, so we should get the SIGINT ourselves (async)
do let script = intercalate "; "
[ "kill -INT $PPID"
, "exit 42" ]
(_,_,_,p) <- createProcess (shell script) { delegate_ctlc = False }
exit <- waitForProcess p
-- need to allow for the async exception to arrive
threadDelay 1000000
-- we should never make it to here...
putStrLn "never caught interrupt"
print exit
`catchUserInterrupt` \e -> putStrLn $ "caught: " ++ show e
putStrLn "===================== done"
catchUserInterrupt :: IO a -> (AsyncException -> IO a) -> IO a
catchUserInterrupt =
catchJust (\e -> case e of UserInterrupt -> Just e; _ -> Nothing)
===================== test 1
ExitFailure (-2)
===================== test 2
caught: user interrupt
===================== test 3
shell trapped SIGINT
ExitFailure 42
===================== test 4
ExitFailure 42
===================== test 5
caught: user interrupt
===================== done
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