X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=800816fdd4f9c0cc7456df3518d4d3d9463f1458;hb=14792b24420df1e4bb818697b6705c07234833fa;hp=cafe759c635548d616769404613efef306fc2520;hpb=dd70cacd4793c4497136829c50ef31f330163638;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index cafe759..800816f 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 @@ -39,6 +42,7 @@ module System.Directory , copyFile -- :: FilePath -> FilePath -> IO () , canonicalizePath + , makeRelativeToCurrentDirectory , findExecutable -- * Existence tests @@ -65,30 +69,33 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where -import System.Directory.Internals +import Prelude hiding ( catch ) + import System.Environment ( getEnv ) -import System.IO.Error +import System.FilePath +import System.IO +import System.IO.Error hiding ( catch, try ) import Control.Monad ( when, unless ) +import Control.Exception #ifdef __NHC__ import Directory -import NHC.FFI +import System (system) #endif /* __NHC__ */ #ifdef __HUGS__ import Hugs.Directory #endif /* __HUGS__ */ -#ifdef __GLASGOW_HASKELL__ -import Prelude +import Foreign +import Foreign.C -import Control.Exception ( bracket ) +{-# CFILES cbits/directory.c #-} + +#ifdef __GLASGOW_HASKELL__ import System.Posix.Types import System.Posix.Internals import System.Time ( ClockTime(..) ) -import System.IO -import Foreign -import Foreign.C import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) @@ -97,7 +104,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. @@ -151,19 +158,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. @@ -194,6 +225,16 @@ setPermissions name (Permissions r w e s) = do modifyBit False m b = m .&. (complement b) modifyBit True m b = m .|. b + +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions source dest = do + 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 + ----------------------------------------------------------------------------- -- Implementation @@ -240,6 +281,13 @@ createDirectory path = do withCString path $ \s -> do throwErrnoIfMinus1Retry_ "createDirectory" $ mkdir s 0o777 + +#else /* !__GLASGOW_HASKELL__ */ + +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions fromFPath toFPath + = getPermissions fromFPath >>= setPermissions toFPath + #endif -- | @'createDirectoryIfMissing' parents dir@ creates a new directory @@ -250,11 +298,12 @@ createDirectoryIfMissing :: Bool -- ^ Create its parents too? -> IO () createDirectoryIfMissing parents file = do b <- doesDirectoryExist file - case (b,parents, file) of + case (b,parents, file) of (_, _, "") -> return () (True, _, _) -> return () - (_, True, _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file)) + (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file (_, False, _) -> createDirectory file + where mkParents = scanl1 () . splitDirectories . normalise #if __GLASGOW_HASKELL__ {- | @'removeDirectory' dir@ removes an existing directory /dir/. The @@ -311,7 +360,7 @@ removeDirectory path = do removeDirectoryRecursive :: FilePath -> IO () removeDirectoryRecursive startLoc = do cont <- getDirectoryContents startLoc - sequence_ [rm (startLoc `joinFileName` x) | x <- cont, x /= "." && x /= ".."] + sequence_ [rm (startLoc x) | x <- cont, x /= "." && x /= ".."] removeDirectory startLoc where rm :: FilePath -> IO () @@ -319,7 +368,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 () @@ -487,34 +536,40 @@ renameFile opath npath = {- |@'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. +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 = -#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600)) - do readFile fromFPath >>= writeFile toFPath - try (getPermissions fromFPath >>= setPermissions 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 (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 - - 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 exc -> + throw $ IOException $ ioeSetLocation exc "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 -#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 @@ -532,10 +587,12 @@ 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 "GetFullPathName" +foreign import stdcall unsafe "GetFullPathNameA" c_GetFullPathName :: CString -> CInt -> CString @@ -547,11 +604,12 @@ foreign import ccall unsafe "realpath" -> CString -> IO CString #endif -#else /* !__GLASGOW_HASKELL__ */ --- dummy implementation -canonicalizePath :: FilePath -> IO FilePath -canonicalizePath fpath = return fpath -#endif /* !__GLASGOW_HASKELL__ */ + +-- | '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 @@ -559,19 +617,42 @@ canonicalizePath fpath = return fpath -- such executable. For example (findExecutable \"ghc\") -- gives you the path to GHC. findExecutable :: String -> IO (Maybe FilePath) -findExecutable binary = do +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 (parseSearchPath path) + search (splitSearchPath path) where - fileName = binary `joinFileExt` exeExtension + fileName = binary <.> 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) + let path = d fileName + b <- doesFileExist path + if b then return (Just path) else search ds +#endif + #ifdef __GLASGOW_HASKELL__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries @@ -679,8 +760,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, @@ -787,25 +868,26 @@ 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 - -foreign import ccall unsafe "__hscore_long_path_size" - long_path_size :: Int +fileNameEndClean name = if isDrive name then addTrailingPathSeparator name + else dropTrailingPathSeparator name -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 +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 "__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 + +#else +long_path_size :: Int +long_path_size = 2048 -- // guess? #endif /* __GLASGOW_HASKELL__ */ @@ -832,13 +914,13 @@ cannot be found. -} getHomeDirectory :: IO FilePath getHomeDirectory = -#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) +#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 @@ -874,7 +956,7 @@ cannot be found. -} getAppUserDataDirectory :: String -> IO FilePath getAppUserDataDirectory appName = do -#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) +#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") @@ -908,7 +990,7 @@ cannot be found. -} getUserDocumentsDirectory :: IO FilePath getUserDocumentsDirectory = do -#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) +#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") @@ -945,16 +1027,23 @@ The function doesn\'t verify whether the path exists. -} getTemporaryDirectory :: IO FilePath getTemporaryDirectory = do -#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) +#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__ + `catch` \ex -> case ex of + IOException e | isDoesNotExistError e -> return "/tmp" + _ -> throw ex +#else + `catch` (\ex -> return "/tmp") +#endif #endif -#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) -foreign import stdcall unsafe "dirUtils.h __hscore_getFolderPath" +#if defined(mingw32_HOST_OS) +foreign import ccall unsafe "__hscore_getFolderPath" c_SHGetFolderPath :: Ptr () -> CInt -> Ptr () @@ -966,9 +1055,21 @@ 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 +foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt +raiseUnsupported :: String -> IO () raiseUnsupported loc = ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing) #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 +