X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=6aeb40e60b40ee498f7513a69bf69601a9cd3e5a;hb=0175c045fc080615e550218149f61dcd1d4624f7;hp=d7a6dc66da00d28df5acd39cffb884b4fbdc0689;hpb=c93cdac729f2ae1ca178718e25818764f749366d;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index d7a6dc6..6aeb40e 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -72,6 +72,7 @@ module System.Directory import Prelude hiding ( catch ) import qualified Prelude +import Control.Monad (guard) import System.Environment ( getEnv ) import System.FilePath import System.IO @@ -80,7 +81,9 @@ import Control.Monad ( when, unless ) import Control.Exception.Base #ifdef __NHC__ -import Directory +import Directory hiding ( getDirectoryContents + , doesDirectoryExist, doesFileExist + , getModificationTime ) import System (system) #endif /* __NHC__ */ @@ -93,12 +96,23 @@ import Foreign.C {-# CFILES cbits/directory.c #-} -#ifdef __GLASGOW_HASKELL__ -import System.Posix.Types -import System.Posix.Internals import System.Time ( ClockTime(..) ) +#ifdef __GLASGOW_HASKELL__ + +#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 +#else +import qualified System.Posix as Posix +#endif {- $intro A directory contains a series of entries, each of which is a named @@ -182,17 +196,17 @@ getPermissions name = do } ) #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 + 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_ok == 0, - writable = write_ok == 0, - executable = not is_dir && exec_ok == 0, - searchable = is_dir && exec_ok == 0 + readable = read_ok, + writable = write_ok, + executable = not is_dir && exec_ok, + searchable = is_dir && exec_ok } ) #endif @@ -211,6 +225,7 @@ The operation may fail with: setPermissions :: FilePath -> Permissions -> IO () setPermissions name (Permissions r w e s) = do +#ifdef mingw32_HOST_OS allocaBytes sizeof_stat $ \ p_stat -> do withCString name $ \p_name -> do throwErrnoIfMinus1_ "setPermissions" $ do @@ -219,22 +234,43 @@ setPermissions name (Permissions r w e s) = do let mode1 = modifyBit r mode s_IRUSR let mode2 = modifyBit w mode1 s_IWUSR let mode3 = modifyBit (e || s) mode2 s_IXUSR - c_chmod p_name mode3 - + c_chmod_ 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 +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "chmod" + c_chmod_ :: CString -> CMode -> IO CInt +#endif copyPermissions :: FilePath -> FilePath -> IO () copyPermissions source dest = do +#ifdef mingw32_HOST_OS allocaBytes sizeof_stat $ \ p_stat -> do withCString source $ \p_source -> do withCString dest $ \p_dest -> do throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat mode <- st_mode p_stat throwErrnoIfMinus1_ "copyPermissions" $ c_chmod p_dest mode +#else + stat <- Posix.getFileStatus source + let mode = Posix.fileMode stat + Posix.setFileMode dest mode +#endif ----------------------------------------------------------------------------- -- Implementation @@ -278,10 +314,11 @@ 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 +#ifdef mingw32_HOST_OS + System.Win32.createDirectory path Nothing +#else + Posix.createDirectory path 0o777 +#endif #else /* !__GLASGOW_HASKELL__ */ @@ -297,14 +334,47 @@ copyPermissions fromFPath toFPath 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) $ mkParents file - (_, False, _) -> createDirectory file - where mkParents = scanl1 () . splitDirectories . normalise +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 @@ -349,10 +419,13 @@ 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 + System.Win32.removeDirectory path +#else + Posix.removeDirectory path +#endif + #endif -- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ @@ -409,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 + System.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 @@ -464,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 + System.Win32.moveFileEx opath npath System.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 @@ -521,17 +605,26 @@ 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 - - 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 + Posix.rename opath npath +#endif #endif /* __GLASGOW_HASKELL__ */ @@ -582,15 +675,14 @@ copyFile fromFPath toFPath = -- 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 + do path <- System.Win32.getFullPathName fpath #else + withCString fpath $ \pInPath -> + allocaBytes long_path_size $ \pOutPath -> do c_realpath pInPath pOutPath -#endif path <- peekCString pOutPath +#endif return (normalise path) -- normalise does more stuff, like upper-casing the drive letter @@ -614,11 +706,24 @@ 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 there isn't --- such executable. For example (findExecutable \"ghc\") --- gives you the path to GHC. +-- | 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) @@ -657,7 +762,7 @@ foreign import stdcall unsafe "SearchPathA" #endif -#ifdef __GLASGOW_HASKELL__ +#ifndef __HUGS__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries in /dir/. @@ -691,6 +796,19 @@ The path refers to an existing non-directory object. getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path = 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 + -- ToDo: rewrite using System.Win32 modifyIOError (`ioeSetFileName` path) $ alloca $ \ ptr_dEnt -> bracket @@ -717,11 +835,13 @@ getDirectoryContents path = do 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 + let (Errno eo) = errno + if (eo == end_of_dir) + then return [] + else throwErrno desc +#endif /* mingw32 */ +#endif /* !__HUGS__ */ {- |If the operating system has a notion of current directories, @@ -749,23 +869,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 + System.Win32.getCurrentDirectory +#else + Posix.getWorkingDirectory +#endif {- |If the operating system has a notion of current directories, @'setCurrentDirectory' dir@ changes the current @@ -800,19 +911,28 @@ 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 + System.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 = +#ifdef mingw32_HOST_OS (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) +#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' @@ -821,7 +941,12 @@ if the argument file exists and is not a directory, and 'False' otherwise. doesFileExist :: FilePath -> IO Bool doesFileExist name = +#ifdef mingw32_HOST_OS (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) +#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 @@ -837,10 +962,21 @@ 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) $ @@ -872,24 +1008,23 @@ fileNameEndClean :: String -> String 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 -foreign import ccall unsafe "__hscore_X_OK" x_OK :: CInt +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 -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 "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. @@ -1029,9 +1164,7 @@ The function doesn\'t verify whether the path exists. getTemporaryDirectory :: IO FilePath getTemporaryDirectory = do #if defined(mingw32_HOST_OS) - allocaBytes long_path_size $ \pPath -> do - _r <- c_GetTempPath (fromIntegral long_path_size) pPath - peekCString pPath + System.Win32.getTemporaryDirectory #else getEnv "TMPDIR" #if !__NHC__ @@ -1055,11 +1188,9 @@ 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 "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt - raiseUnsupported :: String -> IO () raiseUnsupported loc = - ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing) + ioException (ioeSetErrorString (mkIOError UnsupportedOperation loc Nothing Nothing) "unsupported operation") #endif @@ -1072,4 +1203,3 @@ exeExtension = "exe" #else exeExtension = "" #endif -