fix test suite when run by root

This commit is contained in:
Joey Hess 2011-04-26 20:21:24 -04:00
parent 948691e893
commit dbdcb67f79

14
test.hs
View file

@ -577,10 +577,14 @@ checkcontent f = do
checkunwritable :: FilePath -> Assertion checkunwritable :: FilePath -> Assertion
checkunwritable f = do checkunwritable f = do
r <- try $ writeFile f $ content f -- Look at permissions bits rather than trying to write or using
case r of -- fileAccess because if run as root, any file can be modified
Left _ -> return () -- expected permission error -- despite permissions.
Right _ -> assertFailure $ "was able to modify annexed file's " ++ f ++ " content" s <- getFileStatus f
let mode = fileMode s
if (mode == mode `unionFileModes` ownerWriteMode)
then assertFailure $ "able to modify annexed file's " ++ f ++ " content"
else return ()
checkwritable :: FilePath -> Assertion checkwritable :: FilePath -> Assertion
checkwritable f = do checkwritable f = do
@ -640,7 +644,7 @@ runchecks (a:as) f = do
annexed_notpresent :: FilePath -> Assertion annexed_notpresent :: FilePath -> Assertion
annexed_notpresent = runchecks annexed_notpresent = runchecks
[checklink, checkdangling, checkunwritable, notinlocationlog] [checklink, checkdangling, notinlocationlog]
annexed_present :: FilePath -> Assertion annexed_present :: FilePath -> Assertion
annexed_present = runchecks annexed_present = runchecks