From ffeb000dd89964bd89ca0607345472f53c79159d Mon Sep 17 00:00:00 2001
From: David Binder <david.binder@uni-tuebingen.de>
Date: Mon, 27 Nov 2023 21:05:49 +0100
Subject: [PATCH] Add tests from libraries/process/tests and
libraries/Win32/tests to GHC
These tests were previously part of the libraries, which themselves are
submodules of the GHC repository. This commit moves the tests directly
to the GHC repository.
---
testsuite/tests/Win32/HandleConversion.hs | 16 +++
testsuite/tests/Win32/HandleConversion.stdout | 3 +
testsuite/tests/Win32/Makefile | 7 ++
testsuite/tests/Win32/PokeTZI.hs | 13 +++
testsuite/tests/Win32/Semaphores.hs | 60 ++++++++++
testsuite/tests/Win32/Semaphores.stdout | 19 ++++
testsuite/tests/Win32/T4452.hs | 13 +++
testsuite/tests/Win32/all.T | 12 ++
testsuite/tests/Win32/helloworld.hs | 104 ++++++++++++++++++
testsuite/tests/Win32/lasterror.hs | 16 +++
testsuite/tests/Win32/registry001.hs | 16 +++
testsuite/tests/Win32/registry001.stdout | 1 +
testsuite/tests/process/.gitignore | 31 ++++++
testsuite/tests/process/Makefile | 15 +++
testsuite/tests/process/T1780.hs | 19 ++++
testsuite/tests/process/T1780.stdout | 1 +
testsuite/tests/process/T3231.hs | 22 ++++
testsuite/tests/process/T3231.stdout | 1 +
testsuite/tests/process/T3994.hs | 22 ++++
testsuite/tests/process/T3994.stdout | 2 +
testsuite/tests/process/T3994app.hs | 10 ++
testsuite/tests/process/T4198.hs | 3 +
testsuite/tests/process/T4198.stdout | 1 +
testsuite/tests/process/T4198.stdout-mingw32 | 1 +
testsuite/tests/process/T4889.hs | 10 ++
testsuite/tests/process/T4889.stdout | 2 +
testsuite/tests/process/T8343.hs | 8 ++
testsuite/tests/process/T8343.stdout | 2 +
testsuite/tests/process/T9775/Makefile | 12 ++
testsuite/tests/process/T9775/T9775_fail.hs | 7 ++
.../tests/process/T9775/T9775_fail.stdout | 2 +
testsuite/tests/process/T9775/T9775_good.hs | 7 ++
.../tests/process/T9775/T9775_good.stdout | 2 +
testsuite/tests/process/T9775/all.T | 14 +++
testsuite/tests/process/T9775/main.c | 6 +
testsuite/tests/process/T9775/ok.c | 8 ++
testsuite/tests/process/all.T | 53 +++++++++
testsuite/tests/process/exitminus1.c | 1 +
testsuite/tests/process/process001.hs | 10 ++
testsuite/tests/process/process002.hs | 9 ++
testsuite/tests/process/process003.hs | 24 ++++
testsuite/tests/process/process003.stdout | 4 +
testsuite/tests/process/process004.hs | 23 ++++
testsuite/tests/process/process004.stdout | 2 +
...process004.stdout-javascript-unknown-ghcjs | 2 +
.../tests/process/process004.stdout-mingw32 | 2 +
testsuite/tests/process/process005.hs | 26 +++++
testsuite/tests/process/process005.stdin | 3 +
testsuite/tests/process/process005.stdout | 4 +
testsuite/tests/process/process006.hs | 15 +++
testsuite/tests/process/process006.stderr | 1 +
testsuite/tests/process/process006.stdout | 4 +
testsuite/tests/process/process007.hs | 24 ++++
testsuite/tests/process/process007.stdout | 2 +
testsuite/tests/process/process007_fd.c | 41 +++++++
testsuite/tests/process/process008.hs | 9 ++
testsuite/tests/process/process008.stdout | 2 +
testsuite/tests/process/process009.hs | 24 ++++
testsuite/tests/process/process009.stdout | 3 +
testsuite/tests/process/process010.hs | 13 +++
testsuite/tests/process/process010.stdout | 4 +
.../process010.stdout-i386-unknown-solaris2 | 4 +
...process010.stdout-javascript-unknown-ghcjs | 4 +
.../tests/process/process010.stdout-mingw32 | 4 +
testsuite/tests/process/process011.hs | 73 ++++++++++++
testsuite/tests/process/process011.stdout | 12 ++
testsuite/tests/process/process011_c.c | 9 ++
testsuite/tests/process/processT251.hs | 39 +++++++
testsuite/tests/process/processT251.stdout | 6 +
69 files changed, 944 insertions(+)
create mode 100644 testsuite/tests/Win32/HandleConversion.hs
create mode 100644 testsuite/tests/Win32/HandleConversion.stdout
create mode 100644 testsuite/tests/Win32/Makefile
create mode 100644 testsuite/tests/Win32/PokeTZI.hs
create mode 100644 testsuite/tests/Win32/Semaphores.hs
create mode 100644 testsuite/tests/Win32/Semaphores.stdout
create mode 100644 testsuite/tests/Win32/T4452.hs
create mode 100644 testsuite/tests/Win32/all.T
create mode 100644 testsuite/tests/Win32/helloworld.hs
create mode 100644 testsuite/tests/Win32/lasterror.hs
create mode 100644 testsuite/tests/Win32/registry001.hs
create mode 100644 testsuite/tests/Win32/registry001.stdout
create mode 100644 testsuite/tests/process/.gitignore
create mode 100644 testsuite/tests/process/Makefile
create mode 100644 testsuite/tests/process/T1780.hs
create mode 100644 testsuite/tests/process/T1780.stdout
create mode 100644 testsuite/tests/process/T3231.hs
create mode 100644 testsuite/tests/process/T3231.stdout
create mode 100644 testsuite/tests/process/T3994.hs
create mode 100644 testsuite/tests/process/T3994.stdout
create mode 100644 testsuite/tests/process/T3994app.hs
create mode 100644 testsuite/tests/process/T4198.hs
create mode 100644 testsuite/tests/process/T4198.stdout
create mode 100644 testsuite/tests/process/T4198.stdout-mingw32
create mode 100644 testsuite/tests/process/T4889.hs
create mode 100644 testsuite/tests/process/T4889.stdout
create mode 100644 testsuite/tests/process/T8343.hs
create mode 100644 testsuite/tests/process/T8343.stdout
create mode 100644 testsuite/tests/process/T9775/Makefile
create mode 100644 testsuite/tests/process/T9775/T9775_fail.hs
create mode 100644 testsuite/tests/process/T9775/T9775_fail.stdout
create mode 100644 testsuite/tests/process/T9775/T9775_good.hs
create mode 100644 testsuite/tests/process/T9775/T9775_good.stdout
create mode 100644 testsuite/tests/process/T9775/all.T
create mode 100644 testsuite/tests/process/T9775/main.c
create mode 100644 testsuite/tests/process/T9775/ok.c
create mode 100644 testsuite/tests/process/all.T
create mode 100644 testsuite/tests/process/exitminus1.c
create mode 100644 testsuite/tests/process/process001.hs
create mode 100644 testsuite/tests/process/process002.hs
create mode 100644 testsuite/tests/process/process003.hs
create mode 100644 testsuite/tests/process/process003.stdout
create mode 100644 testsuite/tests/process/process004.hs
create mode 100644 testsuite/tests/process/process004.stdout
create mode 100644 testsuite/tests/process/process004.stdout-javascript-unknown-ghcjs
create mode 100644 testsuite/tests/process/process004.stdout-mingw32
create mode 100644 testsuite/tests/process/process005.hs
create mode 100644 testsuite/tests/process/process005.stdin
create mode 100644 testsuite/tests/process/process005.stdout
create mode 100644 testsuite/tests/process/process006.hs
create mode 100644 testsuite/tests/process/process006.stderr
create mode 100644 testsuite/tests/process/process006.stdout
create mode 100644 testsuite/tests/process/process007.hs
create mode 100644 testsuite/tests/process/process007.stdout
create mode 100644 testsuite/tests/process/process007_fd.c
create mode 100644 testsuite/tests/process/process008.hs
create mode 100644 testsuite/tests/process/process008.stdout
create mode 100644 testsuite/tests/process/process009.hs
create mode 100644 testsuite/tests/process/process009.stdout
create mode 100644 testsuite/tests/process/process010.hs
create mode 100644 testsuite/tests/process/process010.stdout
create mode 100644 testsuite/tests/process/process010.stdout-i386-unknown-solaris2
create mode 100644 testsuite/tests/process/process010.stdout-javascript-unknown-ghcjs
create mode 100644 testsuite/tests/process/process010.stdout-mingw32
create mode 100644 testsuite/tests/process/process011.hs
create mode 100644 testsuite/tests/process/process011.stdout
create mode 100644 testsuite/tests/process/process011_c.c
create mode 100644 testsuite/tests/process/processT251.hs
create mode 100644 testsuite/tests/process/processT251.stdout
diff --git a/testsuite/tests/Win32/HandleConversion.hs b/testsuite/tests/Win32/HandleConversion.hs
new file mode 100644
index 000000000000..55483fe233e5
--- /dev/null
+++ b/testsuite/tests/Win32/HandleConversion.hs
@@ -0,0 +1,16 @@
+module Main where
+
+import Graphics.Win32.Misc
+import System.IO
+import System.Win32.Types
+
+testStdHandle :: Handle -> StdHandleId -> IO ()
+testStdHandle haskHandle winStdHandle = do
+ winHandle <- getStdHandle winStdHandle
+ withHandleToHANDLE haskHandle $ print . (== winHandle)
+
+main :: IO ()
+main = do
+ testStdHandle stdin sTD_INPUT_HANDLE
+ testStdHandle stdout sTD_OUTPUT_HANDLE
+ testStdHandle stderr sTD_ERROR_HANDLE
diff --git a/testsuite/tests/Win32/HandleConversion.stdout b/testsuite/tests/Win32/HandleConversion.stdout
new file mode 100644
index 000000000000..b8ca7e7ef092
--- /dev/null
+++ b/testsuite/tests/Win32/HandleConversion.stdout
@@ -0,0 +1,3 @@
+True
+True
+True
diff --git a/testsuite/tests/Win32/Makefile b/testsuite/tests/Win32/Makefile
new file mode 100644
index 000000000000..e17baf38bbf0
--- /dev/null
+++ b/testsuite/tests/Win32/Makefile
@@ -0,0 +1,7 @@
+# This Makefile runs the tests using GHC's testsuite framework. It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/Win32/PokeTZI.hs b/testsuite/tests/Win32/PokeTZI.hs
new file mode 100644
index 000000000000..72e893ef4ab4
--- /dev/null
+++ b/testsuite/tests/Win32/PokeTZI.hs
@@ -0,0 +1,13 @@
+module Main where
+
+import Control.Exception (assert)
+import Foreign
+import System.Win32.Time
+
+main :: IO ()
+main = do
+ (_, tzi) <- getTimeZoneInformation
+ alloca $ \buf -> do
+ poke buf tzi
+ tzi' <- peek buf
+ assert (tzi == tzi') $ return ()
diff --git a/testsuite/tests/Win32/Semaphores.hs b/testsuite/tests/Win32/Semaphores.hs
new file mode 100644
index 000000000000..bca08a1466fd
--- /dev/null
+++ b/testsuite/tests/Win32/Semaphores.hs
@@ -0,0 +1,60 @@
+module Main where
+
+import Control.Concurrent
+ ( forkIO, threadDelay )
+import Control.Monad
+ ( void )
+import Data.Foldable
+ ( for_ )
+
+import System.Win32.Event
+ ( waitForSingleObject )
+import System.Win32.File
+ ( closeHandle )
+import System.Win32.Semaphore
+ ( Semaphore(..), createSemaphore, releaseSemaphore )
+
+main :: IO ()
+main = do
+
+ (test_sem, ex1) <- mk_test_sem
+ (_, ex2) <- mk_test_sem
+
+ let sem_name = "win32-test-semaphore"
+ (sem, ex3) <- createSemaphore Nothing 2 3 (Just sem_name)
+
+ putStrLn (show ex1 ++ " " ++ show ex2 ++ " " ++ show ex3)
+ -- False True False
+
+ putStrLn "=========="
+ for_ [1,2,3] (run_thread sem)
+ -- finish: 1, 2
+
+ putStrLn "=========="
+ void $ releaseSemaphore sem 3
+ -- finish: 3
+
+ threadDelay 5000 -- 5 ms
+ for_ [4,5,6,7] (run_thread sem)
+ -- finish: 4, 5
+
+ threadDelay 1000 -- 1 ms
+ putStrLn "=========="
+ void $ releaseSemaphore sem 1
+ -- finish: 6
+
+ threadDelay 100000 -- 100 ms
+ putStrLn "=========="
+ closeHandle (semaphoreHandle test_sem)
+ closeHandle (semaphoreHandle sem)
+
+run_thread :: Semaphore -> Int -> IO ()
+run_thread sem i = do
+ threadDelay 1000 -- 1 ms
+ putStrLn ("start " ++ show i)
+ void $ forkIO $ do
+ res <- waitForSingleObject (semaphoreHandle sem) 50 -- 50 ms
+ putStrLn ("finish " ++ show i ++ ": " ++ show res)
+
+mk_test_sem :: IO (Semaphore, Bool)
+mk_test_sem = createSemaphore Nothing 1 1 (Just "test-sem")
diff --git a/testsuite/tests/Win32/Semaphores.stdout b/testsuite/tests/Win32/Semaphores.stdout
new file mode 100644
index 000000000000..e1541b06906d
--- /dev/null
+++ b/testsuite/tests/Win32/Semaphores.stdout
@@ -0,0 +1,19 @@
+False True False
+==========
+start 1
+finish 1: 0
+start 2
+finish 2: 0
+start 3
+==========
+finish 3: 0
+start 4
+finish 4: 0
+start 5
+finish 5: 0
+start 6
+start 7
+==========
+finish 6: 0
+finish 7: 258
+==========
diff --git a/testsuite/tests/Win32/T4452.hs b/testsuite/tests/Win32/T4452.hs
new file mode 100644
index 000000000000..9a6793a23b85
--- /dev/null
+++ b/testsuite/tests/Win32/T4452.hs
@@ -0,0 +1,13 @@
+module Main where
+
+import Control.Monad
+import Foreign.Ptr
+import Graphics.Win32.GDI.Clip
+
+main = do
+ openClipboard nullPtr
+ go 0
+ where
+ go n = do
+ n' <- enumClipboardFormats n
+ unless (n == 0) (go n')
diff --git a/testsuite/tests/Win32/all.T b/testsuite/tests/Win32/all.T
new file mode 100644
index 000000000000..dd2c48170493
--- /dev/null
+++ b/testsuite/tests/Win32/all.T
@@ -0,0 +1,12 @@
+test('registry001', normal, compile_and_run, [''])
+
+# This isn't a very good test to run automatically at the moment, since
+# it doesn't terminate
+test('helloworld', skip, compile_and_run, ['-package lang -package win32'])
+
+test('lasterror', normal, compile_and_run, ['-package Win32'])
+test('T4452', normal, compile_and_run, ['-package Win32'])
+test('PokeTZI', ignore_stdout, compile_and_run, ['-package Win32'])
+test('HandleConversion', normal, compile_and_run, ['-package Win32'])
+
+test('Semaphores', normal, compile_and_run, ['-threaded -package Win32'])
diff --git a/testsuite/tests/Win32/helloworld.hs b/testsuite/tests/Win32/helloworld.hs
new file mode 100644
index 000000000000..bfba551c340e
--- /dev/null
+++ b/testsuite/tests/Win32/helloworld.hs
@@ -0,0 +1,104 @@
+-- Haskell version of "Hello, World" using the Win32 library.
+-- Demonstrates how the Win32 library can be put to use.
+-- (c) sof 1999
+
+
+module Main(main) where
+
+import qualified Win32
+import Addr
+
+-- Toplevel main just creates a window and pumps messages.
+-- The window procedure (wndProc) we pass in is partially
+-- applied with the user action that takes care of responding
+-- to repaint messages (WM_PAINT).
+
+main :: IO ()
+main = do
+ lpps <- Win32.malloc Win32.sizeofPAINTSTRUCT
+ hwnd <- createWindow 200 200 (wndProc lpps onPaint)
+ messagePump hwnd
+
+-- OnPaint handler for a window - draw a string centred
+-- inside it.
+onPaint :: Win32.RECT -> Win32.HDC -> IO ()
+onPaint (_,_,w,h) hdc = do
+ Win32.setBkMode hdc Win32.tRANSPARENT
+ Win32.setTextColor hdc (Win32.rgb 255 255 0)
+ let y | h==10 = 0
+ | otherwise = ((h-10) `div` 2)
+ x | w==50 = 0
+ | otherwise = (w-50) `div` 2
+ Win32.textOut hdc x y "Hello, world"
+ return ()
+
+-- Simple window procedure - one way to improve and generalise
+-- it would be to pass it a message map (represented as a
+-- finite map from WindowMessages to actions, perhaps).
+
+wndProc :: Win32.LPPAINTSTRUCT
+ -> (Win32.RECT -> Win32.HDC -> IO ()) -- on paint action
+ -> Win32.HWND
+ -> Win32.WindowMessage
+ -> Win32.WPARAM
+ -> Win32.LPARAM
+ -> IO Win32.LRESULT
+wndProc lpps onPaint hwnd wmsg wParam lParam
+ | wmsg == Win32.wM_DESTROY = do
+ Win32.sendMessage hwnd Win32.wM_QUIT 1 0
+ return 0
+ | wmsg == Win32.wM_PAINT && hwnd /= nullAddr = do
+ r <- Win32.getClientRect hwnd
+ paintWith lpps hwnd (onPaint r)
+ return 0
+ | otherwise =
+ Win32.defWindowProc (Just hwnd) wmsg wParam lParam
+
+createWindow :: Int -> Int -> Win32.WindowClosure -> IO Win32.HWND
+createWindow width height wndProc = do
+ let winClass = Win32.mkClassName "Hello"
+ icon <- Win32.loadIcon Nothing Win32.iDI_APPLICATION
+ cursor <- Win32.loadCursor Nothing Win32.iDC_ARROW
+ bgBrush <- Win32.createSolidBrush (Win32.rgb 0 0 255)
+ mainInstance <- Win32.getModuleHandle Nothing
+ Win32.registerClass
+ ( Win32.cS_VREDRAW + Win32.cS_HREDRAW
+ , mainInstance
+ , Just icon
+ , Just cursor
+ , Just bgBrush
+ , Nothing
+ , winClass
+ )
+ w <- Win32.createWindow
+ winClass
+ "Hello, World example"
+ Win32.wS_OVERLAPPEDWINDOW
+ Nothing Nothing -- leave it to the shell to decide the position
+ -- at where to put the window initially
+ (Just width)
+ (Just height)
+ Nothing -- no parent, i.e, root window is the parent.
+ Nothing -- no menu handle
+ mainInstance
+ wndProc
+ Win32.showWindow w Win32.sW_SHOWNORMAL
+ Win32.updateWindow w
+ return w
+
+messagePump :: Win32.HWND -> IO ()
+messagePump hwnd = do
+ msg <- Win32.getMessage (Just hwnd) `catch` \ _ -> return nullAddr
+ if msg == nullAddr then
+ return ()
+ else do
+ Win32.translateMessage msg
+ Win32.dispatchMessage msg
+ messagePump hwnd
+
+paintWith :: Win32.LPPAINTSTRUCT -> Win32.HWND -> (Win32.HDC -> IO a) -> IO a
+paintWith lpps hwnd p = do
+ hdc <- Win32.beginPaint hwnd lpps
+ a <- p hdc
+ Win32.endPaint hwnd lpps
+ return a
diff --git a/testsuite/tests/Win32/lasterror.hs b/testsuite/tests/Win32/lasterror.hs
new file mode 100644
index 000000000000..21fcbae0ab80
--- /dev/null
+++ b/testsuite/tests/Win32/lasterror.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- Test that the Win32 error code from getLastError is thread-local.
+
+import System.Win32
+import Control.Monad
+import Control.Concurrent
+
+main = do
+ setLastError 42
+ r <- getLastError
+ when (r /= 42) $ fail ("wrong: " ++ show r)
+ m <- newEmptyMVar
+ forkIO $ do setLastError 43; putMVar m ()
+ takeMVar m
+ r <- getLastError
+ when (r /= 42) $ fail ("wrong: " ++ show r)
diff --git a/testsuite/tests/Win32/registry001.hs b/testsuite/tests/Win32/registry001.hs
new file mode 100644
index 000000000000..842221029f1d
--- /dev/null
+++ b/testsuite/tests/Win32/registry001.hs
@@ -0,0 +1,16 @@
+import System.Win32
+import Control.Exception
+import Control.Monad
+
+x = "bumble"
+name = "test_registry001"
+
+-- Create, read, and delete a value (test for bug #3241)
+main = do
+ k1 <- regCreateKey hKEY_CURRENT_USER "Software"
+ k2 <- regCreateKey k1 "Haskell"
+ k3 <- regCreateKey k2 "GHC"
+ flip finally (regDeleteValue k3 name) $ do
+ regSetStringValue k3 name x
+ r <- regQueryDefaultValue k3 name
+ print r
diff --git a/testsuite/tests/Win32/registry001.stdout b/testsuite/tests/Win32/registry001.stdout
new file mode 100644
index 000000000000..17a7bd97bb15
--- /dev/null
+++ b/testsuite/tests/Win32/registry001.stdout
@@ -0,0 +1 @@
+"bumble"
diff --git a/testsuite/tests/process/.gitignore b/testsuite/tests/process/.gitignore
new file mode 100644
index 000000000000..73f38bb5de1a
--- /dev/null
+++ b/testsuite/tests/process/.gitignore
@@ -0,0 +1,31 @@
+.hpc*/
+*.o
+*.hi
+*.comp.std*
+*.run.std*
+*.eventlog
+*.genscript
+*.exe
+
+# specific files
+/T1780
+/T3231
+/T3994
+/T4198
+/T4889
+/T8343
+/process001
+/process001.out
+/process002
+/process002.out
+/process003
+/process004
+/process005
+/process006
+/process007
+/process007.tmp
+/process007_fd
+/process008
+/process009
+/process010
+/process011
diff --git a/testsuite/tests/process/Makefile b/testsuite/tests/process/Makefile
new file mode 100644
index 000000000000..e842a110d08d
--- /dev/null
+++ b/testsuite/tests/process/Makefile
@@ -0,0 +1,15 @@
+# This Makefile runs the tests using GHC's testsuite framework. It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: process007_fd
+process007_fd:
+ '$(TEST_HC)' -optc='-Wall' -no-hs-main -no-auto-link-packages process007_fd.c -o process007_fd
+
+.PHONY: T3994app
+T3994app:
+ '$(TEST_HC)' $(TEST_HC_OPTS) T3994app.hs -threaded
diff --git a/testsuite/tests/process/T1780.hs b/testsuite/tests/process/T1780.hs
new file mode 100644
index 000000000000..b56721fa5caf
--- /dev/null
+++ b/testsuite/tests/process/T1780.hs
@@ -0,0 +1,19 @@
+module Main where
+
+import Control.Concurrent
+import System.IO
+import System.Process
+
+launch :: String -> IO String
+launch i = do (hin,hout,herr,ph) <- runInteractiveProcess "cat" [] Nothing Nothing
+ -- forkIO $ collect ph -- This doesn't seem to be relevant to the problem.
+ forkIO $ do hPutStr hin i
+ hClose hin
+ hGetContents hout
+
+main :: IO ()
+main = do o <- foldl (>>=) (return "foo") (replicate 5 launch)
+ t <- myThreadId
+ -- timeout
+ forkIO $ do threadDelay 5000000; killThread t
+ putStrLn o
diff --git a/testsuite/tests/process/T1780.stdout b/testsuite/tests/process/T1780.stdout
new file mode 100644
index 000000000000..257cc5642cb1
--- /dev/null
+++ b/testsuite/tests/process/T1780.stdout
@@ -0,0 +1 @@
+foo
diff --git a/testsuite/tests/process/T3231.hs b/testsuite/tests/process/T3231.hs
new file mode 100644
index 000000000000..e6b9859d1120
--- /dev/null
+++ b/testsuite/tests/process/T3231.hs
@@ -0,0 +1,22 @@
+module Main (main) where
+
+import Control.Concurrent
+import System.IO
+import System.Cmd
+import System.Directory
+
+main = do
+ hSetBuffering stdout NoBuffering
+ forkIO $ f "foo1.txt"
+ forkIO $ f "foo2.txt"
+ threadDelay $ 2*1000000
+ putStrLn "Finished successfully"
+
+f file = do
+ h <- openFile file WriteMode
+ hPutStrLn h "fjkladsf"
+ system "sleep 1"
+ -- putChar '.'
+ hClose h
+ removeFile file
+ f file
diff --git a/testsuite/tests/process/T3231.stdout b/testsuite/tests/process/T3231.stdout
new file mode 100644
index 000000000000..c34ed5b83ff0
--- /dev/null
+++ b/testsuite/tests/process/T3231.stdout
@@ -0,0 +1 @@
+Finished successfully
diff --git a/testsuite/tests/process/T3994.hs b/testsuite/tests/process/T3994.hs
new file mode 100644
index 000000000000..78ba977cd574
--- /dev/null
+++ b/testsuite/tests/process/T3994.hs
@@ -0,0 +1,22 @@
+module Main where
+
+import Control.Concurrent
+import System.IO
+import System.Process
+
+main :: IO ()
+main = do (_,Just hout,_,p) <- createProcess (proc "./T3994app" ["start", "10000"])
+ { std_out = CreatePipe, create_group = True }
+ start <- hGetLine hout
+ putStrLn start
+ interruptProcessGroupOf p
+ t <- myThreadId
+ -- timeout
+ forkIO $ do
+ threadDelay 5000000
+ putStrLn "Interrupting a Running Process Failed"
+ hFlush stdout
+ killThread t
+ waitForProcess p
+ putStrLn "end"
+ return ()
diff --git a/testsuite/tests/process/T3994.stdout b/testsuite/tests/process/T3994.stdout
new file mode 100644
index 000000000000..5d0fb3b2d2ed
--- /dev/null
+++ b/testsuite/tests/process/T3994.stdout
@@ -0,0 +1,2 @@
+start
+end
diff --git a/testsuite/tests/process/T3994app.hs b/testsuite/tests/process/T3994app.hs
new file mode 100644
index 000000000000..09e574ffc5ef
--- /dev/null
+++ b/testsuite/tests/process/T3994app.hs
@@ -0,0 +1,10 @@
+module Main where
+
+import Control.Concurrent
+import System.Environment
+
+main :: IO ()
+main = do (str:time:_) <- getArgs
+ putStrLn str
+ threadDelay (read time)
+ return ()
diff --git a/testsuite/tests/process/T4198.hs b/testsuite/tests/process/T4198.hs
new file mode 100644
index 000000000000..003b70e20aac
--- /dev/null
+++ b/testsuite/tests/process/T4198.hs
@@ -0,0 +1,3 @@
+import System.Process
+import System.FilePath
+main = system ("." </> "exitminus1") >>= print
diff --git a/testsuite/tests/process/T4198.stdout b/testsuite/tests/process/T4198.stdout
new file mode 100644
index 000000000000..daf2f5f2d83c
--- /dev/null
+++ b/testsuite/tests/process/T4198.stdout
@@ -0,0 +1 @@
+ExitFailure 255
diff --git a/testsuite/tests/process/T4198.stdout-mingw32 b/testsuite/tests/process/T4198.stdout-mingw32
new file mode 100644
index 000000000000..6af223b76249
--- /dev/null
+++ b/testsuite/tests/process/T4198.stdout-mingw32
@@ -0,0 +1 @@
+ExitFailure (-1)
diff --git a/testsuite/tests/process/T4889.hs b/testsuite/tests/process/T4889.hs
new file mode 100644
index 000000000000..d8feb4760ee5
--- /dev/null
+++ b/testsuite/tests/process/T4889.hs
@@ -0,0 +1,10 @@
+module Main where
+
+import System.Process
+
+main :: IO ()
+main = do
+ let text = unlines . map show $ [1..10000 :: Int]
+ (code, out, _) <- readProcessWithExitCode "head" ["-n", "1"] text
+ print code
+ putStr out
diff --git a/testsuite/tests/process/T4889.stdout b/testsuite/tests/process/T4889.stdout
new file mode 100644
index 000000000000..d72cac55b230
--- /dev/null
+++ b/testsuite/tests/process/T4889.stdout
@@ -0,0 +1,2 @@
+ExitSuccess
+1
diff --git a/testsuite/tests/process/T8343.hs b/testsuite/tests/process/T8343.hs
new file mode 100644
index 000000000000..23363a50d725
--- /dev/null
+++ b/testsuite/tests/process/T8343.hs
@@ -0,0 +1,8 @@
+import System.Process
+import System.Timeout
+
+main = timeout 1000000 $ do -- The outer timeout shouldn't trigger
+ timeout 10000 $ print =<< readProcess "sleep" ["7200"] ""
+ putStrLn "Good!"
+ timeout 10000 $ print =<< readProcessWithExitCode "sleep" ["7200"] ""
+ putStrLn "Good!"
diff --git a/testsuite/tests/process/T8343.stdout b/testsuite/tests/process/T8343.stdout
new file mode 100644
index 000000000000..75c573d5701c
--- /dev/null
+++ b/testsuite/tests/process/T8343.stdout
@@ -0,0 +1,2 @@
+Good!
+Good!
diff --git a/testsuite/tests/process/T9775/Makefile b/testsuite/tests/process/T9775/Makefile
new file mode 100644
index 000000000000..8e1cd6e31850
--- /dev/null
+++ b/testsuite/tests/process/T9775/Makefile
@@ -0,0 +1,12 @@
+# This Makefile runs the tests using GHC's testsuite framework. It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../../../../testsuite
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: T9775
+T9775:
+ '$(TEST_CC)' $(TEST_CC_OPTS) ok.c -o ok.exe
+ '$(TEST_CC)' $(TEST_CC_OPTS) main.c -o main.exe
diff --git a/testsuite/tests/process/T9775/T9775_fail.hs b/testsuite/tests/process/T9775/T9775_fail.hs
new file mode 100644
index 000000000000..b2cc020ddd0b
--- /dev/null
+++ b/testsuite/tests/process/T9775/T9775_fail.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import System.Process
+
+main
+ = do (_,_,_,p) <- createProcess (proc "main" [])
+ waitForProcess p >>= print
diff --git a/testsuite/tests/process/T9775/T9775_fail.stdout b/testsuite/tests/process/T9775/T9775_fail.stdout
new file mode 100644
index 000000000000..7374c53f462a
--- /dev/null
+++ b/testsuite/tests/process/T9775/T9775_fail.stdout
@@ -0,0 +1,2 @@
+ExitSuccess
+bye bye
diff --git a/testsuite/tests/process/T9775/T9775_good.hs b/testsuite/tests/process/T9775/T9775_good.hs
new file mode 100644
index 000000000000..a66c3165d76f
--- /dev/null
+++ b/testsuite/tests/process/T9775/T9775_good.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import System.Process
+
+main
+ = do (_,_,_,p) <- createProcess ((proc "main" []){ use_process_jobs = True })
+ waitForProcess p >>= print
diff --git a/testsuite/tests/process/T9775/T9775_good.stdout b/testsuite/tests/process/T9775/T9775_good.stdout
new file mode 100644
index 000000000000..14b2f72ee233
--- /dev/null
+++ b/testsuite/tests/process/T9775/T9775_good.stdout
@@ -0,0 +1,2 @@
+bye bye
+ExitSuccess
diff --git a/testsuite/tests/process/T9775/all.T b/testsuite/tests/process/T9775/all.T
new file mode 100644
index 000000000000..ae07e48ae046
--- /dev/null
+++ b/testsuite/tests/process/T9775/all.T
@@ -0,0 +1,14 @@
+
+test('T9775_fail',
+ [extra_files(['ok.c', 'main.c']),
+ unless(opsys('mingw32'),skip),
+ pre_cmd('$MAKE -s --no-print-directory T9775'),
+ req_process],
+ compile_and_run, [''])
+
+test('T9775_good',
+ [unless(opsys('mingw32'),skip),
+ extra_files(['ok.c', 'main.c']),
+ pre_cmd('$MAKE -s --no-print-directory T9775'),
+ req_process],
+ compile_and_run, [''])
diff --git a/testsuite/tests/process/T9775/main.c b/testsuite/tests/process/T9775/main.c
new file mode 100644
index 000000000000..2c891b1a69f5
--- /dev/null
+++ b/testsuite/tests/process/T9775/main.c
@@ -0,0 +1,6 @@
+#include <unistd.h>
+
+int main(int argc, char *argv[]) {
+ char * args[2] = { "ok", NULL };
+ execv("./ok", args);
+}
diff --git a/testsuite/tests/process/T9775/ok.c b/testsuite/tests/process/T9775/ok.c
new file mode 100644
index 000000000000..50191dc03a96
--- /dev/null
+++ b/testsuite/tests/process/T9775/ok.c
@@ -0,0 +1,8 @@
+#include <stdio.h>
+#include <windows.h>
+
+int main() {
+ Sleep(2000);
+ printf("bye bye\n");
+ return 120;
+}
diff --git a/testsuite/tests/process/all.T b/testsuite/tests/process/all.T
new file mode 100644
index 000000000000..afc0bb1a8cac
--- /dev/null
+++ b/testsuite/tests/process/all.T
@@ -0,0 +1,53 @@
+# some platforms use spawnp instead of exec in some cases, resulting
+# in spurious error output changes.
+normalise_exec = normalise_fun(lambda s: s.replace('posix_spawnp', 'exec'))
+
+test('process001', [req_process], compile_and_run, [''])
+test('process002', [fragile_for(16547, concurrent_ways), req_process], compile_and_run, [''])
+test('process003', [fragile_for(17245, concurrent_ways), req_process], compile_and_run, [''])
+test('process004', [normalise_exec, normalise_exe, req_process], compile_and_run, [''])
+test('T1780', [req_process], compile_and_run, [''])
+test('process005', [omit_ghci, req_process], compile_and_run, [''])
+test('process006', [req_process], compile_and_run, [''])
+
+test('process007',
+ [when(opsys('mingw32'), skip),
+ pre_cmd('$MAKE -s --no-print-directory process007_fd'),
+ js_broken(22349),
+ req_process],
+ compile_and_run, [''])
+test('process008', [req_process], compile_and_run, [''])
+
+# not the normal way: this test runs processes from multiple threads, and
+# will get stuck without the threaded RTS.
+test('T3231',
+ [only_ways(['threaded1','threaded2']),
+ req_process],
+ compile_and_run,
+ [''])
+test('T4198',
+ [pre_cmd('{compiler} exitminus1.c -no-hs-main -o exitminus1'),
+ js_broken(22349),
+ req_process],
+ compile_and_run,
+ [''])
+
+test('T3994', [only_ways(['threaded1','threaded2']),
+ extra_files(['T3994app.hs']),
+ pre_cmd('$MAKE -s --no-print-directory T3994app'),
+ req_process],
+ compile_and_run, [''])
+test('T4889',[req_process], compile_and_run, [''])
+
+test('process009', [when(opsys('mingw32'), skip), req_process], compile_and_run, [''])
+test('process010', [
+ normalise_fun(lambda s: s.replace('illegal operation (Inappropriate ioctl for device)', 'does not exist (No such file or directory)')),
+ normalise_exec,
+ req_process
+], compile_and_run, [''])
+test('process011',
+ [when(opsys('mingw32'), skip), pre_cmd('{compiler} -no-hs-main -o process011_c process011_c.c'), js_broken(22349), req_process],
+ compile_and_run, [''])
+
+test('T8343', [req_process], compile_and_run, [''])
+test('processT251', [omit_ghci, req_process], compile_and_run, [''])
diff --git a/testsuite/tests/process/exitminus1.c b/testsuite/tests/process/exitminus1.c
new file mode 100644
index 000000000000..043d9ff975fc
--- /dev/null
+++ b/testsuite/tests/process/exitminus1.c
@@ -0,0 +1 @@
+int main() { return -1; }
diff --git a/testsuite/tests/process/process001.hs b/testsuite/tests/process/process001.hs
new file mode 100644
index 000000000000..2ad5a46583fd
--- /dev/null
+++ b/testsuite/tests/process/process001.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS -cpp #-}
+import System.IO
+import System.Process
+
+test = do
+ h <- openFile "process001.out" WriteMode
+ ph <- runProcess "ls" [] Nothing Nothing Nothing (Just h) Nothing
+ waitForProcess ph
+
+main = test >> test >> return ()
diff --git a/testsuite/tests/process/process002.hs b/testsuite/tests/process/process002.hs
new file mode 100644
index 000000000000..bf681ad06223
--- /dev/null
+++ b/testsuite/tests/process/process002.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS -cpp #-}
+import System.Process
+import System.IO
+
+main = do
+ h <- openFile "process002.out" WriteMode
+ ph <- runProcess "ls" [] Nothing Nothing Nothing (Just h) (Just h)
+ waitForProcess ph
+ return ()
diff --git a/testsuite/tests/process/process003.hs b/testsuite/tests/process/process003.hs
new file mode 100644
index 000000000000..9d8d7d245ebd
--- /dev/null
+++ b/testsuite/tests/process/process003.hs
@@ -0,0 +1,24 @@
+-- [ ghc-Bugs-1249226 ] runInteractiveProcess and closed stdin.
+-- Fixed in rev 1.9 of fptools/libraries/base/cbits/runProcess.c
+
+-- This test doesn't work in GHCi, because FD 0 gets re-allocated to
+-- the IO manager pipe, which isn't set to non-blocking mode, and the
+-- interactive prompt ends up blocking on a read from this descriptor.
+
+import System.IO
+import Control.Concurrent
+import System.Process
+
+main = do
+ hClose stdin -- everything works as expected if the handle isn't closed.
+ putStrLn "Running cat ..."
+ (inp, out, err, pid) <- runInteractiveProcess "cat" [] Nothing Nothing
+ forkIO (hPutStrLn inp "foo" >> hClose inp)
+ mout <- newEmptyMVar
+ merr <- newEmptyMVar
+ forkIO (hGetContents out >>= \s -> length s `seq` putMVar mout s)
+ forkIO (hGetContents err >>= \s -> length s `seq` putMVar merr s)
+ -- Don't want to deal with waitForProcess and -threaded right now.
+ takeMVar mout >>= putStrLn
+ takeMVar merr >>= putStrLn
+ return ()
diff --git a/testsuite/tests/process/process003.stdout b/testsuite/tests/process/process003.stdout
new file mode 100644
index 000000000000..12cd09d08469
--- /dev/null
+++ b/testsuite/tests/process/process003.stdout
@@ -0,0 +1,4 @@
+Running cat ...
+foo
+
+
diff --git a/testsuite/tests/process/process004.hs b/testsuite/tests/process/process004.hs
new file mode 100644
index 000000000000..d72dc6dbad24
--- /dev/null
+++ b/testsuite/tests/process/process004.hs
@@ -0,0 +1,23 @@
+module Main where
+
+import System.IO.Error
+import System.Process
+
+main :: IO ()
+main = do test1 `catchIOError` \e -> putStrLn ("Exc: " ++ show e)
+ test2 `catchIOError` \e -> putStrLn ("Exc: " ++ show e)
+
+test1 :: IO ()
+test1 = do
+ (_, _, _, commhand) <-
+ runInteractiveProcess "true" [] (Just "/no/such/dir") Nothing
+ exitCode <- waitForProcess commhand
+ print exitCode
+
+test2 :: IO ()
+test2 = do
+ commhand <- runProcess "true" [] (Just "/no/such/dir") Nothing
+ Nothing Nothing Nothing
+ exitCode <- waitForProcess commhand
+ print exitCode
+
diff --git a/testsuite/tests/process/process004.stdout b/testsuite/tests/process/process004.stdout
new file mode 100644
index 000000000000..e8220702ad50
--- /dev/null
+++ b/testsuite/tests/process/process004.stdout
@@ -0,0 +1,2 @@
+Exc: true: runInteractiveProcess: chdir: invalid argument (Bad file descriptor)
+Exc: true: runProcess: chdir: does not exist (No such file or directory)
diff --git a/testsuite/tests/process/process004.stdout-javascript-unknown-ghcjs b/testsuite/tests/process/process004.stdout-javascript-unknown-ghcjs
new file mode 100644
index 000000000000..e90c998d8a4e
--- /dev/null
+++ b/testsuite/tests/process/process004.stdout-javascript-unknown-ghcjs
@@ -0,0 +1,2 @@
+Exc: true: runInteractiveProcess: does not exist (No such file or directory)
+Exc: true: runProcess: does not exist (No such file or directory)
diff --git a/testsuite/tests/process/process004.stdout-mingw32 b/testsuite/tests/process/process004.stdout-mingw32
new file mode 100644
index 000000000000..e9e0e0cdf7f1
--- /dev/null
+++ b/testsuite/tests/process/process004.stdout-mingw32
@@ -0,0 +1,2 @@
+Exc: true: runInteractiveProcess: invalid argument (Invalid argument)
+Exc: true: runProcess: invalid argument (Invalid argument)
diff --git a/testsuite/tests/process/process005.hs b/testsuite/tests/process/process005.hs
new file mode 100644
index 000000000000..adb181092d3c
--- /dev/null
+++ b/testsuite/tests/process/process005.hs
@@ -0,0 +1,26 @@
+module Main where
+
+import Control.Concurrent
+import System.IO
+import System.Process
+
+main :: IO ()
+main = do p <- foldl (>>=) (return stdin) (replicate 10 docat) >>= docat0
+ t <- myThreadId
+ -- timeout
+ forkIO $ do threadDelay 5000000; killThread t
+ waitForProcess p
+ putStrLn "end"
+ return ()
+
+docat :: Handle -> IO Handle
+docat hin = do
+ (_, Just hout, _, ph) <-
+ createProcess (proc "cat" []){ std_in = UseHandle hin,
+ std_out = CreatePipe }
+ return hout
+
+docat0 :: Handle -> IO ProcessHandle
+docat0 hin = do
+ (_,_,_,ph) <- createProcess (proc "cat" []){ std_in = UseHandle hin }
+ return ph
diff --git a/testsuite/tests/process/process005.stdin b/testsuite/tests/process/process005.stdin
new file mode 100644
index 000000000000..d2b8b3d27224
--- /dev/null
+++ b/testsuite/tests/process/process005.stdin
@@ -0,0 +1,3 @@
+testing
+testing
+123
diff --git a/testsuite/tests/process/process005.stdout b/testsuite/tests/process/process005.stdout
new file mode 100644
index 000000000000..e09696b20020
--- /dev/null
+++ b/testsuite/tests/process/process005.stdout
@@ -0,0 +1,4 @@
+testing
+testing
+123
+end
diff --git a/testsuite/tests/process/process006.hs b/testsuite/tests/process/process006.hs
new file mode 100644
index 000000000000..63e13591a4bf
--- /dev/null
+++ b/testsuite/tests/process/process006.hs
@@ -0,0 +1,15 @@
+module Main where
+
+import Control.Concurrent
+import System.IO
+import System.Process
+import Control.Monad
+import Control.Exception
+
+main :: IO ()
+main = do
+ print =<< readProcess "cat" [] "yan\ntan\tether\n"
+ print =<< readProcessWithExitCode "cat" [] "yan\ntan\tether\n"
+ print =<< readProcessWithExitCode "sh" ["-c", "echo stdout; echo stderr 1>&2; exit 3"] ""
+ e <- (try $ readProcess "sh" ["-c", "echo stdout; echo stderr 1>&2; exit 3"] "")
+ print (e :: Either SomeException String)
diff --git a/testsuite/tests/process/process006.stderr b/testsuite/tests/process/process006.stderr
new file mode 100644
index 000000000000..af6415db3c72
--- /dev/null
+++ b/testsuite/tests/process/process006.stderr
@@ -0,0 +1 @@
+stderr
diff --git a/testsuite/tests/process/process006.stdout b/testsuite/tests/process/process006.stdout
new file mode 100644
index 000000000000..1e1186b31e84
--- /dev/null
+++ b/testsuite/tests/process/process006.stdout
@@ -0,0 +1,4 @@
+"yan\ntan\tether\n"
+(ExitSuccess,"yan\ntan\tether\n","")
+(ExitFailure 3,"stdout\n","stderr\n")
+Left readCreateProcess: sh "-c" "echo stdout; echo stderr 1>&2; exit 3" (exit 3): failed
diff --git a/testsuite/tests/process/process007.hs b/testsuite/tests/process/process007.hs
new file mode 100644
index 000000000000..506a0ca40bd1
--- /dev/null
+++ b/testsuite/tests/process/process007.hs
@@ -0,0 +1,24 @@
+
+import System.Process
+import System.IO
+import System.Posix
+import System.Exit
+
+tmpfile = "process007.tmp"
+
+main = do
+ writeFile tmpfile "You bad pie-rats!\n"
+ fd <- handleToFd =<< openFile tmpfile ReadMode
+ rawSystem "./process007_fd" [show fd]
+ closeFd fd
+
+ fd <- handleToFd =<< openFile tmpfile ReadMode
+ nul <- openFile "/dev/null" WriteMode
+ (_,_,_,p) <- createProcess (shell ("./process007_fd " ++ show fd))
+ { close_fds = True,
+ std_err = UseHandle nul }
+ e <- waitForProcess p
+ case e of
+ ExitSuccess -> putStrLn "eek!"
+ _ -> putStrLn "failed, as expected"
+ closeFd fd
diff --git a/testsuite/tests/process/process007.stdout b/testsuite/tests/process/process007.stdout
new file mode 100644
index 000000000000..7a9b0bf1ab77
--- /dev/null
+++ b/testsuite/tests/process/process007.stdout
@@ -0,0 +1,2 @@
+You bad pie-rats!
+failed, as expected
diff --git a/testsuite/tests/process/process007_fd.c b/testsuite/tests/process/process007_fd.c
new file mode 100644
index 000000000000..f62ec249a76f
--- /dev/null
+++ b/testsuite/tests/process/process007_fd.c
@@ -0,0 +1,41 @@
+
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+
+#define SIZE 1024
+
+int main(int argc, char **argv) {
+ int fd;
+ char buf[SIZE];
+ int nRead, nWrite;
+
+ if (argc != 2) {
+ printf("Bad arguments\n");
+ exit(1);
+ }
+
+ fd = atoi(argv[1]);
+
+ while ((nRead = read(fd, buf, SIZE)) != 0) {
+ if (nRead > 0) {
+ ssize_t nWritten = 0;
+ while (nWritten < nRead) {
+ nWrite = write(STDOUT_FILENO, buf + nWritten, nRead - nWritten);
+ if (nWrite < 0) {
+ perror("printf failed");
+ exit(1);
+ }
+ nWritten += nWrite;
+ }
+ }
+ else if (errno != EAGAIN && errno != EWOULDBLOCK && errno != EINTR) {
+ perror("read failed");
+ exit(1);
+ }
+ }
+
+ return 0;
+}
+
diff --git a/testsuite/tests/process/process008.hs b/testsuite/tests/process/process008.hs
new file mode 100644
index 000000000000..f02f55b7aa58
--- /dev/null
+++ b/testsuite/tests/process/process008.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS -cpp #-}
+import System.IO
+import System.Cmd
+import System.Environment
+
+-- echo can't be run outside of the shell in MSYS, hence:
+test = rawSystem "sh" ["-c","echo testing"]
+
+main = test >> test >> return ()
diff --git a/testsuite/tests/process/process008.stdout b/testsuite/tests/process/process008.stdout
new file mode 100644
index 000000000000..755cc82b6727
--- /dev/null
+++ b/testsuite/tests/process/process008.stdout
@@ -0,0 +1,2 @@
+testing
+testing
diff --git a/testsuite/tests/process/process009.hs b/testsuite/tests/process/process009.hs
new file mode 100644
index 000000000000..7cffd335a4c0
--- /dev/null
+++ b/testsuite/tests/process/process009.hs
@@ -0,0 +1,24 @@
+import Control.Monad
+import System.Exit
+import System.Process
+import Data.Maybe
+import Data.List (intercalate)
+
+-- Test that we get the right exit code for processes that terminate
+-- with a signal (#7229)
+
+main = do
+ let script = intercalate " "
+ [ "exec python3 2>/dev/null"
+ , "-c"
+ , "'import os; os.kill(os.getpid(), 1)'"
+ ]
+ (_,_,_,p) <- createProcess (shell script)
+ waitForProcess p >>= print
+ getProcessExitCode p >>= print
+
+ (_,_,_,p) <- createProcess (shell script)
+ forever $ do
+ r <- getProcessExitCode p
+ if (isJust r) then do print r; exitWith ExitSuccess else return ()
+
diff --git a/testsuite/tests/process/process009.stdout b/testsuite/tests/process/process009.stdout
new file mode 100644
index 000000000000..751a73aa6bf2
--- /dev/null
+++ b/testsuite/tests/process/process009.stdout
@@ -0,0 +1,3 @@
+ExitFailure (-1)
+Just (ExitFailure (-1))
+Just (ExitFailure (-1))
diff --git a/testsuite/tests/process/process010.hs b/testsuite/tests/process/process010.hs
new file mode 100644
index 000000000000..ea188eefd3c1
--- /dev/null
+++ b/testsuite/tests/process/process010.hs
@@ -0,0 +1,13 @@
+
+import System.IO.Error
+import System.Process
+
+main :: IO ()
+main = do run "true"
+ run "false"
+ run "/non/existent"
+ putStrLn "Done"
+
+run :: FilePath -> IO ()
+run fp = (rawSystem fp [] >>= print)
+ `catchIOError` \e -> putStrLn ("Exc: " ++ show e)
diff --git a/testsuite/tests/process/process010.stdout b/testsuite/tests/process/process010.stdout
new file mode 100644
index 000000000000..1c78052da1bb
--- /dev/null
+++ b/testsuite/tests/process/process010.stdout
@@ -0,0 +1,4 @@
+ExitSuccess
+ExitFailure 1
+Exc: /non/existent: rawSystem: posix_spawnp: illegal operation (Inappropriate ioctl for device)
+Done
diff --git a/testsuite/tests/process/process010.stdout-i386-unknown-solaris2 b/testsuite/tests/process/process010.stdout-i386-unknown-solaris2
new file mode 100644
index 000000000000..316b23c7740a
--- /dev/null
+++ b/testsuite/tests/process/process010.stdout-i386-unknown-solaris2
@@ -0,0 +1,4 @@
+ExitSuccess
+ExitFailure 255
+Exc: /non/existent: rawSystem: runInteractiveProcess: exec: does not exist (No such file or directory)
+Done
diff --git a/testsuite/tests/process/process010.stdout-javascript-unknown-ghcjs b/testsuite/tests/process/process010.stdout-javascript-unknown-ghcjs
new file mode 100644
index 000000000000..17d996a89259
--- /dev/null
+++ b/testsuite/tests/process/process010.stdout-javascript-unknown-ghcjs
@@ -0,0 +1,4 @@
+ExitSuccess
+ExitFailure 1
+Exc: /non/existent: rawSystem: does not exist (No such file or directory)
+Done
diff --git a/testsuite/tests/process/process010.stdout-mingw32 b/testsuite/tests/process/process010.stdout-mingw32
new file mode 100644
index 000000000000..17d996a89259
--- /dev/null
+++ b/testsuite/tests/process/process010.stdout-mingw32
@@ -0,0 +1,4 @@
+ExitSuccess
+ExitFailure 1
+Exc: /non/existent: rawSystem: does not exist (No such file or directory)
+Done
diff --git a/testsuite/tests/process/process011.hs b/testsuite/tests/process/process011.hs
new file mode 100644
index 000000000000..b711fe491485
--- /dev/null
+++ b/testsuite/tests/process/process011.hs
@@ -0,0 +1,73 @@
+import System.Process
+import System.IO
+import Control.Exception
+import Control.Concurrent
+import Data.List (intercalate)
+
+-- 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 = "./process011_c"
+ (_,_,_,p) <- createProcess (proc 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 = "./process011_c"
+ (_,_,_,p) <- createProcess (proc 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)
diff --git a/testsuite/tests/process/process011.stdout b/testsuite/tests/process/process011.stdout
new file mode 100644
index 000000000000..2c9a46fefd30
--- /dev/null
+++ b/testsuite/tests/process/process011.stdout
@@ -0,0 +1,12 @@
+===================== 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
diff --git a/testsuite/tests/process/process011_c.c b/testsuite/tests/process/process011_c.c
new file mode 100644
index 000000000000..6e271c9cebbe
--- /dev/null
+++ b/testsuite/tests/process/process011_c.c
@@ -0,0 +1,9 @@
+#include <unistd.h>
+#include <signal.h>
+
+int main() {
+ kill(getpid(), SIGINT);
+ sleep(1);
+ return 0;
+}
+
diff --git a/testsuite/tests/process/processT251.hs b/testsuite/tests/process/processT251.hs
new file mode 100644
index 000000000000..863b46e4d6ca
--- /dev/null
+++ b/testsuite/tests/process/processT251.hs
@@ -0,0 +1,39 @@
+import Control.Exception
+import GHC.IO.Exception
+import System.Environment
+import System.Exit
+import System.Process
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ [] -> parent
+ ["child"] -> child
+ ["child2"] -> child2
+ _ -> fail "unknown mode"
+
+parent :: IO ()
+parent = do
+ putStrLn "parent start"
+ (_, _, _, phdl) <- createProcess $ (proc "./processT251" ["child"]) { std_in = NoStream }
+ ExitSuccess <- waitForProcess phdl
+ putStrLn "parent done"
+
+child :: IO ()
+child = do
+ putStrLn "child start"
+ (_, _, _, phdl) <- createProcess $ (proc "./processT251" ["child2"]) { std_in = NoStream }
+ ExitSuccess <- waitForProcess phdl
+ putStrLn "child done"
+
+child2 :: IO ()
+child2 = do
+ putStrLn "child2 start"
+ -- Unfortunate, there isn't a reliable way to test that stdin has been closed.
+ -- Afterall, if any file is opened in the child, it may reuse the
+ -- supposedly-closed fd 0. In particular this tends to happen in the
+ -- threaded RTS, since the event manager's control pipe is opened during
+ -- RTS initialzation.
+ putStrLn "child2 done"
+
diff --git a/testsuite/tests/process/processT251.stdout b/testsuite/tests/process/processT251.stdout
new file mode 100644
index 000000000000..0f78e8ab2a38
--- /dev/null
+++ b/testsuite/tests/process/processT251.stdout
@@ -0,0 +1,6 @@
+child2 start
+child2 done
+child start
+child done
+parent start
+parent done
--
GitLab