On Sun, Nov 02, 2008 at 09:28:24AM +0100, Christian Kellermann wrote:
> Dear darcs-fans,
>
> Another round this time without the Glob dependency. One step further
> down the road to a perl free test suite.
>
> Thanks to Erik for the filter suggestion!
>
> Christian
>
> Sun Nov 2 09:10:42 CET 2008 Christian Kellermann <[EMAIL PROTECTED]>
> * shell_harness script in haskell
Just a few comments...
> [shell_harness script in haskell
> Christian Kellermann <[EMAIL PROTECTED]>**20081102081042
> Ignore-this: 710bcceaaf31ebc087b1b697ad106e8c
> ] addfile ./tests/shell_harness.hs
> hunk ./tests/shell_harness.hs 1
> +import Prelude hiding( catch )
> +import System.Directory ( getCurrentDirectory, setPermissions,
> + Permissions(..), getDirectoryContents )
> +import System.Environment ( getArgs, getEnv, getEnvironment )
> +import System.FilePath
> +import System.IO
> +import System.Process ( ProcessHandle, runInteractiveCommand,
> + runInteractiveProcess, waitForProcess )
> +import System.Exit ( ExitCode (..), exitWith )
> +import Data.Maybe
> +import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy )
isInfixOf is one of those recent innovations that you should avoid if you
want to write portable code.
> +import Control.Concurrent
> +import Control.Exception
> +import Control.Monad
> +
> +main :: IO ()
> +main = do
> + tests <- getArgs
> + cwd <- getCurrentDirectory
> + fails <- run tests
> + if "bugs" `isInfixOf` cwd
> + then if (length tests /= length fails)
> + then do putStrLn $ "Some bug tests passed:"
> + printall (tests \\ fails)
> + exitWith $ ExitFailure 1
> + else putStrLn "All bug tests OK"
> + else if fails /= []
> + then do putStrLn "Some tests failed:"
> + printall fails
> + exitWith $ ExitFailure 1
> + else putStrLn "All tests OK"
> + exitWith ExitSuccess
> + where printall [] = return ()
> + printall (l:ls) = do putStrLn l
> + printall ls
> +
> +run :: [String] -> IO [String]
> +run tests= do
> + cwd <- getCurrentDirectory
> + path <- getEnv "PATH"
> + env <- getEnvironment
> + darcs_path <- get_darcs_path
> + let myenv = [("HOME",cwd)
> + ,("PWD",cwd)
> + ,("EMAIL","tester")
> + ,("DARCSEMAIL","tester")
> + ,("PATH",(darcs_path++":"++path))
> + ,("DARCS_DONT_COLOR","1")
> + ,("DARCS_DONT_ESCAPE_ANYTHING","1")]
> + bash <- find_bash
> + let shell = takeWhile (/= '\n') bash
> + putStrLn $ "Using bash shell in '"++shell++"'"
> + run_helper shell tests [] (set_env myenv env)
> + where get_darcs_path = do
> + env <- getEnvironment
> + cwd <- getCurrentDirectory
> + case lookup "DARCS" env of
> + Nothing -> return (cwd ++ "/..")
> + Just d -> return $ takeDirectory d
> +
> +run_helper :: String -> [String] -> [String] ->
> + [(String,String)] -> IO [String]
> +run_helper _ [] fails _ = return fails
> +run_helper shell (test:ts) fails env = do
> + putStr $ "Running test " ++ test ++ "....."
> + (output,success) <- backtick shell test env
> + if success then do putStrLn "passed."
> + cleanup_dirs
> + run_helper shell ts fails env
> + else do putStrLn "failed."
> + putStrLn $ "Probable reason :" ++ output
> + cleanup_dirs
> + run_helper shell ts (fails++[test]) env
> + where cleanup_dirs :: IO ()
> + cleanup_dirs =
> + do dirfiles <- getDirectoryContents (fromJust $ lookup "PWD" env)
> + mapM_ (\x->
> + setPermissions x (Permissions
> + {readable = True
> + ,writable = True
> + ,executable = True
> + ,searchable = True}
I don't see any reason why we should be making files executable...
> + )
> + ) $ filter ("temp" `isPrefixOf`) dirfiles
> + return ()
> +
> +backtick :: String -> String -> [(String, String)]-> IO (String,Bool)
> +backtick cmd args env = do
> + (exitcode,(res,failure)) <- backtick_helper cmd args env
> + case exitcode of
> + ExitSuccess -> return (res, True)
> + ExitFailure code -> return (failure, False)
> +
> +backtick_helper :: String -> String -> [(String,String)] ->
> + IO (ExitCode, (String, String))
> +backtick_helper cmd args env = process_wrapper (runInteractiveProcess
> + cmd [args] Nothing
> + (Just env)
> + ) ""
> +
> +find_bash =
> + do (exitcode, (bash, failure)) <- process_wrapper
> + (runInteractiveCommand
> + "which bash"
> + ) ""
> + case exitcode of
> + ExitFailure c -> error $ "bash needed for testsuite! Exit Code:"
> + ++ show c ++ " : "++ failure
> + ExitSuccess -> return bash
You could just use findExecutable for this...
> +process_wrapper :: IO (Handle, Handle, Handle, ProcessHandle) ->
> + String -> IO (ExitCode, (String, String))
> +process_wrapper f input =
> + handle (\e -> return (ExitFailure 1, ([], show e))) $ do
> + (inp,out,err,pid) <- f
> + hPutStr inp input >> hClose inp
> + output <- hGetContents out
> + errput <- hGetContents err
> + outMVar <- newEmptyMVar
> + errMVar <- newEmptyMVar
> + forkIO (evaluate (length output) >> putMVar outMVar ())
> + forkIO (evaluate (length errput) >> putMVar errMVar ())
> + takeMVar outMVar
> + takeMVar errMVar
> + e <- catch
> + (waitForProcess pid)
> + (\_ -> return ExitSuccess)
> + hClose out >> hClose err
> + return (e, (output, errput))
It'd be better to keep output and errput interleaved as closely as
possible. It's unfortunate that runInteractiveCommand doesn't support
this, but you could look at franchise for an attempt to get some semblance
of interleaving through use of threads. Without this, it's very hard to
figure out which error messages go with which output.
> +set_env :: [(String,String)] -> [(String,String)] -> [(String, String)]
> +set_env es env = nubBy (\(x,_) (y,_) -> x == y) (es ++ env)
_______________________________________________
darcs-users mailing list
[email protected]
http://lists.osuosl.org/mailman/listinfo/darcs-users
