Commit 869d4561 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Add support for text encoding when invoking a program

Can be either locale text or specifically UTF8.
Also tidy up the rawSystemStd* variants and pass
a text/binary mode flag for the input and output.
parent c287be77
......@@ -11,6 +11,7 @@
module Distribution.Simple.Program.Run (
ProgramInvocation(..),
IOEncoding(..),
emptyProgramInvocation,
simpleProgramInvocation,
programInvocation,
......@@ -24,12 +25,17 @@ module Distribution.Simple.Program.Run (
import Distribution.Simple.Program.Types
( ConfiguredProgram(..), programPath )
import Distribution.Simple.Utils
( die, rawSystemExit, rawSystemStdin, rawSystemStdout )
( die, rawSystemExit, rawSystemStdInOut
, toUTF8, fromUTF8 )
import Distribution.Verbosity
( Verbosity )
import Data.List
( foldl', unfoldr )
import Control.Monad
( when )
import System.Exit
( ExitCode(..) )
-- | Represents a specific invocation of a specific program.
--
......@@ -43,9 +49,14 @@ data ProgramInvocation = ProgramInvocation {
progInvokeArgs :: [String],
progInvokeEnv :: [(String, String)],
progInvokeCwd :: Maybe FilePath,
progInvokeInput :: Maybe String
progInvokeInput :: Maybe String,
progInvokeInputEncoding :: IOEncoding,
progInvokeOutputEncoding :: IOEncoding
}
data IOEncoding = IOEncodingText -- locale mode text
| IOEncodingUTF8 -- always utf8
emptyProgramInvocation :: ProgramInvocation
emptyProgramInvocation =
ProgramInvocation {
......@@ -53,7 +64,9 @@ emptyProgramInvocation =
progInvokeArgs = [],
progInvokeEnv = [],
progInvokeCwd = Nothing,
progInvokeInput = Nothing
progInvokeInput = Nothing,
progInvokeInputEncoding = IOEncodingText,
progInvokeOutputEncoding = IOEncodingText
}
simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation
......@@ -90,9 +103,18 @@ runProgramInvocation verbosity
progInvokeArgs = args,
progInvokeEnv = [],
progInvokeCwd = Nothing,
progInvokeInput = Just input
} =
rawSystemStdin verbosity path args input
progInvokeInput = Just inputStr,
progInvokeInputEncoding = encoding
} = do
(output, errors, exitCode) <- rawSystemStdInOut verbosity
path args
(Just input) False
when (exitCode /= ExitSuccess) $
die errors
where
input = case encoding of
IOEncodingText -> (inputStr, False)
IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8
runProgramInvocation _ _ =
die "runProgramInvocation: not yet implemented for this form of invocation"
......@@ -105,9 +127,17 @@ getProgramInvocationOutput verbosity
progInvokeArgs = args,
progInvokeEnv = [],
progInvokeCwd = Nothing,
progInvokeInput = Nothing
} =
rawSystemStdout verbosity path args
progInvokeInput = Nothing,
progInvokeOutputEncoding = encoding
} = do
let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False
(output, errors, exitCode) <- rawSystemStdInOut verbosity
path args
Nothing utf8
when (exitCode /= ExitSuccess) $
die errors
return (if utf8 then fromUTF8 output else output)
getProgramInvocationOutput _ _ =
die "getProgramInvocationOutput: not yet implemented for this form of invocation"
......
......@@ -60,8 +60,7 @@ module Distribution.Simple.Utils (
-- * running programs
rawSystemExit,
rawSystemStdout,
rawSystemStdout',
rawSystemStdin,
rawSystemStdInOut,
maybeExit,
xargs,
findProgramLocation,
......@@ -358,41 +357,64 @@ rawSystemExit verbosity path args = do
-- | Run a command and return its output.
--
-- The output is assumed to be encoded as UTF8.
-- The output is assumed to be text in the locale encoding.
--
rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
rawSystemStdout verbosity path args = do
(output, exitCode) <- rawSystemStdout' verbosity path args
unless (exitCode == ExitSuccess) $ exitWith exitCode
(output, errors, exitCode) <- rawSystemStdInOut verbosity path args
Nothing False
when (exitCode /= ExitSuccess) $
die errors
return output
rawSystemStdout' :: Verbosity -> FilePath -> [String] -> IO (String, ExitCode)
rawSystemStdout' verbosity path args = do
-- | Run a command and return its output, errors and exit status. Optionally
-- also supply some input. Also provides control over whether the binary/text
-- mode of the input and output.
--
rawSystemStdInOut :: Verbosity
-> FilePath -> [String]
-> Maybe (String, Bool) -- ^ input text and binary mode
-> Bool -- ^ output in binary mode
-> IO (String, String, ExitCode) -- ^ output, errors, exit
rawSystemStdInOut verbosity path args input outputBinary = do
printRawCommandAndArgs verbosity path args
#ifdef __GLASGOW_HASKELL__
Exception.bracket
(runInteractiveProcess path args Nothing Nothing)
(\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
$ \(_,outh,errh,pid) -> do
$ \(inh,outh,errh,pid) -> do
-- We want to process the output as text.
hSetBinaryMode outh False
-- output mode depends on what the caller wants
hSetBinaryMode outh outputBinary
-- but the errors are always assumed to be text (in the current locale)
hSetBinaryMode errh False
-- fork off a thread to pull on (and discard) the stderr
-- fork off a couple threads to pull on the stderr and stdout
-- so if the process writes to stderr we do not block.
-- NB. do the hGetContents synchronously, otherwise the outer
-- bracket can exit before this thread has run, and hGetContents
-- will fail.
err <- hGetContents errh
out <- hGetContents outh
mv <- newEmptyMVar
let force str = (do _ <- evaluate (length str)
return ())
let force str = (evaluate (length str) >> return ())
`Exception.finally` putMVar mv ()
--TODO: handle exceptions like text decoding.
_ <- forkIO $ force out
_ <- forkIO $ force err
-- push all the input, if any
case input of
Nothing -> return ()
Just (inputStr, inputBinary) -> do
-- input mode depends on what the caller wants
hSetBinaryMode inh inputBinary
hPutStr inh inputStr
hClose inh
--TODO: this probably fails if the process refuses to consume
-- or if it closes stdin (eg if it exits)
-- wait for both to finish, in either order
takeMVar mv
takeMVar mv
......@@ -403,66 +425,33 @@ rawSystemStdout' verbosity path args = do
++ if null err then "" else
" with error message:\n" ++ err
return (out, exitcode)
return (out, err, exitcode)
#else
tmpDir <- getTemporaryDirectory
withTempFile tmpDir ".cmd.stdout" $ \tmpName tmpHandle -> do
hClose tmpHandle
let quote name = "'" ++ name ++ "'"
exitcode <- system $ unwords (map quote (path:args)) ++ " >" ++ quote tmpName
unless (exitcode == ExitSuccess) $
debug verbosity $ path ++ " returned " ++ show exitcode
withFileContents tmpName $ \output ->
length output `seq` return (output, exitcode)
#endif
withTempFile tmpDir ".cmd.stdout" $ \outName outHandle ->
withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do
hClose outHandle
rawSystemStdin :: Verbosity -> FilePath -> [String] -> String -> IO ()
rawSystemStdin verbosity path args input = do
printRawCommandAndArgs verbosity path args
case input of
Nothing -> return ()
Just (inputStr, inputBinary) -> do
hSetBinaryMode inHandle inputBinary
hPutStr inHandle inputStr
hClose inHandle
#ifdef __GLASGOW_HASKELL__
Exception.bracket
(runInteractiveProcess path args Nothing Nothing)
(\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
$ \(inh,outh,errh,pid) -> do
-- We want to process the input as text.
hSetBinaryMode inh False
-- fork off a thread to pull on (and discard) the stderr and stdout
-- so if the process writes to stderr or stdout we do not block.
-- NB. do the hGetContents synchronously, otherwise the outer
-- bracket can exit before this thread has run, and hGetContents
-- will fail.
err <- hGetContents errh
out <- hGetContents outh
mv <- newEmptyMVar
let force str = (do _ <- evaluate (length str)
return ())
`Exception.finally` putMVar mv ()
_ <- forkIO $ force out
_ <- forkIO $ force err
-- push all the input
hPutStr inh input
hClose inh
takeMVar mv
takeMVar mv
-- wait for the program to terminate
exitcode <- waitForProcess pid
unless (exitcode == ExitSuccess) (die err)
#else
tmpDir <- getTemporaryDirectory
withTempFile tmpDir ".cmd.stdin" $ \tmpName tmpHandle -> do
hPutStr tmpHandle input
hClose tmpHandle
let quote name = "'" ++ name ++ "'"
exitcode <- system $ unwords (map quote (path:args)) ++ " <" ++ quote tmpName
unless (exitcode == ExitSuccess) $ do
cmd = unwords (map quote (path:args))
++ " <" ++ quote inName
++ " >" ++ quote outName
exitcode <- system cmd
unless (exitcode == ExitSuccess) $
debug verbosity $ path ++ " returned " ++ show exitcode
exitWith exitcode
return ()
Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do
hSetBinaryMode hnd outputBinary
output <- hGetContents hnd
length output `seq` return (output, "", exitcode)
#endif
......
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