darcs 2.1.2.1 → 2.1.2.2
raw patch · 2 files changed
+173/−1 lines, 2 files
Files
- Distribution/ShellHarness.hs +171/−0
- darcs.cabal +2/−1
+ Distribution/ShellHarness.hs view
@@ -0,0 +1,171 @@+{-# OPTIONS_GHC -cpp #-}+module Distribution.ShellHarness ( runTests ) where++import Prelude hiding( catch )+import System.Directory ( getCurrentDirectory, setPermissions,+ Permissions(..), getDirectoryContents,+ findExecutable, createDirectoryIfMissing )+import System.Environment ( getEnv, getEnvironment )+import System.Exit ( ExitCode (..), exitWith )+import System.FilePath+import System.IO+import System.Process ( ProcessHandle, runInteractiveCommand,+ runInteractiveProcess, waitForProcess,+ getProcessExitCode )+import Data.Maybe+import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy )+import Control.Concurrent+#if __GLASGOW_HASKELL__ >= 610+import Control.OldException+#else+import Control.Exception+#endif+import Control.Monad++runTests :: String -> [String] -> IO Bool+runTests cwd tests = do+ fails <- run tests+ if "bugs" `isInfixOf` cwd+ then if (length tests /= length fails)+ then do putStrLn $ "Some bug tests passed:"+ mapM_ putStrLn (tests \\ fails)+ return False+ else do putStrLn "All bug tests OK"+ return True+ else if fails /= []+ then do putStrLn "Some tests failed:"+ mapM_ putStrLn fails+ return False+ else do putStrLn "All tests OK"+ return True++run :: [String] -> IO [String]+run tests= do+ cwd <- getCurrentDirectory+ path <- getEnv "PATH"+ env <- getEnvironment+ darcs_path <- get_darcs_path+ let myenv = [("HOME",cwd)+ ,("DARCS_TESTING_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++"'"+ set_prefs+ 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+ set_prefs = do+ finally (catch (appendFile ".darcs/defaults" "ALL --ignore-times")+ (\e -> fail $ "Unable to set preferences: "+ ++ show e))+ (createDirectoryIfMissing False ".darcs")+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 ++ " ..." ++ (replicate (36 - (length 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)+ let tempfiles = (filter ("temp" `isPrefixOf`) dirfiles) +++ (filter ("tmp" `isPrefixOf`) dirfiles)+ mapM_ (\x-> + setPermissions x (Permissions + {readable = True+ ,writable = True+ ,executable = False+ ,searchable = True}+ )+ ) tempfiles++backtick :: String -> String -> [(String, String)]-> IO (String,Bool)+backtick cmd args env = do+ (exitcode,res) <- backtick_helper cmd args env+ case exitcode of+ ExitSuccess -> return (res, True)+ ExitFailure code -> return (res, False)++backtick_helper :: String -> String -> [(String,String)] ->+ IO (ExitCode, String)+backtick_helper cmd args env = process_wrapper (runInteractiveProcess+ cmd [args] Nothing+ (Just env)+ ) ""++find_bash =+ do sh <- findExecutable "bash"+ case sh of+ Just p -> return p+ Nothing -> error "Could not find bash in PATH"++-- | Run a process with a list of arguments and return anything from+-- /stderr/ or /stdout/+process_wrapper :: IO (Handle, Handle, Handle, ProcessHandle) ->+ String -> IO (ExitCode, String)+process_wrapper f _ = do+ (_,o,e,pid) <- f+ hSetBuffering o LineBuffering+ hSetBuffering e LineBuffering+ ch <- newChan+ -- WARNING: beware of hokeyness ahead!+ let readWrite i = do x <- hGetLine i+ writeChan ch $ Just x+ readWrite i+ `catch` \_ -> writeChan ch Nothing+ readEO = do x <- readChan ch+ case x of+ Just l -> do y <- readEO+ return $ l:y+ Nothing -> readEO'+ readEO' = do x <- readChan ch+ case x of+ Just l -> do y <- readEO'+ return $ l:y+ Nothing -> return []+ forkIO $ readWrite o+ forkIO $ readWrite e+ outerr <- readEO+ ec <- waitForProcessNonBlocking pid+ threadDelay 1000+ case ec of+ ExitFailure 127 -> fail $ "timeout running command\n\n"+ ++unlines outerr+ _ -> return (ec, unlines outerr)++--+-- waitForProcess uses a very hokey heuristic to try to avoid burning too+-- much CPU time in a busy wait, while also not adding too much extra+-- latency.++waitForProcessNonBlocking :: ProcessHandle -> IO ExitCode+waitForProcessNonBlocking = if rtsSupportsBoundThreads+ then waitForProcess+ else wfp 0+ where wfp n pid = do mec <- getProcessExitCode pid+ case mec of+ Just ec -> return ec+ Nothing -> do threadDelay n+ wfp (min 100000 (n+1+n`div`4)) pid++++set_env :: [(String,String)] -> [(String,String)] -> [(String, String)]+set_env es env = nubBy (\(x,_) (y,_) -> x == y) (es ++ env)
darcs.cabal view
@@ -1,5 +1,5 @@ Name: darcs-version: 2.1.2.1+version: 2.1.2.2 License: GPL License-file: COPYING Author: David Roundy <droundy@darcs.net>, <darcs-users@darcs.net>@@ -62,6 +62,7 @@ release/distributed-version, release/distributed-context -- testsuite+ Distribution/ShellHarness.hs tests/repos/*.tgz tests/repos/README tests/*.sh tests/network/*.sh