-{-# OPTIONS -cpp -fffi #-}
+{-# OPTIONS_GHC -cpp -fffi #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Process
terminateProcess,
) where
+import Prelude
+
import System.Process.Internals
import Foreign
import Foreign.C
-import Data.Maybe ( fromMaybe )
-import System.IO ( IOMode(..), Handle )
+import System.IO ( IOMode(..), Handle, hClose )
import System.Exit ( ExitCode(..) )
-import Control.Exception ( handle, throwIO )
import System.Posix.Internals
-import GHC.IOBase ( haFD, FD, Exception(..), IOException(..) )
-import GHC.Handle ( stdin, stdout, stderr, withHandle_, openFd )
+import GHC.IOBase ( FD )
+import GHC.Handle ( openFd )
-- ----------------------------------------------------------------------------
-- runCommand
runCommand string = do
(cmd,args) <- commandToProcess string
-#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
- runProcess1 "runCommand" cmd args Nothing Nothing Nothing Nothing Nothing
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
+ runProcessPosix "runCommand" cmd args Nothing Nothing Nothing Nothing Nothing
+ Nothing Nothing
#else
- runProcess1 "runCommand" cmd [] Nothing Nothing Nothing Nothing Nothing args
+ runProcessWin32 "runCommand" cmd [] Nothing Nothing Nothing Nothing Nothing args
#endif
-- ----------------------------------------------------------------------------
process.
Any 'Handle's passed to 'runProcess' are placed immediately in the
- closed state, so may no longer be referenced by the Haskell process.
+ closed state.
-}
runProcess
:: FilePath -- ^ Filename of the executable
-> Maybe Handle -- ^ Handle to use for @stderr@
-> IO ProcessHandle
-#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
-
-runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
- = runProcess1 "runProcess" cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
-
-runProcess1 fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
- = withFilePathException cmd $
- withHandle_ fun (fromMaybe stdin mb_stdin) $ \hndStdInput ->
- withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
- withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
- maybeWith withCEnvironment mb_env $ \pEnv ->
- maybeWith withCString mb_cwd $ \pWorkDir ->
- withMany withCString (cmd:args) $ \cstrs ->
- withArray0 nullPtr cstrs $ \pargs -> do
- ph <- throwErrnoIfMinus1 fun
- (c_runProcess pargs pWorkDir pEnv
- (haFD hndStdInput)
- (haFD hndStdOutput)
- (haFD hndStdError))
- return (ProcessHandle ph)
-
-foreign import ccall unsafe "runProcess"
- c_runProcess
- :: Ptr CString -- args
- -> CString -- working directory (or NULL)
- -> Ptr CString -- env (or NULL)
- -> FD -- stdin
- -> FD -- stdout
- -> FD -- stderr
- -> IO PHANDLE
-
+runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
+ h <- runProcessPosix "runProcess" cmd args mb_cwd mb_env
+ mb_stdin mb_stdout mb_stderr
+ Nothing Nothing
#else
-
-runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr =
- runProcess1 "runProcess" cmd args mb_cwd mb_env
+ h <- runProcessWin32 "runProcess" cmd args mb_cwd mb_env
mb_stdin mb_stdout mb_stderr ""
-
-runProcess1 fun cmd args mb_cwd mb_env
- mb_stdin mb_stdout mb_stderr extra_cmdline
- = withFilePathException cmd $
- withHandle_ fun (fromMaybe stdin mb_stdin) $ \hndStdInput ->
- withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
- withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
- maybeWith withCEnvironment mb_env $ \pEnv -> do
- maybeWith withCString mb_cwd $ \pWorkDir -> do
- let cmdline = translate cmd ++
- concat (map ((' ':) . translate) args) ++
- (if null extra_cmdline then "" else ' ':extra_cmdline)
- withCString cmdline $ \pcmdline -> do
- proc_handle <- throwErrnoIfMinus1 fun
- (c_runProcess pcmdline pWorkDir pEnv
- (haFD hndStdInput)
- (haFD hndStdOutput)
- (haFD hndStdError))
- return (ProcessHandle proc_handle)
-
-foreign import ccall unsafe "runProcess"
- c_runProcess
- :: CString
- -> CString
- -> Ptr ()
- -> FD
- -> FD
- -> FD
- -> IO PHANDLE
-
- -- Set the standard HANDLEs for the child process appropriately. NOTE:
- -- this relies on the HANDLEs being inheritable. By default, the
- -- runtime open() function creates inheritable handles (unless O_NOINHERIT
- -- is specified). But perhaps we should DuplicateHandle() to make sure
- -- the handle is inheritable?
#endif
+ maybe (return ()) hClose mb_stdin
+ maybe (return ()) hClose mb_stdout
+ maybe (return ()) hClose mb_stderr
+ return h
-- ----------------------------------------------------------------------------
-- runInteractiveCommand
runInteractiveCommand string = do
(cmd,args) <- commandToProcess string
-#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
runInteractiveProcess1 "runInteractiveCommand" cmd args Nothing Nothing
#else
runInteractiveProcess1 "runInteractiveCommand" cmd [] Nothing Nothing args
For example, to start a process and feed a string to its stdin:
-> (in,out,err,pid) <- runInteractiveProcess "..."
-> forkIO (hPutStr in str)
+> (inp,out,err,pid) <- runInteractiveProcess "..."
+> forkIO (hPutStr inp str)
-}
runInteractiveProcess
:: FilePath -- ^ Filename of the executable
-> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit)
-> IO (Handle,Handle,Handle,ProcessHandle)
-#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
runInteractiveProcess cmd args mb_cwd mb_env =
runInteractiveProcess1 "runInteractiveProcess" cmd args mb_cwd mb_env
hndStdInput <- fdToHandle pfdStdInput WriteMode
hndStdOutput <- fdToHandle pfdStdOutput ReadMode
hndStdError <- fdToHandle pfdStdError ReadMode
- return (hndStdInput, hndStdOutput, hndStdError, ProcessHandle proc_handle)
+ ph <- mkProcessHandle proc_handle
+ return (hndStdInput, hndStdOutput, hndStdError, ph)
foreign import ccall unsafe "runInteractiveProcess"
c_runInteractiveProcess
hndStdInput <- fdToHandle pfdStdInput WriteMode
hndStdOutput <- fdToHandle pfdStdOutput ReadMode
hndStdError <- fdToHandle pfdStdError ReadMode
- return (hndStdInput, hndStdOutput, hndStdError,
- ProcessHandle proc_handle)
+ ph <- mkProcessHandle proc_handle
+ return (hndStdInput, hndStdOutput, hndStdError, ph)
foreign import ccall unsafe "runInteractiveProcess"
c_runInteractiveProcess
fdToHandle pfd mode = do
fd <- peek pfd
openFd fd (Just Stream)
-#if __GLASGOW_HASKELL__ >= 603
False{-not a socket-}
-#endif
- ("fd:" ++ show fd) mode True{-binary-} False{-no truncate-}
+ ("fd:" ++ show fd) mode True{-binary-}
-- ----------------------------------------------------------------------------
-- waitForProcess
{- | Waits for the specified process to terminate, and returns its exit code.
- GHC Note: in order to call waitForProcess without blocking all the
+ 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 (ProcessHandle handle) = do
- code <- throwErrnoIfMinus1 "waitForProcess" (c_waitForProcess handle)
- if (code == 0)
- then return ExitSuccess
- else return (ExitFailure (fromIntegral code))
+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)
+ code <- throwErrnoIfMinus1 "waitForProcess" (c_waitForProcess h)
+ withProcessHandle ph $ \p_ ->
+ case p_ of
+ ClosedHandle e -> return (p_,e)
+ OpenHandle ph -> do
+ closePHANDLE ph
+ let e = if (code == 0)
+ then ExitSuccess
+ else (ExitFailure (fromIntegral code))
+ return (ClosedHandle e, e)
-- ----------------------------------------------------------------------------
-- terminateProcess
-- On Windows systems, the Win32 @TerminateProcess@ function is called, passing
-- an exit code of 1.
terminateProcess :: ProcessHandle -> IO ()
-terminateProcess (ProcessHandle pid) =
- throwErrnoIfMinus1_ "terminateProcess" (c_terminateProcess pid)
+terminateProcess ph = do
+ withProcessHandle_ ph $ \p_ ->
+ case p_ of
+ ClosedHandle _ -> return p_
+ OpenHandle h -> do
+ throwErrnoIfMinus1_ "terminateProcess" $ c_terminateProcess h
+ return p_
+ -- does not close the handle, we might want to try terminating it
+ -- again, or get its exit code.
-- ----------------------------------------------------------------------------
-- getProcessExitCode
-{- | Verifies whether the process is completed and if it is then returns the exit code.
- If the process is still running the function returns Nothing
+{- |
+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.
+Subsequent calls to @getProcessExitStatus@ always return @'Just'
+'ExitSuccess'@, regardless of what the original exit code was.
-}
getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)
-getProcessExitCode (ProcessHandle handle) =
- alloca $ \pExitCode -> do
- res <- throwErrnoIfMinus1 "getProcessExitCode" (c_getProcessExitCode handle pExitCode)
- code <- peek pExitCode
- if res == 0
- then return Nothing
- else if code == 0
- then return (Just ExitSuccess)
- else return (Just (ExitFailure (fromIntegral code)))
-
--- ----------------------------------------------------------------------------
--- commandToProcess
-
-{- | Turns a shell command into a raw command. Usually this involves
- wrapping it in an invocation of the shell.
-
- 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.
-
- On Windows, CreateProcess takes a single string for the command,
- which is later decomposed by cmd.exe. In this case, we just want
- to prepend "c:\WINDOWS\CMD.EXE /c" to our command line. The
- command-line translation that we normally do for arguments on
- Windows isn't required (or desirable) here.
--}
-
-#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
-
-commandToProcess
- :: String
- -> IO (FilePath,[String])
-commandToProcess string = return ("/bin/sh", ["-c", string])
-
-#else
-
-commandToProcess
- :: String
- -> IO (FilePath,String)
-commandToProcess string = do
- sysDir <- allocaBytes 1024 (\pdir -> c_getSystemDirectory pdir 1024 >> peekCString pdir)
- return (sysDir ++ "\\CMD.EXE", "/c " ++ string)
- -- We don't want to put the cmd into a single
- -- argument, because cmd.exe will not try to split it up. Instead,
- -- we just tack the command on the end of the cmd.exe command line,
- -- which partly works. There seem to be some quoting issues, but
- -- I don't have the energy to find+fix them right now (ToDo). --SDM
-
-foreign import stdcall unsafe "GetSystemDirectoryA"
- c_getSystemDirectory
- :: CString
- -> CInt
- -> IO CInt
-
-#endif
-
--- ----------------------------------------------------------------------------
--- Utils
-
-withFilePathException :: FilePath -> IO a -> IO a
-withFilePathException fpath act = handle mapEx act
- where
- mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath))
- mapEx e = throwIO e
-
-#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
-withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a
-withCEnvironment env act =
- let env' = map (\(name, val) -> name ++ ('=':val)) env
- in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)
-#else
-withCEnvironment :: [(String,String)] -> (Ptr () -> IO a) -> IO a
-withCEnvironment env act =
- let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" env
- in withCString env' (act . castPtr)
-#endif
-
+getProcessExitCode ph = do
+ withProcessHandle ph $ \p_ ->
+ case p_ of
+ ClosedHandle e -> return (p_, Just e)
+ OpenHandle h ->
+ alloca $ \pExitCode -> do
+ res <- throwErrnoIfMinus1 "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
c_waitForProcess
:: PHANDLE
-> IO CInt
-
--- ------------------------------------------------------------------------
--- Passing commands to the OS on Windows
-
-{-
-On Windows this is tricky. We use CreateProcess, passing a single
-command-line string (lpCommandLine) as its argument. (CreateProcess
-is well documented on http://msdn.microsoft/com.)
-
- - It parses the beginning of the string to find the command. If the
- file name has embedded spaces, it must be quoted, using double
- quotes thus
- "foo\this that\cmd" arg1 arg2
-
- - The invoked command can in turn access the entire lpCommandLine string,
- and the C runtime does indeed do so, parsing it to generate the
- traditional argument vector argv[0], argv[1], etc. It does this
- using a complex and arcane set of rules which are described here:
-
- http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp
-
- (if this URL stops working, you might be able to find it by
- searching for "Parsing C Command-Line Arguments" on MSDN. Also,
- the code in the Microsoft C runtime that does this translation
- is shipped with VC++).
-
-Our goal in runProcess is to take a command filename and list of
-arguments, and construct a string which inverts the translatsions
-described above, such that the program at the other end sees exactly
-the same arguments in its argv[] that we passed to rawSystem.
-
-This inverse translation is implemented by 'translate' below.
-
-Here are some pages that give informations on Windows-related
-limitations and deviations from Unix conventions:
-
- http://support.microsoft.com/default.aspx?scid=kb;en-us;830473
- Command lines and environment variables effectively limited to 8191
- characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x):
-
- http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp
- Command-line substitution under Windows XP. IIRC these facilities (or at
- least a large subset of them) are available on Win NT and 2000. Some
- might be available on Win 9x.
-
- http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp
- How CMD.EXE processes command lines.
-
-
-Note: CreateProcess does have a separate argument (lpApplicationName)
-with which you can specify the command, but we have to slap the
-command into lpCommandLine anyway, so that argv[0] is what a C program
-expects (namely the application name). So it seems simpler to just
-use lpCommandLine alone, which CreateProcess supports.
--}
-
-#if defined(mingw32_TARGET_OS)
-
--- Translate command-line arguments for passing to CreateProcess().
-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)
- -- 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.
-
-#endif