Commit e50782d4 authored by gershomb's avatar gershomb Committed by GitHub

Merge pull request #23 from haskell/gb/response-files-in-process-calls

response file generation and usage
parents 6811e9d4 9a49d183
......@@ -3,6 +3,8 @@ module Common where
import qualified Control.Exception as Exception
import Control.Monad ( when )
import Data.Char ( isSpace )
import Data.List ( foldl' )
import System.IO
#if defined(mingw32_HOST_OS)
import Control.Concurrent ( threadDelay )
......@@ -25,19 +27,21 @@ default_compiler = "gcc"
writeBinaryFile :: FilePath -> String -> IO ()
writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
rawSystemL action flg prog args = do
rawSystemL :: FilePath -> String -> Bool -> FilePath -> [String] -> IO ()
rawSystemL outDir action flg prog args = withResponseFile outDir "c2hscall.rsp" args $ \rspFile -> do
let cmdLine = prog++" "++unwords args
when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
exitStatus <- rawSystem prog args
(_,_,_,ph) <- createProcess (proc prog ['@':rspFile])
exitStatus <- waitForProcess ph
case exitStatus of
ExitFailure exitCode -> die $ action ++ " failed "
++ "(exit code " ++ show exitCode ++ ")\n"
++ "command was: " ++ cmdLine ++ "\n"
_ -> return ()
rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
rawSystemWithStdOutL action flg prog args outFile = do
rawSystemWithStdOutL :: FilePath -> String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
rawSystemWithStdOutL outDir action flg prog args outFile = withResponseFile outDir "c2hscall.rsp" args $ \rspFile -> do
let cmdLine = prog++" "++unwords args++" >"++outFile
when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
hOut <- openFile outFile WriteMode
......@@ -47,9 +51,9 @@ rawSystemWithStdOutL action flg prog args outFile = do
-- available.
createProcess
#if MIN_VERSION_process (1,5,0)
(proc prog args){ use_process_jobs = True, std_out = UseHandle hOut }
(proc prog ['@':rspFile]){ use_process_jobs = True, std_out = UseHandle hOut }
#else
(proc prog args){ std_out = UseHandle hOut }
(proc prog ['@':rspFile]){ std_out = UseHandle hOut }
#endif
exitStatus <- waitForProcess process
hClose hOut
......@@ -103,3 +107,46 @@ catchIO = Exception.catch
onlyOne :: String -> IO a
onlyOne what = die ("Only one "++what++" may be specified\n")
-- response file handling borrowed from cabal's at Distribution.Simple.Program.ResponseFile
withTempFile :: FilePath -- ^ Temp dir to create the file in
-> String -- ^ File name template. See 'openTempFile'.
-> (FilePath -> Handle -> IO a) -> IO a
withTempFile tmpDir template action =
Exception.bracket
(openTempFile tmpDir template)
(\(name, handle) -> do hClose handle
removeFile $ name)
(uncurry action)
withResponseFile ::
FilePath -- ^ Working directory to create response file in.
-> FilePath -- ^ Template for response file name.
-> [String] -- ^ Arguments to put into response file.
-> (FilePath -> IO a)
-> IO a
withResponseFile workDir fileNameTemplate arguments f =
withTempFile workDir fileNameTemplate $ \responseFileName hf -> do
let responseContents = unlines $ map escapeResponseFileArg arguments
hPutStr hf responseContents
hClose hf
f responseFileName
-- Support a gcc-like response file syntax. Each separate
-- argument and its possible parameter(s), will be separated in the
-- response file by an actual newline; all other whitespace,
-- single quotes, double quotes, and the character used for escaping
-- (backslash) are escaped. The called program will need to do a similar
-- inverse operation to de-escape and re-constitute the argument list.
escapeResponseFileArg :: String -> String
escapeResponseFileArg = reverse . foldl' escape []
where
escape :: String -> Char -> String
escape cs c =
case c of
'\\' -> c:'\\':cs
'\'' -> c:'\\':cs
'"' -> c:'\\':cs
_ | isSpace c -> c:'\\':cs
| otherwise -> c:cs
......@@ -73,7 +73,7 @@ outputDirect config outName outDir outBase name toks = do
when (cNoCompile config) $ exitWith ExitSuccess
rawSystemL ("compiling " ++ cProgName) beVerbose (cCompiler config)
rawSystemL outDir ("compiling " ++ cProgName) beVerbose (cCompiler config)
( ["-c"]
++ [cProgName]
++ ["-o", oProgName]
......@@ -82,14 +82,14 @@ outputDirect config outName outDir outBase name toks = do
possiblyRemove cProgName $
withUtilsObject config outDir outBase $ \oUtilsName -> do
rawSystemL ("linking " ++ oProgName) beVerbose (cLinker config)
rawSystemL outDir ("linking " ++ oProgName) beVerbose (cLinker config)
( [oProgName, oUtilsName]
++ ["-o", progName]
++ [f | LinkFlag f <- flags]
)
possiblyRemove oProgName $ do
rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
rawSystemWithStdOutL outDir ("running " ++ execProgName) beVerbose execProgName [] outName
possiblyRemove progName $ do
when needsH $ writeBinaryFile outHName $
......
......@@ -76,11 +76,10 @@ withUtilsObject config outDir outBase f = do
possiblyRemove oUtilsName $ do
unless (cNoCompile config) $
rawSystemL ("compiling " ++ cUtilsName)
rawSystemL outDir ("compiling " ++ cUtilsName)
beVerbose
(cCompiler config)
(["-c", cUtilsName, "-o", oUtilsName] ++
[cFlag | CompFlag cFlag <- flags])
f oUtilsName
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