From: Ian Lynagh Date: Wed, 23 May 2007 21:05:23 +0000 (+0000) Subject: Split off process package X-Git-Tag: 2007-09-13~84 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=aa78dcac9ef64c92c70894977c3a14685134dca6;p=ghc-base.git Split off process package --- diff --git a/Setup.hs b/Setup.hs index 693b16d..927f409 100644 --- a/Setup.hs +++ b/Setup.hs @@ -120,7 +120,7 @@ isPortableBuild :: String -> Bool isPortableBuild s | "GHC" `isPrefixOf` s = False | "Data.Generics" `isPrefixOf` s = False - | otherwise = s `notElem` ["Foreign.Concurrent", "System.Process"] + | otherwise = s `notElem` ["Foreign.Concurrent"] forGHCBuild :: String -> Bool forGHCBuild = ("GHC.Prim" /=) diff --git a/System/Cmd.hs b/System/Cmd.hs deleted file mode 100644 index 2d8635f..0000000 --- a/System/Cmd.hs +++ /dev/null @@ -1,140 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : System.Cmd --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- Executing an external command. --- ------------------------------------------------------------------------------ - -module System.Cmd - ( system, -- :: String -> IO ExitCode - rawSystem, -- :: FilePath -> [String] -> IO ExitCode - ) where - -import Prelude - -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__ -import Hugs.System -#endif - -#ifdef __NHC__ -import System (system) -#endif - --- --------------------------------------------------------------------------- --- system - -{-| -Computation @system cmd@ returns the exit code -produced when the operating system processes the command @cmd@. - -This computation may fail with - - * @PermissionDenied@: The process has insufficient privileges to - perform the operation. - - * @ResourceExhausted@: Insufficient resources are available to - perform the operation. - - * @UnsupportedOperation@: The implementation does not support - system calls. - -On Windows, 'system' is implemented using Windows's native system -call, which ignores the @SHELL@ environment variable, and always -passes the command to the Windows command interpreter (@CMD.EXE@ or -@COMMAND.COM@), hence Unixy shell tricks will not work. --} -#ifdef __GLASGOW_HASKELL__ -system :: String -> IO ExitCode -system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing) -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__ */ - -{-| -The computation @'rawSystem' cmd args@ runs the operating system command -@cmd@ in such a way that it receives as arguments the @args@ strings -exactly as given, with no funny escaping or shell meta-syntax expansion. -It will therefore behave more portably between operating systems than 'system'. - -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 - -#elif !mingw32_HOST_OS --- crude fallback implementation: could do much better than this under Unix -rawSystem cmd args = system (unwords (map translate (cmd:args))) - -translate :: String -> String -translate str = '\'' : foldr escape "'" str - where escape '\'' = showString "'\\''" - escape c = showChar c -#else /* mingw32_HOST_OS && ! __GLASGOW_HASKELL__ */ -# if __HUGS__ -rawSystem cmd args = system (unwords (cmd : map translate args)) -# else -rawSystem cmd args = system (unwords (map translate (cmd:args))) -#endif - --- copied from System.Process (qv) -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 diff --git a/System/Process.hs b/System/Process.hs deleted file mode 100644 index f2e937e..0000000 --- a/System/Process.hs +++ /dev/null @@ -1,326 +0,0 @@ -{-# OPTIONS_GHC -cpp -fffi #-} ------------------------------------------------------------------------------ --- | --- Module : System.Process --- Copyright : (c) The University of Glasgow 2004 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Operations for creating and interacting with sub-processes. --- ------------------------------------------------------------------------------ - --- ToDo: --- * Flag to control whether exiting the parent also kills the child. --- * Windows impl of runProcess should close the Handles. --- * Add system/rawSystem replacements - -{- 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. - - - on Windows, a special version of createPipe is needed that sets - the inheritance flags correctly on the ends of the pipe (see - mkAnonPipe below). --} - -module System.Process ( - -- * Running sub-processes - ProcessHandle, - runCommand, - runProcess, - runInteractiveCommand, - runInteractiveProcess, - - -- * Process completion - waitForProcess, - getProcessExitCode, - terminateProcess, - ) where - -import Prelude - -import System.Process.Internals - -import Foreign -import Foreign.C -import System.IO ( IOMode(..), Handle, hClose ) -import System.Exit ( ExitCode(..) ) - -import System.Posix.Internals -import GHC.IOBase ( FD ) -import GHC.Handle ( openFd ) - --- ---------------------------------------------------------------------------- --- runCommand - -{- | Runs a command using the shell. - -} -runCommand - :: String - -> IO ProcessHandle - -runCommand string = do - (cmd,args) <- commandToProcess string -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - runProcessPosix "runCommand" cmd args Nothing Nothing Nothing Nothing Nothing - Nothing Nothing -#else - runProcessWin32 "runCommand" cmd [] Nothing Nothing Nothing Nothing Nothing args -#endif - --- ---------------------------------------------------------------------------- --- runProcess - -{- | Runs a raw command, optionally specifying 'Handle's from which to - take the @stdin@, @stdout@ and @stderr@ channels for the new - process (otherwise these handles are inherited from the current - process). - - Any 'Handle's passed to 'runProcess' are placed immediately in the - closed state. --} -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@ - -> Maybe Handle -- ^ Handle to use for @stdout@ - -> Maybe Handle -- ^ Handle to use for @stderr@ - -> IO ProcessHandle - -runProcess cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr = do -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - h <- runProcessPosix "runProcess" cmd args mb_cwd mb_env - mb_stdin mb_stdout mb_stderr - Nothing Nothing -#else - h <- runProcessWin32 "runProcess" cmd args mb_cwd mb_env - mb_stdin mb_stdout mb_stderr "" -#endif - maybe (return ()) hClose mb_stdin - maybe (return ()) hClose mb_stdout - maybe (return ()) hClose mb_stderr - return h - --- ---------------------------------------------------------------------------- --- runInteractiveCommand - -{- | Runs a command using the shell, and returns 'Handle's that may - be used to communicate with the process via its @stdin@, @stdout@, - and @stderr@ respectively. --} -runInteractiveCommand - :: String - -> IO (Handle,Handle,Handle,ProcessHandle) - -runInteractiveCommand string = do - (cmd,args) <- commandToProcess string -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - runInteractiveProcess1 "runInteractiveCommand" cmd args Nothing Nothing -#else - runInteractiveProcess1 "runInteractiveCommand" cmd [] Nothing Nothing args -#endif - --- ---------------------------------------------------------------------------- --- runInteractiveProcess - -{- | Runs a raw command, and returns 'Handle's that may be used to communicate - with the process via its @stdin@, @stdout@ and @stderr@ respectively. - - For example, to start a process and feed a string to its stdin: - -> (inp,out,err,pid) <- runInteractiveProcess "..." -> forkIO (hPutStr inp str) --} -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) - -> IO (Handle,Handle,Handle,ProcessHandle) - -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - -runInteractiveProcess cmd args mb_cwd mb_env = - runInteractiveProcess1 "runInteractiveProcess" cmd args mb_cwd mb_env - -runInteractiveProcess1 fun cmd args mb_cwd mb_env = do - withFilePathException cmd $ - alloca $ \ pfdStdInput -> - alloca $ \ pfdStdOutput -> - alloca $ \ pfdStdError -> - maybeWith withCEnvironment mb_env $ \pEnv -> - maybeWith withCString mb_cwd $ \pWorkDir -> - withMany withCString (cmd:args) $ \cstrs -> - withArray0 nullPtr cstrs $ \pargs -> do - proc_handle <- throwErrnoIfMinus1 fun - (c_runInteractiveProcess pargs pWorkDir pEnv - pfdStdInput pfdStdOutput pfdStdError) - hndStdInput <- fdToHandle pfdStdInput WriteMode - hndStdOutput <- fdToHandle pfdStdOutput ReadMode - hndStdError <- fdToHandle pfdStdError ReadMode - ph <- mkProcessHandle proc_handle - return (hndStdInput, hndStdOutput, hndStdError, ph) - -foreign import ccall unsafe "runInteractiveProcess" - c_runInteractiveProcess - :: Ptr CString - -> CString - -> Ptr CString - -> Ptr FD - -> Ptr FD - -> Ptr FD - -> IO PHANDLE - -#else - -runInteractiveProcess cmd args mb_cwd mb_env = - runInteractiveProcess1 "runInteractiveProcess" cmd args mb_cwd mb_env "" - -runInteractiveProcess1 fun cmd args workDir env extra_cmdline - = withFilePathException cmd $ do - let cmdline = translate cmd ++ - concat (map ((' ':) . translate) args) ++ - (if null extra_cmdline then "" else ' ':extra_cmdline) - withCString cmdline $ \pcmdline -> - alloca $ \ pfdStdInput -> - alloca $ \ pfdStdOutput -> - alloca $ \ pfdStdError -> do - maybeWith withCEnvironment env $ \pEnv -> do - maybeWith withCString workDir $ \pWorkDir -> do - proc_handle <- throwErrnoIfMinus1 fun $ - c_runInteractiveProcess pcmdline pWorkDir pEnv - pfdStdInput pfdStdOutput pfdStdError - hndStdInput <- fdToHandle pfdStdInput WriteMode - hndStdOutput <- fdToHandle pfdStdOutput ReadMode - hndStdError <- fdToHandle pfdStdError ReadMode - ph <- mkProcessHandle proc_handle - return (hndStdInput, hndStdOutput, hndStdError, ph) - -foreign import ccall unsafe "runInteractiveProcess" - c_runInteractiveProcess - :: CString - -> CString - -> Ptr () - -> Ptr FD - -> Ptr FD - -> Ptr FD - -> IO PHANDLE - -#endif - -fdToHandle :: Ptr FD -> IOMode -> IO Handle -fdToHandle pfd mode = do - fd <- peek pfd - openFd fd (Just Stream) - False{-not a socket-} - ("fd:" ++ show fd) mode True{-binary-} - --- ---------------------------------------------------------------------------- --- waitForProcess - -{- | Waits for the specified process to terminate, and returns its exit code. - - GHC Note: in order to call @waitForProcess@ without blocking all the - other threads in the system, you must compile the program with - @-threaded@. --} -waitForProcess - :: ProcessHandle - -> IO ExitCode -waitForProcess ph = do - p_ <- withProcessHandle ph $ \p_ -> return (p_,p_) - 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) - code <- throwErrnoIfMinus1 "waitForProcess" (c_waitForProcess h) - withProcessHandle ph $ \p_ -> - case p_ of - ClosedHandle e -> return (p_,e) - OpenHandle ph -> do - closePHANDLE ph - let e = if (code == 0) - then ExitSuccess - else (ExitFailure (fromIntegral code)) - return (ClosedHandle e, e) - --- ---------------------------------------------------------------------------- --- terminateProcess - --- | Attempts to terminate the specified process. This function should --- not be used under normal circumstances - no guarantees are given regarding --- how cleanly the process is terminated. To check whether the process --- has indeed terminated, use 'getProcessExitCode'. --- --- On Unix systems, 'terminateProcess' sends the process the SIGKILL signal. --- On Windows systems, the Win32 @TerminateProcess@ function is called, passing --- an exit code of 1. -terminateProcess :: ProcessHandle -> IO () -terminateProcess ph = do - withProcessHandle_ ph $ \p_ -> - case p_ of - ClosedHandle _ -> return p_ - OpenHandle h -> do - throwErrnoIfMinus1_ "terminateProcess" $ c_terminateProcess h - return p_ - -- does not close the handle, we might want to try terminating it - -- again, or get its exit code. - --- ---------------------------------------------------------------------------- --- getProcessExitCode - -{- | -This is a non-blocking version of 'waitForProcess'. If the process is -still running, 'Nothing' is returned. If the process has exited, then -@'Just' e@ is returned where @e@ is the exit code of the process. -Subsequent calls to @getProcessExitStatus@ always return @'Just' -'ExitSuccess'@, regardless of what the original exit code was. --} -getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode) -getProcessExitCode ph = do - withProcessHandle ph $ \p_ -> - case p_ of - ClosedHandle e -> return (p_, Just e) - OpenHandle h -> - alloca $ \pExitCode -> do - res <- throwErrnoIfMinus1 "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) - --- ---------------------------------------------------------------------------- --- Interface to C bits - -foreign import ccall unsafe "terminateProcess" - c_terminateProcess - :: PHANDLE - -> IO CInt - -foreign import ccall unsafe "getProcessExitCode" - c_getProcessExitCode - :: PHANDLE - -> Ptr CInt - -> IO CInt - -foreign import ccall safe "waitForProcess" -- NB. safe - can block - c_waitForProcess - :: PHANDLE - -> IO CInt diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs deleted file mode 100644 index 208d0ff..0000000 --- a/System/Process/Internals.hs +++ /dev/null @@ -1,429 +0,0 @@ -{-# OPTIONS_GHC -cpp -fffi #-} ------------------------------------------------------------------------------ --- | --- Module : System.Process.Internals --- Copyright : (c) The University of Glasgow 2004 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Operations for creating and interacting with sub-processes. --- ------------------------------------------------------------------------------ - --- #hide -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 -- necessary to get dependencies right - -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) -import System.Posix.Types ( CPid ) -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.Directory.Internals ( parseSearchPath, joinFileName ) -#endif - -#ifdef __HUGS__ -{-# CFILES cbits/execvpe.c #-} -#endif - -#include "HsBaseConfig.h" - -#ifndef __HUGS__ --- ---------------------------------------------------------------------------- --- ProcessHandle type - -{- | A handle to a process, which can be used to wait for termination - of the process using 'waitForProcess'. - - None of the process-creation functions in this library wait for - termination: they all return a 'ProcessHandle' which may be used - to wait for the process later. --} -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 - --- On Windows, we have to close this HANDLE when it is no longer required, --- hence we add a finalizer to it, using an IORef as the box on which to --- attach the finalizer. -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__) - --- this function disables the itimer, which would otherwise cause confusing --- signals to be sent to the new process. -foreign import ccall unsafe "pPrPr_disableITimers" - pPrPr_disableITimers :: IO () - -foreign import ccall unsafe "execvpe" - c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt - -#endif - -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - -#ifdef __GLASGOW_HASKELL__ --- ----------------------------------------------------------------------------- --- POSIX runProcess with signal handling in the child - -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 $ 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 - -- some of these might refer to the same Handle, so don't do - -- nested withHandle_'s (that will deadlock). - 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 -- 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 /* __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 - -- some of these might refer to the same Handle, so don't do - -- nested withHandle_'s (that will deadlock). - 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 - --- ------------------------------------------------------------------------ --- Passing commands to the OS on Windows - -{- -On Windows this is tricky. We use CreateProcess, passing a single -command-line string (lpCommandLine) as its argument. (CreateProcess -is well documented on http://msdn.microsoft/com.) - - - It parses the beginning of the string to find the command. If the - file name has embedded spaces, it must be quoted, using double - quotes thus - "foo\this that\cmd" arg1 arg2 - - - The invoked command can in turn access the entire lpCommandLine string, - and the C runtime does indeed do so, parsing it to generate the - traditional argument vector argv[0], argv[1], etc. It does this - using a complex and arcane set of rules which are described here: - - http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp - - (if this URL stops working, you might be able to find it by - searching for "Parsing C Command-Line Arguments" on MSDN. Also, - the code in the Microsoft C runtime that does this translation - is shipped with VC++). - -Our goal in runProcess is to take a command filename and list of -arguments, and construct a string which inverts the translatsions -described above, such that the program at the other end sees exactly -the same arguments in its argv[] that we passed to rawSystem. - -This inverse translation is implemented by 'translate' below. - -Here are some pages that give informations on Windows-related -limitations and deviations from Unix conventions: - - http://support.microsoft.com/default.aspx?scid=kb;en-us;830473 - Command lines and environment variables effectively limited to 8191 - characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x): - - http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp - Command-line substitution under Windows XP. IIRC these facilities (or at - least a large subset of them) are available on Win NT and 2000. Some - might be available on Win 9x. - - http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp - How CMD.EXE processes command lines. - - -Note: CreateProcess does have a separate argument (lpApplicationName) -with which you can specify the command, but we have to slap the -command into lpCommandLine anyway, so that argv[0] is what a C program -expects (namely the application name). So it seems simpler to just -use lpCommandLine alone, which CreateProcess supports. --} - --- Translate command-line arguments for passing to CreateProcess(). -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) - -- See long comment above for what this function is trying to do. - -- - -- The Bool passed back along the string is True iff the - -- rest of the string is a sequence of backslashes followed by - -- a double quote. - -#endif /* __GLASGOW_HASKELL__ */ - -#endif - -#ifndef __HUGS__ --- ---------------------------------------------------------------------------- --- 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 - cmd <- findCommandInterpreter - return (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. - --- Find CMD.EXE (or COMMAND.COM on Win98). We use the same algorithm as --- system() in the VC++ CRT (Vc7/crt/src/system.c in a VC++ installation). -findCommandInterpreter :: IO FilePath -findCommandInterpreter = do - -- try COMSPEC first - catchJust ioErrors (getEnv "COMSPEC") $ \e -> do - when (not (isDoesNotExistError e)) $ ioError e - - -- try to find CMD.EXE or COMMAND.COM - osver <- c_get_osver - let filename | osver .&. 0x8000 /= 0 = "command.com" - | otherwise = "cmd.exe" - 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 path = d `joinFileName` filename - b <- doesFileExist path - if b then return (Just path) - else search ds - -- - mb_path <- search (parseSearchPath path) - - case mb_path of - Nothing -> ioError (mkIOError doesNotExistErrorType - "findCommandInterpreter" Nothing Nothing) - Just cmd -> return cmd - - -foreign import ccall unsafe "__hscore_get_osver" - c_get_osver :: IO CUInt -#endif - -#endif /* __HUGS__ */ - --- ---------------------------------------------------------------------------- --- 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/base.cabal b/base.cabal index 2e2ae36..38973f2 100644 --- a/base.cabal +++ b/base.cabal @@ -135,7 +135,6 @@ exposed-modules: GHC.Word, Numeric, Prelude, - System.Cmd, System.Console.GetOpt, System.CPUTime, System.Environment, @@ -150,8 +149,6 @@ exposed-modules: System.Posix.Internals, System.Posix.Signals, System.Posix.Types, - System.Process, - System.Process.Internals, Text.ParserCombinators.ReadP, Text.ParserCombinators.ReadPrec, Text.Printf, @@ -168,12 +165,10 @@ c-sources: cbits/Win32Utils.c cbits/consUtils.c cbits/dirUtils.c - cbits/execvpe.c cbits/fpstring.c cbits/inputReady.c cbits/lockFile.c cbits/longlong.c - cbits/runProcess.c cbits/selectUtils.c include-dirs: include, ../../includes, ../../rts includes: HsBase.h diff --git a/cbits/execvpe.c b/cbits/execvpe.c deleted file mode 100644 index eb24bd3..0000000 --- a/cbits/execvpe.c +++ /dev/null @@ -1,175 +0,0 @@ -/* ----------------------------------------------------------------------------- - (c) The University of Glasgow 1995-2004 - - Our low-level exec() variant. - -------------------------------------------------------------------------- */ -#include "HsBase.h" - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) /* to the end */ - -/* Evidently non-Posix. */ -/* #include "PosixSource.h" */ - -#include -#include -#include -#include -#include - -/* - * We want the search semantics of execvp, but we want to provide our - * own environment, like execve. The following copyright applies to - * this code, as it is a derivative of execvp: - *- - * Copyright (c) 1991 The Regents of the University of California. - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. All advertising materials mentioning features or use of this software - * must display the following acknowledgement: - * This product includes software developed by the University of - * California, Berkeley and its contributors. - * 4. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - * SUCH DAMAGE. - */ - -int -execvpe(char *name, char *const argv[], char **envp) -{ - register int lp, ln; - register char *p; - int eacces=0, etxtbsy=0; - char *bp, *cur, *path, *buf = 0; - - /* If it's an absolute or relative path name, it's easy. */ - if (strchr(name, '/')) { - bp = (char *) name; - cur = path = buf = NULL; - goto retry; - } - - /* Get the path we're searching. */ - if (!(path = getenv("PATH"))) { -#ifdef HAVE_CONFSTR - ln = confstr(_CS_PATH, NULL, 0); - if ((cur = path = malloc(ln + 1)) != NULL) { - path[0] = ':'; - (void) confstr (_CS_PATH, path + 1, ln); - } -#else - if ((cur = path = malloc(1 + 1)) != NULL) { - path[0] = ':'; - path[1] = '\0'; - } -#endif - } else - cur = path = strdup(path); - - if (path == NULL || (bp = buf = malloc(strlen(path)+strlen(name)+2)) == NULL) - goto done; - - while (cur != NULL) { - p = cur; - if ((cur = strchr(cur, ':')) != NULL) - *cur++ = '\0'; - - /* - * It's a SHELL path -- double, leading and trailing colons mean the current - * directory. - */ - if (!*p) { - p = "."; - lp = 1; - } else - lp = strlen(p); - ln = strlen(name); - - memcpy(buf, p, lp); - buf[lp] = '/'; - memcpy(buf + lp + 1, name, ln); - buf[lp + ln + 1] = '\0'; - - retry: - (void) execve(bp, argv, envp); - switch (errno) { - case EACCES: - eacces = 1; - break; - case ENOENT: - break; - case ENOEXEC: - { - register size_t cnt; - register char **ap; - - for (cnt = 0, ap = (char **) argv; *ap; ++ap, ++cnt) - ; - if ((ap = malloc((cnt + 2) * sizeof(char *))) != NULL) { - memcpy(ap + 2, argv + 1, cnt * sizeof(char *)); - - ap[0] = "sh"; - ap[1] = bp; - (void) execve("/bin/sh", ap, envp); - free(ap); - } - goto done; - } - case ETXTBSY: - if (etxtbsy < 3) - (void) sleep(++etxtbsy); - goto retry; - default: - goto done; - } - } - if (eacces) - errno = EACCES; - else if (!errno) - errno = ENOENT; - done: - if (path) - free(path); - if (buf) - free(buf); - return (-1); -} - - -/* Copied verbatim from ghc/lib/std/cbits/system.c. */ -void pPrPr_disableITimers (void) -{ -# ifdef HAVE_SETITIMER - /* Reset the itimers in the child, so it doesn't get plagued - * by SIGVTALRM interrupts. - */ - struct timeval tv_null = { 0, 0 }; - struct itimerval itv; - itv.it_interval = tv_null; - itv.it_value = tv_null; - setitimer(ITIMER_REAL, &itv, NULL); - setitimer(ITIMER_VIRTUAL, &itv, NULL); - setitimer(ITIMER_PROF, &itv, NULL); -# endif -} - -#endif diff --git a/cbits/runProcess.c b/cbits/runProcess.c deleted file mode 100644 index 93aa8c4..0000000 --- a/cbits/runProcess.c +++ /dev/null @@ -1,461 +0,0 @@ -/* ---------------------------------------------------------------------------- - (c) The University of Glasgow 2004 - - Support for System.Process - ------------------------------------------------------------------------- */ - -#include "HsBase.h" - -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) -#include -#include -#endif - -#ifdef HAVE_VFORK_H -#include -#endif - -#ifdef HAVE_VFORK -#define fork vfork -#endif - -#ifdef HAVE_SIGNAL_H -#include -#endif - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) -/* ---------------------------------------------------------------------------- - UNIX versions - ------------------------------------------------------------------------- */ - -ProcHandle -runProcess (char *const args[], char *workingDirectory, char **environment, - int fdStdInput, int fdStdOutput, int fdStdError, - int set_inthandler, long inthandler, - int set_quithandler, long quithandler) -{ - int pid; - struct sigaction dfl; - - switch(pid = fork()) - { - case -1: - return -1; - - case 0: - { - pPrPr_disableITimers(); - - if (workingDirectory) { - if (chdir (workingDirectory) < 0) { - return -1; - } - } - - /* Set the SIGINT/SIGQUIT signal handlers in the child, if requested - */ - (void)sigemptyset(&dfl.sa_mask); - dfl.sa_flags = 0; - 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); - dup2 (fdStdError, STDERR_FILENO); - - if (environment) { - execvpe(args[0], args, environment); - } else { - execvp(args[0], args); - } - } - _exit(127); - } - - return pid; -} - -ProcHandle -runInteractiveProcess (char *const args[], - char *workingDirectory, char **environment, - int *pfdStdInput, int *pfdStdOutput, int *pfdStdError) -{ - int pid; - int fdStdInput[2], fdStdOutput[2], fdStdError[2]; - - pipe(fdStdInput); - pipe(fdStdOutput); - pipe(fdStdError); - - switch(pid = fork()) - { - case -1: - close(fdStdInput[0]); - close(fdStdInput[1]); - close(fdStdOutput[0]); - close(fdStdOutput[1]); - close(fdStdError[0]); - close(fdStdError[1]); - return -1; - - case 0: - { - pPrPr_disableITimers(); - - if (workingDirectory) { - if (chdir (workingDirectory) < 0) { - return -1; - } - } - - if (fdStdInput[0] != STDIN_FILENO) { - dup2 (fdStdInput[0], STDIN_FILENO); - close(fdStdInput[0]); - } - - if (fdStdOutput[1] != STDOUT_FILENO) { - dup2 (fdStdOutput[1], STDOUT_FILENO); - close(fdStdOutput[1]); - } - - if (fdStdError[1] != STDERR_FILENO) { - dup2 (fdStdError[1], STDERR_FILENO); - close(fdStdError[1]); - } - - close(fdStdInput[1]); - close(fdStdOutput[0]); - close(fdStdError[0]); - - /* the child */ - if (environment) { - execvpe(args[0], args, environment); - } else { - execvp(args[0], args); - } - } - _exit(127); - - default: - close(fdStdInput[0]); - close(fdStdOutput[1]); - close(fdStdError[1]); - - *pfdStdInput = fdStdInput[1]; - *pfdStdOutput = fdStdOutput[0]; - *pfdStdError = fdStdError[0]; - break; - } - - return pid; -} - -int -terminateProcess (ProcHandle handle) -{ - return (kill(handle, SIGTERM) == 0); -} - -int -getProcessExitCode (ProcHandle handle, int *pExitCode) -{ - int wstat, res; - - *pExitCode = 0; - - if ((res = waitpid(handle, &wstat, WNOHANG)) > 0) - { - if (WIFEXITED(wstat)) - { - *pExitCode = WEXITSTATUS(wstat); - return 1; - } - else - if (WIFSIGNALED(wstat)) - { - errno = EINTR; - return -1; - } - else - { - /* This should never happen */ - } - } - - if (res == 0) return 0; - - if (errno == ECHILD) - { - *pExitCode = 0; - return 1; - } - - return -1; -} - -int waitForProcess (ProcHandle handle) -{ - int wstat; - - while (waitpid(handle, &wstat, 0) < 0) - { - if (errno != EINTR) - { - return -1; - } - } - - if (WIFEXITED(wstat)) - return WEXITSTATUS(wstat); - else - if (WIFSIGNALED(wstat)) - { - return wstat; - } - else - { - /* This should never happen */ - } - - return -1; -} - -#else -/* ---------------------------------------------------------------------------- - Win32 versions - ------------------------------------------------------------------------- */ - -/* -------------------- WINDOWS VERSION --------------------- */ - -/* - * Function: mkAnonPipe - * - * Purpose: create an anonymous pipe with read and write ends being - * optionally (non-)inheritable. - */ -static BOOL -mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn, - HANDLE* pHandleOut, BOOL isInheritableOut) -{ - HANDLE hTemporaryIn = NULL; - HANDLE hTemporaryOut = NULL; - BOOL status; - SECURITY_ATTRIBUTES sec_attrs; - - /* Create inheritable security attributes */ - sec_attrs.nLength = sizeof(SECURITY_ATTRIBUTES); - sec_attrs.lpSecurityDescriptor = NULL; - sec_attrs.bInheritHandle = TRUE; - - /* Create the anon pipe with both ends inheritable */ - if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, &sec_attrs, 0)) - { - maperrno(); - *pHandleIn = NULL; - *pHandleOut = NULL; - return FALSE; - } - - if (isInheritableIn) - *pHandleIn = hTemporaryIn; - else - { - /* Make the read end non-inheritable */ - status = DuplicateHandle(GetCurrentProcess(), hTemporaryIn, - GetCurrentProcess(), pHandleIn, - 0, - FALSE, /* non-inheritable */ - DUPLICATE_SAME_ACCESS); - CloseHandle(hTemporaryIn); - if (!status) - { - maperrno(); - *pHandleIn = NULL; - *pHandleOut = NULL; - CloseHandle(hTemporaryOut); - return FALSE; - } - } - - if (isInheritableOut) - *pHandleOut = hTemporaryOut; - else - { - /* Make the write end non-inheritable */ - status = DuplicateHandle(GetCurrentProcess(), hTemporaryOut, - GetCurrentProcess(), pHandleOut, - 0, - FALSE, /* non-inheritable */ - DUPLICATE_SAME_ACCESS); - CloseHandle(hTemporaryOut); - if (!status) - { - maperrno(); - *pHandleIn = NULL; - *pHandleOut = NULL; - CloseHandle(*pHandleIn); - return FALSE; - } - } - - return TRUE; -} - -ProcHandle -runProcess (char *cmd, char *workingDirectory, void *environment, - int fdStdInput, int fdStdOutput, int fdStdError) -{ - STARTUPINFO sInfo; - PROCESS_INFORMATION pInfo; - DWORD flags; - - ZeroMemory(&sInfo, sizeof(sInfo)); - sInfo.cb = sizeof(sInfo); - sInfo.hStdInput = (HANDLE) _get_osfhandle(fdStdInput); - sInfo.hStdOutput= (HANDLE) _get_osfhandle(fdStdOutput); - sInfo.hStdError = (HANDLE) _get_osfhandle(fdStdError); - - if (sInfo.hStdInput == INVALID_HANDLE_VALUE) - sInfo.hStdInput = NULL; - if (sInfo.hStdOutput == INVALID_HANDLE_VALUE) - sInfo.hStdOutput = NULL; - if (sInfo.hStdError == INVALID_HANDLE_VALUE) - sInfo.hStdError = NULL; - - if (sInfo.hStdInput || sInfo.hStdOutput || sInfo.hStdError) - sInfo.dwFlags = STARTF_USESTDHANDLES; - - if (sInfo.hStdInput != GetStdHandle(STD_INPUT_HANDLE) && - sInfo.hStdOutput != GetStdHandle(STD_OUTPUT_HANDLE) && - sInfo.hStdError != GetStdHandle(STD_ERROR_HANDLE)) - flags = CREATE_NO_WINDOW; // Run without console window only when both output and error are redirected - else - flags = 0; - - if (!CreateProcess(NULL, cmd, NULL, NULL, TRUE, flags, environment, workingDirectory, &sInfo, &pInfo)) - { - maperrno(); - return -1; - } - - CloseHandle(pInfo.hThread); - return (ProcHandle)pInfo.hProcess; -} - -ProcHandle -runInteractiveProcess (char *cmd, char *workingDirectory, void *environment, - int *pfdStdInput, int *pfdStdOutput, int *pfdStdError) -{ - STARTUPINFO sInfo; - PROCESS_INFORMATION pInfo; - HANDLE hStdInputRead, hStdInputWrite; - HANDLE hStdOutputRead, hStdOutputWrite; - HANDLE hStdErrorRead, hStdErrorWrite; - - if (!mkAnonPipe(&hStdInputRead, TRUE, &hStdInputWrite, FALSE)) - return -1; - - if (!mkAnonPipe(&hStdOutputRead, FALSE, &hStdOutputWrite, TRUE)) - { - CloseHandle(hStdInputRead); - CloseHandle(hStdInputWrite); - return -1; - } - - if (!mkAnonPipe(&hStdErrorRead, FALSE, &hStdErrorWrite, TRUE)) - { - CloseHandle(hStdInputRead); - CloseHandle(hStdInputWrite); - CloseHandle(hStdOutputRead); - CloseHandle(hStdOutputWrite); - return -1; - } - - ZeroMemory(&sInfo, sizeof(sInfo)); - sInfo.cb = sizeof(sInfo); - sInfo.dwFlags = STARTF_USESTDHANDLES; - sInfo.hStdInput = hStdInputRead; - sInfo.hStdOutput= hStdOutputWrite; - sInfo.hStdError = hStdErrorWrite; - - if (!CreateProcess(NULL, cmd, NULL, NULL, TRUE, CREATE_NO_WINDOW, environment, workingDirectory, &sInfo, &pInfo)) - { - maperrno(); - CloseHandle(hStdInputRead); - CloseHandle(hStdInputWrite); - CloseHandle(hStdOutputRead); - CloseHandle(hStdOutputWrite); - CloseHandle(hStdErrorRead); - CloseHandle(hStdErrorWrite); - return -1; - } - CloseHandle(pInfo.hThread); - - // Close the ends of the pipes that were inherited by the - // child process. This is important, otherwise we won't see - // EOF on these pipes when the child process exits. - CloseHandle(hStdInputRead); - CloseHandle(hStdOutputWrite); - CloseHandle(hStdErrorWrite); - - *pfdStdInput = _open_osfhandle((intptr_t) hStdInputWrite, _O_WRONLY); - *pfdStdOutput = _open_osfhandle((intptr_t) hStdOutputRead, _O_RDONLY); - *pfdStdError = _open_osfhandle((intptr_t) hStdErrorRead, _O_RDONLY); - - return (int) pInfo.hProcess; -} - -int -terminateProcess (ProcHandle handle) -{ - if (!TerminateProcess((HANDLE) handle, 1)) { - maperrno(); - return -1; - } - return 0; -} - -int -getProcessExitCode (ProcHandle handle, int *pExitCode) -{ - *pExitCode = 0; - - if (WaitForSingleObject((HANDLE) handle, 1) == WAIT_OBJECT_0) - { - if (GetExitCodeProcess((HANDLE) handle, (DWORD *) pExitCode) == 0) - { - maperrno(); - return -1; - } - return 1; - } - - return 0; -} - -int -waitForProcess (ProcHandle handle) -{ - DWORD retCode; - - if (WaitForSingleObject((HANDLE) handle, INFINITE) == WAIT_OBJECT_0) - { - if (GetExitCodeProcess((HANDLE) handle, &retCode) == 0) - { - maperrno(); - return -1; - } - return retCode; - } - - maperrno(); - return -1; -} - -#endif /* Win32 */ diff --git a/configure.ac b/configure.ac index 66569a7..945774b 100644 --- a/configure.ac +++ b/configure.ac @@ -13,9 +13,6 @@ AC_PROG_CC() # do we have long longs? AC_CHECK_TYPES([long long]) -dnl ** Working vfork? -AC_FUNC_FORK - dnl ** determine whether or not const works AC_C_CONST @@ -35,7 +32,7 @@ dnl functions if it's really there. AC_CHECK_HEADERS([wctype.h], [AC_CHECK_FUNCS(iswspace)]) AC_CHECK_FUNCS([lstat readdir_r]) -AC_CHECK_FUNCS([getclock getrusage setitimer times]) +AC_CHECK_FUNCS([getclock getrusage times]) AC_CHECK_FUNCS([_chsize ftruncate]) # map standard C types and ISO types to Haskell types diff --git a/include/HsBase.h b/include/HsBase.h index 8c9fa21..3d2000d 100644 --- a/include/HsBase.h +++ b/include/HsBase.h @@ -129,8 +129,6 @@ #include "dirUtils.h" #include "WCsubst.h" -#include "runProcess.h" - #if defined(__MINGW32__) /* in Win32Utils.c */ extern void maperrno (void); @@ -154,12 +152,6 @@ int inputReady(int fd, int msecs, int isSock); /* in Signals.c */ extern HsInt nocldstop; -#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32) -/* in execvpe.c */ -extern int execvpe(char *name, char *const argv[], char **envp); -extern void pPrPr_disableITimers (void); -#endif - /* ----------------------------------------------------------------------------- 64-bit operations, defined in longlong.c -------------------------------------------------------------------------- */ @@ -705,10 +697,6 @@ INLINE void setTimevalTicks(struct timeval *p, HsWord64 usecs) } #endif /* !defined(__MINGW32__) */ -#if defined(__MINGW32__) -INLINE unsigned int __hscore_get_osver(void) { return _osver; } -#endif - /* ToDo: write a feature test that doesn't assume 'environ' to * be in scope at link-time. */ extern char** environ; diff --git a/include/runProcess.h b/include/runProcess.h deleted file mode 100644 index 33507d8..0000000 --- a/include/runProcess.h +++ /dev/null @@ -1,46 +0,0 @@ -/* ---------------------------------------------------------------------------- - (c) The University of Glasgow 2004 - - Interface for code in runProcess.c (providing support for System.Process) - ------------------------------------------------------------------------- */ - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) -typedef pid_t ProcHandle; -#else -// Should really be intptr_t, but we don't have that type on the Haskell side -typedef long ProcHandle; -#endif - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) - -extern ProcHandle runProcess( char *const args[], - char *workingDirectory, char **environment, - int fdStdInput, int fdStdOutput, int fdStdError, - int set_inthandler, long inthandler, - int set_quithandler, long quithandler); - -extern ProcHandle runInteractiveProcess( char *const args[], - char *workingDirectory, - char **environment, - int *pfdStdInput, - int *pfdStdOutput, - int *pfdStdError); - -#else - -extern ProcHandle runProcess( char *cmd, - char *workingDirectory, void *environment, - int fdStdInput, int fdStdOutput, int fdStdError); - -extern ProcHandle runInteractiveProcess( char *cmd, - char *workingDirectory, - void *environment, - int *pfdStdInput, - int *pfdStdOutput, - int *pfdStdError); - -#endif - -extern int terminateProcess( ProcHandle handle ); -extern int getProcessExitCode( ProcHandle handle, int *pExitCode ); -extern int waitForProcess( ProcHandle handle );