shelltestrunner 0.7 → 0.8
raw patch · 3 files changed
+472/−378 lines, 3 filesdep +FileManipCompatdep +directorydep +filepathnew-component:exe:shelltest
Dependencies added: FileManipCompat, directory, filepath
Files
- shelltest.hs +427/−0
- shelltestrunner.cabal +45/−39
- shelltestrunner.hs +0/−339
+ shelltest.hs view
@@ -0,0 +1,427 @@+#!/usr/bin/env runhaskell+{-# LANGUAGE DeriveDataTypeable #-}+{-++shelltest - a tool for testing command-line programs.++See shelltestrunner.cabal.++(c) Simon Michael 2009-2010, released under GNU GPLv3++-}++module Main+where+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Monad (liftM,when,unless)+import Data.List (intercalate, nub, isPrefixOf)+import Data.Maybe (isNothing,isJust,fromJust,maybe,catMaybes)+import qualified Test.HUnit (Test)+import System.Console.CmdArgs hiding (args)+import qualified System.Console.CmdArgs as CmdArgs (args)+import System.Exit (ExitCode(..), exitWith)+import System.IO (Handle, hGetContents, hPutStr)+import System.Process (StdStream (CreatePipe), shell, createProcess, CreateProcess (..), waitForProcess, ProcessHandle)+import Test.Framework (defaultMainWithArgs)+import Test.Framework.Providers.HUnit (hUnitTestToTests)+import Test.HUnit hiding (Test)+import Text.ParserCombinators.Parsec+import Text.Printf (printf)+import Text.Regex.PCRE.Light.Char8+import Debug.Trace+import System.Directory (doesDirectoryExist)+import System.FilePath (takeDirectory)+import System.FilePath.FindCompat (findWithHandler, (==?), always)+import qualified System.FilePath.FindCompat as Find (extension)+import Control.Applicative ((<$>))+strace :: Show a => a -> a+strace a = trace (show a) a+++version = "0.8" -- keep synced with shelltestrunner.cabal+progname = "shelltest"+progversion = progname ++ " " ++ version+version, progname, progversion :: String++data Args = Args {+ debug :: Bool+ ,debugparse :: Bool+ ,execdir :: Bool+ ,extension :: String+ ,implicit :: String+ ,with :: String+ ,testpaths :: [FilePath]+ ,otheropts :: [String]+ } deriving (Show, Data, Typeable)+++nullargs :: Args+nullargs = Args False False False "" "" "" [] []++argmodes :: [Mode Args]+argmodes = [+ mode (Args{+ debug = def &= text "show debug messages"+ ,debugparse = def &= flag "debug-parse" & explicit & text "show parsing debug messages and stop"+ ,execdir = def &= text "run tests in same directory as test file"+ ,extension = ".test" &= typ "EXT" & text "extension of test files when dirs specified"+ ,implicit = "exit" &= typ "none|exit|all" & text "provide implicit tests"+ ,with = def &= typ "EXECUTABLE" & text "alternate executable, replaces the first word of test commands"+ ,testpaths = def &= CmdArgs.args & typ "TESTFILES|TESTDIRS" & text "test files or directories"+ ,otheropts = def &= unknownFlags & explicit & typ "OTHER FLAGS" & text "any other flags are passed to test runner"+ }) &= helpSuffix [+ "A test file contains one or more shell tests, which look like this:"+ ,""+ ," # optional comment lines"+ ," a one-line shell command to be tested"+ ," <<<"+ ," stdin lines"+ ," >>> [/regexp to match in stdout/]"+ ," [or expected stdout lines"+ ," >>>2 [/regexp to match in stderr/]"+ ," [or expected stderr lines]"+ ," >>>= expected exit status or /regexp/"+ ,""+ ,"The command line is required; all other fields are optional."+ ,"The expected stdout (>>>) and expected stderr (>>>2) fields can have either"+ ,"a regular expression match pattern, in which case the test passes if the"+ ,"output is matched, or 0 or more data lines, in which case the output"+ ,"must match these exactly. The expected exit status (>>>=) field can have"+ ,"either a numeric exit code or a /regexp/. A ! preceding a /regexp/ or exit"+ ,"code negates the match. The regular expression syntax is that of the"+ ,"pcre-light library with the dotall flag."+ ,""+ ,"By default there is an implicit test for exit status=0, but no implicit test"+ ,"for stdout or stderr. You can change this with -i/--implicit-tests."+ ,""+ ,"The command runs in your current directory unless you use --execdir."+ ,"You can use --with/-w to replace the first word of command lines"+ ,"(everything up to the first space) with something else, eg to test a"+ ,"different version of your program. To prevent this, start the command line"+ ,"with a space."+ ,""+ ,"Any unrecognised options will be passed through to test-framework's runner."+ ,"You may be able to get a big speedup by running tests in parallel: try -j8."+ ]+ ]++checkArgs :: Args -> IO Args+checkArgs args = do+ when (not $ i `elem` ["none","exit","all"]) $+ warn $ printf "Bad -i/--implicit value %s, valid choices are: none, exit or all" $ show i+ when (null ps) $+ warn $ printf "Please specify at least one file or directory, eg: %s ." progname+ return args+ where+ i = implicit args+ ps = testpaths args++-- | Show a message, usage string, and terminate with exit status 1.+warn :: String -> IO ()+warn s = cmdArgsHelp s argmodes Text >>= putStrLn >> exitWith (ExitFailure 1)++data ShellTest = ShellTest {+ testname :: String+ ,command :: TestCommand+ ,stdin :: Maybe String+ ,stdoutExpected :: Maybe Matcher+ ,stderrExpected :: Maybe Matcher+ ,exitCodeExpected :: Maybe Matcher+ }++data TestCommand = ReplaceableCommand String+ | FixedCommand String++instance Show TestCommand where+ show (ReplaceableCommand s) = s+ show (FixedCommand s) = " " ++ s++type Regexp = String++data Matcher = Lines String+ | Numeric String+ | NegativeNumeric String+ | PositiveRegex Regexp+ | NegativeRegex Regexp++main :: IO ()+main = do+ args <- cmdArgs progversion argmodes >>= checkArgs+ when (debug args) $ printf "args: %s\n" (show args)+ let paths = testpaths args+ testfiles <- nub . concat <$> mapM (\p -> do+ isdir <- doesDirectoryExist p+ if isdir+ then findWithHandler (\_ e->fail (show e)) always (Find.extension ==? extension args) p+ else return [p]) paths+ loud <- isLoud+ when loud $ do+ printf "executable: %s\n" (with args)+ printf "test files: %s\n" (intercalate ", " $ testfiles)+ parseresults <- mapM (parseShellTestFile args) testfiles + unless (debugparse args) $+ defaultMainWithArgs (concatMap (hUnitTestToTests.testFileParseToHUnitTest args) parseresults) (otheropts args)++-- parsing++parseShellTestFile :: Args -> FilePath -> IO (Either ParseError [ShellTest])+parseShellTestFile args f = do+ p <- parseFromFile shelltestfilep f+ case p of+ Right ts -> do+ let ts' | length ts > 1 = [t{testname=testname t++":"++show n} | (n,t) <- zip ([1..]::[Int]) ts]+ | otherwise = ts+ when (debug args || debugparse args) $ do+ printf "parsed %s:\n" f+ mapM_ (putStrLn.(' ':).show) ts'+ return $ Right ts'+ Left _ -> return p++shelltestfilep :: Parser [ShellTest]+shelltestfilep = do+ ts <- many (try shelltestp)+ many commentlinep+ eof+ return ts++shelltestp :: Parser ShellTest+shelltestp = do+ st <- getParserState+ let f = sourceName $ statePos st+ many $ try commentlinep+ c <- commandp <?> "command line"+ i <- optionMaybe inputp <?> "input"+ o <- optionMaybe expectedoutputp <?> "expected output"+ e <- optionMaybe expectederrorp <?> "expected error output"+ x <- optionMaybe expectedexitcodep <?> "expected exit status"+ when (null (show c) && (isNothing i) && (null $ catMaybes [o,e,x])) $ fail ""+ return $ ShellTest{testname=f,command=c,stdin=i,stdoutExpected=o,stderrExpected=e,exitCodeExpected=x}++newlineoreofp, whitespacecharp :: Parser Char+linep,lineoreofp,whitespacep,whitespacelinep,commentlinep,whitespaceorcommentlinep,whitespaceorcommentlineoreofp,delimiterp,inputp :: Parser String+linep = (anyChar `manyTill` newline) <?> "rest of line"+newlineoreofp = newline <|> (eof >> return '\n') <?> "newline or end of file"+lineoreofp = (anyChar `manyTill` newlineoreofp)+whitespacecharp = oneOf " \t"+whitespacep = many whitespacecharp+whitespacelinep = try (newline >> return "") <|> (whitespacecharp >> whitespacecharp `manyTill` newlineoreofp)+commentlinep = whitespacep >> char '#' >> lineoreofp <?> "comments"+whitespaceorcommentlinep = choice [try commentlinep, whitespacelinep]+whitespaceorcommentlineoreofp = choice [(eof >> return ""), try commentlinep, whitespacelinep]+delimiterp = choice [try $ string "<<<", try $ string ">>>", try commentlinep >> return "", eof >> return ""]++commandp,fixedcommandp,replaceablecommandp :: Parser TestCommand+commandp = fixedcommandp <|> replaceablecommandp+fixedcommandp = space >> linep >>= return . FixedCommand+replaceablecommandp = linep >>= return . ReplaceableCommand++inputp = string "<<<" >> whitespaceorcommentlinep >> (liftM unlines) (linep `manyTill` (lookAhead delimiterp))++expectedoutputp :: Parser Matcher+expectedoutputp = (try $ do+ string ">>>" >> optional (char '1')+ whitespacep+ choice [positiveregexmatcherp, negativeregexmatcherp, whitespaceorcommentlineoreofp >> linesmatcherp]+ ) <?> "expected output"++expectederrorp :: Parser Matcher+expectederrorp = (try $ do+ string ">>>2"+ whitespacep+ choice [positiveregexmatcherp, negativeregexmatcherp, (whitespaceorcommentlineoreofp >> linesmatcherp)]+ ) <?> "expected error output"++expectedexitcodep :: Parser Matcher+expectedexitcodep = (try $ do+ string ">>>="+ whitespacep+ choice [positiveregexmatcherp, try negativeregexmatcherp, numericmatcherp, negativenumericmatcherp]+ ) <?> "expected exit status"++linesmatcherp :: Parser Matcher+linesmatcherp = do+ (liftM $ Lines . unlines) (linep `manyTill` (lookAhead delimiterp)) <?> "lines of output"++negativeregexmatcherp :: Parser Matcher+negativeregexmatcherp = (do+ char '!'+ PositiveRegex r <- positiveregexmatcherp+ return $ NegativeRegex r) <?> "non-matched regexp pattern"++positiveregexmatcherp :: Parser Matcher+positiveregexmatcherp = (do+ char '/'+ r <- (try escapedslashp <|> noneOf "/") `manyTill` (char '/')+ whitespaceorcommentlineoreofp+ return $ PositiveRegex r) <?> "regexp pattern"++negativenumericmatcherp :: Parser Matcher+negativenumericmatcherp = (do+ char '!'+ Numeric s <- numericmatcherp+ return $ NegativeNumeric s+ ) <?> "non-matched number"++numericmatcherp :: Parser Matcher+numericmatcherp = (do+ s <- many1 $ oneOf "0123456789"+ whitespaceorcommentlineoreofp+ return $ Numeric s+ ) <?> "number"++escapedslashp :: Parser Char+escapedslashp = char '\\' >> char '/'++-- running++testFileParseToHUnitTest :: Args -> Either ParseError [ShellTest] -> Test.HUnit.Test+testFileParseToHUnitTest args (Right ts) = TestList $ map (shellTestToHUnitTest args) ts+testFileParseToHUnitTest _ (Left e) = ("parse error in " ++ (sourceName $ errorPos e)) ~: assertFailure $ show e++shellTestToHUnitTest :: Args -> ShellTest -> Test.HUnit.Test+shellTestToHUnitTest args ShellTest{testname=n,command=c,stdin=i,stdoutExpected=o_expected,+ stderrExpected=e_expected,exitCodeExpected=x_expected} = + n ~: do+ let e = with args+ cmd = case (e,c) of (_:_, ReplaceableCommand s) -> e ++ " " ++ dropWhile (/=' ') s+ _ -> show c+ (o_expected',e_expected',x_expected') =+ case (implicit args) of+ "all" -> (case o_expected of+ Just m -> Just m+ _ -> Just $ Lines ""+ ,case e_expected of Just m -> Just m+ _ -> Just $ Lines ""+ ,case x_expected of Just m -> Just m+ _ -> Just $ Numeric "0")+ "exit" -> (o_expected,e_expected+ ,case x_expected of Just m -> Just m+ _ -> Just $ Numeric "0")+ _ -> (o_expected,e_expected,x_expected)+ dir = if execdir args then Just $ takeDirectory n else Nothing+ when (debug args) $ printf "command: %s\n" (show cmd)+ (o_actual, e_actual, x_actual) <- runCommandWithInput dir cmd i+ when (debug args) $ do+ printf "stdout: %s\n" (show $ trim o_actual)+ printf "stderr: %s\n" (show $ trim e_actual)+ printf "exit: %s\n" (show $ trim $ show x_actual)+ if (x_actual == 127) -- catch bad executable - should work on posix systems at least+ then ioError $ userError e_actual -- XXX still a test failure; should be an error+ else assertString $ addnewline $ intercalate "\n" $ filter (not . null) [+ if (maybe True (o_actual `matches`) o_expected')+ then ""+ else showExpectedActual "stdout" (fromJust o_expected') o_actual+ ,if (maybe True (e_actual `matches`) e_expected')+ then ""+ else showExpectedActual "stderr" (fromJust e_expected') e_actual+ ,if (maybe True (show x_actual `matches`) x_expected')+ then ""+ else showExpectedActual "exit code" (fromJust x_expected') (show x_actual)+ ]+ where addnewline "" = ""+ addnewline s = "\n"++s++-- | Run a shell command line, passing it standard input if provided,+-- and return the standard output, standard error output and exit code.+runCommandWithInput :: Maybe FilePath -> String -> Maybe String -> IO (String, String, Int)+runCommandWithInput wd cmd input = do+ -- this has to be done carefully+ (ih,oh,eh,ph) <- runInteractiveCommandInDir wd cmd + when (isJust input) $ forkIO (hPutStr ih $ fromJust input) >> return ()+ o <- newEmptyMVar+ e <- newEmptyMVar+ forkIO $ oh `hGetContentsStrictlyAnd` putMVar o+ forkIO $ eh `hGetContentsStrictlyAnd` putMVar e+ x_actual <- waitForProcess ph >>= return.fromExitCode+ o_actual <- takeMVar o+ e_actual <- takeMVar e+ return (o_actual, e_actual, x_actual)++runInteractiveCommandInDir :: Maybe FilePath -> String -> IO (Handle, Handle, Handle, ProcessHandle)+runInteractiveCommandInDir wd cmd = do+ (mb_in, mb_out, mb_err, p) <- + createProcess $ + (shell cmd) { cwd = wd+ , std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe }+ return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p)++hGetContentsStrictlyAnd :: Handle -> (String -> IO b) -> IO b+hGetContentsStrictlyAnd h f = hGetContents h >>= \s -> length s `seq` f s++matches :: String -> Matcher -> Bool+matches s (PositiveRegex r) = s `containsRegex` r+matches s (NegativeRegex r) = not $ s `containsRegex` r+matches s (Numeric p) = s == p+matches s (NegativeNumeric p) = not $ s == p+matches s (Lines p) = s == p++showExpectedActual :: String -> Matcher -> String -> String+showExpectedActual field e a =+ printf "**Expected %s: %s\n**Got %s: %s" field (show e) field (show $ trim a)++instance Show Matcher where+ show (PositiveRegex r) = "/"++(trim r)++"/"+ show (NegativeRegex r) = "!/"++(trim r)++"/"+ show (Numeric s) = show $ trim s+ show (NegativeNumeric s) = "!"++ show (trim s)+ show (Lines s) = show $ trim s++instance Show ShellTest where+ show ShellTest{testname=n,command=c,stdin=i,stdoutExpected=o,stderrExpected=e,exitCodeExpected=x} =+ printf "ShellTest {testname = %s, command = %s, stdin = %s, stdoutExpected = %s, stderrExpected = %s, exitCodeExpected = %s}"+ (show $ trim n)+ (show c)+ (maybe "Nothing" (show.trim) i)+ (show o)+ (show e)+ (show x)+++-- utils++trim :: String -> String+trim s | l <= limit = s+ | otherwise = take limit s ++ suffix+ where+ limit = 500+ l = length s+ suffix = printf "...(%d more)" (l-limit)++-- toExitCode :: Int -> ExitCode+-- toExitCode 0 = ExitSuccess+-- toExitCode n = ExitFailure n++fromExitCode :: ExitCode -> Int+fromExitCode ExitSuccess = 0+fromExitCode (ExitFailure n) = n++strip,lstrip,rstrip,dropws :: String -> String+strip = lstrip . rstrip+lstrip = dropws+rstrip = reverse . dropws . reverse+dropws = dropWhile (`elem` " \t")++-- | Does string contain this regular expression ?+-- A malformed regexp will cause a runtime error.+containsRegex :: String -> String -> Bool+containsRegex s r =+ case compileM r [+ dotall+ -- ,utf8 -- shows no obvious benefit with 6.10, review situation with 6.12+ ] of+ Right regex -> isJust $ match regex s []+ Left e -> error $ printf "bad regexp, %s: %s" e (trim $ r)++-- | Replace occurrences of old list with new list within a larger list.+replace::(Eq a) => [a] -> [a] -> [a] -> [a]+replace [] _ = id+replace old new = replace'+ where+ replace' [] = []+ replace' l@(h:ts) = if old `isPrefixOf` l+ then new ++ replace' (drop len l)+ else h : replace' ts+ len = length old
shelltestrunner.cabal view
@@ -1,5 +1,5 @@ name: shelltestrunner-version: 0.7+version: 0.8 category: Testing synopsis: A tool for testing command-line programs. description:@@ -12,7 +12,8 @@ . Usage: .- > shelltestrunner [FLAGS] EXECUTABLE [TESTFILES ...]+ > shelltest [FLAG] [TESTFILES|TESTDIRS]+ > > > -? --help[=FORMAT] Show usage information (optional format) > -V --version Show version information@@ -20,42 +21,44 @@ > -q --quiet Lower verbosity > -d --debug show debug messages > --debug-parse show parsing debug messages and stop+ > --execdir run tests in same directory as test file+ > --extension=EXT extension of test files when dirs specified (default=.test) > -i --implicit=none|exit|all provide implicit tests (default=exit)- .- Any unrecognised options will be passed through to test-framework's runner.- You may be able to get a big speedup by running tests in parallel: try -j16.- .- A test file contains one or more shell tests, each of which looks like this:- .- > # optional comment lines beginning with #- > -opt1 -opt2 arg1 arg2 # one line of command line args, executable will be prepended- > <<<- > 0 or more lines of input- > >>> [/regexp/] [optional comment beginning with #]- > [..or 0 or more lines of expected output]- > >>>2 [/regexp/] [optional comment]- > [..or 0 or more lines of expected error output]- > >>>= [expected exit status or /regexp/] [optional comment]- > # optional comment lines- .- The expected output and expected error output fields can have either a- regular expression match expression, in which case the test passes if the- output is matched, or 0 or more following data lines, in which case the- output must match these exactly. The expected exit status field can have- either a numeric exit code or a regular expression match expression. A !- preceding a an exit code or \/regexp\/ negates the match. The regular- expression syntax is that of the pcre-light library with the dotall flag.- .- The command line args field is required, all others are optional. By- default there is an implicit test for exit status = 0, but no implicit- test for stdout or stderr. You can change this with the- -i/--implicit-tests flag.- .- Some issues to be aware of:- .- - uncompiled haskell scripts can't be tested due to http://hackage.haskell.org/trac/ghc/ticket/3890- .- - unparseable test files and uncompilable regexps are counted as test failures+ > -w --with=EXECUTABLE alternate executable, replaces the first word of test commands+ > =OTHER FLAGS any other flags are passed to test runner+ >+ > A test file contains one or more shell tests, which look like this:+ > + > # optional comment lines+ > a one-line shell command to be tested+ > <<<+ > stdin lines+ > >>> [/regexp to match in stdout/]+ > [or expected stdout lines+ > >>>2 [/regexp to match in stderr/]+ > [or expected stderr lines]+ > >>>= expected exit status or /regexp/+ > + > The command line is required; all other fields are optional.+ > The expected stdout (>>>) and expected stderr (>>>2) fields can have either+ > a regular expression match pattern, in which case the test passes if the+ > output is matched, or 0 or more data lines, in which case the output+ > must match these exactly. The expected exit status (>>>=) field can have+ > either a numeric exit code or a /regexp/. A ! preceding a /regexp/ or exit+ > code negates the match. The regular expression syntax is that of the+ > pcre-light library with the dotall flag.+ > + > By default there is an implicit test for exit status=0, but no implicit test+ > for stdout or stderr. You can change this with -i/--implicit-tests.+ > + > The command runs in your current directory unless you use --execdir.+ > You can use --with/-w to replace the first word of command lines+ > (everything up to the first space) with something else, eg to test a+ > different version of your program. To prevent this, start the command line+ > with a space.+ > + > Any unrecognised options will be passed through to test-framework's runner.+ > You may be able to get a big speedup by running tests in parallel: try -j8. . license: GPL license-file: LICENSE@@ -71,8 +74,8 @@ extra-tmp-files: extra-source-files: -executable shelltestrunner- main-is: shelltestrunner.hs+executable shelltest+ main-is: shelltest.hs ghc-options: -Wall -threaded build-depends: base >= 3 && < 5@@ -83,6 +86,9 @@ ,test-framework-hunit >= 0.2 ,cmdargs >= 0.1 ,pcre-light >= 0.3.1+ ,directory+ ,filepath+ ,FileManipCompat source-repository head type: darcs
− shelltestrunner.hs
@@ -1,339 +0,0 @@-#!/usr/bin/env runhaskell-{-# LANGUAGE DeriveDataTypeable #-}-{---shelltestrunner - a tool for testing command-line programs.--See shelltestrunner.cabal.--(c) Simon Michael 2009, released under GNU GPLv3---}--module Main-where-import Control.Concurrent (forkIO)-import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Control.Monad (liftM,when,unless)-import Data.List (intercalate)-import Data.Maybe (isNothing,isJust,fromJust,maybe,catMaybes)-import qualified Test.HUnit (Test)-import System.Console.CmdArgs hiding (args)-import qualified System.Console.CmdArgs as CmdArgs (args)-import System.Exit (ExitCode(..), exitWith)-import System.IO (Handle, hGetContents, hPutStr)-import System.Process (runInteractiveCommand, waitForProcess)-import Test.Framework (defaultMainWithArgs)-import Test.Framework.Providers.HUnit (hUnitTestToTests)-import Test.HUnit hiding (Test)-import Text.ParserCombinators.Parsec-import Text.Printf (printf)-import Text.Regex.PCRE.Light.Char8-import Debug.Trace-strace :: Show a => a -> a-strace a = trace (show a) a---version = "0.6.98" -- keep synced with shelltestrunner.cabal-progname = "shelltestrunner"-progversion = progname ++ " " ++ version-version, progname, progversion :: String--data Args = Args {- debug :: Bool- ,debugparse :: Bool- ,implicit :: String- ,executable :: String- ,testfiles :: [String]- ,otheropts :: [String]- } deriving (Show, Data, Typeable)--nullargs :: Args-nullargs = Args False False "" "" [] []--argmodes :: [Mode Args]-argmodes = [- mode $ Args{- debug = def &= flag "debug" & text "show debug messages"- ,debugparse = def &= flag "debug-parse" & explicit & text "show parsing debug messages and stop"- ,implicit = "exit" &= typ "none|exit|all" & text "provide implicit tests"- ,executable = def &= argPos 0 & typ "EXECUTABLE" & text "executable under test"- ,testfiles = def &= CmdArgs.args & typ "TESTFILES" & text "test files"- ,otheropts = def &= unknownFlags & explicit & typ "FLAGS" & text "other flags are passed to test runner"- }- ]--checkArgs :: Args -> IO Args-checkArgs args = do- when (not $ i `elem` ["none","exit","all"]) $- warn $ printf "Bad -i/--implicit value %s, valid choices are: none, exit or all" $ show i- return args- where- i = implicit args- warn s = cmdArgsHelp s argmodes Text >>= putStrLn >> exitWith (ExitFailure 1)--data ShellTest = ShellTest {- testname :: String- ,commandargs :: String- ,stdin :: Maybe String- ,stdoutExpected :: Maybe Matcher- ,stderrExpected :: Maybe Matcher- ,exitCodeExpected :: Maybe Matcher- }--type Regexp = String--data Matcher = Lines String- | Numeric String- | NegativeNumeric String- | PositiveRegex Regexp- | NegativeRegex Regexp--main :: IO ()-main = do- args <- cmdArgs progversion argmodes >>= checkArgs- when (debug args) $ printf "args: %s\n" (show args)- loud <- isLoud- when loud $ do- printf "executable: %s\n" (executable args)- printf "test files: %s\n" (intercalate ", " $ testfiles args)- parseresults <- mapM (parseShellTestFile args) $ testfiles args- unless (debugparse args) $- defaultMainWithArgs (concatMap (hUnitTestToTests.testFileParseToHUnitTest args) parseresults) (otheropts args)---- parsing--parseShellTestFile :: Args -> FilePath -> IO (Either ParseError [ShellTest])-parseShellTestFile args f = do- p <- parseFromFile shelltestfilep f- case p of- Right ts -> do- let ts' | length ts > 1 = [t{testname=testname t++":"++show n} | (n,t) <- zip ([1..]::[Int]) ts]- | otherwise = ts- when (debug args || debugparse args) $ do- printf "parsed %s:\n" f- mapM_ (putStrLn.(' ':).show) ts'- return $ Right ts'- Left _ -> return p--shelltestfilep :: Parser [ShellTest]-shelltestfilep = do- ts <- many (try shelltestp)- many commentlinep- eof- return ts--shelltestp :: Parser ShellTest-shelltestp = do- st <- getParserState- let f = sourceName $ statePos st- many commentlinep- c <- commandargsp <?> "command arguments"- i <- optionMaybe inputp <?> "input"- o <- optionMaybe expectedoutputp <?> "expected output"- e <- optionMaybe expectederrorp <?> "expected error output"- x <- optionMaybe expectedexitcodep <?> "expected exit status"- when (null c && (isNothing i) && (null $ catMaybes [o,e,x])) $ fail ""- return $ ShellTest{testname=f,commandargs=c,stdin=i,stdoutExpected=o,stderrExpected=e,exitCodeExpected=x}--newlineoreofp, whitespacecharp :: Parser Char-linep,lineoreofp,whitespacep,whitespacelinep,commentlinep,whitespaceorcommentlinep,whitespaceorcommentlineoreofp,commandargsp,delimiterp,inputp :: Parser String-linep = (anyChar `manyTill` newline) <?> "rest of line"-newlineoreofp = newline <|> (eof >> return '\n') <?> "newline or end of file"-lineoreofp = (anyChar `manyTill` newlineoreofp)-whitespacecharp = oneOf " \t"-whitespacep = many whitespacecharp-whitespacelinep = try (newline >> return "") <|> (whitespacecharp >> whitespacecharp `manyTill` newlineoreofp)-commentlinep = whitespacep >> char '#' >> lineoreofp <?> "comments"-whitespaceorcommentlinep = choice [try commentlinep, whitespacelinep]-whitespaceorcommentlineoreofp = choice [(eof >> return ""), try commentlinep, whitespacelinep]-delimiterp = choice [try $ string "<<<", try $ string ">>>", try commentlinep >> return "", eof >> return ""]--commandargsp = linep--inputp = string "<<<" >> whitespaceorcommentlinep >> (liftM unlines) (linep `manyTill` (lookAhead delimiterp))--expectedoutputp :: Parser Matcher-expectedoutputp = (try $ do- string ">>>" >> optional (char '1')- whitespacep- choice [positiveregexmatcherp, negativeregexmatcherp, whitespaceorcommentlineoreofp >> linesmatcherp]- ) <?> "expected output"--expectederrorp :: Parser Matcher-expectederrorp = (try $ do- string ">>>2"- whitespacep- choice [positiveregexmatcherp, negativeregexmatcherp, (whitespaceorcommentlineoreofp >> linesmatcherp)]- ) <?> "expected error output"--expectedexitcodep :: Parser Matcher-expectedexitcodep = (try $ do- string ">>>="- whitespacep- choice [positiveregexmatcherp, try negativeregexmatcherp, numericmatcherp, negativenumericmatcherp]- ) <?> "expected exit status"--linesmatcherp :: Parser Matcher-linesmatcherp = do- (liftM $ Lines . unlines) (linep `manyTill` (lookAhead delimiterp)) <?> "lines of output"--negativeregexmatcherp :: Parser Matcher-negativeregexmatcherp = (do- char '!'- PositiveRegex r <- positiveregexmatcherp- return $ NegativeRegex r) <?> "non-matched regexp pattern"--positiveregexmatcherp :: Parser Matcher-positiveregexmatcherp = (do- char '/'- r <- (try escapedslashp <|> noneOf "/") `manyTill` (char '/')- whitespaceorcommentlineoreofp- return $ PositiveRegex r) <?> "regexp pattern"--negativenumericmatcherp :: Parser Matcher-negativenumericmatcherp = (do- char '!'- Numeric s <- numericmatcherp- return $ NegativeNumeric s- ) <?> "non-matched number"--numericmatcherp :: Parser Matcher-numericmatcherp = (do- s <- many1 $ oneOf "0123456789"- whitespaceorcommentlineoreofp- return $ Numeric s- ) <?> "number"--escapedslashp :: Parser Char-escapedslashp = char '\\' >> char '/'---- running--testFileParseToHUnitTest :: Args -> Either ParseError [ShellTest] -> Test.HUnit.Test-testFileParseToHUnitTest args (Right ts) = TestList $ map (shellTestToHUnitTest args) ts-testFileParseToHUnitTest _ (Left e) = ("parse error in " ++ (sourceName $ errorPos e)) ~: assertFailure $ show e--shellTestToHUnitTest :: Args -> ShellTest -> Test.HUnit.Test-shellTestToHUnitTest args ShellTest{testname=n,commandargs=c,stdin=i,stdoutExpected=o_expected,- stderrExpected=e_expected,exitCodeExpected=x_expected} = - n ~: do- let exe = executable args- cmd = unwords [exe,c]- (o_expected',e_expected',x_expected') =- case (implicit args) of- "all" -> (case o_expected of- Just m -> Just m- _ -> Just $ Lines ""- ,case e_expected of Just m -> Just m- _ -> Just $ Lines ""- ,case x_expected of Just m -> Just m- _ -> Just $ Numeric "0")- "exit" -> (o_expected,e_expected- ,case x_expected of Just m -> Just m- _ -> Just $ Numeric "0")- _ -> (o_expected,e_expected,x_expected)- when (debug args) $ printf "command: %s\n" (show cmd)- (o_actual, e_actual, x_actual) <- runCommandWithInput cmd i- when (debug args) $ do- printf "stdout: %s\n" (show $ trim o_actual)- printf "stderr: %s\n" (show $ trim e_actual)- printf "exit: %s\n" (show $ trim $ show x_actual)- if (x_actual == 127) -- catch bad executable - should work on posix systems at least- then ioError $ userError e_actual -- XXX still a test failure; should be an error- else assertString $ addnewline $ intercalate "\n" $ filter (not . null) [- if (maybe True (o_actual `matches`) o_expected')- then ""- else showExpectedActual "stdout" (fromJust o_expected') o_actual- ,if (maybe True (e_actual `matches`) e_expected')- then ""- else showExpectedActual "stderr" (fromJust e_expected') e_actual- ,if (maybe True (show x_actual `matches`) x_expected')- then ""- else showExpectedActual "exit code" (fromJust x_expected') (show x_actual)- ]- where addnewline "" = ""- addnewline s = "\n"++s---- | Run a shell command line, passing it standard input if provided,--- and return the standard output, standard error output and exit code.-runCommandWithInput :: String -> Maybe String -> IO (String, String, Int)-runCommandWithInput cmd input = do- -- this has to be done carefully- (ih,oh,eh,ph) <- runInteractiveCommand cmd- when (isJust input) $ forkIO (hPutStr ih $ fromJust input) >> return ()- o <- newEmptyMVar- e <- newEmptyMVar- forkIO $ oh `hGetContentsStrictlyAnd` putMVar o- forkIO $ eh `hGetContentsStrictlyAnd` putMVar e- x_actual <- waitForProcess ph >>= return.fromExitCode- o_actual <- takeMVar o- e_actual <- takeMVar e- return (o_actual, e_actual, x_actual)--hGetContentsStrictlyAnd :: Handle -> (String -> IO b) -> IO b-hGetContentsStrictlyAnd h f = hGetContents h >>= \s -> length s `seq` f s--matches :: String -> Matcher -> Bool-matches s (PositiveRegex r) = s `containsRegex` r-matches s (NegativeRegex r) = not $ s `containsRegex` r-matches s (Numeric p) = s == p-matches s (NegativeNumeric p) = not $ s == p-matches s (Lines p) = s == p--showExpectedActual :: String -> Matcher -> String -> String-showExpectedActual field e a =- printf "**Expected %s: %s\n**Got %s: %s" field (show e) field (show $ trim a)--instance Show Matcher where- show (PositiveRegex r) = "/"++(trim r)++"/"- show (NegativeRegex r) = "!/"++(trim r)++"/"- show (Numeric s) = show $ trim s- show (NegativeNumeric s) = "!"++ show (trim s)- show (Lines s) = show $ trim s--instance Show ShellTest where- show ShellTest{testname=n,commandargs=a,stdin=i,stdoutExpected=o,stderrExpected=e,exitCodeExpected=x} = - printf "ShellTest {testname = %s, commandargs = %s, stdin = %s, stdoutExpected = %s, stderrExpected = %s, exitCodeExpected = %s}"- (show $ trim n)- (show $ trim a)- (maybe "Nothing" (show.trim) i)- (show o)- (show e)- (show x)----- utils--trim :: String -> String-trim s | l <= limit = s- | otherwise = take limit s ++ suffix- where- limit = 500- l = length s- suffix = printf "...(%d more)" (l-limit)---- toExitCode :: Int -> ExitCode--- toExitCode 0 = ExitSuccess--- toExitCode n = ExitFailure n--fromExitCode :: ExitCode -> Int-fromExitCode ExitSuccess = 0-fromExitCode (ExitFailure n) = n--strip,lstrip,rstrip,dropws :: String -> String-strip = lstrip . rstrip-lstrip = dropws-rstrip = reverse . dropws . reverse-dropws = dropWhile (`elem` " \t")---- | Does string contain this regular expression ?--- A malformed regexp will cause a runtime error.-containsRegex :: String -> String -> Bool-containsRegex s r =- case compileM r [- dotall- -- ,utf8 -- shows no obvious benefit with 6.10, review situation with 6.12- ] of- Right regex -> isJust $ match regex s []- Left e -> error $ printf "bad regexp, %s: %s" e (trim $ r)