-- #hide
module System.Process.Internals (
- ProcessHandle(..), PHANDLE,
+#ifndef __HUGS__
+ ProcessHandle(..), ProcessHandle__(..),
+ PHANDLE, closePHANDLE, mkProcessHandle,
+ withProcessHandle, withProcessHandle_,
+#endif
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
pPrPr_disableITimers, c_execvpe,
# ifdef __GLASGOW_HASKELL__
runProcessWin32, translate,
# endif
#endif
+#ifndef __HUGS__
commandToProcess,
+#endif
withFilePathException, withCEnvironment
) where
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 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
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
-#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__ */
-- ----------------------------------------------------------------------------
runProcessPosix fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
mb_sigint mb_sigquit
- = withFilePathException cmd $
- withHandle_ fun (fromMaybe stdin mb_stdin) $ \hndStdInput ->
- withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
- withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
- maybeWith withCEnvironment mb_env $ \pEnv ->
- maybeWith withCString mb_cwd $ \pWorkDir ->
- withMany withCString (cmd:args) $ \cstrs ->
+ = 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)
= case mb_sigquit of
Nothing -> (0, 0)
Just hand -> (1, hand)
- in
withArray0 nullPtr cstrs $ \pargs -> do
ph <- throwErrnoIfMinus1 fun $
c_runProcess pargs pWorkDir pEnv
- (haFD hndStdInput)
- (haFD hndStdOutput)
- (haFD hndStdError)
+ fd_stdin fd_stdout fd_stderr
set_int inthand set_quit quithand
- return (ProcessHandle ph)
+ mkProcessHandle ph
foreign import ccall unsafe "runProcess"
c_runProcess
runProcessWin32 fun cmd args mb_cwd mb_env
mb_stdin mb_stdout mb_stderr extra_cmdline
- = withFilePathException cmd $
- withHandle_ fun (fromMaybe stdin mb_stdin) $ \hndStdInput ->
- withHandle_ fun (fromMaybe stdout mb_stdout) $ \hndStdOutput ->
- withHandle_ fun (fromMaybe stderr mb_stderr) $ \hndStdError ->
+ = 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 ++
withCString cmdline $ \pcmdline -> do
proc_handle <- throwErrnoIfMinus1 fun
(c_runProcess pcmdline pWorkDir pEnv
- (haFD hndStdInput)
- (haFD hndStdOutput)
- (haFD hndStdError))
- return (ProcessHandle proc_handle)
+ fd_stdin fd_stdout fd_stderr)
+ mkProcessHandle proc_handle
foreign import ccall unsafe "runProcess"
c_runProcess
#endif
+#ifndef __HUGS__
-- ----------------------------------------------------------------------------
-- commandToProcess
:: String
-> IO (FilePath,String)
commandToProcess string = do
- sysDir <- allocaBytes 1024 (\pdir -> c_getSystemDirectory pdir 1024 >> peekCString pdir)
- return (sysDir ++ "\\CMD.EXE", "/c " ++ string)
+ 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
-
-foreign import stdcall unsafe "GetSystemDirectoryA"
- c_getSystemDirectory
- :: CString
- -> CInt
- -> IO CInt
-
+ -- (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
projects / haskell-directory.git / blobdiff