From: sof Date: Sat, 19 Mar 2005 02:03:28 +0000 (+0000) Subject: [project @ 2005-03-19 02:03:26 by sof] X-Git-Tag: Initial_conversion_from_CVS_complete~881 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=cbe4c3a7cc2b1e627b308aff520a9f354f7a730b;p=ghc-hetmet.git [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/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index ac26a9a..06180a1 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -201,12 +201,15 @@ readPackageConfigs dflags = do -- unless the -no-user-package-conf flag was given. -- We only do this when getAppUserDataDirectory is available -- (GHC >= 6.3). - appdir <- getAppUserDataDirectory "ghc" - let + (exists, pkgconf) <- catch (do + appdir <- getAppUserDataDirectory "ghc" + let pkgconf = appdir ++ '/':TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion ++ "/package.conf" - -- - exists <- doesFileExist pkgconf + flg <- doesFileExist pkgconf + return (flg, pkgconf)) + -- gobble them all up and turn into False. + (\ _ -> return (False, "")) pkg_map2 <- if (dopt Opt_ReadUserPackageConf dflags && exists) then readPackageConfig dflags pkg_map1 pkgconf else return pkg_map1 diff --git a/ghc/lib/compat/Compat/Directory.hs b/ghc/lib/compat/Compat/Directory.hs index ecd5a99..794af31 100644 --- a/ghc/lib/compat/Compat/Directory.hs +++ b/ghc/lib/compat/Compat/Directory.hs @@ -31,7 +31,7 @@ import Control.Monad ( when ) import Foreign.Marshal.Alloc ( allocaBytes ) import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose) import System.IO.Error ( try ) -import GHC.IOBase ( IOException(..) ) +import GHC.IOBase ( IOException(..), IOErrorType(..) ) #else import System.IO ( try ) #endif @@ -46,6 +46,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 "Compat.Directory.getAppUserDataDirectory") s <- peekCString pPath return (s++'\\':appName) #else @@ -54,7 +55,7 @@ getAppUserDataDirectory appName = do #endif #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS) -foreign import stdcall unsafe "SHGetFolderPathA" +foreign import stdcall unsafe "directory.h __hscore_getFolderPath" c_SHGetFolderPath :: Ptr () -> CInt -> Ptr () @@ -63,10 +64,13 @@ foreign import stdcall unsafe "SHGetFolderPathA" -> IO CInt -- __compat_long_path_size defined in cbits/directory.c -foreign import ccall unsafe "__compat_long_path_size" +foreign import ccall unsafe "directory.h __compat_long_path_size" long_path_size :: Int -foreign import ccall unsafe "__hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt +foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt + +raiseUnsupported loc = + ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing) #endif diff --git a/ghc/lib/compat/Makefile b/ghc/lib/compat/Makefile index a087cde..89fe9a4 100644 --- a/ghc/lib/compat/Makefile +++ b/ghc/lib/compat/Makefile @@ -19,7 +19,7 @@ NO_INSTALL_LIBRARY = YES MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR) # Needed so that the libraries can #include relative to this directory. -SRC_HC_OPTS += -I. +SRC_HC_OPTS += -I. -Iinclude UseGhcForCc = YES diff --git a/ghc/lib/compat/cbits/directory.c b/ghc/lib/compat/cbits/directory.c index af09655..cca7b2c 100644 --- a/ghc/lib/compat/cbits/directory.c +++ b/ghc/lib/compat/cbits/directory.c @@ -1,50 +1,92 @@ -#include "../../../includes/ghcconfig.h" - -#include "HsFFI.h" - -#if HAVE_LIMITS_H -#include -#endif -#if HAVE_WINDOWS_H -#include -#endif - -#define INLINE /* nothing */ - -/* - * Following code copied from libraries/base/includes/HsBase.h - */ - -#ifdef PATH_MAX -/* A size that will contain many path names, but not necessarily all - * (PATH_MAX is not defined on systems with unlimited path length, - * e.g. the Hurd). - */ -INLINE HsInt __compat_long_path_size() { return PATH_MAX; } -#else -INLINE HsInt __compat_long_path_size() { return 4096; } -#endif - -#if defined(mingw32_HOST_OS) - -/* Make sure we've got the reqd CSIDL_ constants in scope; - * w32api header files are lagging a bit in defining the full set. - */ -#if !defined(CSIDL_APPDATA) -#define CSIDL_APPDATA 0x001a -#endif -#if !defined(CSIDL_PERSONAL) -#define CSIDL_PERSONAL 0x0005 -#endif -#if !defined(CSIDL_PROFILE) -#define CSIDL_PROFILE 0x0028 -#endif -#if !defined(CSIDL_WINDOWS) -#define CSIDL_WINDOWS 0x0024 -#endif - -INLINE int __hscore_CSIDL_PROFILE() { return CSIDL_PROFILE; } -INLINE int __hscore_CSIDL_APPDATA() { return CSIDL_APPDATA; } -INLINE int __hscore_CSIDL_WINDOWS() { return CSIDL_WINDOWS; } -INLINE int __hscore_CSIDL_PERSONAL() { return CSIDL_PERSONAL; } -#endif +#include "../../../includes/ghcconfig.h" + +#include "HsFFI.h" + +#if HAVE_LIMITS_H +#include +#endif +#if HAVE_WINDOWS_H +#include +#endif +#include "directory.h" + +#define INLINE /* nothing */ + +/* + * Following code copied from libraries/base/includes/HsBase.h + */ + +#ifdef PATH_MAX +/* A size that will contain many path names, but not necessarily all + * (PATH_MAX is not defined on systems with unlimited path length, + * e.g. the Hurd). + */ +INLINE HsInt __compat_long_path_size() { return PATH_MAX; } +#else +INLINE HsInt __compat_long_path_size() { return 4096; } +#endif + +#if defined(mingw32_HOST_OS) + +/* Make sure we've got the reqd CSIDL_ constants in scope; + * w32api header files are lagging a bit in defining the full set. + */ +#if !defined(CSIDL_APPDATA) +#define CSIDL_APPDATA 0x001a +#endif +#if !defined(CSIDL_PERSONAL) +#define CSIDL_PERSONAL 0x0005 +#endif +#if !defined(CSIDL_PROFILE) +#define CSIDL_PROFILE 0x0028 +#endif +#if !defined(CSIDL_WINDOWS) +#define CSIDL_WINDOWS 0x0024 +#endif + +INLINE int __hscore_CSIDL_PROFILE() { return CSIDL_PROFILE; } +INLINE int __hscore_CSIDL_APPDATA() { return CSIDL_APPDATA; } +INLINE int __hscore_CSIDL_WINDOWS() { return CSIDL_WINDOWS; } +INLINE int __hscore_CSIDL_PERSONAL() { return CSIDL_PERSONAL; } + +/* + * Function: __hscore_getFolderPath() + * + * Late-bound version of SHGetFolderPath(), coping with OS versions + * that have shell32's lacking that particular API. + * + */ +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/ghc/lib/compat/include/directory.h b/ghc/lib/compat/include/directory.h new file mode 100644 index 0000000..2e26c3d --- /dev/null +++ b/ghc/lib/compat/include/directory.h @@ -0,0 +1,13 @@ +#ifndef __DIRECTORY_H__ +#define __DIRECTORY_H__ + +#if defined(mingw32_HOST_OS) +extern int __compat_long_path_size(); +extern int __hscore_CSIDL_APPDATA(); +extern int __hscore_getFolderPath(HWND hwndOwner, + int nFolder, + HANDLE hToken, + DWORD dwFlags, + char* pszPath); +#endif +#endif