X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=7cfb090048bda874acf235f9137e49d9e39f2f56;hb=ba9a368b96a4ae622fe463c178f223dffdd5a38f;hp=5da67b691ff3e71521d8c83edc548ba3e3a04b4d;hpb=4265c3f9425684443ce11c78dfd7dfd05de0c88a;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index 5da67b6..7cfb090 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -72,6 +72,7 @@ module System.Directory import Prelude hiding ( catch ) import qualified Prelude +import Control.Monad (guard) import System.Environment ( getEnv ) import System.FilePath import System.IO @@ -80,7 +81,9 @@ import Control.Monad ( when, unless ) import Control.Exception.Base #ifdef __NHC__ -import Directory +import Directory hiding ( getDirectoryContents + , doesDirectoryExist, doesFileExist + , getModificationTime ) import System (system) #endif /* __NHC__ */ @@ -93,11 +96,11 @@ import Foreign.C {-# CFILES cbits/directory.c #-} -#ifdef __GLASGOW_HASKELL__ import System.Posix.Types import System.Posix.Internals import System.Time ( ClockTime(..) ) +#ifdef __GLASGOW_HASKELL__ import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) #ifdef mingw32_HOST_OS @@ -284,10 +287,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__ */ @@ -303,14 +307,40 @@ 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 path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throw + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throw + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- try $ createDirectory dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exeption in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> + (withFileStatus "createDirectoryIfMissing" dir $ \st -> do + isDir <- isDirectory st + if isDir then return () + else throw e + ) `catch` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throw e #if __GLASGOW_HASKELL__ {- | @'removeDirectory' dir@ removes an existing directory /dir/. The @@ -355,10 +385,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/ @@ -415,10 +448,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 @@ -475,13 +510,14 @@ renameDirectory opath npath = withFileStatus "renameDirectory" opath $ \st -> do is_dir <- isDirectory st if (not is_dir) - then ioException (IOError Nothing InappropriateType "renameDirectory" - ("not a directory") (Just opath)) + then ioException (ioeSetErrorString + (mkIOError InappropriateType "renameDirectory" Nothing (Just opath)) + "not a directory") else do #ifdef mingw32_HOST_OS System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING #else - System.Posix.rename s1 s2 + System.Posix.rename opath npath #endif {- |@'renameFile' old new@ changes the name of an existing file system @@ -534,13 +570,14 @@ renameFile opath npath = withFileOrSymlinkStatus "renameFile" opath $ \st -> do is_dir <- isDirectory st if is_dir - then ioException (IOError Nothing InappropriateType "renameFile" - "is a directory" (Just opath)) + then ioException (ioeSetErrorString + (mkIOError InappropriateType "renameFile" Nothing (Just opath)) + "is a directory") else do #ifdef mingw32_HOST_OS System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING #else - System.Posix.rename s1 s2 + System.Posix.rename opath npath #endif #endif /* __GLASGOW_HASKELL__ */ @@ -667,7 +704,7 @@ foreign import stdcall unsafe "SearchPathA" #endif -#ifdef __GLASGOW_HASKELL__ +#ifndef __HUGS__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries in /dir/. @@ -727,11 +764,11 @@ getDirectoryContents path = do return (entry:entries) else do errno <- getErrno if (errno == eINTR) then loop ptr_dEnt dir else do - let (Errno eo) = errno - if (eo == end_of_dir) - then return [] - else throwErrno desc - + let (Errno eo) = errno + if (eo == end_of_dir) + then return [] + else throwErrno desc +#endif /* !__HUGS__ */ {- |If the operating system has a notion of current directories, @@ -759,9 +796,11 @@ Insufficient resources are available to perform the operation. The operating system has no notion of current directory. -} - +#ifdef __GLASGOW_HASKELL__ 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 @@ -776,6 +815,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 @@ -810,12 +857,16 @@ 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 + +#endif /* __GLASGOW_HASKELL__ */ +#ifndef __HUGS__ {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is a directory, and 'False' otherwise. -} @@ -851,6 +902,8 @@ getModificationTime name = withFileStatus "getModificationTime" name $ \ st -> modificationTime st +#endif /* !__HUGS__ */ + withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a withFileStatus loc name f = do modifyIOError (`ioeSetFileName` name) $ @@ -893,13 +946,13 @@ foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode #endif + +#ifdef __GLASGOW_HASKELL__ foreign import ccall unsafe "__hscore_long_path_size" long_path_size :: Int - #else long_path_size :: Int long_path_size = 2048 -- // guess? - #endif /* __GLASGOW_HASKELL__ */ {- | Returns the current user's home directory. @@ -1069,7 +1122,7 @@ foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> raiseUnsupported :: String -> IO () raiseUnsupported loc = - ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing) + ioException (ioeSetErrorString (mkIOError UnsupportedOperation loc Nothing Nothing) "unsupported operation") #endif @@ -1082,4 +1135,3 @@ exeExtension = "exe" #else exeExtension = "" #endif -