From dd70cacd4793c4497136829c50ef31f330163638 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Sat, 19 Mar 2005 02:03:27 +0000
Subject: [PATCH] [project @ 2005-03-19 02:03:26 by sof] [Windows only] for
 System.Directory / Compat.Directory functionality that
 probes the OS for local details re: misc user directories,
 perform late binding of SHGetFolderPath() from shell32.dll,
 as it may not be present. (cf. ghc-6.4's failure to operate
 on Win9x / NT boxes.) If the API isn't there, fail with
 UnsupportedOperation. Packages.readPackageConfigs:
 gracefully handle excns from getAppUserDataDirectory.

Merge to STABLE.
---
 System/Directory.hs |   25 ++++++++++++-------------
 cbits/dirUtils.c    |   42 ++++++++++++++++++++++++++++++++++++++++++
 include/dirUtils.h  |    8 ++++++++
 3 files changed, 62 insertions(+), 13 deletions(-)

diff --git a/System/Directory.hs b/System/Directory.hs
index c6f3d66..cafe759 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -77,8 +77,6 @@ import NHC.FFI
 
 #ifdef __HUGS__
 import Hugs.Directory
-import Control.Exception       ( bracket )
-import System.IO
 #endif /* __HUGS__ */
 
 #ifdef __GLASGOW_HASKELL__
@@ -493,14 +491,7 @@ Neither path may refer to an existing directory.
 -}
 copyFile :: FilePath -> FilePath -> IO ()
 copyFile fromFPath toFPath =
-#if defined(__HUGS__)
-	(bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
-	 bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo -> do
-	 hGetContents hFrom >>= hPutStr hTo
-	 try (getPermissions fromFPath >>= setPermissions toFPath)
-	 return ()) `catch` \err ->
-		ioError (annotateIOError err "copyFile" Nothing Nothing)
-#elif (!defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ <= 600)
+#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
 	do readFile fromFPath >>= writeFile toFPath
 	   try (getPermissions fromFPath >>= setPermissions toFPath)
 	   return ()
@@ -845,8 +836,10 @@ getHomeDirectory =
   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"
@@ -884,6 +877,7 @@ getAppUserDataDirectory appName = do
 #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
@@ -917,6 +911,7 @@ getUserDocumentsDirectory = do
 #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"
@@ -959,7 +954,7 @@ getTemporaryDirectory = do
 #endif
 
 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
-foreign import stdcall unsafe "SHGetFolderPath" 
+foreign import stdcall unsafe "dirUtils.h __hscore_getFolderPath"
             c_SHGetFolderPath :: Ptr () 
                               -> CInt 
                               -> Ptr () 
@@ -972,4 +967,8 @@ 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
+
+raiseUnsupported loc = 
+   ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
+
 #endif
diff --git a/cbits/dirUtils.c b/cbits/dirUtils.c
index fdcdf29..86b3657 100644
--- a/cbits/dirUtils.c
+++ b/cbits/dirUtils.c
@@ -172,3 +172,45 @@ __hscore_renameFile( HsAddr src,
 #endif
 }
 
+/*
+ * Function: __hscore_getFolderPath()
+ *
+ * Late-bound version of SHGetFolderPath(), coping with OS versions
+ * that have shell32's lacking that particular API.
+ *
+ */
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__) || defined(_MSC_VER)
+typedef HRESULT (*HSCORE_GETAPPFOLDERFUNTY)(HWND,int,HANDLE,DWORD,char*);
+int
+__hscore_getFolderPath(HWND hwndOwner,
+		       int nFolder,
+		       HANDLE hToken,
+		       DWORD dwFlags,
+		       char*  pszPath)
+{
+    static int loaded_dll = 0;
+    static HMODULE hMod = (HMODULE)NULL;
+    static HSCORE_GETAPPFOLDERFUNTY funcPtr = NULL;
+    
+    if (loaded_dll < 0) {
+	return (-1);
+    } else if (loaded_dll == 0) {
+	hMod = LoadLibrary("shell32.dll");
+	if (hMod == NULL) {
+	    loaded_dll = (-1);
+	    return (-1);
+	} else {
+	    funcPtr = (HSCORE_GETAPPFOLDERFUNTY)GetProcAddress(hMod, "SHGetFolderPathA");
+	    if (!funcPtr) {
+		loaded_dll = (-1);
+		return (-1);
+	    } else {
+		loaded_dll = 1;
+	    }
+	}
+    }
+    /* OK, if we got this far the function has been bound */
+    return (int)funcPtr(hwndOwner,nFolder,hToken,dwFlags,pszPath);
+    /* ToDo: unload the DLL? */
+}
+#endif
diff --git a/include/dirUtils.h b/include/dirUtils.h
index ce11b08..2330912 100644
--- a/include/dirUtils.h
+++ b/include/dirUtils.h
@@ -9,4 +9,12 @@
 extern HsInt __hscore_readdir(HsAddr dirPtr, HsAddr pDirEnt);
 extern HsInt __hscore_renameFile(HsAddr src, HsAddr dest);
 
+#if defined(mingw32_HOST_OS)
+extern int __hscore_getFolderPath(HWND hwndOwner,
+				  int nFolder,
+				  HANDLE hToken,
+				  DWORD dwFlags,
+				  char*  pszPath);
+#endif
+
 #endif /* __DIRUTILS_H__ */
-- 
1.7.10.4