module System.Win32.Com
(
IUnknown_
, IUnknown
, iidIUnknown
, interfaceNULL, isNullInterface, iidNULL
, queryInterface
, addRef
, release
, withQueryInterface
, ( # )
, ( ## )
, coRun
, coPerformIO
, coUnsafePerformIO
, coInitialize
, coUnInitialize
, GUID
, mkGUID
, newGUID
, stringToGUID
, guidToString
, nullGUID
, IID
, mkIID
, stringToIID
, guidToIID
, iidToGUID
, castIID
, CLSID
, mkCLSID
, stringToCLSID
, guidToCLSID
, clsidToGUID
, clsidToDisplayName
, LIBID
, mkLIBID
, HRESULT
, s_FALSE
, s_OK
, succeeded
, failed
, checkHR
, checkBool
, returnHR
, coFailHR
, coFailWithHR
, coAssert
, coOnFail
, coFail
, isCoError
, coGetErrorHR
, coGetErrorString
, hresultToString
, ComException(..)
, catchComException
, throwIOComException
, throwComException
, coCreateInstance
, coCreateObject
, coGetObject
, coGetActiveObject
, coGetFileObject
, coCreateInstanceEx
, COSERVERINFO(..)
, COAUTHIDENTITY(..)
, COAUTHINFO(..)
, withObject
, withObject_
, withMethod
, withMethod_
, CLSCTX(..)
, ProgID
, progIDFromCLSID
, clsidFromProgID
, printMessage
, putMessage
, messageBox
, outputDebugString
, OSVersionInfo(..)
, isWindowsNT
, isWindows95
, isWindows98
, versionInfo
, ifaceToAddr
, enumNext
, enumNextOne
, enumClone
, enumReset
, enumSkip
, BSTR
, marshallBSTR
, unmarshallBSTR
, readBSTR
, writeBSTR
, freeBSTR
, LPSTR
, coFree
, coAlloc
, marshallIUnknown
, unmarshallIUnknown
, readIUnknown
, writeIUnknown
, unmarshallIUnknownFO
, castIface
, WideString
, marshallWideString
, unmarshallWideString
, writeWideString
, readWideString
, sizeofWideString
, freeWideString
, marshallGUID
, unmarshallGUID
, writeGUID
, readGUID
, copyGUID
, sizeofGUID
, marshallIID
, unmarshallIID
, writeIID
, readIID
, sizeofIID
, copyIID
, marshallCLSID
, unmarshallCLSID
, writeCLSID
, readCLSID
, sizeofCLSID
, copyCLSID
, invokeAndCheck
, invokeIt
, loadTypeLib
, loadTypeLibEx
, loadRegTypeLib
, queryPathOfRegTypeLib
, createTypeLib
, LCID
, messagePump
, postQuitMsg
) where
import System.Win32.Com.Exception
import System.Win32.Com.Base
hiding ( coCreateInstance, loadTypeLib, messageBox,
loadTypeLibEx, loadRegTypeLib, coCreateInstanceEx
)
import qualified System.Win32.Com.Base as Base
( coCreateInstance, loadTypeLib, messageBox,
loadTypeLibEx, loadRegTypeLib, coCreateInstanceEx
)
import System.Win32.Com.HDirect.HDirect
import System.Win32.Com.HDirect.Pointer hiding ( freeBSTR )
import qualified System.Win32.Com.HDirect.Pointer as P ( freeBSTR )
import System.Win32.Com.HDirect.WideString
import System.IO.Unsafe ( unsafePerformIO )
import Control.Monad ( when )
import Foreign.StablePtr ( deRefStablePtr )
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.Marshal.Alloc ( allocaBytes )
import Data.Bits
import Control.Exception ( bracket )
infixl 1 #
infixl 0 ##
( # ) :: a -> (a -> IO b) -> IO b
obj # method = method obj
( ## ) :: IO a -> (a -> IO b) -> IO b
mObj ## method = mObj >>= method
data PersistFile a = PersistFile
type IPersistFile a = IUnknown (PersistFile a)
iidIPersistFile :: IID (IPersistFile ())
iidIPersistFile = mkIID "{0000010B-0000-0000-C000-000000000046}"
coCreateInstance :: CLSID
-> Maybe (IUnknown b)
-> CLSCTX
-> IID (IUnknown a)
-> IO (IUnknown a)
coCreateInstance clsid inner context iid = do
ppvObject <- allocOutPtr
clsid <- marshallCLSID clsid
inner <- marshallInner inner
let ctxt = fromEnum context
iid <- marshallIID iid
Base.coCreateInstance (castForeignPtr clsid) inner (fromIntegral ctxt)
(castForeignPtr iid) ppvObject
doThenFree free (readIUnknown False) ppvObject
coCreateInstanceEx :: CLSID
-> Maybe (IUnknown b)
-> CLSCTX
-> Maybe COSERVERINFO
-> IID (IUnknown a)
-> IO (IUnknown a)
coCreateInstanceEx clsid pUnkOuter context mbServ iid = do
clsid <- marshallCLSID clsid
pUnkOuter <- marshallInner pUnkOuter
let ctxt = fromEnum context
iid <- copyGUID (iidToGUID iid)
let mqi = [ MULTI_QI iid nullPtr 0 ]
r <- Base.coCreateInstanceEx (castForeignPtr clsid) pUnkOuter (fromIntegral ctxt) mbServ mqi
case r of
(MULTI_QI iid pItf hr:_) -> do
coFree iid
checkHR hr
unmarshallIUnknown True pItf
_ -> coFailHR e_FAIL
marshallInner :: Maybe (IUnknown a) -> IO (ForeignPtr b)
marshallInner Nothing = return nullFO
marshallInner (Just v) = marshallIUnknown v
coCreateObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a)
coCreateObject progid iid = do
clsid <- clsidFromProgID progid
coCreateInstance clsid Nothing AnyProcess iid
coGetFileObject :: String -> ProgID -> IID (IUnknown a) -> IO (IUnknown a)
coGetFileObject "" progid iid = coGetActiveObject progid iid
coGetFileObject fname progid iid = do
pf <- coCreateObject progid iidIPersistFile
stackWideString fname $ \pfname -> do
persistfileLoad pf pfname 0
pf # queryInterface iid
coGetActiveObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a)
coGetActiveObject progid iid = do
clsid <- clsidFromProgID progid
iface <- primGetActiveObject clsid
`coOnFail` ("Could not connect to component '" ++ progid ++ "'")
iface # queryInterface iid
primGetActiveObject :: CLSID -> IO (IUnknown a)
primGetActiveObject clsid = do
clsid <- marshallCLSID clsid
ppvObject <- allocOutPtr
hr <- getActiveObject (castForeignPtr clsid) nullPtr ppvObject
doThenFree free (readIUnknown False) ppvObject
coGetObject :: String -> IID (IUnknown a) -> IO (IUnknown a)
coGetObject fname iid = do
stackWideString fname $ \pfname -> do
iid <- marshallIID iid
ppv <- bindObject pfname (castForeignPtr iid)
doThenFree free (readIUnknown False) ppv
coRun :: IO a -> IO a
coRun io = do
coInitialize
v <-
catchComException io
(\ err -> do
when (isCoError err) (putMessage $ coGetErrorString err)
coUnInitialize
throwIOComException err)
coUnInitialize
return v
coPerformIO :: IO a -> IO a
coPerformIO io =
catchComException io
( \ err -> do
putMessage (coGetErrorString err)
throwIOComException err)
coUnsafePerformIO :: IO a -> a
coUnsafePerformIO = unsafePerformIO . coPerformIO
printMessage :: Show a => a -> IO ()
printMessage x = putMessage (show x)
putMessage :: String -> IO ()
putMessage msg =
stackString msg $ \ _ m ->
stackString "Haskell message" $ \ _ t ->
Base.messageBox m t 0x40040
messageBox :: String -> String -> Word32 -> IO ()
messageBox msg title flg =
stackString msg $ \ _ m ->
stackString title $ \ _ t ->
Base.messageBox m t flg
outputDebugString :: String -> IO ()
outputDebugString msg = primOutputDebugString ("haskell-com: " ++ msg ++ "\n")
data OSVersionInfo
= OSVersionInfo Word32 Word32 Word32
isWindowsNT :: OSVersionInfo -> Bool
isWindowsNT (OSVersionInfo _ _ 2) = True
isWindowsNT _ = False
isWindows95 :: OSVersionInfo -> Bool
isWindows95 (OSVersionInfo _ 0 1) = True
isWindows95 _ = False
isWindows98 :: OSVersionInfo -> Bool
isWindows98 (OSVersionInfo _ x 1) = x /= 0
isWindows98 _ = False
versionInfo :: OSVersionInfo
versionInfo = unsafePerformIO $ do
(j,n,d) <- primGetVersionInfo
return (OSVersionInfo j n d)
data CLSCTX
= CLSCTX_INPROC_SERVER
| CLSCTX_INPROC_HANDLER
| CLSCTX_LOCAL_SERVER
| CLSCTX_INPROC_SERVER16
| CLSCTX_REMOTE_SERVER
| CLSCTX_INPROC_HANDLER16
| CLSCTX_INPROC_SERVERX86
| CLSCTX_INPROC_HANDLERX86
| LocalProcess
| InProcess
| ServerProcess
| AnyProcess
deriving (Show)
instance Enum CLSCTX where
fromEnum ctx =
case ctx of
CLSCTX_INPROC_SERVER -> 1
CLSCTX_INPROC_HANDLER -> 2
CLSCTX_LOCAL_SERVER -> 4
CLSCTX_INPROC_SERVER16 -> 8
CLSCTX_REMOTE_SERVER -> 16
CLSCTX_INPROC_HANDLER16 -> 32
CLSCTX_INPROC_SERVERX86 -> 64
CLSCTX_INPROC_HANDLERX86 -> 128
LocalProcess -> localProcess
InProcess -> inProcess
ServerProcess -> serverProcess
AnyProcess -> anyProcess
toEnum x =
case x of
1 -> CLSCTX_INPROC_SERVER
2 -> CLSCTX_INPROC_HANDLER
8 -> CLSCTX_INPROC_SERVER16
16 -> CLSCTX_REMOTE_SERVER
32 -> CLSCTX_INPROC_HANDLER16
64 -> CLSCTX_INPROC_SERVERX86
128 -> CLSCTX_INPROC_HANDLERX86
0x04 -> LocalProcess
0x0b -> InProcess
0x0d -> ServerProcess
4 -> CLSCTX_LOCAL_SERVER
_ -> AnyProcess
localProcess :: Int
localProcess = 0x04
inProcess :: Int
inProcess = 0x0b
serverProcess :: Int
serverProcess = 0x0d
anyProcess :: Int
anyProcess = 0x0f
invokeAndCheck :: (Ptr any -> Ptr b -> IO HRESULT) -> Int -> IUnknown a -> IO ()
invokeAndCheck meth offset iptr = do
hr <- primInvokeItFO meth offset (marshallIUnknown iptr)
checkHR hr
invokeIt :: (Ptr any -> Ptr c -> IO a) -> Int -> IUnknown b -> IO a
invokeIt meth offset iptr = primInvokeItFO meth offset (marshallIUnknown iptr)
enumNext :: Word32 -> (Ptr any -> IO a) -> Word32 -> IUnknown b -> IO [a]
enumNext szof read_elt celt iptr = do
ptr <- allocBytes (fromIntegral (celt * szof))
po <- allocBytes (fromIntegral sizeofWord32)
invokeIt (\ methPtr ip -> primEnumNext methPtr ip celt ptr po) 3 iptr
elts_read <- readWord32 (castPtr po)
unmarshalllist szof 0 elts_read read_elt ptr
enumNextOne :: Word32 -> (Ptr any -> IO a) -> IUnknown b -> IO (Maybe a)
enumNextOne szof read_elt iptr =
allocaBytes (fromIntegral sizeofWord32) $ \ po -> do
ptr <- allocBytes (fromIntegral szof)
invokeIt (\ methPtr ip -> primEnumNext methPtr ip 1 ptr po) 3 iptr
elts_read <- readWord32 (castPtr po)
if elts_read <= 0
then return Nothing
else do
x <- read_elt (castPtr ptr)
return (Just x)
enumSkip :: Word32 -> IUnknown a -> IO ()
enumSkip count iptr =
invokeIt (\ methPtr ip -> primEnumSkip methPtr ip count) 4 iptr
enumReset :: IUnknown a -> IO ()
enumReset iptr =
invokeIt (\ methPtr ip -> primEnumReset methPtr ip) 5 iptr
enumClone :: IUnknown a -> IO (IUnknown b)
enumClone iptr = do
ppv <- allocOutPtr
invokeIt (\ methPtr ip -> primEnumClone methPtr ip ppv) 6 iptr
doThenFree free (readIUnknown False) ppv
data BSTR = BSTR
writeBSTR :: Ptr String -> String -> IO ()
writeBSTR ptr str =
stackString str $ \_ pstr -> do
o_stringToBSTR <- prim_System_Win32_Com_Base_stringToBSTR (castPtr pstr) ptr
checkHR o_stringToBSTR
readBSTR :: Ptr (Ptr String) -> IO String
readBSTR ptr = do
ptr' <- peek ptr
unmarshallBSTR ptr'
unmarshallBSTR :: Ptr String -> IO String
unmarshallBSTR bstr
| bstr == nullPtr = return ""
| len == 0 = return ""
| otherwise = do
stackStringLen (4 + fromIntegral len) "" $ \ pstr -> do
bstrToStringLen (castPtr bstr) len (castPtr pstr)
unmarshallString pstr
where
len = bstrLen (castPtr bstr)
marshallBSTR :: String -> IO (Ptr String)
marshallBSTR s =
stackString s $ \ _ pstr -> do
ptr <- stringToBSTR (castPtr pstr)
x <- peek (castPtr ptr)
free ptr
return x
freeBSTR x
| x == nullPtr = return ()
| otherwise = P.freeBSTR x
type LPSTR = String
coFree :: Ptr a -> IO ()
coFree p = freeMemory p
coAlloc :: Word32 -> IO (Ptr a)
coAlloc sz = allocMemory sz
type ProgID = String
clsidFromProgID :: ProgID -> IO CLSID
clsidFromProgID progid =
stackString progid $ \ _ pprogid -> do
pclsid <- coAlloc sizeofCLSID
coOnFail (primCLSIDFromProgID pprogid (castPtr pclsid))
("Component '" ++ progid ++ "' is unknown")
unmarshallCLSID True pclsid
progIDFromCLSID :: CLSID -> IO ProgID
progIDFromCLSID clsid = do
pclsid <- marshallCLSID clsid
pwide <- primProgIDFromCLSID (castForeignPtr pclsid)
(pstr,hr) <- wideToString (castPtr pwide)
checkHR hr
str <- unmarshallString (castPtr pstr)
coFree pstr
coFree pwide
return str
type LIBID = GUID
mkLIBID :: String -> LIBID
mkLIBID = mkGUID
type LCID = Word32
iidIUnknown :: IID (IUnknown ())
iidIUnknown = mkIID "{00000000-0000-0000-C000-000000000046}"
instance Eq (IUnknown_ a) where
iface1 == iface2 = coEqual (castIface iface1) (castIface iface2)
castIface :: IUnknown a -> IUnknown b
castIface (Unknown o) = Unknown o
interfaceNULL :: IUnknown a
interfaceNULL = unsafePerformIO (unmarshallIUnknown False nullPtr)
isNullInterface :: IUnknown a -> Bool
isNullInterface (Unknown ip) = foreignPtrToPtr ip == nullPtr
iidNULL :: IID ()
iidNULL = mkIID "{00000000-0000-0000-0000-000000000000}"
instance Show (IUnknown_ a) where
showsPrec _ iface =
shows "<interface pointer = " .
shows (ifaceToAddr iface) .
shows ">"
queryInterface :: IID (IUnknown b) -> IUnknown a -> IO (IUnknown b)
queryInterface riid iptr = do
ppvObject <- allocOutPtr
priid <- marshallIID riid
invokeIt (\ methPtr ip -> primQI methPtr ip (castForeignPtr priid) ppvObject) 0 iptr
doThenFree free (readIUnknown False) ppvObject
addRef :: IUnknown a -> IO Word32
addRef iptr = invokeIt (\ methPtr ip -> primAddRef methPtr ip) 1 iptr
release :: IUnknown a -> IO Word32
release iptr = invokeIt (\ methPtr ip -> primRelease methPtr ip) 2 iptr
withQueryInterface :: IID (IUnknown b)
-> IUnknown a
-> (IUnknown b -> IO c)
-> IO c
withQueryInterface iid unk action
= bracket (queryInterface iid unk) release action
persistfileLoad :: IPersistFile a -> Ptr Wchar_t -> Word32 -> IO ()
persistfileLoad iptr pszFileName dwMode =
invokeIt (\ methPtr ip -> primPersistLoad methPtr ip pszFileName dwMode) 5 iptr
newtype GUID = GUID (ForeignPtr ())
data Guid = Guid
mkGUID :: String -> GUID
mkGUID str = unsafePerformIO (stringToGUID str)
newGUID :: IO GUID
newGUID = do
pg <- coAlloc sizeofGUID
ng <- makeFO pg (castPtrToFunPtr finalFreeMemory)
primNewGUID ng
return (GUID ng)
nullGUID :: GUID
nullGUID = unsafePerformIO $ do
x <- primNullIID
p <- makeFO x (castPtrToFunPtr finalNoFree) --primNoFree
return (GUID p)
marshallGUID :: GUID -> IO (ForeignPtr GUID)
marshallGUID (GUID ptr) = return (castForeignPtr ptr)
copyGUID :: GUID -> IO (Ptr ())
copyGUID (GUID ptr) = do
pg <- coAlloc sizeofGUID
primCopyGUID ptr pg
return pg
unmarshallGUID :: Bool -> Ptr GUID -> IO GUID
unmarshallGUID finaliseMe ptr = do
f <- makeFO ptr (castPtrToFunPtr $ if finaliseMe then finalFreeMemory else finalNoFree)
return (GUID f)
writeGUID :: Ptr GUID -> GUID -> IO ()
writeGUID ptr (GUID g) = poke (castPtr ptr) (foreignPtrToPtr g)
readGUID :: Bool -> Ptr GUID -> IO GUID
readGUID finaliseMe ptr = do
unmarshallGUID finaliseMe ptr
sizeofGUID :: Word32
sizeofGUID = 16
stringToGUID :: String -> IO GUID
stringToGUID str =
stackWideString str $ \xstr -> do
pg <- coAlloc sizeofGUID
primStringToGUID xstr (castPtr pg)
unmarshallGUID True pg
stringFromGUID :: GUID -> IO String
stringFromGUID guid = do
pguid <- marshallGUID guid
pwide <- primGUIDToString (castForeignPtr pguid)
(pstr,hr) <- wideToString (castPtr pwide)
checkHR hr
str <- unmarshallString (castPtr pstr)
coFree pstr
coFree pwide
return str
guidToString :: GUID -> String
guidToString ptr = unsafePerformIO (stringFromGUID ptr)
newtype IID a = IID GUID deriving ( Eq )
newtype CLSID = CLSID GUID deriving ( Eq )
mkIID :: String -> IID a
mkIID str = IID (mkGUID str)
mkCLSID :: String -> CLSID
mkCLSID str = CLSID (mkGUID str)
stringToIID :: String -> IID a
stringToIID str = mkIID str
stringToCLSID :: String -> CLSID
stringToCLSID str = mkCLSID str
iidToString :: IID a -> String
iidToString (IID i) = guidToString i
clsidToString :: CLSID -> String
clsidToString (CLSID clsid) = guidToString clsid
iidToGUID :: IID a -> GUID
iidToGUID (IID g) = g
castIID :: IID a -> IID b
castIID (IID i) = IID i
clsidToGUID :: CLSID -> GUID
clsidToGUID (CLSID g) = g
clsidToDisplayName :: CLSID -> String
clsidToDisplayName (CLSID g) = "clsid:" ++ tail (init (show g))
guidToIID :: GUID -> IID a
guidToIID g = IID g
guidToCLSID :: GUID -> CLSID
guidToCLSID g = CLSID g
instance Show (IID a) where
showsPrec _ (IID i) = showString (guidToString i)
instance Show CLSID where
showsPrec _ (CLSID c) = showString (guidToString c)
instance Show GUID where
showsPrec _ guid = showString (guidToString guid)
instance Eq GUID where
(GUID x) == (GUID y) = unsafePerformIO $ do
return (isEqualGUID x y)
marshallIID :: IID a -> IO (ForeignPtr (IID a))
marshallIID (IID x) = marshallGUID x >>= return.castForeignPtr
unmarshallIID :: Bool -> Ptr (IID a) -> IO (IID a)
unmarshallIID finaliseMe x = do
i <- unmarshallGUID finaliseMe (castPtr x)
return (IID i)
copyIID (IID x) = copyGUID x
readIID :: Bool -> Ptr (Ptr (IID a)) -> IO (IID a)
readIID finaliseMe ptr = do
a <- peek ptr
unmarshallIID finaliseMe (castPtr a)
writeIID :: Ptr (IID a) -> IID a -> IO ()
writeIID ptr (IID i) = writeGUID (castPtr ptr) i
marshallCLSID (CLSID x) = marshallGUID x
unmarshallCLSID :: Bool -> Ptr CLSID -> IO CLSID
unmarshallCLSID finaliseMe x = do
i <- unmarshallGUID finaliseMe (castPtr x)
return (CLSID i)
copyCLSID (CLSID x) = copyGUID x
readCLSID :: Bool -> Ptr (Ptr CLSID) -> IO CLSID
readCLSID finaliseMe ptr = do
a <- peek ptr
unmarshallCLSID finaliseMe (castPtr a)
writeCLSID :: Ptr CLSID -> CLSID -> IO ()
writeCLSID ptr (CLSID i) = writeGUID (castPtr ptr) i
sizeofCLSID = sizeofGUID
coInitialize :: IO ()
coInitialize = comInitialize
coUnInitialize :: IO ()
coUnInitialize = comUnInitialize
sizeofIID = sizeofGUID
coEqual :: IUnknown a -> IUnknown b -> Bool
coEqual ip1 ip2 = unsafePerformIO $ primComEqual (castIface ip1) (castIface ip2)
unmarshallIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
unmarshallIUnknown finaliseMe x = do
ip <- addrToIPointer finaliseMe x
case finaliseMe of
True | x /= nullPtr -> ip # addRef >> return ip
_ -> return ip
unmarshallIUnknownFO :: ForeignPtr b -> IO (IUnknown a)
unmarshallIUnknownFO i = return (Unknown (castForeignPtr i))
readIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
readIUnknown addRefMe x = do
ptr <- peek (castPtr x)
ip <- addrToIPointer True ptr
case addRefMe of
True | x /= nullPtr -> ip # addRef >> return ip
_ -> return ip
writeIUnknown :: Bool -> Ptr (Ptr (IUnknown b)) -> IUnknown a -> IO ()
writeIUnknown addRefMe x v = do
let a = ifaceToAddr v
when (addRefMe && a /= nullPtr)
(v # addRef >> return ())
writePtr x a
withObject_ :: IUnknown a -> [IUnknown a -> IO b] -> IO ()
withObject_ obj = sequence_ . map ( obj # )
withMethod_ :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO ()
withMethod_ method args obj = sequence_ $ map (\x -> obj # method x) args
withObject :: IUnknown a -> [IUnknown a -> IO b] -> IO [b]
withObject obj = sequence . map ( obj # )
withMethod :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO [c]
withMethod method args obj = sequence $ map (\x -> obj # method x) args
loadTypeLib :: String -> IO (IUnknown a)
loadTypeLib fname = do
ptr <- allocOutPtr
stackWideString fname $ \pfname -> do
Base.loadTypeLib pfname ptr
doThenFree free (readIUnknown False) ptr
loadRegTypeLib :: GUID -> Int -> Int -> Int -> IO (IUnknown a)
loadRegTypeLib guid maj min lcid = do
ptr <- allocOutPtr
p_guid <- marshallGUID guid
Base.loadRegTypeLib (castForeignPtr p_guid)
(fromIntegral maj) (fromIntegral min)
(fromIntegral lcid) ptr
doThenFree free (readIUnknown False) ptr
queryPathOfRegTypeLib :: GUID
-> Word16
-> Word16
-> IO String
queryPathOfRegTypeLib gd maj min = do
pgd <- marshallGUID gd
pbstr <- primQueryPathOfRegTypeLib (castForeignPtr pgd) maj min
if nullPtr == pbstr then
return ""
else do
str <- unmarshallBSTR (castPtr pbstr)
freeBSTR pbstr
return str
createTypeLib :: String -> IO (IUnknown a)
createTypeLib nm = do
wstr <- stringToWide nm
pptr <- primCreateTypeLib 1 wstr
doThenFree free (readIUnknown False) pptr
loadTypeLibEx :: String -> Bool -> IO (IUnknown a)
loadTypeLibEx path reg_tlb = do
let
rkind :: Int
rkind
| reg_tlb = 1
| otherwise = 2
out_ptr <- allocOutPtr
stackWideString path $ \pfname -> do
Base.loadTypeLibEx pfname (fromIntegral rkind) out_ptr
doThenFree free (readIUnknown False) out_ptr