X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=364f083549f07910316097b6d11807ecb9329008;hb=8a2b8790502da776df1486e7b366c68f33b1722f;hp=a9d15f591102a141c7b907b525ced940159d732a;hpb=8353b621b0ad24a1b5272ca9035581aa74ef7147;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index a9d15f5..364f083 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -72,13 +72,17 @@ import Control.Monad ( when, unless ) #ifdef __NHC__ import Directory -import NHC.FFI #endif /* __NHC__ */ #ifdef __HUGS__ import Hugs.Directory #endif /* __HUGS__ */ +import Foreign +import Foreign.C + +{-# CFILES cbits/directory.c #-} + #ifdef __GLASGOW_HASKELL__ import Prelude @@ -87,8 +91,6 @@ 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 ) @@ -504,7 +506,37 @@ 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. +-} + +{- 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 () copyFile fromFPath toFPath = @@ -531,7 +563,6 @@ copyFile fromFPath toFPath = 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 @@ -552,7 +583,7 @@ canonicalizePath fpath = peekCString pOutPath #if defined(mingw32_HOST_OS) -foreign import stdcall unsafe "GetFullPathName" +foreign import stdcall unsafe "GetFullPathNameA" c_GetFullPathName :: CString -> CInt -> CString @@ -564,11 +595,6 @@ 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__ */ -- | Given an executable file name, searches for such file -- in the directories listed in system PATH. The returned value @@ -576,7 +602,28 @@ 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) where @@ -589,6 +636,8 @@ findExecutable binary = do b <- doesFileExist path if b then return (Just path) else search ds +#endif + #ifdef __GLASGOW_HASKELL__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries @@ -813,17 +862,21 @@ fileNameEndClean name = i = (length name) - 1 ec = name !! i -foreign import ccall unsafe "__hscore_long_path_size" - long_path_size :: Int - -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 +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. @@ -849,7 +902,7 @@ 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) @@ -891,7 +944,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") @@ -925,7 +978,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") @@ -962,7 +1015,7 @@ 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 peekCString pPath @@ -970,7 +1023,7 @@ getTemporaryDirectory = do catch (getEnv "TMPDIR") (\ex -> return "/tmp") #endif -#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) foreign import ccall unsafe "__hscore_getFolderPath" c_SHGetFolderPath :: Ptr () -> CInt @@ -983,7 +1036,7 @@ 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 loc = ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)