diff --git a/System/Cmd.hs b/System/Cmd.hs --- a/System/Cmd.hs +++ b/System/Cmd.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 +#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} #endif @@ -21,27 +21,10 @@ -- ----------------------------------------------------------------------------- --- later: {-# DEPRECATED "Use System.Process instead" #-} -module System.Cmd +module System.Cmd {-# DEPRECATED "Use \"System.Process\" instead" #-} -- deprecated in 7.8 ( system, -- :: String -> IO ExitCode rawSystem, -- :: FilePath -> [String] -> IO ExitCode ) where -#ifndef __NHC__ import System.Process -#else -import System - -rawSystem :: String -> [String] -> IO ExitCode -rawSystem cmd args = system (unwords (map translate (cmd:args))) - --- copied from System.Process (qv) -translate :: String -> String -translate str = '"' : snd (foldr escape (True,"\"") str) - where escape '"' (b, str) = (True, '\\' : '"' : str) - escape '\\' (True, str) = (True, '\\' : '\\' : str) - escape '\\' (False, str) = (False, '\\' : str) - escape c (b, str) = (False, c : str) - -#endif diff --git a/System/Process.hs b/System/Process.hs --- a/System/Process.hs +++ b/System/Process.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE InterruptibleFFI #-} #endif @@ -44,25 +44,36 @@ StdStream(..), ProcessHandle, - -- ** Specific variants of createProcess - runCommand, - runProcess, - runInteractiveCommand, - runInteractiveProcess, + -- ** Simpler functions for common tasks + callProcess, + callCommand, + spawnProcess, + spawnCommand, readProcess, readProcessWithExitCode, -#endif - system, - rawSystem, + + -- ** Related utilities showCommandForUser, -#ifndef __HUGS__ + -- ** Control-C handling on Unix + -- $ctlc-handling + -- * Process completion waitForProcess, getProcessExitCode, terminateProcess, interruptProcessGroupOf, + + -- * Old deprecated functions + -- | These functions pre-date 'createProcess' which is much more + -- flexible. + runProcess, + runCommand, + runInteractiveProcess, + runInteractiveCommand, #endif + system, + rawSystem, ) where import Prelude hiding (mapM) @@ -70,15 +81,13 @@ #ifndef __HUGS__ import System.Process.Internals -import Control.Exception (SomeException, mask, try, onException, throwIO) +import Control.Exception (SomeException, mask, try, throwIO) import Control.DeepSeq (rnf) import System.IO.Error (mkIOError, ioeSetErrorString) #if !defined(mingw32_HOST_OS) import System.Posix.Types -#if MIN_VERSION_unix(2,5,0) import System.Posix.Process (getProcessGroupIDOf) #endif -#endif import qualified Control.Exception as C import Control.Concurrent import Control.Monad @@ -90,11 +99,7 @@ import System.Exit ( ExitCode(..) ) #ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) ) -#else -import GHC.IOBase ( ioException, IOErrorType(..) ) -#endif #if defined(mingw32_HOST_OS) import System.Win32.Process (getProcessId) import System.Win32.Console (generateConsoleCtrlEvent, cTRL_BREAK_EVENT) @@ -107,93 +112,34 @@ import Hugs.System #endif -#ifdef __NHC__ -import System (system) -#endif - #ifndef __HUGS__ --- ---------------------------------------------------------------------------- --- runCommand -{- | Runs a command using the shell. - -} -runCommand - :: String - -> IO ProcessHandle - -runCommand string = do - (_,_,_,ph) <- runGenProcess_ "runCommand" (shell string) Nothing Nothing - return ph - -- ---------------------------------------------------------------------------- --- runProcess - -{- | Runs a raw command, optionally specifying 'Handle's from which to - take the @stdin@, @stdout@ and @stderr@ channels for the new - process (otherwise these handles are inherited from the current - process). - - Any 'Handle's passed to 'runProcess' are placed immediately in the - closed state. - - Note: consider using the more general 'createProcess' instead of - 'runProcess'. --} -runProcess - :: FilePath -- ^ Filename of the executable (see 'proc' for details) - -> [String] -- ^ Arguments to pass to the executable - -> Maybe FilePath -- ^ Optional path to the working directory - -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) - -> Maybe Handle -- ^ Handle to use for @stdin@ (Nothing => use existing @stdin@) - -> Maybe Handle -- ^ Handle to use for @stdout@ (Nothing => use existing @stdout@) - -> Maybe Handle -- ^ Handle to use for @stderr@ (Nothing => use existing @stderr@) - -> IO ProcessHandle - -runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do - (_,_,_,ph) <- - runGenProcess_ "runProcess" - (proc cmd args){ cwd = mb_cwd, - env = mb_env, - std_in = mbToStd mb_stdin, - std_out = mbToStd mb_stdout, - std_err = mbToStd mb_stderr } - Nothing Nothing - maybeClose mb_stdin - maybeClose mb_stdout - maybeClose mb_stderr - return ph - where - maybeClose :: Maybe Handle -> IO () - maybeClose (Just hdl) - | hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl - maybeClose _ = return () - - mbToStd :: Maybe Handle -> StdStream - mbToStd Nothing = Inherit - mbToStd (Just hdl) = UseHandle hdl - --- ---------------------------------------------------------------------------- -- createProcess -- | Construct a 'CreateProcess' record for passing to 'createProcess', -- representing a raw command with arguments. -- --- The @FilePath@ names the executable, and is interpreted according +-- The 'FilePath' argument names the executable, and is interpreted according -- to the platform's standard policy for searching for -- executables. Specifically: -- --- * on Unix systems the @execvp@ semantics is used, where if the --- filename does not contain a slash (@/@) then the @PATH@ --- environment variable is searched for the executable. +-- * on Unix systems the +-- +-- semantics is used, where if the executable filename does not +-- contain a slash (@/@) then the @PATH@ environment variable is +-- searched for the executable. -- -- * on Windows systems the Win32 @CreateProcess@ semantics is used. -- Briefly: if the filename does not contain a path, then the -- directory containing the parent executable is searched, followed --- by the current directory, then some some standard locations, and +-- by the current directory, then some standard locations, and -- finally the current @PATH@. An @.exe@ extension is added if the -- filename does not already have an extension. For full details --- see the documentation for the Windows @SearchPath@ API. +-- see the +-- +-- for the Windows @SearchPath@ API. proc :: FilePath -> [String] -> CreateProcess proc cmd args = CreateProcess { cmdspec = RawCommand cmd args, @@ -203,7 +149,8 @@ std_out = Inherit, std_err = Inherit, close_fds = False, - create_group = False} + create_group = False, + delegate_ctlc = False} -- | Construct a 'CreateProcess' record for passing to 'createProcess', -- representing a command to be passed to the shell. @@ -215,7 +162,8 @@ std_out = Inherit, std_err = Inherit, close_fds = False, - create_group = False} + create_group = False, + delegate_ctlc = False} {- | This is the most general way to spawn an external process. The @@ -230,16 +178,16 @@ fill in the fields with default values which can be overriden as needed. -'createProcess' returns @(mb_stdin_hdl, mb_stdout_hdl, mb_stderr_hdl, p)@, +'createProcess' returns @(/mb_stdin_hdl/, /mb_stdout_hdl/, /mb_stderr_hdl/, /ph/)@, where - * if @std_in == CreatePipe@, then @mb_stdin_hdl@ will be @Just h@, - where @h@ is the write end of the pipe connected to the child + * if @'std_in' == 'CreatePipe'@, then @/mb_stdin_hdl/@ will be @Just /h/@, + where @/h/@ is the write end of the pipe connected to the child process's @stdin@. - * otherwise, @mb_stdin_hdl == Nothing@ + * otherwise, @/mb_stdin_hdl/ == Nothing@ -Similarly for @mb_stdout_hdl@ and @mb_stderr_hdl@. +Similarly for @/mb_stdout_hdl/@ and @/mb_stderr_hdl/@. For example, to execute a simple @ls@ command: @@ -261,7 +209,7 @@ :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess cp = do - r <- runGenProcess_ "createProcess" cp Nothing Nothing + r <- createProcess_ "createProcess" cp maybeCloseStd (std_in cp) maybeCloseStd (std_out cp) maybeCloseStd (std_err cp) @@ -272,94 +220,178 @@ | hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl maybeCloseStd _ = return () --- ---------------------------------------------------------------------------- --- runInteractiveCommand - -{- | Runs a command using the shell, and returns 'Handle's that may - be used to communicate with the process via its @stdin@, @stdout@, - and @stderr@ respectively. The 'Handle's are initially in binary - mode; if you need them to be in text mode then use 'hSetBinaryMode'. +{- +-- TODO: decide if we want to expose this to users +-- | A 'C.bracketOnError'-style resource handler for 'createProcess'. +-- +-- In normal operation it adds nothing, you are still responsible for waiting +-- for (or forcing) process termination and closing any 'Handle's. It only does +-- automatic cleanup if there is an exception. If there is an exception in the +-- body then it ensures that the process gets terminated and any 'CreatePipe' +-- 'Handle's are closed. In particular this means that if the Haskell thread +-- is killed (e.g. 'killThread'), that the external process is also terminated. +-- +-- e.g. +-- +-- > withCreateProcess (proc cmd args) { ... } $ \_ _ _ ph -> do +-- > ... +-- +withCreateProcess + :: CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> IO a +withCreateProcess c action = + C.bracketOnError (createProcess c) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) -} -runInteractiveCommand + +-- wrapper so we can get exceptions with the appropriate function name. +withCreateProcess_ :: String - -> IO (Handle,Handle,Handle,ProcessHandle) + -> CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> IO a +withCreateProcess_ fun c action = + C.bracketOnError (createProcess_ fun c) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) -runInteractiveCommand string = - runInteractiveProcess1 "runInteractiveCommand" (shell string) +cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) + -> IO () +cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do + terminateProcess ph + -- Note, it's important that other threads that might be reading/writing + -- these handles also get killed off, since otherwise they might be holding + -- the handle lock and prevent us from closing, leading to deadlock. + maybe (return ()) (ignoreSigPipe . hClose) mb_stdin + maybe (return ()) hClose mb_stdout + maybe (return ()) hClose mb_stderr + -- terminateProcess does not guarantee that it terminates the process. + -- Indeed on Unix it's SIGTERM, which asks nicely but does not guarantee + -- that it stops. If it doesn't stop, we don't want to hang, so we wait + -- asynchronously using forkIO. + _ <- forkIO (waitForProcess ph >> return ()) + return () + + -- ---------------------------------------------------------------------------- --- runInteractiveProcess +-- spawnProcess/spawnCommand -{- | Runs a raw command, and returns 'Handle's that may be used to communicate - with the process via its @stdin@, @stdout@ and @stderr@ respectively. +-- | Creates a new process to run the specified raw command with the given +-- arguments. It does not wait for the program to finish, but returns the +-- 'ProcessHandle'. +-- +-- /Since: 1.2.0.0/ +spawnProcess :: FilePath -> [String] -> IO ProcessHandle +spawnProcess cmd args = do + (_,_,_,p) <- createProcess_ "spawnProcess" (proc cmd args) + return p - For example, to start a process and feed a string to its stdin: +-- | Creates a new process to run the specified shell command. +-- It does not wait for the program to finish, but returns the 'ProcessHandle'. +-- +-- /Since: 1.2.0.0/ +spawnCommand :: String -> IO ProcessHandle +spawnCommand cmd = do + (_,_,_,p) <- createProcess_ "spawnCommand" (shell cmd) + return p -> (inp,out,err,pid) <- runInteractiveProcess "..." -> forkIO (hPutStr inp str) - The 'Handle's are initially in binary mode; if you need them to be - in text mode then use 'hSetBinaryMode'. --} -runInteractiveProcess - :: FilePath -- ^ Filename of the executable (see 'proc' for details) - -> [String] -- ^ Arguments to pass to the executable - -> Maybe FilePath -- ^ Optional path to the working directory - -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) - -> IO (Handle,Handle,Handle,ProcessHandle) +-- ---------------------------------------------------------------------------- +-- callProcess/callCommand -runInteractiveProcess cmd args mb_cwd mb_env = do - runInteractiveProcess1 "runInteractiveProcess" - (proc cmd args){ cwd = mb_cwd, env = mb_env } +-- | Creates a new process to run the specified command with the given +-- arguments, and wait for it to finish. If the command returns a non-zero +-- exit code, an exception is raised. +-- +-- If an asynchronous exception is thrown to the thread executing +-- @callProcess@. The forked process will be terminated and +-- @callProcess@ will wait (block) until the process has been +-- terminated. +-- +-- /Since: 1.2.0.0/ +callProcess :: FilePath -> [String] -> IO () +callProcess cmd args = do + exit_code <- withCreateProcess_ "callCommand" + (proc cmd args) { delegate_ctlc = True } $ \_ _ _ p -> + waitForProcess p + case exit_code of + ExitSuccess -> return () + ExitFailure r -> processFailedException "callProcess" cmd args r -runInteractiveProcess1 - :: String - -> CreateProcess - -> IO (Handle,Handle,Handle,ProcessHandle) -runInteractiveProcess1 fun cmd = do - (mb_in, mb_out, mb_err, p) <- - runGenProcess_ fun - cmd{ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe } - Nothing Nothing - return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p) +-- | Creates a new process to run the specified shell command. If the +-- command returns a non-zero exit code, an exception is raised. +-- +-- If an asynchronous exception is thrown to the thread executing +-- @callCommand@. The forked process will be terminated and +-- @callCommand@ will wait (block) until the process has been +-- terminated. +-- +-- /Since: 1.2.0.0/ +callCommand :: String -> IO () +callCommand cmd = do + exit_code <- withCreateProcess_ "callCommand" + (shell cmd) { delegate_ctlc = True } $ \_ _ _ p -> + waitForProcess p + case exit_code of + ExitSuccess -> return () + ExitFailure r -> processFailedException "callCommand" cmd [] r --- ---------------------------------------------------------------------------- --- waitForProcess +processFailedException :: String -> String -> [String] -> Int -> IO a +processFailedException fun cmd args exit_code = + ioError (mkIOError OtherError (fun ++ ": " ++ cmd ++ + concatMap ((' ':) . show) args ++ + " (exit " ++ show exit_code ++ ")") + Nothing Nothing) -{- | Waits for the specified process to terminate, and returns its exit code. - GHC Note: in order to call @waitForProcess@ without blocking all the - other threads in the system, you must compile the program with - @-threaded@. --} -waitForProcess - :: ProcessHandle - -> IO ExitCode -waitForProcess ph = do - p_ <- withProcessHandle ph $ \p_ -> return (p_,p_) - case p_ of - ClosedHandle e -> return e - OpenHandle h -> do - -- don't hold the MVar while we call c_waitForProcess... - -- (XXX but there's a small race window here during which another - -- thread could close the handle or call waitForProcess) - alloca $ \pret -> do - throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) - withProcessHandle ph $ \p_' -> - case p_' of - ClosedHandle e -> return (p_',e) - OpenHandle ph' -> do - closePHANDLE ph' - code <- peek pret - let e = if (code == 0) - then ExitSuccess - else (ExitFailure (fromIntegral code)) - return (ClosedHandle e, e) +-- ---------------------------------------------------------------------------- +-- Control-C handling on Unix --- ----------------------------------------------------------------------------- +-- $ctlc-handling -- +-- When running an interactive console process (such as a shell, console-based +-- text editor or ghci), we typically want that process to be allowed to handle +-- Ctl-C keyboard interrupts how it sees fit. For example, while most programs +-- simply quit on a Ctl-C, some handle it specially. To allow this to happen, +-- use the @'delegate_ctlc' = True@ option in the 'CreateProcess' options. +-- +-- The gory details: +-- +-- By default Ctl-C will generate a @SIGINT@ signal, causing a 'UserInterrupt' +-- exception to be sent to the main Haskell thread of your program, which if +-- not specially handled will terminate the program. Normally, this is exactly +-- what is wanted: an orderly shutdown of the program in response to Ctl-C. +-- +-- Of course when running another interactive program in the console then we +-- want to let that program handle Ctl-C. Under Unix however, Ctl-C sends +-- @SIGINT@ to every process using the console. The standard solution is that +-- while running an interactive program, ignore @SIGINT@ in the parent, and let +-- it be handled in the child process. If that process then terminates due to +-- the @SIGINT@ signal, then at that point treat it as if we had recieved the +-- @SIGINT@ ourselves and begin an orderly shutdown. +-- +-- This behaviour is implemented by 'createProcess' (and +-- 'waitForProcess' \/ 'getProcessExitCode') when the @'delegate_ctlc' = True@ +-- option is set. In particular, the @SIGINT@ signal will be ignored until +-- 'waitForProcess' returns (or 'getProcessExitCode' returns a non-Nothing +-- result), so it becomes especially important to use 'waitForProcess' for every +-- processes created. +-- +-- In addition, in 'delegate_ctlc' mode, 'waitForProcess' and +-- 'getProcessExitCode' will throw a 'UserInterrupt' exception if the process +-- terminated with @'ExitFailure' (-SIGINT)@. Typically you will not want to +-- catch this exception, but let it propagate, giving a normal orderly shutdown. +-- One detail to be aware of is that the 'UserInterrupt' exception is thrown +-- /synchronously/ in the thread that calls 'waitForProcess', whereas normally +-- @SIGINT@ causes the exception to be thrown /asynchronously/ to the main +-- thread. +-- +-- For even more detail on this topic, see +-- . + +-- ----------------------------------------------------------------------------- + -- | @readProcess@ forks an external process, reads its standard output -- strictly, blocking until the process terminates, and returns the output -- string. @@ -394,37 +426,36 @@ -> [String] -- ^ any arguments -> String -- ^ standard input -> IO String -- ^ stdout -readProcess cmd args input = - mask $ \restore -> do - (Just inh, Just outh, _, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = Inherit } - flip onException - (do hClose inh; hClose outh; - terminateProcess pid; waitForProcess pid) $ restore $ do +readProcess cmd args input = do + let cp_opts = (proc cmd args) { + std_in = CreatePipe, + std_out = CreatePipe, + std_err = Inherit + } + (ex, output) <- withCreateProcess_ "readProcess" cp_opts $ + \(Just inh) (Just outh) _ ph -> do + -- fork off a thread to start consuming the output output <- hGetContents outh - waitOut <- forkWait $ C.evaluate $ rnf output + withForkWait (C.evaluate $ rnf output) $ \waitOut -> do - -- now write and flush any input - when (not (null input)) $ do hPutStr inh input; hFlush inh - hClose inh -- done with stdin + -- now write any input + unless (null input) $ + ignoreSigPipe $ hPutStr inh input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSigPipe $ hClose inh - -- wait on the output - waitOut - hClose outh + -- wait on the output + waitOut + hClose outh -- wait on the process - ex <- waitForProcess pid + ex <- waitForProcess ph + return (ex, output) - case ex of - ExitSuccess -> return output - ExitFailure r -> - ioError (mkIOError OtherError ("readProcess: " ++ cmd ++ - ' ':unwords (map show args) ++ - " (exit " ++ show r ++ ")") - Nothing Nothing) + case ex of + ExitSuccess -> return output + ExitFailure r -> processFailedException "readProcess" cmd args r {- | @readProcessWithExitCode@ creates an external process, reads its @@ -441,6 +472,9 @@ around 'createProcess'. Constructing variants of these functions is quite easy: follow the link to the source code to see how 'readProcess' is implemented. + +On Unix systems, see 'waitForProcess' for the meaning of exit codes +when the process died as the result of a signal. -} readProcessWithExitCode @@ -448,141 +482,156 @@ -> [String] -- ^ any arguments -> String -- ^ standard input -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr -readProcessWithExitCode cmd args input = - mask $ \restore -> do - (Just inh, Just outh, Just errh, pid) <- createProcess (proc cmd args) - { std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe } - flip onException - (do hClose inh; hClose outh; hClose errh; - terminateProcess pid; waitForProcess pid) $ restore $ do - -- fork off a thread to start consuming stdout - out <- hGetContents outh - waitOut <- forkWait $ C.evaluate $ rnf out +readProcessWithExitCode cmd args input = do + let cp_opts = (proc cmd args) { + std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe + } + withCreateProcess_ "readProcessWithExitCode" cp_opts $ + \(Just inh) (Just outh) (Just errh) ph -> do - -- fork off a thread to start consuming stderr + out <- hGetContents outh err <- hGetContents errh - waitErr <- forkWait $ C.evaluate $ rnf err - -- now write and flush any input - let writeInput = do - unless (null input) $ do - hPutStr inh input - hFlush inh - hClose inh + -- fork off threads to start consuming stdout & stderr + withForkWait (C.evaluate $ rnf out) $ \waitOut -> + withForkWait (C.evaluate $ rnf err) $ \waitErr -> do -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 611 - C.catch writeInput $ \e -> case e of - IOError { ioe_type = ResourceVanished - , ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - _ -> throwIO e -#else - writeInput -#endif + -- now write any input + unless (null input) $ + ignoreSigPipe $ hPutStr inh input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSigPipe $ hClose inh - -- wait on the output - waitOut - waitErr + -- wait on the output + waitOut + waitErr - hClose outh - hClose errh + hClose outh + hClose errh -- wait on the process - ex <- waitForProcess pid + ex <- waitForProcess ph return (ex, out, err) -forkWait :: IO a -> IO (IO a) -forkWait a = do - res <- newEmptyMVar - _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res - return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return) +-- | Fork a thread while doing something else, but kill it if there's an +-- exception. +-- +-- This is important in the cases above because we want to kill the thread +-- that is holding the Handle lock, because when we clean up the process we +-- try to close that handle, which could otherwise deadlock. +-- +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either throwIO return + restore (body wait) `C.onException` killThread tid -#endif /* !__HUGS__ */ +ignoreSigPipe :: IO () -> IO () +#if defined(__GLASGOW_HASKELL__) +ignoreSigPipe = C.handle $ \e -> case e of + IOError { ioe_type = ResourceVanished + , ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e +#else +ignoreSigPipe = id +#endif --- --------------------------------------------------------------------------- --- system +-- ---------------------------------------------------------------------------- +-- showCommandForUser -{-| -Computation @system cmd@ returns the exit code produced when the -operating system runs the shell command @cmd@. +-- | Given a program @/p/@ and arguments @/args/@, +-- @showCommandForUser /p/ /args/@ returns a string suitable for pasting +-- into @\/bin\/sh@ (on Unix systems) or @CMD.EXE@ (on Windows). +showCommandForUser :: FilePath -> [String] -> String +showCommandForUser cmd args = unwords (map translate (cmd : args)) -This computation may fail with - * @PermissionDenied@: The process has insufficient privileges to - perform the operation. +-- ---------------------------------------------------------------------------- +-- waitForProcess - * @ResourceExhausted@: Insufficient resources are available to - perform the operation. +{- | Waits for the specified process to terminate, and returns its exit code. - * @UnsupportedOperation@: The implementation does not support - system calls. +GHC Note: in order to call @waitForProcess@ without blocking all the +other threads in the system, you must compile the program with +@-threaded@. -On Windows, 'system' passes the command to the Windows command -interpreter (@CMD.EXE@ or @COMMAND.COM@), hence Unixy shell tricks -will not work. +(/Since: 1.2.0.0/) On Unix systems, a negative value @'ExitFailure' -/signum/@ +indicates that the child was terminated by signal @/signum/@. +The signal numbers are platform-specific, so to test for a specific signal use +the constants provided by "System.Posix.Signals" in the @unix@ package. +Note: core dumps are not reported, use "System.Posix.Process" if you need this +detail. + -} -#ifdef __GLASGOW_HASKELL__ -system :: String -> IO ExitCode -system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command") -system str = syncProcess "system" (shell str) +waitForProcess + :: ProcessHandle + -> IO ExitCode +waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do + p_ <- modifyProcessHandle ph $ \p_ -> return (p_,p_) + case p_ of + ClosedHandle e -> return e + OpenHandle h -> do + -- don't hold the MVar while we call c_waitForProcess... + -- (XXX but there's a small race window here during which another + -- thread could close the handle or call waitForProcess) + e <- alloca $ \pret -> do + throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) + modifyProcessHandle ph $ \p_' -> + case p_' of + ClosedHandle e -> return (p_',e) + OpenHandle ph' -> do + closePHANDLE ph' + code <- peek pret + let e = if (code == 0) + then ExitSuccess + else (ExitFailure (fromIntegral code)) + return (ClosedHandle e, e) + when delegating_ctlc $ + endDelegateControlC e + return e -syncProcess :: String -> CreateProcess -> IO ExitCode -#if mingw32_HOST_OS -syncProcess _fun c = do - (_,_,_,p) <- createProcess c - waitForProcess p -#else -syncProcess fun c = do - -- The POSIX version of system needs to do some manipulation of signal - -- handlers. Since we're going to be synchronously waiting for the child, - -- we want to ignore ^C in the parent, but handle it the default way - -- in the child (using SIG_DFL isn't really correct, it should be the - -- original signal handler, but the GHC RTS will have already set up - -- its own handler and we don't want to use that). - old_int <- installHandler sigINT Ignore Nothing - old_quit <- installHandler sigQUIT Ignore Nothing - (_,_,_,p) <- runGenProcess_ fun c - (Just defaultSignal) (Just defaultSignal) - r <- waitForProcess p - _ <- installHandler sigINT old_int Nothing - _ <- installHandler sigQUIT old_quit Nothing - return r -#endif /* mingw32_HOST_OS */ -#endif /* __GLASGOW_HASKELL__ */ +-- ---------------------------------------------------------------------------- +-- getProcessExitCode -{-| -The computation @'rawSystem' cmd args@ runs the operating system command -@cmd@ in such a way that it receives as arguments the @args@ strings -exactly as given, with no funny escaping or shell meta-syntax expansion. -It will therefore behave more portably between operating systems than 'system'. +{- | +This is a non-blocking version of 'waitForProcess'. If the process is +still running, 'Nothing' is returned. If the process has exited, then +@'Just' e@ is returned where @e@ is the exit code of the process. -The return codes and possible failures are the same as for 'system'. +On Unix systems, see 'waitForProcess' for the meaning of exit codes +when the process died as the result of a signal. -} -rawSystem :: String -> [String] -> IO ExitCode -#ifdef __GLASGOW_HASKELL__ -rawSystem cmd args = syncProcess "rawSystem" (proc cmd args) -#elif !mingw32_HOST_OS --- crude fallback implementation: could do much better than this under Unix -rawSystem cmd args = system (showCommandForUser cmd args) -#else /* mingw32_HOST_OS && ! __GLASGOW_HASKELL__ */ -# if __HUGS__ -rawSystem cmd args = system (cmd ++ showCommandForUser "" args) -# else -rawSystem cmd args = system (showCommandForUser cmd args) -#endif -#endif --- | Given a program @p@ and arguments @args@, --- @showCommandForUser p args@ returns a string suitable for pasting --- into sh (on POSIX OSs) or cmd.exe (on Windows). -showCommandForUser :: FilePath -> [String] -> String -showCommandForUser cmd args = unwords (map translate (cmd : args)) +getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode) +getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do + (m_e, was_open) <- modifyProcessHandle ph $ \p_ -> + case p_ of + ClosedHandle e -> return (p_, (Just e, False)) + OpenHandle h -> + alloca $ \pExitCode -> do + res <- throwErrnoIfMinus1Retry "getProcessExitCode" $ + c_getProcessExitCode h pExitCode + code <- peek pExitCode + if res == 0 + then return (p_, (Nothing, False)) + else do + closePHANDLE h + let e | code == 0 = ExitSuccess + | otherwise = ExitFailure (fromIntegral code) + return (ClosedHandle e, (Just e, True)) + case m_e of + Just e | was_open && delegating_ctlc -> endDelegateControlC e + _ -> return () + return m_e -#ifndef __HUGS__ + -- ---------------------------------------------------------------------------- -- terminateProcess @@ -603,15 +652,16 @@ terminateProcess :: ProcessHandle -> IO () terminateProcess ph = do - withProcessHandle_ ph $ \p_ -> + withProcessHandle ph $ \p_ -> case p_ of - ClosedHandle _ -> return p_ + ClosedHandle _ -> return () OpenHandle h -> do throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h - return p_ + return () -- does not close the handle, we might want to try terminating it -- again, or get its exit code. + -- ---------------------------------------------------------------------------- -- interruptProcessGroupOf @@ -626,55 +676,23 @@ :: ProcessHandle -- ^ A process in the process group -> IO () interruptProcessGroupOf ph = do -#if mingw32_HOST_OS - withProcessHandle_ ph $ \p_ -> do + withProcessHandle ph $ \p_ -> do case p_ of - ClosedHandle _ -> return p_ + ClosedHandle _ -> return () OpenHandle h -> do +#if mingw32_HOST_OS pid <- getProcessId h generateConsoleCtrlEvent cTRL_BREAK_EVENT pid - return p_ +-- We can't use an #elif here, because MIN_VERSION_unix isn't defined +-- on Windows, so on Windows cpp fails: +-- error: missing binary operator before token "(" #else - withProcessHandle_ ph $ \p_ -> do - case p_ of - ClosedHandle _ -> return p_ - OpenHandle h -> do -#if MIN_VERSION_unix(2,5,0) - -- getProcessGroupIDOf was added in unix-2.5.0.0 pgid <- getProcessGroupIDOf h signalProcessGroup sigINT pgid -#else - signalProcessGroup sigINT h #endif - return p_ -#endif + return () --- ---------------------------------------------------------------------------- --- getProcessExitCode -{- | -This is a non-blocking version of 'waitForProcess'. If the process is -still running, 'Nothing' is returned. If the process has exited, then -@'Just' e@ is returned where @e@ is the exit code of the process. --} -getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode) -getProcessExitCode ph = do - withProcessHandle ph $ \p_ -> - case p_ of - ClosedHandle e -> return (p_, Just e) - OpenHandle h -> - alloca $ \pExitCode -> do - res <- throwErrnoIfMinus1Retry "getProcessExitCode" $ - c_getProcessExitCode h pExitCode - code <- peek pExitCode - if res == 0 - then return (p_, Nothing) - else do - closePHANDLE h - let e | code == 0 = ExitSuccess - | otherwise = ExitFailure (fromIntegral code) - return (ClosedHandle e, Just e) - -- ---------------------------------------------------------------------------- -- Interface to C bits @@ -689,15 +707,204 @@ -> Ptr CInt -> IO CInt -#if __GLASGOW_HASKELL__ < 701 --- not available prior to 7.1 -#define interruptible safe -#endif - foreign import ccall interruptible "waitForProcess" -- NB. safe - can block c_waitForProcess :: PHANDLE -> Ptr CInt -> IO CInt + + +-- ---------------------------------------------------------------------------- +-- Old deprecated variants +-- ---------------------------------------------------------------------------- + +-- TODO: We're not going to mark these functions as DEPRECATED immediately in +-- process-1.2.0.0. That's because some of their replacements have not been +-- around for all that long. But they should eventually be marked with a +-- suitable DEPRECATED pragma after a release or two. + + +-- ---------------------------------------------------------------------------- +-- runCommand + +--TODO: in a later release {-# DEPRECATED runCommand "Use 'spawnCommand' instead" #-} + +{- | Runs a command using the shell. + -} +runCommand + :: String + -> IO ProcessHandle + +runCommand string = do + (_,_,_,ph) <- createProcess_ "runCommand" (shell string) + return ph + + +-- ---------------------------------------------------------------------------- +-- runProcess + +--TODO: in a later release {-# DEPRECATED runProcess "Use 'spawnProcess' or 'createProcess' instead" #-} + +{- | Runs a raw command, optionally specifying 'Handle's from which to + take the @stdin@, @stdout@ and @stderr@ channels for the new + process (otherwise these handles are inherited from the current + process). + + Any 'Handle's passed to 'runProcess' are placed immediately in the + closed state. + + Note: consider using the more general 'createProcess' instead of + 'runProcess'. +-} +runProcess + :: FilePath -- ^ Filename of the executable (see 'proc' for details) + -> [String] -- ^ Arguments to pass to the executable + -> Maybe FilePath -- ^ Optional path to the working directory + -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) + -> Maybe Handle -- ^ Handle to use for @stdin@ (Nothing => use existing @stdin@) + -> Maybe Handle -- ^ Handle to use for @stdout@ (Nothing => use existing @stdout@) + -> Maybe Handle -- ^ Handle to use for @stderr@ (Nothing => use existing @stderr@) + -> IO ProcessHandle + +runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do + (_,_,_,ph) <- + createProcess_ "runProcess" + (proc cmd args){ cwd = mb_cwd, + env = mb_env, + std_in = mbToStd mb_stdin, + std_out = mbToStd mb_stdout, + std_err = mbToStd mb_stderr } + maybeClose mb_stdin + maybeClose mb_stdout + maybeClose mb_stderr + return ph + where + maybeClose :: Maybe Handle -> IO () + maybeClose (Just hdl) + | hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl + maybeClose _ = return () + + mbToStd :: Maybe Handle -> StdStream + mbToStd Nothing = Inherit + mbToStd (Just hdl) = UseHandle hdl + + +-- ---------------------------------------------------------------------------- +-- runInteractiveCommand + +--TODO: in a later release {-# DEPRECATED runInteractiveCommand "Use 'createProcess' instead" #-} + +{- | Runs a command using the shell, and returns 'Handle's that may + be used to communicate with the process via its @stdin@, @stdout@, + and @stderr@ respectively. The 'Handle's are initially in binary + mode; if you need them to be in text mode then use 'hSetBinaryMode'. +-} +runInteractiveCommand + :: String + -> IO (Handle,Handle,Handle,ProcessHandle) + +runInteractiveCommand string = + runInteractiveProcess1 "runInteractiveCommand" (shell string) + + +-- ---------------------------------------------------------------------------- +-- runInteractiveProcess + +--TODO: in a later release {-# DEPRECATED runInteractiveCommand "Use 'createProcess' instead" #-} + +{- | Runs a raw command, and returns 'Handle's that may be used to communicate + with the process via its @stdin@, @stdout@ and @stderr@ respectively. + + For example, to start a process and feed a string to its stdin: + +> (inp,out,err,pid) <- runInteractiveProcess "..." +> forkIO (hPutStr inp str) + + The 'Handle's are initially in binary mode; if you need them to be + in text mode then use 'hSetBinaryMode'. +-} +runInteractiveProcess + :: FilePath -- ^ Filename of the executable (see 'proc' for details) + -> [String] -- ^ Arguments to pass to the executable + -> Maybe FilePath -- ^ Optional path to the working directory + -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) + -> IO (Handle,Handle,Handle,ProcessHandle) + +runInteractiveProcess cmd args mb_cwd mb_env = do + runInteractiveProcess1 "runInteractiveProcess" + (proc cmd args){ cwd = mb_cwd, env = mb_env } + +runInteractiveProcess1 + :: String + -> CreateProcess + -> IO (Handle,Handle,Handle,ProcessHandle) +runInteractiveProcess1 fun cmd = do + (mb_in, mb_out, mb_err, p) <- + createProcess_ fun + cmd{ std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe } + return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p) #endif /* !__HUGS__ */ + +-- --------------------------------------------------------------------------- +-- system & rawSystem + +--TODO: in a later release {-# DEPRECATED system "Use 'callCommand' (or 'spawnCommand' and 'waitForProcess') instead" #-} + +{-| +Computation @system cmd@ returns the exit code produced when the +operating system runs the shell command @cmd@. + +This computation may fail with one of the following +'System.IO.Error.IOErrorType' exceptions: + +[@PermissionDenied@] +The process has insufficient privileges to perform the operation. + +[@ResourceExhausted@] +Insufficient resources are available to perform the operation. + +[@UnsupportedOperation@] +The implementation does not support system calls. + +On Windows, 'system' passes the command to the Windows command +interpreter (@CMD.EXE@ or @COMMAND.COM@), hence Unixy shell tricks +will not work. + +On Unix systems, see 'waitForProcess' for the meaning of exit codes +when the process died as the result of a signal. +-} +#ifdef __GLASGOW_HASKELL__ +system :: String -> IO ExitCode +system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command") +system str = do + (_,_,_,p) <- createProcess_ "system" (shell str) { delegate_ctlc = True } + waitForProcess p +#endif /* __GLASGOW_HASKELL__ */ + + +--TODO: in a later release {-# DEPRECATED rawSystem "Use 'callProcess' (or 'spawnProcess' and 'waitForProcess') instead" #-} + +{-| +The computation @'rawSystem' /cmd/ /args/@ runs the operating system command +@/cmd/@ in such a way that it receives as arguments the @/args/@ strings +exactly as given, with no funny escaping or shell meta-syntax expansion. +It will therefore behave more portably between operating systems than 'system'. + +The return codes and possible failures are the same as for 'system'. +-} +rawSystem :: String -> [String] -> IO ExitCode +#ifdef __GLASGOW_HASKELL__ +rawSystem cmd args = do + (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True } + waitForProcess p +#elif !mingw32_HOST_OS +-- crude fallback implementation: could do much better than this under Unix +rawSystem cmd args = system (showCommandForUser cmd args) +#elif __HUGS__ +rawSystem cmd args = system (cmd ++ showCommandForUser "" args) +#else +rawSystem cmd args = system (showCommandForUser cmd args) +#endif diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, RecordWildCards #-} +{-# LANGUAGE CPP, RecordWildCards, BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} -{-# OPTIONS_GHC -w #-} --- XXX We get some warnings on Windows -#if __GLASGOW_HASKELL__ >= 701 +#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE InterruptibleFFI #-} #endif ----------------------------------------------------------------------------- @@ -11,7 +10,7 @@ -- Module : System.Process.Internals -- Copyright : (c) The University of Glasgow 2004 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable @@ -20,97 +19,82 @@ -- ----------------------------------------------------------------------------- --- #hide module System.Process.Internals ( -#ifndef __HUGS__ - ProcessHandle(..), ProcessHandle__(..), - PHANDLE, closePHANDLE, mkProcessHandle, - withProcessHandle, withProcessHandle_, + ProcessHandle(..), ProcessHandle__(..), + PHANDLE, closePHANDLE, mkProcessHandle, + modifyProcessHandle, withProcessHandle, #ifdef __GLASGOW_HASKELL__ CreateProcess(..), CmdSpec(..), StdStream(..), - runGenProcess_, + createProcess_, + runGenProcess_, --deprecated #endif + startDelegateControlC, + endDelegateControlC, #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - pPrPr_disableITimers, c_execvpe, + pPrPr_disableITimers, c_execvpe, ignoreSignal, defaultSignal, #endif -#endif withFilePathException, withCEnvironment, translate, - -#ifndef __HUGS__ fdToHandle, -#endif ) where -#ifndef __HUGS__ #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import Control.Monad +import Data.Char import System.Posix.Types import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe ) -import System.IO ( IOMode(..) ) -#else -import Data.Word ( Word32 ) -import Data.IORef -#endif +import System.IO #endif -import System.IO ( Handle ) -import System.Exit ( ExitCode ) import Control.Concurrent import Control.Exception +import Data.Bits import Foreign.C -import Foreign - -# ifdef __GLASGOW_HASKELL__ +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable +import System.IO.Unsafe +#ifdef __GLASGOW_HASKELL__ import System.Posix.Internals -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO.Exception import GHC.IO.Encoding import qualified GHC.IO.FD as FD import GHC.IO.Device -import GHC.IO.Handle import GHC.IO.Handle.FD import GHC.IO.Handle.Internals -import GHC.IO.Handle.Types +import GHC.IO.Handle.Types hiding (ClosedHandle) import System.IO.Error import Data.Typeable #if defined(mingw32_HOST_OS) import GHC.IO.IOMode import System.Win32.DebugApi (PHANDLE) -#endif #else -import GHC.IOBase ( haFD, FD, IOException(..) ) -import GHC.Handle +import System.Posix.Signals as Sig #endif - -# elif __HUGS__ - -import Hugs.Exception ( IOException(..) ) - -# endif - -#ifdef base4 -import System.IO.Error ( ioeSetFileName ) #endif + #if defined(mingw32_HOST_OS) -import Control.Monad ( when ) import System.Directory ( doesFileExist ) -import System.IO.Error ( isDoesNotExistError, doesNotExistErrorType, - mkIOError ) import System.Environment ( getEnv ) import System.FilePath #endif -#ifdef __HUGS__ -{-# CFILES cbits/execvpe.c #-} -#endif - #include "HsProcessConfig.h" #include "processFlags.h" -#ifndef __HUGS__ +#ifdef mingw32_HOST_OS +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif + -- ---------------------------------------------------------------------------- -- ProcessHandle type @@ -122,51 +106,48 @@ to wait for the process later. -} data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode -newtype ProcessHandle = ProcessHandle (MVar ProcessHandle__) +data ProcessHandle = ProcessHandle !(MVar ProcessHandle__) !Bool -withProcessHandle - :: ProcessHandle +modifyProcessHandle + :: ProcessHandle -> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a -withProcessHandle (ProcessHandle m) io = modifyMVar m io +modifyProcessHandle (ProcessHandle m _) io = modifyMVar m io -withProcessHandle_ - :: ProcessHandle - -> (ProcessHandle__ -> IO ProcessHandle__) - -> IO () -withProcessHandle_ (ProcessHandle m) io = modifyMVar_ m io +withProcessHandle + :: ProcessHandle + -> (ProcessHandle__ -> IO a) + -> IO a +withProcessHandle (ProcessHandle m _) io = withMVar m io #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) type PHANDLE = CPid -throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE -throwErrnoIfBadPHandle = throwErrnoIfMinus1 - -mkProcessHandle :: PHANDLE -> IO ProcessHandle -mkProcessHandle p = do +mkProcessHandle :: PHANDLE -> Bool -> IO ProcessHandle +mkProcessHandle p mb_delegate_ctlc = do m <- newMVar (OpenHandle p) - return (ProcessHandle m) + return (ProcessHandle m mb_delegate_ctlc) closePHANDLE :: PHANDLE -> IO () closePHANDLE _ = return () #else -throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE +throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE throwErrnoIfBadPHandle = throwErrnoIfNull -- On Windows, we have to close this HANDLE when it is no longer required, --- hence we add a finalizer to it, using an IORef as the box on which to --- attach the finalizer. +-- hence we add a finalizer to it mkProcessHandle :: PHANDLE -> IO ProcessHandle mkProcessHandle h = do m <- newMVar (OpenHandle h) - addMVarFinalizer m (processHandleFinaliser m) - return (ProcessHandle m) + _ <- mkWeakMVar m (processHandleFinaliser m) + return (ProcessHandle m False) +processHandleFinaliser :: MVar ProcessHandle__ -> IO () processHandleFinaliser m = - modifyMVar_ m $ \p_ -> do + modifyMVar_ m $ \p_ -> do case p_ of OpenHandle ph -> closePHANDLE ph _ -> return () @@ -175,12 +156,11 @@ closePHANDLE :: PHANDLE -> IO () closePHANDLE ph = c_CloseHandle ph -foreign import stdcall unsafe "CloseHandle" +foreign import WINDOWS_CCONV unsafe "CloseHandle" c_CloseHandle :: PHANDLE -> IO () #endif -#endif /* !__HUGS__ */ -- ---------------------------------------------------------------------------- @@ -192,11 +172,16 @@ std_out :: StdStream, -- ^ How to determine stdout std_err :: StdStream, -- ^ How to determine stderr close_fds :: Bool, -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit) - create_group :: Bool -- ^ Create a new process group + create_group :: Bool, -- ^ Create a new process group + delegate_ctlc:: Bool -- ^ Delegate control-C handling. Use this for interactive console processes to let them handle control-C themselves (see below for details). + -- + -- On Windows this has no effect. + -- + -- /Since: 1.2.0.0/ } -data CmdSpec - = ShellCommand String +data CmdSpec + = ShellCommand String -- ^ a command line to execute using the shell | RawCommand FilePath [String] -- ^ the filename of an executable with a list of arguments. @@ -211,11 +196,9 @@ -- and newline translation mode (just -- like @Handle@s created by @openFile@). -runGenProcess_ +createProcess_ :: String -- ^ function name (for error messages) -> CreateProcess - -> Maybe CLong -- ^ handler for SIGINT - -> Maybe CLong -- ^ handler for SIGQUIT -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) @@ -225,64 +208,140 @@ -- ----------------------------------------------------------------------------- -- POSIX runProcess with signal handling in the child -runGenProcess_ fun CreateProcess{ cmdspec = cmdsp, +createProcess_ fun CreateProcess{ cmdspec = cmdsp, cwd = mb_cwd, env = mb_env, std_in = mb_stdin, std_out = mb_stdout, std_err = mb_stderr, close_fds = mb_close_fds, - create_group = mb_create_group } - mb_sigint mb_sigquit + create_group = mb_create_group, + delegate_ctlc = mb_delegate_ctlc } = do let (cmd,args) = commandToProcess cmdsp withFilePathException cmd $ alloca $ \ pfdStdInput -> alloca $ \ pfdStdOutput -> alloca $ \ pfdStdError -> + alloca $ \ pFailedDoing -> maybeWith withCEnvironment mb_env $ \pEnv -> maybeWith withFilePath mb_cwd $ \pWorkDir -> withMany withFilePath (cmd:args) $ \cstrs -> withArray0 nullPtr cstrs $ \pargs -> do - + fdin <- mbFd fun fd_stdin mb_stdin fdout <- mbFd fun fd_stdout mb_stdout fderr <- mbFd fun fd_stderr mb_stderr - let (set_int, inthand) - = case mb_sigint of - Nothing -> (0, 0) - Just hand -> (1, hand) - (set_quit, quithand) - = case mb_sigquit of - Nothing -> (0, 0) - Just hand -> (1, hand) + when mb_delegate_ctlc + startDelegateControlC -- runInteractiveProcess() blocks signals around the fork(). -- Since blocking/unblocking of signals is a global state -- operation, we better ensure mutual exclusion of calls to -- runInteractiveProcess(). proc_handle <- withMVar runInteractiveProcess_lock $ \_ -> - throwErrnoIfMinus1 fun $ - c_runInteractiveProcess pargs pWorkDir pEnv + c_runInteractiveProcess pargs pWorkDir pEnv fdin fdout fderr pfdStdInput pfdStdOutput pfdStdError - set_int inthand set_quit quithand + (if mb_delegate_ctlc then 1 else 0) ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)) + pFailedDoing + when (proc_handle == -1) $ do + cFailedDoing <- peek pFailedDoing + failedDoing <- peekCString cFailedDoing + throwErrno (fun ++ ": " ++ failedDoing) + hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode hndStdError <- mbPipe mb_stderr pfdStdError ReadMode - ph <- mkProcessHandle proc_handle + ph <- mkProcessHandle proc_handle mb_delegate_ctlc return (hndStdInput, hndStdOutput, hndStdError, ph) {-# NOINLINE runInteractiveProcess_lock #-} runInteractiveProcess_lock :: MVar () runInteractiveProcess_lock = unsafePerformIO $ newMVar () -foreign import ccall unsafe "runInteractiveProcess" +-- ---------------------------------------------------------------------------- +-- Delegated control-C handling on Unix + +-- See ticket https://ghc.haskell.org/trac/ghc/ticket/2301 +-- and http://www.cons.org/cracauer/sigint.html +-- +-- While running an interactive console process like ghci or a shell, we want +-- to let that process handle Ctl-C keyboard interrupts how it sees fit. +-- So that means we need to ignore the SIGINT/SIGQUIT Unix signals while we're +-- running such programs. And then if/when they do terminate, we need to check +-- if they terminated due to SIGINT/SIGQUIT and if so then we behave as if we +-- got the Ctl-C then, by throwing the UserInterrupt exception. +-- +-- If we run multiple programs like this concurrently then we have to be +-- careful to avoid messing up the signal handlers. We keep a count and only +-- restore when the last one has finished. + +{-# NOINLINE runInteractiveProcess_delegate_ctlc #-} +runInteractiveProcess_delegate_ctlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler)) +runInteractiveProcess_delegate_ctlc = unsafePerformIO $ newMVar Nothing + +startDelegateControlC :: IO () +startDelegateControlC = + modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do + case delegating of + Nothing -> do +-- print ("startDelegateControlC", "Nothing") + -- We're going to ignore ^C in the parent while there are any + -- processes using ^C delegation. + -- + -- If another thread runs another process without using + -- delegation while we're doing this then it will inherit the + -- ignore ^C status. + old_int <- installHandler sigINT Ignore Nothing + old_quit <- installHandler sigQUIT Ignore Nothing + return (Just (1, old_int, old_quit)) + + Just (count, old_int, old_quit) -> do +-- print ("startDelegateControlC", count) + -- If we're already doing it, just increment the count + let !count' = count + 1 + return (Just (count', old_int, old_quit)) + +endDelegateControlC :: ExitCode -> IO () +endDelegateControlC exitCode = do + modifyMVar_ runInteractiveProcess_delegate_ctlc $ \delegating -> do + case delegating of + Just (1, old_int, old_quit) -> do +-- print ("endDelegateControlC", exitCode, 1 :: Int) + -- Last process, so restore the old signal handlers + _ <- installHandler sigINT old_int Nothing + _ <- installHandler sigQUIT old_quit Nothing + return Nothing + + Just (count, old_int, old_quit) -> do +-- print ("endDelegateControlC", exitCode, count) + -- Not the last, just decrement the count + let !count' = count - 1 + return (Just (count', old_int, old_quit)) + + Nothing -> return Nothing -- should be impossible + + -- And if the process did die due to SIGINT or SIGQUIT then + -- we throw our equivalent exception here (synchronously). + -- + -- An alternative design would be to throw to the main thread, as the + -- normal signal handler does. But since we can be sync here, we do so. + -- It allows the code locally to catch it and do something. + case exitCode of + ExitFailure n | isSigIntQuit n -> throwIO UserInterrupt + _ -> return () + where + isSigIntQuit n = sig == sigINT || sig == sigQUIT + where + sig = fromIntegral (-n) + +foreign import ccall unsafe "runInteractiveProcess" c_runInteractiveProcess :: Ptr CString -> CString @@ -293,11 +352,9 @@ -> Ptr FD -> Ptr FD -> Ptr FD - -> CInt -- non-zero: set child's SIGINT handler - -> CLong -- SIGINT handler - -> CInt -- non-zero: set child's SIGQUIT handler - -> CLong -- SIGQUIT handler + -> CInt -- reset child's SIGINT & SIGQUIT handlers -> CInt -- flags + -> Ptr CString -> IO PHANDLE #endif /* __GLASGOW_HASKELL__ */ @@ -310,15 +367,15 @@ #ifdef __GLASGOW_HASKELL__ -runGenProcess_ fun CreateProcess{ cmdspec = cmdsp, +createProcess_ fun CreateProcess{ cmdspec = cmdsp, cwd = mb_cwd, env = mb_env, std_in = mb_stdin, std_out = mb_stdout, std_err = mb_stderr, close_fds = mb_close_fds, - create_group = mb_create_group } - _ignored_mb_sigint _ignored_mb_sigquit + create_group = mb_create_group, + delegate_ctlc = _ignored } = do (cmd, cmdline) <- commandToProcess cmdsp withFilePathException cmd $ @@ -328,7 +385,7 @@ maybeWith withCEnvironment mb_env $ \pEnv -> maybeWith withCWString mb_cwd $ \pWorkDir -> do withCWString cmdline $ \pcmdline -> do - + fdin <- mbFd fun fd_stdin mb_stdin fdout <- mbFd fun fd_stdout mb_stdout fderr <- mbFd fun fd_stderr mb_stderr @@ -338,14 +395,14 @@ -- has created some pipes, and another thread spawns a process which -- accidentally inherits some of the pipe handles that the first -- thread has created. - -- + -- -- An MVar in Haskell is the best way to do this, because there -- is no way to do one-time thread-safe initialisation of a mutex -- the C code. Also the MVar will be cheaper when not running -- the threaded RTS. proc_handle <- withMVar runInteractiveProcess_lock $ \_ -> throwErrnoIfBadPHandle fun $ - c_runInteractiveProcess pcmdline pWorkDir pEnv + c_runInteractiveProcess pcmdline pWorkDir pEnv fdin fdout fderr pfdStdInput pfdStdOutput pfdStdError ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) @@ -362,6 +419,12 @@ runInteractiveProcess_lock :: MVar () runInteractiveProcess_lock = unsafePerformIO $ newMVar () +startDelegateControlC :: IO () +startDelegateControlC = return () + +endDelegateControlC :: ExitCode -> IO () +endDelegateControlC _ = return () + foreign import ccall unsafe "runInteractiveProcess" c_runInteractiveProcess :: CWString @@ -387,22 +450,18 @@ mbFd :: String -> FD -> StdStream -> IO FD mbFd _ _std CreatePipe = return (-1) mbFd _fun std Inherit = return std -mbFd fun _std (UseHandle hdl) = -#if __GLASGOW_HASKELL__ < 611 - withHandle_ fun hdl $ return . haFD -#else - withHandle fun hdl $ \h@Handle__{haDevice=dev,..} -> +mbFd fun _std (UseHandle hdl) = + withHandle fun hdl $ \Handle__{haDevice=dev,..} -> case cast dev of Just fd -> do -- clear the O_NONBLOCK flag on this FD, if it is set, since -- we're exposing it externally (see #3316) - fd <- FD.setNonBlockingMode fd False - return (Handle__{haDevice=fd,..}, FD.fdFD fd) + fd' <- FD.setNonBlockingMode fd False + return (Handle__{haDevice=fd',..}, FD.fdFD fd') Nothing -> ioError (mkIOError illegalOperationErrorType "createProcess" (Just hdl) Nothing `ioeSetErrorString` "handle is not a file descriptor") -#endif mbPipe :: StdStream -> Ptr FD -> IOMode -> IO (Maybe Handle) mbPipe CreatePipe pfd mode = fmap Just (pfdToHandle pfd mode) @@ -412,26 +471,18 @@ pfdToHandle pfd mode = do fd <- peek pfd let filepath = "fd:" ++ show fd -#if __GLASGOW_HASKELL__ >= 611 - (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode + (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode (Just (Stream,0,0)) -- avoid calling fstat() False {-is_socket-} False {-non-blocking-} - fD <- FD.setNonBlockingMode fD True -- see #3316 + fD' <- FD.setNonBlockingMode fD True -- see #3316 +#if __GLASGOW_HASKELL__ >= 704 enc <- getLocaleEncoding - mkHandleFromFD fD fd_type filepath mode False {-is_socket-} (Just enc) #else - fdToHandle' fd (Just Stream) - False {-Windows: not a socket, Unix: don't set non-blocking-} - filepath mode True {-binary-} -#endif - -#if __GLASGOW_HASKELL__ < 703 -getLocaleEncoding :: IO TextEncoding -getLocaleEncoding = return localeEncoding + let enc = localeEncoding #endif + mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc) -#ifndef __HUGS__ -- ---------------------------------------------------------------------------- -- commandToProcess @@ -440,7 +491,7 @@ There's a difference in the signature of commandToProcess between the Windows and Unix versions. On Unix, exec takes a list of strings, - and we want to pass our command to /bin/sh as a single argument. + and we want to pass our command to /bin/sh as a single argument. On Windows, CreateProcess takes a single string for the command, which is later decomposed by cmd.exe. In this case, we just want @@ -477,14 +528,8 @@ findCommandInterpreter :: IO FilePath findCommandInterpreter = do -- try COMSPEC first -#ifdef base3 - catchJust (\e -> case e of - IOException e | isDoesNotExistError e -> Just e - _otherwise -> Nothing) -#else catchJust (\e -> if isDoesNotExistError e then Just e else Nothing) -#endif - (getEnv "COMSPEC") $ \e -> do + (getEnv "COMSPEC") $ \_ -> do -- try to find CMD.EXE or COMMAND.COM {- @@ -513,13 +558,11 @@ mb_path <- search (splitSearchPath path) case mb_path of - Nothing -> ioError (mkIOError doesNotExistErrorType + Nothing -> ioError (mkIOError doesNotExistErrorType "findCommandInterpreter" Nothing Nothing) Just cmd -> return cmd #endif -#endif /* __HUGS__ */ - -- ------------------------------------------------------------------------ -- Escaping commands for shells @@ -577,20 +620,27 @@ translate :: String -> String #if mingw32_HOST_OS -translate str = '"' : snd (foldr escape (True,"\"") str) - where escape '"' (b, str) = (True, '\\' : '"' : str) +translate xs = '"' : snd (foldr escape (True,"\"") xs) + where escape '"' (_, str) = (True, '\\' : '"' : str) escape '\\' (True, str) = (True, '\\' : '\\' : str) escape '\\' (False, str) = (False, '\\' : str) - escape c (b, str) = (False, c : str) + escape c (_, str) = (False, c : str) -- See long comment above for what this function is trying to do. -- -- The Bool passed back along the string is True iff the -- rest of the string is a sequence of backslashes followed by -- a double quote. #else -translate str = '\'' : foldr escape "'" str +translate "" = "''" +translate str + -- goodChar is a pessimistic predicate, such that if an argument is + -- non-empty and only contains goodChars, then there is no need to + -- do any quoting or escaping + | all goodChar str = str + | otherwise = '\'' : foldr escape "'" str where escape '\'' = showString "'\\''" escape c = showChar c + goodChar c = isAlphaNum c || c `elem` "-_.,/" #endif -- ---------------------------------------------------------------------------- @@ -599,16 +649,12 @@ withFilePathException :: FilePath -> IO a -> IO a withFilePathException fpath act = handle mapEx act where -#ifdef base4 mapEx ex = ioError (ioeSetFileName ex fpath) -#else - mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath)) -#endif #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a withCEnvironment envir act = - let env' = map (\(name, val) -> name ++ ('=':val)) envir + let env' = map (\(name, val) -> name ++ ('=':val)) envir in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act) #else withCEnvironment :: [(String,String)] -> (Ptr CWString -> IO a) -> IO a @@ -617,3 +663,25 @@ in withCWString env' (act . castPtr) #endif + +-- ---------------------------------------------------------------------------- +-- Deprecated / compat + +#ifdef __GLASGOW_HASKELL__ +{-# DEPRECATED runGenProcess_ + "Please do not use this anymore, use the ordinary 'System.Process.createProcess'. If you need the SIGINT handling, use delegate_ctlc = True (runGenProcess_ is now just an imperfectly emulated stub that probably duplicates or overrides your own signal handling)." #-} +runGenProcess_ + :: String -- ^ function name (for error messages) + -> CreateProcess + -> Maybe CLong -- ^ handler for SIGINT + -> Maybe CLong -- ^ handler for SIGQUIT + -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +runGenProcess_ fun c (Just sig) (Just sig') | sig == defaultSignal && sig == sig' + = createProcess_ fun c { delegate_ctlc = True } +runGenProcess_ fun c _ _ = createProcess_ fun c +#else +runGenProcess_ fun c _ _ = createProcess_ fun c +#endif + +#endif diff --git a/cbits/runProcess.c b/cbits/runProcess.c --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -1,538 +1,628 @@ -/* ---------------------------------------------------------------------------- - (c) The University of Glasgow 2004 - - Support for System.Process - ------------------------------------------------------------------------- */ - -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) -#define UNICODE -#endif - -/* XXX This is a nasty hack; should put everything necessary in this package */ -#include "HsBase.h" -#include "Rts.h" - -#include "runProcess.h" - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) - -#include "execvpe.h" - -/* ---------------------------------------------------------------------------- - UNIX versions - ------------------------------------------------------------------------- */ - -static long max_fd = 0; - -// Rts internal API, not exposed in a public header file: -extern void blockUserSignals(void); -extern void unblockUserSignals(void); - -ProcHandle -runInteractiveProcess (char *const args[], - char *workingDirectory, char **environment, - int fdStdIn, int fdStdOut, int fdStdErr, - int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, - int set_inthandler, long inthandler, - int set_quithandler, long quithandler, - int flags) -{ - int close_fds = ((flags & RUN_PROCESS_IN_CLOSE_FDS) != 0); - int pid; - int fdStdInput[2], fdStdOutput[2], fdStdError[2]; - int r; - struct sigaction dfl; - - // Ordering matters here, see below [Note #431]. - if (fdStdIn == -1) { - r = pipe(fdStdInput); - if (r == -1) { - sysErrorBelch("runInteractiveProcess: pipe"); - return -1; - } - - } - if (fdStdOut == -1) { - r = pipe(fdStdOutput); - if (r == -1) { - sysErrorBelch("runInteractiveProcess: pipe"); - return -1; - } - } - if (fdStdErr == -1) { - r = pipe(fdStdError); - if (r == -1) { - sysErrorBelch("runInteractiveProcess: pipe"); - return -1; - } - } - - // Block signals with Haskell handlers. The danger here is that - // with the threaded RTS, a signal arrives in the child process, - // the RTS writes the signal information into the pipe (which is - // shared between parent and child), and the parent behaves as if - // the signal had been raised. - blockUserSignals(); - - // See #4074. Sometimes fork() gets interrupted by the timer - // signal and keeps restarting indefinitely. - stopTimer(); - - switch(pid = fork()) - { - case -1: - unblockUserSignals(); -#if __GLASGOW_HASKELL__ > 612 - startTimer(); -#endif - if (fdStdIn == -1) { - close(fdStdInput[0]); - close(fdStdInput[1]); - } - if (fdStdOut == -1) { - close(fdStdOutput[0]); - close(fdStdOutput[1]); - } - if (fdStdErr == -1) { - close(fdStdError[0]); - close(fdStdError[1]); - } - return -1; - - case 0: - { - // WARNING! we are now in the child of vfork(), so any memory - // we modify below will also be seen in the parent process. - - if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { - setpgid(0, 0); - } - - unblockUserSignals(); - - if (workingDirectory) { - if (chdir (workingDirectory) < 0) { - // See #1593. The convention for the exit code when - // exec() fails seems to be 127 (gleened from C's - // system()), but there's no equivalent convention for - // chdir(), so I'm picking 126 --SimonM. - _exit(126); - } - } - - // [Note #431]: Ordering matters here. If any of the FDs - // 0,1,2 were initially closed, then our pipes may have used - // these FDs. So when we dup2 the pipe FDs down to 0,1,2, we - // must do it in that order, otherwise we could overwrite an - // FD that we need later. - - if (fdStdIn == -1) { - if (fdStdInput[0] != STDIN_FILENO) { - dup2 (fdStdInput[0], STDIN_FILENO); - close(fdStdInput[0]); - } - close(fdStdInput[1]); - } else { - dup2(fdStdIn, STDIN_FILENO); - } - - if (fdStdOut == -1) { - if (fdStdOutput[1] != STDOUT_FILENO) { - dup2 (fdStdOutput[1], STDOUT_FILENO); - close(fdStdOutput[1]); - } - close(fdStdOutput[0]); - } else { - dup2(fdStdOut, STDOUT_FILENO); - } - - if (fdStdErr == -1) { - if (fdStdError[1] != STDERR_FILENO) { - dup2 (fdStdError[1], STDERR_FILENO); - close(fdStdError[1]); - } - close(fdStdError[0]); - } else { - dup2(fdStdErr, STDERR_FILENO); - } - - if (close_fds) { - int i; - if (max_fd == 0) { -#if HAVE_SYSCONF - max_fd = sysconf(_SC_OPEN_MAX); - if (max_fd == -1) { - max_fd = 256; - } -#else - max_fd = 256; -#endif - } - for (i = 3; i < max_fd; i++) { - close(i); - } - } - - /* Set the SIGINT/SIGQUIT signal handlers in the child, if requested - */ - (void)sigemptyset(&dfl.sa_mask); - dfl.sa_flags = 0; - if (set_inthandler) { - dfl.sa_handler = (void *)inthandler; - (void)sigaction(SIGINT, &dfl, NULL); - } - if (set_quithandler) { - dfl.sa_handler = (void *)quithandler; - (void)sigaction(SIGQUIT, &dfl, NULL); - } - - /* the child */ - if (environment) { - execvpe(args[0], args, environment); - } else { - execvp(args[0], args); - } - } - _exit(127); - - default: - if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { - setpgid(pid, pid); - } - if (fdStdIn == -1) { - close(fdStdInput[0]); - fcntl(fdStdInput[1], F_SETFD, FD_CLOEXEC); - *pfdStdInput = fdStdInput[1]; - } - if (fdStdOut == -1) { - close(fdStdOutput[1]); - fcntl(fdStdOutput[0], F_SETFD, FD_CLOEXEC); - *pfdStdOutput = fdStdOutput[0]; - } - if (fdStdErr == -1) { - close(fdStdError[1]); - fcntl(fdStdError[0], F_SETFD, FD_CLOEXEC); - *pfdStdError = fdStdError[0]; - } - break; - } - unblockUserSignals(); - startTimer(); - - return pid; -} - -int -terminateProcess (ProcHandle handle) -{ - return (kill(handle, SIGTERM) == 0); -} - -int -getProcessExitCode (ProcHandle handle, int *pExitCode) -{ - int wstat, res; - - *pExitCode = 0; - - if ((res = waitpid(handle, &wstat, WNOHANG)) > 0) - { - if (WIFEXITED(wstat)) - { - *pExitCode = WEXITSTATUS(wstat); - return 1; - } - else - if (WIFSIGNALED(wstat)) - { - errno = EINTR; - return -1; - } - else - { - /* This should never happen */ - } - } - - if (res == 0) return 0; - - if (errno == ECHILD) - { - *pExitCode = 0; - return 1; - } - - return -1; -} - -int waitForProcess (ProcHandle handle, int *pret) -{ - int wstat; - - if (waitpid(handle, &wstat, 0) < 0) - { - return -1; - } - - if (WIFEXITED(wstat)) { - *pret = WEXITSTATUS(wstat); - return 0; - } - else - if (WIFSIGNALED(wstat)) - { - *pret = wstat; - return 0; - } - else - { - /* This should never happen */ - } - - return -1; -} - -#else -/* ---------------------------------------------------------------------------- - Win32 versions - ------------------------------------------------------------------------- */ - -/* -------------------- WINDOWS VERSION --------------------- */ - -/* - * Function: mkAnonPipe - * - * Purpose: create an anonymous pipe with read and write ends being - * optionally (non-)inheritable. - */ -static BOOL -mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn, - HANDLE* pHandleOut, BOOL isInheritableOut) -{ - HANDLE hTemporaryIn = NULL; - HANDLE hTemporaryOut = NULL; - - /* Create the anon pipe with both ends inheritable */ - if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, NULL, 0)) - { - maperrno(); - *pHandleIn = NULL; - *pHandleOut = NULL; - return FALSE; - } - - if (isInheritableIn) { - // SetHandleInformation requires at least Win2k - if (!SetHandleInformation(hTemporaryIn, - HANDLE_FLAG_INHERIT, - HANDLE_FLAG_INHERIT)) - { - maperrno(); - *pHandleIn = NULL; - *pHandleOut = NULL; - CloseHandle(hTemporaryIn); - CloseHandle(hTemporaryOut); - return FALSE; - } - } - *pHandleIn = hTemporaryIn; - - if (isInheritableOut) { - if (!SetHandleInformation(hTemporaryOut, - HANDLE_FLAG_INHERIT, - HANDLE_FLAG_INHERIT)) - { - maperrno(); - *pHandleIn = NULL; - *pHandleOut = NULL; - CloseHandle(hTemporaryIn); - CloseHandle(hTemporaryOut); - return FALSE; - } - } - *pHandleOut = hTemporaryOut; - - return TRUE; -} - -ProcHandle -runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, - wchar_t *environment, - int fdStdIn, int fdStdOut, int fdStdErr, - int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, - int flags) -{ - STARTUPINFO sInfo; - PROCESS_INFORMATION pInfo; - HANDLE hStdInputRead = INVALID_HANDLE_VALUE; - HANDLE hStdInputWrite = INVALID_HANDLE_VALUE; - HANDLE hStdOutputRead = INVALID_HANDLE_VALUE; - HANDLE hStdOutputWrite = INVALID_HANDLE_VALUE; - HANDLE hStdErrorRead = INVALID_HANDLE_VALUE; - HANDLE hStdErrorWrite = INVALID_HANDLE_VALUE; - BOOL close_fds = ((flags & RUN_PROCESS_IN_CLOSE_FDS) != 0); - // We always pass a wide environment block, so we MUST set this flag - DWORD dwFlags = CREATE_UNICODE_ENVIRONMENT; - BOOL status; - BOOL inherit; - - ZeroMemory(&sInfo, sizeof(sInfo)); - sInfo.cb = sizeof(sInfo); - sInfo.dwFlags = STARTF_USESTDHANDLES; - - if (fdStdIn == -1) { - if (!mkAnonPipe(&hStdInputRead, TRUE, &hStdInputWrite, FALSE)) - goto cleanup_err; - sInfo.hStdInput = hStdInputRead; - } else if (fdStdIn == 0) { - // Don't duplicate stdin, as console handles cannot be - // duplicated and inherited. urg. - sInfo.hStdInput = GetStdHandle(STD_INPUT_HANDLE); - } else { - // The handle might not be inheritable, so duplicate it - status = DuplicateHandle(GetCurrentProcess(), - (HANDLE) _get_osfhandle(fdStdIn), - GetCurrentProcess(), &hStdInputRead, - 0, - TRUE, /* inheritable */ - DUPLICATE_SAME_ACCESS); - if (!status) goto cleanup_err; - sInfo.hStdInput = hStdInputRead; - } - - if (fdStdOut == -1) { - if (!mkAnonPipe(&hStdOutputRead, FALSE, &hStdOutputWrite, TRUE)) - goto cleanup_err; - sInfo.hStdOutput = hStdOutputWrite; - } else if (fdStdOut == 1) { - // Don't duplicate stdout, as console handles cannot be - // duplicated and inherited. urg. - sInfo.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); - } else { - // The handle might not be inheritable, so duplicate it - status = DuplicateHandle(GetCurrentProcess(), - (HANDLE) _get_osfhandle(fdStdOut), - GetCurrentProcess(), &hStdOutputWrite, - 0, - TRUE, /* inheritable */ - DUPLICATE_SAME_ACCESS); - if (!status) goto cleanup_err; - sInfo.hStdOutput = hStdOutputWrite; - } - - if (fdStdErr == -1) { - if (!mkAnonPipe(&hStdErrorRead, TRUE, &hStdErrorWrite, TRUE)) - goto cleanup_err; - sInfo.hStdError = hStdErrorWrite; - } else if (fdStdErr == 2) { - // Don't duplicate stderr, as console handles cannot be - // duplicated and inherited. urg. - sInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE); - } else { - /* The handle might not be inheritable, so duplicate it */ - status = DuplicateHandle(GetCurrentProcess(), - (HANDLE) _get_osfhandle(fdStdErr), - GetCurrentProcess(), &hStdErrorWrite, - 0, - TRUE, /* inheritable */ - DUPLICATE_SAME_ACCESS); - if (!status) goto cleanup_err; - sInfo.hStdError = hStdErrorWrite; - } - - if (sInfo.hStdInput != GetStdHandle(STD_INPUT_HANDLE) && - sInfo.hStdOutput != GetStdHandle(STD_OUTPUT_HANDLE) && - sInfo.hStdError != GetStdHandle(STD_ERROR_HANDLE) && - (flags & RUN_PROCESS_IN_NEW_GROUP) == 0) - dwFlags |= CREATE_NO_WINDOW; // Run without console window only when both output and error are redirected - - // See #3231 - if (close_fds && fdStdIn == 0 && fdStdOut == 1 && fdStdErr == 2) { - inherit = FALSE; - } else { - inherit = TRUE; - } - - if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { - dwFlags |= CREATE_NEW_PROCESS_GROUP; - } - - if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, dwFlags, environment, workingDirectory, &sInfo, &pInfo)) - { - goto cleanup_err; - } - CloseHandle(pInfo.hThread); - - // Close the ends of the pipes that were inherited by the - // child process. This is important, otherwise we won't see - // EOF on these pipes when the child process exits. - if (hStdInputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdInputRead); - if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); - if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); - - *pfdStdInput = _open_osfhandle((intptr_t) hStdInputWrite, _O_WRONLY); - *pfdStdOutput = _open_osfhandle((intptr_t) hStdOutputRead, _O_RDONLY); - *pfdStdError = _open_osfhandle((intptr_t) hStdErrorRead, _O_RDONLY); - - return pInfo.hProcess; - -cleanup_err: - if (hStdInputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdInputRead); - if (hStdInputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdInputWrite); - if (hStdOutputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputRead); - if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); - if (hStdErrorRead != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorRead); - if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); - maperrno(); - return NULL; -} - -int -terminateProcess (ProcHandle handle) -{ - if (!TerminateProcess((HANDLE) handle, 1)) { - maperrno(); - return -1; - } - return 0; -} - -int -getProcessExitCode (ProcHandle handle, int *pExitCode) -{ - *pExitCode = 0; - - if (WaitForSingleObject((HANDLE) handle, 1) == WAIT_OBJECT_0) - { - if (GetExitCodeProcess((HANDLE) handle, (DWORD *) pExitCode) == 0) - { - maperrno(); - return -1; - } - return 1; - } - - return 0; -} - -int -waitForProcess (ProcHandle handle, int *pret) -{ - DWORD retCode; - - if (WaitForSingleObject((HANDLE) handle, INFINITE) == WAIT_OBJECT_0) - { - if (GetExitCodeProcess((HANDLE) handle, &retCode) == 0) - { - maperrno(); - return -1; - } - *pret = retCode; - return 0; - } - - maperrno(); - return -1; -} - -#endif /* Win32 */ +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Support for System.Process + ------------------------------------------------------------------------- */ + +#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +#define UNICODE +#endif + +/* XXX This is a nasty hack; should put everything necessary in this package */ +#include "HsBase.h" +#include "Rts.h" + +#include "runProcess.h" + +#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) + +#include "execvpe.h" + +/* ---------------------------------------------------------------------------- + UNIX versions + ------------------------------------------------------------------------- */ + +// If a process was terminated by a signal, the exit status we return +// via the System.Process API is (-signum). This encoding avoids collision with +// normal process termination status codes. See also #7229. +#define TERMSIG_EXITSTATUS(s) (-(WTERMSIG(s))) + +static long max_fd = 0; + +// Rts internal API, not exposed in a public header file: +extern void blockUserSignals(void); +extern void unblockUserSignals(void); + +// See #1593. The convention for the exit code when +// exec() fails seems to be 127 (gleened from C's +// system()), but there's no equivalent convention for +// chdir(), so I'm picking 126 --SimonM. +#define forkChdirFailed 126 +#define forkExecFailed 127 + +__attribute__((__noreturn__)) +static void childFailed(int pipe, int failCode) { + int err; + ssize_t unused __attribute__((unused)); + + err = errno; + unused = write(pipe, &failCode, sizeof(failCode)); + unused = write(pipe, &err, sizeof(err)); + // As a fallback, exit with the failCode + _exit(failCode); +} + +ProcHandle +runInteractiveProcess (char *const args[], + char *workingDirectory, char **environment, + int fdStdIn, int fdStdOut, int fdStdErr, + int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, + int reset_int_quit_handlers, + int flags, + char **failed_doing) +{ + int close_fds = ((flags & RUN_PROCESS_IN_CLOSE_FDS) != 0); + int pid; + int fdStdInput[2], fdStdOutput[2], fdStdError[2]; + int forkCommunicationFds[2]; + int r; + int failCode, err; + + // Ordering matters here, see below [Note #431]. + if (fdStdIn == -1) { + r = pipe(fdStdInput); + if (r == -1) { + *failed_doing = "runInteractiveProcess: pipe"; + return -1; + } + } + if (fdStdOut == -1) { + r = pipe(fdStdOutput); + if (r == -1) { + *failed_doing = "runInteractiveProcess: pipe"; + return -1; + } + } + if (fdStdErr == -1) { + r = pipe(fdStdError); + if (r == -1) { + *failed_doing = "runInteractiveProcess: pipe"; + return -1; + } + } + + r = pipe(forkCommunicationFds); + if (r == -1) { + *failed_doing = "runInteractiveProcess: pipe"; + return -1; + } + + // Block signals with Haskell handlers. The danger here is that + // with the threaded RTS, a signal arrives in the child process, + // the RTS writes the signal information into the pipe (which is + // shared between parent and child), and the parent behaves as if + // the signal had been raised. + blockUserSignals(); + + // See #4074. Sometimes fork() gets interrupted by the timer + // signal and keeps restarting indefinitely. + stopTimer(); + + switch(pid = myfork()) + { + case -1: + unblockUserSignals(); + startTimer(); + if (fdStdIn == -1) { + close(fdStdInput[0]); + close(fdStdInput[1]); + } + if (fdStdOut == -1) { + close(fdStdOutput[0]); + close(fdStdOutput[1]); + } + if (fdStdErr == -1) { + close(fdStdError[0]); + close(fdStdError[1]); + } + close(forkCommunicationFds[0]); + close(forkCommunicationFds[1]); + *failed_doing = "fork"; + return -1; + + case 0: + // WARNING! We may now be in the child of vfork(), and any + // memory we modify below may also be seen in the parent + // process. + + close(forkCommunicationFds[0]); + fcntl(forkCommunicationFds[1], F_SETFD, FD_CLOEXEC); + + if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { + setpgid(0, 0); + } + + unblockUserSignals(); + + if (workingDirectory) { + if (chdir (workingDirectory) < 0) { + childFailed(forkCommunicationFds[1], forkChdirFailed); + } + } + + // [Note #431]: Ordering matters here. If any of the FDs + // 0,1,2 were initially closed, then our pipes may have used + // these FDs. So when we dup2 the pipe FDs down to 0,1,2, we + // must do it in that order, otherwise we could overwrite an + // FD that we need later. + + if (fdStdIn == -1) { + if (fdStdInput[0] != STDIN_FILENO) { + dup2 (fdStdInput[0], STDIN_FILENO); + close(fdStdInput[0]); + } + close(fdStdInput[1]); + } else { + dup2(fdStdIn, STDIN_FILENO); + } + + if (fdStdOut == -1) { + if (fdStdOutput[1] != STDOUT_FILENO) { + dup2 (fdStdOutput[1], STDOUT_FILENO); + close(fdStdOutput[1]); + } + close(fdStdOutput[0]); + } else { + dup2(fdStdOut, STDOUT_FILENO); + } + + if (fdStdErr == -1) { + if (fdStdError[1] != STDERR_FILENO) { + dup2 (fdStdError[1], STDERR_FILENO); + close(fdStdError[1]); + } + close(fdStdError[0]); + } else { + dup2(fdStdErr, STDERR_FILENO); + } + + if (close_fds) { + int i; + if (max_fd == 0) { +#if HAVE_SYSCONF + max_fd = sysconf(_SC_OPEN_MAX); + if (max_fd == -1) { + max_fd = 256; + } +#else + max_fd = 256; +#endif + } + // XXX Not the pipe + for (i = 3; i < max_fd; i++) { + close(i); + } + } + + /* Reset the SIGINT/SIGQUIT signal handlers in the child, if requested + */ + if (reset_int_quit_handlers) { + struct sigaction dfl; + (void)sigemptyset(&dfl.sa_mask); + dfl.sa_flags = 0; + dfl.sa_handler = SIG_DFL; + (void)sigaction(SIGINT, &dfl, NULL); + (void)sigaction(SIGQUIT, &dfl, NULL); + } + + /* the child */ + if (environment) { + // XXX Check result + execvpe(args[0], args, environment); + } else { + // XXX Check result + execvp(args[0], args); + } + + childFailed(forkCommunicationFds[1], forkExecFailed); + + default: + if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { + setpgid(pid, pid); + } + if (fdStdIn == -1) { + close(fdStdInput[0]); + fcntl(fdStdInput[1], F_SETFD, FD_CLOEXEC); + *pfdStdInput = fdStdInput[1]; + } + if (fdStdOut == -1) { + close(fdStdOutput[1]); + fcntl(fdStdOutput[0], F_SETFD, FD_CLOEXEC); + *pfdStdOutput = fdStdOutput[0]; + } + if (fdStdErr == -1) { + close(fdStdError[1]); + fcntl(fdStdError[0], F_SETFD, FD_CLOEXEC); + *pfdStdError = fdStdError[0]; + } + close(forkCommunicationFds[1]); + fcntl(forkCommunicationFds[0], F_SETFD, FD_CLOEXEC); + + break; + } + + // If the child process had a problem, then it will tell us via the + // forkCommunicationFds pipe. First we try to read what the problem + // was. Note that if none of these conditionals match then we fall + // through and just return pid. + r = read(forkCommunicationFds[0], &failCode, sizeof(failCode)); + if (r == -1) { + *failed_doing = "runInteractiveProcess: read pipe"; + pid = -1; + } + else if (r == sizeof(failCode)) { + // This is the case where we successfully managed to read + // the problem + switch (failCode) { + case forkChdirFailed: + *failed_doing = "runInteractiveProcess: chdir"; + break; + case forkExecFailed: + *failed_doing = "runInteractiveProcess: exec"; + break; + default: + *failed_doing = "runInteractiveProcess: unknown"; + break; + } + // Now we try to get the errno from the child + r = read(forkCommunicationFds[0], &err, sizeof(err)); + if (r == -1) { + *failed_doing = "runInteractiveProcess: read pipe"; + } + else if (r != sizeof(failCode)) { + *failed_doing = "runInteractiveProcess: read pipe bad length"; + } + else { + // If we succeed then we set errno. It'll be saved and + // restored again below. Note that in any other case we'll + // get the errno of whatever else went wrong instead. + errno = err; + } + pid = -1; + } + else if (r != 0) { + *failed_doing = "runInteractiveProcess: read pipe bad length"; + pid = -1; + } + + if (pid == -1) { + err = errno; + } + + close(forkCommunicationFds[0]); + + unblockUserSignals(); + startTimer(); + + if (pid == -1) { + errno = err; + } + + return pid; +} + +int +terminateProcess (ProcHandle handle) +{ + return (kill(handle, SIGTERM) == 0); +} + +int +getProcessExitCode (ProcHandle handle, int *pExitCode) +{ + int wstat, res; + + *pExitCode = 0; + + if ((res = waitpid(handle, &wstat, WNOHANG)) > 0) + { + if (WIFEXITED(wstat)) + { + *pExitCode = WEXITSTATUS(wstat); + return 1; + } + else + if (WIFSIGNALED(wstat)) + { + *pExitCode = TERMSIG_EXITSTATUS(wstat); + return 1; + } + else + { + /* This should never happen */ + } + } + + if (res == 0) return 0; + + if (errno == ECHILD) + { + *pExitCode = 0; + return 1; + } + + return -1; +} + +int waitForProcess (ProcHandle handle, int *pret) +{ + int wstat; + + if (waitpid(handle, &wstat, 0) < 0) + { + return -1; + } + + if (WIFEXITED(wstat)) { + *pret = WEXITSTATUS(wstat); + return 0; + } + else { + if (WIFSIGNALED(wstat)) + { + *pret = TERMSIG_EXITSTATUS(wstat); + return 0; + } + else + { + /* This should never happen */ + } + } + + return -1; +} + +#else +/* ---------------------------------------------------------------------------- + Win32 versions + ------------------------------------------------------------------------- */ + +/* -------------------- WINDOWS VERSION --------------------- */ + +/* + * Function: mkAnonPipe + * + * Purpose: create an anonymous pipe with read and write ends being + * optionally (non-)inheritable. + */ +static BOOL +mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn, + HANDLE* pHandleOut, BOOL isInheritableOut) +{ + HANDLE hTemporaryIn = NULL; + HANDLE hTemporaryOut = NULL; + + /* Create the anon pipe with both ends inheritable */ + if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, NULL, 0)) + { + maperrno(); + *pHandleIn = NULL; + *pHandleOut = NULL; + return FALSE; + } + + if (isInheritableIn) { + // SetHandleInformation requires at least Win2k + if (!SetHandleInformation(hTemporaryIn, + HANDLE_FLAG_INHERIT, + HANDLE_FLAG_INHERIT)) + { + maperrno(); + *pHandleIn = NULL; + *pHandleOut = NULL; + CloseHandle(hTemporaryIn); + CloseHandle(hTemporaryOut); + return FALSE; + } + } + *pHandleIn = hTemporaryIn; + + if (isInheritableOut) { + if (!SetHandleInformation(hTemporaryOut, + HANDLE_FLAG_INHERIT, + HANDLE_FLAG_INHERIT)) + { + maperrno(); + *pHandleIn = NULL; + *pHandleOut = NULL; + CloseHandle(hTemporaryIn); + CloseHandle(hTemporaryOut); + return FALSE; + } + } + *pHandleOut = hTemporaryOut; + + return TRUE; +} + +ProcHandle +runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, + wchar_t *environment, + int fdStdIn, int fdStdOut, int fdStdErr, + int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, + int flags) +{ + STARTUPINFO sInfo; + PROCESS_INFORMATION pInfo; + HANDLE hStdInputRead = INVALID_HANDLE_VALUE; + HANDLE hStdInputWrite = INVALID_HANDLE_VALUE; + HANDLE hStdOutputRead = INVALID_HANDLE_VALUE; + HANDLE hStdOutputWrite = INVALID_HANDLE_VALUE; + HANDLE hStdErrorRead = INVALID_HANDLE_VALUE; + HANDLE hStdErrorWrite = INVALID_HANDLE_VALUE; + BOOL close_fds = ((flags & RUN_PROCESS_IN_CLOSE_FDS) != 0); + // We always pass a wide environment block, so we MUST set this flag + DWORD dwFlags = CREATE_UNICODE_ENVIRONMENT; + BOOL status; + BOOL inherit; + + ZeroMemory(&sInfo, sizeof(sInfo)); + sInfo.cb = sizeof(sInfo); + sInfo.dwFlags = STARTF_USESTDHANDLES; + + if (fdStdIn == -1) { + if (!mkAnonPipe(&hStdInputRead, TRUE, &hStdInputWrite, FALSE)) + goto cleanup_err; + sInfo.hStdInput = hStdInputRead; + } else if (fdStdIn == 0) { + // Don't duplicate stdin, as console handles cannot be + // duplicated and inherited. urg. + sInfo.hStdInput = GetStdHandle(STD_INPUT_HANDLE); + } else { + // The handle might not be inheritable, so duplicate it + status = DuplicateHandle(GetCurrentProcess(), + (HANDLE) _get_osfhandle(fdStdIn), + GetCurrentProcess(), &hStdInputRead, + 0, + TRUE, /* inheritable */ + DUPLICATE_SAME_ACCESS); + if (!status) goto cleanup_err; + sInfo.hStdInput = hStdInputRead; + } + + if (fdStdOut == -1) { + if (!mkAnonPipe(&hStdOutputRead, FALSE, &hStdOutputWrite, TRUE)) + goto cleanup_err; + sInfo.hStdOutput = hStdOutputWrite; + } else if (fdStdOut == 1) { + // Don't duplicate stdout, as console handles cannot be + // duplicated and inherited. urg. + sInfo.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); + } else { + // The handle might not be inheritable, so duplicate it + status = DuplicateHandle(GetCurrentProcess(), + (HANDLE) _get_osfhandle(fdStdOut), + GetCurrentProcess(), &hStdOutputWrite, + 0, + TRUE, /* inheritable */ + DUPLICATE_SAME_ACCESS); + if (!status) goto cleanup_err; + sInfo.hStdOutput = hStdOutputWrite; + } + + if (fdStdErr == -1) { + if (!mkAnonPipe(&hStdErrorRead, TRUE, &hStdErrorWrite, TRUE)) + goto cleanup_err; + sInfo.hStdError = hStdErrorWrite; + } else if (fdStdErr == 2) { + // Don't duplicate stderr, as console handles cannot be + // duplicated and inherited. urg. + sInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE); + } else { + /* The handle might not be inheritable, so duplicate it */ + status = DuplicateHandle(GetCurrentProcess(), + (HANDLE) _get_osfhandle(fdStdErr), + GetCurrentProcess(), &hStdErrorWrite, + 0, + TRUE, /* inheritable */ + DUPLICATE_SAME_ACCESS); + if (!status) goto cleanup_err; + sInfo.hStdError = hStdErrorWrite; + } + + if (sInfo.hStdInput != GetStdHandle(STD_INPUT_HANDLE) && + sInfo.hStdOutput != GetStdHandle(STD_OUTPUT_HANDLE) && + sInfo.hStdError != GetStdHandle(STD_ERROR_HANDLE) && + (flags & RUN_PROCESS_IN_NEW_GROUP) == 0) + dwFlags |= CREATE_NO_WINDOW; // Run without console window only when both output and error are redirected + + // See #3231 + if (close_fds && fdStdIn == 0 && fdStdOut == 1 && fdStdErr == 2) { + inherit = FALSE; + } else { + inherit = TRUE; + } + + if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { + dwFlags |= CREATE_NEW_PROCESS_GROUP; + } + + if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, dwFlags, environment, workingDirectory, &sInfo, &pInfo)) + { + goto cleanup_err; + } + CloseHandle(pInfo.hThread); + + // Close the ends of the pipes that were inherited by the + // child process. This is important, otherwise we won't see + // EOF on these pipes when the child process exits. + if (hStdInputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdInputRead); + if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); + if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); + + *pfdStdInput = _open_osfhandle((intptr_t) hStdInputWrite, _O_WRONLY); + *pfdStdOutput = _open_osfhandle((intptr_t) hStdOutputRead, _O_RDONLY); + *pfdStdError = _open_osfhandle((intptr_t) hStdErrorRead, _O_RDONLY); + + return pInfo.hProcess; + +cleanup_err: + if (hStdInputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdInputRead); + if (hStdInputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdInputWrite); + if (hStdOutputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputRead); + if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); + if (hStdErrorRead != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorRead); + if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); + maperrno(); + return NULL; +} + +int +terminateProcess (ProcHandle handle) +{ + if (!TerminateProcess((HANDLE) handle, 1)) { + maperrno(); + return -1; + } + return 0; +} + +int +getProcessExitCode (ProcHandle handle, int *pExitCode) +{ + *pExitCode = 0; + + if (WaitForSingleObject((HANDLE) handle, 1) == WAIT_OBJECT_0) + { + if (GetExitCodeProcess((HANDLE) handle, (DWORD *) pExitCode) == 0) + { + maperrno(); + return -1; + } + return 1; + } + + return 0; +} + +int +waitForProcess (ProcHandle handle, int *pret) +{ + DWORD retCode; + + if (WaitForSingleObject((HANDLE) handle, INFINITE) == WAIT_OBJECT_0) + { + if (GetExitCodeProcess((HANDLE) handle, &retCode) == 0) + { + maperrno(); + return -1; + } + *pret = retCode; + return 0; + } + + maperrno(); + return -1; +} + +#endif /* Win32 */ diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,15 @@ +1.2.0.0 Dec 2013 + + * Update to Cabal 1.10 format + * Remove NHC specific code + * Add support for `base-4.7.0.0` + * Improve `showCommandForUser` to reduce redundant quoting + * New functions `callProcess`, `callCommand`, `spawnProcess` and `spawnCommand` + * Implement WCE handling according to http://www.cons.org/cracauer/sigint.html + * New `delegate_ctlc` field in `CreateProcess` for WCE handling + * Use `ExitFailure (-signum)` on Unix when a proc is terminated due to + a signal. + * Deprecate `module System.Cmd` + * On non-Windows, the child thread now comunicates any errors back + to the parent thread via pipes. + * Fix deadlocks in `readProcess` and `readProcessWithExitCode` diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,13 +1,11 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.67 for Haskell process package 1.0. +# Generated by GNU Autoconf 2.69 for Haskell process package 1.0. # # Report bugs to . # # -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, -# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software -# Foundation, Inc. +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation @@ -91,6 +89,7 @@ IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. +as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -135,6 +134,31 @@ # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh @@ -168,7 +192,8 @@ else exitcode=1; echo positional parameters were not saved. fi -test x\$exitcode = x0 || exit 1" +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && @@ -213,14 +238,25 @@ if test "x$CONFIG_SHELL" != x; then : - # We cannot yet assume a decent shell, so we have to provide a - # neutralization value for shells without unset; and this also - # works around shells that cannot unset nonexistent variables. - BASH_ENV=/dev/null - ENV=/dev/null - (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV - export CONFIG_SHELL - exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 fi if test x$as_have_required = xno; then : @@ -323,6 +359,14 @@ } # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take @@ -444,6 +488,10 @@ chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). @@ -478,16 +526,16 @@ # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' + as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null @@ -499,28 +547,8 @@ as_mkdir_p=false fi -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in #( - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x +as_test_x='test -x' +as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" @@ -1062,7 +1090,7 @@ $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac @@ -1113,8 +1141,6 @@ if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe - $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. - If a cross compiler is detected then cross compile mode will be used" >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi @@ -1347,9 +1373,9 @@ if $ac_init_version; then cat <<\_ACEOF Haskell process package configure 1.0 -generated by GNU Autoconf 2.67 +generated by GNU Autoconf 2.69 -Copyright (C) 2010 Free Software Foundation, Inc. +Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF @@ -1393,7 +1419,7 @@ ac_retval=1 fi - eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile @@ -1407,7 +1433,7 @@ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } -if eval "test \"\${$3+set}\"" = set; then : +if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=no" @@ -1448,7 +1474,7 @@ eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } - eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_type @@ -1484,7 +1510,7 @@ ac_retval=1 fi - eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp @@ -1526,7 +1552,7 @@ ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run @@ -1540,7 +1566,7 @@ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } -if eval "test \"\${$3+set}\"" = set; then : +if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -1558,7 +1584,7 @@ eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } - eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile @@ -1570,10 +1596,10 @@ ac_fn_c_check_header_mongrel () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if eval "test \"\${$3+set}\"" = set; then : + if eval \${$3+:} false; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } -if eval "test \"\${$3+set}\"" = set; then : +if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 fi eval ac_res=\$$3 @@ -1640,7 +1666,7 @@ esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } -if eval "test \"\${$3+set}\"" = set; then : +if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=\$ac_header_compiler" @@ -1649,7 +1675,7 @@ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi - eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_mongrel @@ -1680,7 +1706,7 @@ test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext + test -x conftest$ac_exeext }; then : ac_retval=0 else @@ -1694,7 +1720,7 @@ # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_link @@ -1707,7 +1733,7 @@ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } -if eval "test \"\${$3+set}\"" = set; then : +if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -1762,7 +1788,7 @@ eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } - eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_func @@ -1783,7 +1809,8 @@ main () { static int test_array [1 - 2 * !(($2) >= 0)]; -test_array [0] = 0 +test_array [0] = 0; +return test_array [0]; ; return 0; @@ -1799,7 +1826,8 @@ main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; -test_array [0] = 0 +test_array [0] = 0; +return test_array [0]; ; return 0; @@ -1825,7 +1853,8 @@ main () { static int test_array [1 - 2 * !(($2) < 0)]; -test_array [0] = 0 +test_array [0] = 0; +return test_array [0]; ; return 0; @@ -1841,7 +1870,8 @@ main () { static int test_array [1 - 2 * !(($2) >= $ac_mid)]; -test_array [0] = 0 +test_array [0] = 0; +return test_array [0]; ; return 0; @@ -1875,7 +1905,8 @@ main () { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; -test_array [0] = 0 +test_array [0] = 0; +return test_array [0]; ; return 0; @@ -1939,7 +1970,7 @@ rm -f conftest.val fi - eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_compute_int @@ -1948,7 +1979,7 @@ running configure, to aid debugging if configure makes a mistake. It was created by Haskell process package $as_me 1.0, which was -generated by GNU Autoconf 2.67. Invocation command line was +generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -2206,7 +2237,7 @@ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5 ; } +See \`config.log' for more details" "$LINENO" 5; } fi done @@ -2318,7 +2349,7 @@ set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_CC+set}" = set; then : +if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then @@ -2330,7 +2361,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2358,7 +2389,7 @@ set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_ac_ct_CC+set}" = set; then : +if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then @@ -2370,7 +2401,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2411,7 +2442,7 @@ set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_CC+set}" = set; then : +if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then @@ -2423,7 +2454,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2451,7 +2482,7 @@ set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_CC+set}" = set; then : +if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then @@ -2464,7 +2495,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue @@ -2510,7 +2541,7 @@ set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_CC+set}" = set; then : +if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then @@ -2522,7 +2553,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2554,7 +2585,7 @@ set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_ac_ct_CC+set}" = set; then : +if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then @@ -2566,7 +2597,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2609,7 +2640,7 @@ test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH -See \`config.log' for more details" "$LINENO" 5 ; } +See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 @@ -2724,7 +2755,7 @@ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5 ; } +See \`config.log' for more details" "$LINENO" 5; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } @@ -2767,7 +2798,7 @@ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details" "$LINENO" 5 ; } +See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 @@ -2826,7 +2857,7 @@ $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run C compiled programs. If you meant to cross compile, use \`--host'. -See \`config.log' for more details" "$LINENO" 5 ; } +See \`config.log' for more details" "$LINENO" 5; } fi fi fi @@ -2837,7 +2868,7 @@ ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } -if test "${ac_cv_objext+set}" = set; then : +if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -2878,7 +2909,7 @@ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile -See \`config.log' for more details" "$LINENO" 5 ; } +See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi @@ -2888,7 +2919,7 @@ ac_objext=$OBJEXT { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } -if test "${ac_cv_c_compiler_gnu+set}" = set; then : +if ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -2925,7 +2956,7 @@ ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } -if test "${ac_cv_prog_cc_g+set}" = set; then : +if ${ac_cv_prog_cc_g+:} false; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag @@ -3003,7 +3034,7 @@ fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } -if test "${ac_cv_prog_cc_c89+set}" = set; then : +if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no @@ -3012,8 +3043,7 @@ /* end confdefs.h. */ #include #include -#include -#include +struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); @@ -3112,7 +3142,7 @@ CPP= fi if test -z "$CPP"; then - if test "${ac_cv_prog_CPP+set}" = set; then : + if ${ac_cv_prog_CPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded @@ -3228,7 +3258,7 @@ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check -See \`config.log' for more details" "$LINENO" 5 ; } +See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c @@ -3240,7 +3270,7 @@ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } -if test "${ac_cv_path_GREP+set}" = set; then : +if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then @@ -3254,7 +3284,7 @@ for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" - { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue + as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in @@ -3303,7 +3333,7 @@ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } -if test "${ac_cv_path_EGREP+set}" = set; then : +if ${ac_cv_path_EGREP+:} false; then : $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 @@ -3320,7 +3350,7 @@ for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" - { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue + as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in @@ -3370,7 +3400,7 @@ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } -if test "${ac_cv_header_stdc+set}" = set; then : +if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -3498,7 +3528,7 @@ ac_fn_c_check_type "$LINENO" "pid_t" "ac_cv_type_pid_t" "$ac_includes_default" -if test "x$ac_cv_type_pid_t" = x""yes; then : +if test "x$ac_cv_type_pid_t" = xyes; then : else @@ -3511,7 +3541,7 @@ for ac_header in vfork.h do : ac_fn_c_check_header_mongrel "$LINENO" "vfork.h" "ac_cv_header_vfork_h" "$ac_includes_default" -if test "x$ac_cv_header_vfork_h" = x""yes; then : +if test "x$ac_cv_header_vfork_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_VFORK_H 1 _ACEOF @@ -3535,7 +3565,7 @@ if test "x$ac_cv_func_fork" = xyes; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working fork" >&5 $as_echo_n "checking for working fork... " >&6; } -if test "${ac_cv_func_fork_works+set}" = set; then : +if ${ac_cv_func_fork_works+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : @@ -3588,7 +3618,7 @@ if test "x$ac_cv_func_vfork" = xyes; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working vfork" >&5 $as_echo_n "checking for working vfork... " >&6; } -if test "${ac_cv_func_vfork_works+set}" = set; then : +if ${ac_cv_func_vfork_works+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : @@ -3737,7 +3767,7 @@ done -for ac_func in setitimer, sysconf +for ac_func in setitimer sysconf do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" @@ -3755,7 +3785,7 @@ as_fp_Cache=`$as_echo "fp_cv_const_$fp_const_name" | $as_tr_sh` { $as_echo "$as_me:${as_lineno-$LINENO}: checking value of $fp_const_name" >&5 $as_echo_n "checking value of $fp_const_name... " >&6; } -if eval "test \"\${$as_fp_Cache+set}\"" = set; then : +if eval \${$as_fp_Cache+:} false; then : $as_echo_n "(cached) " >&6 else if ac_fn_c_compute_int "$LINENO" "$fp_const_name" "fp_check_const_result" "$ac_includes_default"; then : @@ -3841,10 +3871,21 @@ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then - test "x$cache_file" != "x/dev/null" && + if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} - cat confcache >$cache_file + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} @@ -3876,7 +3917,7 @@ -: ${CONFIG_STATUS=./config.status} +: "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" @@ -3977,6 +4018,7 @@ IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. +as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4172,16 +4214,16 @@ # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' + as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null @@ -4241,29 +4283,17 @@ as_mkdir_p=false fi -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in #( - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" @@ -4284,7 +4314,7 @@ # values after options handling. ac_log=" This file was extended by Haskell process package $as_me 1.0, which was -generated by GNU Autoconf 2.67. Invocation command line was +generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS @@ -4337,10 +4367,10 @@ ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ Haskell process package config.status 1.0 -configured by $0, generated by GNU Autoconf 2.67, +configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" -Copyright (C) 2010 Free Software Foundation, Inc. +Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -4420,7 +4450,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then - set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' @@ -4451,7 +4481,7 @@ case $ac_config_target in "include/HsProcessConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS include/HsProcessConfig.h" ;; - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5 ;; + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done @@ -4472,9 +4502,10 @@ # after its creation but before its name has been assigned to `$tmp'. $debug || { - tmp= + tmp= ac_tmp= trap 'exit_status=$? - { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } @@ -4482,18 +4513,19 @@ { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && - test -n "$tmp" && test -d "$tmp" + test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then -cat >"$tmp/defines.awk" <<\_ACAWK || +cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF @@ -4505,8 +4537,8 @@ # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do - ac_t=`sed -n "/$ac_delim/p" confdefs.h` - if test -z "$ac_t"; then + ac_tt=`sed -n "/$ac_delim/p" confdefs.h` + if test -z "$ac_tt"; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 @@ -4607,7 +4639,7 @@ esac case $ac_mode$ac_tag in :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5 ;; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac @@ -4626,7 +4658,7 @@ for ac_f do case $ac_f in - -) ac_f="$tmp/stdin";; + -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. @@ -4635,7 +4667,7 @@ [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5 ;; + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" @@ -4661,8 +4693,8 @@ esac case $ac_tag in - *:-:* | *:-) cat >"$tmp/stdin" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac @@ -4735,20 +4767,20 @@ if test x"$ac_file" != x-; then { $as_echo "/* $configure_input */" \ - && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" - } >"$tmp/config.h" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" + } >"$ac_tmp/config.h" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - if diff "$ac_file" "$tmp/config.h" >/dev/null 2>&1; then + if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" - mv "$tmp/config.h" "$ac_file" \ + mv "$ac_tmp/config.h" "$ac_file" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 fi else $as_echo "/* $configure_input */" \ - && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error $? "could not create -" "$LINENO" 5 fi ;; diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -16,7 +16,7 @@ # check for specific header (.h) files that we are interested in AC_CHECK_HEADERS([signal.h sys/wait.h fcntl.h]) -AC_CHECK_FUNCS([setitimer, sysconf]) +AC_CHECK_FUNCS([setitimer sysconf]) FP_CHECK_CONSTS([SIG_DFL SIG_IGN]) diff --git a/include/HsProcessConfig.h b/include/HsProcessConfig.h deleted file mode 100644 --- a/include/HsProcessConfig.h +++ /dev/null @@ -1,92 +0,0 @@ -/* include/HsProcessConfig.h. Generated from HsProcessConfig.h.in by configure. */ -/* include/HsProcessConfig.h.in. Generated from configure.ac by autoheader. */ - -/* The value of SIG_DFL. */ -#define CONST_SIG_DFL -1 - -/* The value of SIG_IGN. */ -#define CONST_SIG_IGN -1 - -/* Define to 1 if you have the header file. */ -#define HAVE_FCNTL_H 1 - -/* Define to 1 if you have the `fork' function. */ -#define HAVE_FORK 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_INTTYPES_H 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_MEMORY_H 1 - -/* Define to 1 if you have the `setitimer,' function. */ -/* #undef HAVE_SETITIMER_ */ - -/* Define to 1 if you have the header file. */ -#define HAVE_SIGNAL_H 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_STDINT_H 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_STDLIB_H 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_STRINGS_H 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_STRING_H 1 - -/* Define to 1 if you have the `sysconf' function. */ -#define HAVE_SYSCONF 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_SYS_STAT_H 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_SYS_TYPES_H 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_SYS_WAIT_H 1 - -/* Define to 1 if you have the header file. */ -#define HAVE_UNISTD_H 1 - -/* Define to 1 if you have the `vfork' function. */ -#define HAVE_VFORK 1 - -/* Define to 1 if you have the header file. */ -/* #undef HAVE_VFORK_H */ - -/* Define to 1 if `fork' works. */ -#define HAVE_WORKING_FORK 1 - -/* Define to 1 if `vfork' works. */ -#define HAVE_WORKING_VFORK 1 - -/* Define to the address where bug reports for this package should be sent. */ -#define PACKAGE_BUGREPORT "libraries@haskell.org" - -/* Define to the full name of this package. */ -#define PACKAGE_NAME "Haskell process package" - -/* Define to the full name and version of this package. */ -#define PACKAGE_STRING "Haskell process package 1.0" - -/* Define to the one symbol short name of this package. */ -#define PACKAGE_TARNAME "process" - -/* Define to the home page for this package. */ -#define PACKAGE_URL "" - -/* Define to the version of this package. */ -#define PACKAGE_VERSION "1.0" - -/* Define to 1 if you have the ANSI C header files. */ -#define STDC_HEADERS 1 - -/* Define to `int' if does not define. */ -/* #undef pid_t */ - -/* Define as `fork' if `vfork' does not work. */ -/* #undef vfork */ diff --git a/include/HsProcessConfig.h.in b/include/HsProcessConfig.h.in --- a/include/HsProcessConfig.h.in +++ b/include/HsProcessConfig.h.in @@ -18,8 +18,8 @@ /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H -/* Define to 1 if you have the `setitimer,' function. */ -#undef HAVE_SETITIMER_ +/* Define to 1 if you have the `setitimer' function. */ +#undef HAVE_SETITIMER /* Define to 1 if you have the header file. */ #undef HAVE_SIGNAL_H diff --git a/include/runProcess.h b/include/runProcess.h --- a/include/runProcess.h +++ b/include/runProcess.h @@ -1,77 +1,86 @@ -/* ---------------------------------------------------------------------------- - (c) The University of Glasgow 2004 - - Interface for code in runProcess.c (providing support for System.Process) - ------------------------------------------------------------------------- */ - -#include "HsProcessConfig.h" -// Otherwise these clash with similar definitions from other packages: -#undef PACKAGE_BUGREPORT -#undef PACKAGE_NAME -#undef PACKAGE_STRING -#undef PACKAGE_TARNAME -#undef PACKAGE_VERSION - -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) -#define UNICODE -#include -#include -#endif - -#include -#include - -#ifdef HAVE_FCNTL_H -#include -#endif - -#ifdef HAVE_VFORK_H -#include -#endif - -#ifdef HAVE_VFORK -#define fork vfork -#endif - -#ifdef HAVE_SIGNAL_H -#include -#endif - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) -typedef pid_t ProcHandle; -#else -// Should really be intptr_t, but we don't have that type on the Haskell side -typedef PHANDLE ProcHandle; -#endif - -#include "processFlags.h" - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) - -extern ProcHandle runInteractiveProcess( char *const args[], - char *workingDirectory, - char **environment, - int fdStdIn, int fdStdOut, int fdStdErr, - int *pfdStdInput, - int *pfdStdOutput, - int *pfdStdError, - int set_inthandler, long inthandler, - int set_quithandler, long quithandler, - int flags); - -#else - -extern ProcHandle runInteractiveProcess( wchar_t *cmd, - wchar_t *workingDirectory, - wchar_t *environment, - int fdStdIn, int fdStdOut, int fdStdErr, - int *pfdStdInput, - int *pfdStdOutput, - int *pfdStdError, - int flags); - -#endif - -extern int terminateProcess( ProcHandle handle ); -extern int getProcessExitCode( ProcHandle handle, int *pExitCode ); -extern int waitForProcess( ProcHandle handle, int *ret ); +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Interface for code in runProcess.c (providing support for System.Process) + ------------------------------------------------------------------------- */ + +#include "HsProcessConfig.h" +// Otherwise these clash with similar definitions from other packages: +#undef PACKAGE_BUGREPORT +#undef PACKAGE_NAME +#undef PACKAGE_STRING +#undef PACKAGE_TARNAME +#undef PACKAGE_VERSION + +#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +#define UNICODE +#include +#include +#endif + +#include +#include + +#ifdef HAVE_FCNTL_H +#include +#endif + +#ifdef HAVE_VFORK_H +#include +#endif + +#if defined(HAVE_WORKING_VFORK) +#define myfork vfork +#elif defined(HAVE_WORKING_FORK) +#define myfork fork +// We don't need a fork command on Windows +#elif !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) +#error Cannot find a working fork command +#endif + +#ifdef HAVE_SIGNAL_H +#include +#endif + +#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) +typedef pid_t ProcHandle; +#else +// Should really be intptr_t, but we don't have that type on the Haskell side +typedef PHANDLE ProcHandle; +#endif + +#include "processFlags.h" + +#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) + +extern ProcHandle runInteractiveProcess( char *const args[], + char *workingDirectory, + char **environment, + int fdStdIn, + int fdStdOut, + int fdStdErr, + int *pfdStdInput, + int *pfdStdOutput, + int *pfdStdError, + int reset_int_quit_handlers, + int flags, + char **failed_doing); + +#else + +extern ProcHandle runInteractiveProcess( wchar_t *cmd, + wchar_t *workingDirectory, + wchar_t *environment, + int fdStdIn, + int fdStdOut, + int fdStdErr, + int *pfdStdInput, + int *pfdStdOutput, + int *pfdStdError, + int flags); + +#endif + +extern int terminateProcess( ProcHandle handle ); +extern int getProcessExitCode( ProcHandle handle, int *pExitCode ); +extern int waitForProcess( ProcHandle handle, int *ret ); diff --git a/process.buildinfo b/process.buildinfo new file mode 100644 --- /dev/null +++ b/process.buildinfo @@ -0,0 +1,1 @@ +install-includes: HsProcessConfig.h diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -1,36 +1,56 @@ -name: process -version: 1.1.0.2 -license: BSD3 -license-file: LICENSE -maintainer: libraries@haskell.org -bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/process -synopsis: Process libraries -category: System +name: process +version: 1.2.0.0 +-- GHC 7.6.1 released with 1.1.0.2 +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries/process +synopsis: Process libraries +category: System +build-type: Configure +cabal-version: >=1.10 description: This package contains libraries for dealing with system processes. + extra-source-files: - aclocal.m4 configure.ac configure + aclocal.m4 + changelog + configure + configure.ac include/HsProcessConfig.h.in + process.buildinfo + extra-tmp-files: - config.log config.status autom4te.cache + autom4te.cache + config.log + config.status include/HsProcessConfig.h -build-type: Configure -cabal-version: >=1.6 source-repository head type: git - location: http://darcs.haskell.org/packages/process.git/ + location: http://git.haskell.org/packages/process.git -flag base4 +source-repository this + type: git + location: http://git.haskell.org/packages/process.git + tag: process-1.2.0.0-release -Library { - exposed-modules: System.Cmd - if !impl(nhc98) { +library + default-language: Haskell2010 + other-extensions: + BangPatterns + CPP + InterruptibleFFI + RecordWildCards + Trustworthy + exposed-modules: + System.Cmd System.Process if impl(ghc) exposed-modules: - System.Process.Internals + System.Process.Internals + c-sources: cbits/runProcess.c include-dirs: include @@ -39,27 +59,15 @@ install-includes: runProcess.h processFlags.h - HsProcessConfig.h + + ghc-options: -Wall + + build-depends: base >= 4.4 && < 4.8, + directory >= 1.1 && < 1.3, + filepath >= 1.2 && < 1.4, + deepseq >= 1.1 && < 1.4 if os(windows) - build-depends: Win32 >=2.2.0.0 + build-depends: Win32 >=2.2 && < 2.4 extra-libraries: kernel32 else - build-depends: unix - } - - if (flag(base4)) { - build-depends: base >= 4 && < 5 - cpp-options: -Dbase4 - -- later, we can use the new MIN_VERSION_base() stuff that - -- arrived in Cabal-1.6. - } else { - build-depends: base >= 3 && < 4 - cpp-options: -Dbase3 - } - - build-depends: directory >= 1.0 && < 1.3, - filepath >= 1.1 && < 1.4, - deepseq >= 1.1 && < 1.4 - - extensions: CPP -} + build-depends: unix >= 2.5 && < 2.8