1 {-# OPTIONS_GHC -cpp -fffi #-}
2 -----------------------------------------------------------------------------
4 -- Module : System.Process.Internals
5 -- Copyright : (c) The University of Glasgow 2004
6 -- License : BSD-style (see the file libraries/base/LICENSE)
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : portable
12 -- Operations for creating and interacting with sub-processes.
14 -----------------------------------------------------------------------------
17 module System.Process.Internals (
18 ProcessHandle(..), PHANDLE,
19 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
20 pPrPr_disableITimers, c_execvpe,
21 # ifdef __GLASGOW_HASKELL__
24 ignoreSignal, defaultSignal,
27 withFilePathException, withCEnvironment
30 import Prelude -- necessary to get dependencies right
32 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
33 import System.Posix.Types ( CPid )
34 # ifdef __GLASGOW_HASKELL__
35 import GHC.IOBase ( haFD, FD, Exception(..), IOException(..) )
36 import GHC.Handle ( stdin, stdout, stderr, withHandle_ )
38 import Hugs.Exception ( Exception(..), IOException(..) )
40 import System.IO ( Handle )
41 import Data.Maybe ( fromMaybe )
43 import Data.Word ( Word32 )
46 import Control.Exception ( handle, throwIO )
51 {-# CFILES cbits/execvpe.c #-}
54 #include "HsBaseConfig.h"
56 -- ----------------------------------------------------------------------------
59 {- | A handle to a process, which can be used to wait for termination
60 of the process using 'waitForProcess'.
62 None of the process-creation functions in this library wait for
63 termination: they all return a 'ProcessHandle' which may be used
64 to wait for the process later.
66 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
72 newtype ProcessHandle = ProcessHandle PHANDLE
74 -- ----------------------------------------------------------------------------
76 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
78 -- this function disables the itimer, which would otherwise cause confusing
79 -- signals to be sent to the new process.
80 foreign import ccall unsafe "pPrPr_disableITimers"
81 pPrPr_disableITimers :: IO ()
83 foreign import ccall unsafe "execvpe"
84 c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt
88 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
90 #ifdef __GLASGOW_HASKELL__
91 -- -----------------------------------------------------------------------------
92 -- POSIX runProcess with signal handling in the child
96 -> FilePath -- ^ Filename of the executable
97 -> [String] -- ^ Arguments to pass to the executable
98 -> Maybe FilePath -- ^ Optional path to the working directory
99 -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit)
100 -> Maybe Handle -- ^ Handle to use for @stdin@
101 -> Maybe Handle -- ^ Handle to use for @stdout@
102 -> Maybe Handle -- ^ Handle to use for @stderr@
103 -> Maybe CLong -- handler for SIGINT
104 -> Maybe CLong -- handler for SIGQUIT
107 runProcessPosix fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
109 = withFilePathException cmd $
110 withHandle_ fun (fromMaybe stdin mb_stdin) $ \hndStdInput ->
111 withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
112 withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
113 maybeWith withCEnvironment mb_env $ \pEnv ->
114 maybeWith withCString mb_cwd $ \pWorkDir ->
115 withMany withCString (cmd:args) $ \cstrs ->
116 let (set_int, inthand)
119 Just hand -> (1, hand)
123 Just hand -> (1, hand)
125 withArray0 nullPtr cstrs $ \pargs -> do
126 ph <- throwErrnoIfMinus1 fun $
127 c_runProcess pargs pWorkDir pEnv
131 set_int inthand set_quit quithand
132 return (ProcessHandle ph)
134 foreign import ccall unsafe "runProcess"
136 :: Ptr CString -- args
137 -> CString -- working directory (or NULL)
138 -> Ptr CString -- env (or NULL)
142 -> CInt -- non-zero: set child's SIGINT handler
143 -> CLong -- SIGINT handler
144 -> CInt -- non-zero: set child's SIGQUIT handler
145 -> CLong -- SIGQUIT handler
148 #endif /* __GLASGOW_HASKELL__ */
150 ignoreSignal = CONST_SIG_IGN :: CLong
151 defaultSignal = CONST_SIG_DFL :: CLong
155 -- ----------------------------------------------------------------------------
158 {- | Turns a shell command into a raw command. Usually this involves
159 wrapping it in an invocation of the shell.
161 There's a difference in the signature of commandToProcess between
162 the Windows and Unix versions. On Unix, exec takes a list of strings,
163 and we want to pass our command to /bin/sh as a single argument.
165 On Windows, CreateProcess takes a single string for the command,
166 which is later decomposed by cmd.exe. In this case, we just want
167 to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line. The
168 command-line translation that we normally do for arguments on
169 Windows isn't required (or desirable) here.
172 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
176 -> IO (FilePath,[String])
177 commandToProcess string = return ("/bin/sh", ["-c", string])
183 -> IO (FilePath,String)
184 commandToProcess string = do
185 sysDir <- allocaBytes 1024 (\pdir -> c_getSystemDirectory pdir 1024 >> peekCString pdir)
186 return (sysDir ++ "\\CMD.EXE", "/c " ++ string)
187 -- We don't want to put the cmd into a single
188 -- argument, because cmd.exe will not try to split it up. Instead,
189 -- we just tack the command on the end of the cmd.exe command line,
190 -- which partly works. There seem to be some quoting issues, but
191 -- I don't have the energy to find+fix them right now (ToDo). --SDM
193 foreign import stdcall unsafe "GetSystemDirectoryA"
201 -- ----------------------------------------------------------------------------
204 withFilePathException :: FilePath -> IO a -> IO a
205 withFilePathException fpath act = handle mapEx act
207 mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath))
210 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
211 withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a
212 withCEnvironment env act =
213 let env' = map (\(name, val) -> name ++ ('=':val)) env
214 in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)
216 withCEnvironment :: [(String,String)] -> (Ptr () -> IO a) -> IO a
217 withCEnvironment env act =
218 let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" env
219 in withCString env' (act . castPtr)