X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FProcess%2FInternals.hs;h=474c662aa8dae37d0023aa93913713a72636cc1d;hb=65e3818434e254ed37b16bf4e26bf3ff2dec153f;hp=22caedbd5876e335777388d2b42f6d3a99b324dd;hpb=9846058c21cf4eae3d5b4b3b977db2b85342771e;p=ghc-base.git diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 22caedb..474c662 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -17,25 +17,35 @@ module System.Process.Internals ( ProcessHandle(..), PHANDLE, #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - pPrPr_disableITimers, c_execvpe + pPrPr_disableITimers, c_execvpe, + runProcessPosix, ignoreSignal, defaultSignal, #endif + commandToProcess, + withFilePathException, withCEnvironment ) where import Prelude -- necessary to get dependencies right #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) import System.Posix.Types ( CPid ) +import GHC.IOBase ( haFD, FD, Exception(..), IOException(..) ) +import GHC.Handle ( stdin, stdout, stderr, withHandle_ ) +import System.IO ( Handle ) +import Data.Maybe ( fromMaybe ) #else import Data.Word ( Word32 ) #endif -import Foreign.C.String ( CString ) -import Foreign.C.Types ( CInt ) -import Foreign.Ptr ( Ptr ) + +import Control.Exception ( handle, throwIO ) +import Foreign.C +import Foreign #ifdef __HUGS__ {-# CFILES cbits/execvpe.c #-} #endif +#include "HsBaseConfig.h" + -- ---------------------------------------------------------------------------- -- ProcessHandle type @@ -67,3 +77,135 @@ foreign import ccall unsafe "execvpe" c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt #endif + +-- ----------------------------------------------------------------------------- +-- POSIX runProcess with signal handling in the child + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + +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 $ + 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 -> + 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) + in + withArray0 nullPtr cstrs $ \pargs -> do + ph <- throwErrnoIfMinus1 fun $ + c_runProcess pargs pWorkDir pEnv + (haFD hndStdInput) + (haFD hndStdOutput) + (haFD hndStdError) + set_int inthand set_quit quithand + return (ProcessHandle ph) + +ignoreSignal = CONST_SIG_IGN :: CLong +defaultSignal = CONST_SIG_DFL :: CLong + +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 + +-- ---------------------------------------------------------------------------- +-- 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 + 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_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 +