X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=295d3a50aa01a7b2daff1b25954cb4e7b89cbf45;hb=819adca5f17b40ee129e4a30edf685f817febbf9;hp=62072a2222fb535e80579572247b30f0b3dcba4d;hpb=8fc8458be52b5b7b235b4cc992816a2bd104a95b;p=ghc-base.git diff --git a/System/Directory.hs b/System/Directory.hs index 62072a2..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,8 +65,14 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where +import System.Directory.Internals +import System.Environment ( getEnv ) +import System.IO.Error +import Control.Monad ( when, unless ) + #ifdef __NHC__ import Directory +import NHC.FFI #endif /* __NHC__ */ #ifdef __HUGS__ @@ -74,14 +83,10 @@ 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(..) ) import System.IO -import System.IO.Error -import System.FilePath -import System.Environment (getEnv) import Foreign import Foreign.C @@ -231,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 @@ -281,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 @@ -441,6 +483,8 @@ renameFile opath npath = withCString npath $ \s2 -> throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2) +#endif /* __GLASGOW_HASKELL__ */ + {- |@'copyFile' old new@ copies the existing file from /old/ to /new/. If the /new/ file already exists, it is atomically replaced by the /old/ file. Neither path may refer to an existing directory. @@ -470,18 +514,19 @@ copyFile fromFPath toFPath = copyContents hFrom hTo buffer #endif +#ifdef __GLASGOW_HASKELL__ -- | Given path referring to a file or directory, returns a -- 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 @@ -489,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 @@ -502,6 +547,11 @@ foreign import ccall unsafe "realpath" -> CString -> IO CString #endif +#else /* !__GLASGOW_HASKELL__ */ +-- dummy implementation +canonicalizePath :: FilePath -> IO FilePath +canonicalizePath fpath = return fpath +#endif /* !__GLASGOW_HASKELL__ */ -- | Given an executable file name, searches for such file -- in the directories listed in system PATH. The returned value @@ -513,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 @@ -527,7 +573,7 @@ findExecutable binary = do if b then return (Just path) else search ds - +#ifdef __GLASGOW_HASKELL__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries in /dir/. @@ -786,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) @@ -826,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 @@ -859,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 @@ -867,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 @@ -879,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