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 (
19 ProcessHandle(..), ProcessHandle__(..),
20 PHANDLE, closePHANDLE, mkProcessHandle,
21 withProcessHandle, withProcessHandle_,
23 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
24 pPrPr_disableITimers, c_execvpe,
25 # ifdef __GLASGOW_HASKELL__
28 ignoreSignal, defaultSignal,
30 # ifdef __GLASGOW_HASKELL__
31 runProcessWin32, translate,
37 withFilePathException, withCEnvironment
40 import Prelude -- necessary to get dependencies right
42 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
43 import System.Posix.Types ( CPid )
44 import System.IO ( Handle )
46 import Data.Word ( Word32 )
50 import System.Exit ( ExitCode )
51 import Data.Maybe ( fromMaybe )
52 # ifdef __GLASGOW_HASKELL__
53 import GHC.IOBase ( haFD, FD, Exception(..), IOException(..) )
54 import GHC.Handle ( stdin, stdout, stderr, withHandle_ )
56 import Hugs.Exception ( Exception(..), IOException(..) )
59 import Control.Concurrent
60 import Control.Exception ( handle, throwIO )
64 #if defined(mingw32_HOST_OS)
65 import Control.Monad ( when )
66 import System.Directory ( doesFileExist )
67 import Control.Exception ( catchJust, ioErrors )
68 import System.IO.Error ( isDoesNotExistError, doesNotExistErrorType,
70 import System.Environment ( getEnv )
71 import System.Directory.Internals ( parseSearchPath, joinFileName )
75 {-# CFILES cbits/execvpe.c #-}
78 #include "HsBaseConfig.h"
81 -- ----------------------------------------------------------------------------
84 {- | A handle to a process, which can be used to wait for termination
85 of the process using 'waitForProcess'.
87 None of the process-creation functions in this library wait for
88 termination: they all return a 'ProcessHandle' which may be used
89 to wait for the process later.
91 data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode
92 newtype ProcessHandle = ProcessHandle (MVar ProcessHandle__)
96 -> (ProcessHandle__ -> IO (ProcessHandle__, a))
98 withProcessHandle (ProcessHandle m) io = modifyMVar m io
102 -> (ProcessHandle__ -> IO ProcessHandle__)
104 withProcessHandle_ (ProcessHandle m) io = modifyMVar_ m io
106 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
110 mkProcessHandle :: PHANDLE -> IO ProcessHandle
111 mkProcessHandle p = do
112 m <- newMVar (OpenHandle p)
113 return (ProcessHandle m)
115 closePHANDLE :: PHANDLE -> IO ()
116 closePHANDLE _ = return ()
120 type PHANDLE = Word32
122 -- On Windows, we have to close this HANDLE when it is no longer required,
123 -- hence we add a finalizer to it, using an IORef as the box on which to
124 -- attach the finalizer.
125 mkProcessHandle :: PHANDLE -> IO ProcessHandle
126 mkProcessHandle h = do
127 m <- newMVar (OpenHandle h)
128 addMVarFinalizer m (processHandleFinaliser m)
129 return (ProcessHandle m)
131 processHandleFinaliser m =
132 modifyMVar_ m $ \p_ -> do
134 OpenHandle ph -> closePHANDLE ph
136 return (error "closed process handle")
138 closePHANDLE :: PHANDLE -> IO ()
139 closePHANDLE ph = c_CloseHandle ph
141 foreign import stdcall unsafe "CloseHandle"
146 #endif /* !__HUGS__ */
148 -- ----------------------------------------------------------------------------
150 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
152 -- this function disables the itimer, which would otherwise cause confusing
153 -- signals to be sent to the new process.
154 foreign import ccall unsafe "pPrPr_disableITimers"
155 pPrPr_disableITimers :: IO ()
157 foreign import ccall unsafe "execvpe"
158 c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt
162 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
164 #ifdef __GLASGOW_HASKELL__
165 -- -----------------------------------------------------------------------------
166 -- POSIX runProcess with signal handling in the child
170 -> FilePath -- ^ Filename of the executable
171 -> [String] -- ^ Arguments to pass to the executable
172 -> Maybe FilePath -- ^ Optional path to the working directory
173 -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit)
174 -> Maybe Handle -- ^ Handle to use for @stdin@
175 -> Maybe Handle -- ^ Handle to use for @stdout@
176 -> Maybe Handle -- ^ Handle to use for @stderr@
177 -> Maybe CLong -- handler for SIGINT
178 -> Maybe CLong -- handler for SIGQUIT
181 runProcessPosix fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
183 = withFilePathException cmd $ do
184 fd_stdin <- withHandle_ fun (fromMaybe stdin mb_stdin) $ return . haFD
185 fd_stdout <- withHandle_ fun (fromMaybe stdout mb_stdout) $ return . haFD
186 fd_stderr <- withHandle_ fun (fromMaybe stderr mb_stderr) $ return . haFD
187 -- some of these might refer to the same Handle, so don't do
188 -- nested withHandle_'s (that will deadlock).
189 maybeWith withCEnvironment mb_env $ \pEnv -> do
190 maybeWith withCString mb_cwd $ \pWorkDir -> do
191 withMany withCString (cmd:args) $ \cstrs -> do
192 let (set_int, inthand)
195 Just hand -> (1, hand)
199 Just hand -> (1, hand)
200 withArray0 nullPtr cstrs $ \pargs -> do
201 ph <- throwErrnoIfMinus1 fun $
202 c_runProcess pargs pWorkDir pEnv
203 fd_stdin fd_stdout fd_stderr
204 set_int inthand set_quit quithand
207 foreign import ccall unsafe "runProcess"
209 :: Ptr CString -- args
210 -> CString -- working directory (or NULL)
211 -> Ptr CString -- env (or NULL)
215 -> CInt -- non-zero: set child's SIGINT handler
216 -> CLong -- SIGINT handler
217 -> CInt -- non-zero: set child's SIGQUIT handler
218 -> CLong -- SIGQUIT handler
221 #endif /* __GLASGOW_HASKELL__ */
223 ignoreSignal = CONST_SIG_IGN :: CLong
224 defaultSignal = CONST_SIG_DFL :: CLong
228 #ifdef __GLASGOW_HASKELL__
230 runProcessWin32 fun cmd args mb_cwd mb_env
231 mb_stdin mb_stdout mb_stderr extra_cmdline
232 = withFilePathException cmd $ do
233 fd_stdin <- withHandle_ fun (fromMaybe stdin mb_stdin) $ return . haFD
234 fd_stdout <- withHandle_ fun (fromMaybe stdout mb_stdout) $ return . haFD
235 fd_stderr <- withHandle_ fun (fromMaybe stderr mb_stderr) $ return . haFD
236 -- some of these might refer to the same Handle, so don't do
237 -- nested withHandle_'s (that will deadlock).
238 maybeWith withCEnvironment mb_env $ \pEnv -> do
239 maybeWith withCString mb_cwd $ \pWorkDir -> do
240 let cmdline = translate cmd ++
241 concat (map ((' ':) . translate) args) ++
242 (if null extra_cmdline then "" else ' ':extra_cmdline)
243 withCString cmdline $ \pcmdline -> do
244 proc_handle <- throwErrnoIfMinus1 fun
245 (c_runProcess pcmdline pWorkDir pEnv
246 fd_stdin fd_stdout fd_stderr)
247 mkProcessHandle proc_handle
249 foreign import ccall unsafe "runProcess"
259 -- ------------------------------------------------------------------------
260 -- Passing commands to the OS on Windows
263 On Windows this is tricky. We use CreateProcess, passing a single
264 command-line string (lpCommandLine) as its argument. (CreateProcess
265 is well documented on http://msdn.microsoft/com.)
267 - It parses the beginning of the string to find the command. If the
268 file name has embedded spaces, it must be quoted, using double
270 "foo\this that\cmd" arg1 arg2
272 - The invoked command can in turn access the entire lpCommandLine string,
273 and the C runtime does indeed do so, parsing it to generate the
274 traditional argument vector argv[0], argv[1], etc. It does this
275 using a complex and arcane set of rules which are described here:
277 http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp
279 (if this URL stops working, you might be able to find it by
280 searching for "Parsing C Command-Line Arguments" on MSDN. Also,
281 the code in the Microsoft C runtime that does this translation
282 is shipped with VC++).
284 Our goal in runProcess is to take a command filename and list of
285 arguments, and construct a string which inverts the translatsions
286 described above, such that the program at the other end sees exactly
287 the same arguments in its argv[] that we passed to rawSystem.
289 This inverse translation is implemented by 'translate' below.
291 Here are some pages that give informations on Windows-related
292 limitations and deviations from Unix conventions:
294 http://support.microsoft.com/default.aspx?scid=kb;en-us;830473
295 Command lines and environment variables effectively limited to 8191
296 characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x):
298 http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp
299 Command-line substitution under Windows XP. IIRC these facilities (or at
300 least a large subset of them) are available on Win NT and 2000. Some
301 might be available on Win 9x.
303 http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp
304 How CMD.EXE processes command lines.
307 Note: CreateProcess does have a separate argument (lpApplicationName)
308 with which you can specify the command, but we have to slap the
309 command into lpCommandLine anyway, so that argv[0] is what a C program
310 expects (namely the application name). So it seems simpler to just
311 use lpCommandLine alone, which CreateProcess supports.
314 -- Translate command-line arguments for passing to CreateProcess().
315 translate :: String -> String
316 translate str = '"' : snd (foldr escape (True,"\"") str)
317 where escape '"' (b, str) = (True, '\\' : '"' : str)
318 escape '\\' (True, str) = (True, '\\' : '\\' : str)
319 escape '\\' (False, str) = (False, '\\' : str)
320 escape c (b, str) = (False, c : str)
321 -- See long comment above for what this function is trying to do.
323 -- The Bool passed back along the string is True iff the
324 -- rest of the string is a sequence of backslashes followed by
327 #endif /* __GLASGOW_HASKELL__ */
332 -- ----------------------------------------------------------------------------
335 {- | Turns a shell command into a raw command. Usually this involves
336 wrapping it in an invocation of the shell.
338 There's a difference in the signature of commandToProcess between
339 the Windows and Unix versions. On Unix, exec takes a list of strings,
340 and we want to pass our command to /bin/sh as a single argument.
342 On Windows, CreateProcess takes a single string for the command,
343 which is later decomposed by cmd.exe. In this case, we just want
344 to prepend @\"c:\WINDOWS\CMD.EXE \/c\"@ to our command line. The
345 command-line translation that we normally do for arguments on
346 Windows isn't required (or desirable) here.
349 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
353 -> IO (FilePath,[String])
354 commandToProcess string = return ("/bin/sh", ["-c", string])
360 -> IO (FilePath,String)
361 commandToProcess string = do
362 cmd <- findCommandInterpreter
363 return (cmd, "/c "++string)
364 -- We don't want to put the cmd into a single
365 -- argument, because cmd.exe will not try to split it up. Instead,
366 -- we just tack the command on the end of the cmd.exe command line,
367 -- which partly works. There seem to be some quoting issues, but
368 -- I don't have the energy to find+fix them right now (ToDo). --SDM
369 -- (later) Now I don't know what the above comment means. sigh.
371 -- Find CMD.EXE (or COMMAND.COM on Win98). We use the same algorithm as
372 -- system() in the VC++ CRT (Vc7/crt/src/system.c in a VC++ installation).
373 findCommandInterpreter :: IO FilePath
374 findCommandInterpreter = do
376 catchJust ioErrors (getEnv "COMSPEC") $ \e -> do
377 when (not (isDoesNotExistError e)) $ ioError e
379 -- try to find CMD.EXE or COMMAND.COM
381 let filename | osver .&. 0x8000 /= 0 = "command.com"
382 | otherwise = "cmd.exe"
383 path <- getEnv "PATH"
385 -- use our own version of System.Directory.findExecutable, because
386 -- that assumes the .exe suffix.
387 search :: [FilePath] -> IO (Maybe FilePath)
388 search [] = return Nothing
390 let path = d `joinFileName` filename
391 b <- doesFileExist path
392 if b then return (Just path)
395 mb_path <- search (parseSearchPath path)
398 Nothing -> ioError (mkIOError doesNotExistErrorType
399 "findCommandInterpreter" Nothing Nothing)
400 Just cmd -> return cmd
403 foreign import ccall unsafe "__hscore_get_osver"
404 c_get_osver :: IO CUInt
407 #endif /* __HUGS__ */
409 -- ----------------------------------------------------------------------------
412 withFilePathException :: FilePath -> IO a -> IO a
413 withFilePathException fpath act = handle mapEx act
415 mapEx (IOException (IOError h iot fun str _)) = ioError (IOError h iot fun str (Just fpath))
418 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
419 withCEnvironment :: [(String,String)] -> (Ptr CString -> IO a) -> IO a
420 withCEnvironment env act =
421 let env' = map (\(name, val) -> name ++ ('=':val)) env
422 in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act)
424 withCEnvironment :: [(String,String)] -> (Ptr () -> IO a) -> IO a
425 withCEnvironment env act =
426 let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" env
427 in withCString env' (act . castPtr)