[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36

[John Goerzen]

The following commit has been merged in the master branch:
commit 5b68af1f5f1c8c2b19866eb2e255180f3d2ea5c0
Author: John Goerzen <jgoerzen at complete.org>
Date:   Fri Nov 24 11:28:18 2006 +0100

    New function pOpen3Raw

diff --git a/MissingH/Cmd.hs b/MissingH/Cmd.hs
index 83fc68e..0334195 100644
--- a/MissingH/Cmd.hs
+++ b/MissingH/Cmd.hs
@@ -500,6 +500,31 @@ pOpen3 :: Maybe Fd                      -- ^ Send stdin to this fd
        -> IO ()                         -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS
        -> IO a
 pOpen3 pin pout perr fp args func childfunc = 
+    do pid <- pOpen3Raw pin pout perr fp args childfunc
+       retval <- func $! pid
+       let rv = seq retval retval
+       forceSuccess (PipeHandle (seq retval pid) fp args "pOpen3")
+       return rv
+#endif
+#endif
+
+#ifndef mingw32_HOST_OS
+#ifndef __HUGS__
+{- | Runs a command, redirecting things to pipes. 
+
+Not available on Windows.
+
+Returns immediately with the PID of the child.  Using 'waitProcess' on it
+is YOUR responsibility!
+-}
+pOpen3Raw :: Maybe Fd                      -- ^ Send stdin to this fd
+       -> Maybe Fd                      -- ^ Get stdout from this fd
+       -> Maybe Fd                      -- ^ Get stderr from this fd
+       -> FilePath                      -- ^ Command to run
+       -> [String]                      -- ^ Command args
+       -> IO ()                         -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS
+       -> IO ProcessID
+pOpen3Raw pin pout perr fp args childfunc =
     let mayberedir Nothing _ = return ()
         mayberedir (Just fromfd) tofd = do
                                         dupTo fromfd tofd
@@ -527,13 +552,12 @@ pOpen3 pin pout perr fp args func childfunc =
         pid <- case p of
                 Right x -> return x
                 Left e -> fail ("Error in fork: " ++ (show e))
-        retval <- func $! pid
-        let rv = seq retval retval
-        forceSuccess (PipeHandle (seq retval pid) fp args "pOpen3")
-        return rv
+        return pid
+
 #endif
 #endif
 
+
 showCmd :: FilePath -> [String] -> String
 showCmd fp args =
     fp ++ " " ++ show args

-- 
haskell-testpack