11de33d4ff
The ActiveX part of MysterX is gone. The `ffi/com' re-imeplemtnation provides only core COM support. The "mysssink" DLL is still needed, and its source is still in the tree, but it is downloaded in the same way as other pre-built DLLs. The DLL no longer needs to be registered with regsvr32.
1804 lines
67 KiB
Racket
1804 lines
67 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/alloc
|
|
ffi/winapi
|
|
ffi/unsafe/atomic
|
|
racket/date
|
|
racket/runtime-path
|
|
(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?)
|
|
|
|
;; 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
|
|
(make-ctype _pointer
|
|
(lambda (s)
|
|
(and s
|
|
(let ([c (string->pointer s)])
|
|
(register-cleanup! (lambda () (SysFreeString c)))
|
|
c)))
|
|
(lambda (p) (cast p _pointer _string/utf-16))))
|
|
|
|
(define current-cleanup (make-parameter #f))
|
|
|
|
(define (register-cleanup! proc)
|
|
(let ([c (current-cleanup)])
|
|
(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)))
|
|
expr)
|
|
self
|
|
arg ...))]
|
|
[(_ (#:releases) expr arg ...)
|
|
(((deallocator cadr) expr) 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
|
|
((retainer Release)
|
|
(lambda (obj)
|
|
(check-com-type 'AddRef 'IUknown IUnknown? obj)
|
|
((IUnknown_vt-AddRef (cast (IUnknown-vt obj) _pointer _IUnknown_vt-pointer))
|
|
obj))))
|
|
|
|
;; --------------------------------------------------
|
|
;; 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
|
|
(e : (_ptr o _EXCEPINFO))
|
|
(err : (_ptr o _UINT))
|
|
-> (r : _HRESULT)
|
|
-> (values r e err))]))
|
|
|
|
;; --------------------------------------------------
|
|
;; 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]
|
|
[pAuthInfo _pointer]
|
|
[dwReserved2 _DWORD]))
|
|
(define-cstruct _MULTI_QI ([pIID _GUID-pointer]
|
|
[pItf _IUnknown-pointer]
|
|
[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))
|
|
|
|
(struct com-object ([unknown #:mutable]
|
|
[dispatch #:mutable]
|
|
[type-info #:mutable]
|
|
[event-type-info #:mutable]
|
|
[clsid #:mutable]
|
|
[connection-point #:mutable]
|
|
[connection-cookie #:mutable]
|
|
[sink #:mutable]
|
|
[types #:mutable]
|
|
[mref #:mutable]))
|
|
|
|
(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 _com-object
|
|
(make-ctype _pointer
|
|
(lambda (v)
|
|
(com-object-get-dispatch v))
|
|
(lambda (p)
|
|
(if p
|
|
(let ()
|
|
(define dispatch (cast p _pointer _IDispatch-pointer))
|
|
(((allocator Release) (lambda () dispatch)))
|
|
(make-com-object dispatch #f))
|
|
#f))))
|
|
|
|
(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 scheme_add_managed
|
|
(get-ffi-obj 'scheme_add_managed #f
|
|
(_fun _racket _racket _fpointer _racket _int
|
|
-> _pointer)))
|
|
(define scheme_remove_managed
|
|
(get-ffi-obj 'scheme_remove_managed #f
|
|
(_fun _pointer _racket -> _void)))
|
|
(define (custodian-shutdown-com obj proc-self) (com-release obj))
|
|
(define custodian_shutdown_com
|
|
(cast custodian-shutdown-com (_fun #:atomic? #t _racket _racket -> _void) _fpointer))
|
|
|
|
(define (register-with-custodian obj)
|
|
(set-com-object-mref!
|
|
obj
|
|
(scheme_add_managed (current-custodian)
|
|
obj
|
|
custodian_shutdown_com
|
|
custodian-shutdown-com ; proc as data -> ffi callback retained
|
|
1)))
|
|
|
|
(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 csi (make-COSERVERINFO 0 (cast machine _system-string/utf-16 _pointer) #f 0))
|
|
(define mqi (make-MULTI_QI IID_IUnknown #f 0))
|
|
(define unknown
|
|
(CoCreateInstanceEx clsid #f CLSCTX_REMOTE_SERVER (and machine csi) 1 mqi))
|
|
(when machine
|
|
(SysFreeString (COSERVERINFO-pwszName csi)))
|
|
(unless (and (zero? (MULTI_QI-hr mqi))
|
|
unknown)
|
|
(error who "unable to obtain IUnknown interface for remote server"))
|
|
unknown]))
|
|
|
|
(define obj (make-com-object unknown clsid))
|
|
(register-with-custodian obj)
|
|
obj)))
|
|
|
|
(define (make-com-object unknown clsid)
|
|
(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))
|
|
(com-object unknown
|
|
#f
|
|
#f
|
|
#f
|
|
clsid
|
|
#f
|
|
#f
|
|
#f
|
|
(make-hash)
|
|
#f))
|
|
|
|
(define (com-release obj)
|
|
(check-com-obj 'com-release obj)
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(scheme_remove_managed (com-object-mref obj) obj)
|
|
(define (bye! sel st!)
|
|
(when (sel obj)
|
|
(Release (sel obj))
|
|
(st! obj #f)))
|
|
(bye! com-object-dispatch
|
|
set-com-object-dispatch!)
|
|
(bye! com-object-unknown
|
|
set-com-object-unknown!)
|
|
(bye! com-object-type-info
|
|
set-com-object-type-info!)
|
|
(bye! com-object-event-type-info
|
|
set-com-object-event-type-info!)
|
|
(bye! com-object-connection-point
|
|
set-com-object-connection-point!)
|
|
(bye! com-object-sink
|
|
set-com-object-sink!)
|
|
(when (hash-count (com-object-types obj))
|
|
(set-com-object-types! obj (make-hash))))))
|
|
|
|
(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))
|
|
(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 'set-com-object-clsid! "clsid" clsid))
|
|
(set-com-object-clsid! 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-object-dispatch! obj dispatch)
|
|
dispatch)))
|
|
|
|
(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"))
|
|
(set-com-object-type-info! obj type-info)
|
|
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 [exn? #t])
|
|
(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-object-event-type-info! 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)
|
|
(cond
|
|
[(com-object? obj) (type-info-from-com-object obj)]
|
|
[(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)
|
|
(define type-info (extract-type-info who obj))
|
|
(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 ([released? #:mutable]
|
|
memid
|
|
type-info
|
|
type-info-impl
|
|
interface
|
|
fun-ptr
|
|
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)])))
|
|
;; 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 #f
|
|
(VARDESC-memid found)
|
|
(begin
|
|
(AddRef type-info)
|
|
type-info)
|
|
#f
|
|
#f
|
|
#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 #f
|
|
(FUNCDESC-memid (car found))
|
|
(begin
|
|
(AddRef type-info)
|
|
type-info)
|
|
(begin
|
|
(AddRef type-info-impl)
|
|
type-info-impl)
|
|
#f
|
|
#f
|
|
(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 #f
|
|
(FUNCDESC-memid (car found))
|
|
(begin
|
|
(AddRef type-info)
|
|
type-info)
|
|
#f
|
|
#f
|
|
#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)
|
|
(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)])])
|
|
(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)
|
|
(define param-desc (union-ref (ELEMDESC-u elem-desc) 1))
|
|
(define flags (PARAMDESC-wParamFlags param-desc))
|
|
(cond
|
|
[(and (bit-and? flags PARAMFLAG_FOPT)
|
|
(bit-and? flags PARAMFLAG_FHASDEFAULT))
|
|
(VARIANT-vt (PARAMDESCEX-varDefaultValue (PARAMDESC-pparamdescex param-desc)))]
|
|
[(= (TYPEDESC-vt (ELEMDESC-tdesc elem-desc)) VT_PTR)
|
|
(bitwise-ior VT_BYREF
|
|
(TYPEDESC-vt (cast (union-ref (TYPEDESC-u (ELEMDESC-tdesc elem-desc)) 0)
|
|
_pointer
|
|
_TYPEDESC-pointer)))]
|
|
[else
|
|
(TYPEDESC-vt (ELEMDESC-tdesc elem-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)])
|
|
(if ignore-by-ref?
|
|
(- 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?
|
|
'iunknown
|
|
'(opt iunknown))]
|
|
[(bit-and? vt VT_ARRAY)
|
|
(error "here")
|
|
(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))
|
|
i
|
|
_SAFEARRAYBOUND))
|
|
,base))]
|
|
[else
|
|
(define base (vt-to-scheme-type (- vt (bitwise-and vt VT_BYREF))))
|
|
(define new-base
|
|
(if (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]
|
|
[else (string->symbol (format "COM-0x~x" vt))]))
|
|
|
|
(define (arg-to-type arg)
|
|
(cond
|
|
[(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]
|
|
[else 'any]))
|
|
|
|
(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?)
|
|
(define type-info (extract-type-info who obj))
|
|
(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)]
|
|
[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
|
|
(values
|
|
(append
|
|
(for/list ([i (in-range num-actual-params)])
|
|
(elem-desc-to-scheme-type (elem-desc-ref func-desc i)
|
|
#f
|
|
#f
|
|
internal?))
|
|
(list '...))
|
|
(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
|
|
[(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) (IUnknown? 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)
|
|
(= (vector-length arg) (cadr type))
|
|
(for/and ([v (in-vector arg)])
|
|
(ok-argument? v (caddr type))))]
|
|
[else #f]))
|
|
|
|
(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)
|
|
(cond
|
|
[(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 _long DISP_E_PARAMNOTFOUND)))]
|
|
[(and elem-desc (not (eq? 'any scheme-type)))
|
|
(set-VARIANT-vt! var (get-var-type-from-elem-desc elem-desc))
|
|
(variant-set! var (to-ctype scheme-type) a)]
|
|
[else
|
|
(set-VARIANT-vt! var (to-vt scheme-type))
|
|
(variant-set! var (to-ctype scheme-type) a)]))
|
|
|
|
(define _float*
|
|
(make-ctype _float
|
|
(lambda (v) (exact->inexact v))
|
|
(lambda (v) v)))
|
|
|
|
(define (_box/permanent _t)
|
|
(make-ctype _pointer
|
|
(lambda (v)
|
|
(define p (malloc 'raw 1 _t))
|
|
(register-cleanup!
|
|
(lambda ()
|
|
(set-box! v (ptr-ref p _t))
|
|
(free p)))
|
|
(ptr-set! p _t (unbox v))
|
|
p)
|
|
(lambda (p)
|
|
(ptr-ref p _t))))
|
|
|
|
(define (to-ctype type)
|
|
(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]
|
|
[(currency) _currency]
|
|
[(date) _date]
|
|
[(boolean) _bool]
|
|
[(scode) _SCODE]
|
|
[(iunknown) _IUnknown-pointer]
|
|
[(com-object) _com-object]
|
|
[(any) (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 type)]
|
|
[(eq? 'box (car type))
|
|
(_box/permanent (to-ctype (cadr type)))]
|
|
[(eq? 'array (car type))
|
|
(_array/vector (to-ctype (caddr type))
|
|
(cadr type))]
|
|
[else #f]))
|
|
|
|
(define (to-vt type)
|
|
;; only used for inferred 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]
|
|
[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 count (if func-desc
|
|
(- (FUNCDESC-cParams func-desc)
|
|
(if lcid-index 1 0)
|
|
(if last-is-retval? 1 0))
|
|
(length scheme-types)))
|
|
(define vars (if (zero? count)
|
|
#f
|
|
(malloc count _VARIANTARG 'raw)))
|
|
(define cleanup (box (if vars
|
|
(list (lambda () (free vars)))
|
|
null)))
|
|
(parameterize ([current-cleanup cleanup])
|
|
(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 (and func-desc (elem-desc-ref func-desc i)) scheme-type)))
|
|
(values count
|
|
(make-DISPPARAMS vars
|
|
(if (= inv-kind INVOKE_PROPERTYPUT)
|
|
prop-put-long
|
|
#f)
|
|
count
|
|
(if (= inv-kind INVOKE_PROPERTYPUT)
|
|
count
|
|
0))
|
|
(unbox cleanup)))
|
|
|
|
(define (variant-to-scheme var)
|
|
(define _t (to-ctype (vt-to-scheme-type (VARIANT-vt var))))
|
|
(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
|
|
(error "unimplemented") ; FIXME?
|
|
'(build-method-arguments-using-var-desc (mx-com-type-desc-desc type-desc)
|
|
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 (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 'com-invoke obj name inv-kind #t)
|
|
;; wing it by inferring types from the arguments:
|
|
`(-> ,(map arg-to-type args) any))])
|
|
(unless (<= (length (filter (lambda (v) (not (and (pair? v) (eq? (car v) 'opt))))
|
|
(cadr t)))
|
|
(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))
|
|
(define type-desc (get-method-type obj name inv-kind)) ; 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 cleanups)
|
|
(build-method-arguments type-desc
|
|
(cadr t)
|
|
inv-kind
|
|
args))
|
|
;; from this point, don't escape/return without running cleanups
|
|
(define method-result
|
|
(if (= inv-kind INVOKE_PROPERTYPUT)
|
|
#f
|
|
(cast (malloc 'atomic _VARIANT) _pointer _VARIANT-pointer)))
|
|
(when method-result
|
|
(VariantInit method-result))
|
|
(define-values (hr exn-info error-index)
|
|
(Invoke (com-object-get-dispatch obj)
|
|
memid IID_NULL LOCALE_SYSTEM_DEFAULT
|
|
inv-kind method-arguments
|
|
method-result))
|
|
(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 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)))
|
|
|
|
(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
|
|
(make-MYSSINK_TABLE sink-release-handler
|
|
sink-release-arg
|
|
sink-apply
|
|
sink-variant-to-scheme
|
|
sink-unmarshal-scheme
|
|
sink-make-scode))
|
|
|
|
(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))
|
|
(set-com-object-connection-point! obj connection-point)
|
|
(set-com-object-connection-cookie! obj cookie)
|
|
(set-com-object-sink! obj sink)
|
|
(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)
|
|
(com-object-get-unknown obj))
|
|
|
|
(define (com-object-get-idispatch obj)
|
|
(check-com-obj 'com-object-get-idispatch obj)
|
|
(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 (_hfun (_pointer = #f)
|
|
-> CoInitialize (void)))
|
|
|
|
(define inited? #f)
|
|
(define (init!)
|
|
(unless inited?
|
|
(CoInitialize)
|
|
(set! inited? #t)))
|