[project @ 2005-11-11 12:01:58 by simonmar]

[haskell-directory.git] / System / Process / Internals.hs

diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs
index 76eec2e..36b0f24 100644 (file)
--- a/System/Process/Internals.hs
+++ b/System/Process/Internals.hs
@@ -15,7 +15,7 @@
 
 -- #hide
 module System.Process.Internals (
-       ProcessHandle(..), PHANDLE,
+       ProcessHandle(..), PHANDLE, getProcessHandle, mkProcessHandle,
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
         pPrPr_disableITimers, c_execvpe,
 # ifdef __GLASGOW_HASKELL__
@@ -27,7 +27,9 @@ module System.Process.Internals (
        runProcessWin32, translate,
 # endif
 #endif
+#ifndef __HUGS__
        commandToProcess,
+#endif
        withFilePathException, withCEnvironment
   ) where
 
@@ -38,6 +40,7 @@ import System.Posix.Types ( CPid )
 import System.IO       ( Handle )
 #else
 import Data.Word ( Word32 )
+import Data.IORef
 #endif
 
 import Data.Maybe      ( fromMaybe )
@@ -79,13 +82,39 @@ import System.Directory.Internals ( parseSearchPath, joinFileName )
      to wait for the process later.
 -}
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
+
 type PHANDLE = CPid
+newtype ProcessHandle = ProcessHandle PHANDLE
+
+getProcessHandle :: ProcessHandle -> IO PHANDLE
+getProcessHandle (ProcessHandle p) = return p
+
+mkProcessHandle :: PHANDLE -> IO ProcessHandle
+mkProcessHandle p = return (ProcessHandle p)
+
 #else
+
 type PHANDLE = Word32
+newtype ProcessHandle = ProcessHandle (IORef PHANDLE)
+
+getProcessHandle :: ProcessHandle -> IO PHANDLE
+getProcessHandle (ProcessHandle ior) = readIORef ior
+
+-- 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
+   ioref <- newIORef h
+   mkWeakIORef ioref (c_CloseHandle h)
+   return (ProcessHandle ioref)
+
+foreign import stdcall unsafe "CloseHandle"
+  c_CloseHandle
+       :: PHANDLE
+       -> IO ()
 #endif
 
-newtype ProcessHandle = ProcessHandle PHANDLE
-
 -- ----------------------------------------------------------------------------
 
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
@@ -121,13 +150,15 @@ runProcessPosix
 
 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)
@@ -136,15 +167,12 @@ runProcessPosix fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
                = 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
@@ -171,10 +199,12 @@ defaultSignal = CONST_SIG_DFL :: CLong
 
 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 ++ 
@@ -183,10 +213,8 @@ runProcessWin32 fun cmd args mb_cwd mb_env
        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
@@ -270,6 +298,7 @@ translate str = '"' : snd (foldr escape (True,"\"") str)
 
 #endif
 
+#ifndef __HUGS__
 -- ----------------------------------------------------------------------------
 -- commandToProcess
 
@@ -341,10 +370,12 @@ findCommandInterpreter = do
       Just cmd -> return cmd
 
 
-foreign import stdcall unsafe "__hscore_get_osver"
+foreign import ccall unsafe "__hscore_get_osver"
   c_get_osver :: IO CUInt
 #endif
 
+#endif /* __HUGS__ */
+
 -- ----------------------------------------------------------------------------
 -- Utils