diff --git a/collects/ffi/com-registry.rkt b/collects/ffi/com-registry.rkt new file mode 100644 index 0000000000..704f1d84dd --- /dev/null +++ b/collects/ffi/com-registry.rkt @@ -0,0 +1,185 @@ +#lang racket/base +(require ffi/unsafe + ffi/winapi + "unsafe/private/win32.rkt") + +;; Implements MysterX's "coclass" lookup, which is deprecated +(provide com-all-coclasses + com-all-controls + coclass->clsid + clsid->coclass) + +;; ---------------------------------------- +;; Registry + +(define _HKEY (_cpointer/null 'HKEY)) + +(define KEY_QUERY_VALUE #x1) +(define KEY_SET_VALUE #x2) +(define KEY_READ #x20019) + +(define ERROR_SUCCESS 0) +(define ERROR_MORE_DATA 234) +(define ERROR_NO_MORE_ITEMS 259) + +(define (const-hkey v) + (cast (bitwise-ior v (arithmetic-shift -1 32)) _intptr _HKEY)) + +(define HKEY_CLASSES_ROOT (const-hkey #x80000000)) +(define HKEY_CURRENT_USER (const-hkey #x80000001)) +(define HKEY_LOCAL_MACHINE (const-hkey #x80000002)) +(define HKEY_USERS (const-hkey #x80000003)) +(define HKEY_CURRENT_CONFIG (const-hkey #x80000005)) + +(define REG_SZ 1) +(define REG_BINARY 3) +(define REG_DWORD 4) + +(define-advapi RegOpenKeyExW (_hfun _HKEY _string/utf-16 _DWORD _REGSAM (hkey : (_ptr o _HKEY)) + -> RegOpenKeyExW hkey)) + +(define-advapi RegEnumKeyExW (_wfun _HKEY _DWORD _pointer (_ptr io _DWORD) + (_pointer = #f) ; reserved; must be NULL + (_pointer = #f) (_pointer = #f) ; class + (_pointer = #f) ; filetime + -> (r : _LONG))) +(define (RegEnumKeyExW* hkey index) + (let loop ([sz 256]) + (define bstr (make-bytes sz)) + (define r (RegEnumKeyExW hkey index bstr (quotient sz 2))) + (cond + [(= r ERROR_SUCCESS) (cast bstr _pointer _string/utf-16)] + [(= r ERROR_MORE_DATA) (loop (* sz 2))] + [(= r ERROR_NO_MORE_ITEMS) #f] + [else (error "RegEnumKeyExW failed")]))) + +(define-advapi RegCreateKeyExW (_wfun _HKEY _string/utf-16 (_DWORD = 0) + (_pointer = #f) ; class + _DWORD ; options + _REGSAM + _pointer ; security + (hkey : (_ptr o _HKEY)) + (_ptr o _DWORD) ; disposition + -> (r : _LONG) + -> (and (= r ERROR_SUCCESS) hkey))) + +(define-advapi RegQueryValueExW (_wfun _HKEY _string/utf-16 (_pointer = #f) + (type : (_ptr o _DWORD)) + _pointer (len : (_ptr io _DWORD)) + -> (r : _LONG) + -> (if (= r ERROR_SUCCESS) + (values len type) + (values #f #f)))) +(define-advapi RegSetValueExW (_wfun _HKEY _string/utf-16 (_pointer = #f) + _DWORD _pointer _DWORD + -> (r : _LONG) + -> (= r ERROR_SUCCESS))) + +(define-advapi RegCloseKey (_hfun _HKEY -> RegCloseKey (void))) + +(define CLSIDLEN 38) + +(define KEY_WOW64_64KEY #x0100) +(define KEY_WOW64_32KEY #x0200) + +(define wow-flags + (if win64? + (list KEY_WOW64_64KEY KEY_WOW64_32KEY) + (list 0))) + +(define (enum-keys rx include-clsid? include-name? convert all?) + (let wloop ([wow-flags wow-flags]) + (cond + [(null? wow-flags) (if all? null #f)] + [else + (define r + (let ([hkey (RegOpenKeyExW HKEY_CLASSES_ROOT "CLSID" 0 + (bitwise-ior (car wow-flags) KEY_READ))]) + (begin0 + (let loop ([key-index 0]) + (define sub (RegEnumKeyExW* hkey key-index)) + (cond + [(not sub) (if all? null #f)] + [(not (= CLSIDLEN (string-length sub))) + ;; Bogus entry? Skip it. + (loop (add1 key-index))] + [(not (include-clsid? sub)) + (loop (add1 key-index))] + [else + (define sub-hkey (RegOpenKeyExW hkey sub 0 KEY_READ)) + (define buffer (make-bytes 256)) + (define-values (len type) (RegQueryValueExW sub-hkey "" buffer (bytes-length buffer))) + (cond + [(and type + (= type REG_SZ)) + (define name (cast buffer _pointer _string/utf-16)) + (if (include-name? name) + (let sloop ([sub-key-index 0]) + (define subsub (RegEnumKeyExW* sub-hkey sub-key-index)) + (cond + [(not subsub) + (RegCloseKey sub-hkey) + (loop (add1 key-index))] + [(regexp-match? rx subsub) + (RegCloseKey sub-hkey) + (define val (convert sub name subsub)) + (if all? + (cons val (loop (add1 key-index))) + val)] + [else + (sloop (add1 sub-key-index))])) + (begin + (RegCloseKey sub-hkey) + (loop (add1 key-index))))] + [else + (RegCloseKey sub-hkey) + (loop (add1 key-index))])])) + (RegCloseKey hkey)))) + (cond + [all? (append (wloop (cdr wow-flags)) r)] + [r r] + [else (wloop (cdr wow-flags))])]))) + +(define rx:object #rx"^(?i:InprocServer|InprocServer32|LocalServer|LocalServer32)$") +(define rx:control #rx"^(?i:control)$") + +(define (com-all-coclasses) + (sort-and-filter + (enum-keys rx:object + (lambda (sub) #t) + (lambda (name) #t) + (lambda (sub name subsub) name) + #t))) + +(define (com-all-controls) + (sort-and-filter + (enum-keys rx:control + (lambda (sub) #t) + (lambda (name) #t) + (lambda (sub name subsub) name) + #t))) + +(define (sort-and-filter l) + (let loop ([l (sort l string-ciclsid coclass) + (enum-keys rx:object + (lambda (sub) #t) + (lambda (name) (equal? name coclass)) + (lambda (sub name subsub) (string->guid sub)) + #f)) + +(define (clsid->coclass clsid) + (enum-keys rx:object + (lambda (sub) + (define clsid2 (string->guid sub)) + (guid=? clsid clsid2)) + (lambda (name) #t) + (lambda (sub name subsub) name) + #f)) diff --git a/collects/ffi/com.rkt b/collects/ffi/com.rkt new file mode 100644 index 0000000000..b5c4ee71e0 --- /dev/null +++ b/collects/ffi/com.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require ffi/unsafe/com) + +(provide guid? iid? clsid? + string->guid string->iid string->clsid + 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-register-event-callback + com-unregister-event-callback + com-make-event-executor com-event-executor? + + com-object-get-iunknown com-iunknown? + com-object-get-idispatch com-idispatch?) diff --git a/collects/ffi/unsafe/com.rkt b/collects/ffi/unsafe/com.rkt new file mode 100644 index 0000000000..ab3be2a8d6 --- /dev/null +++ b/collects/ffi/unsafe/com.rkt @@ -0,0 +1,1788 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/alloc + ffi/winapi + ffi/unsafe/atomic + racket/date + (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 (utf-16-length s) + (for/fold ([len 0]) ([c (in-string s)]) + (+ len + (if ((char->integer c) . > . #xFFFF) + 2 + 1)))) + +(define _system-string/utf-16 + (make-ctype _pointer + (lambda (s) + (and s + (let ([v (malloc _gcpointer)]) + (ptr-set! v _string/utf-16 s) + (let ([p (ptr-ref v _gcpointer)]) + (let ([len (utf-16-length s)]) + (let ([c (SysAllocStringLen p len)]) + (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)) + -> GetTypeAttr p) + #:release-with-method ReleaseTypeAttr] + [GetTypeComp _fpointer] + [GetFuncDesc (_hmfun _UINT (p : (_ptr o _FUNCDESC-pointer)) + -> GetFuncDesc p) + #:release-with-method ReleaseFuncDesc] + [GetVarDesc (_hmfun _UINT (p : (_ptr o _VARDESC-pointer)) + -> 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)) + -> GetTypeInfo p) + #:release-with-function Release] + [GetTypeInfoType (_hmfun _UINT (p : (_ptr o _TYPEKIND)) + -> GetTypeInfoType p)] + [GetTypeInfoOfGuid (_hmfun _REFGUID (p : (_ptr o _ITypeInfo-pointer)) + -> 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)) + -> 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)) + -> FindConnectionPoint p) + #:release-with-function Release])) + +;; ---------------------------------------- +;; 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)) + -> 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" 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-cisymbol (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 exacpe/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, error code 0x~x~a~a" + (EXCEPINFO-wCode exn-info) + (if desc "\nDescription: " "") + (or desc "")) + (format "COM object exception~a~a" + (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)) + (handle-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 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) + (define sink-unknown + (CoCreateInstance CLSID_Sink #f + (bitwise-ior CLSCTX_LOCAL_SERVER CLSCTX_INPROC_SERVER) + IID_IUnknown)) + (define sink (QueryInterface sink-unknown IID_ISink _ISink-pointer)) + (Release sink-unknown) + (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))) diff --git a/collects/ffi/unsafe/private/win32.rkt b/collects/ffi/unsafe/private/win32.rkt new file mode 100644 index 0000000000..f597b6a0bc --- /dev/null +++ b/collects/ffi/unsafe/private/win32.rkt @@ -0,0 +1,335 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/winapi) +(provide (protect-out (all-defined-out))) + +;; Win32 type and structure declarations. + +(define advapi-dll (and (eq? (system-type) 'windows) + (ffi-lib "Advapi32.dll"))) +(define kernel-dll (and (eq? (system-type) 'windows) + (ffi-lib "kernel32.dll"))) +(define ole-dll (and (eq? (system-type) 'windows) + (ffi-lib "ole32.dll"))) +(define oleaut-dll (and (eq? (system-type) 'windows) + (ffi-lib "oleaut32.dll"))) + +(define-ffi-definer define-advapi advapi-dll + #:default-make-fail make-not-available) +(define-ffi-definer define-kernel kernel-dll + #:default-make-fail make-not-available) +(define-ffi-definer define-ole ole-dll + #:default-make-fail make-not-available) +(define-ffi-definer define-oleaut oleaut-dll + #:default-make-fail make-not-available) + +;; for functions that use the Windows stdcall ABI: +(define-syntax-rule (_wfun type ...) + (_fun #:abi winapi type ...)) + +;; for functions that return HRESULTs +(define-syntax _hfun + (syntax-rules (->) + [(_ type ... -> who res) + (_wfun type ... + -> (r : _HRESULT) + -> (if (positive? r) + (windows-error (format "~a: failed" 'who) r) + res))])) + +(define (bit-and? a b)(not (zero? (bitwise-and a b)))) + +(define _HRESULT _ulong) + +(define _LONG _long) +(define _DWORD _int32) +(define _WORD _int16) +(define _REGSAM _DWORD) +(define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v))))) +(define _UINT _uint) +(define _ULONG _ulong) +(define _INT _int) +(define _SHORT _short) +(define _USHORT _ushort) +(define _LCID _int32) +(define _DISPID _LONG) +(define _TYPEKIND _int) +(define _VARKIND _int) +(define _MEMBERID _DISPID) +(define _HREFTYPE _DWORD) +(define _VARTYPE _ushort) +(define _SCODE _LONG) +(define _FUNCKIND _int) +(define _INVOKEKIND _int) +(define _CALLCONV _int) +(define _DATE _double) +(define _CY _llong) +(define _SIZE_T _intptr) + +(define-cstruct _GUID ([l _uint] + [s1 _ushort] + [s2 _ushort] + [c (_array/list _byte 8)])) + +(define-cstruct _TYPEDESC ([u (_union + _pointer ; _TYPEDESC_pointer + _pointer ; _ARRAYDESC-pointer + _HREFTYPE)] + [vt _VARTYPE])) + +(define-cstruct _SAFEARRAYBOUND ([cElements _ULONG] + [lLbound _LONG])) + +(define-cstruct _ARRAYDESC ([tdescElem _TYPEDESC] + [cDims _USHORT] + [rgbounds (_array _SAFEARRAYBOUND 1)])) + +(define-cstruct _TYPEATTR ([guid _GUID] + [lcid _LCID] + [dwReserved _DWORD] + [memidConstructor _MEMBERID] + [memidDestructor _MEMBERID] + [lpstrSchema _string/utf-16] + [cbSizeInstance _ULONG] + [typekind _TYPEKIND] + [cFuncs _WORD] + [cVars _WORD] + [cImplTypes _WORD] + [cbSizeVft _WORD] + [cbAlignment _WORD] + [wTypeFlags _WORD] + [wMajorVerNum _WORD] + [wMinorVerNum _WORD] + ;;[tdescAlias _TYPEDESC] + ;;[idldescType _IDLDESC] + )) + +(define _VVAL (_union _double + _intptr + ;; etc. + )) + +(define-cstruct _VARIANT ([vt _VARTYPE] + [wReserved1 _WORD] + [wReserved2 _WORD] + [wReserved3 _WORD] + [u _VVAL])) +(define _VARIANTARG _VARIANT) +(define _VARIANTARG-pointer _VARIANT-pointer) + +(define-cstruct _IDLDESC ([dwReserved _intptr] + [wIDLFlags _USHORT])) + +(define-cstruct _PARAMDESCEX ([cBytes _ULONG] + [varDefaultValue _VARIANTARG])) + +(define-cstruct _PARAMDESC ([pparamdescex _PARAMDESCEX-pointer] + [wParamFlags _USHORT])) + +(define-cstruct _ELEMDESC ([tdesc _TYPEDESC] + [u (_union _IDLDESC + _PARAMDESC)])) + + +(define-cstruct _FUNCDESC ([memid _MEMBERID] + [lprgscode _pointer] + [lprgelemdescParam _ELEMDESC-pointer] ; an array + [funckind _FUNCKIND] + [invkind _INVOKEKIND] + [callconv _CALLCONV] + [cParams _SHORT] + [cParamsOpt _SHORT] + [oVft _SHORT] + [cScodes _SHORT] + [elemdescFunc _ELEMDESC] + [wFuncFlags _WORD])) + +(define-cstruct _VARDESC ([memid _MEMBERID] + [lpstrSchema _string/utf-16] + [u (_union _ULONG _VARIANT-pointer)] + [elemdescVar _ELEMDESC] + [wVarFlags _WORD] + [varkind _VARKIND])) + +(define-cstruct _DISPPARAMS ([rgvarg _pointer] ; to _VARIANTARGs + [rgdispidNamedArgs _pointer] ; to _DISPIDs + [cArgs _UINT] + [cNamedArgs _UINT])) + +(define-cstruct _EXCEPINFO ([wCode _WORD] + [wReserved _WORD] + [bstrSource _string/utf-16] + [bstrDescription _string/utf-16] + [bstrHelpFile _string/utf-16] + [dwHelpContext _DWORD] + [pvReserved _intptr] + [pfnDeferredFillIn _intptr] + [scode _SCODE])) + +(define (windows-error str raw-scode) + (define size 1024) + (define buf (make-bytes size)) + (define scode (if (negative? raw-scode) + (bitwise-and #xFFFFFFFF raw-scode) + raw-scode)) + (define len (FormatMessageW FORMAT_MESSAGE_FROM_SYSTEM #f scode 0 buf (quotient size 2))) + (if (positive? len) + (error (format "~a (~x; ~a)" str scode (regexp-replace #rx"[\r\n]+$" + (cast buf _pointer _string/utf-16) + ""))) + (error (format "~a (~x)" str scode)))) + +(define E_NOINTERFACE #x80004002) + +(define-kernel FormatMessageW (_wfun _DWORD _pointer + _HRESULT _DWORD + _pointer _DWORD + (_pointer = #f) + -> _DWORD)) +(define FORMAT_MESSAGE_FROM_SYSTEM #x00001000) + +(define CLSCTX_INPROC_SERVER #x1) +(define CLSCTX_LOCAL_SERVER #x4) +(define CLSCTX_REMOTE_SERVER #x10) + +(define LOCALE_SYSTEM_DEFAULT #x0800) + +(define IMPLTYPEFLAG_FDEFAULT #x1) +(define IMPLTYPEFLAG_FSOURCE #x2) +(define IMPLTYPEFLAG_FRESTRICTED #x4) +(define IMPLTYPEFLAG_FDEFAULTVTABLE #x8) + +(define TKIND_ENUM 0) +(define TKIND_RECORD 1) +(define TKIND_MODULE 2) +(define TKIND_INTERFACE 3) +(define TKIND_DISPATCH 4) +(define TKIND_COCLASS 5) +(define TKIND_ALIAS 6) +(define TKIND_UNION 7) +(define TKIND_MAX 8) + +(define INVOKE_FUNC 1) +(define INVOKE_PROPERTYGET 2) +(define INVOKE_PROPERTYPUT 4) +(define INVOKE_PROPERTYPUTREF 8) +(define INVOKE_EVENT 16) + +(define FUNC_VIRTUAL 0) +(define FUNC_PUREVIRTUAL 1) +(define FUNC_NONVIRTUAL 2) +(define FUNC_STATIC 3) +(define FUNC_DISPATCH 4) + +(define PARAMFLAG_NONE 0) +(define PARAMFLAG_FIN #x1) +(define PARAMFLAG_FOUT #x2) +(define PARAMFLAG_FLCID #x4) +(define PARAMFLAG_FRETVAL #x8) +(define PARAMFLAG_FOPT #x10) +(define PARAMFLAG_FHASDEFAULT #x20) +(define PARAMFLAG_FHASCUSTDATA #x40) + +(define VT_EMPTY 0) +(define VT_NULL 1) +(define VT_I2 2) +(define VT_I4 3) +(define VT_R4 4) +(define VT_R8 5) +(define VT_CY 6) +(define VT_DATE 7) +(define VT_BSTR 8) +(define VT_DISPATCH 9) +(define VT_ERROR 10) +(define VT_BOOL 11) +(define VT_VARIANT 12) +(define VT_UNKNOWN 13) +(define VT_DECIMAL 14) +(define VT_I1 16) +(define VT_UI1 17) +(define VT_UI2 18) +(define VT_UI4 19) +(define VT_I8 20) +(define VT_UI8 21) +(define VT_INT 22) +(define VT_UINT 23) +(define VT_VOID 24) +(define VT_HRESULT 25) +(define VT_PTR 26) +(define VT_SAFEARRAY 27) +(define VT_CARRAY 28) +(define VT_USERDEFINED 29) +(define VT_LPSTR 30) +(define VT_LPWSTR 31) +(define VT_RECORD 36) +(define VT_INT_PTR 37) +(define VT_UINT_PTR 38) +(define VT_FILETIME 64) +(define VT_BLOB 65) +(define VT_STREAM 66) +(define VT_STORAGE 67) +(define VT_STREAMED_OBJECT 68) +(define VT_STORED_OBJECT 69) +(define VT_BLOB_OBJECT 70) +(define VT_CF 71) +(define VT_CLSID 72) +(define VT_VERSIONED_STREAM 73) +(define VT_BSTR_BLOB #xfff) +(define VT_VECTOR #x1000) +(define VT_ARRAY #x2000) +(define VT_BYREF #x4000) +(define VT_RESERVED #x8000) +(define VT_ILLEGAL #xffff) +(define VT_ILLEGALMASKED #xfff) +(define VT_TYPEMASK #xfff) + +(define DISPID_PROPERTYPUT -3) + +(define DISP_E_PARAMNOTFOUND #x80020004) +(define DISP_E_EXCEPTION #x80020009) +(define DISP_E_UNKNOWNNAME #x80020006) +(define REGDB_E_CLASSNOTREG #x80040154) + +(define-ole IIDFromString (_hfun _string/utf-16 _GUID-pointer + -> IIDFromString (void)) + #:fail (lambda () + (lambda (s guid) + ;; Implement the conversion manually, so that it works + ;; on all platforms (which module-startup issues) + (define n (string->number (regexp-replace* #rx"[-{}]" s "") 16)) + (set-GUID-l! guid (arithmetic-shift n (* -12 8))) + (set-GUID-s1! guid (bitwise-and #xFFFF (arithmetic-shift n (* -10 8)))) + (set-GUID-s2! guid (bitwise-and #xFFFF (arithmetic-shift n (* -8 8)))) + (set-GUID-c! guid (for/list ([i (in-range 8)]) + (bitwise-and #xFF (arithmetic-shift n (* (- -7 i))))))))) + +(define-ole StringFromIID(_hfun _GUID-pointer (p : (_ptr o _pointer)) + -> StringFromIID p)) + + +(define (string->guid s [stay-put? #f]) + (define guid + (if stay-put? + (cast (malloc _GUID 'atomic-interior) _pointer _GUID-pointer) + (make-GUID 0 0 0 (list 0 0 0 0 0 0 0 0)))) + (IIDFromString s guid) + guid) + +(define (guid->string guid) + (define p (StringFromIID guid)) + (begin0 + (cast p _pointer _string/utf-16) + (CoTaskMemFree p))) + +(define (guid=? guid guid2) + (and (= (GUID-l guid) (GUID-l guid2)) + (= (GUID-s1 guid) (GUID-s1 guid2)) + (= (GUID-s2 guid) (GUID-s2 guid2)) + (andmap = (GUID-c guid) (GUID-c guid2)))) + +(define-ole CoTaskMemFree (_wfun _pointer -> _void)) +(define-ole CoTaskMemAlloc (_wfun _SIZE_T -> _pointer)) + +(define-oleaut SysFreeString (_wfun _pointer -> _void)) +(define-oleaut SysAllocStringLen (_wfun _pointer _uint -> _pointer)) diff --git a/collects/scribble/private/manual-scheme.rkt b/collects/scribble/private/manual-scheme.rkt index af5d923f33..20f28337b5 100644 --- a/collects/scribble/private/manual-scheme.rkt +++ b/collects/scribble/private/manual-scheme.rkt @@ -230,18 +230,21 @@ (define-/form racketblock/form racketblock) (define-/form racket/form racket) -(define (*racketlink stx-id id . s) +(define (*racketlink stx-id id style . s) (let ([content (decode-content s)]) (make-delayed-element (lambda (r p ri) (make-link-element - #f + style content (or (find-racket-tag p ri stx-id #f) `(undef ,(format "--UNDEFINED:~a--" (syntax-e stx-id)))))) (lambda () content) (lambda () content)))) -(define-syntax-rule (racketlink id . content) - (*racketlink (quote-syntax id) 'id . content)) - +(define-syntax racketlink + (syntax-rules () + [(_ id #:style style . content) + (*racketlink (quote-syntax id) 'id style . content)] + [(_ id . content) + (*racketlink (quote-syntax id) 'id #f . content)])) diff --git a/collects/scribblings/foreign/com-auto.scrbl b/collects/scribblings/foreign/com-auto.scrbl new file mode 100644 index 0000000000..1136869e08 --- /dev/null +++ b/collects/scribblings/foreign/com-auto.scrbl @@ -0,0 +1,464 @@ +#lang scribble/doc +@(require scribble/manual + scribble/bnf + "com-common.rkt" + (for-label racket/base + (except-in racket/contract ->) + ffi/unsafe/com + ffi/com-registry)) + +@title[#:tag "com-auto"]{COM Automation} + +@defmodule[ffi/com #:use-sources (ffi/unsafe/com)]{The +@racketmodname[ffi/com] library builds on COM automation to provide a +safe use of COM objects that support the @as-index{@cpp{IDispatch}} +interface.} + +@margin-note{The @racketmodname[ffi/com] library is based on the +@deftech{MysterX} library by Paul Steckler. MysterX is included with +Racket but deprecated, and it will be replaced in the next version +with a partial compability library that redirects to this one.} + +@; ---------------------------------------- + +@section{GUIDs, CLSIDs, IIDs, and ProgIDs} + +@deftogether[( +@defproc[(guid? [v any/c]) boolean?] +@defproc[(clsid? [v any/c]) boolean?] +@defproc[(iid? [v any/c]) boolean?] +)]{ + +Returns @racket[#t] if @racket[v] is a structure representing a +@tech{GUID}, @racket[#f] otherwise. The @racket[clsid?] and +@racket[iid?] functions are the same as @racket[guid?]. + +A @tech{GUID} corresponds an a @racket[_GUID] structure at the unsafe +layer.} + +@deftogether[( +@defproc[(string->guid [str string?]) guid?] +@defproc[(string->clsid [str string?]) clsid?] +@defproc[(string->iid [str string?]) iid?] +)]{ + +Converts a string of the form +@racket["{00000000-0000-0000-0000-0000000000}"], where each @tt{0} can +be a hexadecimal digit, to a @tech{GUID}. If @racket[str] does not +have te expected form, the @racket[exn:fail] exception is raised. + +The @racket[string->clsid] and @racket[string->iid] functions are the +same as @racket[string->guid].} + +@defproc[(guid->string [g guid?]) string?]{ + +Converts a @tech{GUID} to its string form.} + +@defproc[(guid=? [g1 guid?] [g2 guid?]) boolean?]{ + +Determines whether @racket[g1] and @racket[g2] represent the same @tech{GUID}.} + +@deftogether[( +@defproc[(progid->clsid [progid string?]) clsid?] +@defproc[(clsid->progid [clsid clsid?]) (or/c string? #f)] +)]{ + +Converts a @tech{ProgID} to a @tech{CLSID} or vice versa. Not evey +@tech{COM class} has a @tech{ProgID}, so the result of +@racket[clsid->progid] can be @racket[#f]. + +The @racket[progid->clsid] function accepts a versionless +@tech{ProgID}, in which case it produces the @tech{CLSID} of the most +recent available version. The @racket[clsid->progid] function always +produces a @tech{ProgID} with its version.} + +@; ---------------------------------------- + +@section{COM Objects} + +@defproc[(com-object? [obj com-object?]) boolean?]{ + + Returns @racket[#t] if the argument is a COM object, @racket[#f] + otherwise.} + + +@defproc[(com-create-instance [clsid-or-progid (or/c clsid? string?)] + [where (or/c (one-of/c 'local 'remote) string?) 'local]) + com-object?]{ + + Returns an instance of the @tech{COM class} specified by + @racket[clsid-or-progid], which is either a @tech{CLSID} or a + @tech{ProgID}. + + The optional @racket[where] argument indicates a location for + running the instance, and may be @racket['local], @racket['remote], + or a string indicating a machine name. See @secref["remote"] for + more information. + + An object can be created this way for any COM class, but functions + such as @racket[com-invoke] work only if the object supports the + @cpp{IDispatch} COM automation interface. + + The resulting object is registered with the current custodian, which + retains a reference to the object until it is released with + @racket[com-release] or the custodian is shut down.} + + +@defproc[(com-release [obj com-object?]) void?]{ + +Releases the given @tech{COM object}. The given @racket[obj] is +subsequently unusable, and the underlying COM object is destroyed +unless its reference count has been incremented (via COM methods or +unsafe operations).} + + +@defproc[(com-get-active-object [clsid-or-progid (or/c clsid? string?)]) + com-object?]{ + + Like @racket[com-create-instance], but gets an existing + active object (always local) instead of creating a new one.} + + +@defproc[(com-object-clsid [obj com-object?]) clsid?]{ + + Returns the @racket{CLSID} of the COM class instantiated by + @racket[obj], or raises an error if the COM class is not known.} + + +@defproc[(com-object-set-clsid! [obj com-object?] [clsid clsid?]) void?]{ + + Sets the COM @tech{CLSID} for @racket[obj] to @racket[clsid]. This + is useful when COM event-handling procedures can obtain only + ambiguous information about the object's COM class.} + + +@defproc[(com-object-eq? [obj1 com-object?] [obj2 com-object?]) + boolean?]{ + + Returns @racket[#t] if the two COM objects are the same, + @racket[#f] otherwise.} + + +@defproc[(com-type? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] represents reflective information +about a COM object's type, @racket[#f] otherwise.} + + +@defproc[(com-object-type [obj com-object?]) com-type?]{ + +Returns a representation of a COM object's type that is independent of +the object itself.} + + +@defproc[(com-type=? [t1 com-type?] [t2 com-type?]) boolean?]{ + +Returns @racket[#t] if @racket[t1] and @racket[t2] represent the same +type information, @racket[#f] otherwise.} + +@; ---------------------------------------- + +@section{COM Methods} + +@defproc[(com-methods [obj/type (or/c com-object? com-type?)]) + (listof string?)]{ + + Returns a list of strings indicating the names of methods on + @racket[obj/type].} + + +@defproc[(com-method-type [obj/type (or/c com-object? com-type?)] + [method-name string?]) + (list/c '-> list? any/c)]{ + + Returns a list indicating the type of the specified method in + @racket[obj/type]. The list after the @racket['->] represents the + argument types, and the final value represents the result type. See + @secref["com-types"] for more information.} + + +@defproc[(com-invoke [obj com-object?] [method-name string?] [v any/c]) + any/c]{ + + Invokes @racket[method-name] on @racket[obj] with @racket[v]s as the + arguments. The special value @racket[com-omit] may be used for + optional arguments, which useful when values are supplied for + arguments after the omitted argument(s).} + + +@defthing[com-omit any/c]{ + +A constant for use with @racket[com-invoke] in place of an optional +argument.} + + +@; ---------------------------------------- + +@section{COM Properties} + +@defproc[(com-get-properties [obj/type (or/c com-object? com-type?)]) + (listof string?)]{ + + Returns a list of strings indicating the names of readable + properties in @racket[obj/type].} + + +@defproc[(com-get-property-type [obj/type (or/c com-object? com-type?)] + [property-name string?]) + (list/c '-> '() any/c)]{ + + Returns a type for @racket[property-name] like a result of + @racket[com-method], where the result type corresponds to the + property value type. See @secref["com-types"] for information on the + symbols.} + + +@defproc[(com-get-property [obj com-object?] [property string?] ...+) + any/c]{ + + Returns the value of the final property by following the indicated + path of @racket[property]s, where each intermediate property must be a + COM object.} + + +@defproc[(com-set-properties [obj/type (or/c com-object? com-type?)]) + (listof string?)]{ + + Returns a list of strings indicating the names of writeable + properties in @racket[obj/type].} + + +@defproc[(com-set-property-type [obj/type (or/c com-object? com-type?)] + [property-name string?]) + (list/c '-> (list/c any/c) 'void)]{ + + Returns a type for @racket[property-name] like a result of + @racket[com-method], where the sole argument type corresponds to the + property value type. See @secref["com-types"] for + information on the symbols.} + + +@defproc[(com-set-property! [obj com-object?] + [string? property] ...+ + [v any/c]) + void?]{ + + Sets the value of the final property in @racket[obj] to @racket[v] + by following the @racket[property]s, where the value of each + intermediate property must be a COM object.} + +@; ---------------------------------------- + +@section{COM Events} + +@defproc[(com-events [obj/type (or/c com-object? com-type?)]) + (listof string?)]{ + + Returns a list of strings indicating the names of events on + @racket[obj/type].} + + +@defproc[(com-event-type [obj/type (or/c com-object? com-type?)] + [event-name string?]) + (list/c '-> list? 'void)]{ + + Returns a list indicating the type of the specified events in + @racket[obj/type]. The list after the @racket['->] represents the + argument types. See @secref["com-types"] for more information.} + + +@defproc[(com-event-executor? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @deftech{COM event executor}, +which queues event callbacks. A @tech{COM event executor} +@racket[_com-ev-ex] is a synchronizable event in the sense of +@racket[sync], and @racket[(sync _com-ev-ex)] returns a thunk for a +ready callback.} + + +@defproc[(com-make-event-executor) com-event-executor?]{ + +Creates a fresh @tech{COM event executor} for use with +@racket[com-register-event-callback].} + + +@defproc[(com-register-event-callback [obj com-object?] + [name string?] + [proc procedure?] + [com-ev-ex com-event-executor?]) + void?]{ + +Registers a callback for the event named by @racket[name] in +@racket[obj]. When the event fires, an invocation of @racket[proc] to +event arguments (which depends on @racket[obj] and @racket[name]) is +queued in @racket[com-ev-ex]. Synchronizing on @racket[com-ev-ex] +produces a thunk that applies @racket[proc] to the event arguments and +returns the result. + +Only one callback can be registered for each @racket[obj] and +@racket[name] combination. + +Registration of event callbacks relies on prior registration of the +COM class implemented by @filepath{myssink.dll} as distributed with +Racket. (The DLL is the same for all Racket versions.)} + + +@defproc[(com-unregister-event-callback [obj com-object?] + [name string?]) + void?]{ + +Removes any existing callback for @racket[name] in @racket[obj].} + + +@; ---------------------------------------- + +@section{Interface Pointers} + +@deftogether[( +@defproc[(com-object-get-iunknown [obj com-object?]) com-iunkown?] +@defproc[(com-object-get-idispatch [obj com-object?]) com-idispatch?] +)]{ + +Extracts an @cpp{IUnknown} or @cpp{IDispatch} pointer from +@racket[obj]. The former succeeds for any @tech{COM object} that has +not been relased via @racket[com-release]. The latter succeeds +only when the @tech{COM object} supports @cpp{IDispatch}, otherwise +@racket[exn:fail] is raised.} + + +@defproc[(com-iunknown? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] corresponds to an unsafe +@racket[_IUnknown-pointer], @racket[#f] otherwise. Every @tech{COM +interface} extends @cpp{IUnknown}, so @racket[com-iunknown?] returns +@racket[#t] for every interface pointers.} + + +@defproc[(com-idispatch? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] corresponds to an unsafe +@cpp{IDispatch}, @racket[#f] otherwise.} + + +@; ---------------------------------------- + +@section[#:tag "remote"]{Remote COM servers (DCOM)} + +The optional @racket[_where] argument to @racket[com-create-instance] +can be @racket['remote]. In that case, the server instance is run at +the location given by the Registry key + +@centerline{@tt{HKEY_CLASSES_ROOT\AppID\@nonterm{CLSID}\RemoteServerName}} + +where @nonterm{CLSID} is the CLSID of the application. This key may +be set using the @exec{dcomcnfg} utility. From @exec{dcomcnfg}, pick +the application to be run on the @onscreen{Applications} tab, then +click on the @onscreen{Properties} button. On the @onscreen{Location} +tab, choose @onscreen{Run application on the following computer}, and +enter the machine name. + +To run a COM remote server, the registry on the client machine must +contain an entry at + +@centerline{@tt{HKEY_CLASSES_ROOT\CLSID\@nonterm{CLSID}}} + +where @nonterm{CLSID} is the CLSID for the server. The server +application itself need not be installed on the client machine. + +There are a number of configuration issues relating to DCOM. See + +@centerline{@link["http://www.distribucon.com/dcom95.aspx"]{http://www.distribucon.com/dcom95.html}} + +for more information on how to setup client and server machines for DCOM. + +@; ---------------------------------------- + +@section[#:tag "com-types"]{COM Types} + +In the result of a function like @racket[com-method-type], symbols are +used to represent various atomic types: + +@itemlist[ + + @item{@racket['int] --- a 32-bit signed integer} + + @item{@racket['unsigned-int] --- a 32-bit unsigned integer} + + @item{@racket['short] --- a 16-bit signed integer} + + @item{@racket['unsigned-short] --- a 16-bit unsigned integer} + + @item{@racket['char] --- an 8-bit signed integer} + + @item{@racket['unsigned-char] --- an 8-bit unsigned integer} + + @item{@racket['long-long] --- a 64-bit signed integer} + + @item{@racket['unsigned-long-long] --- a 64-bit unsigned integer} + + @item{@racket['float] --- a 32-bit floating-point number} + + @item{@racket['double] --- a 64-bit floating-point number} + + @item{@racket['currency] --- an exact number that, when multiplied by 10,000, + is a 64-bit signed integer} + + @item{@racket['boolean] --- a boolean} + + @item{@racket['string] --- a string} + + @item{@racket['date] --- a @racket[date] or @racket[date*]} + + @item{@racket['com-object] --- a @tech{COM object} as in @racket[com-object?]} + + @item{@racket['iunknown] --- an @cpp{IUnknown} pointer as in @racket[com-iunknown?]} + + @item{@racket['com-enumeration] --- a 32-bit signed integer} + + @item{@racket['any] --- any of the above} + + @item{@racket['void] --- no value} + +] + +A type symbol wrapped in a list with @racket['box], such as +@racket['(box int)], is a call-by-reference argument. A box supplied +for the argument is updated with a new value when the method returns. + +A type wrapped in a list with @racket['opt], such as @racket['(opt +(box int))], is an optional argument. The argument can be omitted or +replaced with @racket[com-omit]. + +@; ---------------------------------------- + +@section{Class Display Names} + +@defmodule[ffi/com-registry]{The @racketmodname[ffi/com-registry] +library provides a mapping from @tech{coclass} names to @tech{CLSIDs} +for compatibility with the older @tech{MysterX} interface.} + +A @deftech{coclass} name corresponds to the display name of a COM +class; the display name is not uniquely mapped to a COM class, and +some COM classes have no display name. + + +@defproc[(com-all-coclasses) (listof string?)]{ + +Returns a list of @tech{coclass} strings for all @tech{COM class}es +registered on a system.} + + +@defproc[(com-all-controls) (listof string?)]{ + +Returns a list of @tech{coclass} strings for all COM classes in the +system registry that have the @racket["Control"] subkey.} + + +@deftogether[( +@defproc[(coclass->clsid [coclass string?]) clsid?] +@defproc[(clsid->coclass [clsid clsid?]) string?] +)]{ + +Converts a @tech{coclass} string to/from a @tech{CLSID}. This +conversion is implemented by an enumeration an @tech{COM class}es from +the system registry.} diff --git a/collects/scribblings/foreign/com-common.rkt b/collects/scribblings/foreign/com-common.rkt new file mode 100644 index 0000000000..522fd13a0d --- /dev/null +++ b/collects/scribblings/foreign/com-common.rkt @@ -0,0 +1,7 @@ +#lang racket/base +(require scribble/base) + +(provide cpp) + +(define cpp tt) + diff --git a/collects/scribblings/foreign/com-intf.scrbl b/collects/scribblings/foreign/com-intf.scrbl new file mode 100644 index 0000000000..118865d063 --- /dev/null +++ b/collects/scribblings/foreign/com-intf.scrbl @@ -0,0 +1,328 @@ +#lang scribble/doc +@(require scribble/manual + "com-common.rkt" + scribble/racket + (for-syntax racket/base) + (for-label racket/base + (except-in racket/contract ->) + ffi/unsafe + ffi/unsafe/com + ffi/unsafe/alloc + ffi/winapi)) + +@title[#:tag "com-intf"]{COM Classes and Interfaces} + +@defmodule[ffi/unsafe/com]{The @racketmodname[ffi/unsafe/com] library +exports all of @racketmodname[ffi/com], and it also supports direct, +FFI-based calls to COM object methods.} + +@; ---------------------------------------- + +@section{Describing COM Interfaces} + +@defform/subs[(define-com-interface (_id _super-id) + ([method-id ctype-expr maybe-alloc-spec])) + ([maybe-alloc-spec code:blank + (code:line #:release-with-function function-id) + (code:line #:release-with-method method-id) + #:releases])]{ + +Defines @racket[_id] as an interface that extends @racket[_super-id], +where @racket[_super-id] is often @racket[_IUnknown], and that +includes methods named by @racket[method-id]. The @racket[_id] and +@racket[_super-id] identifiers must start with an underscore. A +@racket[@#,racket[_super-id]@#,racketidfont{_vt}] must also be defined +for deriving a virtual-method table type. + +The order of the @racket[method-id]s must match the specification of +the @tech{COM interface}, not including methods inherited from +@racket[_super-id]. Each method type produced by @racket[ctype-expr] +that is not @racket[_fpointer] must be a function type whose first +argument is the ``self'' pointer, usually constructed with +@racket[_mfun] or @racket[_hmfun]. + +The @racket[define-com-interface] form binds @racket[_id], +@racket[@#,racketvarfont{id}?], @racket[@#,racket[_id]-pointer], +@racket[@#,racket[_id]@#,racketidfont{_}vt] (for the virtual-method +table), @racket[@#,racket[_id]@#,racketidfont{_}vt-pointer], and +@racket[method-id] for each method whose @racket[ctype-expr] is not +@racket[_fpointer]. (In other words, use @racket[_fpointer] as a +placeholder for methods of the interface that you do not need to +call.) An instance of the interface will have type +@racket[@#,racket[_id]-pointer]. Each defined @racket[method-id] is +bound to a function-like macro that expects a +@racket[@#,racket[_id]-pointer] as its first argument and the method +arguments as the remaining arguments. + +A @racket[maybe-alloc-spec] describes allocation and finalization +information for a method along the lines of +@racketmodname[ffi/unsafe/alloc]. If the @racket[maybe-alloc-spec] is +@racket[#:release-with-function function-id], then +@racket[function-id] is used to deallocate the result produced by the +method, unless the result is explictly deallocated before it becomes +unreachable; for exmaple, @racket[#:release-with-function Release] is +suitable for a method that returns a COM interface reference that must +be eventually released. The @racket[#:release-with-method method-id] +form is similar, except that the deallocator is a method on the same +object as the allocating method (i.e., one of the other +@racket[method-id]s or an inherited method). A @racket[#:releases] +annotation indicates that a method is a deallocator (so that a value +should not be automatically deallocated if it is explicitly +deallocated using the method). + +See @secref["com-intf-example"] for an example using +@racket[define-com-interface].} + +@; ---------------------------------------- + +@section{Obtaining COM Interface References} + +@defproc[(QueryInterface [iunknown com-iunknown?] [iid iid?] [intf-pointer-type ctype?]) + (or/c cpointer? #f)]{ + +Attempts to extract a @tech{COM interface} pointer for the given +@tech{COM object}. If the object does not support the requested +interface, the result is @racket[#f], otherwise it is cast to the type +@racket[intf-pointer-type]. + +Specific @tech{IIDs} and @racket[intf-pointer-type]s go together. For +example, @racket[IID_IUnknown] goes with @racket[_IUnknown-pointer]. + +For a non-@racket[#f] result, @racket[Release] function is the +automatic deallocator for the resulting pointer. The pointer is +register with a deallocator after the cast to +@racket[intf-pointer-type], which is why @racket[QueryInterface] +accepts the @racket[intf-pointer-type] argument (since a cast +generates a fresh reference).} + +@deftogether[( +@defproc[(AddRef [iunknown com-iunknown?]) exact-positive-integer?] +@defproc[(Release [iunknown com-iunknown?]) exact-nonnegative-integer?] +)]{ + +Increments or decrements the reference count on @racket[iunknown], +returning the new reference count and releasing the interface +reference if the count goes to zero.} + + +@defproc[(make-com-object [iunknown com-iunknown?] [clsid (or/c clsid? #f)]) + com-object?]{ + +Converts a @tech{COM object} into a object that can be used with the +COM automation functions, such as @racket[com-invoke].} + +@; ---------------------------------------- + +@section{COM FFI Helpers} + + +@defform[(_wfun fun-option ... maybe-args type-spec ... -> type-spec + maybe-wrapper)]{ + +Like @racket[_fun], but adds @racket[#:abi winapi].} + + +@defform[(_mfun fun-option ... maybe-args type-spec ... -> type-spec + maybe-wrapper)]{ + +Like @racket[_wfun], but adds a @racket[_pointer] type (for the +``self'' argument of a method) as the first argument @racket[type-spec].} + + +@defform[(_hfun fun-option ... type-spec ... -> id output-expr)]{ + +Like @racket[_wfun], but for a function that returns an +@racket[_HRESULT]. If the result is not zero, then an error is raised +using @racket[windows-error] and using @racket[id] as the name of the +failed function. Otherwise, @racket[output-expr] (as in a +@racket[_maybe-racket] for @racket[_fun]) determines the result.} + + +@defform[(_hmfun fun-option ... type-spec ... -> id output-expr)]{ + +Like @racket[_hfun], but lke @racket[_mfun] in that @racket[_pointer] +is added for the first argument.} + + +@deftogether[( +@defthing[_GUID ctype?] +@defthing[_GUID-pointer ctype?] +@defthing[_HRESULT ctype?] +@defthing[_LCID ctype?] +)]{ + +Some @tech{C types} that commonly appear in COM interface +specifications.} + + +@defthing[LOCALE_SYSTEM_DEFAULT exact-integer?]{ + +The usual value for a @racket[_LCID] argument.} + + +@deftogether[( +@defproc[(SysFreeString [str _pointer]) void?] +@defproc[(SysAllocStringLen [content _pointer] [len integer?]) cpointer?] +)]{ + +COM interfaces often require or return srings that must be allocated +or freed as system strings. + +When receiving a string value, @racket[cast] it to +@racket[_string/utf-16] to extract a copy of the string, and then free +the original pointer with @racket[SysFreeString].} + + +@deftogether[( +@defthing[IID_NULL iid?] +@defthing[IID_IUnknown iid?] +)]{ + +Commonly used @tech{IIDs}.} + +@deftogether[( +@defthing[_IUnknown ctype?] +@defthing[_IUnknown-pointer ctype?] +@defthing[_IUnknown_vt ctype?] +)]{ + +Types for the @cpp{IUnknown} @tech{COM interface}.} + + +@defproc[(windows-error [msg string?] [hresult exact-integer?]) + any]{ + +Raises an exception. The @racket[msg] strign provides the base error +message, but @racket[hresult] and its human-readable interpretation +(if available) are added to the message.} + +@; ---------------------------------------- + +@section[#:tag "com-intf-example"]{COM Interface Example} + +Here's an example using the Standard Component Categories Manager to +enumerate installed COM classes that are in the different +systemd-defined categories. The example illustrates instantiating a +COM class by @tech{CLSID}, describing COM interfaces with +@racket[define-com-interface], and using allocation specifications to +ensure that resources are reclaimed even if an error is encountered or +the program is interrupted. + +@(define-syntax-rule (define-literals id ...) (begin (define-literal id) ...)) +@(define-syntax-rule (define-literal id) + (define-syntax id (make-element-id-transformer + (lambda (stx) #'@racketidfont[(symbol->string 'id)])))) +@define-literals[_ULONG _CATID _REFCATID + _CATEGORYINFO _CATEGORYINFO-pointer + _IEnumGUID _IEnumGUID-pointer + _IEnumCATEGORYINFO _IEnumCATEGORYINFO-pointer + _ICatInformation _ICatInformation-pointer] + +@racketmod[ +racket/base +(require ffi/unsafe + ffi/unsafe/com) + +(provide show-all-classes) + +(code:comment @#,t{The function that uses COM interfaces defined further below:}) + +(define (show-all-classes) + (define ccm + (com-create-instance CLSID_StdComponentCategoriesMgr)) + (define icat (QueryInterface (com-object-get-iunknown ccm) + IID_ICatInformation + _ICatInformation-pointer)) + (define eci (EnumCategories icat LOCALE_SYSTEM_DEFAULT)) + (for ([catinfo (in-producer (lambda () (Next/ci eci)) #f)]) + (printf "~a:\n" + (cast (array-ptr (CATEGORYINFO-szDescription catinfo)) + _pointer + _string/utf-16)) + (define eg + (EnumClassesOfCategories icat (CATEGORYINFO-catid catinfo))) + (for ([guid (in-producer (lambda () (Next/g eg)) #f)]) + (printf " ~a\n" (or (clsid->progid guid) + (guid->string guid)))) + (Release eg)) + (Release eci) + (Release icat)) + +(code:comment @#,t{The class to instantiate:}) + +(define CLSID_StdComponentCategoriesMgr + (string->clsid "{0002E005-0000-0000-C000-000000000046}")) + +(code:comment @#,t{Some types and variants to match the specification:}) + +(define _ULONG _ulong) +(define _CATID _GUID) +(define _REFCATID _GUID-pointer) +(define-cstruct _CATEGORYINFO ([catid _CATID] + [lcid _LCID] + [szDescription (_array _short 128)])) + +(code:comment @#,t{------ IEnumGUID -------}) + +(define IID_IEnumGUID + (string->iid "{0002E000-0000-0000-C000-000000000046}")) + +(define-com-interface (_IEnumGUID _IUnknown) + ([Next/g (_mfun (_ULONG = 1) (code:comment @#,t{simplifed to just one}) + (guid : (_ptr o _GUID)) + (got : (_ptr o _ULONG)) + -> (r : _HRESULT) + -> (cond + [(zero? r) guid] + [(= r 1) #f] ; done + [else (windows-error "Next/g failed" r)]))] + [Skip _fpointer] + [Reset _fpointer] + [Clone _fpointer])) + +(code:comment @#,t{------ IEnumCATEGORYINFO -------}) + +(define IID_IEnumCATEGORYINFO + (string->iid "{0002E011-0000-0000-C000-000000000046}")) + +(define-com-interface (_IEnumCATEGORYINFO _IUnknown) + ([Next/ci (_mfun (_ULONG = 1) (code:comment @#,t{simplifed to just one}) + (catinfo : (_ptr o _CATEGORYINFO)) + (got : (_ptr o _ULONG)) + -> (r : _HRESULT) + -> (cond + [(zero? r) catinfo] + [(= r 1) #f] ; done + [else (windows-error "Next/ci failed" r)]))] + [Skip _fpointer] + [Reset _fpointer] + [Clone _fpointer])) + +(code:comment @#,t{------ ICatInformation -------}) + +(define IID_ICatInformation + (string->iid "{0002E013-0000-0000-C000-000000000046}")) + +(define-com-interface (_ICatInformation _IUnknown) + ([EnumCategories (_hmfun _LCID + (p : (_ptr o _IEnumCATEGORYINFO-pointer)) + -> EnumCategories p)] + [GetCategoryDesc (_hmfun _REFCATID _LCID + (p : (_ptr o _pointer)) + -> GetCategoryDesc + (begin0 + (cast p _pointer _string/utf-16) + (SysFreeString p)))] + [EnumClassesOfCategories (_hmfun (_ULONG = 1) (code:comment @#,t{simplifed}) + _REFCATID + (_ULONG = 0) (code:comment @#,t{simplifed}) + (_pointer = #f) + (p : (_ptr o + _IEnumGUID-pointer)) + -> EnumClassesOfCategories p) + #:release-with-function Release] + [IsClassOfCategories _fpointer] + [EnumImplCategoriesOfClass _fpointer] + [EnumReqCategoriesOfClass _fpointer])) + +] diff --git a/collects/scribblings/foreign/com.scrbl b/collects/scribblings/foreign/com.scrbl new file mode 100644 index 0000000000..c791235f1d --- /dev/null +++ b/collects/scribblings/foreign/com.scrbl @@ -0,0 +1,62 @@ +#lang scribble/doc +@(require scribble/manual + "com-common.rkt" + (for-label racket/base + ffi/unsafe/com)) + +@title[#:style 'toc #:tag "com"]{COM (Common Object Model)} + +The @racketmodname[ffi/com] and @racketmodname[ffi/unsafe/com] +libraries support COM interaction in two layers. The safe upper layer +provides functions for creating COM objects and dynamically +constructing method calls based on COM automatiion (i.e., reflective +information provided by the object). The unsafe lower layer provides a +syntactic form and functions for working more directly with COM +objects and interfaces. + +A @deftech{COM object} instantiates a particular @deftech{COM +class}. A @tech{COM class} can be specified in either of two ways: + +@itemlist[ + + @item{A @deftech{CLSID} (class id), which is represented as a + @tech{GUID}. A @deftech{GUID} (globally unique identifier) is a + 16-byte structure. GUIDs are typically written in string forms such + as @racket["{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}"]. The + @racket[string->guid] and @racket[guid->string] convert between + string and @tech{GUID} forms. The @racket[string->clsid] function is + the same as @racket[string->guid], but its use suggests that the + resulting @tech{GUID} is to be used as a @tech{CLSID}.} + + @item{A @deftech{ProgID} is a human-readable name, such as + @racket["MzCom.MzObj.5.2.0.7"], which includes a version number. The + version number can be omitted in a @tech{ProgID}, in which case the + most recent available version is used. The operating system provides + a mapping between @tech{ProgIDs} and @tech{CLSIDs} that is available + via @racket[progid->clsid] and @racket[clsid->progid].} + +] + +A @tech{COM object} can be instantiated either on the local machine or +on a remote machine. The latter relies on the operating system's +@deftech{DCOM} (distributed COM) support. + +Each @tech{COM object} supports some number of @deftech{COM +interfaces}. A @tech{COM interface} has a programmatic name, such as +@cpp{IDispatch}, that corresponds to a C-layer protocol. Each +interface also has an @deftech{IID} (interface id) that is represented +as a @tech{GUID} such as +@racket["{00020400-0000-0000-C000-000000000046}"]. Direct calls to COM +methods require extracting a suitable interface pointer from an object +using @racket[QueryInterface] and the desired @tech{IID}; the result +is effectively cast it to a pointer to a dispatch-table pointer, where +the dispatch table has a statically known size and foreign-function +content. The @racket[define-com-interface] form simplifies description +and use of interface pointers. The COM automation layer uses a fixed +number of reflection interfaces internally, notably @cpp{IDispatch}, +to call methods by name and with safe argument marshaling. + +@local-table-of-contents[] + +@include-section["com-auto.scrbl"] +@include-section["com-intf.scrbl"] diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index 9f7d964e03..0b21c6396a 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -13,5 +13,6 @@ @include-section["atomic.scrbl"] @include-section["try-atomic.scrbl"] @include-section["objc.scrbl"] +@include-section["com.scrbl"] @include-section["file.scrbl"] @include-section["winapi.scrbl"] diff --git a/collects/scribblings/foreign/objc.scrbl b/collects/scribblings/foreign/objc.scrbl index 14ebcb6d49..6d86dcec37 100644 --- a/collects/scribblings/foreign/objc.scrbl +++ b/collects/scribblings/foreign/objc.scrbl @@ -23,7 +23,7 @@ The library supports Objective-C interaction in two layers. The upper layer provides syntactic forms for sending messages and deriving -subclasses. The lower layer is a think wrapper on the +subclasses. The lower layer is a thin wrapper on the @link["http://developer.apple.com/DOCUMENTATION/Cocoa/Reference/ObjCRuntimeRef/index.html"]{Objective-C runtime library} functions. Even the upper layer is unsafe and relatively low-level compared to normal Racket libraries, because diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 3b4397c158..d8647a2019 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -9,6 +9,11 @@ (lambda (stx) #'@racketidfont{_float*}))) +@(define-syntax-rule (defform-arrow . content) + (begin + (require (only-in (for-label ffi/unsafe) ->)) + (defidform -> . content))) + @title[#:tag "types" #:style 'toc]{C Types} @deftech{C types} are the main concept of the @tech{FFI}, either @@ -539,8 +544,8 @@ values: @itemize[ ]} -@defform/subs[#:literals (-> :: :) - (_fun fun-option ... maybe-args type-spec ... -> type-spec +@defform/subs[#:literals (->> :: :) + (_fun fun-option ... maybe-args type-spec ... ->> type-spec maybe-wrapper) ([fun-option (code:line #:abi abi-expr) (code:line #:save-errno save-errno-expr) @@ -557,7 +562,7 @@ values: @itemize[ (type-expr = value-expr) (id : type-expr = value-expr)] [maybe-wrapper code:blank - (code:line -> output-expr)])]{ + (code:line ->> output-expr)])]{ Creates a new function type. The @racket[_fun] form is a convenient syntax for the @racket[_cprocedure] type constructor. In its simplest @@ -568,7 +573,7 @@ straightforward function type. For instance, @racketblock[ -(_fun _int _string -> _int) +(_fun _int _string ->> _int) ] specifies a function that receives an integer and a @@ -599,7 +604,7 @@ labels, so if an argument is there is no need to use an expression. For example, @racketblock[ -(_fun (n s) :: (s : _string) (n : _int) -> _int) +(_fun (n s) :: (s : _string) (n : _int) ->> _int) ] specifies a function that receives an integer and a string, but the @@ -611,6 +616,12 @@ foreign function receives the string first.} Casts @racket[ptr-or-proc] to a function pointer of type @racket[fun-type].} +@defform-arrow{ + +A literal used in @racket[_fun] forms. (It's unfortunate that this +literal has the same name as @racket[->] from +@racketmodname[racket/contract], but it's a different binding.}} + @; ---------------------------------------------------------------------- @subsection[#:tag "foreign:custom-types"]{Custom Function Types} @@ -696,7 +707,7 @@ the @racket[_float] type. (syntax-id-rules (_float*) [(_float*) (type: _float pre: (x => (+ 0.0 x)))])) -(_fun _float* -> _bool)]} +(_fun _float* ->> _bool)]} @defidform[_?]{ @@ -748,8 +759,8 @@ following type: @racketblock[ (_fun (i : (_ptr o _int)) - -> (d : _double) - -> (values d i)) + ->> (d : _double) + ->> (values d i)) ] creates a function that calls the foreign function with a fresh @@ -957,7 +968,7 @@ work: @racketblock[ (define makeB (get-ffi-obj 'makeB "foo.so" - (_fun -> (_list-struct (_list-struct _int _byte) _int)))) + (_fun ->> (_list-struct (_list-struct _int _byte) _int)))) (makeB) (code:comment @#,t{should return @racket['((1 2) 3)]}) ] @@ -966,7 +977,7 @@ than the struct itself. The following works as expected: @racketblock[ (define makeB - (get-ffi-obj 'makeB "foo.so" (_fun -> _pointer))) + (get-ffi-obj 'makeB "foo.so" (_fun ->> _pointer))) (ptr-ref (makeB) (_list-struct (_list-struct _int _byte) _int)) ] @@ -978,7 +989,7 @@ define a type for @cpp{A} which makes it possible to use @cpp{makeA}: (define-cstruct #,(racketidfont "_A") ([x _int] [y _byte])) (define makeA (get-ffi-obj 'makeA "foo.so" - (_fun -> #,(racketidfont "_A-pointer")))) (code:comment @#,t{using @racketidfont{_A} is a memory-corrupting bug!}) + (_fun ->> #,(racketidfont "_A-pointer")))) (code:comment @#,t{using @racketidfont{_A} is a memory-corrupting bug!}) (define a (makeA)) (list a (A-x a) (A-y a)) (code:comment @#,t{produces an @racket[A] containing @racket[1] and @racket[2]}) @@ -989,7 +1000,7 @@ Using @cpp{gety} is also simple: @racketblock[ (define gety (get-ffi-obj 'gety "foo.so" - (_fun #,(racketidfont "_A-pointer") -> _byte))) + (_fun #,(racketidfont "_A-pointer") ->> _byte))) (gety a) (code:comment @#,t{produces @racket[2]}) ] @@ -1000,7 +1011,7 @@ using it: (define-cstruct #,(racketidfont "_B") ([a #,(racketidfont "_A")] [z _int])) (define makeB (get-ffi-obj 'makeB "foo.so" - (_fun -> #,(racketidfont "_B-pointer")))) + (_fun ->> #,(racketidfont "_B-pointer")))) (define b (makeB)) ] diff --git a/collects/scribblings/foreign/utils.rkt b/collects/scribblings/foreign/utils.rkt index b3e9b21bef..4c1776889b 100644 --- a/collects/scribblings/foreign/utils.rkt +++ b/collects/scribblings/foreign/utils.rkt @@ -5,15 +5,18 @@ scribble/decode (only-in "../inside/utils.rkt" cpp) (for-syntax racket/base) + scribble/racket (for-label racket/base racket/contract (except-in ffi/unsafe ->) ffi/unsafe/cvector - ffi/vector)) + ffi/vector + (only-in ffi/unsafe [-> ->>]))) (provide cpp InsideRacket InsideRacket-doc guide.scrbl + ->> (all-from-out scribble/manual) (for-label (all-from-out racket/base racket/contract @@ -28,3 +31,8 @@ (define guide.scrbl '(lib "scribblings/guide/guide.scrbl")) + +(define-syntax ->> + (make-element-id-transformer + (lambda (stx) + #'(racketlink ->> #:style "plainlink" (racketkeywordfont "->"))))) diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 5ae3a8d5e9..1f843b41ab 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -1213,9 +1213,10 @@ typewriter font with two leading @litchar{+}s).} See also @secref["base-links"]. -@defform[(racketlink id pre-content ...) - #:contracts ([id identifier?] - [pre-content pre-content?])]{ +@defform*[[(racketlink id #:style style-expr pre-content ...) + (racketlink id pre-content ...)] + #:contracts ([id identifier?] + [pre-content pre-content?])]{ An element where the @tech{decode}d @racket[pre-content] is hyperlinked to the definition of @racket[id].} diff --git a/collects/tests/racket/com-category.rkt b/collects/tests/racket/com-category.rkt new file mode 100644 index 0000000000..8fb8ce8076 --- /dev/null +++ b/collects/tests/racket/com-category.rkt @@ -0,0 +1,113 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/com) + +;; -------------------------------------------------- +;; Example from the documentation. +;; This test file is designed to load on all platforms, but interesting +;; tests run ony under Windows. + +; The function that uses COM interfaces defined further below: + +(define (show-all-classes) + (define ccm + (com-create-instance CLSID_StdComponentCategoriesMgr)) + (define icat (QueryInterface (com-object-get-iunknown ccm) + IID_ICatInformation + _ICatInformation-pointer)) + (define eci (EnumCategories icat LOCALE_SYSTEM_DEFAULT)) + (for ([catinfo (in-producer (lambda () (Next/ci eci)) #f)]) + (printf "~a:\n" + (cast (array-ptr (CATEGORYINFO-szDescription catinfo)) + _pointer + _string/utf-16)) + (define eg + (EnumClassesOfCategories icat (CATEGORYINFO-catid catinfo))) + (for ([guid (in-producer (lambda () (Next/g eg)) #f)]) + (printf " ~a\n" (or (clsid->progid guid) + (guid->string guid)))) + (Release eg)) + (Release eci) + (Release icat)) + +; The class to instantiate: + +(define CLSID_StdComponentCategoriesMgr + (string->clsid "{0002E005-0000-0000-C000-000000000046}")) + +; Some types and variants to match the specification: + +(define _ULONG _ulong) +(define _CATID _GUID) +(define _REFCATID _GUID-pointer) +(define-cstruct _CATEGORYINFO ([catid _CATID] + [lcid _LCID] + [szDescription (_array _short 128)])) + +; —— IEnumGUID ——- + +(define IID_IEnumGUID + (string->iid "{0002E000-0000-0000-C000-000000000046}")) + +(define-com-interface (_IEnumGUID _IUnknown) + ([Next/g (_mfun (_ULONG = 1) ; simplifed to just one + (guid : (_ptr o _GUID)) + (got : (_ptr o _ULONG)) + -> (r : _HRESULT) + -> (cond + [(zero? r) guid] + [(= r 1) #f] + [else (windows-error "Next/g failed" r)]))] + [Skip _fpointer] + [Reset _fpointer] + [Clone _fpointer])) + +; —— IEnumCATEGORYINFO ——- + +(define IID_IEnumCATEGORYINFO + (string->iid "{0002E011-0000-0000-C000-000000000046}")) + +(define-com-interface (_IEnumCATEGORYINFO _IUnknown) + ([Next/ci (_mfun (_ULONG = 1) ; simplifed to just one + (catinfo : (_ptr o _CATEGORYINFO)) + (got : (_ptr o _ULONG)) + -> (r : _HRESULT) + -> (cond + [(zero? r) catinfo] + [(= r 1) #f] + [else (windows-error "Next/ci failed" r)]))] + [Skip _fpointer] + [Reset _fpointer] + [Clone _fpointer])) + +; —— ICatInformation ——- + +(define IID_ICatInformation + (string->iid "{0002E013-0000-0000-C000-000000000046}")) + +(define-com-interface (_ICatInformation _IUnknown) + ([EnumCategories (_hmfun _LCID + (p : (_ptr o _IEnumCATEGORYINFO-pointer)) + -> EnumCategories p)] + [GetCategoryDesc (_hmfun _REFCATID _LCID + (p : (_ptr o _pointer)) + -> GetCategoryDesc + (begin0 + (cast p _pointer _string/utf-16) + (SysFreeString p)))] + [EnumClassesOfCategories (_hmfun (_ULONG = 1) ; simplifed + _REFCATID + (_ULONG = 0) ; simplifed + (_pointer = #f) + (p : (_ptr o + _IEnumGUID-pointer)) + -> EnumClassesOfCategories p) + #:release-with-function Release] + [IsClassOfCategories _fpointer] + [EnumImplCategoriesOfClass _fpointer] + [EnumReqCategoriesOfClass _fpointer])) + +; -------------------------------------------------- + +(when (eq? (system-type) 'windows) + (show-all-classes)) diff --git a/collects/tests/racket/com.rkt b/collects/tests/racket/com.rkt new file mode 100644 index 0000000000..e4e05b2bf9 --- /dev/null +++ b/collects/tests/racket/com.rkt @@ -0,0 +1,128 @@ +#lang racket/base +(require ffi/com + racket/system + setup/dirs) + +(define-syntax-rule (test expect expr) + (let ([val expr] + [ex expect]) + (unless (equal? ex val) + (error 'test "~s failed: ~e" 'expr val)) + (set! count (add1 count)))) + +(define count 0) + +(when (eq? 'windows (system-type)) + (system* (build-path (find-console-bin-dir) "MzCom.exe") + "/RegServer") + (define mzcom-progid (string-append "MzCOM.MzObj." (version))) + + (define a-guid-str "{abcdef00-1234-4321-9876-1234567890ab}") + (define another-guid-str "{0bcdef00-1234-4321-9876-1234567890ab}") + (define a-guid (string->guid a-guid-str)) + (test #t (guid? a-guid)) + (test #t (iid? a-guid)) + (test #t (clsid? a-guid)) + (test #t (guid=? a-guid (string->iid a-guid-str))) + (test #t (guid=? a-guid (string->clsid a-guid-str))) + (test #f (guid=? a-guid (string->iid another-guid-str))) + + (test #t (guid=? (string->clsid "{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}") + (progid->clsid mzcom-progid))) + (test mzcom-progid (clsid->progid (string->clsid "{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}"))) + + (define mzcom (com-create-instance mzcom-progid)) + (test #t (com-object? mzcom)) + (test #t (com-type? (com-object-type mzcom))) + (test #t (com-type=? (com-object-type mzcom) + (com-object-type mzcom))) + (test #t (guid=? (progid->clsid mzcom-progid) (com-object-clsid mzcom))) + (test (void) (com-object-set-clsid! mzcom (progid->clsid mzcom-progid))) + (test #t (com-object-eq? mzcom mzcom)) + (test '("About" "Eval" "Reset") (com-methods mzcom)) + (test '("About" "Eval" "Reset") (com-methods (com-object-type mzcom))) + (test '(-> () void) (com-method-type mzcom "About")) + (test '(-> () void) (com-method-type (com-object-type mzcom) "About")) + (test '(-> () void) (com-method-type mzcom "Reset")) + (test '(-> (string) string) (com-method-type mzcom "Eval")) + (test "3" (com-invoke mzcom "Eval" "(+ 1 2)")) + + (test '() (com-get-properties mzcom)) + (test '() (com-get-properties (com-object-type mzcom))) + (test '() (com-set-properties mzcom)) + (test '() (com-set-properties (com-object-type mzcom))) + + (test '("SchemeError") (com-events mzcom)) + (test '("SchemeError") (com-events (com-object-type mzcom))) + (test #f (com-event-type mzcom "SchemeError")) + (test #f (com-event-type (com-object-type mzcom) "SchemeError")) + (define recved #f) + (define exec (com-make-event-executor)) + (test #t (com-event-executor? exec)) + (test (void) (com-register-event-callback mzcom "SchemeError" + (lambda (msg) (set! recved msg)) + exec)) + (test #f (sync/timeout 0 exec)) + (test #t (with-handlers ([exn:fail? (lambda (exn) + (regexp-match? #rx"COM object exception" + (exn-message exn)))]) + (com-invoke mzcom "Eval" "bad"))) + (test #f recved) + (test (void) (com-unregister-event-callback mzcom "SchemeError")) + (test (void) ((sync exec))) + (test #t (regexp-match? #rx"bad" recved)) + + (test #f (com-iunknown? mzcom)) + (test #t (com-iunknown? (com-object-get-iunknown mzcom))) + (test #t (com-iunknown? (com-object-get-idispatch mzcom))) + (test #f (com-idispatch? mzcom)) + (test #t (com-idispatch? (com-object-get-idispatch mzcom))) + + (test (void) (com-release mzcom)) + + (define (with-fail-to-no thunk) + (with-handlers ([exn:fail? (lambda (exn) + (and (regexp-match #rx"released" (exn-message exn)) + 'no))]) + (thunk))) + (test 'no (with-fail-to-no (lambda () (com-invoke mzcom "About")))) + (test 'no (with-fail-to-no (lambda () (com-methods mzcom)))) + (test 'no (with-fail-to-no (lambda () (com-events mzcom)))) + + (test com-omit com-omit) + + (let ([c (make-custodian)]) + (define mzcom2 + (parameterize ([current-custodian c]) + (com-create-instance mzcom-progid))) + (test '("About" "Eval" "Reset") (com-methods mzcom2)) + (custodian-shutdown-all c) + (test 'no (with-handlers ([exn:fail? (lambda (exn) + (and (regexp-match #rx"released" (exn-message exn)) + 'no))]) + (com-invoke mzcom2 "About")))) + + (define ie (com-create-instance "InternetExplorer.Application.1")) + (test #t (and (member "Visible" (com-get-properties ie)) #t)) + (test #t (and (member "Visible" (com-set-properties ie)) #t)) + (test #f (com-get-property ie "Visible")) + (test (void) (com-set-property! ie "Visible" #t)) + (test #t (com-get-property ie "Visible")) + (test (void) (com-set-property! ie "Visible" #f)) + (test #f (com-get-property ie "Container")) + (test (void) (com-invoke ie "Navigate" (format "file://~a" + (build-path (find-doc-dir) "index.html")))) + + (define doc (com-get-property ie "Document")) + (test #t (com-object? doc)) + (test "Racket Documentation" (com-get-property ie "Document" "title")) + (test (void) (com-set-property! ie "Document" "title" "The Racket Documentation")) + (test "The Racket Documentation" (com-get-property ie "Document" "title")) + (test '(-> () string) (com-get-property-type doc "title")) + (test '(-> (string) void) (com-set-property-type doc "title")) + + (test (void) (com-release ie)) + + (void)) + +(printf "~a passed\n" count)