Permalink
Browse files

Use standard function launch process in test code

  • Loading branch information...
1 parent 5166dbc commit ff1c2727ce2a36800bf48ae47e692db89dfd822b @tibbe tibbe committed Sep 20, 2012
Showing with 27 additions and 10 deletions.
  1. +8 −10 Cabal/Distribution/Simple/Test.hs
  2. +19 −0 Cabal/Distribution/Simple/Utils.hs
@@ -71,7 +71,7 @@ import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
( LocalBuildInfo(..) )
import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )
-import Distribution.Simple.Utils ( die, notice )
+import Distribution.Simple.Utils ( die, notice, rawSystemIOWithEnv )
import Distribution.TestSuite
( OptionDescr(..), Options, Progress(..), Result(..), TestInstance(..)
, Test(..) )
@@ -91,7 +91,6 @@ import System.Environment ( getEnvironment )
import System.Exit ( ExitCode(..), exitFailure, exitWith )
import System.FilePath ( (</>), (<.>) )
import System.IO ( hClose, IOMode(..), openFile )
-import System.Process ( runProcess, waitForProcess )
-- | Logs all test results for a package, broken down first by test suite and
-- then by test case.
@@ -191,10 +190,10 @@ testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do
pwd <- getCurrentDirectory
existingEnv <- getEnvironment
let dataDirPath = pwd </> PD.dataDir pkg_descr
- shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
- : ("HPCTIXFILE", (</>) pwd
- $ tixFilePath distPref $ PD.testName suite)
- : existingEnv
+ shellEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
+ : ("HPCTIXFILE", (</>) pwd
+ $ tixFilePath distPref $ PD.testName suite)
+ : existingEnv
bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->
bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do
@@ -223,10 +222,9 @@ testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do
exit <- do
hLog <- openFile tempLog AppendMode
hIn <- openFile tempInput ReadMode
- -- these handles get closed by runProcess
- proc <- runProcess cmd opts Nothing shellEnv
- (Just hIn) (Just hLog) (Just hLog)
- waitForProcess proc
+ -- these handles get closed by rawSystemIOWithEnv
+ rawSystemIOWithEnv verbosity cmd opts shellEnv (Just hIn)
+ (Just hLog) (Just hLog)
-- Generate TestSuiteLog from executable exit code and a machine-
-- readable test log
@@ -62,6 +62,7 @@ module Distribution.Simple.Utils (
rawSystemExitWithEnv,
rawSystemStdout,
rawSystemStdInOut,
+ rawSystemIOWithEnv,
maybeExit,
xargs,
findProgramLocation,
@@ -401,6 +402,24 @@ rawSystemExitWithEnv verbosity path args env = do
debug verbosity $ path ++ " returned " ++ show exitcode
exitWith exitcode
+-- Closes the passed in handles before returning.
+rawSystemIOWithEnv :: Verbosity
+ -> FilePath
+ -> [String]
+ -> [(String, String)]
+ -> Maybe Handle -- ^ stdin
+ -> Maybe Handle -- ^ stdout
+ -> Maybe Handle -- ^ stderr
+ -> IO ExitCode
+rawSystemIOWithEnv verbosity path args env inp out err = do
+ printRawCommandAndArgsAndEnv verbosity path args env
+ hFlush stdout
+ ph <- runProcess path args Nothing (Just env) inp out err
+ exitcode <- waitForProcess ph
+ unless (exitcode == ExitSuccess) $ do
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ return exitcode
+
-- | Run a command and return its output.
--
-- The output is assumed to be text in the locale encoding.

0 comments on commit ff1c272

Please sign in to comment.