From 5d6720f9916e7d1ada9bad5b38a0802368f6edca Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 21 Mar 2008 20:36:24 -0700 Subject: [PATCH] Unit tests for COM callbacks --- extra/windows/com/com-tests.factor | 162 ++++++++++++----------------- 1 file changed, 69 insertions(+), 93 deletions(-) diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor index 4a2f465fef..4c62e7adfd 100644 --- a/extra/windows/com/com-tests.factor +++ b/extra/windows/com/com-tests.factor @@ -1,93 +1,69 @@ -USING: kernel windows.com windows.com.syntax windows.ole32 -alien alien.syntax tools.test libc alien.c-types arrays.lib -namespaces arrays continuations ; -IN: windows.com.tests - -! Create some test COM interfaces - -COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} - HRESULT returnOK ( ) - HRESULT returnError ( ) ; - -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 ; - -: ( x -- imp ) - "test-implementation" (make-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 - - "{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 ISimple::returnOK ] unit-test - E_FAIL *long 1array [ 0 ISimple::returnError ] unit-test - 1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test - - ! Test that the helper functions for QueryInterface, AddRef, Release work - - 0 +guinea-pig-implementation+ set - [ - +guinea-pig-implementation+ get 1array [ - +guinea-pig-implementation+ get com-add-ref - ] unit-test - - { } [ +guinea-pig-implementation+ get com-release ] unit-test - - +guinea-pig-implementation+ get 1array [ - +guinea-pig-implementation+ get IUnknown-iid com-query-interface - ] unit-test - - ] [ +guinea-pig-implementation+ get free ] [ ] cleanup -] with-malloc +USING: kernel windows.com windows.com.syntax windows.ole32 +alien alien.syntax tools.test libc alien.c-types arrays.lib +namespaces arrays continuations accessors ; +IN: windows.com.tests + +COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} + HRESULT returnOK ( ) + HRESULT returnError ( ) ; + +COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} + int getX ( ) + void setX ( int newX ) ; + +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 + +SYMBOL: +test-vtbl+ +SYMBOL: +guinea-pig-implementation+ + +TUPLE: test-implementation x ; +C: 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 + } } +} +dup +test-vtbl+ set [ + + 0 +test-vtbl+ get com-wrap + dup +guinea-pig-implementation+ set [ + + S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test + E_FAIL *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 + + +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get com-add-ref + ] unit-test + + { } [ +guinea-pig-implementation+ get com-release ] unit-test + + +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 1array [ + +guinea-pig-implementation+ get IUnrelated-iid com-query-interface + ] unit-test + + ] with-com-interface + +] [ free-com-vtbl ] [ ] cleanup