Commit 3b4518db authored by ttuegel's avatar ttuegel
Browse files

Add Distribution.Compat.CreatePipe

parent 193c49c7
......@@ -137,6 +137,7 @@ library
ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs
exposed-modules:
Distribution.Compat.CreatePipe
Distribution.Compat.Environment
Distribution.Compat.Exception
Distribution.Compat.ReadP
......@@ -239,7 +240,6 @@ test-suite package-tests
type: exitcode-stdio-1.0
main-is: PackageTests.hs
other-modules:
Distribution.Compat.CreatePipe
PackageTests.BenchmarkExeV10.Check
PackageTests.BenchmarkOptions.Check
PackageTests.BenchmarkStanza.Check
......
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module Distribution.Compat.CreatePipe (createPipe) where
module Distribution.Compat.CreatePipe (createPipe, tee) where
import System.IO (Handle)
import Control.Concurrent (forkIO)
import Control.Monad (forM_, when)
import System.IO (Handle, hClose, hGetContents, hPutStr)
#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
import System.Posix.IO (fdToHandle)
import qualified System.Posix.IO as Posix
#else
# include <io.h> /* for _close and _pipe */
# include <fcntl.h> /* for _O_BINARY */
-- The mingw32_HOST_OS CPP macro is GHC-specific
#if mingw32_HOST_OS
import Control.Exception (onException)
import Foreign.C.Error (throwErrnoIfMinus1_)
import Foreign.C.Types (CInt(..), CUInt(..))
......@@ -19,37 +17,59 @@ import GHC.IO.FD (mkFD)
import GHC.IO.Device (IODeviceType(Stream))
import GHC.IO.Handle.FD (mkHandleFromFD)
import System.IO (IOMode(ReadMode, WriteMode))
#else
import System.Posix.IO (fdToHandle)
import qualified System.Posix.IO as Posix
#endif
createPipe :: IO (Handle, Handle)
#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
createPipe = do
(readfd, writefd) <- Posix.createPipe
readh <- fdToHandle readfd
writeh <- fdToHandle writefd
return (readh, writeh)
#else
-- The mingw32_HOST_OS CPP macro is GHC-specific
#if mingw32_HOST_OS
createPipe = do
(readfd, writefd) <- allocaArray 2 $ \ pfds -> do
throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)
throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768)
readfd <- peek pfds
writefd <- peekElemOff pfds 1
return (readfd, writefd)
(do readh <- fdToHandle readfd ReadMode
writeh <- fdToHandle writefd WriteMode
return (readh, writeh)) `onException` (close readfd >> close writefd)
where
fdToHandle :: CInt -> IOMode -> IO Handle
fdToHandle fd mode = do
(fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False
mkHandleFromFD fd' deviceType "" mode False Nothing
fdToHandle :: CInt -> IOMode -> IO Handle
fdToHandle fd mode = do
(fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False
mkHandleFromFD fd' deviceType "" mode False Nothing
close :: CInt -> IO ()
close = throwErrnoIfMinus1_ "_close" . c__close
close :: CInt -> IO ()
close = throwErrnoIfMinus1_ "_close" . c__close
foreign import ccall "io.h _pipe" c__pipe ::
Ptr CInt -> CUInt -> CInt -> IO CInt
foreign import ccall "io.h _close" c__close ::
CInt -> IO CInt
#else
createPipe = do
(readfd, writefd) <- Posix.createPipe
readh <- fdToHandle readfd
writeh <- fdToHandle writefd
return (readh, writeh)
#endif
-- | Copy the contents of the input handle to the output handles, like
-- the Unix command. The input handle is processed in another thread until
-- EOF is reached; 'tee' returns immediately. The 'Bool' with each output
-- handle indicates if it should be closed when EOF is reached.
-- Synchronization can be achieved by blocking on an output handle.
tee :: Handle -- ^ input
-> [(Handle, Bool)] -- ^ output, close?
-> IO ()
tee inH outHs = do
-- 'hGetContents' might cause text decoding errors on binary streams that
-- are not text. It might be better to read into a buffer with 'hGetBuf'
-- that does no text decoding, but that seems to block all threads on
-- Windows. This is much simpler.
str <- hGetContents inH
forM_ outHs $ \(h, close) -> forkIO $ do
hPutStr h str
when close $ hClose h
......@@ -14,7 +14,7 @@ all: build
# build the library itself
SOURCES=Distribution/*.hs Distribution/Simple/*.hs Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs Distribution/Simple/Build/*.hs Distribution/Compat/*.hs Distribution/Simple/Program/*.hs
SOURCES=Distribution/*.hs Distribution/Simple/*.hs Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs Distribution/Simple/Build/*.hs Distribution/Compat/*.hs Distribution/Simple/Program/*.hs Distribution/Compat/CreatePipe.hs
CONFIG_STAMP=dist/setup-config
BUILD_STAMP=dist/build/libHSCabal-$(VERSION).a
HADDOCK_STAMP=dist/doc/html/Cabal/index.html
......@@ -25,6 +25,9 @@ DIST_STAMP=$(DISTLOC)/Cabal-$(VERSION).tar.gz
COMMA=,
Distribution/Compat/CreatePipe.hs: Distribution/Compat/CreatePipe.hsc
hsc2hs Distribution/Compat/CreatePipe.hsc
setup: $(SOURCES) Setup.hs
-mkdir -p dist/setup
$(HC) $(GHCFLAGS) --make -i. -odir dist/setup -hidir dist/setup Setup.hs -o setup
......@@ -83,6 +86,7 @@ docs: haddock users-guide
clean:
rm -rf dist/
rm -f setup
rm Distribution/Compat/CreatePipe.hs
# testing...
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment