{-# OPTIONS_GHC -cpp -fffi #-} ----------------------------------------------------------------------------- -- | -- 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 -- -- Operations for creating and interacting with sub-processes. -- ----------------------------------------------------------------------------- -- #hide module System.Process.Internals ( #ifndef __HUGS__ ProcessHandle(..), ProcessHandle__(..), PHANDLE, closePHANDLE, mkProcessHandle, withProcessHandle, withProcessHandle_, #endif #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) pPrPr_disableITimers, c_execvpe, # ifdef __GLASGOW_HASKELL__ runProcessPosix, # endif ignoreSignal, defaultSignal, #else # ifdef __GLASGOW_HASKELL__ runProcessWin32, translate, # endif #endif #ifndef __HUGS__ commandToProcess, #endif withFilePathException, withCEnvironment ) where import Prelude -- necessary to get dependencies right #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) import System.Posix.Types ( CPid ) import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe ) import System.IO ( Handle ) #else import Data.Word ( Word32 ) import Data.IORef #endif import System.Exit ( ExitCode ) import Data.Maybe ( fromMaybe ) # ifdef __GLASGOW_HASKELL__ import GHC.IOBase ( haFD, FD, Exception(..), IOException(..) ) import GHC.Handle ( stdin, stdout, stderr, withHandle_ ) # elif __HUGS__ import Hugs.Exception ( Exception(..), IOException(..) ) # endif import Control.Concurrent import Control.Exception ( handle, throwIO ) import Foreign.C import Foreign #if defined(mingw32_HOST_OS) import Control.Monad ( when ) import System.Directory ( doesFileExist ) import Control.Exception ( catchJust, ioErrors ) 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" #ifndef __HUGS__ -- ---------------------------------------------------------------------------- -- ProcessHandle type {- | A handle to a process, which can be used to wait for termination of the process using 'waitForProcess'. None of the process-creation functions in this library wait for termination: they all return a 'ProcessHandle' which may be used to wait for the process later. -} data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode newtype ProcessHandle = ProcessHandle (MVar ProcessHandle__) withProcessHandle :: ProcessHandle -> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a withProcessHandle (ProcessHandle m) io = modifyMVar m io withProcessHandle_ :: ProcessHandle -> (ProcessHandle__ -> IO ProcessHandle__) -> IO () withProcessHandle_ (ProcessHandle m) io = modifyMVar_ m io #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) type PHANDLE = CPid mkProcessHandle :: PHANDLE -> IO ProcessHandle mkProcessHandle p = do m <- newMVar (OpenHandle p) return (ProcessHandle m) closePHANDLE :: PHANDLE -> IO () closePHANDLE _ = return () #else type PHANDLE = Word32 -- 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. mkProcessHandle :: PHANDLE -> IO ProcessHandle mkProcessHandle h = do m <- newMVar (OpenHandle h) addMVarFinalizer m (processHandleFinaliser m) return (ProcessHandle m) processHandleFinaliser m = modifyMVar_ m $ \p_ -> do case p_ of OpenHandle ph -> closePHANDLE ph _ -> return () return (error "closed process handle") closePHANDLE :: PHANDLE -> IO () closePHANDLE ph = c_CloseHandle ph foreign import stdcall unsafe "CloseHandle" c_CloseHandle :: PHANDLE -> IO () #endif #endif /* !__HUGS__ */ -- ---------------------------------------------------------------------------- #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) #ifdef __GLASGOW_HASKELL__ -- ----------------------------------------------------------------------------- -- POSIX runProcess with signal handling in the child runProcessPosix :: String -> FilePath -- ^ Filename of the executable -> [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@ -> Maybe Handle -- ^ Handle to use for @stdout@ -> Maybe Handle -- ^ Handle to use for @stderr@ -> Maybe CLong -- handler for SIGINT -> Maybe CLong -- handler for SIGQUIT -> IO ProcessHandle runProcessPosix fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr mb_sigint mb_sigquit = withFilePathException cmd $ do fd_stdin <- withHandle_ fun (fromMaybe stdin mb_stdin) $ return . haFD fd_stdout <- withHandle_ fun (fromMaybe stdout mb_stdout) $ return . haFD fd_stderr <- withHandle_ fun (fromMaybe stderr mb_stderr) $ return . haFD -- some of these might refer to the same Handle, so don't do -- nested withHandle_'s (that will deadlock). maybeWith withCEnvironment mb_env $ \pEnv -> do maybeWith withCString mb_cwd $ \pWorkDir -> do withMany withCString (cmd:args) $ \cstrs -> do 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) withArray0 nullPtr cstrs $ \pargs -> do ph <- throwErrnoIfMinus1 fun $ c_runProcess pargs pWorkDir pEnv fd_stdin fd_stdout fd_stderr set_int inthand set_quit quithand mkProcessHandle 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 -> CInt -- non-zero: set child's SIGINT handler -> CLong -- SIGINT handler -> CInt -- non-zero: set child's SIGQUIT handler -> CLong -- SIGQUIT handler -> IO PHANDLE #endif /* __GLASGOW_HASKELL__ */ ignoreSignal = CONST_SIG_IGN :: CLong defaultSignal = CONST_SIG_DFL :: CLong #else #ifdef __GLASGOW_HASKELL__ runProcessWin32 fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr extra_cmdline = withFilePathException cmd $ do fd_stdin <- withHandle_ fun (fromMaybe stdin mb_stdin) $ return . haFD fd_stdout <- withHandle_ fun (fromMaybe stdout mb_stdout) $ return . haFD fd_stderr <- withHandle_ fun (fromMaybe stderr mb_stderr) $ return . haFD -- some of these might refer to the same Handle, so don't do -- nested withHandle_'s (that will deadlock). 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 fd_stdin fd_stdout fd_stderr) mkProcessHandle proc_handle foreign import ccall unsafe "runProcess" c_runProcess :: CString -> CString -> Ptr () -> FD -> FD -> FD -> IO PHANDLE -- ------------------------------------------------------------------------ -- 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. -} -- 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 /* __GLASGOW_HASKELL__ */ #endif #ifndef __HUGS__ -- ---------------------------------------------------------------------------- -- 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_HOST_OS) && !defined(__MINGW32__) commandToProcess :: String -> IO (FilePath,[String]) commandToProcess string = return ("/bin/sh", ["-c", string]) #else commandToProcess :: String -> IO (FilePath,String) commandToProcess string = do cmd <- findCommandInterpreter return (cmd, "/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 -- (later) Now I don't know what the above comment means. sigh. -- Find CMD.EXE (or COMMAND.COM on Win98). We use the same algorithm as -- system() in the VC++ CRT (Vc7/crt/src/system.c in a VC++ installation). findCommandInterpreter :: IO FilePath findCommandInterpreter = do -- try COMSPEC first catchJust ioErrors (getEnv "COMSPEC") $ \e -> do when (not (isDoesNotExistError e)) $ ioError e -- try to find CMD.EXE or COMMAND.COM {- XXX We used to look at _osver (using cbits) and pick which shell to use with let filename | osver .&. 0x8000 /= 0 = "command.com" | otherwise = "cmd.exe" We ought to use GetVersionEx instead, but for now we just look for either filename -} path <- getEnv "PATH" let -- use our own version of System.Directory.findExecutable, because -- that assumes the .exe suffix. search :: [FilePath] -> IO (Maybe FilePath) search [] = return Nothing search (d:ds) = do let path1 = d "cmd.exe" path2 = d "command.com" b1 <- doesFileExist path1 b2 <- doesFileExist path2 if b1 then return (Just path1) else if b2 then return (Just path2) else search ds -- mb_path <- search (splitSearchPath path) case mb_path of Nothing -> ioError (mkIOError doesNotExistErrorType "findCommandInterpreter" Nothing Nothing) Just cmd -> return cmd #endif #endif /* __HUGS__ */ -- ---------------------------------------------------------------------------- -- 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_HOST_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