X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=295d3a50aa01a7b2daff1b25954cb4e7b89cbf45;hb=819adca5f17b40ee129e4a30edf685f817febbf9;hp=c63a88a1579bc38baa568602e016d01becef69e4;hpb=dd98821bb79a1e4d266a4660b9282f1f3d4401e3;p=ghc-base.git diff --git a/System/Directory.hs b/System/Directory.hs index c63a88a..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,13 +31,15 @@ module System.Directory , getHomeDirectory , getAppUserDataDirectory , getUserDocumentsDirectory + , getTemporaryDirectory -- * Actions on files , removeFile -- :: FilePath -> IO () , renameFile -- :: FilePath -> FilePath -> IO () -#ifdef __GLASGOW_HASKELL__ , copyFile -- :: FilePath -> FilePath -> IO () -#endif + + , canonicalizePath + , findExecutable -- * Existence tests , doesFileExist -- :: FilePath -> IO Bool @@ -61,35 +65,33 @@ 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 System (getEnv) +import NHC.FFI #endif /* __NHC__ */ #ifdef __HUGS__ import Hugs.Directory -import System.Environment (getEnv) #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(..) ) import System.IO -import System.IO.Error import Foreign import Foreign.C import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) -#ifndef mingw32_TARGET_OS -import System.Environment -#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 @@ -234,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 @@ -284,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 @@ -444,16 +483,25 @@ 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. -} copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath = +#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600)) + do readFile fromFPath >>= writeFile toFPath + try (getPermissions fromFPath >>= setPermissions toFPath) + return () +#else (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo -> - allocaBytes bufferSize $ \buffer -> - copyContents hFrom hTo buffer) `catch` (ioError . changeFunName) + allocaBytes bufferSize $ \buffer -> do + copyContents hFrom hTo buffer + try (getPermissions fromFPath >>= setPermissions toFPath) + return ()) `catch` (ioError . changeFunName) where bufferSize = 1024 @@ -464,8 +512,68 @@ copyFile fromFPath toFPath = when (count > 0) $ do hPutBuf hTo buffer count 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 +-- 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_HOST_OS) + alloca $ \ppFilePart -> + do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart +#else + do c_realpath pInPath pOutPath +#endif + peekCString pOutPath + +#if defined(mingw32_HOST_OS) +foreign import stdcall unsafe "GetFullPathName" + c_GetFullPathName :: CString + -> CInt + -> CString + -> Ptr CString + -> IO CInt +#else +foreign import ccall unsafe "realpath" + c_realpath :: CString + -> 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 +-- is the path to the found executable or Nothing if there isn't +-- such executable. For example (findExecutable \"ghc\") +-- gives you the path to GHC. +findExecutable :: String -> IO (Maybe FilePath) +findExecutable binary = do + path <- getEnv "PATH" + search (parseSearchPath path) + where + fileName = binary `joinFileExt` exeExtension + search :: [FilePath] -> IO (Maybe FilePath) + search [] = return Nothing + search (d:ds) = do + let path = d `joinFileName` fileName + b <- doesFileExist path + if b then return (Just path) + else search ds +#ifdef __GLASGOW_HASKELL__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries in /dir/. @@ -724,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) @@ -764,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 @@ -797,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 @@ -805,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 @@ -817,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