Unit tests for COM callbacks
Joe Groff
parent
11d28109cf
commit
5d6720f991
|
|
@ -1,10 +1,8 @@
|
|||
USING: kernel windows.com windows.com.syntax windows.ole32
|
||||
alien alien.syntax tools.test libc alien.c-types arrays.lib
|
||||
namespaces arrays continuations ;
|
||||
namespaces arrays continuations accessors ;
|
||||
IN: windows.com.tests
|
||||
|
||||
! Create some test COM interfaces
|
||||
|
||||
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
|
||||
HRESULT returnOK ( )
|
||||
HRESULT returnError ( ) ;
|
||||
|
|
@ -13,72 +11,43 @@ COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
|
|||
int getX ( )
|
||||
void setX ( int newX ) ;
|
||||
|
||||
! Implement the IInherited interface in factor using alien-callbacks
|
||||
|
||||
C-STRUCT: test-implementation
|
||||
{ "void*" "vtbl" }
|
||||
{ "int" "x" } ;
|
||||
|
||||
: QueryInterface-callback
|
||||
"HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ]
|
||||
alien-callback ;
|
||||
: AddRef-callback
|
||||
"ULONG" { "void*" } "stdcall" [ drop 2 ]
|
||||
alien-callback ;
|
||||
: Release-callback
|
||||
"ULONG" { "void*" } "stdcall" [ drop 1 ]
|
||||
alien-callback ;
|
||||
: returnOK-callback
|
||||
"HRESULT" { "void*" } "stdcall" [ drop S_OK ]
|
||||
alien-callback ;
|
||||
: returnError-callback
|
||||
"HRESULT" { "void*" } "stdcall" [ drop E_FAIL ]
|
||||
alien-callback ;
|
||||
: getX-callback
|
||||
"int" { "void*" } "stdcall" [ test-implementation-x ]
|
||||
alien-callback ;
|
||||
: setX-callback
|
||||
"void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ]
|
||||
alien-callback ;
|
||||
|
||||
SYMBOL: +test-implementation-vtbl+
|
||||
SYMBOL: +guinea-pig-implementation+
|
||||
|
||||
: (make-test-implementation) ( x imp -- imp )
|
||||
[ set-test-implementation-x ] keep
|
||||
+test-implementation-vtbl+ get over set-test-implementation-vtbl ;
|
||||
|
||||
: <test-implementation> ( x -- imp )
|
||||
"test-implementation" <c-object> (make-test-implementation) ;
|
||||
|
||||
: <malloced-test-implementation> ( x -- imp )
|
||||
"test-implementation" heap-size malloc (make-test-implementation) ;
|
||||
|
||||
QueryInterface-callback
|
||||
AddRef-callback
|
||||
Release-callback
|
||||
returnOK-callback
|
||||
returnError-callback
|
||||
getX-callback
|
||||
setX-callback
|
||||
7 narray >c-void*-array
|
||||
dup byte-length [
|
||||
[ byte-array>memory ] keep
|
||||
+test-implementation-vtbl+ set
|
||||
|
||||
! Test that the words defined by COM-INTERFACE: do their magic
|
||||
COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
|
||||
int xPlus ( int y )
|
||||
int xMulAdd ( int mul, int add ) ;
|
||||
|
||||
"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
|
||||
"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
|
||||
"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
|
||||
S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
|
||||
E_FAIL <long> *long 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
|
||||
1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
|
||||
|
||||
! Test that the helper functions for QueryInterface, AddRef, Release work
|
||||
SYMBOL: +test-vtbl+
|
||||
SYMBOL: +guinea-pig-implementation+
|
||||
|
||||
TUPLE: test-implementation x ;
|
||||
C: test-implementation <test-implementation>
|
||||
|
||||
{
|
||||
{ "IInherited" {
|
||||
[ drop S_OK ] ! ISimple::returnOK
|
||||
[ drop E_FAIL ] ! ISimple::returnError
|
||||
[ x>> ] ! IInherited::getX
|
||||
[ >>x drop ] ! IInherited::setX
|
||||
} }
|
||||
{ "IUnrelated" {
|
||||
[ swap x>> + ] ! IUnrelated::xPlus
|
||||
[ spin x>> * + ] ! IUnrealted::xMulAdd
|
||||
} }
|
||||
} <com-vtbl>
|
||||
dup +test-vtbl+ set [
|
||||
|
||||
0 <test-implementation> +test-vtbl+ get com-wrap
|
||||
dup +guinea-pig-implementation+ set [
|
||||
|
||||
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
|
||||
E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
|
||||
20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test
|
||||
420 1array [ +guinea-pig-implementation+ get 20 20 IUnrelated::xMulAdd ] unit-test
|
||||
40 1array [ +guinea-pig-implementation+ get 20 IUnrelated::xPlus ] unit-test
|
||||
|
||||
0 <malloced-test-implementation> +guinea-pig-implementation+ set
|
||||
[
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get com-add-ref
|
||||
] unit-test
|
||||
|
|
@ -88,6 +57,13 @@ dup byte-length [
|
|||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get IUnknown-iid com-query-interface
|
||||
] unit-test
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get ISimple-iid com-query-interface
|
||||
] unit-test
|
||||
"void*" heap-size +guinea-pig-implementation+ get <displaced-alien> 1array [
|
||||
+guinea-pig-implementation+ get IUnrelated-iid com-query-interface
|
||||
] unit-test
|
||||
|
||||
] [ +guinea-pig-implementation+ get free ] [ ] cleanup
|
||||
] with-malloc
|
||||
] with-com-interface
|
||||
|
||||
] [ free-com-vtbl ] [ ] cleanup
|
||||
|
|
|
|||
Loading…
Reference in New Issue