[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 68db46d663cc47a414817e67ff7f049671a271b3
Author: John Goerzen <jgoerzen at complete.org>
Date:   Sun Apr 17 11:06:34 2005 +0100

    Added more pipe utiilties to Cmd.hs

diff --git a/MissingH/Cmd.hs b/MissingH/Cmd.hs
index 27b1338..6469e34 100644
--- a/MissingH/Cmd.hs
+++ b/MissingH/Cmd.hs
@@ -36,6 +36,9 @@ module MissingH.Cmd(-- * High-Level Tools
                     safeSystem,
                     forceSuccess,
                     pipeFrom,
+                    pipeLinesFrom,
+                    pipeTo,
+                    pipeBoth,
                     -- * Low-Level Tools
                     PipeMode(..),
                     pOpen, pOpen3)
@@ -52,6 +55,8 @@ import System.Posix.IO
 import System.Posix.Process
 import System.Posix.Types
 import System.IO
+import Control.Concurrent(forkIO)
+import Control.Exception(finally)
 
 import qualified System.Posix.Signals
 
@@ -78,9 +83,16 @@ See also: 'MissingH.Logging.Logger.updateGlobalLogger',
 
 -}
 
+{- | Like 'pipeFrom', but returns data in lines instead of just a String.
+Shortcut for calling lines on the result from 'pipeFrom'. -}
+pipeLinesFrom :: FilePath -> [String] -> IO (ProcessID, [String])
+pipeLinesFrom fp args =
+    do (pid, c) <- pipeFrom fp args
+       return $ (pid, lines c)
+
 {- | Read data from a pipe.  Returns a lazy string and a ProcessID.
 
-ONLY AFTER the string has been read completely, you must call either
+ONLY AFTER the string has been read completely, You must call either
 'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the ProcessID.
 Zombies will result otherwise.
 -}
@@ -101,6 +113,58 @@ pipeFrom fp args =
        c <- hGetContents h
        return (pid, c)
 
+{- | Write data to a pipe.  Returns a ProcessID.
+
+You must call either
+'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the ProcessID.
+Zombies will result otherwise.
+-}
+pipeTo :: FilePath -> [String] -> String -> IO ProcessID
+pipeTo fp args message =
+    do pipepair <- createPipe
+       debugM (logbase ++ ".pipeto")
+              ("Running: " ++ fp ++ " " ++ show args)
+       let childstuff = do dupTo (fst pipepair) stdInput
+                           executeFile fp True args Nothing
+       p <- try (forkProcess childstuff)
+       -- parent
+       pid <- case p of
+                     Right x -> return x
+                     Left e -> fail $ "Error in fork: " ++ show e
+       closeFd (fst pipepair)
+       h <- fdToHandle (snd pipepair)
+       finally (hPutStr h message)
+               (hClose h)
+       return pid
+
+{- | Like a combination of 'pipeTo' and 'pipeFrom'; forks an IO thread
+to send data to the piped program, and simultaneously returns its output
+stream.
+
+The same caveat about checking the return status applies here as with 'pipeFrom'. -}
+pipeBoth :: FilePath -> [String] -> String -> IO (ProcessID, String)
+pipeBoth fp args message =
+    do frompair <- createPipe
+       topair <- createPipe
+       debugM (logbase ++ ".pipeBoth")
+              ("Running: " ++ fp ++ " " ++ show args)
+       let childstuff = do dupTo (snd frompair) stdOutput
+                           dupTo (fst topair) stdInput
+                           executeFile fp True args Nothing
+       p <- try (forkProcess childstuff)
+       -- parent
+       pid <- case p of
+                     Right x -> return x
+                     Left e -> fail $ "Error in fork: " ++ show e
+       closeFd (snd frompair)
+       closeFd (fst topair)
+       fromh <- fdToHandle (fst frompair)
+       toh <- fdToHandle (snd topair)
+       forkIO $ finally (hPutStr toh message)
+                        (hClose toh)
+       c <- hGetContents fromh
+       return (pid, c)
+
 {- | Uses 'System.Posix.Process.getProcessStatus' to obtain the exit status
 of the given process ID.  If the process terminated normally, does nothing.
 Otherwise, raises an exception with an appropriate error message.  If error

-- 
haskell-testpack