[project @ 2005-11-17 11:28:43 by simonmar]

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

diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs
index 3348306..b0af3de 100644 (file)
--- a/System/Process/Internals.hs
+++ b/System/Process/Internals.hs
@@ -15,7 +15,9 @@
 
 -- #hide
 module System.Process.Internals (
-       ProcessHandle(..), PHANDLE,
+       ProcessHandle(..), ProcessHandle__(..), 
+       PHANDLE, closePHANDLE, mkProcessHandle, 
+       withProcessHandle, withProcessHandle_,
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
         pPrPr_disableITimers, c_execvpe,
 # ifdef __GLASGOW_HASKELL__
@@ -40,8 +42,10 @@ 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(..) )
@@ -50,6 +54,7 @@ import GHC.Handle     ( stdin, stdout, stderr, withHandle_ )
 import Hugs.Exception  ( Exception(..), IOException(..) )
 # endif
 
+import Control.Concurrent
 import Control.Exception ( handle, throwIO )
 import Foreign.C
 import Foreign
@@ -80,13 +85,61 @@ import System.Directory.Internals ( parseSearchPath, joinFileName )
      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
 
 -- ----------------------------------------------------------------------------
 
@@ -145,7 +198,7 @@ runProcessPosix fun cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr
                 c_runProcess pargs pWorkDir pEnv 
                        fd_stdin fd_stdout fd_stderr
                        set_int inthand set_quit quithand
-        return (ProcessHandle ph)
+        mkProcessHandle ph
 
 foreign import ccall unsafe "runProcess" 
   c_runProcess
@@ -187,7 +240,7 @@ runProcessWin32 fun cmd args mb_cwd mb_env
          proc_handle <- throwErrnoIfMinus1 fun
                          (c_runProcess pcmdline pWorkDir pEnv 
                                fd_stdin fd_stdout fd_stderr)
-         return (ProcessHandle proc_handle)
+        mkProcessHandle proc_handle
 
 foreign import ccall unsafe "runProcess" 
   c_runProcess