X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=6c351221390605dc0848069ddc33b01e1aae7a4c;hb=d20f3c9e058e81146ba3d346c4319b63ae6858f1;hp=39ca47f271efb1f523363c5d23a2a20e723183f0;hpb=cabbe6e5fc458473162345543f55bad0d9faa892;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index 39ca47f..6c35122 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -25,10 +25,19 @@ module System.Directory , getCurrentDirectory -- :: IO FilePath , setCurrentDirectory -- :: FilePath -> IO () + -- * Pre-defined directories + , getHomeDirectory + , getAppUserDataDirectory + , getUserDocumentsDirectory + , getTemporaryDirectory + -- * Actions on files , removeFile -- :: FilePath -> IO () , renameFile -- :: FilePath -> FilePath -> IO () , copyFile -- :: FilePath -> FilePath -> IO () + + , canonicalizePath + , findExecutable -- * Existence tests , doesFileExist -- :: FilePath -> IO Bool @@ -54,12 +63,20 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where +import System.Environment ( getEnv ) +import System.FilePath +import System.IO.Error + #ifdef __NHC__ import Directory -#elif defined(__HUGS__) +import NHC.FFI +#endif /* __NHC__ */ + +#ifdef __HUGS__ import Hugs.Directory -#else +#endif /* __HUGS__ */ +#ifdef __GLASGOW_HASKELL__ import Prelude import Control.Exception ( bracket ) @@ -68,13 +85,10 @@ import System.Posix.Types import System.Posix.Internals import System.Time ( ClockTime(..) ) import System.IO -import System.IO.Error import Foreign import Foreign.C -#ifdef __GLASGOW_HASKELL__ import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) -#endif {- $intro A directory contains a series of entries, each of which is a named @@ -430,29 +444,97 @@ 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 = handle (changeFunName) $ +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 changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp - changeFunName e = e copyContents hFrom hTo buffer = do count <- hGetBuf hFrom buffer bufferSize 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_TARGET_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_TARGET_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/. @@ -686,4 +768,160 @@ foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode +#endif /* __GLASGOW_HASKELL__ */ + +{- | Returns the current user's home directory. + +The directory returned is expected to be writable by the current user, +but note that it isn't generally considered good practice to store +application-specific data here; use 'getAppUserDataDirectory' +instead. + +On Unix, 'getHomeDirectory' returns the value of the @HOME@ +environment variable. On Windows, the system is queried for a +suitable path; a typical path might be +@C:/Documents And Settings/user@. + +The operation may fail with: + +* 'UnsupportedOperation' +The operating system has no notion of home directory. + +* 'isDoesNotExistError' +The home directory for the current user does not exist, or +cannot be found. +-} +getHomeDirectory :: IO FilePath +getHomeDirectory = +#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath + if (r < 0) + then c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath + else return 0 + peekCString pPath +#else + getEnv "HOME" +#endif + +{- | Returns the pathname of a directory in which application-specific +data for the current user can be stored. The result of +'getAppUserDataDirectory' for a given application is specific to +the current user. + +The argument should be the name of the application, which will be used +to construct the pathname (so avoid using unusual characters that +might result in an invalid pathname). + +Note: the directory may not actually exist, and may need to be created +first. It is expected that the parent directory exists and is +writable. + +On Unix, this function returns @$HOME\/.appName@. On Windows, a +typical path might be + +> C:/Documents And Settings/user/Application Data/appName + +The operation may fail with: + +* 'UnsupportedOperation' +The operating system has no notion of application-specific data directory. + +* 'isDoesNotExistError' +The home directory for the current user does not exist, or +cannot be found. +-} +getAppUserDataDirectory :: String -> IO FilePath +getAppUserDataDirectory appName = do +#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath + s <- peekCString pPath + return (s++'\\':appName) +#else + path <- getEnv "HOME" + return (path++'/':'.':appName) +#endif + +{- | Returns the current user's document directory. + +The directory returned is expected to be writable by the current user, +but note that it isn't generally considered good practice to store +application-specific data here; use 'getAppUserDataDirectory' +instead. + +On Unix, 'getUserDocumentsDirectory' returns the value of the @HOME@ +environment variable. On Windows, the system is queried for a +suitable path; a typical path might be +@C:\/Documents and Settings\/user\/My Documents@. + +The operation may fail with: + +* 'UnsupportedOperation' +The operating system has no notion of document directory. + +* 'isDoesNotExistError' +The document directory for the current user does not exist, or +cannot be found. +-} +getUserDocumentsDirectory :: IO FilePath +getUserDocumentsDirectory = do +#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath + peekCString pPath +#else + getEnv "HOME" +#endif + +{- | 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_TARGET_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_TARGET_OS) +foreign import stdcall unsafe "SHGetFolderPath" + c_SHGetFolderPath :: Ptr () + -> CInt + -> Ptr () + -> CInt + -> CString + -> IO CInt +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