X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FProcess%2FInternals.hs;h=208d0ff54c43c351ecfccd659eb4c171ca5a2205;hb=6b1a36a595eddf1e124529646afdb75c76a9966d;hp=0d01825aa90be2d063978bd09cd89dae76e66223;hpb=6c90d0330e6954c16a38f8228c875328b3fc1a38;p=haskell-directory.git diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 0d01825..208d0ff 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -cpp -fffi #-} +{-# OPTIONS_GHC -cpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module : System.Process.Internals @@ -15,27 +15,69 @@ -- #hide module System.Process.Internals ( - ProcessHandle(..), PHANDLE, -#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__) - pPrPr_disableITimers, c_execvpe +#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_TARGET_OS) && !defined(__MINGW32__) +#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 -import Foreign.C.String ( CString ) -import Foreign.C.Types ( CInt ) -import Foreign.Ptr ( Ptr ) #ifdef __HUGS__ -{-# CBITS execvpe.c #-} +{-# CFILES cbits/execvpe.c #-} #endif +#include "HsBaseConfig.h" + +#ifndef __HUGS__ -- ---------------------------------------------------------------------------- -- ProcessHandle type @@ -46,17 +88,66 @@ import Foreign.Ptr ( Ptr ) termination: they all return a 'ProcessHandle' which may be used to wait for the process later. -} -#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__) +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 -#endif -newtype ProcessHandle = ProcessHandle PHANDLE +-- 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_TARGET_OS) && !defined(__MINGW32__) +#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. @@ -67,3 +158,272 @@ 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 +