#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
import System.Posix.Internals
import System.Time ( ClockTime(..) )
import System.IO
-import Foreign
-import Foreign.C
import GHC.IOBase ( IOException(..), IOErrorType(..), ioException )
{- |@'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 =
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
peekCString pOutPath
#if defined(mingw32_HOST_OS)
-foreign import stdcall unsafe "GetFullPathName"
+foreign import stdcall unsafe "GetFullPathNameA"
c_GetFullPathName :: CString
-> CInt
-> CString
-> 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
-- 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
b <- doesFileExist path
if b then return (Just path)
else search ds
+#endif
+
#ifdef __GLASGOW_HASKELL__
{- |@'getDirectoryContents' dir@ returns a list of /all/ entries
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.
-}
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)
-}
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")
-}
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")
-}
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
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
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)
projects / haskell-directory.git / blobdiff