X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=afa38ebfa3bed61d664283a72d146b726dee6b9e;hb=cbcd2d44aff0b908ee90bbdcc9b0c3ccb3008e20;hp=52983221fb52622a644f1809d2b2c898bb36a8cb;hpb=1e5361634268e81dfa56c87e2c2f0342d4314e81;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index 5298322..afa38eb 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -72,12 +72,13 @@ module System.Directory import Prelude hiding ( catch ) import qualified Prelude +import Control.Monad (guard) import System.Environment ( getEnv ) import System.FilePath import System.IO import System.IO.Error hiding ( catch, try ) import Control.Monad ( when, unless ) -import Control.Exception +import Control.Exception.Base #ifdef __NHC__ import Directory @@ -100,6 +101,12 @@ import System.Time ( ClockTime(..) ) import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) +#ifdef mingw32_HOST_OS +import qualified System.Win32 +#else +import qualified System.Posix +#endif + {- $intro A directory contains a series of entries, each of which is a named reference to a file system object (file, directory etc.). Some @@ -278,10 +285,11 @@ The path refers to an existing non-directory object. createDirectory :: FilePath -> IO () createDirectory path = do - modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> do - throwErrnoIfMinus1Retry_ "createDirectory" $ - mkdir s 0o777 +#ifdef mingw32_HOST_OS + System.Win32.createDirectory path Nothing +#else + System.Posix.createDirectory path 0o777 +#endif #else /* !__GLASGOW_HASKELL__ */ @@ -297,14 +305,23 @@ copyPermissions fromFPath toFPath createDirectoryIfMissing :: Bool -- ^ Create its parents too? -> FilePath -- ^ The path to the directory you want to make -> IO () -createDirectoryIfMissing parents file = do - b <- doesDirectoryExist file - case (b,parents, file) of - (_, _, "") -> return () - (True, _, _) -> return () - (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file - (_, False, _) -> createDirectory file - where mkParents = scanl1 () . splitDirectories . normalise +createDirectoryIfMissing create_parents "" = return () +createDirectoryIfMissing create_parents path0 + = do r <- try $ createDirectory path + case (r :: Either IOException ()) of + Right _ -> return () + Left e + | isAlreadyExistsError e -> return () + | isDoesNotExistError e && create_parents -> do + createDirectoryIfMissing True (dropFileName path) + createDirectoryIfMissing True path + | otherwise -> throw e + where + -- we want createDirectoryIfMissing "a/" to behave like + -- createDirectoryIfMissing "a". Also, unless we apply + -- dropTrailingPathSeparator first, dropFileName won't drop + -- anything from "a/". + path = dropTrailingPathSeparator path0 #if __GLASGOW_HASKELL__ {- | @'removeDirectory' dir@ removes an existing directory /dir/. The @@ -349,10 +366,13 @@ The operand refers to an existing non-directory object. -} removeDirectory :: FilePath -> IO () -removeDirectory path = do - modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s) +removeDirectory path = +#ifdef mingw32_HOST_OS + System.Win32.removeDirectory path +#else + System.Posix.removeDirectory path +#endif + #endif -- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ @@ -409,10 +429,12 @@ The operand refers to an existing directory. -} removeFile :: FilePath -> IO () -removeFile path = do - modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s) +removeFile path = +#if mingw32_HOST_OS + System.Win32.deleteFile path +#else + System.Posix.removeLink path +#endif {- |@'renameDirectory' old new@ changes the name of an existing directory from /old/ to /new/. If the /new/ directory @@ -465,16 +487,18 @@ Either path refers to an existing non-directory object. renameDirectory :: FilePath -> FilePath -> IO () renameDirectory opath npath = + -- XXX this test isn't performed atomically with the following rename withFileStatus "renameDirectory" opath $ \st -> do is_dir <- isDirectory st if (not is_dir) then ioException (IOError Nothing InappropriateType "renameDirectory" ("not a directory") (Just opath)) else do - - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameDirectory" (c_rename s1 s2) +#ifdef mingw32_HOST_OS + System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING +#else + System.Posix.rename opath npath +#endif {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/. If the /new/ object already @@ -522,16 +546,18 @@ Either path refers to an existing directory. renameFile :: FilePath -> FilePath -> IO () renameFile opath npath = + -- XXX this test isn't performed atomically with the following rename withFileOrSymlinkStatus "renameFile" opath $ \st -> do is_dir <- isDirectory st if is_dir then ioException (IOError Nothing InappropriateType "renameFile" "is a directory" (Just opath)) else do - - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2) +#ifdef mingw32_HOST_OS + System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING +#else + System.Posix.rename opath npath +#endif #endif /* __GLASGOW_HASKELL__ */ @@ -545,8 +571,8 @@ copyFile :: FilePath -> FilePath -> IO () #ifdef __NHC__ copyFile fromFPath toFPath = do readFile fromFPath >>= writeFile toFPath - try (copyPermissions fromFPath toFPath) - return () + Prelude.catch (copyPermissions fromFPath toFPath) + (\_ -> return ()) #else copyFile fromFPath toFPath = copy `Prelude.catch` (\exc -> throw $ ioeSetLocation exc "copyFile") @@ -554,11 +580,12 @@ copyFile fromFPath toFPath = bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> do allocaBytes bufferSize $ copyContents hFrom hTmp hClose hTmp - ignoreExceptions $ copyPermissions fromFPath tmpFPath + ignoreIOExceptions $ copyPermissions fromFPath tmpFPath renameFile tmpFPath toFPath openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" - cleanTmp (tmpFPath, hTmp) = do ignoreExceptions $ hClose hTmp - ignoreExceptions $ removeFile tmpFPath + cleanTmp (tmpFPath, hTmp) + = do ignoreIOExceptions $ hClose hTmp + ignoreIOExceptions $ removeFile tmpFPath bufferSize = 1024 copyContents hFrom hTo buffer = do @@ -566,6 +593,10 @@ copyFile fromFPath toFPath = when (count > 0) $ do hPutBuf hTo buffer count copyContents hFrom hTo buffer + + ignoreIOExceptions io = io `catch` ioExceptionIgnorer + ioExceptionIgnorer :: IOException -> IO () + ioExceptionIgnorer _ = return () #endif -- | Given path referring to a file or directory, returns a @@ -747,6 +778,8 @@ The operating system has no notion of current directory. getCurrentDirectory :: IO FilePath getCurrentDirectory = do +#ifdef mingw32_HOST_OS + -- XXX: should use something from Win32 p <- mallocBytes long_path_size go p long_path_size where go p bytes = do @@ -761,6 +794,14 @@ getCurrentDirectory = do p'' <- reallocBytes p bytes' go p'' bytes' else throwErrno "getCurrentDirectory" +#else + System.Posix.getWorkingDirectory +#endif + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "getcwd" + c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) +#endif {- |If the operating system has a notion of current directories, @'setCurrentDirectory' dir@ changes the current @@ -795,31 +836,30 @@ The path refers to an existing non-directory object. -} setCurrentDirectory :: FilePath -> IO () -setCurrentDirectory path = do - modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s) - -- ToDo: add path to error +setCurrentDirectory path = +#ifdef mingw32_HOST_OS + System.Win32.setCurrentDirectory path +#else + System.Posix.changeWorkingDirectory path +#endif {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is a directory, and 'False' otherwise. -} doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist name = - catchAny +doesDirectoryExist name = (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) - (\ _ -> return False) + `catch` ((\ _ -> return False) :: IOException -> IO Bool) {- |The operation 'doesFileExist' returns 'True' if the argument file exists and is not a directory, and 'False' otherwise. -} doesFileExist :: FilePath -> IO Bool -doesFileExist name = do - catchAny +doesFileExist name = (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) - (\ _ -> return False) + `catch` ((\ _ -> return False) :: IOException -> IO Bool) {- |The 'getModificationTime' operation returns the clock time at which the file or directory was last modified. @@ -1035,7 +1075,7 @@ getTemporaryDirectory = do `Prelude.catch` \e -> if isDoesNotExistError e then return "/tmp" else throw e #else - `catch` (\ex -> return "/tmp") + `Prelude.catch` (\ex -> return "/tmp") #endif #endif