672910f27b
I started from tabs that are not on the beginning of lines, and in several places I did further cleanings. If you're worried about knowing who wrote some code, for example, if you get to this commit in "git blame", then note that you can use the "-w" flag in many git commands to ignore whitespaces. For example, to see per-line authors, use "git blame -w <file>". Another example: to see the (*much* smaller) non-whitespace changes in this (or any other) commit, use "git log -p -w -1 <sha1>".
2248 lines
86 KiB
Racket
2248 lines
86 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/alloc
|
|
ffi/winapi
|
|
ffi/unsafe/atomic
|
|
ffi/unsafe/custodian
|
|
racket/date
|
|
racket/runtime-path
|
|
racket/list
|
|
(for-syntax racket/base)
|
|
"private/win32.rkt")
|
|
|
|
;; Based on Paul Steckler's MysterX (especially the COM automation part)
|
|
|
|
(provide (protect-out
|
|
;; Unsafe:
|
|
|
|
make-com-object
|
|
|
|
define-com-interface
|
|
QueryInterface AddRef Release)
|
|
|
|
;; Unsafe, but protected by original export:
|
|
|
|
SysFreeString SysAllocStringLen
|
|
|
|
;; Not useful in safe mode, but harmless:
|
|
|
|
_wfun _hfun _mfun _hmfun _GUID _GUID-pointer
|
|
_HRESULT _LCID
|
|
|
|
windows-error
|
|
|
|
IID_NULL IID_IUnknown
|
|
_IUnknown _IUnknown-pointer _IUnknown_vt
|
|
|
|
LOCALE_SYSTEM_DEFAULT
|
|
|
|
;; Safe:
|
|
|
|
guid? iid? clsid?
|
|
string->guid string->iid string->clsid
|
|
guid->string
|
|
guid=?
|
|
|
|
progid->clsid clsid->progid
|
|
|
|
com-create-instance com-get-active-object
|
|
com-object? com-object-eq?
|
|
com-object-clsid com-object-set-clsid!
|
|
com-release
|
|
com-object-type com-type? com-type=?
|
|
|
|
com-methods com-method-type com-invoke com-omit
|
|
com-get-properties com-get-property-type com-get-property
|
|
com-set-properties com-set-property-type com-set-property!
|
|
|
|
com-events com-event-type
|
|
com-make-event-executor com-event-executor?
|
|
com-register-event-callback
|
|
com-unregister-event-callback
|
|
|
|
com-object-get-iunknown com-iunknown?
|
|
com-object-get-idispatch com-idispatch?
|
|
|
|
type-description?
|
|
type-describe type-described?
|
|
type-described-value type-described-description)
|
|
|
|
;; FIXME:
|
|
;; call args via var-desc (instead of func-dec)
|
|
|
|
;; ----------------------------------------
|
|
;; GUIDs
|
|
|
|
(define _REFIID _GUID-pointer)
|
|
(define _REFGUID _GUID-pointer)
|
|
(define _REFCLSID _GUID-pointer)
|
|
|
|
(define (copy-guid guid)
|
|
(make-GUID (GUID-l guid)
|
|
(GUID-s1 guid)
|
|
(GUID-s2 guid)
|
|
(GUID-c guid)))
|
|
|
|
(define (guid? v) (and (GUID? v) #t))
|
|
(define (iid? v) (guid? v))
|
|
(define (string->iid s [stay-put? #f])
|
|
(string->guid s stay-put?))
|
|
|
|
(define IID_NULL (make-GUID 0 0 0 '(0 0 0 0 0 0 0 0)))
|
|
(define IID_IUnknown (string->iid "{00000000-0000-0000-C000-000000000046}"
|
|
;; permanent for use in a MULTI_QI:
|
|
#t))
|
|
|
|
|
|
(define-ole CLSIDFromProgID (_hfun _string/utf-16 _pointer
|
|
-> CLSIDFromProgID (void)))
|
|
|
|
(define-ole ProgIDFromCLSID (_fun _GUID-pointer (p : (_ptr o _pointer))
|
|
-> (r : _HRESULT)
|
|
-> (cond
|
|
[(zero? r)
|
|
(begin0
|
|
(cast p _pointer _string/utf-16)
|
|
(CoTaskMemFree p))]
|
|
[(= REGDB_E_CLASSNOTREG r) #f]
|
|
[else (windows-error "ProgIDFromCLSID: failed" r)])))
|
|
|
|
(define (progid->clsid progid)
|
|
(unless (string? progid) (raise-type-error 'progid->clsid "string" progid))
|
|
(define clsid (make-GUID 0 0 0 (list 0 0 0 0 0 0 0 0)))
|
|
(CLSIDFromProgID progid clsid)
|
|
clsid)
|
|
|
|
(define (clsid->progid clsid)
|
|
(unless (clsid? clsid) (raise-type-error 'clsid->progid "clsid" clsid))
|
|
(ProgIDFromCLSID clsid))
|
|
|
|
(define (clsid? v) (guid? v))
|
|
(define (string->clsid s)
|
|
(string->guid s))
|
|
|
|
;; ----------------------------------------
|
|
;; Manual memory management and strings
|
|
|
|
(define (_system-string/utf-16 mode)
|
|
(make-ctype _pointer
|
|
(lambda (s)
|
|
(and s
|
|
(let ([c (string->pointer s)])
|
|
(register-cleanup! (lambda () (SysFreeString c)))
|
|
c)))
|
|
(lambda (p)
|
|
(begin0
|
|
(cast p _pointer _string/utf-16)
|
|
(when (memq 'out mode) (SysFreeString p))))))
|
|
|
|
(define current-cleanup (make-parameter #f))
|
|
(define current-commit (make-parameter #f))
|
|
|
|
(define (register-cleanup! proc)
|
|
(let ([c (current-cleanup)])
|
|
(when c
|
|
(set-box! c (cons proc (unbox c))))))
|
|
|
|
(define (register-commit! proc)
|
|
(let ([c (current-commit)])
|
|
(when c
|
|
(set-box! c (cons proc (unbox c))))))
|
|
|
|
;; ----------------------------------------
|
|
;; Describing COM interfaces for direct calls
|
|
|
|
(define-syntax-rule (_mfun type ...) (_wfun _pointer type ...))
|
|
(define-syntax-rule (_hmfun type ...) (_hfun _pointer type ...))
|
|
|
|
(define-for-syntax (format-id fmt id)
|
|
(datum->syntax id
|
|
(string->symbol (format fmt (syntax-e id)))
|
|
id))
|
|
|
|
(define-syntax (define-com-interface stx)
|
|
(syntax-case stx ()
|
|
[(_ (_id _super-id) ([method-name type . alloc-spec] ...))
|
|
(let ([strip-underscore (lambda (id)
|
|
(unless (identifier? id)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier"
|
|
stx
|
|
id))
|
|
(let ([s (symbol->string (syntax-e id))])
|
|
(unless (regexp-match #rx"^_" s)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier that starts with an underscore"
|
|
stx
|
|
id))
|
|
(datum->syntax id
|
|
(string->symbol (substring s 1))
|
|
id)))])
|
|
(with-syntax ([id (strip-underscore #'_id)]
|
|
[super-id (strip-underscore #'_super-id)])
|
|
(for ([m (in-list (syntax->list #'(method-name ...)))]
|
|
[a (in-list (syntax->list #'(alloc-spec ...)))])
|
|
(unless (identifier? m)
|
|
(raise-syntax-error #f "expected a method-name identifier" stx m))
|
|
(syntax-case a ()
|
|
[() (void)]
|
|
[(#:release-with-function id)
|
|
(unless (identifier? #'id)
|
|
(raise-syntax-error #f "expected an identifier" stx #'id))]
|
|
[(#:release-with-function . _)
|
|
(raise-syntax-error #f "expected an identifier after keyword" stx (syntax-case a () [(x . _) #'x]))]
|
|
[(#:release-with-method id)
|
|
(unless (identifier? #'id)
|
|
(raise-syntax-error #f "expected an identifier" stx #'id))]
|
|
[(#:release-with-method . _)
|
|
(raise-syntax-error #f "expected an identifier after keyword" stx (syntax-case a () [(x . _) #'x]))]
|
|
[(#:releases) (void)]
|
|
[(#:release . _)
|
|
(raise-syntax-error #f "expected nothing after keyword" stx (syntax-case a () [(x . _) #'x]))]
|
|
[(x . _) (raise-syntax-error #f "bad allocation specification" stx #'x)]
|
|
[x (raise-syntax-error #f "bad allocation specification" stx #'x)]))
|
|
(with-syntax ([id_vt (format-id "~a_vt" #'id)]
|
|
[_id_vt (format-id "_~a_vt" #'id)]
|
|
[_id_vt-pointer (format-id "_~a_vt-pointer" #'id)]
|
|
[_super-id_vt (format-id "_~a_vt" #'super-id)]
|
|
[id? (format-id "~a?" #'id)])
|
|
#'(begin
|
|
(define-cstruct (_id _super-id) ())
|
|
(define-cstruct (_id_vt _super-id_vt) ([method-name type] ...))
|
|
(define-syntax/maybe type method-name
|
|
(make-method-syntax #'id_vt #'id #'id? #'_id_vt-pointer #'method-name #'alloc-spec))
|
|
...))))]))
|
|
|
|
(define-syntax define-syntax/maybe
|
|
(syntax-rules (_fpointer)
|
|
[(_ _fpointer . _) (begin)]
|
|
[(_ _ . rest) (define-syntax . rest)]))
|
|
|
|
(define-for-syntax (make-method-syntax id_vt id id? _id_vt-pointer method-name alloc-spec)
|
|
(lambda (stx)
|
|
(if (identifier? stx)
|
|
(raise-syntax-error #f "method name must be used only in an application position" stx)
|
|
(syntax-case stx ()
|
|
[(_ self arg ...)
|
|
(with-syntax ([id_vt id_vt]
|
|
[id id]
|
|
[id? id?]
|
|
[_id_vt-pointer _id_vt-pointer]
|
|
[method-name method-name]
|
|
[alloc-spec alloc-spec]
|
|
[id_vt-method-name (format-id (format "~~a-~a" (syntax-e method-name))
|
|
id_vt)])
|
|
#'(let ([obj self])
|
|
(check-com-type 'method-name 'id id? obj)
|
|
(wrap-alloc-spec
|
|
alloc-spec
|
|
(id_vt-method-name (cast (IUnknown-vt obj) _pointer _id_vt-pointer))
|
|
obj
|
|
arg ...)))]))))
|
|
|
|
(define-syntax wrap-alloc-spec
|
|
(syntax-rules ()
|
|
[(_ () expr arg ...) (expr arg ...)]
|
|
[(_ (#:release-with-function name) expr arg ...)
|
|
(((allocator (lambda (v) (name v)))
|
|
expr)
|
|
arg ...)]
|
|
[(_ (#:release-with-method name) expr obj arg ...)
|
|
(let ([self obj])
|
|
(((allocator (lambda (v) (name self v)))
|
|
(let ([f expr])
|
|
(lambda args
|
|
(AddRef self)
|
|
(apply f args))))
|
|
self
|
|
arg ...))]
|
|
[(_ (#:releases) expr obj arg ...)
|
|
(let ([self obj])
|
|
(((deallocator cadr)
|
|
(let ([f expr])
|
|
(lambda args
|
|
(apply f args)
|
|
(Release self))))
|
|
self arg ...))]))
|
|
|
|
(define (check-com-type who id id? obj)
|
|
(unless (id? obj)
|
|
(raise-type-error who (symbol->string id) obj)))
|
|
|
|
;; --------------------------------------------------
|
|
;; IUnknown
|
|
|
|
(define-cstruct _IUnknown ([vt _pointer]))
|
|
|
|
(define-cstruct _IUnknown_vt
|
|
([QueryInterface (_mfun _REFIID (p : (_ptr o _pointer))
|
|
-> (r : _HRESULT)
|
|
-> (cond
|
|
[(= r E_NOINTERFACE) #f]
|
|
[(positive? r) (windows-error "QueryInterface: failed" r)]
|
|
[else p]))]
|
|
[AddRef (_mfun -> _ULONG)]
|
|
[Release (_mfun -> _ULONG)]))
|
|
|
|
(define Release
|
|
((deallocator)
|
|
(lambda (obj)
|
|
(check-com-type 'Release 'IUknown IUnknown? obj)
|
|
((IUnknown_vt-Release (cast (IUnknown-vt obj) _pointer _IUnknown_vt-pointer))
|
|
obj))))
|
|
|
|
(define QueryInterface
|
|
((allocator Release)
|
|
(lambda (obj refiid _type)
|
|
(check-com-type 'QueryInterface 'IUknown IUnknown? obj)
|
|
(unless (and (ctype? _type)
|
|
(eq? 'pointer (ctype->layout _type)))
|
|
(raise-type-error 'QueryInterface "pointer ctype" _type))
|
|
(define p ((IUnknown_vt-QueryInterface (cast (IUnknown-vt obj) _pointer _IUnknown_vt-pointer))
|
|
obj
|
|
refiid))
|
|
(and p (cast p _pointer _type)))))
|
|
|
|
(define AddRef/no-release
|
|
(lambda (obj)
|
|
(check-com-type 'AddRef 'IUknown IUnknown? obj)
|
|
((IUnknown_vt-AddRef (cast (IUnknown-vt obj) _pointer _IUnknown_vt-pointer))
|
|
obj)))
|
|
|
|
(define AddRef
|
|
((retainer Release) AddRef/no-release))
|
|
|
|
;; --------------------------------------------------
|
|
;; IDispatch
|
|
|
|
(define IID_IDispatch (string->iid "{00020400-0000-0000-C000-000000000046}"))
|
|
|
|
(define-com-interface (_IDispatch _IUnknown)
|
|
([GetTypeInfoCount (_hmfun (c : (_ptr o _UINT))
|
|
-> GetTypeInfoCount c)]
|
|
[GetTypeInfo (_hmfun _UINT _LCID (p : (_ptr o _pointer))
|
|
-> GetTypeInfo (cast p _pointer _ITypeInfo-pointer))
|
|
#:release-with-function Release]
|
|
[GetIDsOfNames (_mfun _REFIID (_ptr i _string/utf-16)
|
|
(_UINT = 1) _LCID
|
|
(p : (_ptr o _DISPID))
|
|
-> (r : _HRESULT)
|
|
-> (values r p))]
|
|
[Invoke (_mfun _DISPID _REFIID _LCID _WORD
|
|
_DISPPARAMS-pointer/null
|
|
_VARIANT-pointer/null
|
|
_pointer ; to _EXCEPINFO
|
|
_pointer ; to _UINT
|
|
-> _HRESULT)]))
|
|
|
|
(define error-index-ptr (malloc 'atomic-interior _UINT))
|
|
|
|
;; --------------------------------------------------
|
|
;; ITypeInfo
|
|
|
|
(define-com-interface (_ITypeInfo _IUnknown)
|
|
([GetTypeAttr (_hmfun (p : (_ptr o _TYPEATTR-pointer/null))
|
|
-> GetTypeAttr p)
|
|
#:release-with-method ReleaseTypeAttr]
|
|
[GetTypeComp _fpointer]
|
|
[GetFuncDesc (_hmfun _UINT (p : (_ptr o _FUNCDESC-pointer/null))
|
|
-> GetFuncDesc p)
|
|
#:release-with-method ReleaseFuncDesc]
|
|
[GetVarDesc (_hmfun _UINT (p : (_ptr o _VARDESC-pointer/null))
|
|
-> GetVarDesc p)
|
|
#:release-with-method ReleaseVarDesc]
|
|
[GetNames (_hmfun _MEMBERID (s : (_ptr o _pointer)) ; string
|
|
(_UINT = 1) (i : (_ptr o _UINT))
|
|
-> GetNames (values (let ([name (cast s _pointer _string/utf-16)])
|
|
(SysFreeString s)
|
|
name)
|
|
i))]
|
|
[GetRefTypeOfImplType (_hmfun _UINT (p : (_ptr o _HREFTYPE))
|
|
-> GetRefTypeOfImplType p)]
|
|
[GetImplTypeFlags (_hmfun _UINT (p : (_ptr o _INT))
|
|
-> GetImplTypeFlags p)]
|
|
[GetIDsOfNames/ti (_hmfun _pointer ; string array
|
|
_UINT
|
|
_pointer ; _MEMBERID array
|
|
-> GetIDsOfNames (void))]
|
|
[Invoke/ti (_hmfun _pointer
|
|
_MEMBERID _WORD _DISPPARAMS-pointer
|
|
(v : (_ptr o _VARIANT))
|
|
(e : (_ptr o _EXCEPINFO))
|
|
(err : (_ptr o _UINT))
|
|
-> Invoke (values v e err))]
|
|
[GetDocumentation (_hmfun _MEMBERID
|
|
_pointer _pointer _pointer
|
|
(p : (_ptr o _pointer))
|
|
-> GetDocumentation p)]
|
|
[GetDllEntry _fpointer]
|
|
[GetRefTypeInfo (_hmfun _HREFTYPE
|
|
(p : (_ptr o _pointer)) ; _ITypeInfo-pointer
|
|
-> GetRefTypeInfo (cast p _pointer _ITypeInfo-pointer))
|
|
#:release-with-function Release]
|
|
[AddressOfMember _fpointer]
|
|
[CreateInstance _fpointer]
|
|
[GetMops _fpointer]
|
|
[GetContainingTypeLib (_hmfun (p : (_ptr o _pointer)) ; _ITypeLib-pointer
|
|
(i : (_ptr o _UINT))
|
|
-> GetContainingTypeLib (cast p _pointer _ITypeLib-pointer))
|
|
#:release-with-function Release]
|
|
[ReleaseTypeAttr (_mfun _TYPEATTR-pointer
|
|
-> _void)
|
|
#:releases]
|
|
[ReleaseFuncDesc (_mfun _FUNCDESC-pointer
|
|
-> _void)
|
|
#:releases]
|
|
[ReleaseVarDesc (_mfun _VARDESC-pointer
|
|
-> _void)
|
|
#:releases]))
|
|
|
|
;; --------------------------------------------------
|
|
;; ITypeLib
|
|
|
|
(define-com-interface (_ITypeLib _IUnknown)
|
|
([GetTypeInfoCount/tl (_mfun -> _UINT)]
|
|
[GetTypeInfo/tl (_hmfun _UINT (p : (_ptr o _ITypeInfo-pointer/null))
|
|
-> GetTypeInfo p)
|
|
#:release-with-function Release]
|
|
[GetTypeInfoType (_hmfun _UINT (p : (_ptr o _TYPEKIND))
|
|
-> GetTypeInfoType p)]
|
|
[GetTypeInfoOfGuid (_hmfun _REFGUID (p : (_ptr o _ITypeInfo-pointer/null))
|
|
-> GetTypeInfoOfGuid p)
|
|
#:release-with-function Release]
|
|
[GetLibAttr _fpointer]
|
|
[GetTypeComp/tl _fpointer]
|
|
[GetDocumentation/tl _fpointer]
|
|
[IsName _fpointer]
|
|
[FindName _fpointer]
|
|
[ReleaseTLibAttr _fpointer]))
|
|
|
|
;; ----------------------------------------
|
|
;; IProvideClassInfo
|
|
|
|
(define IID_IProvideClassInfo (string->iid "{B196B283-BAB4-101A-B69C-00AA00341D07}"))
|
|
|
|
(define-com-interface (_IProvideClassInfo _IUnknown)
|
|
([GetClassInfo (_hmfun (p : (_ptr o _ITypeInfo-pointer/null))
|
|
-> GetClassInfo p)
|
|
#:release-with-function Release]))
|
|
|
|
;; ----------------------------------------
|
|
;; IConnectionPoint
|
|
|
|
(define IID_IConnectionPoint (string->iid "{B196B286-BAB4-101A-B69C-00AA00341D07}"))
|
|
|
|
(define-com-interface (_IConnectionPoint _IUnknown)
|
|
([GetConnectionInterface (_hmfun (g : (_ptr o _GUID))
|
|
-> GetConnectionInterface g)]
|
|
[GetConnectionPointContainer _fpointer]
|
|
[Advise (_hmfun _IUnknown-pointer
|
|
(cookie : (_ptr o _DWORD))
|
|
-> Advise cookie)]
|
|
[Unadvise (_hmfun _DWORD
|
|
-> Unadvise (void))]
|
|
[EnumConnections _fpointer]))
|
|
|
|
;; ----------------------------------------
|
|
;; IConnectionPointContainer
|
|
|
|
(define IID_IConnectionPointContainer (string->iid "{B196B284-BAB4-101A-B69C-00AA00341D07}"))
|
|
|
|
(define-com-interface (_IConnectionPointContainer _IUnknown)
|
|
([EnumConnectionPoints _fpointer]
|
|
[FindConnectionPoint (_hmfun _REFIID
|
|
(p : (_ptr o _IConnectionPoint-pointer/null))
|
|
-> FindConnectionPoint p)
|
|
#:release-with-function Release]))
|
|
|
|
;; ----------------------------------------
|
|
;; IClassFactory
|
|
|
|
(define IID_IClassFactory (string->iid "{00000001-0000-0000-C000-000000000046}"))
|
|
|
|
(define-com-interface (_IClassFactory _IUnknown)
|
|
([CreateInstance/factory (_hmfun _IUnknown-pointer/null _REFIID
|
|
(p : (_ptr o _ISink-pointer/null))
|
|
-> CreateInstance p)]
|
|
[LockServer _fpointer]))
|
|
|
|
|
|
;; ----------------------------------------
|
|
;; COM object creation
|
|
|
|
(define-cstruct _COSERVERINFO ([dwReserved1 _DWORD]
|
|
[pwszName (_system-string/utf-16 '(in))]
|
|
[pAuthInfo _pointer]
|
|
[dwReserved2 _DWORD]))
|
|
(define-cstruct _MULTI_QI ([pIID _GUID-pointer]
|
|
[pItf _IUnknown-pointer/null]
|
|
[hr _HRESULT]))
|
|
|
|
(define-ole CoCreateInstance (_hfun _REFCLSID _pointer _DWORD _REFIID
|
|
(p : (_ptr o _IUnknown-pointer/null))
|
|
-> CoCreateInstance p)
|
|
#:wrap (allocator Release))
|
|
|
|
(define-ole CoCreateInstanceEx (_hfun _REFCLSID _pointer _DWORD
|
|
_COSERVERINFO-pointer/null
|
|
_DWORD
|
|
(mqi : _MULTI_QI-pointer)
|
|
-> CoCreateInstanceEx
|
|
(and (zero? (MULTI_QI-hr mqi))
|
|
(MULTI_QI-pItf mqi))))
|
|
(define-oleaut GetActiveObject (_hfun _REFCLSID
|
|
(_pointer = #f)
|
|
(p : (_ptr o _IUnknown-pointer/null))
|
|
-> GetActiveObject p)
|
|
#:wrap (allocator Release))
|
|
|
|
;; We want to create a finalizer on a `com-object' value,
|
|
;; and we don't want things that an object references to be
|
|
;; finalized before the object. So we use an indirection,
|
|
;; the the finalizer on a `com-object' will have the `impl'
|
|
;; in its closure:
|
|
(struct com-object (impl)
|
|
#:property prop:equal+hash (list
|
|
(lambda (a b eql?)
|
|
(ptr-equal? (com-object-unknown a) (com-object-unknown b)))
|
|
(lambda (a ehc)
|
|
(ehc (com-object-unknown a)))
|
|
(lambda (a ehc2)
|
|
(ehc2 (com-object-unknown a)))))
|
|
|
|
(struct com-impl ([unknown #:mutable]
|
|
[dispatch #:mutable]
|
|
[type-info #:mutable]
|
|
[event-type-info #:mutable]
|
|
[clsid #:mutable]
|
|
[connection-point #:mutable]
|
|
[connection-cookie #:mutable]
|
|
[sink #:mutable]
|
|
[sink-table-links #:mutable]
|
|
[types #:mutable]
|
|
[scheme-types #:mutable]
|
|
[mref #:mutable]))
|
|
|
|
(define (com-object-unknown obj) (com-impl-unknown (com-object-impl obj)))
|
|
(define (com-object-dispatch obj) (com-impl-dispatch (com-object-impl obj)))
|
|
(define (com-object-type-info obj) (com-impl-type-info (com-object-impl obj)))
|
|
(define (com-object-event-type-info obj) (com-impl-event-type-info (com-object-impl obj)))
|
|
(define (com-object-clsid obj) (com-impl-clsid (com-object-impl obj)))
|
|
(define (com-object-connection-point obj) (com-impl-connection-point (com-object-impl obj)))
|
|
(define (com-object-connection-cookie obj) (com-impl-connection-cookie (com-object-impl obj)))
|
|
(define (com-object-sink obj) (com-impl-sink (com-object-impl obj)))
|
|
(define (com-object-sink-table-links obj) (com-impl-sink-table-links (com-object-impl obj)))
|
|
(define (com-object-types obj) (com-impl-types (com-object-impl obj)))
|
|
(define (com-object-scheme-types obj) (com-impl-scheme-types (com-object-impl obj)))
|
|
(define (com-object-mref obj) (com-impl-mref (com-object-impl obj)))
|
|
|
|
(define (com-object-eq? a b)
|
|
(check-com-obj 'com-object-eq? a)
|
|
(check-com-obj 'com-object-eq? b)
|
|
(ptr-equal? (com-object-unknown a) (com-object-unknown b)))
|
|
|
|
(struct com-type (type-info clsid))
|
|
|
|
(define scheme_security_check_file
|
|
(get-ffi-obj 'scheme_security_check_file #f (_fun _string _path _int -> _void)))
|
|
|
|
(define SCHEME_GUARD_FILE_EXECUTE #x4)
|
|
|
|
(define (register-with-custodian obj)
|
|
(define impl (com-object-impl obj))
|
|
(set-com-impl-mref!
|
|
impl
|
|
(register-custodian-shutdown impl impl-release #:at-exit? #t))
|
|
;; If we don't finalize the object, then it could
|
|
;; happen that the object becomes unreachable and
|
|
;; pointers that the object references could be
|
|
;; finalized at the same time that the custodian
|
|
;; changes its weak reference to a strong one; then,
|
|
;; a custodian shutdown would try to redundantly
|
|
;; free the pointers.
|
|
(register-finalizer obj (lambda (obj) (impl-release impl))))
|
|
|
|
(define (do-cocreate-instance who clsid [where 'local])
|
|
(init!)
|
|
|
|
;; Kind of a hack: synthesize a path to represent the class
|
|
;; to be loaded, so that we have a path for the security-guard
|
|
;; check. Putting it in the Windows system folder suggests
|
|
;; an appropriate level of trust: outside of the Racket installation,
|
|
;; but installed on the current machine.
|
|
(scheme_security_check_file "com-create-instance"
|
|
(build-path (find-system-path 'sys-dir)
|
|
"com"
|
|
(guid->string clsid))
|
|
SCHEME_GUARD_FILE_EXECUTE)
|
|
|
|
(define machine
|
|
(cond
|
|
[(eq? where 'local) #f]
|
|
[(eq? where 'remote) #f]
|
|
[(string? where) where]
|
|
[else (raise-type-error who
|
|
"'local, 'remote, or a string"
|
|
where)]))
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(define unknown
|
|
(cond
|
|
[(eq? where 'local)
|
|
(CoCreateInstance clsid #f
|
|
(bitwise-ior CLSCTX_LOCAL_SERVER CLSCTX_INPROC_SERVER)
|
|
IID_IUnknown)]
|
|
[else
|
|
(define cleanup (box null))
|
|
(define csi (parameterize ([current-cleanup cleanup])
|
|
(make-COSERVERINFO 0 machine #f 0)))
|
|
(define mqi (make-MULTI_QI IID_IUnknown #f 0))
|
|
(define unknown
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(CoCreateInstanceEx clsid #f CLSCTX_REMOTE_SERVER (and machine csi) 1 mqi))
|
|
(lambda ()
|
|
(for ([proc (in-list (unbox cleanup))]) (proc)))))
|
|
(unless (and (zero? (MULTI_QI-hr mqi))
|
|
unknown)
|
|
(error who "unable to obtain IUnknown interface for remote server"))
|
|
unknown]))
|
|
|
|
(make-com-object unknown clsid))))
|
|
|
|
(define (make-com-object unknown clsid #:manage? [manage? #t])
|
|
(unless (com-iunknown? unknown) (raise-type-error 'make-com-object "com-iunknown" unknown))
|
|
(unless (or (not clsid) (clsid? clsid)) (raise-type-error 'make-com-object "clsid or #f" clsid))
|
|
(define obj (com-object
|
|
(com-impl unknown
|
|
#f
|
|
#f
|
|
#f
|
|
clsid
|
|
#f
|
|
#f
|
|
#f
|
|
#f
|
|
(make-hash)
|
|
(make-hash)
|
|
#f)))
|
|
(when manage?
|
|
(register-with-custodian obj))
|
|
obj)
|
|
|
|
(define (com-release obj)
|
|
(check-com-obj 'com-release obj)
|
|
(impl-release (com-object-impl obj)))
|
|
|
|
(define (impl-release impl)
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(let ([mref (com-impl-mref impl)])
|
|
(when mref
|
|
(set-com-impl-mref! impl #f)
|
|
(unregister-custodian-shutdown impl mref)))
|
|
(release-type-types (com-impl-type-info impl))
|
|
(define (bye! sel st!)
|
|
(when (sel impl)
|
|
(Release (sel impl))
|
|
(st! impl #f)))
|
|
(bye! com-impl-type-info
|
|
set-com-impl-type-info!)
|
|
(bye! com-impl-event-type-info
|
|
set-com-impl-event-type-info!)
|
|
(bye! com-impl-connection-point
|
|
set-com-impl-connection-point!)
|
|
(bye! com-impl-sink
|
|
set-com-impl-sink!)
|
|
(bye! com-impl-dispatch
|
|
set-com-impl-dispatch!)
|
|
(bye! com-impl-unknown
|
|
set-com-impl-unknown!))))
|
|
|
|
(define (release-type-types type-info)
|
|
(when type-info
|
|
(let ([type (type-info-type type-info)])
|
|
(set-type-ref-count! type (sub1 (type-ref-count type)))
|
|
(when (zero? (type-ref-count type))
|
|
(when (positive? (hash-count (type-types type)))
|
|
(for ([td (in-hash-values (type-types type))])
|
|
(release-type-desc td))
|
|
(set-type-types! type (make-hash)))
|
|
(hash-remove! types type-info)))))
|
|
|
|
(define (release-type-desc td)
|
|
;; call in atomic mode
|
|
(define type-info (mx-com-type-desc-type-info td))
|
|
(define type-info-impl (mx-com-type-desc-type-info-impl td))
|
|
(define tdd (mx-com-type-desc-desc td))
|
|
(cond
|
|
[(list? tdd)
|
|
(ReleaseFuncDesc type-info (car tdd))
|
|
(when type-info-impl
|
|
(ReleaseFuncDesc type-info-impl (cadr tdd)))]
|
|
[else
|
|
(ReleaseVarDesc type-info tdd)])
|
|
(Release type-info)
|
|
(when type-info-impl
|
|
(Release type-info-impl)))
|
|
|
|
(define (gen->clsid who name)
|
|
(cond
|
|
[(clsid? name) name]
|
|
[(string? name) (progid->clsid name)]
|
|
[else
|
|
(raise-type-error who "clsid or string" name)]))
|
|
|
|
(define (com-create-instance name [where 'local])
|
|
(define clsid (gen->clsid 'com-create-instance name))
|
|
(do-cocreate-instance 'com-create-instance clsid where))
|
|
|
|
(define (com-get-active-object name)
|
|
(init!)
|
|
(define clsid (gen->clsid 'com-get-active-object name))
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(define unknown (GetActiveObject clsid))
|
|
(and unknown
|
|
(make-com-object unknown clsid)))))
|
|
|
|
(define (check-com-obj who obj)
|
|
(unless (com-object? obj)
|
|
(raise-type-error who "com-object" obj)))
|
|
|
|
(define (com-object-set-clsid! obj clsid)
|
|
(check-com-obj 'com-object-set-clsid! obj)
|
|
(unless (clsid? clsid) (raise-type-error 'com-object-set-clsid! "clsid" clsid))
|
|
(set-com-impl-clsid! (com-object-impl obj) clsid))
|
|
|
|
;; ----------------------------------------
|
|
;; Getting COM methods and types
|
|
|
|
(define (com-object-get-unknown obj)
|
|
(or (com-object-unknown obj)
|
|
(error 'com-object-get-unknown "COM object has been released: ~e" obj)))
|
|
|
|
(define (com-object-get-dispatch obj)
|
|
(or (com-object-dispatch obj)
|
|
(let ([dispatch (QueryInterface (com-object-get-unknown obj)
|
|
IID_IDispatch
|
|
_IDispatch-pointer)])
|
|
(unless dispatch
|
|
(error 'com-object-get-idispatch "cannot get IDispatch interface for object: ~e" obj))
|
|
(set-com-impl-dispatch! (com-object-impl obj) dispatch)
|
|
dispatch)))
|
|
|
|
(struct type (type-info [types #:mutable]
|
|
scheme-types
|
|
[ref-count #:mutable]))
|
|
(define types (make-weak-hash))
|
|
|
|
(define (intern-type-info type-info)
|
|
;; called in atomic mode
|
|
(let ([ti-e (hash-ref types type-info #f)])
|
|
(if ti-e
|
|
(let* ([t (ephemeron-value ti-e)]
|
|
[ti (type-type-info t)])
|
|
(set-type-ref-count! t (add1 (type-ref-count t)))
|
|
(Release type-info)
|
|
(AddRef ti)
|
|
t)
|
|
(let ([t (type type-info (make-hash) (make-hash) 1)])
|
|
(hash-set! types type-info (make-ephemeron type-info t))
|
|
t))))
|
|
|
|
(define (type-info-type type-info)
|
|
(ephemeron-value (hash-ref types type-info)))
|
|
|
|
(define (type-info-from-com-object obj [exn? #t])
|
|
(or (com-object-type-info obj)
|
|
(let ([dispatch (com-object-get-dispatch obj)])
|
|
(define c (GetTypeInfoCount dispatch))
|
|
(if (zero? c)
|
|
(if exn?
|
|
(error "COM object does not expose type information")
|
|
#f)
|
|
(let ([type-info (GetTypeInfo
|
|
dispatch
|
|
0
|
|
LOCALE_SYSTEM_DEFAULT)])
|
|
(unless type-info
|
|
(error "Error getting COM type information"))
|
|
(let* ([type (intern-type-info type-info)]
|
|
[type-info (type-type-info type)]
|
|
[impl (com-object-impl obj)])
|
|
(set-com-impl-type-info! impl type-info)
|
|
(set-com-impl-types! impl (type-types type))
|
|
(set-com-impl-scheme-types! impl (type-scheme-types type))
|
|
type-info))))))
|
|
|
|
(define (com-object-type obj)
|
|
(check-com-obj 'com-object-type obj)
|
|
(com-type (type-info-from-com-object obj)
|
|
(com-object-clsid obj)))
|
|
|
|
(define (event-type-info-from-coclass-type-info coclass-type-info)
|
|
(define type-attr (GetTypeAttr coclass-type-info))
|
|
(for/or ([i (in-range (begin0
|
|
(TYPEATTR-cImplTypes type-attr)
|
|
(ReleaseTypeAttr coclass-type-info type-attr)))])
|
|
(define type-flags (GetImplTypeFlags coclass-type-info i))
|
|
(and (bit-and? type-flags IMPLTYPEFLAG_FSOURCE)
|
|
(bit-and? type-flags IMPLTYPEFLAG_FDEFAULT)
|
|
(let ()
|
|
(define ref-type (GetRefTypeOfImplType coclass-type-info i))
|
|
(GetRefTypeInfo coclass-type-info ref-type)))))
|
|
|
|
(define (type-info=? a b)
|
|
;; intensional equality
|
|
(or (eq? a b)
|
|
(let ([aa (GetTypeAttr a)]
|
|
[ba (GetTypeAttr b)])
|
|
(begin0
|
|
(guid=? (TYPEATTR-guid aa)
|
|
(TYPEATTR-guid ba))
|
|
(ReleaseTypeAttr a aa)
|
|
(ReleaseTypeAttr b ba)))))
|
|
|
|
(define (com-type=? a b)
|
|
(unless (com-type? a) (raise-type-error 'com-type=? "com-type" a))
|
|
(unless (com-type? b) (raise-type-error 'com-type=? "com-type" b))
|
|
(type-info=? (com-type-type-info a) (com-type-type-info b)))
|
|
|
|
(define (coclass-type-info-from-type-info type-info clsid)
|
|
(define type-lib (GetContainingTypeLib type-info))
|
|
;; first, try using explicit clsId
|
|
(cond
|
|
[(and clsid
|
|
(GetTypeInfoOfGuid type-lib clsid))
|
|
=> (lambda (coclass-type-info)
|
|
(Release type-lib)
|
|
coclass-type-info)]
|
|
;; if no CLSID, search for coclass implementing supplied
|
|
;; interface
|
|
[else
|
|
(define coclass-index
|
|
(for/fold ([found #f]) ([i (in-range (GetTypeInfoCount/tl type-lib))])
|
|
(define type-kind (GetTypeInfoType type-lib i))
|
|
(cond
|
|
[(= type-kind TKIND_COCLASS)
|
|
(define coclass-type-info (GetTypeInfo/tl type-lib i))
|
|
(define count (let ()
|
|
(define type-attr (GetTypeAttr coclass-type-info))
|
|
(begin0
|
|
(TYPEATTR-cImplTypes type-attr)
|
|
(ReleaseTypeAttr coclass-type-info type-attr))))
|
|
(begin0
|
|
(for/fold ([found found]) ([j (in-range count)])
|
|
(define ref-type (GetRefTypeOfImplType coclass-type-info j))
|
|
(define candidate-type-info (GetRefTypeInfo coclass-type-info ref-type))
|
|
(begin0
|
|
(if (type-info=? candidate-type-info type-info)
|
|
(if found
|
|
(error "Ambiguous coclass for object")
|
|
i)
|
|
found)
|
|
(Release candidate-type-info)))
|
|
(Release coclass-type-info))]
|
|
[else found])))
|
|
(begin0
|
|
(and coclass-index
|
|
(GetTypeInfo/tl type-lib coclass-index))
|
|
(Release type-lib))]))
|
|
|
|
(define (event-type-info-from-com-object obj)
|
|
(or (com-object-event-type-info obj)
|
|
(let ([dispatch (com-object-get-dispatch obj)])
|
|
(define provide-class-info (QueryInterface dispatch IID_IProvideClassInfo _IProvideClassInfo-pointer))
|
|
(define coclass-type-info
|
|
(cond
|
|
[provide-class-info
|
|
(begin0
|
|
(GetClassInfo provide-class-info)
|
|
(Release provide-class-info))]
|
|
[else
|
|
(define type-info (type-info-from-com-object obj))
|
|
(coclass-type-info-from-type-info type-info
|
|
(com-object-clsid obj))]))
|
|
(define event-type-info (event-type-info-from-coclass-type-info
|
|
coclass-type-info))
|
|
(Release coclass-type-info)
|
|
(set-com-impl-event-type-info! (com-object-impl obj) event-type-info)
|
|
event-type-info)))
|
|
|
|
(define (is-dispatch-name? s)
|
|
(member s '("AddRef" "GetIDsOfNames"
|
|
"GetTypeInfo" "GetTypeInfoCount"
|
|
"Invoke" "QueryInterface"
|
|
"Release")))
|
|
|
|
(define (get-type-names type-info type-attr accum inv-kind)
|
|
(define accum1
|
|
(for/fold ([accum accum]) ([i (in-range (TYPEATTR-cImplTypes type-attr))])
|
|
(define ref-type (GetRefTypeOfImplType type-info i))
|
|
(define type-info-impl (GetRefTypeInfo type-info ref-type))
|
|
(define type-attr-impl (GetTypeAttr type-info-impl))
|
|
;; recursion, to ascend the inheritance graph
|
|
(define new-accum (get-type-names type-info-impl type-attr-impl accum inv-kind))
|
|
(ReleaseTypeAttr type-info-impl type-attr-impl)
|
|
(Release type-info-impl)
|
|
new-accum))
|
|
;; properties can appear in list of functions
|
|
;; or in list of variables
|
|
(define accum2
|
|
(for/fold ([accum accum1]) ([i (in-range (TYPEATTR-cFuncs type-attr))])
|
|
(define func-desc (GetFuncDesc type-info i))
|
|
(define new-accum
|
|
(if (= inv-kind (FUNCDESC-invkind func-desc))
|
|
(let-values ([(name count) (GetNames type-info (FUNCDESC-memid func-desc))])
|
|
;; don't consider names inherited from IDispatch
|
|
(if (or (not (= inv-kind INVOKE_FUNC))
|
|
(not (is-dispatch-name? name)))
|
|
(cons name accum)
|
|
accum))
|
|
accum))
|
|
(ReleaseFuncDesc type-info func-desc)
|
|
new-accum))
|
|
(if (= inv-kind INVOKE_FUNC) ; done, if not a property
|
|
accum2
|
|
(for/fold ([accum accum2]) ([i (in-range (TYPEATTR-cVars type-attr))])
|
|
(define var-desc (GetVarDesc type-info i))
|
|
(let-values ([(name count) (GetNames type-info (FUNCDESC-memid var-desc))])
|
|
(begin0
|
|
(cons name accum)
|
|
(ReleaseVarDesc type-info var-desc))))))
|
|
|
|
(define (extract-type-info who obj exn?)
|
|
(cond
|
|
[(com-object? obj) (type-info-from-com-object obj exn?)]
|
|
[(com-type? obj) (com-type-type-info obj)]
|
|
[else (raise-type-error who "com-object or com-type" obj)]))
|
|
|
|
(define (do-get-methods who obj inv-kind)
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(define type-info (extract-type-info who obj #t))
|
|
(define type-attr (GetTypeAttr type-info))
|
|
(begin0
|
|
(sort (get-type-names type-info type-attr null inv-kind) string-ci<?)
|
|
(ReleaseTypeAttr type-info type-attr)))))
|
|
|
|
(define (com-methods obj)
|
|
(do-get-methods 'com-methods obj INVOKE_FUNC))
|
|
|
|
(define (com-get-properties obj)
|
|
(do-get-methods 'com-get-properties obj INVOKE_PROPERTYGET))
|
|
|
|
(define (com-set-properties obj)
|
|
(do-get-methods 'com-set-properties obj INVOKE_PROPERTYPUT))
|
|
|
|
(define (event-type-info-from-type-info type-info clsid)
|
|
(event-type-info-from-coclass-type-info
|
|
(coclass-type-info-from-type-info type-info clsid)))
|
|
|
|
(define (extract-event-type-info who obj)
|
|
(cond
|
|
[(com-object? obj) (event-type-info-from-com-object obj)]
|
|
[(com-type? obj) (event-type-info-from-com-type obj)]
|
|
[else (raise-type-error who "com-object or com-type" obj)]))
|
|
|
|
(define (com-events obj)
|
|
(define event-type-info (extract-event-type-info 'com-events obj))
|
|
(define type-attr (GetTypeAttr event-type-info))
|
|
(begin0
|
|
(sort
|
|
(for/list ([i (in-range (TYPEATTR-cFuncs type-attr))])
|
|
(define func-desc (GetFuncDesc event-type-info i))
|
|
(define-values (name count) (GetNames event-type-info (FUNCDESC-memid func-desc)))
|
|
(begin0
|
|
name
|
|
(ReleaseFuncDesc event-type-info func-desc)))
|
|
string-ci<?)
|
|
(ReleaseTypeAttr event-type-info type-attr)))
|
|
|
|
(struct mx-com-type-desc (memid
|
|
type-info
|
|
type-info-impl
|
|
fun-offset
|
|
impl-guid
|
|
desc))
|
|
|
|
(define (function-type-desc? td)
|
|
(list? (mx-com-type-desc-desc td)))
|
|
|
|
(define (type-desc-from-type-info name inv-kind type-info)
|
|
(define type-attr (GetTypeAttr type-info))
|
|
;; can skip first 7, because those are IDispatch-specific
|
|
(define num-funcs (TYPEATTR-cFuncs type-attr))
|
|
(define found
|
|
(or
|
|
(for/or ([i (in-range 7 num-funcs)])
|
|
(define func-desc (GetFuncDesc type-info i))
|
|
(define-values (ti-name name-count) (GetNames type-info (FUNCDESC-memid func-desc)))
|
|
;; see if this FUNCDESC is the one we want
|
|
(cond
|
|
[(and (string=? ti-name name)
|
|
(or (= inv-kind INVOKE_EVENT)
|
|
(= inv-kind (FUNCDESC-invkind func-desc))))
|
|
(list func-desc i)]
|
|
[else
|
|
(ReleaseFuncDesc type-info func-desc)
|
|
#f]))
|
|
(and (or (= inv-kind INVOKE_PROPERTYGET)
|
|
(= inv-kind INVOKE_PROPERTYPUT)
|
|
(= inv-kind INVOKE_PROPERTYPUTREF))
|
|
(for/or ([i (in-range (TYPEATTR-cVars type-attr))])
|
|
(define var-desc (GetVarDesc type-info i))
|
|
(define-values (ti-name name-count) (GetNames type-info (VARDESC-memid var-desc)))
|
|
;; see if this VARDESC is the one we want
|
|
(cond
|
|
[(string=? ti-name name)
|
|
var-desc]
|
|
[else
|
|
(ReleaseVarDesc type-info var-desc)
|
|
#f])))
|
|
;; search in inherited interfaces
|
|
(for/or ([i (in-range (TYPEATTR-cImplTypes type-attr))])
|
|
(define ref-type (GetRefTypeOfImplType type-info i))
|
|
(define type-info-impl (GetRefTypeInfo type-info ref-type))
|
|
;; recursion, to ascend the inheritance graph
|
|
(define type-desc (type-desc-from-type-info name inv-kind type-info-impl))
|
|
(Release type-info-impl)
|
|
type-desc)))
|
|
|
|
(ReleaseTypeAttr type-info type-attr)
|
|
|
|
(cond
|
|
[(mx-com-type-desc? found) found]
|
|
[(not found) #f]
|
|
[(VARDESC? found)
|
|
(mx-com-type-desc (VARDESC-memid found)
|
|
(begin
|
|
(AddRef type-info)
|
|
type-info)
|
|
#f
|
|
#f
|
|
#f
|
|
found)]
|
|
[else
|
|
(define ref-type (with-handlers ([exn:fail? (lambda (x) #f)])
|
|
(GetRefTypeOfImplType type-info -1)))
|
|
(define type-info-impl (and ref-type
|
|
(GetRefTypeInfo type-info ref-type)))
|
|
(define mx-type-desc
|
|
(and type-info-impl
|
|
(let ([type-attr-impl (GetTypeAttr type-info-impl)])
|
|
;; assumption: impl TypeInfo has FuncDescs in same order
|
|
;; as the Dispatch TypeInfo
|
|
;; but num-funcs has IDispatch methods
|
|
(define func-index (- (cadr found)
|
|
(- num-funcs
|
|
(TYPEATTR-cFuncs type-attr-impl))))
|
|
(define func-desc-impl (GetFuncDesc type-info-impl func-index))
|
|
(begin0
|
|
(if (or (= (FUNCDESC-funckind func-desc-impl) FUNC_VIRTUAL)
|
|
(= (FUNCDESC-funckind func-desc-impl) FUNC_PUREVIRTUAL))
|
|
(mx-com-type-desc (FUNCDESC-memid (car found))
|
|
(begin
|
|
(AddRef type-info)
|
|
type-info)
|
|
(begin
|
|
(AddRef type-info-impl)
|
|
type-info-impl)
|
|
(quotient (FUNCDESC-oVft func-desc-impl) (ctype-sizeof _pointer))
|
|
(copy-guid (TYPEATTR-guid type-attr-impl))
|
|
(list (car found)
|
|
func-desc-impl))
|
|
(begin
|
|
(ReleaseFuncDesc type-info-impl func-desc-impl)
|
|
#f))
|
|
(ReleaseTypeAttr type-info-impl type-attr-impl))
|
|
(Release type-info-impl))))
|
|
|
|
(or mx-type-desc
|
|
(mx-com-type-desc (FUNCDESC-memid (car found))
|
|
(begin
|
|
(AddRef type-info)
|
|
type-info)
|
|
#f
|
|
#f
|
|
#f
|
|
(list (car found) #f)))]))
|
|
|
|
(define (event-type-info-from-com-type obj)
|
|
(event-type-info-from-type-info (com-type-type-info obj)
|
|
(com-type-clsid obj)))
|
|
|
|
(define (get-method-type obj name inv-kind [exn? #t])
|
|
(or (hash-ref (com-object-types obj) (cons name inv-kind) #f)
|
|
(let ([type-info
|
|
(cond
|
|
[(= inv-kind INVOKE_EVENT)
|
|
(event-type-info-from-com-object obj)]
|
|
[else
|
|
(type-info-from-com-object obj exn?)])])
|
|
(and type-info
|
|
(let ([mx-type-desc (type-desc-from-type-info name inv-kind type-info)])
|
|
(when mx-type-desc
|
|
(hash-set! (com-object-types obj) (cons name inv-kind) mx-type-desc))
|
|
mx-type-desc)))))
|
|
|
|
(define (get-var-type-from-elem-desc elem-desc
|
|
#:keep-safe-array? [keep-safe-array? #f])
|
|
;; hack: allow elem-desc as a TYPEDESC
|
|
(define param-desc (and (ELEMDESC? elem-desc)
|
|
(union-ref (ELEMDESC-u elem-desc) 1)))
|
|
(define flags (if param-desc
|
|
(PARAMDESC-wParamFlags param-desc)
|
|
0))
|
|
(define (fixup-vt vt)
|
|
(cond
|
|
[(= vt (bitwise-ior VT_USERDEFINED VT_BYREF))
|
|
VT_UNKNOWN]
|
|
[(= vt VT_USERDEFINED)
|
|
VT_INT]
|
|
[(and (= vt VT_SAFEARRAY)
|
|
(not keep-safe-array?))
|
|
(bitwise-ior VT_ARRAY VT_VARIANT)]
|
|
[else vt]))
|
|
(define type-desc (if (ELEMDESC? elem-desc)
|
|
(ELEMDESC-tdesc elem-desc)
|
|
elem-desc))
|
|
(cond
|
|
[(and (bit-and? flags PARAMFLAG_FOPT)
|
|
(bit-and? flags PARAMFLAG_FHASDEFAULT))
|
|
(fixup-vt
|
|
(VARIANT-vt (PARAMDESCEX-varDefaultValue (PARAMDESC-pparamdescex param-desc))))]
|
|
[(= (TYPEDESC-vt type-desc) VT_PTR)
|
|
(fixup-vt
|
|
(bitwise-ior VT_BYREF
|
|
(TYPEDESC-vt (cast (union-ref (TYPEDESC-u type-desc) 0)
|
|
_pointer
|
|
_TYPEDESC-pointer))))]
|
|
[else
|
|
(fixup-vt (TYPEDESC-vt type-desc))]))
|
|
|
|
(define (elem-desc-has-default? elem-desc)
|
|
(define param-desc (union-ref (ELEMDESC-u elem-desc) 1))
|
|
(define flags (PARAMDESC-wParamFlags param-desc))
|
|
(bit-and? flags PARAMFLAG_FHASDEFAULT))
|
|
|
|
(define (elem-desc-is-optional? elem-desc)
|
|
(define param-desc (union-ref (ELEMDESC-u elem-desc) 1))
|
|
(define flags (PARAMDESC-wParamFlags param-desc))
|
|
(bit-and? flags PARAMFLAG_FOPT))
|
|
|
|
(define-syntax-rule (switch e [val expr] ... [else else-expr])
|
|
(let ([v e])
|
|
(cond
|
|
[(= v val) expr]
|
|
...
|
|
[else else-expr])))
|
|
|
|
(define (elem-desc-to-scheme-type elem-desc ignore-by-ref? is-opt? internal?)
|
|
(define vt (let ([vt (get-var-type-from-elem-desc elem-desc #:keep-safe-array? #t)])
|
|
(if (and ignore-by-ref?
|
|
(not (= vt (bitwise-ior VT_USERDEFINED VT_BYREF))))
|
|
(- vt (bitwise-and vt VT_BYREF))
|
|
vt)))
|
|
(cond
|
|
[(= vt (bitwise-ior VT_USERDEFINED VT_BYREF))
|
|
;; The convention is that these represent specific COM interfaces
|
|
;; that the caller and callee have agreed upon. For our purposes,
|
|
;; it is an IUnknown pointer.
|
|
(if is-opt?
|
|
'(opt iunknown)
|
|
'iunknown)]
|
|
[(= vt VT_SAFEARRAY) `(array ? any)]
|
|
[(bit-and? vt VT_ARRAY)
|
|
(define array-desc (cast (union-ref (TYPEDESC-u (ELEMDESC-tdesc elem-desc)) 1)
|
|
_pointer
|
|
_ARRAYDESC-pointer))
|
|
(define base
|
|
(elem-desc-to-scheme-type (ARRAYDESC-tdescElem array-desc) #f #f internal?))
|
|
(for/fold ([base base]) ([i (in-range (ARRAYDESC-cDims array-desc))])
|
|
`(array ,(SAFEARRAYBOUND-cElements (ptr-ref (array-ptr (ARRAYDESC-rgbounds array-desc))
|
|
_SAFEARRAYBOUND
|
|
i))
|
|
,base))]
|
|
[else
|
|
(define as-iunk? (= vt (bitwise-ior VT_USERDEFINED VT_BYREF)))
|
|
(define base (vt-to-scheme-type (if as-iunk?
|
|
vt
|
|
(- vt (bitwise-and vt VT_BYREF)))))
|
|
(define new-base
|
|
(if (and (not as-iunk?)
|
|
(bit-and? vt VT_BYREF))
|
|
`(box ,base)
|
|
base))
|
|
(if is-opt?
|
|
`(opt ,new-base)
|
|
new-base)]))
|
|
|
|
(define (vt-to-scheme-type vt)
|
|
(switch
|
|
vt
|
|
[VT_HRESULT 'void]
|
|
[VT_EMPTY 'void]
|
|
[VT_NULL 'void]
|
|
[VT_UI1 'char]
|
|
[VT_UI2 'unsigned-short]
|
|
[VT_UI4 'unsigned-int]
|
|
[VT_UINT 'unsigned-int]
|
|
[VT_UI8 'unsigned-long-long]
|
|
[VT_I1 'signed-char]
|
|
[VT_I2 'short-int]
|
|
[VT_I4 'int]
|
|
[VT_INT 'int]
|
|
[VT_I8 'long-long]
|
|
[VT_R4 'float]
|
|
[VT_R8 'double]
|
|
[VT_BSTR 'string]
|
|
[VT_CY 'currency]
|
|
[VT_DATE 'date]
|
|
[VT_BOOL 'boolean]
|
|
[VT_ERROR 'scode]
|
|
[VT_UNKNOWN 'iunknown]
|
|
[VT_DISPATCH 'com-object]
|
|
[VT_VARIANT 'any]
|
|
[VT_USERDEFINED
|
|
;; Reporting this as `user-defined' is sure to confuse somebody.
|
|
;; The convention is that these are ENUMs that the caller and the
|
|
;; callee have agreed upon. For our purposes, they will be INTs,
|
|
;; but we'll report them as an enumeration.
|
|
'com-enumeration]
|
|
[VT_VOID 'void]
|
|
[VT_SAFEARRAY `(array ? any)]
|
|
[else
|
|
(cond
|
|
[(= VT_ARRAY (bitwise-and vt VT_ARRAY))
|
|
`(array ? ,(vt-to-scheme-type (- vt VT_ARRAY)))]
|
|
[(= vt (bitwise-ior VT_USERDEFINED VT_BYREF))
|
|
'iunknown]
|
|
[(= VT_BYREF (bitwise-and vt VT_BYREF))
|
|
`(box ,(vt-to-scheme-type (- vt VT_BYREF)))]
|
|
[else
|
|
(string->symbol (format "COM-0x~x" vt))])]))
|
|
|
|
(define (arg-to-type arg [in-array 0])
|
|
(cond
|
|
[(type-described? arg)
|
|
(type-described-description arg)]
|
|
[(vector? arg) `(array ,(vector-length arg)
|
|
,(if (zero? (vector-length arg))
|
|
'int
|
|
(for/fold ([t (arg-to-type (vector-ref arg 0))]) ([v (in-vector arg)])
|
|
(if (equal? t (arg-to-type v))
|
|
t
|
|
'any))))]
|
|
[(in-array . > . 1) 'any]
|
|
[(boolean? arg) 'boolean]
|
|
[(signed-int? arg 32) 'int]
|
|
[(unsigned-int? arg 32) 'unsigned-int]
|
|
[(signed-int? arg 64) 'long-long]
|
|
[(unsigned-int? arg 64) 'unsigned-long-long]
|
|
[(string? arg) 'string]
|
|
[(real? arg) 'double]
|
|
[(com-object? arg) 'com-object]
|
|
[(IUnknown? arg) 'iunknown]
|
|
[(eq? com-omit arg) 'any]
|
|
[(box? arg) `(box ,(arg-to-type (unbox arg)))]
|
|
[else (error 'com "cannot infer marshal format for value: ~e" arg)]))
|
|
|
|
(define (elem-desc-ref func-desc i)
|
|
(ptr-add (FUNCDESC-lprgelemdescParam func-desc) i _ELEMDESC))
|
|
|
|
(define (is-last-param-retval? inv-kind func-desc)
|
|
(define num-params (FUNCDESC-cParams func-desc))
|
|
(and (positive? num-params)
|
|
(or (= inv-kind INVOKE_PROPERTYGET)
|
|
(= inv-kind INVOKE_FUNC))
|
|
(bit-and?
|
|
PARAMFLAG_FRETVAL
|
|
(PARAMDESC-wParamFlags
|
|
(union-ref
|
|
(ELEMDESC-u (elem-desc-ref func-desc (sub1 num-params)))
|
|
1)))))
|
|
|
|
(define (get-opt-param-count func-desc num-params)
|
|
(for/fold ([count 0]) ([i (in-range num-params)])
|
|
(if (bit-and?
|
|
PARAMFLAG_FOPT
|
|
(PARAMDESC-wParamFlags
|
|
(union-ref
|
|
(ELEMDESC-u (elem-desc-ref func-desc (sub1 num-params)))
|
|
1)))
|
|
(add1 count)
|
|
0)))
|
|
|
|
(define (do-get-method-type who obj name inv-kind internal?)
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(or (and (com-object? obj)
|
|
(hash-ref (com-object-scheme-types obj) (cons name inv-kind) #f))
|
|
(let ([t (get-uncached-method-type who obj name inv-kind internal?)])
|
|
(when (com-object? obj)
|
|
(hash-set! (com-object-scheme-types obj) (cons name inv-kind) t))
|
|
t)))))
|
|
|
|
(define (get-uncached-method-type who obj name inv-kind internal?)
|
|
(define type-info (extract-type-info who obj (not internal?)))
|
|
(when (and (= inv-kind INVOKE_FUNC)
|
|
(is-dispatch-name? name))
|
|
(error who "IDispatch methods not available"))
|
|
(define mx-type-desc
|
|
(cond
|
|
[(com-object? obj) (get-method-type obj name inv-kind (not internal?))]
|
|
[else (define x-type-info
|
|
(if (= inv-kind INVOKE_EVENT)
|
|
(event-type-info-from-com-type obj)
|
|
type-info))
|
|
(type-desc-from-type-info name inv-kind x-type-info)]))
|
|
(cond
|
|
[(not mx-type-desc)
|
|
;; there is no type info
|
|
#f]
|
|
[else
|
|
(define-values (args ret)
|
|
(cond
|
|
[(function-type-desc? mx-type-desc)
|
|
(define func-desc (car (mx-com-type-desc-desc mx-type-desc)))
|
|
(define num-actual-params (FUNCDESC-cParams func-desc))
|
|
(cond
|
|
[(= -1 (FUNCDESC-cParamsOpt func-desc))
|
|
;; all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY,
|
|
;; but that is handled by COM automation; we just pass "any"s
|
|
(values
|
|
(append
|
|
(for/list ([i (in-range (sub1 num-actual-params))])
|
|
(elem-desc-to-scheme-type (elem-desc-ref func-desc i)
|
|
#f
|
|
#f
|
|
internal?))
|
|
'(any ...))
|
|
(elem-desc-to-scheme-type (FUNCDESC-elemdescFunc func-desc)
|
|
#f
|
|
#f
|
|
internal?))]
|
|
[else
|
|
(define last-is-retval?
|
|
(is-last-param-retval? inv-kind func-desc))
|
|
(define num-params (- num-actual-params (if last-is-retval? 1 0)))
|
|
;; parameters that are optional with a default value in IDL are not
|
|
;; counted in pFuncDesc->cParamsOpt, so look for default bit flag
|
|
(define num-opt-params (get-opt-param-count func-desc num-params))
|
|
(define first-opt-arg (- num-params num-opt-params))
|
|
(values
|
|
(for/list ([i (in-range num-params)])
|
|
(elem-desc-to-scheme-type (elem-desc-ref func-desc i)
|
|
#f
|
|
(i . >= . first-opt-arg)
|
|
internal?))
|
|
(elem-desc-to-scheme-type (if last-is-retval?
|
|
(elem-desc-ref func-desc num-params)
|
|
(FUNCDESC-elemdescFunc func-desc))
|
|
#t
|
|
#f
|
|
internal?))])]
|
|
[(= inv-kind INVOKE_PROPERTYGET)
|
|
(define var-desc (mx-com-type-desc-desc mx-type-desc))
|
|
(values null
|
|
(elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc)
|
|
#f
|
|
#f
|
|
internal?))]
|
|
[(= inv-kind INVOKE_PROPERTYPUT)
|
|
(define var-desc (mx-com-type-desc-desc mx-type-desc))
|
|
(values (list (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc)
|
|
#f
|
|
#f
|
|
internal?))
|
|
'void)]
|
|
[(= inv-kind INVOKE_EVENT)
|
|
(values null 'void)]))
|
|
`(-> ,args ,ret)]))
|
|
|
|
(define (com-method-type obj name)
|
|
(do-get-method-type 'com-method-type obj name INVOKE_FUNC #f))
|
|
|
|
(define (com-get-property-type obj name)
|
|
(do-get-method-type 'com-get-property-type obj name INVOKE_PROPERTYGET #f))
|
|
|
|
(define (com-set-property-type obj name)
|
|
(do-get-method-type 'com-set-property-type obj name INVOKE_PROPERTYPUT #f))
|
|
|
|
(define (com-event-type obj name)
|
|
(do-get-method-type 'com-event-type obj name INVOKE_EVENT #f))
|
|
|
|
(define (get-func-desc-for-event name type-info)
|
|
(for/or ([i (in-range (let ()
|
|
(define type-attr (GetTypeAttr type-info))
|
|
(begin0
|
|
(TYPEATTR-cFuncs type-attr)
|
|
(ReleaseTypeAttr type-info type-attr))))])
|
|
(define func-desc (GetFuncDesc type-info i))
|
|
(define-values (fname index) (GetNames type-info (FUNCDESC-memid func-desc)))
|
|
(if (string=? name fname)
|
|
func-desc
|
|
(begin
|
|
(ReleaseFuncDesc type-info func-desc)
|
|
#f))))
|
|
|
|
;; ----------------------------------------
|
|
;; Calling COM Methods via IDispatch
|
|
|
|
(define-oleaut VariantInit (_wfun _VARIANT-pointer -> _void))
|
|
|
|
(define com-omit
|
|
(let ()
|
|
(struct com-omit ())
|
|
(com-omit)))
|
|
|
|
(define CY-factor 10000)
|
|
|
|
(define (currency? v)
|
|
(and (real? v)
|
|
(exact? v)
|
|
(integer? (* v CY-factor))
|
|
(signed-int? (* v CY-factor) 64)))
|
|
|
|
(define-cstruct _SYSTEMTIME ([wYear _WORD]
|
|
[wMonth _WORD]
|
|
[wDayOfWeek _WORD]
|
|
[wDay _WORD]
|
|
[wHour _WORD]
|
|
[wMinute _WORD]
|
|
[wSecond _WORD]
|
|
[wMilliseconds _WORD]))
|
|
|
|
(define-ole VariantTimeToSystemTime (_wfun _DATE _SYSTEMTIME-pointer
|
|
-> _INT))
|
|
(define-ole SystemTimeToVariantTime (_wfun _SYSTEMTIME-pointer (d : (_ptr o _DATE))
|
|
-> (r : _int)
|
|
-> (and (zero? r) d)))
|
|
|
|
(define _date
|
|
(make-ctype _DATE
|
|
(lambda (d)
|
|
(define s (make-SYSTEMTIME (date-year d)
|
|
(date-month d)
|
|
(date-week-day d)
|
|
(date-day d)
|
|
(date-hour d)
|
|
(date-minute d)
|
|
(date-second d)
|
|
(if (date*? d)
|
|
(inexact->exact (floor (* (date*-nanosecond d) 1000)))
|
|
0)))
|
|
(define d (SystemTimeToVariantTime s))
|
|
(or d
|
|
(error 'date "error converting date to COM date")))
|
|
(lambda (d)
|
|
(define s (make-SYSTEMTIME 0 0 0 0 0 0 0 0))
|
|
(unless (zero? (VariantTimeToSystemTime d s))
|
|
(error 'date "error converting date from COM date"))
|
|
(seconds->date
|
|
(find-seconds (SYSTEMTIME-wSecond s)
|
|
(SYSTEMTIME-wMinute s)
|
|
(SYSTEMTIME-wHour s)
|
|
(SYSTEMTIME-wDay s)
|
|
(SYSTEMTIME-wMonth s)
|
|
(SYSTEMTIME-wYear s))))))
|
|
|
|
(define _currency
|
|
(make-ctype _CY
|
|
(lambda (s)
|
|
(* s CY-factor))
|
|
(lambda (s)
|
|
(/ s CY-factor))))
|
|
|
|
|
|
(define (unsigned-int? v n)
|
|
(and (exact-integer? v)
|
|
(positive? v)
|
|
(zero? (arithmetic-shift v (- n)))))
|
|
|
|
(define (signed-int? v n)
|
|
(and (exact-integer? v)
|
|
(if (negative? v)
|
|
(= -1 (arithmetic-shift v (- (sub1 n))))
|
|
(zero? (arithmetic-shift v (- (sub1 n)))))))
|
|
|
|
(define (ok-argument? arg type)
|
|
(cond
|
|
[(type-described? arg)
|
|
(ok-argument? (type-described-value arg) type)]
|
|
[(symbol? type)
|
|
(case type
|
|
[(void) (void? arg)]
|
|
[(char) (byte? arg)]
|
|
[(unsigned-short) (unsigned-int? arg 16)]
|
|
[(unsigned-int) (unsigned-int? arg 32)]
|
|
[(unsigned-long-long) (unsigned-int? arg 64)]
|
|
[(signed-char) (signed-int? arg 8)]
|
|
[(short-int) (signed-int? arg 16)]
|
|
[(int) (signed-int? arg 32)]
|
|
[(long-long) (signed-int? arg 64)]
|
|
[(float double) (real? arg)]
|
|
[(string) (string? arg)]
|
|
[(currency) (currency? arg)]
|
|
[(date) (date? arg)]
|
|
[(boolean) #t]
|
|
[(scode) (signed-int? arg 32)]
|
|
[(iunknown) (or (IUnknown? arg)
|
|
(com-object? arg))]
|
|
[(com-object) (com-object? arg)]
|
|
[(any ...) #t]
|
|
[(com-enumeration) (signed-int? arg 32)]
|
|
[else #f])]
|
|
[(eq? 'opt (car type))
|
|
(or (eq? com-omit arg)
|
|
(ok-argument? arg (cadr type)))]
|
|
[(eq? 'box (car type))
|
|
(and (box? arg)
|
|
(ok-argument? (unbox arg) (cadr type)))]
|
|
[(eq? 'array (car type))
|
|
(and (vector? arg)
|
|
(or (eq? (cadr type) '?)
|
|
(= (vector-length arg) (cadr type)))
|
|
(for/and ([v (in-vector arg)])
|
|
(ok-argument? v (caddr type))))]
|
|
[(eq? 'variant (car type))
|
|
(ok-argument? arg (cadr type))]
|
|
[else #f]))
|
|
|
|
(define (type-description? type)
|
|
(cond
|
|
[(symbol? type)
|
|
(hash-ref
|
|
#hasheq((void . #t)
|
|
(char . #t)
|
|
(unsigned-short . #t)
|
|
(unsigned-int . #t)
|
|
(unsigned-long-long . #t)
|
|
(signed-char . #t)
|
|
(short-int . #t)
|
|
(int . #t)
|
|
(long-long . #t)
|
|
(float . #t)
|
|
(double . #t)
|
|
(string . #t)
|
|
(currency . #t)
|
|
(date . #t)
|
|
(boolean . #t)
|
|
(scode . #t)
|
|
(iunknown . #t)
|
|
(com-object . #t)
|
|
(any . #t)
|
|
(com-enumeration . #t)
|
|
;; meant to to be used only at the end
|
|
;; of an argument list:
|
|
(... . #t))
|
|
type
|
|
#f)]
|
|
[(and (list? type)
|
|
(pair? type))
|
|
(cond
|
|
[(eq? 'opt (car type))
|
|
(and (= (length type) 2)
|
|
(type-description? (cadr type)))]
|
|
[(eq? 'box (car type))
|
|
(and (= (length type) 2)
|
|
(type-description? (cadr type)))]
|
|
[(eq? 'array (car type))
|
|
(and (= (length type) 3)
|
|
(or (exact-positive-integer? (cadr type))
|
|
(eq? '? (cadr type)))
|
|
(type-description? (caddr type)))]
|
|
[(eq? 'variant (car type))
|
|
(and (= (length type) 2)
|
|
(type-description? (cadr type)))]
|
|
[else #f])]
|
|
[else #f]))
|
|
|
|
(struct type-described (value description))
|
|
|
|
(define (type-describe v desc)
|
|
(unless (type-description? desc)
|
|
(raise-type-error 'type-describe "type description" desc))
|
|
(type-described v desc))
|
|
|
|
(define (check-argument who method arg type)
|
|
(unless (ok-argument? arg type)
|
|
(raise-type-error (string->symbol method) (format "~s" type) arg)))
|
|
|
|
(define (get-lcid-param-index func-desc)
|
|
(for/or ([i (in-range (FUNCDESC-cParams func-desc))])
|
|
(and (bit-and? (PARAMDESC-wParamFlags (union-ref (ELEMDESC-u (elem-desc-ref func-desc i)) 1))
|
|
PARAMFLAG_FLCID)
|
|
i)))
|
|
|
|
(define prop-put-long (malloc _LONG 'atomic-interior))
|
|
(ptr-set! prop-put-long _LONG DISPID_PROPERTYPUT)
|
|
|
|
(define (variant-set! var type val)
|
|
(ptr-set! (union-ptr (VARIANT-u var)) type val))
|
|
|
|
(define (scheme-to-variant! var a elem-desc scheme-type #:mode [mode '(in)])
|
|
(cond
|
|
[(type-described? a)
|
|
(scheme-to-variant! var (type-described-value a) elem-desc scheme-type #:mode mode)]
|
|
[(and (pair? scheme-type) (eq? 'variant (car scheme-type)))
|
|
(scheme-to-variant! var a elem-desc (cadr scheme-type) #:mode mode)]
|
|
[(eq? a com-omit)
|
|
(if (and elem-desc
|
|
(elem-desc-has-default? elem-desc))
|
|
(begin
|
|
(memcpy var
|
|
(PARAMDESCEX-varDefaultValue
|
|
(PARAMDESC-pparamdescex (union-ref (ELEMDESC-u elem-desc) 1)))
|
|
1
|
|
_VARIANT))
|
|
(begin
|
|
(set-VARIANT-vt! var VT_ERROR)
|
|
(variant-set! var _ulong DISP_E_PARAMNOTFOUND)))]
|
|
[(and elem-desc (not (any-type? scheme-type)))
|
|
(set-VARIANT-vt! var (get-var-type-from-elem-desc elem-desc))
|
|
(variant-set! var (to-ctype scheme-type #:mode mode) a)]
|
|
[else
|
|
(define use-scheme-type (if (any-type? scheme-type)
|
|
(arg-to-type a)
|
|
scheme-type))
|
|
(set-VARIANT-vt! var (to-vt use-scheme-type))
|
|
(variant-set! var (to-ctype use-scheme-type #:mode mode) a)]))
|
|
|
|
(define (any-type? t)
|
|
(or (eq? t 'any)
|
|
(and (pair? t)
|
|
(eq? (car t) 'opt)
|
|
(any-type? (cadr t)))))
|
|
|
|
(define _float*
|
|
(make-ctype _float
|
|
(lambda (v) (exact->inexact v))
|
|
(lambda (v) v)))
|
|
|
|
(define (_box/permanent _t)
|
|
(define (extract p)
|
|
(if (eq? _t _VARIANT)
|
|
(variant-to-scheme (cast p _pointer _VARIANT-pointer) #:mode '(in out))
|
|
(ptr-ref p _t)))
|
|
(make-ctype _pointer
|
|
(lambda (v)
|
|
(define p (malloc 'raw 1 _t))
|
|
(if (eq? _t _VARIANT)
|
|
(let ([p (cast p _pointer _VARIANT-pointer)]
|
|
[v (unbox v)])
|
|
(VariantInit p)
|
|
(scheme-to-variant! p v #f (arg-to-type v) #:mode '(in out)))
|
|
(ptr-set! p _t (unbox v)))
|
|
(register-cleanup!
|
|
(lambda ()
|
|
(set-box! v (extract p))
|
|
(free p)))
|
|
p)
|
|
(lambda (p)
|
|
;; We box the value, but we don't support reflecting box
|
|
;; changes back to changes of the original reference:
|
|
(box (extract p)))))
|
|
|
|
(define (make-a-VARIANT [mode 'atomic-interior])
|
|
(define var (cast (malloc _VARIANT mode)
|
|
_pointer
|
|
(if (eq? mode 'raw)
|
|
_VARIANT-pointer
|
|
(_gcable _VARIANT-pointer))))
|
|
(VariantInit var)
|
|
var)
|
|
|
|
(define (extract-variant-pointer var get? [vt (VARIANT-vt var)])
|
|
(define ptr (union-ptr (VARIANT-u var)))
|
|
(switch
|
|
vt
|
|
[VT_BSTR (if get? ptr (ptr-ref ptr _pointer))]
|
|
[VT_DISPATCH (if get? ptr (ptr-ref ptr _pointer))]
|
|
[VT_UNKNOWN (if get? ptr (ptr-ref ptr _pointer))]
|
|
[VT_VARIANT var]
|
|
[else ptr]))
|
|
|
|
(define (_safe-array/vectors given-dims base mode)
|
|
(make-ctype _pointer
|
|
(lambda (v)
|
|
(define base-vt (to-vt base))
|
|
(define dims (if (equal? given-dims '(?))
|
|
(list (vector-length v))
|
|
given-dims))
|
|
(define sa (SafeArrayCreate base-vt
|
|
(length dims)
|
|
(for/list ([d (in-list dims)])
|
|
(make-SAFEARRAYBOUND d 0))))
|
|
(register-cleanup!
|
|
(lambda () (SafeArrayDestroy sa)))
|
|
(let loop ([v v] [index null] [dims dims])
|
|
(for ([v (in-vector v)]
|
|
[i (in-naturals)])
|
|
(define idx (cons i index))
|
|
(if (null? (cdr dims))
|
|
(let ([var (make-a-VARIANT)])
|
|
(scheme-to-variant! var v #f base #:mode mode)
|
|
(SafeArrayPutElement sa (reverse idx)
|
|
(extract-variant-pointer var #f base-vt)))
|
|
(loop v idx (cdr dims)))))
|
|
sa)
|
|
(lambda (_sa)
|
|
(define sa (cast _sa _pointer _SAFEARRAY-pointer))
|
|
(define dims (for/list ([i (in-range (SafeArrayGetDim sa))])
|
|
(- (add1 (SafeArrayGetUBound sa (add1 i)))
|
|
(SafeArrayGetLBound sa (add1 i)))))
|
|
(define vt (SafeArrayGetVartype sa))
|
|
(let loop ([dims dims] [level 1] [index null])
|
|
(define lb (SafeArrayGetLBound sa level))
|
|
(for/vector ([i (in-range (car dims))])
|
|
(if (null? (cdr dims))
|
|
(let ([var (make-a-VARIANT)])
|
|
(set-VARIANT-vt! var vt)
|
|
(SafeArrayGetElement sa (reverse (cons i index))
|
|
(extract-variant-pointer var #t))
|
|
(variant-to-scheme var #:mode mode))
|
|
(loop (cdr dims) (add1 level) (cons i index))))))))
|
|
|
|
(define (_IUnknown-pointer-or-com-object mode)
|
|
(make-ctype
|
|
_IUnknown-pointer/null
|
|
(lambda (v)
|
|
(define p
|
|
(if (com-object? v)
|
|
(com-object-get-iunknown v)
|
|
v))
|
|
(when (memq 'out mode)
|
|
(register-commit! (lambda () (AddRef/no-release p))))
|
|
p)
|
|
(lambda (p)
|
|
(if p
|
|
(begin
|
|
(if (memq 'out mode)
|
|
(((allocator Release) (lambda () p)))
|
|
(AddRef p))
|
|
(make-com-object p #f))
|
|
p))))
|
|
|
|
(define (_com-object mode)
|
|
(_IUnknown-pointer-or-com-object mode))
|
|
|
|
(define (to-ctype type [as-boxed? #f] #:mode [mode '()])
|
|
(cond
|
|
[(symbol? type)
|
|
(case type
|
|
[(void) #f]
|
|
[(char) _byte]
|
|
[(unsigned-short) _ushort]
|
|
[(unsigned-int) _uint]
|
|
[(unsigned-long-long) _ullong]
|
|
[(signed-char) _sbyte]
|
|
[(short-int) _short]
|
|
[(int) _int]
|
|
[(long-long) _llong]
|
|
[(float) _float*]
|
|
[(double) _double*]
|
|
[(string) (_system-string/utf-16 mode)]
|
|
[(currency) _currency]
|
|
[(date) _date]
|
|
[(boolean) _bool]
|
|
[(scode) _SCODE]
|
|
[(iunknown) (_IUnknown-pointer-or-com-object mode)]
|
|
[(com-object) (_com-object mode)]
|
|
[(any ...) (if as-boxed?
|
|
_VARIANT
|
|
(error "internal error: cannot marshal to any"))]
|
|
[(com-enumeration) _int]
|
|
[else (error 'to-ctype "internal error: unknown type ~s" type)])]
|
|
[(eq? 'opt (car type))
|
|
(to-ctype (cadr type) #:mode mode)]
|
|
[(eq? 'box (car type))
|
|
(_box/permanent (to-ctype (cadr type) #t #:mode '(in out)))]
|
|
[(eq? 'array (car type))
|
|
(define-values (dims base)
|
|
(let loop ([t type] [?-ok? #t])
|
|
(cond
|
|
[(and (pair? t) (eq? 'array (car t)) (or ?-ok? (number? (cadr t))))
|
|
(define-values (d b) (if (number? (cadr t))
|
|
(loop (caddr t) #f)
|
|
(values null (cadr t))))
|
|
(values (cons (cadr t) d) b)]
|
|
[else
|
|
(values null t)])))
|
|
(_safe-array/vectors dims base mode)]
|
|
[(eq? 'variant (car type))
|
|
(to-ctype (cadr type) #:mode mode)]
|
|
[else #f]))
|
|
|
|
(define (to-vt type)
|
|
;; used for inferred or described types
|
|
(case type
|
|
[(void) VT_VOID]
|
|
[(char) VT_UI1]
|
|
[(unsigned-short) VT_UI2]
|
|
[(unsigned-int) VT_UI4]
|
|
[(unsigned-long-long) VT_UI8]
|
|
[(signed-char) VT_I1]
|
|
[(short-int) VT_I2]
|
|
[(int) VT_I4]
|
|
[(long-long) VT_I8]
|
|
[(float) VT_R4]
|
|
[(double) VT_R8]
|
|
[(string) VT_BSTR]
|
|
[(currency) VT_CY]
|
|
[(date) VT_DATE]
|
|
[(boolean) VT_BOOL]
|
|
[(iunknown) VT_UNKNOWN]
|
|
[(com-object) VT_DISPATCH]
|
|
[(any ...) VT_VARIANT]
|
|
[(com-enumeration) VT_INT]
|
|
[else
|
|
(case (and (pair? type)
|
|
(car type))
|
|
[(array) (bitwise-ior VT_ARRAY (to-vt (caddr type)))]
|
|
[(opt) (to-vt (cadr type))]
|
|
[(variant) VT_VARIANT]
|
|
[(box) (bitwise-ior VT_BYREF (to-vt (cadr type)))]
|
|
[else
|
|
(error 'to-vt "internal error: unsupported type ~s" type)])]))
|
|
|
|
(define (build-method-arguments-using-function-desc func-desc scheme-types inv-kind args)
|
|
(define lcid-index (and func-desc (get-lcid-param-index func-desc)))
|
|
(define last-is-retval? (and func-desc (is-last-param-retval? inv-kind func-desc)))
|
|
(define last-is-repeat-any? (and func-desc (= -1 (FUNCDESC-cParamsOpt func-desc))))
|
|
(define base-count (if func-desc
|
|
(- (FUNCDESC-cParams func-desc)
|
|
(if lcid-index 1 0)
|
|
(if last-is-retval? 1 0))
|
|
(length scheme-types)))
|
|
(define count (if last-is-repeat-any?
|
|
(if (or lcid-index
|
|
last-is-retval?)
|
|
(error "cannot handle combination of `any ...' and lcid/retval")
|
|
(length scheme-types))
|
|
base-count))
|
|
(build-method-arguments-from-desc count
|
|
(lambda (i)
|
|
(and func-desc
|
|
(or (not last-is-repeat-any?)
|
|
(i . < . (sub1 base-count)))
|
|
(elem-desc-ref func-desc i)))
|
|
scheme-types
|
|
inv-kind
|
|
args))
|
|
|
|
(define (build-method-arguments-from-desc count get-elem-desc scheme-types inv-kind args)
|
|
(define vars (if (zero? count)
|
|
#f
|
|
(malloc count _VARIANTARG 'raw)))
|
|
(define cleanup (box (if vars
|
|
(list (lambda () (free vars)))
|
|
null)))
|
|
(define commit (box null))
|
|
(parameterize ([current-cleanup cleanup]
|
|
[current-commit commit])
|
|
(for ([i (in-range count)]
|
|
[a (in-sequences (in-list args)
|
|
(in-cycle (list com-omit)))]
|
|
[scheme-type (in-list scheme-types)])
|
|
(define var (ptr-ref vars _VARIANT (- count i 1))) ; reverse order
|
|
(VariantInit var)
|
|
(scheme-to-variant! var
|
|
a
|
|
(get-elem-desc i)
|
|
scheme-type)))
|
|
(define disp-params (cast (malloc _DISPPARAMS 'raw)
|
|
_pointer
|
|
_DISPPARAMS-pointer))
|
|
(memcpy disp-params
|
|
(make-DISPPARAMS vars
|
|
(if (= inv-kind INVOKE_PROPERTYPUT)
|
|
prop-put-long
|
|
#f)
|
|
count
|
|
(if (= inv-kind INVOKE_PROPERTYPUT)
|
|
count
|
|
0))
|
|
(ctype-sizeof _DISPPARAMS))
|
|
(values count
|
|
disp-params
|
|
(cons (lambda () (free disp-params)) (unbox cleanup))
|
|
(unbox commit)))
|
|
|
|
(define (build-method-arguments-using-var-desc var-desc scheme-types inv-kind args)
|
|
(build-method-arguments-from-desc (if (= inv-kind INVOKE_PROPERTYPUT)
|
|
1
|
|
0)
|
|
(lambda (i)
|
|
(VARDESC-elemdescVar var-desc))
|
|
scheme-types
|
|
inv-kind
|
|
args))
|
|
|
|
(define (variant-to-scheme var #:mode [mode '(out)])
|
|
(define _t (to-ctype (vt-to-scheme-type (VARIANT-vt var)) #:mode mode))
|
|
(if _t
|
|
(ptr-ref (union-ptr (VARIANT-u var)) _t)
|
|
(void)))
|
|
|
|
(define (build-method-arguments type-desc scheme-types inv-kind args)
|
|
(cond
|
|
[(not type-desc)
|
|
(build-method-arguments-using-function-desc #f
|
|
scheme-types
|
|
inv-kind args)]
|
|
[(function-type-desc? type-desc)
|
|
(build-method-arguments-using-function-desc (car (mx-com-type-desc-desc type-desc))
|
|
scheme-types
|
|
inv-kind args)]
|
|
[else
|
|
(build-method-arguments-using-var-desc (mx-com-type-desc-desc type-desc)
|
|
scheme-types
|
|
inv-kind args)]))
|
|
|
|
(define (find-memid who obj name)
|
|
(define-values (r memid)
|
|
(GetIDsOfNames (com-object-get-dispatch obj) IID_NULL name LOCALE_SYSTEM_DEFAULT))
|
|
(cond
|
|
[(zero? r) memid]
|
|
[(= r DISP_E_UNKNOWNNAME) (error who "unknown method name: ~e" name)]
|
|
[else
|
|
(windows-error (format "~a: error getting ID of method ~s" who name)
|
|
r)]))
|
|
|
|
(define (adjust-any-... args t)
|
|
(define ta (cadr t))
|
|
(define len (length ta))
|
|
(if (and (len . >= . 2)
|
|
((length args) . >= . (- len 2))
|
|
(eq? '... (list-ref ta (sub1 len)))
|
|
(eq? 'any (list-ref ta (- len 2))))
|
|
;; Replace `any ...' with the right number of `any's
|
|
`(,(car t) ,(append (take ta (- len 2))
|
|
(make-list (- (length args) (- len 2)) 'any))
|
|
. ,(cddr t))
|
|
t))
|
|
|
|
(define (do-com-invoke who obj name args inv-kind)
|
|
(check-com-obj who obj)
|
|
(unless (string? name) (raise-type-error who "string" name))
|
|
(let* ([t (or (do-get-method-type who obj name inv-kind #t)
|
|
;; wing it by inferring types from the arguments:
|
|
`(-> ,(map arg-to-type args) any))]
|
|
[t (adjust-any-... args t)])
|
|
(unless (<= (for/fold ([n 0]) ([v (in-list (cadr t))])
|
|
(if (and (pair? v) (eq? (car v) 'opt))
|
|
(add1 n)
|
|
n))
|
|
(length args)
|
|
(length (cadr t)))
|
|
(error 'com-invoke "bad argument count for ~s" name))
|
|
(for ([arg (in-list args)]
|
|
[type (in-list (cadr t))])
|
|
(check-argument 'com-invoke name arg type))
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(define type-desc (get-method-type obj name inv-kind #f)) ; cached
|
|
(cond
|
|
[(if type-desc
|
|
(mx-com-type-desc-memid type-desc)
|
|
(find-memid who obj name))
|
|
=> (lambda (memid)
|
|
(define-values (num-params-passed method-arguments arg-cleanups commits)
|
|
(build-method-arguments type-desc
|
|
(cadr t)
|
|
inv-kind
|
|
args))
|
|
;; from this point, don't escape/return without running cleanups
|
|
(when #f
|
|
;; for debugging, inspect constructed arguments:
|
|
(eprintf "~e ~e\n"
|
|
t
|
|
(reverse
|
|
(for/list ([i (in-range num-params-passed)])
|
|
(variant-to-scheme (ptr-ref (DISPPARAMS-rgvarg method-arguments)
|
|
_VARIANT
|
|
i)
|
|
#:mode '())))))
|
|
(define exn-info-ptr (malloc 'atomic-interior _EXCEPINFO))
|
|
(define-values (method-result cleanups)
|
|
(if (= inv-kind INVOKE_PROPERTYPUT)
|
|
(values #f arg-cleanups)
|
|
(let ([r (make-a-VARIANT 'raw)])
|
|
(values r (cons (lambda () (free r))
|
|
arg-cleanups)))))
|
|
(for ([proc (in-list commits)]) (proc))
|
|
(define hr
|
|
;; Note that all arguments to `Invoke' should
|
|
;; not be movable by a GC. A call to `Invoke'
|
|
;; may use the Windows message queue, and other
|
|
;; libraries (notably `racket/gui') may have
|
|
;; callbacks triggered via messages.
|
|
(Invoke (com-object-get-dispatch obj)
|
|
memid IID_NULL LOCALE_SYSTEM_DEFAULT
|
|
inv-kind method-arguments
|
|
method-result
|
|
exn-info-ptr error-index-ptr))
|
|
(cond
|
|
[(zero? hr)
|
|
(begin0
|
|
(if method-result
|
|
(variant-to-scheme method-result)
|
|
(void))
|
|
(for ([proc (in-list cleanups)]) (proc)))]
|
|
[(= hr DISP_E_EXCEPTION)
|
|
(for ([proc (in-list cleanups)]) (proc))
|
|
(define exn-info (cast exn-info-ptr _pointer _EXCEPINFO-pointer))
|
|
(define has-error-code? (positive? (EXCEPINFO-wCode exn-info)))
|
|
(define desc (EXCEPINFO-bstrDescription exn-info))
|
|
(windows-error
|
|
(if has-error-code?
|
|
(format "COM object exception during ~s, error code 0x~x~a~a"
|
|
name
|
|
(EXCEPINFO-wCode exn-info)
|
|
(if desc "\nDescription: " "")
|
|
(or desc ""))
|
|
(format "COM object exception during ~s~a~a"
|
|
name
|
|
(if desc "\nDescription: " "")
|
|
(or desc "")))
|
|
(EXCEPINFO-scode exn-info))]
|
|
[else
|
|
(for ([proc (in-list cleanups)]) (proc))
|
|
(windows-error (format "~a: failed for ~s" who name) hr)]))]
|
|
[else (error "not yet implemented")])))))
|
|
|
|
(define (com-invoke obj name . args)
|
|
(do-com-invoke 'com-invoke obj name args INVOKE_FUNC))
|
|
|
|
(define (follow-chain who obj names len)
|
|
(for ([s (in-list names)]
|
|
[i (in-range len)])
|
|
(unless (string? s) (raise-type-error who "string" s)))
|
|
(define-values (target-obj release?)
|
|
(for/fold ([obj obj] [release? #f]) ([i (in-range (sub1 len))]
|
|
[s (in-list names)])
|
|
(define new-obj (com-get-property obj s))
|
|
(when release?
|
|
(com-release obj))
|
|
(unless (com-object? new-obj)
|
|
(error who "result for ~s not a com-object: ~e" s new-obj))
|
|
(values new-obj #t)))
|
|
target-obj)
|
|
|
|
(define com-get-property
|
|
(case-lambda
|
|
[(obj name)
|
|
(do-com-invoke 'com-get-property obj name null INVOKE_PROPERTYGET)]
|
|
[(obj name1 . more-names)
|
|
(check-com-obj 'com-get-property obj)
|
|
(define names (cons name1 more-names))
|
|
(define len (length names))
|
|
(define target-obj (follow-chain 'com-get-property obj names len))
|
|
(begin0
|
|
(com-get-property target-obj (list-ref names (sub1 len)))
|
|
(com-release target-obj))]))
|
|
|
|
(define com-set-property!
|
|
(case-lambda
|
|
[(obj name val)
|
|
(do-com-invoke 'com-set-property! obj name (list val) INVOKE_PROPERTYPUT)]
|
|
[(obj name1 name2 . names+val)
|
|
(check-com-obj 'com-set-property obj)
|
|
(define names (list* name1 name2 names+val))
|
|
(define len (sub1 (length names)))
|
|
(define val (list-ref names len))
|
|
(define target-obj (follow-chain 'com-set-property! obj names len))
|
|
(begin0
|
|
(com-set-property! target-obj (list-ref names (sub1 len)) val)
|
|
(com-release target-obj))]))
|
|
|
|
;; ----------------------------------------
|
|
;; COM event executor
|
|
|
|
(struct com-event-executor (t ch)
|
|
#:property prop:evt (lambda (self)
|
|
(guard-evt
|
|
(lambda ()
|
|
(thread-resume (com-event-executor-t self)
|
|
(current-thread))
|
|
(wrap-evt
|
|
(com-event-executor-ch self)
|
|
(lambda (v)
|
|
(lambda ()
|
|
(apply (car v) (cdr v)))))))))
|
|
|
|
(define (com-make-event-executor)
|
|
(define ch (make-channel))
|
|
(define t (thread/suspend-to-kill
|
|
(lambda ()
|
|
(let loop ()
|
|
(channel-put ch (thread-receive))
|
|
(loop)))))
|
|
(com-event-executor t ch))
|
|
|
|
;; ----------------------------------------
|
|
;; COM event handlers
|
|
|
|
(define-runtime-path myssink-dll '(so "myssink.dll"))
|
|
|
|
(define CLSID_Sink
|
|
;; "myssink.dll":
|
|
(string->clsid "{DA064DCD-0881-11D3-B5CA-0060089002FF}"))
|
|
|
|
(define IID_ISink
|
|
(string->clsid "{DA064DCC-0881-11D3-B5CA-0060089002FF}"))
|
|
|
|
(define-com-interface (_ISink _IDispatch)
|
|
([set_myssink_table (_hmfun _pointer -> set_myssink_table (void))]
|
|
[register_handler (_hmfun _DISPID _pointer -> register_handler (void))]
|
|
[unregister_handler (_hmfun _DISPID -> unregister_handler (void))]))
|
|
|
|
(define-syntax-rule (_sfun type ...)
|
|
(_fun #:atomic? #t #:async-apply (lambda (f) (f)) type ...))
|
|
|
|
(define-cstruct _MYSSINK_TABLE
|
|
([psink_release_handler (_sfun _pointer -> _void)]
|
|
[psink_release_arg (_sfun _pointer -> _void)]
|
|
[psink_apply (_sfun _pointer _int _pointer -> _void)]
|
|
[psink_variant_to_scheme (_sfun _VARIANTARG-pointer -> _pointer)]
|
|
[psink_unmarshal_scheme (_sfun _pointer _VARIANTARG-pointer -> _void)]
|
|
[pmake_scode (_sfun _SCODE -> _pointer)]))
|
|
|
|
(define (sink-release-handler h)
|
|
(free-immobile-cell h))
|
|
|
|
(define (sink-release-arg a)
|
|
(free-immobile-cell a))
|
|
|
|
(define (sink-apply f-in argc argv)
|
|
(define f (ptr-ref f-in _racket))
|
|
(thread-send (com-event-executor-t (car f))
|
|
(cons (cdr f)
|
|
(for/list ([i (in-range argc)])
|
|
(ptr-ref (ptr-ref argv _pointer i) _racket)))))
|
|
|
|
(define (sink-variant-to-scheme var)
|
|
(malloc-immobile-cell (variant-to-scheme var #:mode '(in add-ref))))
|
|
|
|
(define (sink-unmarshal-scheme p var)
|
|
(define a (ptr-ref p _racket))
|
|
(scheme-to-variant! var a #f (arg-to-type a)))
|
|
|
|
(define (sink-make-scode v)
|
|
(malloc-immobile-cell v))
|
|
|
|
(define myssink-table (cast (malloc _MYSSINK_TABLE 'atomic-interior)
|
|
_pointer
|
|
(_gcable _MYSSINK_TABLE-pointer)))
|
|
(define sink-table-links
|
|
;; used to ensure that everything is retained long enough:
|
|
(list myssink-table
|
|
sink-release-handler
|
|
sink-release-arg
|
|
sink-apply
|
|
sink-variant-to-scheme
|
|
sink-unmarshal-scheme
|
|
sink-make-scode))
|
|
(memcpy myssink-table
|
|
(apply make-MYSSINK_TABLE (cdr sink-table-links))
|
|
(ctype-sizeof _MYSSINK_TABLE))
|
|
|
|
(define (connect-com-object-to-event-sink obj)
|
|
(or (com-object-connection-point obj)
|
|
(let ([dispatch (com-object-get-dispatch obj)])
|
|
(define connection-point-container
|
|
(QueryInterface dispatch IID_IConnectionPointContainer _IConnectionPointContainer-pointer))
|
|
(define type-info (event-type-info-from-com-object obj))
|
|
(define type-attr (GetTypeAttr type-info))
|
|
(define connection-point (FindConnectionPoint connection-point-container
|
|
(TYPEATTR-guid type-attr)))
|
|
(ReleaseTypeAttr type-info type-attr)
|
|
;; emulate CoCreateInstance on athe myssink DLL, which avoids the
|
|
;; need for registration:
|
|
(define myssink-lib (ffi-lib myssink-dll))
|
|
(define myssink-DllGetClassObject
|
|
(get-ffi-obj 'DllGetClassObject myssink-lib
|
|
(_hfun _GUID-pointer _GUID-pointer
|
|
(u : (_ptr o _IClassFactory-pointer/null))
|
|
-> DllGetClassObject u)))
|
|
(define sink-factory
|
|
(myssink-DllGetClassObject CLSID_Sink IID_IClassFactory))
|
|
(define sink-unknown
|
|
;; This primitive method doesn't AddRef the object,
|
|
;; so don't Release it:
|
|
(CreateInstance/factory sink-factory #f CLSID_Sink))
|
|
(define sink (QueryInterface sink-unknown IID_ISink _ISink-pointer))
|
|
(set_myssink_table sink myssink-table)
|
|
(define cookie (Advise connection-point sink))
|
|
(define impl (com-object-impl obj))
|
|
(set-com-impl-connection-point! impl connection-point)
|
|
(set-com-impl-connection-cookie! impl cookie)
|
|
(set-com-impl-sink! impl sink)
|
|
(set-com-impl-sink-table-links! impl sink-table-links)
|
|
(Release connection-point-container)
|
|
connection-point)))
|
|
|
|
(define (do-register-event-callback who obj name proc? proc executor)
|
|
(check-com-obj who obj)
|
|
(unless (string? name) (raise-type-error who "string" name))
|
|
(when proc?
|
|
(unless (procedure? proc) (raise-type-error who "procedure" proc))
|
|
(unless (com-event-executor? executor)
|
|
(raise-type-error who "com-event-executor" executor)))
|
|
(when (or proc? (com-object-sink obj))
|
|
(define connection-point (connect-com-object-to-event-sink obj))
|
|
(define type-info (event-type-info-from-com-object obj))
|
|
(define sink (com-object-sink obj))
|
|
(define func-desc (get-func-desc-for-event name type-info))
|
|
(unless func-desc
|
|
(error who "event not found: ~e" name))
|
|
(if proc
|
|
(register_handler sink (FUNCDESC-memid func-desc) (malloc-immobile-cell (cons executor proc)))
|
|
(unregister_handler sink (FUNCDESC-memid func-desc)))
|
|
(ReleaseFuncDesc type-info func-desc)))
|
|
|
|
(define (com-register-event-callback obj name proc executor)
|
|
(do-register-event-callback 'com-register-event-callback obj name #t proc executor))
|
|
|
|
(define (com-unregister-event-callback obj name)
|
|
(do-register-event-callback 'com-unregister-event-callback obj name #f #f #f))
|
|
|
|
;; ----------------------------------------
|
|
;; Extract raw interface pointers
|
|
|
|
(define (com-object-get-iunknown obj)
|
|
(check-com-obj 'com-object-get-iunknown obj)
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(com-object-get-unknown obj))))
|
|
|
|
(define (com-object-get-idispatch obj)
|
|
(check-com-obj 'com-object-get-idispatch obj)
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(com-object-get-dispatch obj))))
|
|
|
|
(define (com-iunknown? v) (and (IUnknown? v) #t))
|
|
(define (com-idispatch? v) (and (IDispatch? v) #t))
|
|
|
|
;; ----------------------------------------
|
|
;; Initialize
|
|
|
|
(define-ole CoInitialize (_wfun (_pointer = #f) -> (r : _HRESULT)
|
|
-> (cond
|
|
[(= r 0) (void)] ; ok
|
|
[(= r 1) (void)] ; already initialized
|
|
[else (windows-error (format "~a: failed" 'CoInitialize) r)])))
|
|
|
|
(define inited? #f)
|
|
(define (init!)
|
|
(unless inited?
|
|
(CoInitialize)
|
|
(set! inited? #t)))
|