basis/windows/com/com-tests.factor

   1 USING: kernel windows.com windows.com.syntax windows.ole32
   2 alien alien.syntax tools.test libc alien.c-types
   3 namespaces arrays continuations accessors math windows.com.wrapper
   4 windows.com.wrapper.private destructors effects ;
   5 IN: windows.com.tests
   6
   7 COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
   8     HRESULT returnOK ( )
   9     HRESULT returnError ( ) ;
  10
  11 COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
  12     int getX ( )
  13     void setX ( int newX ) ;
  14
  15 COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
  16     int xPlus ( int y )
  17     int xMulAdd ( int mul, int add ) ;
  18
  19 { GUID: {216fb341-0eb2-44b1-8edb-60b76e353abc} } [ ISimple-iid ] unit-test
  20 { GUID: {9620ecec-8438-423b-bb14-86f835aa40dd} } [ IInherited-iid ] unit-test
  21 { GUID: {00000000-0000-0000-C000-000000000046} } [ IUnknown-iid ] unit-test
  22 { GUID: {b06ac3f4-30e4-406b-a7cd-c29cead4552c} } [ IUnrelated-iid ] unit-test
  23
  24 { (( -- iid )) } [ \ ISimple-iid stack-effect ] unit-test
  25 { (( this -- HRESULT )) } [ \ ISimple::returnOK stack-effect ] unit-test
  26 { (( this -- int )) } [ \ IInherited::getX stack-effect ] unit-test
  27 { (( this newX -- )) } [ \ IInherited::setX stack-effect ] unit-test
  28 { (( this mul add -- int )) } [ \ IUnrelated::xMulAdd stack-effect ] unit-test
  29
  30 SYMBOL: +test-wrapper+
  31 SYMBOL: +guinea-pig-implementation+
  32 SYMBOL: +orig-wrapped-objects+
  33
  34 +wrapped-objects+ get-global clone +orig-wrapped-objects+ set-global
  35
  36 TUPLE: test-implementation x ;
  37 C: <test-implementation> test-implementation
  38
  39 {
  40     { "IInherited" {
  41         [ drop S_OK ] ! ISimple::returnOK
  42         [ drop E_FAIL ] ! ISimple::returnError
  43         [ x>> ] ! IInherited::getX
  44         [ >>x drop ] ! IInherited::setX
  45     } }
  46     { "IUnrelated" {
  47         [ swap x>> + ] ! IUnrelated::xPlus
  48         [ spin x>> * + ] ! IUnrelated::xMulAdd
  49     } }
  50 } <com-wrapper>
  51 dup +test-wrapper+ set [
  52
  53     0 <test-implementation> swap com-wrap
  54     dup +guinea-pig-implementation+ set [ drop
  55
  56         S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
  57         E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
  58         20 1array [
  59             +guinea-pig-implementation+ get
  60             [ 20 IInherited::setX ]
  61             [ IInherited::getX ] bi
  62         ] unit-test
  63         420 1array [
  64             +guinea-pig-implementation+ get
  65             IUnrelated-iid com-query-interface
  66             [ 20 20 IUnrelated::xMulAdd ] with-com-interface
  67         ] unit-test
  68         40 1array [
  69             +guinea-pig-implementation+ get
  70             IUnrelated-iid com-query-interface
  71             [ 20 IUnrelated::xPlus ] with-com-interface
  72         ] unit-test
  73
  74         +guinea-pig-implementation+ get 1array [
  75             +guinea-pig-implementation+ get com-add-ref
  76         ] unit-test
  77
  78         { } [ +guinea-pig-implementation+ get com-release ] unit-test
  79
  80         +guinea-pig-implementation+ get 1array [
  81             +guinea-pig-implementation+ get IUnknown-iid com-query-interface
  82             dup com-release
  83         ] unit-test
  84         +guinea-pig-implementation+ get 1array [
  85             +guinea-pig-implementation+ get ISimple-iid com-query-interface
  86             dup com-release
  87         ] unit-test
  88         "void*" heap-size +guinea-pig-implementation+ get <displaced-alien>
  89         +guinea-pig-implementation+ get
  90         2array [
  91             +guinea-pig-implementation+ get IUnrelated-iid com-query-interface
  92             dup ISimple-iid com-query-interface
  93             over com-release dup com-release
  94         ] unit-test
  95
  96     ] with-com-interface
  97
  98 ] with-disposal
  99
 100 ! Ensure that we freed +guinea-pig-implementation
 101 +orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test