#ifdef __GLASGOW_HASKELL__
import System.Process
import GHC.IOBase ( ioException, IOException(..), IOErrorType(..) )
+#if !defined(mingw32_HOST_OS)
+import System.Process.Internals
+import System.Posix.Signals
+#endif
#endif
#ifdef __HUGS__
#ifdef __GLASGOW_HASKELL__
system :: String -> IO ExitCode
system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
-system cmd = do
- p <- runCommand cmd
+system str = do
+#if mingw32_HOST_OS
+ p <- runCommand str
waitForProcess p
+#else
+ -- The POSIX version of system needs to do some manipulation of signal
+ -- handlers. Since we're going to be synchronously waiting for the child,
+ -- we want to ignore ^C in the parent, but handle it the default way
+ -- in the child (using SIG_DFL isn't really correct, it should be the
+ -- original signal handler, but the GHC RTS will have already set up
+ -- its own handler and we don't want to use that).
+ old_int <- installHandler sigINT Ignore Nothing
+ old_quit <- installHandler sigQUIT Ignore Nothing
+ (cmd,args) <- commandToProcess str
+ p <- runProcessPosix "runCommand" cmd args Nothing Nothing
+ Nothing Nothing Nothing
+ (Just defaultSignal) (Just defaultSignal)
+ r <- waitForProcess p
+ installHandler sigINT old_int Nothing
+ installHandler sigQUIT old_quit Nothing
+ return r
+#endif /* mingw32_HOST_OS */
#endif /* __GLASGOW_HASKELL__ */
{-|
rawSystem :: String -> [String] -> IO ExitCode
#ifdef __GLASGOW_HASKELL__
rawSystem cmd args = do
+
+#if mingw32_HOST_OS
p <- runProcess cmd args Nothing Nothing Nothing Nothing Nothing
waitForProcess p
+#else
+ old_int <- installHandler sigINT Ignore Nothing
+ old_quit <- installHandler sigQUIT Ignore Nothing
+ p <- runProcessPosix "rawSystem" cmd args Nothing Nothing
+ Nothing Nothing Nothing
+ (Just defaultSignal) (Just defaultSignal)
+ r <- waitForProcess p
+ installHandler sigINT old_int Nothing
+ installHandler sigQUIT old_quit Nothing
+ return r
+#endif
+
#else /* ! __GLASGOW_HASKELL__ */
-- crude fallback implementation: could do much better than this under Unix
rawSystem cmd args = system (unwords (map translate (cmd:args)))
import Foreign
import Foreign.C
-import Data.Maybe ( fromMaybe )
import System.IO ( IOMode(..), Handle )
import System.Exit ( ExitCode(..) )
-import Control.Exception ( handle, throwIO )
import System.Posix.Internals
-import GHC.IOBase ( haFD, FD, Exception(..), IOException(..) )
-import GHC.Handle ( stdin, stdout, stderr, withHandle_, openFd )
+import GHC.IOBase ( FD )
+import GHC.Handle ( openFd )
-- ----------------------------------------------------------------------------
-- runCommand
runCommand string = do
(cmd,args) <- commandToProcess string
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
- runProcess1 "runCommand" cmd args Nothing Nothing Nothing Nothing Nothing
+ runProcessPosix "runCommand" cmd args Nothing Nothing Nothing Nothing Nothing
+ Nothing Nothing
#else
- runProcess1 "runCommand" cmd [] Nothing Nothing Nothing Nothing Nothing args
+ runProcessWin32 "runCommand" cmd [] Nothing Nothing Nothing Nothing Nothing args
#endif
-- ----------------------------------------------------------------------------
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
- = runProcess1 "runProcess" cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
-
-runProcess1 fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
- = 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 ->
- withArray0 nullPtr cstrs $ \pargs -> do
- ph <- throwErrnoIfMinus1 fun
- (c_runProcess pargs pWorkDir pEnv
- (haFD hndStdInput)
- (haFD hndStdOutput)
- (haFD hndStdError))
- return (ProcessHandle 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
- -> IO PHANDLE
+ = runProcessPosix "runProcess" cmd args mb_cwd mb_env
+ mb_stdin mb_stdout mb_stderr
+ Nothing Nothing
#else
runProcess1 "runProcess" cmd args mb_cwd mb_env
mb_stdin mb_stdout mb_stderr ""
-runProcess1 fun cmd args mb_cwd mb_env
+runProcessWin32 fun cmd args mb_cwd mb_env
mb_stdin mb_stdout mb_stderr extra_cmdline
= withFilePathException cmd $
withHandle_ fun (fromMaybe stdin mb_stdin) $ \hndStdInput ->
else return (Just (ExitFailure (fromIntegral code)))
-- ----------------------------------------------------------------------------
--- 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
-
-
--- ----------------------------------------------------------------------------
-- Interface to C bits
foreign import ccall unsafe "terminateProcess"
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
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
+
\r
ProcHandle\r
runProcess (char *const args[], char *workingDirectory, char **environment, \r
- int fdStdInput, int fdStdOutput, int fdStdError)\r
+ int fdStdInput, int fdStdOutput, int fdStdError,\r
+ int set_inthandler, long inthandler, \r
+ int set_quithandler, long quithandler)\r
{\r
int pid;\r
struct sigaction dfl;\r
chdir (workingDirectory);\r
}\r
\r
- /*\r
- * Restore SIGINT and SIGQUIT to default actions\r
- *\r
- * Glyn Clemments writes:\r
- * For your purposes, runProcess + waitForProcess is probably\r
- * the way to go. Except that runProcess appears to be missing\r
- * the usual signal handling. system() ignores SIGINT and\r
- * SIGQUIT in the parent, and resets them to their defaults in\r
- * the child; it also blocks SIGCHLD in the parent. runProcess\r
- * may need to do something similar; it should probably at\r
- * least reset SIGINT and SIGQUIT in the child, in case they\r
- * are ignored in the parent. The parent can set up its own\r
- * signal handling, but the only place it can control the\r
- * child's signal handling is between the fork() and the\r
- * exec(), so if runProcess doesn't do it, it won't get done.\r
+ /* Set the SIGINT/SIGQUIT signal handlers in the child, if requested \r
*/\r
- dfl.sa_handler = SIG_DFL;\r
(void)sigemptyset(&dfl.sa_mask);\r
dfl.sa_flags = 0;\r
- (void)sigaction(SIGINT, &dfl, NULL);\r
- (void)sigaction(SIGQUIT, &dfl, NULL);\r
+ if (set_inthandler) {\r
+ dfl.sa_handler = (void *)inthandler;\r
+ (void)sigaction(SIGINT, &dfl, NULL);\r
+ }\r
+ if (set_quithandler) {\r
+ dfl.sa_handler = (void *)quithandler;\r
+ (void)sigaction(SIGQUIT, &dfl, NULL);\r
+ }\r
\r
dup2 (fdStdInput, STDIN_FILENO);\r
dup2 (fdStdOutput, STDOUT_FILENO);\r
INLINE int __hscore_hs_fileno (FILE *f) { return fileno (f); }
-#if !defined(mingw32_HOST_OS) && !defined(_MSC_VER)
-INLINE int __hsposix_SIGABRT() { return SIGABRT; }
-INLINE int __hsposix_SIGALRM() { return SIGALRM; }
-INLINE int __hsposix_SIGBUS() { return SIGBUS; }
-INLINE int __hsposix_SIGCHLD() { return SIGCHLD; }
-INLINE int __hsposix_SIGCONT() { return SIGCONT; }
-INLINE int __hsposix_SIGFPE() { return SIGFPE; }
-INLINE int __hsposix_SIGHUP() { return SIGHUP; }
-INLINE int __hsposix_SIGILL() { return SIGILL; }
-INLINE int __hsposix_SIGINT() { return SIGINT; }
-INLINE int __hsposix_SIGKILL() { return SIGKILL; }
-INLINE int __hsposix_SIGPIPE() { return SIGPIPE; }
-INLINE int __hsposix_SIGQUIT() { return SIGQUIT; }
-INLINE int __hsposix_SIGSEGV() { return SIGSEGV; }
-INLINE int __hsposix_SIGSTOP() { return SIGSTOP; }
-INLINE int __hsposix_SIGTERM() { return SIGTERM; }
-INLINE int __hsposix_SIGTSTP() { return SIGTSTP; }
-INLINE int __hsposix_SIGTTIN() { return SIGTTIN; }
-INLINE int __hsposix_SIGTTOU() { return SIGTTOU; }
-INLINE int __hsposix_SIGUSR1() { return SIGUSR1; }
-INLINE int __hsposix_SIGUSR2() { return SIGUSR2; }
-#ifdef SIGPOLL
-INLINE int __hsposix_SIGPOLL() { return SIGPOLL; }
-#endif
-INLINE int __hsposix_SIGPROF() { return SIGPROF; }
-INLINE int __hsposix_SIGSYS() { return SIGSYS; }
-INLINE int __hsposix_SIGTRAP() { return SIGTRAP; }
-INLINE int __hsposix_SIGURG() { return SIGURG; }
-INLINE int __hsposix_SIGVTALRM() { return SIGVTALRM; }
-INLINE int __hsposix_SIGXCPU() { return SIGXCPU; }
-INLINE int __hsposix_SIGXFSZ() { return SIGXFSZ; }
-
-INLINE int __hsposix_SIG_BLOCK() { return SIG_BLOCK; }
-INLINE int __hsposix_SIG_UNBLOCK() { return SIG_UNBLOCK; }
-INLINE int __hsposix_SIG_SETMASK() { return SIG_SETMASK; }
-
-#endif /* mingw32_HOST_OS */
-
INLINE int __hscore_open(char *file, int how, mode_t mode) {
#ifdef mingw32_HOST_OS
if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND))
extern ProcHandle runProcess( char *const args[],
char *workingDirectory, char **environment,
- int fdStdInput, int fdStdOutput, int fdStdError);
+ int fdStdInput, int fdStdOutput, int fdStdError,
+ int set_inthandler, long inthandler,
+ int set_quithandler, long quithandler);
extern ProcHandle runInteractiveProcess( char *const args[],
char *workingDirectory,
projects / ghc-base.git / commitdiff