, 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 )
#ifdef __NHC__
import Directory
import Hugs.Directory
#endif /* __HUGS__ */
+#if defined(__GLASGOW_HASKELL__) || defined(mingw32_HOST_OS)
+import Foreign
+import Foreign.C
+#endif
+
#ifdef __GLASGOW_HASKELL__
import Prelude
import Control.Exception ( bracket )
-import Control.Monad ( when, unless )
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 )
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
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
-- @dir@ if it doesn\'t exist. If the first argument is 'True'
-- the function will also create all parent directories if they are missing.
(_, True, _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
(_, False, _) -> createDirectory file
+#if __GLASGOW_HASKELL__
{- | @'removeDirectory' dir@ removes an existing directory /dir/. The
implementation may specify additional constraints which must be
satisfied before a directory can be removed (e.g. the directory has to
modifyIOError (`ioeSetFileName` path) $
withCString path $ \s ->
throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
+#endif
-- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/
-- together with its content and all subdirectories. Be careful,
removeDirectoryRecursive f
Right _ -> return ()
+#if __GLASGOW_HASKELL__
{- |'removeFile' /file/ removes the directory entry for an existing file
/file/, where /file/ is not itself a directory. The
implementation may specify additional constraints which must be
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
-- 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
#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
-- 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
b <- doesFileExist path
if b then return (Just path)
else search ds
+#endif
+
#ifdef __GLASGOW_HASKELL__
{- |@'getDirectoryContents' dir@ returns a list of /all/ entries
-}
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"
-}
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
-}
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"
-}
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
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 ()
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
projects / haskell-directory.git / blobdiff