X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=c6f3d66663e01f73677da2d63f461c75e619306b;hb=9ecf132d64d35e5997c12286f509b2f8d7f2a7ef;hp=b9dcbfad9a8b3ac05a0d76d4863541e575b9c602;hpb=6bf0c4665a11101321b3e1bc2cb4de807cce60ba;p=ghc-base.git diff --git a/System/Directory.hs b/System/Directory.hs index b9dcbfa..c6f3d66 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -18,7 +18,9 @@ module System.Directory -- * Actions on directories createDirectory -- :: FilePath -> IO () + , createDirectoryIfMissing -- :: Bool -> FilePath -> IO () , removeDirectory -- :: FilePath -> IO () + , removeDirectoryRecursive -- :: FilePath -> IO () , renameDirectory -- :: FilePath -> FilePath -> IO () , getDirectoryContents -- :: FilePath -> IO [FilePath] @@ -63,9 +65,10 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where +import System.Directory.Internals import System.Environment ( getEnv ) -import System.FilePath import System.IO.Error +import Control.Monad ( when, unless ) #ifdef __NHC__ import Directory @@ -74,13 +77,14 @@ import NHC.FFI #ifdef __HUGS__ import Hugs.Directory +import Control.Exception ( bracket ) +import System.IO #endif /* __HUGS__ */ #ifdef __GLASGOW_HASKELL__ import Prelude import Control.Exception ( bracket ) -import Control.Monad ( when ) import System.Posix.Types import System.Posix.Internals import System.Time ( ClockTime(..) ) @@ -234,10 +238,27 @@ 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 +#endif +-- | @'createDirectoryIfMissing' parents dir@ creates a new directory +-- @dir@ if it doesn\'t exist. If the first argument is 'True' +-- the function will also create all parent directories if they are missing. +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) (tail (pathParents file)) + (_, False, _) -> createDirectory file + +#if __GLASGOW_HASKELL__ {- | @'removeDirectory' dir@ removes an existing directory /dir/. The implementation may specify additional constraints which must be satisfied before a directory can be removed (e.g. the directory has to @@ -284,7 +305,27 @@ removeDirectory path = do modifyIOError (`ioeSetFileName` path) $ withCString path $ \s -> throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s) +#endif +-- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ +-- together with its content and all subdirectories. Be careful, +-- if the directory contains symlinks, the function will follow them. +removeDirectoryRecursive :: FilePath -> IO () +removeDirectoryRecursive startLoc = do + cont <- getDirectoryContents startLoc + sequence_ [rm (startLoc `joinFileName` x) | x <- cont, x /= "." && x /= ".."] + removeDirectory startLoc + where + rm :: FilePath -> IO () + rm f = do temp <- try (removeFile f) + case temp of + Left e -> do isDir <- doesDirectoryExist f + -- If f is not a directory, re-throw the error + unless isDir $ ioError e + removeDirectoryRecursive f + Right _ -> return () + +#if __GLASGOW_HASKELL__ {- |'removeFile' /file/ removes the directory entry for an existing file /file/, where /file/ is not itself a directory. The implementation may specify additional constraints which must be @@ -452,7 +493,14 @@ Neither path may refer to an existing directory. -} copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath = -#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600)) +#if defined(__HUGS__) + (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> + bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo -> do + hGetContents hFrom >>= hPutStr hTo + try (getPermissions fromFPath >>= setPermissions toFPath) + return ()) `catch` \err -> + ioError (annotateIOError err "copyFile" Nothing Nothing) +#elif (!defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ <= 600) do readFile fromFPath >>= writeFile toFPath try (getPermissions fromFPath >>= setPermissions toFPath) return () @@ -480,14 +528,14 @@ copyFile fromFPath toFPath = -- canonicalized path, with the intent that two paths referring -- to the same file\/directory will map to the same canonicalized -- path. Note that it is impossible to guarantee that the --- implication (same file\/dir <=> same canonicalizedPath) holds +-- implication (same file\/dir \<=\> same canonicalizedPath) holds -- in either direction: this function can make only a best-effort -- attempt. canonicalizePath :: FilePath -> IO FilePath canonicalizePath fpath = withCString fpath $ \pInPath -> allocaBytes long_path_size $ \pOutPath -> -#if defined(mingw32_TARGET_OS) +#if defined(mingw32_HOST_OS) alloca $ \ppFilePart -> do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart #else @@ -495,7 +543,7 @@ canonicalizePath fpath = #endif peekCString pOutPath -#if defined(mingw32_TARGET_OS) +#if defined(mingw32_HOST_OS) foreign import stdcall unsafe "GetFullPathName" c_GetFullPathName :: CString -> CInt @@ -524,7 +572,7 @@ findExecutable binary = do path <- getEnv "PATH" search (parseSearchPath path) where - fileName = binary `joinFileExt` drop 1 exeExtension + fileName = binary `joinFileExt` exeExtension search :: [FilePath] -> IO (Maybe FilePath) search [] = return Nothing @@ -793,7 +841,7 @@ cannot be found. -} getHomeDirectory :: IO FilePath getHomeDirectory = -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath if (r < 0) @@ -833,7 +881,7 @@ cannot be found. -} getAppUserDataDirectory :: String -> IO FilePath getAppUserDataDirectory appName = do -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath s <- peekCString pPath @@ -866,7 +914,7 @@ cannot be found. -} getUserDocumentsDirectory :: IO FilePath getUserDocumentsDirectory = do -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath peekCString pPath @@ -881,10 +929,17 @@ environment variable or \"\/tmp\" if the variable isn\'t defined. On Windows, the function checks for the existence of environment variables in the following order and uses the first path found: -* TMP environment variable. -* TEMP environment variable. -* USERPROFILE environment variable. -* The Windows directory +* +TMP environment variable. + +* +TEMP environment variable. + +* +USERPROFILE environment variable. + +* +The Windows directory The operation may fail with: @@ -895,7 +950,7 @@ The function doesn\'t verify whether the path exists. -} getTemporaryDirectory :: IO FilePath getTemporaryDirectory = do -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do r <- c_GetTempPath (fromIntegral long_path_size) pPath peekCString pPath @@ -903,7 +958,7 @@ getTemporaryDirectory = do catch (getEnv "TMPDIR") (\ex -> return "/tmp") #endif -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) foreign import stdcall unsafe "SHGetFolderPath" c_SHGetFolderPath :: Ptr () -> CInt