System/Mem \
System/IO \
System/Posix \
+ System/Process \
Text \
Text/Html \
Text/PrettyPrint \
import Prelude
#ifdef __GLASGOW_HASKELL__
-import Foreign
-import Foreign.C
-import System.Exit
-import GHC.IOBase
-#include "ghcconfig.h"
+import System.Process
+import System.Exit ( ExitCode )
+import GHC.IOBase ( ioException, IOException(..), IOErrorType(..) )
#endif
#ifdef __HUGS__
#ifdef __GLASGOW_HASKELL__
system :: String -> IO ExitCode
system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
-system cmd =
- withCString cmd $ \s -> do
- status <- throwErrnoIfMinus1 "system" (primSystem s)
- case status of
- 0 -> return ExitSuccess
- n -> return (ExitFailure n)
-
-foreign import ccall unsafe "systemCmd" primSystem :: CString -> IO Int
-
--- ---------------------------------------------------------------------------
--- rawSystem
-
--- rawSystem is in a separate file, so we can #include it various places.
-#include "RawSystem.hs-inc"
-
+system cmd = do
+ p <- runCommand cmd
+ waitForProcess p
+
+rawSystem :: String -> [String] -> IO ExitCode
+rawSystem cmd args = do
+ p <- runProcess cmd args Nothing Nothing Nothing Nothing Nothing
+ waitForProcess p
#endif /* __GLASGOW_HASKELL__ */
--- /dev/null
+{-# OPTIONS -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 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 )
+
+-- ----------------------------------------------------------------------------
+-- runCommand
+
+{- | Runs a command using the shell.
+ -}
+runCommand
+ :: String
+ -> IO ProcessHandle
+
+runCommand string = do
+ (cmd,args) <- commandToProcess string
+#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
+ runProcess1 "runProcess" cmd args Nothing Nothing Nothing Nothing Nothing
+#else
+ runProcess1 "runProcess" 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.
+
+ Any 'Handle's passed to 'runProcess' are placed immediately in the
+ closed state, so may no longer be referenced by the Haskell process.
+-}
+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
+
+#if !defined(mingw32_TARGET_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
+
+#else
+
+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 extra_cmdline
+ = 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 -> 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
+ (haFD hndStdInput)
+ (haFD hndStdOutput)
+ (haFD hndStdError))
+ return (ProcessHandle proc_handle)
+
+foreign import ccall unsafe "runProcess"
+ c_runProcess
+ :: CString
+ -> CString
+ -> Ptr ()
+ -> FD
+ -> FD
+ -> FD
+ -> IO PHANDLE
+
+ -- Set the standard HANDLEs for the child process appropriately. NOTE:
+ -- this relies on the HANDLEs being inheritable. By default, the
+ -- runtime open() function creates inheritable handles (unless O_NOINHERIT
+ -- is specified). But perhaps we should DuplicateHandle() to make sure
+ -- the handle is inheritable?
+#endif
+
+-- ----------------------------------------------------------------------------
+-- 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_TARGET_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:
+
+> (in,out,err,pid) <- runInteractiveProcess "..."
+> forkIO (hPutStr in 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_TARGET_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
+ return (hndStdInput, hndStdOutput, hndStdError, ProcessHandle proc_handle)
+
+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
+ return (hndStdInput, hndStdOutput, hndStdError,
+ ProcessHandle proc_handle)
+
+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)
+#if __GLASGOW_HASKELL__ >= 603
+ False{-not a socket-}
+#endif
+ ("fd:" ++ show fd) mode True{-binary-} False{-no truncate-}
+
+-- ----------------------------------------------------------------------------
+-- 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 (ProcessHandle handle) = do
+ code <- throwErrnoIfMinus1 "waitForProcess" (c_waitForProcess handle)
+ if (code == 0)
+ then return ExitSuccess
+ else return (ExitFailure (fromIntegral code))
+
+-- ----------------------------------------------------------------------------
+-- 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 (ProcessHandle pid) =
+ throwErrnoIfMinus1_ "terminateProcess" (c_terminateProcess pid)
+
+-- ----------------------------------------------------------------------------
+-- getProcessExitCode
+
+{- | Verifies whether the process is completed and if it is then returns the exit code.
+ If the process is still running the function returns Nothing
+-}
+getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)
+getProcessExitCode (ProcessHandle handle) =
+ alloca $ \pExitCode -> do
+ res <- throwErrnoIfMinus1 "getProcessExitCode" (c_getProcessExitCode handle pExitCode)
+ code <- peek pExitCode
+ if res == 0
+ then return Nothing
+ else if code == 0
+ then return (Just ExitSuccess)
+ 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_TARGET_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_TARGET_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"
+ 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
+
+-- ------------------------------------------------------------------------
+-- 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.
+-}
+
+#if defined(mingw32_TARGET_OS)
+
+-- 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
--- /dev/null
+{-# OPTIONS -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 (
+ ProcessHandle(..), PHANDLE,
+ ) where
+
+#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
+import System.Posix.Types ( CPid )
+#else
+import Data.Word ( Word32 )
+#endif
+
+-- ----------------------------------------------------------------------------
+-- 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.
+-}
+#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
+type PHANDLE = CPid
+#else
+type PHANDLE = Word32
+#endif
+
+newtype ProcessHandle = ProcessHandle PHANDLE
-# $Id: Makefile,v 1.11 2004/08/16 11:08:47 simonmar Exp $
+# $Id: Makefile,v 1.12 2004/09/29 15:50:51 simonmar Exp $
TOP = ../..
include $(TOP)/mk/boilerplate.mk
EXCLUDED_SRCS += regex/engine.c
endif
-EXCLUDED_SRCS += ilxstubs.c
+EXCLUDED_SRCS += rawSystem.c
ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
EXCLUDED_SRCS += consUtils.c
--- /dev/null
+/* -----------------------------------------------------------------------------
+ (c) The University of Glasgow 1995-2004
+
+ Our low-level exec() variant.
+ -------------------------------------------------------------------------- */
+
+/* Evidently non-Posix. */
+/* #include "PosixSource.h" */
+
+#include <unistd.h>
+#include <sys/time.h>
+#include <stdlib.h>
+#include <string.h>
+#include <errno.h>
+
+/*
+ * 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 **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
+}
/*
* (c) The University of Glasgow 1994-2004
*
+ * WARNING: this file is here for backwards compatibility only. It is
+ * not included as part of the base package, but is #included into the
+ * compiler and the runghc utility when building either of these with
+ * an old version of GHC.
+ *
* shell-less system Runtime Support (see System.Cmd.rawSystem).
*/
--- /dev/null
+/* ----------------------------------------------------------------------------\r
+ (c) The University of Glasgow 2004\r
+ \r
+ Support for System.Process\r
+ ------------------------------------------------------------------------- */\r
+\r
+#include "HsBase.h"\r
+\r
+#if defined(mingw32_TARGET_OS)\r
+#include <windows.h>\r
+#include <stdlib.h>\r
+#endif\r
+\r
+#ifdef HAVE_VFORK_H\r
+#include <vfork.h>\r
+#endif\r
+\r
+#ifdef HAVE_VFORK\r
+#define fork vfork\r
+#endif\r
+\r
+#ifdef HAVE_SIGNAL_H\r
+#include <signal.h>\r
+#endif\r
+\r
+#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)\r
+/* ----------------------------------------------------------------------------\r
+ UNIX versions\r
+ ------------------------------------------------------------------------- */\r
+\r
+int\r
+runProcess (char *const args[], char *workingDirectory, char **environment, \r
+ int fdStdInput, int fdStdOutput, int fdStdError)\r
+{\r
+ int pid;\r
+ struct sigaction dfl;\r
+\r
+ switch(pid = fork())\r
+ {\r
+ case -1:\r
+ return -1;\r
+ \r
+ case 0:\r
+ {\r
+ pPrPr_disableITimers();\r
+ \r
+ if (workingDirectory) {\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
+ */\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
+\r
+ dup2 (fdStdInput, STDIN_FILENO);\r
+ dup2 (fdStdOutput, STDOUT_FILENO);\r
+ dup2 (fdStdError, STDERR_FILENO);\r
+ \r
+ if (environment) {\r
+ execvpe(args[0], args, environment);\r
+ } else {\r
+ execvp(args[0], args);\r
+ }\r
+ }\r
+ _exit(127);\r
+ }\r
+ \r
+ return pid;\r
+}\r
+\r
+ProcHandle\r
+runInteractiveProcess (char *const args[], \r
+ char *workingDirectory, char **environment,\r
+ int *pfdStdInput, int *pfdStdOutput, int *pfdStdError)\r
+{\r
+ int pid;\r
+ int fdStdInput[2], fdStdOutput[2], fdStdError[2];\r
+\r
+ pipe(fdStdInput);\r
+ pipe(fdStdOutput);\r
+ pipe(fdStdError);\r
+\r
+ switch(pid = fork())\r
+ {\r
+ case -1:\r
+ close(fdStdInput[0]);\r
+ close(fdStdInput[1]);\r
+ close(fdStdOutput[0]);\r
+ close(fdStdOutput[1]);\r
+ close(fdStdError[0]);\r
+ close(fdStdError[1]);\r
+ return -1;\r
+ \r
+ case 0:\r
+ {\r
+ pPrPr_disableITimers();\r
+ \r
+ if (workingDirectory) {\r
+ chdir (workingDirectory);\r
+ }\r
+ \r
+ dup2 (fdStdInput[0], STDIN_FILENO);\r
+ dup2 (fdStdOutput[1], STDOUT_FILENO);\r
+ dup2 (fdStdError[1], STDERR_FILENO);\r
+ \r
+ close(fdStdInput[0]);\r
+ close(fdStdInput[1]);\r
+ close(fdStdOutput[0]);\r
+ close(fdStdOutput[1]);\r
+ close(fdStdError[0]);\r
+ close(fdStdError[1]);\r
+ \r
+ /* the child */\r
+ if (environment) {\r
+ execvpe(args[0], args, environment);\r
+ } else {\r
+ execvp(args[0], args);\r
+ }\r
+ }\r
+ _exit(127);\r
+ \r
+ default:\r
+ close(fdStdInput[0]);\r
+ close(fdStdOutput[1]);\r
+ close(fdStdError[1]);\r
+ \r
+ *pfdStdInput = fdStdInput[1];\r
+ *pfdStdOutput = fdStdOutput[0];\r
+ *pfdStdError = fdStdError[0];\r
+ break;\r
+ }\r
+ \r
+ return pid;\r
+}\r
+\r
+int\r
+terminateProcess (ProcHandle handle)\r
+{\r
+ return (kill(handle, SIGTERM) == 0);\r
+}\r
+\r
+int\r
+getProcessExitCode (ProcHandle handle, int *pExitCode)\r
+{\r
+ int wstat;\r
+ \r
+ *pExitCode = 0;\r
+ \r
+ if (waitpid(handle, &wstat, WNOHANG) > 0)\r
+ {\r
+ if (WIFEXITED(wstat))\r
+ {\r
+ *pExitCode = WEXITSTATUS(wstat);\r
+ return 1;\r
+ }\r
+ else\r
+ if (WIFSIGNALED(wstat))\r
+ {\r
+ errno = EINTR;\r
+ return -1;\r
+ }\r
+ else\r
+ {\r
+ /* This should never happen */\r
+ }\r
+ }\r
+ \r
+ return 0;\r
+}\r
+\r
+int waitForProcess (ProcHandle handle)\r
+{\r
+ int wstat;\r
+ \r
+ while (waitpid(handle, &wstat, 0) < 0)\r
+ {\r
+ if (errno != EINTR)\r
+ {\r
+ return -1;\r
+ }\r
+ }\r
+ \r
+ if (WIFEXITED(wstat))\r
+ return WEXITSTATUS(wstat);\r
+ else\r
+ if (WIFSIGNALED(wstat))\r
+ {\r
+ errno = EINTR;\r
+ }\r
+ else\r
+ {\r
+ /* This should never happen */\r
+ }\r
+ \r
+ return -1;\r
+}\r
+\r
+#else\r
+/* ----------------------------------------------------------------------------\r
+ Win32 versions\r
+ ------------------------------------------------------------------------- */\r
+\r
+/* -------------------- WINDOWS VERSION --------------------- */\r
+\r
+/* This is the error table that defines the mapping between OS error\r
+ codes and errno values */\r
+\r
+struct errentry {\r
+ unsigned long oscode; /* OS return value */\r
+ int errnocode; /* System V error code */\r
+};\r
+\r
+static struct errentry errtable[] = {\r
+ { ERROR_INVALID_FUNCTION, EINVAL }, /* 1 */\r
+ { ERROR_FILE_NOT_FOUND, ENOENT }, /* 2 */\r
+ { ERROR_PATH_NOT_FOUND, ENOENT }, /* 3 */\r
+ { ERROR_TOO_MANY_OPEN_FILES, EMFILE }, /* 4 */\r
+ { ERROR_ACCESS_DENIED, EACCES }, /* 5 */\r
+ { ERROR_INVALID_HANDLE, EBADF }, /* 6 */\r
+ { ERROR_ARENA_TRASHED, ENOMEM }, /* 7 */\r
+ { ERROR_NOT_ENOUGH_MEMORY, ENOMEM }, /* 8 */\r
+ { ERROR_INVALID_BLOCK, ENOMEM }, /* 9 */\r
+ { ERROR_BAD_ENVIRONMENT, E2BIG }, /* 10 */\r
+ { ERROR_BAD_FORMAT, ENOEXEC }, /* 11 */\r
+ { ERROR_INVALID_ACCESS, EINVAL }, /* 12 */\r
+ { ERROR_INVALID_DATA, EINVAL }, /* 13 */\r
+ { ERROR_INVALID_DRIVE, ENOENT }, /* 15 */\r
+ { ERROR_CURRENT_DIRECTORY, EACCES }, /* 16 */\r
+ { ERROR_NOT_SAME_DEVICE, EXDEV }, /* 17 */\r
+ { ERROR_NO_MORE_FILES, ENOENT }, /* 18 */\r
+ { ERROR_LOCK_VIOLATION, EACCES }, /* 33 */\r
+ { ERROR_BAD_NETPATH, ENOENT }, /* 53 */\r
+ { ERROR_NETWORK_ACCESS_DENIED, EACCES }, /* 65 */\r
+ { ERROR_BAD_NET_NAME, ENOENT }, /* 67 */\r
+ { ERROR_FILE_EXISTS, EEXIST }, /* 80 */\r
+ { ERROR_CANNOT_MAKE, EACCES }, /* 82 */\r
+ { ERROR_FAIL_I24, EACCES }, /* 83 */\r
+ { ERROR_INVALID_PARAMETER, EINVAL }, /* 87 */\r
+ { ERROR_NO_PROC_SLOTS, EAGAIN }, /* 89 */\r
+ { ERROR_DRIVE_LOCKED, EACCES }, /* 108 */\r
+ { ERROR_BROKEN_PIPE, EPIPE }, /* 109 */\r
+ { ERROR_DISK_FULL, ENOSPC }, /* 112 */\r
+ { ERROR_INVALID_TARGET_HANDLE, EBADF }, /* 114 */\r
+ { ERROR_INVALID_HANDLE, EINVAL }, /* 124 */\r
+ { ERROR_WAIT_NO_CHILDREN, ECHILD }, /* 128 */\r
+ { ERROR_CHILD_NOT_COMPLETE, ECHILD }, /* 129 */\r
+ { ERROR_DIRECT_ACCESS_HANDLE, EBADF }, /* 130 */\r
+ { ERROR_NEGATIVE_SEEK, EINVAL }, /* 131 */\r
+ { ERROR_SEEK_ON_DEVICE, EACCES }, /* 132 */\r
+ { ERROR_DIR_NOT_EMPTY, ENOTEMPTY }, /* 145 */\r
+ { ERROR_NOT_LOCKED, EACCES }, /* 158 */\r
+ { ERROR_BAD_PATHNAME, ENOENT }, /* 161 */\r
+ { ERROR_MAX_THRDS_REACHED, EAGAIN }, /* 164 */\r
+ { ERROR_LOCK_FAILED, EACCES }, /* 167 */\r
+ { ERROR_ALREADY_EXISTS, EEXIST }, /* 183 */\r
+ { ERROR_FILENAME_EXCED_RANGE, ENOENT }, /* 206 */\r
+ { ERROR_NESTING_NOT_ALLOWED, EAGAIN }, /* 215 */\r
+ { ERROR_NOT_ENOUGH_QUOTA, ENOMEM } /* 1816 */\r
+};\r
+\r
+/* size of the table */\r
+#define ERRTABLESIZE (sizeof(errtable)/sizeof(errtable[0]))\r
+\r
+/* The following two constants must be the minimum and maximum\r
+ values in the (contiguous) range of Exec Failure errors. */\r
+#define MIN_EXEC_ERROR ERROR_INVALID_STARTING_CODESEG\r
+#define MAX_EXEC_ERROR ERROR_INFLOOP_IN_RELOC_CHAIN\r
+\r
+/* These are the low and high value in the range of errors that are\r
+ access violations */\r
+#define MIN_EACCES_RANGE ERROR_WRITE_PROTECT\r
+#define MAX_EACCES_RANGE ERROR_SHARING_BUFFER_EXCEEDED\r
+\r
+static void maperrno (void)\r
+{\r
+ int i;\r
+ DWORD dwErrorCode;\r
+\r
+ dwErrorCode = GetLastError();\r
+\r
+ /* check the table for the OS error code */\r
+ for (i = 0; i < ERRTABLESIZE; ++i)\r
+ {\r
+ if (dwErrorCode == errtable[i].oscode)\r
+ {\r
+ errno = errtable[i].errnocode;\r
+ return;\r
+ }\r
+ }\r
+\r
+ /* The error code wasn't in the table. We check for a range of */\r
+ /* EACCES errors or exec failure errors (ENOEXEC). Otherwise */\r
+ /* EINVAL is returned. */\r
+\r
+ if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE)\r
+ errno = EACCES;\r
+ else\r
+ if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR)\r
+ errno = ENOEXEC;\r
+ else\r
+ errno = EINVAL;\r
+}\r
+\r
+/*\r
+ * Function: mkAnonPipe\r
+ *\r
+ * Purpose: create an anonymous pipe with read and write ends being\r
+ * optionally (non-)inheritable.\r
+ */\r
+static BOOL\r
+mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn, \r
+ HANDLE* pHandleOut, BOOL isInheritableOut)\r
+{\r
+ HANDLE hTemporaryIn = NULL;\r
+ HANDLE hTemporaryOut = NULL;\r
+ BOOL status;\r
+ SECURITY_ATTRIBUTES sec_attrs;\r
+\r
+ /* Create inheritable security attributes */\r
+ sec_attrs.nLength = sizeof(SECURITY_ATTRIBUTES);\r
+ sec_attrs.lpSecurityDescriptor = NULL;\r
+ sec_attrs.bInheritHandle = TRUE;\r
+\r
+ /* Create the anon pipe with both ends inheritable */\r
+ if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, &sec_attrs, 0))\r
+ {\r
+ maperrno();\r
+ *pHandleIn = NULL;\r
+ *pHandleOut = NULL;\r
+ return FALSE;\r
+ }\r
+\r
+ if (isInheritableIn)\r
+ *pHandleIn = hTemporaryIn;\r
+ else\r
+ {\r
+ /* Make the read end non-inheritable */\r
+ status = DuplicateHandle(GetCurrentProcess(), hTemporaryIn,\r
+ GetCurrentProcess(), pHandleIn,\r
+ 0,\r
+ FALSE, /* non-inheritable */\r
+ DUPLICATE_SAME_ACCESS);\r
+ CloseHandle(hTemporaryIn);\r
+ if (!status)\r
+ {\r
+ maperrno();\r
+ *pHandleIn = NULL;\r
+ *pHandleOut = NULL;\r
+ CloseHandle(hTemporaryOut);\r
+ return FALSE;\r
+ }\r
+ }\r
+\r
+ if (isInheritableOut)\r
+ *pHandleOut = hTemporaryOut;\r
+ else\r
+ {\r
+ /* Make the write end non-inheritable */\r
+ status = DuplicateHandle(GetCurrentProcess(), hTemporaryOut,\r
+ GetCurrentProcess(), pHandleOut,\r
+ 0,\r
+ FALSE, /* non-inheritable */\r
+ DUPLICATE_SAME_ACCESS);\r
+ CloseHandle(hTemporaryOut);\r
+ if (!status)\r
+ {\r
+ maperrno();\r
+ *pHandleIn = NULL;\r
+ *pHandleOut = NULL;\r
+ CloseHandle(*pHandleIn);\r
+ return FALSE;\r
+ }\r
+ }\r
+\r
+ return TRUE;\r
+}\r
+\r
+ProcHandle\r
+runProcess (char *cmd, char *workingDirectory, void *environment,\r
+ int fdStdInput, int fdStdOutput, int fdStdError)\r
+{\r
+ STARTUPINFO sInfo;\r
+ PROCESS_INFORMATION pInfo;\r
+ DWORD flags;\r
+\r
+ ZeroMemory(&sInfo, sizeof(sInfo));\r
+ sInfo.cb = sizeof(sInfo);\r
+ sInfo.dwFlags = STARTF_USESTDHANDLES;\r
+ sInfo.hStdInput = (HANDLE) _get_osfhandle(fdStdInput);\r
+ sInfo.hStdOutput= (HANDLE) _get_osfhandle(fdStdOutput);\r
+ sInfo.hStdError = (HANDLE) _get_osfhandle(fdStdError);\r
+\r
+ if (sInfo.hStdOutput != GetStdHandle(STD_OUTPUT_HANDLE) &&\r
+ sInfo.hStdError != GetStdHandle(STD_ERROR_HANDLE))\r
+ flags = CREATE_NO_WINDOW; // Run without console window only when both output and error are redirected\r
+ else\r
+ flags = 0;\r
+\r
+ if (!CreateProcess(NULL, cmd, NULL, NULL, TRUE, flags, environment, workingDirectory, &sInfo, &pInfo))\r
+ {\r
+ maperrno();\r
+ return -1;\r
+ }\r
+\r
+ CloseHandle(pInfo.hThread);\r
+ return (ProcHandle)pInfo.hProcess;\r
+}\r
+\r
+ProcHandle\r
+runInteractiveProcess (char *cmd, char *workingDirectory, void *environment,\r
+ int *pfdStdInput, int *pfdStdOutput, int *pfdStdError)\r
+{\r
+ STARTUPINFO sInfo;\r
+ PROCESS_INFORMATION pInfo;\r
+ HANDLE hStdInputRead, hStdInputWrite;\r
+ HANDLE hStdOutputRead, hStdOutputWrite;\r
+ HANDLE hStdErrorRead, hStdErrorWrite;\r
+\r
+ if (!mkAnonPipe(&hStdInputRead, TRUE, &hStdInputWrite, FALSE))\r
+ return -1;\r
+\r
+ if (!mkAnonPipe(&hStdOutputRead, FALSE, &hStdOutputWrite, TRUE))\r
+ {\r
+ CloseHandle(hStdInputRead);\r
+ CloseHandle(hStdInputWrite);\r
+ return -1;\r
+ }\r
+\r
+ if (!mkAnonPipe(&hStdErrorRead, FALSE, &hStdErrorWrite, TRUE))\r
+ {\r
+ CloseHandle(hStdInputRead);\r
+ CloseHandle(hStdInputWrite);\r
+ CloseHandle(hStdOutputRead);\r
+ CloseHandle(hStdOutputWrite);\r
+ return -1;\r
+ }\r
+\r
+ ZeroMemory(&sInfo, sizeof(sInfo));\r
+ sInfo.cb = sizeof(sInfo);\r
+ sInfo.dwFlags = STARTF_USESTDHANDLES;\r
+ sInfo.hStdInput = hStdInputRead;\r
+ sInfo.hStdOutput= hStdOutputWrite;\r
+ sInfo.hStdError = hStdErrorWrite;\r
+\r
+ if (!CreateProcess(NULL, cmd, NULL, NULL, TRUE, CREATE_NO_WINDOW, environment, workingDirectory, &sInfo, &pInfo))\r
+ {\r
+ maperrno();\r
+ CloseHandle(hStdInputRead);\r
+ CloseHandle(hStdInputWrite);\r
+ CloseHandle(hStdOutputRead);\r
+ CloseHandle(hStdOutputWrite);\r
+ CloseHandle(hStdErrorRead);\r
+ CloseHandle(hStdErrorWrite);\r
+ return -1;\r
+ }\r
+ CloseHandle(pInfo.hThread);\r
+\r
+ // Close the ends of the pipes that were inherited by the\r
+ // child process. This is important, otherwise we won't see\r
+ // EOF on these pipes when the child process exits.\r
+ CloseHandle(hStdInputRead);\r
+ CloseHandle(hStdOutputWrite);\r
+ CloseHandle(hStdErrorWrite);\r
+\r
+ *pfdStdInput = _open_osfhandle((intptr_t) hStdInputWrite, _O_WRONLY);\r
+ *pfdStdOutput = _open_osfhandle((intptr_t) hStdOutputRead, _O_RDONLY);\r
+ *pfdStdError = _open_osfhandle((intptr_t) hStdErrorRead, _O_RDONLY);\r
+\r
+ return (int) pInfo.hProcess;\r
+}\r
+\r
+int\r
+terminateProcess (ProcHandle handle)\r
+{\r
+ if (!TerminateProcess((HANDLE) handle, 1)) {\r
+ maperrno();\r
+ return -1;\r
+ }\r
+\r
+ CloseHandle((HANDLE) handle);\r
+ return 0;\r
+}\r
+\r
+int\r
+getProcessExitCode (ProcHandle handle, int *pExitCode)\r
+{\r
+ *pExitCode = 0;\r
+\r
+ if (WaitForSingleObject((HANDLE) handle, 1) == WAIT_OBJECT_0)\r
+ {\r
+ if (GetExitCodeProcess((HANDLE) handle, (DWORD *) pExitCode) == 0)\r
+ {\r
+ maperrno();\r
+ return -1;\r
+ }\r
+ \r
+ CloseHandle((HANDLE) handle);\r
+ return 1;\r
+ }\r
+ \r
+ return 0;\r
+}\r
+\r
+int\r
+waitForProcess (ProcHandle handle)\r
+{\r
+ DWORD retCode;\r
+\r
+ if (WaitForSingleObject((HANDLE) handle, INFINITE) == WAIT_OBJECT_0)\r
+ {\r
+ if (GetExitCodeProcess((HANDLE) handle, &retCode) == 0)\r
+ {\r
+ maperrno();\r
+ return -1;\r
+ }\r
+ \r
+ CloseHandle((HANDLE) handle);\r
+ return retCode;\r
+ }\r
+ \r
+ maperrno();\r
+ return -1;\r
+}\r
+\r
+#endif // Win32\r
+++ /dev/null
-/*
- * (c) The University of Glasgow 2002
- *
- * $Id: system.c,v 1.8 2003/07/02 13:27:35 stolz Exp $
- *
- * system Runtime Support
- */
-
-/* The itimer stuff in this module is non-posix */
-// #include "PosixSource.h"
-
-#include "HsBase.h"
-
-#if defined(mingw32_TARGET_OS)
-#include <windows.h>
-#include <stdlib.h>
-#endif
-
-#ifdef HAVE_VFORK_H
-#include <vfork.h>
-#endif
-
-#ifdef HAVE_VFORK
-#define fork vfork
-#endif
-
-HsInt
-systemCmd(HsAddr cmd)
-{
- /* -------------------- WINDOWS VERSION --------------------- */
-#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
- return system(cmd);
-#else
- /* -------------------- UNIX VERSION --------------------- */
- int pid;
- int wstat;
-
- switch(pid = fork()) {
- case -1:
- {
- return -1;
- }
- case 0:
- {
-#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
-
- /* the child */
- execl("/bin/sh", "sh", "-c", cmd, NULL);
- _exit(127);
- }
- }
-
- while (waitpid(pid, &wstat, 0) < 0) {
- if (errno != EINTR) {
- return -1;
- }
- }
-
- if (WIFEXITED(wstat))
- return WEXITSTATUS(wstat);
- else if (WIFSIGNALED(wstat)) {
- errno = EINTR;
- }
- else {
- /* This should never happen */
- }
- return -1;
-#endif
-}
/* -----------------------------------------------------------------------------
*
- * (c) The University of Glasgow 2001-2002
+ * (c) The University of Glasgow 2001-2004
*
* Definitions for package `base' which are visible in Haskell land.
*
#include "lockFile.h"
#include "dirUtils.h"
+#include "runProcess.h"
+
#if defined(mingw32_TARGET_OS)
#include <io.h>
#include <fcntl.h>
#include <shlobj.h>
#endif
-/* in system.c */
-HsInt systemCmd(HsAddr cmd);
-
-/* in rawSystem.c */
-#if defined(mingw32_TARGET_OS)
-HsInt rawSystem(HsAddr cmd);
-#else
-HsInt rawSystem(HsAddr cmd, HsAddr args);
-#endif
-
/* in inputReady.c */
int inputReady(int fd, int msecs, int isSock);
/* in Signals.c */
extern HsInt nocldstop;
+/* in execvpe.c */
+extern int execvpe(char *name, char *const argv[], char **envp);
+extern void pPrPr_disableITimers (void);
+
/* -----------------------------------------------------------------------------
64-bit operations, defined in longlong.c
-------------------------------------------------------------------------- */
--- /dev/null
+/* ----------------------------------------------------------------------------
+ (c) The University of Glasgow 2004
+
+ Interface for code in runProcess.c (providing support for System.Process)
+ ------------------------------------------------------------------------- */
+
+#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
+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(mingw32_TARGET_OS) && !defined(__MINGW32__)
+
+extern ProcHandle runProcess( char *const args[],
+ char *workingDirectory, char **environment,
+ int fdStdInput, int fdStdOutput, int fdStdError);
+
+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 );
projects / haskell-directory.git / commitdiff