fbb6a294f3
That is, when the sto plist contains only `module*', core forms are not implicitly added to the stop list.
1995 lines
74 KiB
Racket
1995 lines
74 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?
|
|
|
|
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
|
|
(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]
|
|
[sink-table-links #:mutable]
|
|
[types #:mutable]
|
|
[mref #:mutable])
|
|
#: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)))))
|
|
|
|
(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
|
|
-> _gcpointer)))
|
|
(define scheme_remove_managed
|
|
(get-ffi-obj 'scheme_remove_managed #f
|
|
(_fun _gcpointer _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
|
|
#f
|
|
(make-hash)
|
|
#f))
|
|
|
|
(define (com-release obj)
|
|
(check-com-obj 'com-release obj)
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(let ([mref (com-object-mref obj)])
|
|
(when mref
|
|
(scheme_remove_managed mref 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)
|
|
(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 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)
|
|
(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 ([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 [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)
|
|
(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)
|
|
(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
|
|
(if (= VT_ARRAY (bitwise-and vt VT_ARRAY))
|
|
`(array ? ,(vt-to-scheme-type (- vt VT_ARRAY)))
|
|
(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]
|
|
[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?)
|
|
(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
|
|
(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
|
|
[(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) (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))))]
|
|
[(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))
|
|
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)
|
|
(exact-positive-integer? (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)
|
|
(cond
|
|
[(type-described? a)
|
|
(scheme-to-variant! var (type-described-value a) elem-desc scheme-type)]
|
|
[(and (pair? scheme-type) (eq? 'variant (car scheme-type)))
|
|
(scheme-to-variant! var a elem-desc (cadr scheme-type))]
|
|
[(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) 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) 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)
|
|
(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 (make-a-VARIANT)
|
|
(define var (cast (malloc _VARIANT 'atomic-interior)
|
|
_pointer
|
|
_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 dims base)
|
|
(make-ctype _pointer
|
|
(lambda (v)
|
|
(define base-vt (to-vt base))
|
|
(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)
|
|
(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))
|
|
(loop (cdr dims) (add1 level) (cons i index))))))))
|
|
|
|
(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 (cadr type))]
|
|
[(eq? 'box (car type))
|
|
(_box/permanent (to-ctype (cadr type)))]
|
|
[(eq? 'array (car type))
|
|
(define-values (dims base)
|
|
(let loop ([t type])
|
|
(cond
|
|
[(and (pair? t) (eq? 'array (car t)))
|
|
(define-values (d b) (loop (caddr t)))
|
|
(values (cons (cadr t) d) b)]
|
|
[else
|
|
(values null t)])))
|
|
(_safe-array/vectors dims base)]
|
|
[(eq? 'variant (car type))
|
|
(to-ctype (cadr type))]
|
|
[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]
|
|
[else
|
|
(case (and (pair? type)
|
|
(car type))
|
|
[(array) (bitwise-ior VT_ARRAY (to-vt (caddr type)))]
|
|
[(opt) (to-vt (cadr type))]
|
|
[(variant) VT_VARIANT]
|
|
[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 who 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 #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 cleanups)
|
|
(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))))))
|
|
(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 (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))
|
|
(set-com-object-connection-point! obj connection-point)
|
|
(set-com-object-connection-cookie! obj cookie)
|
|
(set-com-object-sink! obj sink)
|
|
(set-com-object-sink-table-links! obj 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)
|
|
(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 (_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)))
|