make test suite link in git-annex's commands and run directly

this way, test coverage works
This commit is contained in:
Joey Hess 2011-01-06 20:26:57 -04:00
parent 901cdbde78
commit 2533d826fc
4 changed files with 99 additions and 86 deletions

75
GitAnnex.hs Normal file
View file

@ -0,0 +1,75 @@
{- git-annex main program
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module GitAnnex where
import System.Console.GetOpt
import Command
import Options
import qualified Command.Add
import qualified Command.Unannex
import qualified Command.Drop
import qualified Command.Move
import qualified Command.Copy
import qualified Command.Get
import qualified Command.FromKey
import qualified Command.DropKey
import qualified Command.SetKey
import qualified Command.Fix
import qualified Command.Init
import qualified Command.Fsck
import qualified Command.Unused
import qualified Command.DropUnused
import qualified Command.Unlock
import qualified Command.Lock
import qualified Command.PreCommit
import qualified Command.Find
import qualified Command.Uninit
import qualified Command.Trust
import qualified Command.Untrust
cmds :: [Command]
cmds = concat
[ Command.Add.command
, Command.Get.command
, Command.Drop.command
, Command.Move.command
, Command.Copy.command
, Command.Unlock.command
, Command.Lock.command
, Command.Init.command
, Command.Unannex.command
, Command.Uninit.command
, Command.PreCommit.command
, Command.Trust.command
, Command.Untrust.command
, Command.FromKey.command
, Command.DropKey.command
, Command.SetKey.command
, Command.Fix.command
, Command.Fsck.command
, Command.Unused.command
, Command.DropUnused.command
, Command.Find.command
]
options :: [Option]
options = commonOptions ++
[ Option ['k'] ["key"] (ReqArg (storeOptString "key") paramKey)
"specify a key to use"
, Option ['t'] ["to"] (ReqArg (storeOptString "torepository") paramRemote)
"specify to where to transfer content"
, Option ['f'] ["from"] (ReqArg (storeOptString "fromrepository") paramRemote)
"specify from where to transfer content"
, Option ['x'] ["exclude"] (ReqArg (storeOptString "exclude") paramGlob)
"skip files matching the glob pattern"
]
header :: String
header = "Usage: git-annex command [option ..]"

2
debian/changelog vendored
View file

@ -8,7 +8,7 @@ git-annex (0.16) UNRELEASED; urgency=low
significant problem, since the remote *did* record that it had the file.
* Also, add a general guard to detect attempts to record information
about repositories with missing UUIDs.
* Test suite improvements.
* Test suite improvements. Current top-level test coverage: 43%
-- Joey Hess <joeyh@debian.org> Tue, 04 Jan 2011 17:33:42 -0400

View file

@ -6,74 +6,10 @@
-}
import System.Environment
import System.Console.GetOpt
import qualified GitRepo as Git
import CmdLine
import Command
import Options
import qualified Command.Add
import qualified Command.Unannex
import qualified Command.Drop
import qualified Command.Move
import qualified Command.Copy
import qualified Command.Get
import qualified Command.FromKey
import qualified Command.DropKey
import qualified Command.SetKey
import qualified Command.Fix
import qualified Command.Init
import qualified Command.Fsck
import qualified Command.Unused
import qualified Command.DropUnused
import qualified Command.Unlock
import qualified Command.Lock
import qualified Command.PreCommit
import qualified Command.Find
import qualified Command.Uninit
import qualified Command.Trust
import qualified Command.Untrust
cmds :: [Command]
cmds = concat
[ Command.Add.command
, Command.Get.command
, Command.Drop.command
, Command.Move.command
, Command.Copy.command
, Command.Unlock.command
, Command.Lock.command
, Command.Init.command
, Command.Unannex.command
, Command.Uninit.command
, Command.PreCommit.command
, Command.Trust.command
, Command.Untrust.command
, Command.FromKey.command
, Command.DropKey.command
, Command.SetKey.command
, Command.Fix.command
, Command.Fsck.command
, Command.Unused.command
, Command.DropUnused.command
, Command.Find.command
]
options :: [Option]
options = commonOptions ++
[ Option ['k'] ["key"] (ReqArg (storeOptString "key") paramKey)
"specify a key to use"
, Option ['t'] ["to"] (ReqArg (storeOptString "torepository") paramRemote)
"specify to where to transfer content"
, Option ['f'] ["from"] (ReqArg (storeOptString "fromrepository") paramRemote)
"specify from where to transfer content"
, Option ['x'] ["exclude"] (ReqArg (storeOptString "exclude") paramGlob)
"skip files matching the glob pattern"
]
header :: String
header = "Usage: git-annex command [option ..]"
import GitAnnex
main :: IO ()
main = do

42
test.hs
View file

@ -10,35 +10,30 @@ import Test.HUnit.Tools
import System.Directory
import System.Posix.Directory (changeWorkingDirectory)
import System.Posix.Files
import System.Posix.Env
import IO (bracket_, bracket)
import Control.Monad (unless, when)
import Data.List
import System.IO.Error
import qualified GitRepo as Git
import Locations
import Utility
import TypeInternals
import qualified Locations
import qualified Utility
import qualified TypeInternals
import qualified GitAnnex
import qualified CmdLine
main :: IO (Counts, Int)
main = do
-- Add current directory to the from of PATH, so git-annex etc will
-- be used, no matter where it is run from.
cwd <- getCurrentDirectory
p <- getEnvDefault "PATH" ""
setEnv "PATH" (cwd++":"++p) True
runVerboseTests $ TestList [quickchecks, toplevels]
main = runVerboseTests $ TestList [quickchecks, toplevels]
quickchecks :: Test
quickchecks = TestLabel "quickchecks" $ TestList
[ qctest "prop_idempotent_deencode" Git.prop_idempotent_deencode
, qctest "prop_idempotent_fileKey" prop_idempotent_fileKey
, qctest "prop_idempotent_key_read_show" prop_idempotent_key_read_show
, qctest "prop_idempotent_shellEscape" prop_idempotent_shellEscape
, qctest "prop_idempotent_shellEscape_multiword" prop_idempotent_shellEscape_multiword
, qctest "prop_parentDir_basics" prop_parentDir_basics
, qctest "prop_relPathDirToDir_basics" prop_relPathDirToDir_basics
, qctest "prop_idempotent_fileKey" Locations.prop_idempotent_fileKey
, qctest "prop_idempotent_key_read_show" TypeInternals.prop_idempotent_key_read_show
, qctest "prop_idempotent_shellEscape" Utility.prop_idempotent_shellEscape
, qctest "prop_idempotent_shellEscape_multiword" Utility.prop_idempotent_shellEscape_multiword
, qctest "prop_parentDir_basics" Utility.prop_parentDir_basics
, qctest "prop_relPathDirToDir_basics" Utility.prop_relPathDirToDir_basics
]
toplevels :: Test
@ -79,7 +74,14 @@ test_add = TestLabel "git-annex add" $ TestCase $ inannex $ do
content = "foo file content"
git_annex :: String -> [String] -> IO Bool
git_annex command params = boolSystem "git-annex" (command:params)
git_annex command params = do
gitrepo <- Git.repoFromCwd
r <- try $
CmdLine.dispatch gitrepo (command:params)
GitAnnex.cmds GitAnnex.options GitAnnex.header
case r of
Right _ -> return True
Left _ -> return False
inannex :: Assertion -> Assertion
inannex a = ingitrepo $ do
@ -103,7 +105,7 @@ withgitrepo = bracket setup cleanup
setup = do
cleanup True
createDirectory tmpdir
ok <- boolSystem "git" ["init", "-q", repodir]
ok <- Utility.boolSystem "git" ["init", "-q", repodir]
unless ok $
assertFailure "git init failed"
return $ Git.repoFromPath repodir
@ -113,5 +115,5 @@ withgitrepo = bracket setup cleanup
-- git-annex prevents annexed file content
-- from being removed with permissions
-- bits; undo
_ <- boolSystem "chmod" ["+rw", "-R", tmpdir]
_ <- Utility.boolSystem "chmod" ["+rw", "-R", tmpdir]
removeDirectoryRecursive tmpdir