Test Suite in Cabal (cabal test)

Please run using "cabal test --show-details=streaming", there's a known
issue about this that was fixed in the latest version of cabal:
https://github.com/haskell/cabal/issues/1810
This commit is contained in:
Rodrigo Setti 2014-05-31 01:30:23 +00:00
parent 3fcc6c44d8
commit 0a9ed917e7
8 changed files with 141 additions and 192 deletions

View File

@ -3,17 +3,13 @@
GHCFLAGS=-O9 GHCFLAGS=-O9
GHCFLAGS_STATIC=$(GHCFLAGS) -optl-static -optl-pthread GHCFLAGS_STATIC=$(GHCFLAGS) -optl-static -optl-pthread
all: shellcheck .tests shellcheck.1 all: shellcheck shellcheck.1
: Done : Done
shellcheck: regardless shellcheck: regardless
: Conditionally compiling shellcheck : Conditionally compiling shellcheck
ghc $(GHCFLAGS) --make shellcheck ghc $(GHCFLAGS) --make shellcheck
.tests: *.hs */*.hs
: Running unit tests
./test/runQuack && touch .tests
shellcheck.1: shellcheck.1.md shellcheck.1: shellcheck.1.md
: Formatting man page : Formatting man page
pandoc -s -t man $< -o $@ pandoc -s -t man $< -o $@

View File

@ -35,7 +35,8 @@ library
json, json,
mtl, mtl,
parsec, parsec,
regex-compat regex-compat,
QuickCheck >= 2.2
exposed-modules: exposed-modules:
ShellCheck.Analytics ShellCheck.Analytics
ShellCheck.AST ShellCheck.AST
@ -54,6 +55,21 @@ executable shellcheck
json, json,
mtl, mtl,
parsec, parsec,
regex-compat regex-compat,
QuickCheck >= 2.2
main-is: shellcheck.hs main-is: shellcheck.hs
test-suite test-shellcheck
type: exitcode-stdio-1.0
build-depends:
ShellCheck,
base >= 4 && < 5,
containers,
directory,
json,
mtl,
parsec,
regex-compat,
QuickCheck >= 2.2
main-is: test/shellcheck.hs

View File

@ -15,7 +15,8 @@
You should have received a copy of the GNU Affero General Public License You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. along with this program. If not, see <http://www.gnu.org/licenses/>.
-} -}
module ShellCheck.Analytics (AnalysisOption(..), filterByAnnotation, runAnalytics, shellForExecutable) where {-# LANGUAGE TemplateHaskell #-}
module ShellCheck.Analytics (AnalysisOption(..), filterByAnnotation, runAnalytics, shellForExecutable, runTests) where
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State
@ -27,9 +28,10 @@ import Data.Maybe
import Debug.Trace import Debug.Trace
import ShellCheck.AST import ShellCheck.AST
import ShellCheck.Data import ShellCheck.Data
import ShellCheck.Parser import ShellCheck.Parser hiding (runTests)
import Text.Regex import Text.Regex
import qualified Data.Map as Map import qualified Data.Map as Map
import Test.QuickCheck.All (quickCheckAll)
data Shell = Ksh | Zsh | Sh | Bash data Shell = Ksh | Zsh | Sh | Bash
deriving (Show, Eq) deriving (Show, Eq)
@ -1979,15 +1981,15 @@ getVariableFlow shell parents t =
startScope t = startScope t =
let scopeType = leadType shell parents t let scopeType = leadType shell parents t
in do in do
when (scopeType /= NoneScope) $ modify ((StackScope scopeType):) when (scopeType /= NoneScope) $ modify (StackScope scopeType:)
if assignFirst t then setWritten t else return () when (assignFirst t) $ setWritten t
endScope t = endScope t =
let scopeType = leadType shell parents t let scopeType = leadType shell parents t
in do in do
setRead t setRead t
if assignFirst t then return () else setWritten t unless (assignFirst t) $ setWritten t
when (scopeType /= NoneScope) $ modify ((StackScopeEnd):) when (scopeType /= NoneScope) $ modify (StackScopeEnd:)
assignFirst (T_ForIn {}) = True assignFirst (T_ForIn {}) = True
assignFirst (T_SelectIn {}) = True assignFirst (T_SelectIn {}) = True
@ -1995,16 +1997,16 @@ getVariableFlow shell parents t =
setRead t = setRead t =
let read = getReferencedVariables t let read = getReferencedVariables t
in mapM_ (\v -> modify ((Reference v):)) read in mapM_ (\v -> modify (Reference v:)) read
setWritten t = setWritten t =
let written = getModifiedVariables t let written = getModifiedVariables t
in mapM_ (\v -> modify ((Assignment v):)) written in mapM_ (\v -> modify (Assignment v:)) written
findSubshelled [] _ _ = return () findSubshelled [] _ _ = return ()
findSubshelled ((Assignment x@(_, _, str, _)):rest) ((reason,scope):lol) deadVars = findSubshelled (Assignment x@(_, _, str, _):rest) ((reason,scope):lol) deadVars =
findSubshelled rest ((reason, x:scope):lol) $ Map.insert str Alive deadVars findSubshelled rest ((reason, x:scope):lol) $ Map.insert str Alive deadVars
findSubshelled ((Reference (_, readToken, str)):rest) scopes deadVars = do findSubshelled (Reference (_, readToken, str):rest) scopes deadVars = do
case Map.findWithDefault Alive str deadVars of case Map.findWithDefault Alive str deadVars of
Alive -> return () Alive -> return ()
Dead writeToken reason -> do Dead writeToken reason -> do
@ -2012,15 +2014,15 @@ findSubshelled ((Reference (_, readToken, str)):rest) scopes deadVars = do
info (getId readToken) 2031 $ str ++ " was modified in a subshell. That change might be lost." info (getId readToken) 2031 $ str ++ " was modified in a subshell. That change might be lost."
findSubshelled rest scopes deadVars findSubshelled rest scopes deadVars
findSubshelled ((StackScope (SubshellScope reason)):rest) scopes deadVars = findSubshelled (StackScope (SubshellScope reason):rest) scopes deadVars =
findSubshelled rest ((reason,[]):scopes) deadVars findSubshelled rest ((reason,[]):scopes) deadVars
findSubshelled ((StackScopeEnd):rest) ((reason, scope):oldScopes) deadVars = findSubshelled (StackScopeEnd:rest) ((reason, scope):oldScopes) deadVars =
findSubshelled rest oldScopes $ findSubshelled rest oldScopes $
foldl (\m (_, token, var, _) -> foldl (\m (_, token, var, _) ->
Map.insert var (Dead token reason) m) deadVars scope Map.insert var (Dead token reason) m) deadVars scope
doVariableFlowAnalysis readFunc writeFunc empty flow = fst $ runState ( doVariableFlowAnalysis readFunc writeFunc empty flow = evalState (
foldM (\list x -> do { l <- doFlow x; return $ l ++ list; }) [] flow foldM (\list x -> do { l <- doFlow x; return $ l ++ list; }) [] flow
) empty ) empty
where where
@ -2062,17 +2064,17 @@ checkSpacefulness params t =
map <- get map <- get
return $ Map.findWithDefault True name map return $ Map.findWithDefault True name map
setSpaces name bool = do setSpaces name bool =
modify $ Map.insert name bool modify $ Map.insert name bool
readF _ token name = do readF _ token name = do
spaced <- hasSpaces name spaced <- hasSpaces name
if spaced if spaced
&& (not $ "@" `isPrefixOf` name) -- There's another warning for this && not ("@" `isPrefixOf` name) -- There's another warning for this
&& (not $ isCounting token) && not (isCounting token)
&& (not $ isQuoteFree parents token) && not (isQuoteFree parents token)
&& (not $ usedAsCommandName parents token) && not (usedAsCommandName parents token)
then return [(Note (getId token) InfoC 2086 warning)] then return [Note (getId token) InfoC 2086 warning]
else return [] else return []
where where
warning = "Double quote to prevent globbing and word splitting." warning = "Double quote to prevent globbing and word splitting."
@ -2096,14 +2098,14 @@ checkSpacefulness params t =
isCounting _ = False isCounting _ = False
isSpacefulWord :: (String -> Bool) -> [Token] -> Bool isSpacefulWord :: (String -> Bool) -> [Token] -> Bool
isSpacefulWord f words = any (isSpaceful f) words isSpacefulWord f = any (isSpaceful f)
isSpaceful :: (String -> Bool) -> Token -> Bool isSpaceful :: (String -> Bool) -> Token -> Bool
isSpaceful spacefulF x = isSpaceful spacefulF x =
case x of case x of
T_DollarExpansion _ _ -> True T_DollarExpansion _ _ -> True
T_Backticked _ _ -> True T_Backticked _ _ -> True
T_Glob _ _ -> True T_Glob _ _ -> True
T_Extglob _ _ _ -> True T_Extglob {} -> True
T_Literal _ s -> s `containsAny` globspace T_Literal _ s -> s `containsAny` globspace
T_SingleQuoted _ s -> s `containsAny` globspace T_SingleQuoted _ s -> s `containsAny` globspace
T_DollarBraced _ l -> spacefulF $ getBracedReference $ bracedString l T_DollarBraced _ l -> spacefulF $ getBracedReference $ bracedString l
@ -2112,7 +2114,7 @@ checkSpacefulness params t =
_ -> False _ -> False
where where
globspace = "*? \t\n" globspace = "*? \t\n"
containsAny s chars = any (\c -> c `elem` s) chars containsAny s = any (\c -> c `elem` s)
prop_checkQuotesInLiterals1 = verifyTree checkQuotesInLiterals "param='--foo=\"bar\"'; app $param" prop_checkQuotesInLiterals1 = verifyTree checkQuotesInLiterals "param='--foo=\"bar\"'; app $param"
@ -2161,9 +2163,9 @@ checkQuotesInLiterals params t =
&& not (isParamTo parents "eval" expr) && not (isParamTo parents "eval" expr)
&& not (isQuoteFree parents expr) && not (isQuoteFree parents expr)
then return [ then return [
Note (fromJust assignment)WarningC 2089 $ Note (fromJust assignment)WarningC 2089
"Quotes/backslashes will be treated literally. Use an array.", "Quotes/backslashes will be treated literally. Use an array.",
Note (getId expr) WarningC 2090 $ Note (getId expr) WarningC 2090
"Quotes/backslashes in this variable will not be respected." "Quotes/backslashes in this variable will not be respected."
] ]
else return [] else return []
@ -2193,7 +2195,7 @@ checkFunctionsUsedExternally params t =
mapM_ (checkArg name) args mapM_ (checkArg name) args
checkCommand _ _ = return () checkCommand _ _ = return ()
analyse f t = snd $ runState (doAnalysis f t) [] analyse f t = execState (doAnalysis f t) []
functions = Map.fromList $ analyse findFunctions t functions = Map.fromList $ analyse findFunctions t
findFunctions (T_Function id _ _ name _) = modify ((name, id):) findFunctions (T_Function id _ _ name _) = modify ((name, id):)
findFunctions t@(T_SimpleCommand id _ (_:args)) findFunctions t@(T_SimpleCommand id _ (_:args))
@ -2207,7 +2209,7 @@ checkFunctionsUsedExternally params t =
case Map.lookup (concat $ deadSimple arg) functions of case Map.lookup (concat $ deadSimple arg) functions of
Nothing -> return () Nothing -> return ()
Just id -> do Just id -> do
warn (getId arg) 2033 $ warn (getId arg) 2033
"Shell functions can't be passed to external commands." "Shell functions can't be passed to external commands."
info id 2032 $ info id 2032 $
"Use own script or sh -c '..' to run this from " ++ cmd ++ "." "Use own script or sh -c '..' to run this from " ++ cmd ++ "."
@ -2246,7 +2248,7 @@ checkUnusedAssignments params t = snd $ runWriter (mapM_ checkAssignment flow)
name ++ " appears unused. Verify it or export it." name ++ " appears unused. Verify it or export it."
checkAssignment _ = return () checkAssignment _ = return ()
stripSuffix str = takeWhile isVariableChar str stripSuffix = takeWhile isVariableChar
defaultMap = Map.fromList $ zip internalVariables $ repeat () defaultMap = Map.fromList $ zip internalVariables $ repeat ()
prop_checkGlobsAsOptions1 = verify checkGlobsAsOptions "rm *.txt" prop_checkGlobsAsOptions1 = verify checkGlobsAsOptions "rm *.txt"
@ -2255,9 +2257,9 @@ prop_checkGlobsAsOptions3 = verifyNot checkGlobsAsOptions "rm -- *.txt"
checkGlobsAsOptions _ (T_SimpleCommand _ _ args) = checkGlobsAsOptions _ (T_SimpleCommand _ _ args) =
mapM_ check $ takeWhile (not . isEndOfArgs) args mapM_ check $ takeWhile (not . isEndOfArgs) args
where where
check v@(T_NormalWord _ ((T_Glob id s):_)) | s == "*" || s == "?" = check v@(T_NormalWord _ (T_Glob id s:_)) | s == "*" || s == "?" =
info id 2035 $ info id 2035 $
"Use ./" ++ (concat $ deadSimple v) "Use ./" ++ concat (deadSimple v)
++ " so names with dashes won't become options." ++ " so names with dashes won't become options."
check _ = return () check _ = return ()
@ -2279,7 +2281,7 @@ prop_checkWhileReadPitfalls5 = verifyNot checkWhileReadPitfalls "while read foo;
prop_checkWhileReadPitfalls6 = verifyNot checkWhileReadPitfalls "while read foo <&3; do ssh $foo; done 3< foo" prop_checkWhileReadPitfalls6 = verifyNot checkWhileReadPitfalls "while read foo <&3; do ssh $foo; done 3< foo"
checkWhileReadPitfalls _ (T_WhileExpression id [command] contents) checkWhileReadPitfalls _ (T_WhileExpression id [command] contents)
| isStdinReadCommand command = do | isStdinReadCommand command =
mapM_ checkMuncher contents mapM_ checkMuncher contents
where where
munchers = [ "ssh", "ffmpeg", "mplayer" ] munchers = [ "ssh", "ffmpeg", "mplayer" ]
@ -2291,7 +2293,7 @@ checkWhileReadPitfalls _ (T_WhileExpression id [command] contents)
&& all (not . stdinRedirect) redirs && all (not . stdinRedirect) redirs
isStdinReadCommand _ = False isStdinReadCommand _ = False
checkMuncher (T_Pipeline _ _ ((T_Redirecting _ redirs cmd):_)) = do checkMuncher (T_Pipeline _ _ (T_Redirecting _ redirs cmd:_)) = do
let name = fromMaybe "" $ getCommandBasename cmd let name = fromMaybe "" $ getCommandBasename cmd
when ((not . any stdinRedirect $ redirs) && (name `elem` munchers)) $ do when ((not . any stdinRedirect $ redirs) && (name `elem` munchers)) $ do
info id 2095 $ info id 2095 $
@ -2340,12 +2342,11 @@ checkCharRangeGlob p t@(T_Glob id str) |
&& contents /= ":" && contents /= ":"
then warn id 2101 "Named class needs outer [], e.g. [[:digit:]]." then warn id 2101 "Named class needs outer [], e.g. [[:digit:]]."
else else
if ('[' `notElem` contents) && hasDupes when ('[' `notElem` contents && hasDupes) $
then info id 2102 "Ranges can only match single chars (mentioned due to duplicates)." info id 2102 "Ranges can only match single chars (mentioned due to duplicates)."
else return ()
where where
isCharClass str = "[" `isPrefixOf` str && "]" `isSuffixOf` str isCharClass str = "[" `isPrefixOf` str && "]" `isSuffixOf` str
contents = drop 1 . take ((length str) - 1) $ str contents = drop 1 . take (length str - 1) $ str
hasDupes = any (>1) . map length . group . sort . filter (/= '-') $ contents hasDupes = any (>1) . map length . group . sort . filter (/= '-') $ contents
checkCharRangeGlob _ _ = return () checkCharRangeGlob _ _ = return ()
@ -2397,10 +2398,10 @@ checkLoopKeywordScope params t |
if not $ any isLoop path if not $ any isLoop path
then if any isFunction $ take 1 path then if any isFunction $ take 1 path
-- breaking at a source/function invocation is an abomination. Let's ignore it. -- breaking at a source/function invocation is an abomination. Let's ignore it.
then err (getId t) 2104 $ "In functions, use return instead of " ++ (fromJust name) ++ "." then err (getId t) 2104 $ "In functions, use return instead of " ++ fromJust name ++ "."
else err (getId t) 2105 $ (fromJust name) ++ " is only valid in loops." else err (getId t) 2105 $ (fromJust name) ++ " is only valid in loops."
else case map subshellType $ filter (not . isFunction) path of else case map subshellType $ filter (not . isFunction) path of
(Just str):_ -> warn (getId t) 2106 $ Just str:_ -> warn (getId t) 2106 $
"This only exits the subshell caused by the " ++ str ++ "." "This only exits the subshell caused by the " ++ str ++ "."
_ -> return () _ -> return ()
where where
@ -2409,7 +2410,7 @@ checkLoopKeywordScope params t |
subshellType t = case leadType (shellType params) (parentMap params) t of subshellType t = case leadType (shellType params) (parentMap params) t of
NoneScope -> Nothing NoneScope -> Nothing
SubshellScope str -> return str SubshellScope str -> return str
isFunction t = case t of T_Function _ _ _ _ _ -> True; _ -> False isFunction t = case t of T_Function {} -> True; _ -> False
relevant t = isLoop t || isFunction t || isJust (subshellType t) relevant t = isLoop t || isFunction t || isJust (subshellType t)
checkLoopKeywordScope _ _ = return () checkLoopKeywordScope _ _ = return ()
@ -2422,7 +2423,7 @@ checkFunctionDeclarations params
case (shellType params) of case (shellType params) of
Bash -> return () Bash -> return ()
Zsh -> return () Zsh -> return ()
Ksh -> do Ksh ->
when (hasKeyword && hasParens) $ when (hasKeyword && hasParens) $
err id 2111 "ksh does not allow 'function' keyword and '()' at the same time." err id 2111 "ksh does not allow 'function' keyword and '()' at the same time."
Sh -> do Sh -> do
@ -2444,7 +2445,7 @@ prop_checkCatastrophicRm7 = verifyNot checkCatastrophicRm "var=$(cmd); if [ -n \
prop_checkCatastrophicRm8 = verify checkCatastrophicRm "rm -rf /home" prop_checkCatastrophicRm8 = verify checkCatastrophicRm "rm -rf /home"
prop_checkCatastrophicRm9 = verifyNot checkCatastrophicRm "rm -rf -- /home" prop_checkCatastrophicRm9 = verifyNot checkCatastrophicRm "rm -rf -- /home"
checkCatastrophicRm params t@(T_SimpleCommand id _ tokens) | t `isCommand` "rm" = checkCatastrophicRm params t@(T_SimpleCommand id _ tokens) | t `isCommand` "rm" =
when (any isRecursiveFlag $ simpleArgs) $ when (any isRecursiveFlag simpleArgs) $
mapM_ checkWord tokens mapM_ checkWord tokens
where where
-- This ugly hack is based on the fact that ids generally increase -- This ugly hack is based on the fact that ids generally increase
@ -2456,8 +2457,8 @@ checkCatastrophicRm params t@(T_SimpleCommand id _ tokens) | t `isCommand` "rm"
checkWord token = checkWord token =
case getLiteralString token of case getLiteralString token of
Just str -> Just str ->
when (all (/= "--") simpleArgs && (fixPath str `elem` importantPaths)) $ when (notElem "--" simpleArgs && (fixPath str `elem` importantPaths)) $
info (getId token) 2114 $ "Obligatory typo warning. Use 'rm --' to disable this message." info (getId token) 2114 "Obligatory typo warning. Use 'rm --' to disable this message."
Nothing -> Nothing ->
checkWord' token checkWord' token
@ -2465,12 +2466,12 @@ checkCatastrophicRm params t@(T_SimpleCommand id _ tokens) | t `isCommand` "rm"
m <- relevantMap id m <- relevantMap id
filename <- combine m token filename <- combine m token
let path = fixPath filename let path = fixPath filename
return . when (path `elem` importantPaths) $ do return . when (path `elem` importantPaths) $
warn (getId token) 2115 $ "Make sure this never accidentally expands to '" ++ path ++ "'." warn (getId token) 2115 $ "Make sure this never accidentally expands to '" ++ path ++ "'."
fixPath filename = fixPath filename =
let normalized = skipRepeating '/' . skipRepeating '*' $ filename in let normalized = skipRepeating '/' . skipRepeating '*' $ filename in
if normalized == "/" then normalized else stripTrailing '/' $ normalized if normalized == "/" then normalized else stripTrailing '/' normalized
unnullable = all isVariableChar . concat . deadSimple unnullable = all isVariableChar . concat . deadSimple
isRecursiveFlag "--recursive" = True isRecursiveFlag "--recursive" = True
@ -2480,7 +2481,7 @@ checkCatastrophicRm params t@(T_SimpleCommand id _ tokens) | t `isCommand` "rm"
stripTrailing c = reverse . dropWhile (== c) . reverse stripTrailing c = reverse . dropWhile (== c) . reverse
skipRepeating c (a:b:rest) | a == b && b == c = skipRepeating c (b:rest) skipRepeating c (a:b:rest) | a == b && b == c = skipRepeating c (b:rest)
skipRepeating c (a:r) = a:(skipRepeating c r) skipRepeating c (a:r) = a:skipRepeating c r
skipRepeating _ [] = [] skipRepeating _ [] = []
addNulls map (Reference (_, token, name)) = addNulls map (Reference (_, token, name)) =
@ -2491,13 +2492,10 @@ checkCatastrophicRm params t@(T_SimpleCommand id _ tokens) | t `isCommand` "rm"
if mightBeGuarded token if mightBeGuarded token
then Map.insert name Nothing map then Map.insert name Nothing map
else Map.insert name (Just "") map else Map.insert name (Just "") map
addNulls m (Assignment (_, token, name, DataFrom [word])) = addNulls m (Assignment (_, token, name, DataFrom [word]))
if mightBeGuarded token | mightBeGuarded token = Map.insert name Nothing m
then Map.insert name Nothing m | couldFail word = m
else | otherwise = Map.insert name (combine m word) m
if couldFail word
then m
else Map.insert name ((combine m) word) m
addNulls m (Assignment (_, token, name, DataFrom _)) = addNulls m (Assignment (_, token, name, DataFrom _)) =
Map.insert name Nothing m Map.insert name Nothing m
addNulls map _ = map addNulls map _ = map
@ -2508,7 +2506,7 @@ checkCatastrophicRm params t@(T_SimpleCommand id _ tokens) | t `isCommand` "rm"
joinMaybes :: [Maybe String] -> Maybe String joinMaybes :: [Maybe String] -> Maybe String
joinMaybes = foldl (liftM2 (++)) (Just "") joinMaybes = foldl (liftM2 (++)) (Just "")
combine m token = c token combine m = c
where where
c (T_DollarBraced _ t) | unnullable t = c (T_DollarBraced _ t) | unnullable t =
Map.findWithDefault (Just "") (concat $ deadSimple t) m Map.findWithDefault (Just "") (concat $ deadSimple t) m
@ -2525,9 +2523,9 @@ checkCatastrophicRm params t@(T_SimpleCommand id _ tokens) | t `isCommand` "rm"
mightBeGuarded token = any t (getPath (parentMap params) token) mightBeGuarded token = any t (getPath (parentMap params) token)
where where
t (T_Condition _ _ _) = True t (T_Condition {}) = True
t (T_OrIf _ _ _) = True t (T_OrIf {}) = True
t (T_AndIf _ _ _) = True t (T_AndIf {}) = True
t _ = False t _ = False
paths = [ paths = [
@ -2684,20 +2682,17 @@ shellSupport t =
T_ProcSub _ "=" _ -> ("=(..) process substitution", [Zsh]) T_ProcSub _ "=" _ -> ("=(..) process substitution", [Zsh])
otherwise -> ("", [Bash, Ksh, Sh, Zsh]) otherwise -> ("", [Bash, Ksh, Sh, Zsh])
getCommandSequences t = getCommandSequences (T_Script _ _ cmds) = [cmds]
f t getCommandSequences (T_BraceGroup _ cmds) = [cmds]
where getCommandSequences (T_Subshell _ cmds) = [cmds]
f (T_Script _ _ cmds) = [cmds] getCommandSequences (T_WhileExpression _ _ cmds) = [cmds]
f (T_BraceGroup _ cmds) = [cmds] getCommandSequences (T_UntilExpression _ _ cmds) = [cmds]
f (T_Subshell _ cmds) = [cmds] getCommandSequences (T_ForIn _ _ _ _ cmds) = [cmds]
f (T_WhileExpression _ _ cmds) = [cmds] getCommandSequences (T_ForArithmetic _ _ _ _ cmds) = [cmds]
f (T_UntilExpression _ _ cmds) = [cmds] getCommandSequences (T_IfExpression _ thens elses) = elses:map snd thens
f (T_ForIn _ _ _ _ cmds) = [cmds] getCommandSequences _ = []
f (T_ForArithmetic _ _ _ _ cmds) = [cmds]
f (T_IfExpression _ thens elses) = elses:(map snd thens)
f _ = []
groupWith f l = groupBy (\x y -> f x == f y) l groupWith f = groupBy (\x y -> f x == f y)
prop_checkMultipleAppends1 = verify checkMultipleAppends "foo >> file; bar >> file; baz >> file;" prop_checkMultipleAppends1 = verify checkMultipleAppends "foo >> file; bar >> file; baz >> file;"
prop_checkMultipleAppends2 = verify checkMultipleAppends "foo >> file; bar | grep f >> file; baz >> file;" prop_checkMultipleAppends2 = verify checkMultipleAppends "foo >> file; bar | grep f >> file; baz >> file;"
@ -2715,7 +2710,7 @@ checkMultipleAppends params t =
checkGroup _ = return () checkGroup _ = return ()
getTarget (T_Pipeline _ _ args@(_:_)) = getTarget (last args) getTarget (T_Pipeline _ _ args@(_:_)) = getTarget (last args)
getTarget (T_Redirecting id list _) = do getTarget (T_Redirecting id list _) = do
file <- (mapMaybe getAppend list) !!! 0 file <- mapMaybe getAppend list !!! 0
return (file, id) return (file, id)
getTarget _ = Nothing getTarget _ = Nothing
getAppend (T_FdRedirect _ _ (T_IoFile _ (T_DGREAT {}) f)) = return f getAppend (T_FdRedirect _ _ (T_IoFile _ (T_DGREAT {}) f)) = return f
@ -2729,8 +2724,8 @@ checkAliasesExpandEarly params =
checkUnqualifiedCommand "alias" (const f) checkUnqualifiedCommand "alias" (const f)
where where
f = mapM_ checkArg f = mapM_ checkArg
checkArg arg | '=' `elem` (concat $ deadSimple arg) = checkArg arg | '=' `elem` concat (deadSimple arg) =
flip mapM_ (take 1 $ filter (not . isLiteral) $ getWordParts arg) $ forM_ (take 1 $ filter (not . isLiteral) $ getWordParts arg) $
\x -> warn (getId x) 2139 "This expands when defined, not when used. Consider escaping." \x -> warn (getId x) 2139 "This expands when defined, not when used. Consider escaping."
checkArg _ = return () checkArg _ = return ()
@ -2741,8 +2736,8 @@ checkSuspiciousIFS params (T_Assignment id Assign "IFS" Nothing value) =
str <- getLiteralString value str <- getLiteralString value
return $ check str return $ check str
where where
n = if (shellType params == Sh) then "'<literal linefeed here>'" else "$'\\n'" n = if shellType params == Sh then "'<literal linefeed here>'" else "$'\\n'"
t = if (shellType params == Sh) then "\"$(printf '\\t')\"" else "$'\\t'" t = if shellType params == Sh then "\"$(printf '\\t')\"" else "$'\\t'"
check value = check value =
case value of case value of
"\\n" -> suggest n "\\n" -> suggest n
@ -2808,3 +2803,7 @@ checkTestGlobs params (TC_Unary _ _ op token) | isGlob token =
err (getId token) 2144 $ err (getId token) 2144 $
op ++ " doesn't work with globs. Use a for loop." op ++ " doesn't work with globs. Use a for loop."
checkTestGlobs _ _ = return () checkTestGlobs _ _ = return ()
return []
runTests = $quickCheckAll

View File

@ -15,9 +15,8 @@
You should have received a copy of the GNU Affero General Public License You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. along with this program. If not, see <http://www.gnu.org/licenses/>.
-} -}
{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NoMonomorphismRestriction, TemplateHaskell #-}
module ShellCheck.Parser (Note(..), Severity(..), parseShell, ParseResult(..), ParseNote(..), sortNotes, noteToParseNote, runTests) where
module ShellCheck.Parser (Note(..), Severity(..), parseShell, ParseResult(..), ParseNote(..), sortNotes, noteToParseNote) where
import ShellCheck.AST import ShellCheck.AST
import ShellCheck.Data import ShellCheck.Data
@ -33,6 +32,7 @@ import Prelude hiding (readList)
import System.IO import System.IO
import Text.Parsec.Error import Text.Parsec.Error
import GHC.Exts (sortWith) import GHC.Exts (sortWith)
import Test.QuickCheck.All (quickCheckAll)
backslash = char '\\' backslash = char '\\'
linefeed = (optional carriageReturn) >> char '\n' linefeed = (optional carriageReturn) >> char '\n'
@ -2071,4 +2071,8 @@ parseShell filename contents = do
"The mentioned parser error was in this " ++ str ++ "." "The mentioned parser error was in this " ++ str ++ "."
lt x = trace (show x) x lt x = trace (show x) x
ltt t x = trace (show t) x ltt t = trace (show t)
return []
runTests = $quickCheckAll

View File

@ -15,30 +15,15 @@
You should have received a copy of the GNU Affero General Public License You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. along with this program. If not, see <http://www.gnu.org/licenses/>.
-} -}
module ShellCheck.Simple (shellCheck, ShellCheckComment, scLine, scColumn, scSeverity, scCode, scMessage) where {-# LANGUAGE TemplateHaskell #-}
module ShellCheck.Simple (shellCheck, ShellCheckComment, scLine, scColumn, scSeverity, scCode, scMessage, runTests) where
import ShellCheck.Parser import ShellCheck.Parser hiding (runTests)
import ShellCheck.Analytics import ShellCheck.Analytics hiding (runTests)
import Data.Maybe import Data.Maybe
import Text.Parsec.Pos import Text.Parsec.Pos
import Data.List import Data.List
import Test.QuickCheck.All (quickCheckAll)
prop_findsParseIssue =
let comments = shellCheck "echo \"$12\"" [] in
(length comments) == 1 && (scCode $ head comments) == 1037
prop_commentDisablesParseIssue1 =
null $ shellCheck "#shellcheck disable=SC1037\necho \"$12\"" []
prop_commentDisablesParseIssue2 =
null $ shellCheck "#shellcheck disable=SC1037\n#lol\necho \"$12\"" []
prop_findsAnalysisIssue =
let comments = shellCheck "echo $1" [] in
(length comments) == 1 && (scCode $ head comments) == 2086
prop_commentDisablesAnalysisIssue1 =
null $ shellCheck "#shellcheck disable=SC2086\necho $1" []
prop_commentDisablesAnalysisIssue2 =
null $ shellCheck "#shellcheck disable=SC2086\n#lol\necho $1" []
shellCheck :: String -> [AnalysisOption] -> [ShellCheckComment] shellCheck :: String -> [AnalysisOption] -> [ShellCheckComment]
shellCheck script options = shellCheck script options =
@ -65,3 +50,23 @@ severityToString s =
formatNote (ParseNote pos severity code text) = formatNote (ParseNote pos severity code text) =
ShellCheckComment (sourceLine pos) (sourceColumn pos) (severityToString severity) (fromIntegral code) text ShellCheckComment (sourceLine pos) (sourceColumn pos) (severityToString severity) (fromIntegral code) text
prop_findsParseIssue =
let comments = shellCheck "echo \"$12\"" [] in
length comments == 1 && scCode (head comments) == 1037
prop_commentDisablesParseIssue1 =
null $ shellCheck "#shellcheck disable=SC1037\necho \"$12\"" []
prop_commentDisablesParseIssue2 =
null $ shellCheck "#shellcheck disable=SC1037\n#lol\necho \"$12\"" []
prop_findsAnalysisIssue =
let comments = shellCheck "echo $1" [] in
length comments == 1 && scCode (head comments) == 2086
prop_commentDisablesAnalysisIssue1 =
null $ shellCheck "#shellcheck disable=SC2086\necho $1" []
prop_commentDisablesAnalysisIssue2 =
null $ shellCheck "#shellcheck disable=SC2086\n#lol\necho $1" []
return []
runTests = $quickCheckAll

View File

@ -1,65 +0,0 @@
#!/usr/bin/env runhaskell
-- #!/usr/bin/env runhugs
-- $Id: quickcheck,v 1.4 2003/01/08 15:09:22 shae Exp $
-- This file defines a command
-- quickCheck <options> <files>
-- which invokes quickCheck on all properties defined in the files given as
-- arguments, by generating an input script for hugs and then invoking it.
-- quickCheck recognises the options
-- +names print the name of each property before checking it
-- -names do not print property names (the default)
-- +verbose displays each test case before running
-- -verbose do not displays each test case before running (the default)
-- Other options (beginning with + or -) are passed unchanged to hugs.
--
-- Change the first line of this file to the location of runhaskell or runhugs
-- on your system.
-- Make the file executable.
--
-- TODO:
-- someone on #haskell asked about supporting QC tests inside LaTeX, ex. \{begin} \{end}, how?
import System.Cmd
import System.Directory (findExecutable)
import System.Environment
import Data.List
import Data.Maybe (fromJust)
main :: IO ()
main = do as<-getArgs
sequence_ (map (process (filter isOption as))
(filter (not.isOption) as))
-- ugly hack for .lhs files, is there a better way?
unlit [] = []
unlit x = if (head x) == '>' then (tail x) else x
process opts file =
let (namesOpt,opts') = getOption "names" "-names" opts
(verboseOpt,opts'') = getOption "verbose" "-verbose" opts' in
do xs<-readFile file
let names = nub$ filter (\x -> (("> prop_" `isPrefixOf` x) || ("prop_" `isPrefixOf` x)))
(map (fst.head.lex.unlit) (lines xs))
if null names then
putStr (file++": no properties to check\n")
else do writeFile "hugsin"$
unlines ((":load "++file):
":m +Test.QuickCheck":
"let quackCheck p = quickCheckWith (stdArgs { maxSuccess = 1 }) p ":
[(if namesOpt=="+names" then
"putStr \""++p++": \" >> "
else "") ++
("quackCheck ")
++ p | p<-names])
-- To use ghci
ghci <- findExecutable "ghci"
system (fromJust ghci ++options opts''++" <hugsin")
return ()
isOption xs = head xs `elem` "-+"
options opts = unwords ["\""++opt++"\"" | opt<-opts]
getOption name def opts =
let opt = head [opt | opt<-opts++[def], isPrefixOf name (drop 1 opt)] in
(opt, filter (/=opt) opts)

View File

@ -1,22 +0,0 @@
#!/bin/bash
# Todo: Find a way to make this not suck.
ulimit -t 60 # Sometimes GHC ends in a spin loop, and this is easier than debugging
[[ -e test/quackCheck.hs ]] || { echo "Are you running me from the wrong directory?"; exit 1; }
[[ $1 == -v ]] && pattern="" || pattern="FAIL"
find . -name '*.hs' -exec bash -c '
grep -v "^module " "$1" > quack.tmp.hs
./test/quackCheck.hs +names quack.tmp.hs
' -- {} \; 2>&1 | grep -i "$pattern"
result=$?
rm -f quack.tmp.hs hugsin
if [[ $result == 0 ]]
then
exit 1
else
exit 0
fi

16
test/shellcheck.hs Normal file
View File

@ -0,0 +1,16 @@
module Main where
import Control.Monad
import System.Exit
import qualified ShellCheck.Simple
import qualified ShellCheck.Analytics
import qualified ShellCheck.Parser
main = do
putStrLn "Running ShellCheck tests..."
results <- sequence [ShellCheck.Simple.runTests,
ShellCheck.Analytics.runTests,
ShellCheck.Parser.runTests]
if and results then exitSuccess
else exitFailure