com 1.2.1 → 1.2.2
raw patch · 7 files changed
+124/−93 lines, 7 filesdep ~base
Dependency ranges changed: base
Files
- CHANGES +10/−0
- System/Win32/Com.hs +16/−2
- System/Win32/Com/Automation.hs +50/−27
- System/Win32/Com/Automation/Base.hs +4/−4
- cbits/AutoPrimSrc.c +41/−56
- com.cabal +2/−3
- include/autoPrim.h +1/−1
CHANGES view
@@ -1,3 +1,13 @@+Version 1.2.2 - released 2009-01-27; changes from 1.2.1 + + * built-in enumeration handling of variants (via the + IEnumVariant interface) was buggy and stale. + + * Fixed Integer unmarshalling for Variants; used to + go via CURRENCY, now Int64. + + * Only buildable on Windows platforms. + Version 1.2.1 - released 2009-01-19; changes from 1.2.0 * fix bad mix of allocators, the accidental introduction of the
System/Win32/Com.hs view
@@ -131,6 +131,7 @@ -- IEnum* methods. , enumNext + , enumNextOne , enumClone , enumReset , enumSkip @@ -223,6 +224,7 @@ import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Storable +import Foreign.Marshal.Alloc ( allocaBytes ) import Data.Bits import Control.Exception ( bracket ) @@ -503,8 +505,20 @@ po <- allocBytes (fromIntegral sizeofWord32) invokeIt (\ methPtr ip -> primEnumNext methPtr ip celt ptr po) 3 iptr elts_read <- readWord32 (castPtr po) - v <- peek ((castPtr ptr) :: Ptr (Ptr a)) - unmarshalllist szof 0 elts_read read_elt v +-- v <- peek ((castPtr ptr) :: Ptr (Ptr a)) + 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 =
System/Win32/Com/Automation.hs view
@@ -2,10 +2,10 @@ ----------------------------------------------------------------------------- -- | -- Module : System.Win32.Com.Automation --- Copyright : (c) Daan Leijen <leijen@fwi.uva.nl>, Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99 +-- Copyright : (c) Daan Leijen <leijen@fwi.uva.nl>, Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99, Sigbjorn Finne <sigbjorn.finne@gmail.com> 2000-2009 -- License : BSD-style (see the file libraries/base/LICENSE) -- --- Maintainer : sof@galois.com +-- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com> -- Stability : provisional -- Portability : portable -- @@ -159,6 +159,8 @@ import System.IO.Unsafe ( unsafePerformIO ) import Data.Bits +import System.IO ( hPutStrLn, stderr ) + {- The following creation functions are the VB equivalents in Haskell, notice the `unsafe' interface pointer return types used here. The @@ -478,7 +480,7 @@ resMaybe :: Variant a => ArgRes (Maybe a) resMaybe p = - catch + catchComException (readVarError p >> return Nothing) (\ _ -> fmap Just (resVariant p)) @@ -618,11 +620,11 @@ defaultInt64 :: Int64 defaultInt64 = 0 -inInt64 :: ArgIn Currency -inInt64 = inCurrency +inInt64 :: ArgIn Int64 +inInt64 i = inWord64 (fromIntegral i) -resInt64 :: ArgRes Currency -resInt64 = resCurrency +resInt64 :: ArgRes Int64 +resInt64 p = resWord64 p >>= return.fromIntegral inoutInt64 i = (inInt64 i,resInt64) outInt64 = inoutInt64 defaultInt64 @@ -824,16 +826,16 @@ writeVarCurrency (fromIntegral (fromIntegral hi)) (fromIntegral (fromIntegral lo)) +-- NOTE: this handles the decimal currency type in a shallow way, i.e., in its +-- int64-encoded form. To translate that fixed-point number (15,4) encoding +-- you'll have to do some more work... resCurrency :: ArgRes Currency -resCurrency = - let - coerceI = fromIntegral - readCur v = do - (hi,lo) <- readVarCurrency v - return (coerceI (fromIntegral hi) * (coerceI (maxBound :: Int) + 1) + - coerceI (fromIntegral lo)) - in - readCur +resCurrency v = do + (hi,lo) <- readVarCurrency v + return (coerceI (fromIntegral hi) * (coerceI (maxBound :: Int) + 1) + + coerceI (fromIntegral lo)) + where + coerceI = fromIntegral inoutCurrency b = (inCurrency b, resCurrency) outCurrency = inoutCurrency defaultCurrency @@ -849,7 +851,7 @@ writeVarString (castPtr pbstr) p resString :: ArgRes String -resString p = readTempVar readVarString p (\ p -> unmarshallBSTR (castPtr p)) +resString p = readTempVar "String" readVarString p (\ p -> unmarshallBSTR (castPtr p)) inoutString i = (inString i,resString) outString = inoutString defaultString @@ -869,7 +871,7 @@ resIUnknown :: ArgRes (IUnknown a) resIUnknown p = - readTempVar readVarUnknown p (unmarshallIUnknown True{-finalise-}) + readTempVar "IUnknown" readVarUnknown p (unmarshallIUnknown True{-finalise-}) inoutIUnknown d = (inIUnknown d,resIUnknown) outIUnknown = inoutIUnknown defaultIUnknown @@ -888,7 +890,7 @@ resIDispatch :: ArgRes (IDispatch a) resIDispatch p = - readTempVar readVarDispatch p (unmarshallIUnknown True{-finalise-}) + readTempVar "IDispatch" readVarDispatch p (unmarshallIUnknown True{-finalise-}) inoutIDispatch d = (inIDispatch d,resIDispatch) outIDispatch = inoutIDispatch defaultIDispatch @@ -1540,12 +1542,18 @@ --Some helper functions for @Variants@. -readTempVar :: (VARIANT -> IO (Ptr (Ptr b), Ptr (VARIANT))) +readTempVar :: String + -> (VARIANT -> IO (Ptr (Ptr b), Ptr (VARIANT))) -> VARIANT -> (Ptr b -> IO d) -> IO d -readTempVar io p f - = do (x,v) <- io p +readTempVar atTy io p f = do + tg <- readVariantTag p + (x,v) <- + catchComException (io p) + (\ ex -> do + hPutStrLn stderr ("VARIANT error: found type " ++ show (tg, atTy)) + throwIOComException ex) x <- readPtr x -- we always get a ty* back, so dereference it before using. f x `always` (freeVariants 1 (castPtr v) >> free v) -- _don't_ use freeMemVariants, as it ends up @@ -1585,22 +1593,37 @@ newEnum :: IDispatch a -> IO (Int, IEnumVARIANT b) newEnum ip = do - iunk <- ip # function1 "_NewEnum" [] outIUnknown + iunk <- + catchComException (ip # propertyGet "_NewEnum" [] outIUnknown) + (\ _ -> ip # function1 "_NewEnum" [] outIUnknown) ienum <- iunk # queryInterface iidIEnumVARIANT - len <- ip # propertyGet "length" [] outInt + len <- + catchComException (ip # propertyGet "length" [] outInt) + (\ _ -> ip # propertyGet "Count" [] outInt) return (len, castIface ienum) -enumVariants :: Variant a => IDispatch b -> IO [a] +enumVariants :: Variant a => IDispatch b -> IO (Int, [a]) enumVariants ip = do (len, ienum) <- newEnum ip - enumNext (fromIntegral sizeofVARIANT) resVariant (fromIntegral len) ienum +-- enumNext (fromIntegral sizeofVARIANT) resVariant (fromIntegral len) ienum + let + getByOne ie = do + mb <- ie # enumNextOne (fromIntegral sizeofVARIANT) resVariant + case mb of + Nothing -> return [] + Just x -> do + -- note: here we have the option of making it on-demand.. + xs <- getByOne ie + return (x:xs) + ls <- getByOne ienum + return (len, ls) --Helpers always :: IO a -> IO () -> IO a always io action = do - x <- io `catch` (\ e -> action >> ioError e) + x <- io `catchComException` (\ e -> action >> throwIOComException e) action return x
System/Win32/Com/Automation/Base.hs view
@@ -390,18 +390,18 @@ foreign import ccall "writeVarCurrency" prim_System_Win32_Com_Automation_Base_writeVarCurrency :: Int32 -> Word32 -> VARIANT -> IO () readVarCurrency :: VARIANT - -> IO (Int32, Int32) + -> IO (Int32, Word32) readVarCurrency p = do hi <- allocBytes (fromIntegral sizeofInt32) - lo <- allocBytes (fromIntegral sizeofInt32) + lo <- allocBytes (fromIntegral sizeofWord32) o_readVarCurrency <- prim_System_Win32_Com_Automation_Base_readVarCurrency p hi lo checkHR o_readVarCurrency hi <- doThenFree free readInt32 hi - lo <- doThenFree free readInt32 lo + lo <- doThenFree free readWord32 lo return (hi, lo) -foreign import ccall "readVarCurrency" prim_System_Win32_Com_Automation_Base_readVarCurrency :: VARIANT -> Ptr Int32 -> Ptr Int32 -> IO Int32 +foreign import ccall "readVarCurrency" prim_System_Win32_Com_Automation_Base_readVarCurrency :: VARIANT -> Ptr Int32 -> Ptr Word32 -> IO Int32 writeVarWord64 :: Word32 -> Word32 -> VARIANT
cbits/AutoPrimSrc.c view
@@ -427,35 +427,29 @@ v->cyVal.Lo = lo; } -HRESULT readVarCurrency( VARIANT* v, int* hi, int* lo ) -{ +HRESULT readVarCurrency( VARIANT* v, int* hi, unsigned int* lo ) { if (!v) return E_POINTER; if (!hi) return E_POINTER; if (!lo) return E_POINTER; - if (v->vt == VT_CY) - { - *hi = v->cyVal.Hi; - *lo = v->cyVal.Lo; - return S_OK; - } - else - { - VARIANT w; - HRESULT hr; + if ( v->vt == VT_CY ) { + *hi = v->cyVal.Hi; + *lo = v->cyVal.Lo; + return S_OK; + } else { + VARIANT w; + HRESULT hr; - VariantInit(&w); - hr = VariantChangeType( &w, v, 0, VT_CY); - if (SUCCEEDED(hr)) - { - *hi = w.cyVal.Hi; - *lo = w.cyVal.Lo; - } - else - { - *hi = *lo = 0; - } - return hr; + VariantInit(&w); + fprintf(stderr, "0x%04x\n", v->vt); fflush(stderr); + hr = VariantChangeType( &w, v, 0, VT_CY); + if ( SUCCEEDED(hr) ) { + *hi = w.cyVal.Hi; + *lo = w.cyVal.Lo; + } else { + *hi = *lo = 0; + } + return hr; } } @@ -484,39 +478,32 @@ if (!hi) return E_POINTER; if (!lo) return E_POINTER; - if (v->vt == VT_DECIMAL) - { - r = v->decVal.Lo64; - *lo = (unsigned long)r; - r <<= 32; - *hi = (unsigned long)r; - return S_OK; - } - else - { - VARIANT w; - HRESULT hr; + if ( v->vt == VT_DECIMAL ) { + r = v->decVal.Lo64; + *lo = (unsigned long)r; + r <<= 32; + *hi = (unsigned long)r; + return S_OK; + } else { + VARIANT w; + HRESULT hr; - VariantInit(&w); - hr = VariantChangeType( &w, v, 0, VT_DECIMAL); - if (SUCCEEDED(hr)) - { - r = v->decVal.Lo64; - *lo = (unsigned long)r; - r <<= 32; - *hi = (unsigned long)r; - } - else - { - *hi = *lo = 0; - } - return hr; + VariantInit(&w); + hr = VariantChangeType( &w, v, 0, VT_DECIMAL); + if ( SUCCEEDED(hr) ) { + r = v->decVal.Lo64; + *lo = (unsigned long)r; + r <<= 32; + *hi = (unsigned long)r; + } else { + *hi = *lo = 0; + } + return hr; } } -void writeVarVariant( VARIANT* x, VARIANT* v) -{ +void writeVarVariant( VARIANT* x, VARIANT* v) { if (!v) return; if (!x) return; @@ -524,8 +511,7 @@ VariantCopy( v, x ); } -HRESULT readVarVariant( VARIANT* v, VARIANT* x ) -{ +HRESULT readVarVariant( VARIANT* v, VARIANT* x ) { if (!v) return E_POINTER; if (!x) return E_POINTER; @@ -557,8 +543,7 @@ * Automation. */ HRESULT -primClockToDate (int t, double *pt) -{ +primClockToDate (int t, double *pt) { FILETIME ft; SYSTEMTIME st; LONGLONG l = Int32x32To64(t, 10000000) + 116444736000000000ULL;
com.cabal view
@@ -1,5 +1,5 @@ Name: com -version: 1.2.1 +version: 1.2.2 Synopsis: Haskell COM support library Description: COM + Automation libraries for Haskell. @@ -82,6 +82,5 @@ Build-Depends: base >= 4 CPP-Options: -DBASE=4 else - Build-Depends: base - + Buildable: False }
include/autoPrim.h view
@@ -265,7 +265,7 @@ extern HRESULT readVarVariant( VARIANT* v, VARIANT* x ); extern int readVariantTag( VARIANT* v ); extern void writeVarVariant( VARIANT* x, VARIANT* v); -extern HRESULT readVarCurrency( VARIANT* v, int* hi, int* lo ); +extern HRESULT readVarCurrency( VARIANT* v, int* hi, unsigned int* lo ); extern void writeVarCurrency( int hi, unsigned int lo, VARIANT* v ); extern HRESULT readVarWord64( VARIANT* v, unsigned int* hi, unsigned int* lo ); extern void writeVarWord64( unsigned int hi, unsigned int lo, VARIANT* v );