X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fcompat%2FCompat%2FDirectory.hs;h=73b7f5924482140e0d38585408679bcf2548dc22;hb=ec2e8e570cc9f67b6be72ec259c9ac04463f957d;hp=6ec4af54ccf72ebb3b23c22d965eb89fa1d13902;hpb=d8cde19805cd0ee6460b5a4d47e23a10adc7d261;p=ghc-hetmet.git

diff --git a/ghc/lib/compat/Compat/Directory.hs b/ghc/lib/compat/Compat/Directory.hs
index 6ec4af5..73b7f59 100644
--- a/ghc/lib/compat/Compat/Directory.hs
+++ b/ghc/lib/compat/Compat/Directory.hs
@@ -16,14 +16,26 @@
 
 module Compat.Directory (
   	getAppUserDataDirectory,
+  	copyFile,
+  	findExecutable
   ) where
 
 #if __GLASGOW_HASKELL__ < 603
 #include "config.h"
 #endif
 
-#if !defined(mingw32_TARGET_OS)
+import Control.Exception       ( bracket )
+import Control.Monad           ( when )
 import System.Environment (getEnv)
+import System.FilePath
+import System.IO
+#if defined(mingw32_TARGET_OS)
+import Foreign
+import Foreign.C
+#endif
+import System.Directory(doesFileExist, getPermissions, setPermissions)
+#if defined(__GLASGOW_HASKELL__)
+import GHC.IOBase ( IOException(..) )
 #endif
 
 getAppUserDataDirectory :: String -> IO FilePath
@@ -39,11 +51,62 @@ getAppUserDataDirectory appName = do
 #endif
 
 #if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
-foreign import stdcall unsafe "SHGetFolderPath" 
+foreign import stdcall unsafe "SHGetFolderPathA"
             c_SHGetFolderPath :: Ptr () 
                               -> CInt 
                               -> Ptr () 
                               -> CInt 
                               -> CString 
                               -> IO CInt
+
+foreign import ccall unsafe "__hscore_long_path_size"
+  long_path_size :: Int
+
+foreign import ccall unsafe "__hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
+#endif
+
+
+copyFile :: FilePath -> FilePath -> IO ()
+copyFile fromFPath toFPath =
+#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
+	do readFile fromFPath >>= writeFile toFPath
+	   try (getPermissions fromFPath >>= setPermissions 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)
+		return ()) `catch` (ioError . changeFunName)
+	where
+		bufferSize = 1024
+		
+		changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
+		
+		copyContents hFrom hTo buffer = do
+			count <- hGetBuf hFrom buffer bufferSize
+			when (count > 0) $ do
+				hPutBuf hTo buffer count
+				copyContents hFrom hTo buffer
+#endif
+
+
+findExecutable :: String -> IO (Maybe FilePath)
+findExecutable binary = do
+  path <- getEnv "PATH"
+  search (parseSearchPath path)
+  where
+#ifdef mingw32_TARGET_OS
+    fileName = binary `joinFileExt` "exe"
+#else
+    fileName = binary
 #endif
+
+    search :: [FilePath] -> IO (Maybe FilePath)
+    search [] = return Nothing
+    search (d:ds) = do
+	let path = d `joinFileName` fileName
+	b <- doesFileExist path
+	if b then return (Just path)
+             else search ds