X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=bd05bad4ec7f6357ab99b89f60bee0ded2a958c0;hb=8ba5e95fc14cdaef89980bae2bf5be01fea9757a;hp=6aeb40e60b40ee498f7513a69bf69601a9cd3e5a;hpb=0175c045fc080615e550218149f61dcd1d4624f7;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index 6aeb40e..bd05bad 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -21,7 +21,9 @@ module System.Directory -- * Actions on directories createDirectory -- :: FilePath -> IO () +#ifndef __NHC__ , createDirectoryIfMissing -- :: Bool -> FilePath -> IO () +#endif , removeDirectory -- :: FilePath -> IO () , removeDirectoryRecursive -- :: FilePath -> IO () , renameDirectory -- :: FilePath -> FilePath -> IO () @@ -63,6 +65,7 @@ module System.Directory , getPermissions -- :: FilePath -> IO Permissions , setPermissions -- :: FilePath -> Permissions -> IO () + , copyPermissions -- * Timestamps @@ -81,9 +84,9 @@ import Control.Monad ( when, unless ) import Control.Exception.Base #ifdef __NHC__ -import Directory hiding ( getDirectoryContents - , doesDirectoryExist, doesFileExist - , getModificationTime ) +import Directory -- hiding ( getDirectoryContents + -- , doesDirectoryExist, doesFileExist + -- , getModificationTime ) import System (system) #endif /* __NHC__ */ @@ -109,7 +112,7 @@ import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) #ifdef mingw32_HOST_OS import System.Posix.Types import System.Posix.Internals -import qualified System.Win32 +import qualified System.Win32 as Win32 #else import qualified System.Posix as Posix #endif @@ -172,8 +175,8 @@ The operation may fail with: getPermissions :: FilePath -> IO Permissions getPermissions name = do - withCString name $ \s -> do #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 :-) @@ -227,14 +230,14 @@ 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 + 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_chmod_ p_name mode3 + c_wchmod p_name mode3 where modifyBit :: Bool -> CMode -> CMode -> CMode modifyBit False m b = m .&. (complement b) @@ -253,19 +256,19 @@ setPermissions name (Permissions r w e s) = do #endif #ifdef mingw32_HOST_OS -foreign import ccall unsafe "chmod" - c_chmod_ :: CString -> CMode -> IO CInt +foreign import ccall unsafe "_wchmod" + c_wchmod :: CWString -> 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 + 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_chmod p_dest mode + throwErrnoIfMinus1_ "copyPermissions" $ c_wchmod p_dest mode #else stat <- Posix.getFileStatus source let mode = Posix.fileMode stat @@ -315,7 +318,7 @@ The path refers to an existing non-directory object. createDirectory :: FilePath -> IO () createDirectory path = do #ifdef mingw32_HOST_OS - System.Win32.createDirectory path Nothing + Win32.createDirectory path Nothing #else Posix.createDirectory path 0o777 #endif @@ -328,6 +331,7 @@ copyPermissions fromFPath toFPath #endif +#ifndef __NHC__ -- | @'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. @@ -375,6 +379,7 @@ createDirectoryIfMissing create_parents path0 #endif ) `catch` ((\_ -> return ()) :: IOException -> IO ()) | otherwise -> throw e +#endif /* !__NHC__ */ #if __GLASGOW_HASKELL__ {- | @'removeDirectory' dir@ removes an existing directory /dir/. The @@ -421,7 +426,7 @@ The operand refers to an existing non-directory object. removeDirectory :: FilePath -> IO () removeDirectory path = #ifdef mingw32_HOST_OS - System.Win32.removeDirectory path + Win32.removeDirectory path #else Posix.removeDirectory path #endif @@ -484,7 +489,7 @@ The operand refers to an existing directory. removeFile :: FilePath -> IO () removeFile path = #if mingw32_HOST_OS - System.Win32.deleteFile path + Win32.deleteFile path #else Posix.removeLink path #endif @@ -555,7 +560,7 @@ renameDirectory opath npath = do "not a directory") else do #ifdef mingw32_HOST_OS - System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING + Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING #else Posix.rename opath npath #endif @@ -621,7 +626,7 @@ renameFile opath npath = do "is a directory") else do #ifdef mingw32_HOST_OS - System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING + Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING #else Posix.rename opath npath #endif @@ -676,7 +681,7 @@ copyFile fromFPath toFPath = canonicalizePath :: FilePath -> IO FilePath canonicalizePath fpath = #if defined(mingw32_HOST_OS) - do path <- System.Win32.getFullPathName fpath + do path <- Win32.getFullPathName fpath #else withCString fpath $ \pInPath -> allocaBytes long_path_size $ \pOutPath -> @@ -686,14 +691,7 @@ canonicalizePath fpath = 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 +#if !defined(mingw32_HOST_OS) foreign import ccall unsafe "realpath" c_realpath :: CString -> CString @@ -727,24 +725,7 @@ makeRelativeToCurrentDirectory x = do 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 + Win32.searchPath Nothing binary ('.':exeExtension) #else do path <- getEnv "PATH" @@ -762,7 +743,7 @@ foreign import stdcall unsafe "SearchPathA" #endif -#ifndef __HUGS__ +#ifdef __GLASGOW_HASKELL__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries in /dir/. @@ -795,53 +776,39 @@ The path refers to an existing non-directory object. -} getDirectoryContents :: FilePath -> IO [FilePath] -getDirectoryContents path = do +getDirectoryContents path = + modifyIOError ((`ioeSetFileName` path) . + (`ioeSetLocation` "getDirectoryContents")) $ do #ifndef mingw32_HOST_OS - bracket - (Posix.openDirStream path) - Posix.closeDirStream - loop + 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) + es <- loop dirp + return (e:es) #else - -- ToDo: rewrite using System.Win32 - 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) + 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__ */ +#endif /* __GLASGOW_HASKELL__ */ {- |If the operating system has a notion of current directories, @@ -873,7 +840,7 @@ The operating system has no notion of current directory. getCurrentDirectory :: IO FilePath getCurrentDirectory = do #ifdef mingw32_HOST_OS - System.Win32.getCurrentDirectory + Win32.getCurrentDirectory #else Posix.getWorkingDirectory #endif @@ -913,14 +880,14 @@ The path refers to an existing non-directory object. setCurrentDirectory :: FilePath -> IO () setCurrentDirectory path = #ifdef mingw32_HOST_OS - System.Win32.setCurrentDirectory path + Win32.setCurrentDirectory path #else Posix.changeWorkingDirectory path #endif #endif /* __GLASGOW_HASKELL__ */ -#ifndef __HUGS__ +#ifdef __GLASGOW_HASKELL__ {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is a directory, and 'False' otherwise. -} @@ -974,14 +941,14 @@ getModificationTime name = do #endif -#endif /* !__HUGS__ */ +#endif /* __GLASGOW_HASKELL__ */ #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 @@ -989,7 +956,7 @@ 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 @@ -1008,10 +975,6 @@ fileNameEndClean :: String -> String fileNameEndClean name = if isDrive name then addTrailingPathSeparator name else dropTrailingPathSeparator name -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 "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 @@ -1050,17 +1013,18 @@ cannot be found. -} getHomeDirectory :: IO FilePath getHomeDirectory = + modifyIOError ((`ioeSetLocation` "getHomeDirectory")) $ do #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 + r <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_PROFILE nullPtr 0 + case (r :: Either IOException String) of + Right s -> return s + Left _ -> do + r1 <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_WINDOWS nullPtr 0 + case r1 of + Right s -> return s + Left e -> ioError (e :: IOException) #else - getEnv "HOME" + getEnv "HOME" #endif {- | Returns the pathname of a directory in which application-specific @@ -1092,15 +1056,13 @@ cannot be found. -} getAppUserDataDirectory :: String -> IO FilePath getAppUserDataDirectory appName = do + modifyIOError ((`ioeSetLocation` "getAppUserDataDirectory")) $ 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) + s <- Win32.sHGetFolderPath nullPtr Win32.cSIDL_APPDATA nullPtr 0 + return (s++'\\':appName) #else - path <- getEnv "HOME" - return (path++'/':'.':appName) + path <- getEnv "HOME" + return (path++'/':'.':appName) #endif {- | Returns the current user's document directory. @@ -1126,13 +1088,11 @@ cannot be found. -} getUserDocumentsDirectory :: IO FilePath getUserDocumentsDirectory = do + modifyIOError ((`ioeSetLocation` "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 + Win32.sHGetFolderPath nullPtr Win32.cSIDL_PERSONAL nullPtr 0 #else - getEnv "HOME" + getEnv "HOME" #endif {- | Returns the current directory for temporary files. @@ -1164,7 +1124,7 @@ The function doesn\'t verify whether the path exists. getTemporaryDirectory :: IO FilePath getTemporaryDirectory = do #if defined(mingw32_HOST_OS) - System.Win32.getTemporaryDirectory + Win32.getTemporaryDirectory #else getEnv "TMPDIR" #if !__NHC__ @@ -1175,25 +1135,6 @@ getTemporaryDirectory = do #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)