[project @ 2005-10-18 11:36:25 by simonmar]

[haskell-directory.git] / System / Directory.hs

diff --git a/System/Directory.hs b/System/Directory.hs
index e2fd121..5ff3e77 100644 (file)
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -194,6 +194,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 +250,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 
@@ -493,14 +510,14 @@ 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 +536,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 +551,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
@@ -832,12 +849,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 +891,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 +925,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 +962,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 +970,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 +983,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