X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=5da67b691ff3e71521d8c83edc548ba3e3a04b4d;hb=4265c3f9425684443ce11c78dfd7dfd05de0c88a;hp=fd6774c082b1d3ae25e6f9c8fad9445091138f89;hpb=1e7b1d58aab549ad7efc2b0f33d5b13872c6e004;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index fd6774c..5da67b6 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 @@ -66,13 +69,19 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where +import Prelude hiding ( catch ) +import qualified Prelude + import System.Environment ( getEnv ) import System.FilePath -import System.IO.Error +import System.IO +import System.IO.Error hiding ( catch, try ) import Control.Monad ( when, unless ) +import Control.Exception.Base #ifdef __NHC__ import Directory +import System (system) #endif /* __NHC__ */ #ifdef __HUGS__ @@ -85,22 +94,24 @@ import Foreign.C {-# CFILES cbits/directory.c #-} #ifdef __GLASGOW_HASKELL__ -import Prelude - -import Control.Exception ( bracket ) import System.Posix.Types import System.Posix.Internals import System.Time ( ClockTime(..) ) -import System.IO import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) +#ifdef mingw32_HOST_OS +import qualified System.Win32 +#else +import qualified System.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. @@ -154,19 +165,43 @@ 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 +#ifdef mingw32_HOST_OS + -- 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 <- c_access s r_OK + write_ok <- c_access s w_OK + exec_ok <- c_access s x_OK withFileStatus "getPermissions" name $ \st -> do is_dir <- isDirectory st return ( Permissions { - readable = read == 0, - writable = write == 0, - executable = not is_dir && exec == 0, - searchable = is_dir && exec == 0 + readable = read_ok == 0, + writable = write_ok == 0, + executable = not is_dir && exec_ok == 0, + searchable = is_dir && exec_ok == 0 } ) +#endif {- |The 'setPermissions' operation sets the permissions for the file or directory. @@ -340,7 +375,7 @@ removeDirectoryRecursive startLoc = do case temp of Left e -> do isDir <- doesDirectoryExist f -- If f is not a directory, re-throw the error - unless isDir $ ioError e + unless isDir $ throw (e :: SomeException) removeDirectoryRecursive f Right _ -> return () @@ -436,16 +471,18 @@ Either path refers to an existing non-directory object. renameDirectory :: FilePath -> FilePath -> IO () renameDirectory opath npath = + -- XXX this test isn't performed atomically with the following rename withFileStatus "renameDirectory" opath $ \st -> do is_dir <- isDirectory st if (not is_dir) then ioException (IOError Nothing InappropriateType "renameDirectory" ("not a directory") (Just opath)) else do - - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameDirectory" (c_rename s1 s2) +#ifdef mingw32_HOST_OS + System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING +#else + System.Posix.rename s1 s2 +#endif {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/. If the /new/ object already @@ -493,16 +530,18 @@ Either path refers to an existing directory. renameFile :: FilePath -> FilePath -> IO () renameFile opath npath = + -- XXX this test isn't performed atomically with the following rename withFileOrSymlinkStatus "renameFile" opath $ \st -> do is_dir <- isDirectory st if is_dir then ioException (IOError Nothing InappropriateType "renameFile" "is a directory" (Just opath)) else do - - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2) +#ifdef mingw32_HOST_OS + System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING +#else + System.Posix.rename s1 s2 +#endif #endif /* __GLASGOW_HASKELL__ */ @@ -512,57 +551,36 @@ Neither path may refer to an existing directory. The permissions of /old/ are copied to /new/, if possible. -} -{- NOTES: - -It's tempting to try to remove the target file before opening it for -writing. This could be useful: for example if the target file is an -executable that is in use, writing will fail, but unlinking first -would succeed. - -However, it certainly isn't always what you want. - - * if the target file is hardlinked, removing it would break - the hard link, but just opening would preserve it. - - * opening and truncating will preserve permissions and - ACLs on the target. - - * If the destination file is read-only in a writable directory, - we might want copyFile to fail. Removing the target first - would succeed, however. - - * If the destination file is special (eg. /dev/null), removing - it is probably not the right thing. Copying to /dev/null - should leave /dev/null intact, not replace it with a plain - file. - - * There's a small race condition between removing the target and - opening it for writing during which time someone might - create it again. --} copyFile :: FilePath -> FilePath -> IO () +#ifdef __NHC__ copyFile fromFPath toFPath = -#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600)) - do readFile fromFPath >>= writeFile toFPath - try (copyPermissions fromFPath toFPath) - return () + do readFile fromFPath >>= writeFile toFPath + Prelude.catch (copyPermissions fromFPath toFPath) + (\_ -> return ()) #else - (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> - bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo -> - allocaBytes bufferSize $ \buffer -> do - copyContents hFrom hTo buffer - try (copyPermissions fromFPath toFPath) - return ()) `catch` (ioError . changeFunName) - where - bufferSize = 1024 - - changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp - - copyContents hFrom hTo buffer = do - count <- hGetBuf hFrom buffer bufferSize - when (count > 0) $ do - hPutBuf hTo buffer count - copyContents hFrom hTo buffer +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 @@ -582,7 +600,9 @@ canonicalizePath fpath = #else do c_realpath pInPath pOutPath #endif - peekCString pOutPath + path <- peekCString pOutPath + return (normalise path) + -- normalise does more stuff, like upper-casing the drive letter #if defined(mingw32_HOST_OS) foreign import stdcall unsafe "GetFullPathNameA" @@ -753,8 +773,8 @@ getCurrentDirectory = do else do errno <- getErrno if errno == eRANGE then do let bytes' = bytes * 2 - p' <- reallocBytes p bytes' - go p' bytes' + p'' <- reallocBytes p bytes' + go p'' bytes' else throwErrno "getCurrentDirectory" {- |If the operating system has a notion of current directories, @@ -801,20 +821,18 @@ exists and is a directory, and 'False' otherwise. -} doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist name = - catch +doesDirectoryExist name = (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) - (\ _ -> return False) + `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 = (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) - (\ _ -> return False) + `catch` ((\ _ -> return False) :: IOException -> IO Bool) {- |The 'getModificationTime' operation returns the clock time at which the file or directory was last modified. @@ -861,14 +879,8 @@ 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 foreign import ccall unsafe "__hscore_R_OK" r_OK :: CInt foreign import ccall unsafe "__hscore_W_OK" w_OK :: CInt @@ -877,6 +889,9 @@ foreign import ccall unsafe "__hscore_X_OK" x_OK :: CInt 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 +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode +#endif foreign import ccall unsafe "__hscore_long_path_size" long_path_size :: Int @@ -912,11 +927,11 @@ getHomeDirectory :: IO FilePath getHomeDirectory = #if defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do - r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath - if (r < 0) + r0 <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath + if (r0 < 0) then do - r <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath - when (r < 0) (raiseUnsupported "System.Directory.getHomeDirectory") + r1 <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath + when (r1 < 0) (raiseUnsupported "System.Directory.getHomeDirectory") else return () peekCString pPath #else @@ -1025,10 +1040,16 @@ getTemporaryDirectory :: IO FilePath getTemporaryDirectory = do #if defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do - r <- c_GetTempPath (fromIntegral long_path_size) pPath + _r <- c_GetTempPath (fromIntegral long_path_size) pPath peekCString pPath #else - catch (getEnv "TMPDIR") (\ex -> return "/tmp") + 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) @@ -1046,6 +1067,7 @@ foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt +raiseUnsupported :: String -> IO () raiseUnsupported loc = ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)