Commit 6d9f33ce authored by Ben Gamari's avatar Ben Gamari 🐢

Fix binary stdin

parent 97f9ea57
......@@ -13,6 +13,7 @@ import qualified Data.Map.Strict as M
import Data.Time.Clock
import qualified System.Directory as IO
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import System.Exit
import System.Info
import System.IO
......@@ -291,21 +292,21 @@ buildRules nofib@Build{..} = do
(stdin, args) <- liftIO $ getTestCmdline nofib test
executable <- liftIO $ IO.canonicalizePath $ output </> test </> "Main" <.> exe
out' <- liftIO $ IO.canonicalizePath out
cmd_ (Cwd test) (EchoStdout False) (Stdin stdin) "valgrind" "--tool=cachegrind" ("--cachegrind-out-file="++out') executable args
cmd_ (Cwd test) (EchoStdout False) (StdinBS stdin) "valgrind" "--tool=cachegrind" ("--cachegrind-out-file="++out') executable args
getTestCmdline :: Nofib -> String -> IO (FilePath, [String])
getTestCmdline :: Nofib -> String -> IO (BSL.ByteString, [String])
getTestCmdline nofib@Build{run=Just speed,..} test = do
config <- readConfig $ output </> test </> "config.txt"
let args = words (config "PROG_ARGS") ++ words (config $ map toUpper (show speed) ++ "_OPTS")
stdin <- let s = config "STDIN_FILE" in if s == "" then grab "stdin" else readFile $ test </> s
stdin <- let s = config "STDIN_FILE" in if s == "" then grab "stdin" else BSL.readFile $ test </> s
return (stdin, args)
where
grab :: String -> IO String
grab :: String -> IO BSL.ByteString
grab ext = do
let s = [test </> takeFileName test <.> map toLower (show speed) ++ ext
,test </> takeFileName test <.> ext]
ss <- filterM IO.doesFileExist s
maybe (return "") readFile $ listToMaybe ss
maybe (return BSL.empty) BSL.readFile $ listToMaybe ss
-- | Run a test, checking stdout/stderr are as expected, and reporting time.
-- Return True if the test passes.
......@@ -322,8 +323,8 @@ runTest nofib@Build{run=Just speed,..} test = do
end <- getCurrentTime
stdoutWant <- grab "stdout"
stderrWant <- grab "stderr"
writeFile (output </> test </> "stdout") stdout
writeFile (output </> test </> "stderr") stderr
BSL.writeFile (output </> test </> "stdout") stdout
BSL.writeFile (output </> test </> "stderr") stderr
putStrLn $ show (floor $ fromRational (toRational $ end `diffUTCTime` start) * 1000) ++ "ms"
putStr =<< readFile stats
err <- return $
......@@ -333,14 +334,15 @@ runTest nofib@Build{run=Just speed,..} test = do
else ""
if null err then return True else putStrLn err >> return False
where
snip x = if length x > 200 then take 200 x ++ "..." else x
snip :: BSL.ByteString -> String
snip x = if BSL.length x > 200 then BSL.unpack (BSL.take 200 x) ++ "..." else BSL.unpack x
grab :: String -> IO String
grab :: String -> IO BSL.ByteString
grab ext = do
let s = [test </> takeFileName test <.> map toLower (show speed) ++ ext
,test </> takeFileName test <.> ext]
ss <- filterM IO.doesFileExist s
maybe (return "") readFile $ listToMaybe ss
maybe (return BSL.empty) BSL.readFile $ listToMaybe ss
---------------------------------------------------------------------
......@@ -404,8 +406,8 @@ readProcessWithExitCodeAndWorkingDirectory
:: FilePath -- ^ directory to use
-> FilePath -- ^ command to run
-> [String] -- ^ any arguments
-> String -- ^ standard input
-> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr
-> BSL.ByteString -- ^ standard input
-> IO (ExitCode, BSL.ByteString, BSL.ByteString) -- ^ exitcode, stdout, stderr
readProcessWithExitCodeAndWorkingDirectory cwd cmd args input = do
(Just inh, Just outh, Just errh, pid) <-
createProcess (proc cmd args){ cwd = Just cwd,
......@@ -413,11 +415,11 @@ readProcessWithExitCodeAndWorkingDirectory cwd cmd args input = do
std_out = CreatePipe,
std_err = CreatePipe }
outMVar <- newEmptyMVar
out <- hGetContents outh
_ <- forkIO $ evaluate (length out) >> putMVar outMVar ()
err <- hGetContents errh
_ <- forkIO $ evaluate (length err) >> putMVar outMVar ()
when (not (null input)) $ do hPutStr inh input; hFlush inh
out <- BSL.hGetContents outh
_ <- forkIO $ evaluate (BSL.length out) >> putMVar outMVar ()
err <- BSL.hGetContents errh
_ <- forkIO $ evaluate (BSL.length err) >> putMVar outMVar ()
when (not (BSL.null input)) $ do BSL.hPutStr inh input; hFlush inh
hClose inh
takeMVar outMVar
takeMVar outMVar
......
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