Commit ce05b36c authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Rewrite rawSystemStdout to not use runInteractiveProcess with ghc

So it doesn't use a temp file to capture the output.
Since runInteractiveProcess is only available on ghc we
use the temp file method for other implementations.
parent 118a377a
......@@ -84,7 +84,7 @@ module Distribution.Simple.Utils (
) where
import Control.Monad
( when, filterM, unless, liftM2 )
( when, filterM, unless )
import Data.List
( nub, unfoldr )
......@@ -100,10 +100,9 @@ import System.Exit
import System.FilePath
( takeDirectory, takeExtension, (</>), (<.>), pathSeparator )
import System.Directory
( copyFile, findExecutable, createDirectoryIfMissing
, getTemporaryDirectory )
( copyFile, findExecutable, createDirectoryIfMissing )
import System.IO
( hPutStrLn, stderr, hFlush, stdout, openFile, IOMode(WriteMode) )
( hPutStrLn, stderr, hFlush, stdout )
import System.IO.Error
( try )
import Control.Exception
......@@ -116,11 +115,14 @@ import Distribution.Version
import Distribution.Package
(PackageIdentifier(..))
#ifdef __NHC__
import System.Cmd (system)
#else
#ifdef __GLASGOW_HASKELL__
import Control.Concurrent (forkIO)
import Control.Exception (evaluate)
import System.Process (runProcess, waitForProcess)
import System.Process (runInteractiveProcess, waitForProcess)
import System.IO (hGetContents)
#else
import System.Cmd (system)
import System.Directory (getTemporaryDirectory)
#endif
import System.IO (Handle, hClose)
......@@ -258,30 +260,28 @@ rawSystemStdout verbosity path args = do
rawSystemStdout' :: Verbosity -> FilePath -> [String] -> IO (String, ExitCode)
rawSystemStdout' verbosity path args = do
printRawCommandAndArgs verbosity path args
tmpDir <- getTemporaryDirectory
#if __GLASGOW_HASKELL__ >= 604
-- TODO Ideally we'd use runInteractiveProcess and not have to make any
-- silly temp files, however it is not possible to only connect pipes
-- to a subset of the process's stdin/out/err. We really cannot
-- connect to all three since then we'd need threads to pull on stdout
-- and stderr simultaniously to avoid deadlock, and using threads like
-- that would not be portable to Hugs for example.
bracket (liftM2 (,) (openTempFile tmpDir "cmdstdout") (openFile devNull WriteMode))
-- We need to close tmpHandle or the file removal fails on Windows
(\((tmpName, tmpHandle), nullHandle) -> do
hClose tmpHandle
removeFile tmpName
hClose nullHandle)
$ \((tmpName, tmpHandle), nullHandle) -> do
cmdHandle <- runProcess path args Nothing Nothing
Nothing (Just tmpHandle) (Just nullHandle)
exitCode <- waitForProcess cmdHandle
output <- readFile tmpName
evaluate (length output)
return (output, exitCode)
#ifdef __GLASGOW_HASKELL__
bracket (runInteractiveProcess path args Nothing Nothing)
(\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
$ \(_,outh,errh,pid) -> do
-- fork off a thread to pull on (and discard) the stderr
-- so if the process writes to stderr we do not block.
forkIO $ hGetContents errh >>= evaluate . length >> return ()
-- wait for all the output
output <- hGetContents outh
evaluate (length output)
-- wait for the program to terminate
exitcode <- waitForProcess pid
return (output, exitcode)
#else
withTempFile tmpDir "cmdstdout" $ \tmpName -> do
tmpDir <- getTemporaryDirectory
withTempFile tmpDir ".cmd.stdout" $ \tmpName tmpHandle -> do
hClose tmpHandle
let quote name = "'" ++ name ++ "'"
exitCode <- system $ unwords (map quote (path:args)) ++ " >" ++ quote tmpName
output <- readFile tmpName
......@@ -586,11 +586,6 @@ dllExtension = case os of
OSX -> "dylib"
_ -> "so"
devNull :: FilePath
devNull = case os of
Windows _ -> "NUL"
_ -> "/dev/null"
-- ------------------------------------------------------------
-- * 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