X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=6e86c22c222ffa99795cfec351c85a2cd45ad04c;hb=4c05263487d18395acc9d9de0d56455402f32c45;hp=7338fff513da8acc76d924d6137344df0fc36e4c;hpb=b8ac498face4c8b16c06d30fbc86666b7dc28173;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index 7338fff..6e86c22 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -w #-} +-- XXX We get some warnings on Windows + ----------------------------------------------------------------------------- -- | -- Module : System.Directory @@ -18,16 +21,29 @@ 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] , 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 + , makeRelativeToCurrentDirectory + , findExecutable -- * Existence tests , doesFileExist -- :: FilePath -> IO Bool @@ -53,33 +69,57 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where +import Prelude hiding ( catch ) +import qualified Prelude + +import Control.Monad (guard) +import System.Environment ( getEnv ) +import System.FilePath +import System.IO +import System.IO.Error hiding ( catch, try ) +import Control.Monad ( when, unless ) +import Control.Exception.Base + #ifdef __NHC__ -import Directory -#elif defined(__HUGS__) -import Hugs.Directory -#else +import Directory hiding ( getDirectoryContents + , doesDirectoryExist, doesFileExist + , getModificationTime ) +import System (system) +#endif /* __NHC__ */ -import Prelude +#ifdef __HUGS__ +import Hugs.Directory +#endif /* __HUGS__ */ -import Control.Exception ( bracket ) -import System.Posix.Types -import System.Time ( ClockTime(..) ) -import System.IO -import System.IO.Error import Foreign import Foreign.C +{-# CFILES cbits/directory.c #-} + +import System.Time ( ClockTime(..) ) + #ifdef __GLASGOW_HASKELL__ -import System.Posix.Internals + +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Exception ( IOException(..), IOErrorType(..), ioException ) +#else import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) #endif +#ifdef mingw32_HOST_OS +import System.Posix.Types +import System.Posix.Internals +import qualified System.Win32 as Win32 +#else +import qualified System.Posix as Posix +#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 entries may be hidden, inaccessible, or have some administrative function (e.g. `.' or `..' under POSIX -), but in +), but in this standard all such entries are considered to form part of the directory contents. Entries in sub-directories are not, however, considered to form part of the directory contents. @@ -132,20 +172,44 @@ The operation may fail with: getPermissions :: FilePath -> IO Permissions getPermissions name = do - withCString name $ \s -> do - read <- c_access s r_OK - write <- c_access s w_OK - exec <- c_access s x_OK - withFileStatus "getPermissions" name $ \st -> do - is_dir <- isDirectory st +#ifdef mingw32_HOST_OS + withFilePath name $ \s -> do + -- stat() does a better job of guessing the permissions on Windows + -- than access() does. e.g. for execute permission, it looks at the + -- filename extension :-) + -- + -- I tried for a while to do this properly, using the Windows security API, + -- and eventually gave up. getPermissions is a flawed API anyway. -- SimonM + allocaBytes sizeof_stat $ \ p_stat -> do + throwErrnoIfMinus1_ "getPermissions" $ c_stat s p_stat + mode <- st_mode p_stat + let usr_read = mode .&. s_IRUSR + let usr_write = mode .&. s_IWUSR + let usr_exec = mode .&. s_IXUSR + let is_dir = mode .&. s_IFDIR + return ( + Permissions { + readable = usr_read /= 0, + writable = usr_write /= 0, + executable = is_dir == 0 && usr_exec /= 0, + searchable = is_dir /= 0 && usr_exec /= 0 + } + ) +#else + read_ok <- Posix.fileAccess name True False False + write_ok <- Posix.fileAccess name False True False + exec_ok <- Posix.fileAccess name False False True + stat <- Posix.getFileStatus name + let is_dir = Posix.fileMode stat .&. Posix.directoryMode /= 0 return ( Permissions { - readable = read == 0, - writable = write == 0, - executable = not is_dir && exec == 0, - searchable = is_dir && exec == 0 + readable = read_ok, + writable = write_ok, + executable = not is_dir && exec_ok, + searchable = is_dir && exec_ok } ) +#endif {- |The 'setPermissions' operation sets the permissions for the file or directory. @@ -161,15 +225,52 @@ The operation may fail with: setPermissions :: FilePath -> Permissions -> IO () setPermissions name (Permissions r w e s) = do - let - read = if r then s_IRUSR else emptyCMode - write = if w then s_IWUSR else emptyCMode - exec = if e || s then s_IXUSR else emptyCMode +#ifdef mingw32_HOST_OS + allocaBytes sizeof_stat $ \ p_stat -> do + withFilePath name $ \p_name -> do + throwErrnoIfMinus1_ "setPermissions" $ do + c_stat p_name p_stat + mode <- st_mode p_stat + let mode1 = modifyBit r mode s_IRUSR + let mode2 = modifyBit w mode1 s_IWUSR + let mode3 = modifyBit (e || s) mode2 s_IXUSR + c_wchmod p_name mode3 + where + modifyBit :: Bool -> CMode -> CMode -> CMode + modifyBit False m b = m .&. (complement b) + modifyBit True m b = m .|. b +#else + stat <- Posix.getFileStatus name + let mode = Posix.fileMode stat + let mode1 = modifyBit r mode Posix.ownerReadMode + let mode2 = modifyBit w mode1 Posix.ownerWriteMode + let mode3 = modifyBit (e || s) mode2 Posix.ownerExecuteMode + Posix.setFileMode name mode3 + where + modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode + modifyBit False m b = m .&. (complement b) + modifyBit True m b = m .|. b +#endif - mode = read `unionCMode` (write `unionCMode` exec) +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "_wchmod" + c_wchmod :: CWString -> CMode -> IO CInt +#endif - withCString name $ \s -> - throwErrnoIfMinus1_ "setPermissions" $ c_chmod s mode +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions source dest = do +#ifdef mingw32_HOST_OS + allocaBytes sizeof_stat $ \ p_stat -> do + withFilePath source $ \p_source -> do + withFilePath dest $ \p_dest -> do + throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat + mode <- st_mode p_stat + throwErrnoIfMinus1_ "copyPermissions" $ c_wchmod p_dest mode +#else + stat <- Posix.getFileStatus source + let mode = Posix.fileMode stat + Posix.setFileMode dest mode +#endif ----------------------------------------------------------------------------- -- Implementation @@ -213,10 +314,69 @@ The path refers to an existing non-directory object. createDirectory :: FilePath -> IO () createDirectory path = do - withCString path $ \s -> do - throwErrnoIfMinus1Retry_ "createDirectory" $ - mkdir s 0o777 +#ifdef mingw32_HOST_OS + Win32.createDirectory path Nothing +#else + Posix.createDirectory path 0o777 +#endif + +#else /* !__GLASGOW_HASKELL__ */ + +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions fromFPath toFPath + = getPermissions fromFPath >>= setPermissions toFPath +#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 create_parents path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throw + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throw + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- try $ createDirectory dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exeption in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> (do +#ifdef mingw32_HOST_OS + withFileStatus "createDirectoryIfMissing" dir $ \st -> do + isDir <- isDirectory st + if isDir then return () + else throw e +#else + stat <- Posix.getFileStatus dir + if Posix.fileMode stat .&. Posix.directoryMode /= 0 + then return () + else throw e +#endif + ) `catch` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throw e + +#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 @@ -259,11 +419,34 @@ The operand refers to an existing non-directory object. -} removeDirectory :: FilePath -> IO () -removeDirectory path = do - modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s) +removeDirectory path = +#ifdef mingw32_HOST_OS + Win32.removeDirectory path +#else + Posix.removeDirectory path +#endif + +#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 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 $ throw (e :: SomeException) + 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 @@ -299,10 +482,12 @@ The operand refers to an existing directory. -} removeFile :: FilePath -> IO () -removeFile path = do - modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s) +removeFile path = +#if mingw32_HOST_OS + Win32.deleteFile path +#else + Posix.removeLink path +#endif {- |@'renameDirectory' old new@ changes the name of an existing directory from /old/ to /new/. If the /new/ directory @@ -354,17 +539,26 @@ Either path refers to an existing non-directory object. -} renameDirectory :: FilePath -> FilePath -> IO () -renameDirectory opath npath = +renameDirectory opath npath = do + -- XXX this test isn't performed atomically with the following rename +#ifdef mingw32_HOST_OS + -- ToDo: use Win32 API withFileStatus "renameDirectory" opath $ \st -> do is_dir <- isDirectory st +#else + stat <- Posix.getFileStatus opath + let is_dir = Posix.fileMode stat .&. Posix.directoryMode /= 0 +#endif if (not is_dir) - then ioException (IOError Nothing InappropriateType "renameDirectory" - ("not a directory") (Just opath)) + then ioException (ioeSetErrorString + (mkIOError InappropriateType "renameDirectory" Nothing (Just opath)) + "not a directory") else do - - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameDirectory" (c_rename s1 s2) +#ifdef mingw32_HOST_OS + Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING +#else + Posix.rename opath npath +#endif {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/. If the /new/ object already @@ -411,18 +605,164 @@ Either path refers to an existing directory. -} renameFile :: FilePath -> FilePath -> IO () -renameFile opath npath = +renameFile opath npath = do + -- XXX this test isn't performed atomically with the following rename +#ifdef mingw32_HOST_OS + -- ToDo: use Win32 API withFileOrSymlinkStatus "renameFile" opath $ \st -> do is_dir <- isDirectory st +#else + stat <- Posix.getSymbolicLinkStatus opath + let is_dir = Posix.fileMode stat .&. Posix.directoryMode /= 0 +#endif if is_dir - then ioException (IOError Nothing InappropriateType "renameFile" - "is a directory" (Just opath)) + then ioException (ioeSetErrorString + (mkIOError InappropriateType "renameFile" Nothing (Just opath)) + "is a directory") else do +#ifdef mingw32_HOST_OS + Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING +#else + Posix.rename opath npath +#endif + +#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. The permissions of /old/ are +copied to /new/, if possible. +-} + +copyFile :: FilePath -> FilePath -> IO () +#ifdef __NHC__ +copyFile fromFPath toFPath = + do readFile fromFPath >>= writeFile toFPath + Prelude.catch (copyPermissions fromFPath toFPath) + (\_ -> return ()) +#else +copyFile fromFPath toFPath = + copy `Prelude.catch` (\exc -> throw $ ioeSetLocation exc "copyFile") + where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> + bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> + do allocaBytes bufferSize $ copyContents hFrom hTmp + hClose hTmp + ignoreIOExceptions $ copyPermissions fromFPath tmpFPath + renameFile tmpFPath toFPath + openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" + cleanTmp (tmpFPath, hTmp) + = do ignoreIOExceptions $ hClose hTmp + ignoreIOExceptions $ removeFile tmpFPath + bufferSize = 1024 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer + + ignoreIOExceptions io = io `catch` ioExceptionIgnorer + ioExceptionIgnorer :: IOException -> IO () + ioExceptionIgnorer _ = return () +#endif + +-- | 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 = +#if defined(mingw32_HOST_OS) + do path <- Win32.getFullPathName fpath +#else + withCString fpath $ \pInPath -> + allocaBytes long_path_size $ \pOutPath -> + do c_realpath pInPath pOutPath + path <- peekCString pOutPath +#endif + return (normalise path) + -- normalise does more stuff, like upper-casing the drive letter + +#if defined(mingw32_HOST_OS) +foreign import stdcall unsafe "GetFullPathNameA" + c_GetFullPathName :: CString + -> CInt + -> CString + -> Ptr CString + -> IO CInt +#else +foreign import ccall unsafe "realpath" + c_realpath :: CString + -> CString + -> IO CString +#endif + +-- | 'makeRelative' the current directory. +makeRelativeToCurrentDirectory :: FilePath -> IO FilePath +makeRelativeToCurrentDirectory x = do + cur <- getCurrentDirectory + return $ makeRelative cur x + +-- | 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 an executable with the given +-- name was not found. For example (findExecutable \"ghc\") gives you +-- the path to GHC. +-- +-- The path returned by 'findExecutable' corresponds to the +-- program that would be executed by 'System.Process.createProcess' +-- when passed the same string (as a RawCommand, not a ShellCommand). +-- +-- On Windows, 'findExecutable' calls the Win32 function 'SearchPath', +-- which may search other places before checking the directories in +-- @PATH@. Where it actually searches depends on registry settings, +-- but notably includes the directory containing the current +-- executable. See +-- for more +-- details. +-- +findExecutable :: String -> IO (Maybe FilePath) +findExecutable binary = +#if defined(mingw32_HOST_OS) + withCString binary $ \c_binary -> + withCString ('.':exeExtension) $ \c_ext -> + allocaBytes long_path_size $ \pOutPath -> + alloca $ \ppFilePart -> do + res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart + if res > 0 && res < fromIntegral long_path_size + then do fpath <- peekCString pOutPath + return (Just fpath) + else return Nothing + +foreign import stdcall unsafe "SearchPathA" + c_SearchPath :: CString + -> CString + -> CString + -> CInt + -> CString + -> Ptr CString + -> IO CInt +#else + do + path <- getEnv "PATH" + search (splitSearchPath path) + where + fileName = binary <.> exeExtension + + search :: [FilePath] -> IO (Maybe FilePath) + search [] = return Nothing + search (d:ds) = do + let path = d fileName + b <- doesFileExist path + if b then return (Just path) + else search ds +#endif - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2) +#ifndef __HUGS__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries in /dir/. @@ -455,38 +795,39 @@ The path refers to an existing non-directory object. -} getDirectoryContents :: FilePath -> IO [FilePath] -getDirectoryContents path = do - modifyIOError (`ioeSetFileName` path) $ - alloca $ \ ptr_dEnt -> - bracket - (withCString path $ \s -> - throwErrnoIfNullRetry desc (c_opendir s)) - (\p -> throwErrnoIfMinus1_ desc (c_closedir p)) - (\p -> loop ptr_dEnt p) +getDirectoryContents path = + modifyIOError ((`ioeSetFileName` path) . + (`ioeSetLocation` "getDirectoryContents")) $ do +#ifndef mingw32_HOST_OS + bracket + (Posix.openDirStream path) + Posix.closeDirStream + loop + where + loop dirp = do + e <- Posix.readDirStream dirp + if null e then return [] else do + es <- loop dirp + return (e:es) +#else + bracket + (Win32.findFirstFile (path "*")) + (\(h,_) -> Win32.findClose h) + (\(h,fdat) -> loop h fdat []) where - desc = "getDirectoryContents" - - loop :: Ptr (Ptr CDirent) -> Ptr CDir -> IO [String] - loop ptr_dEnt dir = do - resetErrno - r <- readdir dir ptr_dEnt - if (r == 0) - then do - dEnt <- peek ptr_dEnt - if (dEnt == nullPtr) - then return [] - else do - entry <- (d_name dEnt >>= peekCString) - freeDirEnt dEnt - entries <- loop ptr_dEnt dir - return (entry:entries) - else do errno <- getErrno - if (errno == eINTR) then loop ptr_dEnt dir else do - let (Errno eo) = errno - if (eo == end_of_dir) - then return [] - else throwErrno desc + -- we needn't worry about empty directories: adirectory always + -- has at least "." and ".." entries + loop :: Win32.HANDLE -> Win32.FindData -> [FilePath] -> IO [FilePath] + loop h fdat acc = do + filename <- Win32.getFindDataFileName fdat + more <- Win32.findNextFile h fdat + if more + then loop h fdat (filename:acc) + else return (filename:acc) + -- no need to reverse, ordering is undefined +#endif /* mingw32 */ +#endif /* !__HUGS__ */ {- |If the operating system has a notion of current directories, @@ -514,23 +855,14 @@ Insufficient resources are available to perform the operation. The operating system has no notion of current directory. -} - +#ifdef __GLASGOW_HASKELL__ getCurrentDirectory :: IO FilePath getCurrentDirectory = do - p <- mallocBytes long_path_size - go p long_path_size - where go p bytes = do - p' <- c_getcwd p (fromIntegral bytes) - if p' /= nullPtr - then do s <- peekCString p' - free p' - return s - else do errno <- getErrno - if errno == eRANGE - then do let bytes' = bytes * 2 - p' <- reallocBytes p bytes' - go p' bytes' - else throwErrno "getCurrentDirectory" +#ifdef mingw32_HOST_OS + Win32.getCurrentDirectory +#else + Posix.getWorkingDirectory +#endif {- |If the operating system has a notion of current directories, @'setCurrentDirectory' dir@ changes the current @@ -565,31 +897,43 @@ The path refers to an existing non-directory object. -} setCurrentDirectory :: FilePath -> IO () -setCurrentDirectory path = do - modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s) - -- ToDo: add path to error +setCurrentDirectory path = +#ifdef mingw32_HOST_OS + Win32.setCurrentDirectory path +#else + Posix.changeWorkingDirectory path +#endif +#endif /* __GLASGOW_HASKELL__ */ + +#ifndef __HUGS__ {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is a directory, and 'False' otherwise. -} doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist name = - catch +doesDirectoryExist name = +#ifdef mingw32_HOST_OS (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) - (\ _ -> return False) +#else + (do stat <- Posix.getFileStatus name + return (Posix.fileMode stat .&. Posix.directoryMode /= 0)) +#endif + `catch` ((\ _ -> return False) :: IOException -> IO Bool) {- |The operation 'doesFileExist' returns 'True' if the argument file exists and is not a directory, and 'False' otherwise. -} doesFileExist :: FilePath -> IO Bool -doesFileExist name = do - catch +doesFileExist name = +#ifdef mingw32_HOST_OS (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) - (\ _ -> return False) +#else + (do stat <- Posix.getFileStatus name + return (Posix.fileMode stat .&. Posix.directoryMode == 0)) +#endif + `catch` ((\ _ -> return False) :: IOException -> IO Bool) {- |The 'getModificationTime' operation returns the clock time at which the file or directory was last modified. @@ -604,15 +948,26 @@ The operation may fail with: -} getModificationTime :: FilePath -> IO ClockTime -getModificationTime name = - withFileStatus "getModificationTime" name $ \ st -> +getModificationTime name = do +#ifdef mingw32_HOST_OS + -- ToDo: use Win32 API + withFileStatus "getModificationTime" name $ \ st -> do modificationTime st +#else + stat <- Posix.getFileStatus name + let realToInteger = round . realToFrac :: Real a => a -> Integer + return (TOD (realToInteger (Posix.modificationTime stat)) 0) +#endif + + +#endif /* !__HUGS__ */ +#ifdef mingw32_HOST_OS withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a withFileStatus loc name f = do modifyIOError (`ioeSetFileName` name) $ allocaBytes sizeof_stat $ \p -> - withCString (fileNameEndClean name) $ \s -> do + withFilePath (fileNameEndClean name) $ \s -> do throwErrnoIfMinus1Retry_ loc (c_stat s p) f p @@ -620,14 +975,15 @@ withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a withFileOrSymlinkStatus loc name f = do modifyIOError (`ioeSetFileName` name) $ allocaBytes sizeof_stat $ \p -> - withCString name $ \s -> do + withFilePath name $ \s -> do throwErrnoIfMinus1Retry_ loc (lstat s p) f p modificationTime :: Ptr CStat -> IO ClockTime modificationTime stat = do mtime <- st_mtime stat - return (TOD (toInteger (mtime :: CTime)) 0) + let realToInteger = round . realToFrac :: Real a => a -> Integer + return (TOD (realToInteger (mtime :: CTime)) 0) isDirectory :: Ptr CStat -> IO Bool isDirectory stat = do @@ -635,31 +991,201 @@ isDirectory stat = do return (s_isdir mode) fileNameEndClean :: String -> String -fileNameEndClean name = - if i > 0 && (ec == '\\' || ec == '/') then - fileNameEndClean (take i name) - else - name - where - i = (length name) - 1 - ec = name !! i +fileNameEndClean name = if isDrive name then addTrailingPathSeparator name + else dropTrailingPathSeparator name -emptyCMode :: CMode -emptyCMode = 0 +foreign import ccall unsafe "HsDirectory.h __hscore_R_OK" r_OK :: CInt +foreign import ccall unsafe "HsDirectory.h __hscore_W_OK" w_OK :: CInt +foreign import ccall unsafe "HsDirectory.h __hscore_X_OK" x_OK :: CInt -unionCMode :: CMode -> CMode -> CMode -unionCMode = (+) +foreign import ccall unsafe "HsDirectory.h __hscore_S_IRUSR" s_IRUSR :: CMode +foreign import ccall unsafe "HsDirectory.h __hscore_S_IWUSR" s_IWUSR :: CMode +foreign import ccall unsafe "HsDirectory.h __hscore_S_IXUSR" s_IXUSR :: CMode +foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode +#endif +#ifdef __GLASGOW_HASKELL__ foreign import ccall unsafe "__hscore_long_path_size" long_path_size :: Int +#else +long_path_size :: Int +long_path_size = 2048 -- // guess? +#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 defined(mingw32_HOST_OS) + allocaBytes long_path_size $ \pPath -> do + r0 <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath + if (r0 < 0) + then do + r1 <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath + when (r1 < 0) (raiseUnsupported "System.Directory.getHomeDirectory") + else return () + 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 -foreign import ccall unsafe "__hscore_R_OK" r_OK :: CMode -foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode -foreign import ccall unsafe "__hscore_X_OK" x_OK :: CMode +> C:/Documents And Settings/user/Application Data/appName -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 +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 defined(mingw32_HOST_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath + when (r<0) (raiseUnsupported "System.Directory.getAppUserDataDirectory") + 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 defined(mingw32_HOST_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath + when (r<0) (raiseUnsupported "System.Directory.getUserDocumentsDirectory") + 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 defined(mingw32_HOST_OS) + Win32.getTemporaryDirectory +#else + getEnv "TMPDIR" +#if !__NHC__ + `Prelude.catch` \e -> if isDoesNotExistError e then return "/tmp" + else throw e +#else + `Prelude.catch` (\ex -> return "/tmp") +#endif +#endif + +#if defined(mingw32_HOST_OS) +foreign import ccall unsafe "__hscore_getFolderPath" + 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 + +raiseUnsupported :: String -> IO () +raiseUnsupported loc = + ioException (ioeSetErrorString (mkIOError UnsupportedOperation loc Nothing Nothing) "unsupported operation") + +#endif + +-- ToDo: This should be determined via autoconf (AC_EXEEXT) +-- | Extension for executable files +-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) +exeExtension :: String +#ifdef mingw32_HOST_OS +exeExtension = "exe" +#else +exeExtension = "" #endif