X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=e5e988fa88222c7f0917c1e66f91b55bec3b0e94;hb=a70f356e023abdd0abb130cc149b0e3de7469044;hp=b3c09e1fd44029bbb97b33e95fe001ce2cd1b37a;hpb=9281b993a3001cfac3613121396e932c321e52b8;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index b3c09e1..e5e988f 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -65,8 +65,8 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where +import System.Directory.Internals import System.Environment ( getEnv ) -import System.FilePath import System.IO.Error import Control.Monad ( when, unless ) @@ -79,6 +79,11 @@ import NHC.FFI import Hugs.Directory #endif /* __HUGS__ */ +#if defined(__GLASGOW_HASKELL__) || defined(mingw32_HOST_OS) +import Foreign +import Foreign.C +#endif + #ifdef __GLASGOW_HASKELL__ import Prelude @@ -87,8 +92,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 ) @@ -194,6 +197,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 +253,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 @@ -487,20 +507,50 @@ 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 = #if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600)) do readFile fromFPath >>= writeFile toFPath - try (getPermissions fromFPath >>= setPermissions 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) + try (copyPermissions fromFPath toFPath) return ()) `catch` (ioError . changeFunName) where bufferSize = 1024 @@ -519,14 +569,14 @@ copyFile fromFPath toFPath = -- canonicalized path, with the intent that two paths referring -- to the same file\/directory will map to the same canonicalized -- path. Note that it is impossible to guarantee that the --- implication (same file\/dir <=> same canonicalizedPath) holds +-- implication (same file\/dir \<=\> same canonicalizedPath) holds -- in either direction: this function can make only a best-effort -- attempt. canonicalizePath :: FilePath -> IO FilePath canonicalizePath fpath = withCString fpath $ \pInPath -> allocaBytes long_path_size $ \pOutPath -> -#if defined(mingw32_TARGET_OS) +#if defined(mingw32_HOST_OS) alloca $ \ppFilePart -> do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart #else @@ -534,8 +584,8 @@ canonicalizePath fpath = #endif peekCString pOutPath -#if defined(mingw32_TARGET_OS) -foreign import stdcall unsafe "GetFullPathName" +#if defined(mingw32_HOST_OS) +foreign import stdcall unsafe "GetFullPathNameA" c_GetFullPathName :: CString -> CInt -> CString @@ -559,7 +609,32 @@ 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 +# if !defined(__GLASGOW_HASKELL__) +long_path_size :: Int +long_path_size = 4096 +# endif +#else + do path <- getEnv "PATH" search (parseSearchPath path) where @@ -572,6 +647,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 @@ -832,12 +909,14 @@ cannot be found. -} getHomeDirectory :: IO FilePath getHomeDirectory = -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath if (r < 0) - then c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath - else return 0 + then do + r <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath + when (r < 0) (raiseUnsupported "System.Directory.getHomeDirectory") + else return () peekCString pPath #else getEnv "HOME" @@ -872,9 +951,10 @@ cannot be found. -} getAppUserDataDirectory :: String -> IO FilePath getAppUserDataDirectory appName = do -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +#if __GLASGOW_HASKELL__ && 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) #else @@ -905,9 +985,10 @@ cannot be found. -} getUserDocumentsDirectory :: IO FilePath getUserDocumentsDirectory = do -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +#if __GLASGOW_HASKELL__ && 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 #else getEnv "HOME" @@ -941,7 +1022,7 @@ The function doesn\'t verify whether the path exists. -} getTemporaryDirectory :: IO FilePath getTemporaryDirectory = do -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do r <- c_GetTempPath (fromIntegral long_path_size) pPath peekCString pPath @@ -949,8 +1030,8 @@ getTemporaryDirectory = do catch (getEnv "TMPDIR") (\ex -> return "/tmp") #endif -#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) -foreign import stdcall unsafe "SHGetFolderPath" +#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) +foreign import ccall unsafe "__hscore_getFolderPath" c_SHGetFolderPath :: Ptr () -> CInt -> Ptr () @@ -962,5 +1043,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 "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) + #endif