[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.

diff --git a/System/Directory.hs b/System/Directory.hs
index c6f3d66..cafe759 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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__ */