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
#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__
#endif
#include "HsProcessConfig.h"
#ifndef __HUGS__
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
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__
runProcessPosix
:: String
-> FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String,String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> Maybe CLong
-> Maybe CLong
-> 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
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
-> CString
-> Ptr CString
-> FD
-> FD
-> FD
-> CInt
-> CLong
-> CInt
-> CLong
-> 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
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
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)
#endif /* __GLASGOW_HASKELL__ */
#endif
#ifndef __HUGS__
#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)
findCommandInterpreter :: IO FilePath
findCommandInterpreter = do
catchJust ioErrors (getEnv "COMSPEC") $ \e -> do
when (not (isDoesNotExistError e)) $ ioError e
path <- getEnv "PATH"
let
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__ */
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