X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=295d3a50aa01a7b2daff1b25954cb4e7b89cbf45;hb=819adca5f17b40ee129e4a30edf685f817febbf9;hp=50e77abed895aa612ec1bbb04095dffc4b93f73e;hpb=b3e13e24b24d6c2aede318db7be33929c4e4feb8;p=ghc-base.git diff --git a/System/Directory.hs b/System/Directory.hs index 50e77ab..295d3a5 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] @@ -29,6 +31,7 @@ module System.Directory , getHomeDirectory , getAppUserDataDirectory , getUserDocumentsDirectory + , getTemporaryDirectory -- * Actions on files , removeFile -- :: FilePath -> IO () @@ -62,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 @@ -79,7 +83,6 @@ import Hugs.Directory import Prelude import Control.Exception ( bracket ) -import Control.Monad ( when ) import System.Posix.Types import System.Posix.Internals import System.Time ( ClockTime(..) ) @@ -233,10 +236,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 @@ -283,7 +303,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 @@ -479,14 +519,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 @@ -494,7 +534,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 @@ -523,11 +563,7 @@ findExecutable binary = do path <- getEnv "PATH" search (parseSearchPath path) where -#ifdef mingw32_TARGET_OS - fileName = binary `joinFileExt` "exe" -#else - fileName = binary -#endif + fileName = binary `joinFileExt` exeExtension search :: [FilePath] -> IO (Maybe FilePath) search [] = return Nothing @@ -796,7 +832,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) @@ -836,7 +872,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 @@ -869,7 +905,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 @@ -877,7 +913,43 @@ getUserDocumentsDirectory = do getEnv "HOME" #endif -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +{- | Returns the current directory for temporary files. + +On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@ +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 + +The operation may fail with: + +* 'UnsupportedOperation' +The operating system has no notion of temporary directory. + +The function doesn\'t verify whether the path exists. +-} +getTemporaryDirectory :: IO FilePath +getTemporaryDirectory = do +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_GetTempPath (fromIntegral long_path_size) pPath + peekCString pPath +#else + catch (getEnv "TMPDIR") (\ex -> return "/tmp") +#endif + +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) foreign import stdcall unsafe "SHGetFolderPath" c_SHGetFolderPath :: Ptr () -> CInt @@ -889,4 +961,6 @@ foreign import ccall unsafe "__hscore_CSIDL_PROFILE" csidl_PROFILE :: CInt foreign import ccall unsafe "__hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt foreign import ccall unsafe "__hscore_CSIDL_WINDOWS" csidl_WINDOWS :: CInt foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt + +foreign import stdcall unsafe "GetTempPath" c_GetTempPath :: CInt -> CString -> IO CInt #endif