X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=42ed6afe51c88e85171a9ef3763c419ee7815c6a;hb=e5bc07906c3690afa056029f94e6aae5ef4dbaa6;hp=3301ed3d2f93268ad96871703a713afd634100c6;hpb=e3a4b0478ada7409027379fdf104419a46e219a7;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index 3301ed3..42ed6af 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -66,13 +66,18 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where +import Prelude hiding ( catch ) + 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 #ifdef __NHC__ import Directory +import System (system) #endif /* __NHC__ */ #ifdef __HUGS__ @@ -85,13 +90,9 @@ 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 ) @@ -100,7 +101,7 @@ 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,6 +155,29 @@ The operation may fail with: getPermissions :: FilePath -> IO Permissions getPermissions name = do withCString name $ \s -> do +#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 read = mode .&. s_IRUSR + let write = mode .&. s_IWUSR + let exec = mode .&. s_IXUSR + let is_dir = mode .&. s_IFDIR + return ( + Permissions { + readable = read /= 0, + writable = write /= 0, + executable = is_dir == 0 && exec /= 0, + searchable = is_dir /= 0 && exec /= 0 + } + ) +#else read <- c_access s r_OK write <- c_access s w_OK exec <- c_access s x_OK @@ -167,6 +191,7 @@ getPermissions name = do searchable = is_dir && exec == 0 } ) +#endif {- |The 'setPermissions' operation sets the permissions for the file or directory. @@ -340,7 +365,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 removeDirectoryRecursive f Right _ -> return () @@ -512,57 +537,34 @@ 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 + try (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 `catch` (\e -> case e of + IOException e -> + throw $ IOException $ ioeSetLocation e "copyFile" + _ -> throw e) + where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> + bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> + do allocaBytes bufferSize $ copyContents hFrom hTmp + hClose hTmp + try (copyPermissions fromFPath tmpFPath) + renameFile tmpFPath toFPath + openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" + cleanTmp (tmpFPath, hTmp) = do try $ hClose hTmp + try $ 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 #endif -- | Given path referring to a file or directory, returns a @@ -871,6 +873,7 @@ 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 +foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode foreign import ccall unsafe "__hscore_long_path_size" long_path_size :: Int