diff --git a/System/Cmd.hs b/System/Cmd.hs --- a/System/Cmd.hs +++ b/System/Cmd.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : System.Cmd @@ -39,3 +44,4 @@ escape c (b, str) = (False, c : str) #endif + diff --git a/System/Process.hs b/System/Process.hs --- a/System/Process.hs +++ b/System/Process.hs @@ -1,8 +1,9 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} #if __GLASGOW_HASKELL__ >= 701 --- not available prior to 7.1 +{-# LANGUAGE Trustworthy #-} {-# LANGUAGE InterruptibleFFI #-} #endif + ----------------------------------------------------------------------------- -- | -- Module : System.Process @@ -18,36 +19,36 @@ ----------------------------------------------------------------------------- -- ToDo: --- * Flag to control whether exiting the parent also kills the child. +-- * Flag to control whether exiting the parent also kills the child. {- NOTES on createPipe: createPipe is no longer exported, because of the following problems: - - it wasn't used to implement runInteractiveProcess on Unix, because - the file descriptors for the unused ends of the pipe need to be closed - in the child process. + - it wasn't used to implement runInteractiveProcess on Unix, because + the file descriptors for the unused ends of the pipe need to be closed + in the child process. - on Windows, a special version of createPipe is needed that sets - the inheritance flags correctly on the ends of the pipe (see - mkAnonPipe below). + the inheritance flags correctly on the ends of the pipe (see + mkAnonPipe below). -} module System.Process ( #ifndef __HUGS__ - -- * Running sub-processes + -- * Running sub-processes createProcess, shell, proc, CreateProcess(..), CmdSpec(..), StdStream(..), - ProcessHandle, + ProcessHandle, -- ** Specific variants of createProcess - runCommand, - runProcess, - runInteractiveCommand, - runInteractiveProcess, + runCommand, + runProcess, + runInteractiveCommand, + runInteractiveProcess, readProcess, readProcessWithExitCode, #endif @@ -56,11 +57,11 @@ showCommandForUser, #ifndef __HUGS__ - -- * Process completion - waitForProcess, - getProcessExitCode, - terminateProcess, - interruptProcessGroupOf, + -- * Process completion + waitForProcess, + getProcessExitCode, + terminateProcess, + interruptProcessGroupOf, #endif ) where @@ -70,6 +71,12 @@ import System.Process.Internals import System.IO.Error +#if !defined(mingw32_HOST_OS) +import System.Posix.Types +#if MIN_VERSION_unix(2,5,0) +import System.Posix.Process (getProcessGroupIDOf) +#endif +#endif import qualified Control.Exception as C import Control.Concurrent import Control.Monad @@ -78,13 +85,13 @@ import System.IO import Data.Maybe #endif -import System.Exit ( ExitCode(..) ) +import System.Exit ( ExitCode(..) ) #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Exception ( ioException, IOErrorType(..) ) +import GHC.IO.Exception ( ioException, IOErrorType(..) ) #else -import GHC.IOBase ( ioException, IOErrorType(..) ) +import GHC.IOBase ( ioException, IOErrorType(..) ) #endif #if defined(mingw32_HOST_OS) import System.Win32.Process (getProcessId) @@ -132,13 +139,13 @@ 'runProcess'. -} runProcess - :: 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@ (Nothing => use existing @stdin@) - -> Maybe Handle -- ^ Handle to use for @stdout@ (Nothing => use existing @stdout@) - -> Maybe Handle -- ^ Handle to use for @stderr@ (Nothing => use existing @stderr@) + :: 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@ (Nothing => use existing @stdin@) + -> Maybe Handle -- ^ Handle to use for @stdout@ (Nothing => use existing @stdout@) + -> Maybe Handle -- ^ Handle to use for @stderr@ (Nothing => use existing @stderr@) -> IO ProcessHandle runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do @@ -149,7 +156,7 @@ std_in = mbToStd mb_stdin, std_out = mbToStd mb_stdout, std_err = mbToStd mb_stderr } - Nothing Nothing + Nothing Nothing maybeClose mb_stdin maybeClose mb_stdout maybeClose mb_stderr @@ -276,10 +283,10 @@ in text mode then use 'hSetBinaryMode'. -} runInteractiveProcess - :: 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) + :: 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) -> IO (Handle,Handle,Handle,ProcessHandle) runInteractiveProcess cmd args mb_cwd mb_env = do @@ -316,9 +323,9 @@ case p_ of ClosedHandle e -> return e OpenHandle h -> do - -- don't hold the MVar while we call c_waitForProcess... - -- (XXX but there's a small race window here during which another - -- thread could close the handle or call waitForProcess) + -- don't hold the MVar while we call c_waitForProcess... + -- (XXX but there's a small race window here during which another + -- thread could close the handle or call waitForProcess) alloca $ \pret -> do throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) withProcessHandle ph $ \p_' -> @@ -341,6 +348,9 @@ -- Output is returned strictly, so this is not suitable for -- interactive applications. -- +-- This function throws an 'IOError' if the process 'ExitCode' is +-- anything other than 'ExitSuccess'. +-- -- Users of this function should compile with @-threaded@ if they -- want other Haskell threads to keep running while waiting on -- the result of readProcess. @@ -484,7 +494,7 @@ old_int <- installHandler sigINT Ignore Nothing old_quit <- installHandler sigQUIT Ignore Nothing (_,_,_,p) <- runGenProcess_ fun c - (Just defaultSignal) (Just defaultSignal) + (Just defaultSignal) (Just defaultSignal) r <- waitForProcess p _ <- installHandler sigINT old_int Nothing _ <- installHandler sigQUIT old_quit Nothing @@ -546,9 +556,9 @@ ClosedHandle _ -> return p_ OpenHandle h -> do throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h - return p_ - -- does not close the handle, we might want to try terminating it - -- again, or get its exit code. + return p_ + -- does not close the handle, we might want to try terminating it + -- again, or get its exit code. -- ---------------------------------------------------------------------------- -- interruptProcessGroupOf @@ -561,7 +571,7 @@ -- processes created using 'createProcess' and setting the 'create_group' flag interruptProcessGroupOf - :: ProcessHandle -- ^ Lead process in the process group + :: ProcessHandle -- ^ A process in the process group -> IO () interruptProcessGroupOf ph = do #if mingw32_HOST_OS @@ -577,7 +587,13 @@ case p_ of ClosedHandle _ -> return p_ OpenHandle h -> do +#if MIN_VERSION_unix(2,5,0) + -- getProcessGroupIDOf was added in unix-2.5.0.0 + pgid <- getProcessGroupIDOf h + signalProcessGroup sigINT pgid +#else signalProcessGroup sigINT h +#endif return p_ #endif @@ -595,31 +611,31 @@ case p_ of ClosedHandle e -> return (p_, Just e) OpenHandle h -> - alloca $ \pExitCode -> do + alloca $ \pExitCode -> do res <- throwErrnoIfMinus1Retry "getProcessExitCode" $ - c_getProcessExitCode h pExitCode - code <- peek pExitCode - if res == 0 - then return (p_, Nothing) - else do - closePHANDLE h - let e | code == 0 = ExitSuccess - | otherwise = ExitFailure (fromIntegral code) - return (ClosedHandle e, Just e) + c_getProcessExitCode h pExitCode + code <- peek pExitCode + if res == 0 + then return (p_, Nothing) + else do + closePHANDLE h + let e | code == 0 = ExitSuccess + | otherwise = ExitFailure (fromIntegral code) + return (ClosedHandle e, Just e) -- ---------------------------------------------------------------------------- -- Interface to C bits foreign import ccall unsafe "terminateProcess" c_terminateProcess - :: PHANDLE - -> IO CInt + :: PHANDLE + -> IO CInt foreign import ccall unsafe "getProcessExitCode" c_getProcessExitCode - :: PHANDLE - -> Ptr CInt - -> IO CInt + :: PHANDLE + -> Ptr CInt + -> IO CInt #if __GLASGOW_HASKELL__ < 701 -- not available prior to 7.1 @@ -628,7 +644,8 @@ foreign import ccall interruptible "waitForProcess" -- NB. safe - can block c_waitForProcess - :: PHANDLE + :: PHANDLE -> Ptr CInt - -> IO CInt + -> IO CInt #endif /* !__HUGS__ */ + diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -2,6 +2,9 @@ {-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -w #-} -- XXX We get some warnings on Windows +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif ----------------------------------------------------------------------------- -- | @@ -20,21 +23,21 @@ -- #hide module System.Process.Internals ( #ifndef __HUGS__ - ProcessHandle(..), ProcessHandle__(..), - PHANDLE, closePHANDLE, mkProcessHandle, - withProcessHandle, withProcessHandle_, + ProcessHandle(..), ProcessHandle__(..), + PHANDLE, closePHANDLE, mkProcessHandle, + withProcessHandle, withProcessHandle_, #ifdef __GLASGOW_HASKELL__ CreateProcess(..), CmdSpec(..), StdStream(..), - runGenProcess_, + runGenProcess_, #endif #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - pPrPr_disableITimers, c_execvpe, - ignoreSignal, defaultSignal, + pPrPr_disableITimers, c_execvpe, + ignoreSignal, defaultSignal, #endif #endif - withFilePathException, withCEnvironment, - translate, + withFilePathException, withCEnvironment, + translate, #ifndef __HUGS__ fdToHandle, @@ -43,17 +46,17 @@ #ifndef __HUGS__ #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) -import System.Posix.Types ( CPid ) +import System.Posix.Types import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe ) -import System.IO ( IOMode(..) ) +import System.IO ( IOMode(..) ) #else import Data.Word ( Word32 ) import Data.IORef #endif #endif -import System.IO ( Handle ) -import System.Exit ( ExitCode ) +import System.IO ( Handle ) +import System.Exit ( ExitCode ) import Control.Concurrent import Control.Exception import Foreign.C @@ -78,25 +81,25 @@ import System.Win32.DebugApi (PHANDLE) #endif #else -import GHC.IOBase ( haFD, FD, IOException(..) ) +import GHC.IOBase ( haFD, FD, IOException(..) ) import GHC.Handle #endif # elif __HUGS__ -import Hugs.Exception ( IOException(..) ) +import Hugs.Exception ( IOException(..) ) # endif #ifdef base4 -import System.IO.Error ( ioeSetFileName ) +import System.IO.Error ( ioeSetFileName ) #endif #if defined(mingw32_HOST_OS) -import Control.Monad ( when ) -import System.Directory ( doesFileExist ) -import System.IO.Error ( isDoesNotExistError, doesNotExistErrorType, - mkIOError ) -import System.Environment ( getEnv ) +import Control.Monad ( when ) +import System.Directory ( doesFileExist ) +import System.IO.Error ( isDoesNotExistError, doesNotExistErrorType, + mkIOError ) +import System.Environment ( getEnv ) import System.FilePath #endif @@ -122,15 +125,15 @@ newtype ProcessHandle = ProcessHandle (MVar ProcessHandle__) withProcessHandle - :: ProcessHandle - -> (ProcessHandle__ -> IO (ProcessHandle__, a)) - -> IO a + :: ProcessHandle + -> (ProcessHandle__ -> IO (ProcessHandle__, a)) + -> IO a withProcessHandle (ProcessHandle m) io = modifyMVar m io withProcessHandle_ - :: ProcessHandle - -> (ProcessHandle__ -> IO ProcessHandle__) - -> IO () + :: ProcessHandle + -> (ProcessHandle__ -> IO ProcessHandle__) + -> IO () withProcessHandle_ (ProcessHandle m) io = modifyMVar_ m io #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) @@ -164,18 +167,18 @@ processHandleFinaliser m = modifyMVar_ m $ \p_ -> do - case p_ of - OpenHandle ph -> closePHANDLE ph - _ -> return () - return (error "closed process handle") + 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 () + :: PHANDLE + -> IO () #endif #endif /* !__HUGS__ */ @@ -209,8 +212,8 @@ runGenProcess_ :: String -- ^ function name (for error messages) -> CreateProcess - -> Maybe CLong -- ^ handler for SIGINT - -> Maybe CLong -- ^ handler for SIGQUIT + -> Maybe CLong -- ^ handler for SIGINT + -> Maybe CLong -- ^ handler for SIGQUIT -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) @@ -245,13 +248,13 @@ fderr <- mbFd fun fd_stderr mb_stderr 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) + = 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) -- runInteractiveProcess() blocks signals around the fork(). -- Since blocking/unblocking of signals is a global state @@ -259,10 +262,10 @@ -- runInteractiveProcess(). proc_handle <- withMVar runInteractiveProcess_lock $ \_ -> throwErrnoIfMinus1 fun $ - c_runInteractiveProcess pargs pWorkDir pEnv + c_runInteractiveProcess pargs pWorkDir pEnv fdin fdout fderr - pfdStdInput pfdStdOutput pfdStdError - set_int inthand set_quit quithand + pfdStdInput pfdStdOutput pfdStdError + set_int inthand set_quit quithand ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)) @@ -280,7 +283,7 @@ foreign import ccall unsafe "runInteractiveProcess" c_runInteractiveProcess :: Ptr CString - -> CString + -> CString -> Ptr CString -> FD -> FD @@ -288,10 +291,10 @@ -> Ptr FD -> Ptr FD -> Ptr FD - -> CInt -- non-zero: set child's SIGINT handler - -> CLong -- SIGINT handler - -> CInt -- non-zero: set child's SIGQUIT handler - -> CLong -- SIGQUIT handler + -> CInt -- non-zero: set child's SIGINT handler + -> CLong -- SIGINT handler + -> CInt -- non-zero: set child's SIGQUIT handler + -> CLong -- SIGQUIT handler -> CInt -- flags -> IO PHANDLE @@ -340,9 +343,9 @@ -- the threaded RTS. proc_handle <- withMVar runInteractiveProcess_lock $ \_ -> throwErrnoIfBadPHandle fun $ - c_runInteractiveProcess pcmdline pWorkDir pEnv + c_runInteractiveProcess pcmdline pWorkDir pEnv fdin fdout fderr - pfdStdInput pfdStdOutput pfdStdError + pfdStdInput pfdStdOutput pfdStdError ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)) @@ -395,7 +398,7 @@ return (Handle__{haDevice=fd,..}, FD.fdFD fd) Nothing -> ioError (mkIOError illegalOperationErrorType - "createProcess" (Just hdl) Nothing + "createProcess" (Just hdl) Nothing `ioeSetErrorString` "handle is not a file descriptor") #endif @@ -413,14 +416,19 @@ False {-is_socket-} False {-non-blocking-} fD <- FD.setNonBlockingMode fD True -- see #3316 - mkHandleFromFD fD fd_type filepath mode False{-is_socket-} - (Just localeEncoding) + enc <- getLocaleEncoding + mkHandleFromFD fD fd_type filepath mode False {-is_socket-} (Just enc) #else fdToHandle' fd (Just Stream) - False{-Windows: not a socket, Unix: don't set non-blocking-} - filepath mode True{-binary-} + False {-Windows: not a socket, Unix: don't set non-blocking-} + filepath mode True {-binary-} #endif +#if __GLASGOW_HASKELL__ < 703 +getLocaleEncoding :: IO TextEncoding +getLocaleEncoding = return localeEncoding +#endif + #ifndef __HUGS__ -- ---------------------------------------------------------------------------- -- commandToProcess @@ -452,13 +460,13 @@ -> IO (FilePath, String) commandToProcess (ShellCommand string) = do cmd <- findCommandInterpreter - return (cmd, translate 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. + return (cmd, translate 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. commandToProcess (RawCommand cmd args) = do return (cmd, translate cmd ++ concatMap ((' ':) . translate) args) @@ -487,24 +495,24 @@ -} 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 + -- 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) + "findCommandInterpreter" Nothing Nothing) Just cmd -> return cmd #endif diff --git a/include/processFlags.h b/include/processFlags.h new file mode 100644 --- /dev/null +++ b/include/processFlags.h @@ -0,0 +1,8 @@ +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Flags used in runProcess.c and for System.Process.Internals + ------------------------------------------------------------------------- */ + +#define RUN_PROCESS_IN_CLOSE_FDS 0x1 +#define RUN_PROCESS_IN_NEW_GROUP 0x2 diff --git a/process.cabal b/process.cabal --- a/process.cabal +++ b/process.cabal @@ -1,5 +1,5 @@ name: process -version: 1.1.0.0 +version: 1.1.0.1 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -38,6 +38,7 @@ runProcess.h install-includes: runProcess.h + processFlags.h HsProcessConfig.h if os(windows) build-depends: Win32 >=2.2.0.0 @@ -57,7 +58,7 @@ } build-depends: directory >= 1.0 && < 1.2, - filepath >= 1.1 && < 1.3 + filepath >= 1.1 && < 1.4 extensions: CPP }