From: simonmar Date: Mon, 31 Jan 2005 13:51:24 +0000 (+0000) Subject: [project @ 2005-01-31 13:51:22 by simonmar] X-Git-Tag: nhc98-1-18-release~53 X-Git-Url: http://git.megacz.com/?p=haskell-directory.git;a=commitdiff_plain;h=65e3818434e254ed37b16bf4e26bf3ff2dec153f [project @ 2005-01-31 13:51:22 by simonmar] Some improvements to System.Cmd.{system,rawSystem} on Un*x systems: these commands now do the appropriate signal handling, namely ignoring SIGINT/SIGQUIT in the parent but allowing these signals in the child. This behaviour matches the Un*x system(). What this means is that when System.Cmd.system is executing, ^C only kills the child process, the parent will see an exception. --- diff --git a/System/Cmd.hs b/System/Cmd.hs index cf1dc5b..9777bf1 100644 --- a/System/Cmd.hs +++ b/System/Cmd.hs @@ -24,6 +24,10 @@ import System.Exit ( ExitCode ) #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__ @@ -60,9 +64,28 @@ passes the command to the Windows command interpreter (@CMD.EXE@ or #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__ */ {-| @@ -76,8 +99,22 @@ The return codes and possible failures are the same as for 'system'. 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))) diff --git a/System/Process.hs b/System/Process.hs index a3594fb..e2539f5 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -51,14 +51,12 @@ import System.Process.Internals 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 @@ -72,9 +70,10 @@ 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 -- ---------------------------------------------------------------------------- @@ -100,33 +99,9 @@ runProcess #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 @@ -134,7 +109,7 @@ 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 +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 -> @@ -334,74 +309,6 @@ getProcessExitCode (ProcessHandle handle) = 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" 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 + diff --git a/cbits/runProcess.c b/cbits/runProcess.c index 56d4eab..8358605 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -30,7 +30,9 @@ 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) { int pid; struct sigaction dfl; @@ -48,27 +50,18 @@ runProcess (char *const args[], char *workingDirectory, char **environment, chdir (workingDirectory); } - /* - * Restore SIGINT and SIGQUIT to default actions - * - * Glyn Clemments writes: - * For your purposes, runProcess + waitForProcess is probably - * the way to go. Except that runProcess appears to be missing - * the usual signal handling. system() ignores SIGINT and - * SIGQUIT in the parent, and resets them to their defaults in - * the child; it also blocks SIGCHLD in the parent. runProcess - * may need to do something similar; it should probably at - * least reset SIGINT and SIGQUIT in the child, in case they - * are ignored in the parent. The parent can set up its own - * signal handling, but the only place it can control the - * child's signal handling is between the fork() and the - * exec(), so if runProcess doesn't do it, it won't get done. + /* Set the SIGINT/SIGQUIT signal handlers in the child, if requested */ - dfl.sa_handler = SIG_DFL; (void)sigemptyset(&dfl.sa_mask); dfl.sa_flags = 0; - (void)sigaction(SIGINT, &dfl, NULL); - (void)sigaction(SIGQUIT, &dfl, NULL); + if (set_inthandler) { + dfl.sa_handler = (void *)inthandler; + (void)sigaction(SIGINT, &dfl, NULL); + } + if (set_quithandler) { + dfl.sa_handler = (void *)quithandler; + (void)sigaction(SIGQUIT, &dfl, NULL); + } dup2 (fdStdInput, STDIN_FILENO); dup2 (fdStdOutput, STDOUT_FILENO); diff --git a/include/HsBase.h b/include/HsBase.h index 0ea5027..a559774 100644 --- a/include/HsBase.h +++ b/include/HsBase.h @@ -665,44 +665,6 @@ extern void __hscore_set_saved_termios(int fd, void* ts); 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)) diff --git a/include/runProcess.h b/include/runProcess.h index cda5c46..efa4251 100644 --- a/include/runProcess.h +++ b/include/runProcess.h @@ -15,7 +15,9 @@ typedef long ProcHandle; 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,