suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add ffi/com', ffi/unsafe/com'

Browse Source
This commit is contained in:
Matthew Flatt 2011-12-31 10:08:30 -07:00
parent 5736695bae
commit ff41a896bc
16 changed files with 3483 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

185
collects/ffi/com-registry.rkt Normal file
View File

@ -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-ci<?)])
(cond
[(null? l) null]
[(null? (cdr l)) l]
[(string-ci=? (car l) (cadr l))
(loop (cdr l))]
[else (cons (car l) (loop (cdr l)))])))
(define (coclass->clsid 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))

26
collects/ffi/com.rkt Normal file
View File

@ -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?)

1788
collects/ffi/unsafe/com.rkt Normal file
View File

File diff suppressed because it is too large Load Diff

335
collects/ffi/unsafe/private/win32.rkt Normal file
View File

@ -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))

13
collects/scribble/private/manual-scheme.rkt
View File

@ -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)]))

464
collects/scribblings/foreign/com-auto.scrbl Normal file
View File

@ -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.}

7
collects/scribblings/foreign/com-common.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(require scribble/base)
(provide cpp)
(define cpp tt)

328
collects/scribblings/foreign/com-intf.scrbl Normal file
View File

@ -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]))
]

62
collects/scribblings/foreign/com.scrbl Normal file
View File

@ -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"]

1
collects/scribblings/foreign/derived.scrbl
View File

@ -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"]

2
collects/scribblings/foreign/objc.scrbl
View File

@ -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

37
collects/scribblings/foreign/types.scrbl
View File

@ -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))
]

10
collects/scribblings/foreign/utils.rkt
View File

@ -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 "->")))))

7
collects/scribblings/scribble/manual.scrbl
View File

@ -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].}

113
collects/tests/racket/com-category.rkt Normal file
View File

@ -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))

128
collects/tests/racket/com.rkt Normal file
View File

@ -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)