blob: 8c44d65e03928e653ec1d00ff19d24d5aa0f8f2e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
{ %TARGET=win32,win64,wince}
program tdispinterface2;
{$ifdef fpc}
{$mode objfpc}
{$endif}
uses
Variants;
type
{ IIE }
IIE = dispinterface
['{0002DF05-0000-0000-C000-000000000046}']
procedure Disp300; dispid 300;
property Disp1: integer;
procedure Disp2;
property Disp402: wordbool dispid 402;
procedure DispArg1(Arg: IUnknown);
procedure DispArg2(Arg: IDispatch);
function DispArg3(var Arg: wordbool): widestring;
property DispProp[index: OleVariant]: Integer;
end;
var
cur_dispid: longint;
cur_argtype: byte;
cur_restype: byte;
cur_calltype: byte;
{$HINTS OFF}
procedure DoDispCallByID(res: Pointer; const disp: IDispatch; desc: PDispDesc;
params: Pointer);
begin
if desc^.dispid <> cur_dispid then
halt(cur_dispid);
end;
procedure DoDispCallByIDArg(res: Pointer; const disp: IDispatch; desc: PDispDesc;
params: Pointer);
begin
if desc^.calldesc.argcount <> 1 then
halt(4);
if desc^.calldesc.argtypes[0] <> cur_argtype then
halt(cur_argtype);
if desc^.restype <> cur_restype then
halt($FF);
end;
procedure DoDispCallByIDProp(res: Pointer; const disp: IDispatch; desc: PDispDesc;
params: Pointer);
begin
if desc^.calldesc.calltype <> cur_calltype then
halt(5);
// put: arg #0 is value, arg #1 is index (in Delphi: vice-versa)
// get: arg #0 is index
if desc^.calldesc.argtypes[ord(cur_calltype=4)] <> cur_argtype then
halt(6);
if cur_calltype=4 then
begin
if desc^.calldesc.argcount <> 2 then
halt(7);
if desc^.calldesc.argtypes[0] <> cur_restype then
halt(8);
if desc^.restype <> 0 then
halt(9);
end;
end;
{$HINTS ON}
var
II: IIE;
B: wordbool;
begin
// check dispid values
writeln('Testing dispid values...');
DispCallByIDProc := @DoDispCallByID;
cur_dispid := 300;
II.Disp300;
cur_dispid := 1;
II.Disp1 := 1;
cur_dispid := 2;
II.Disp2;
cur_dispid := 402;
II.Disp402 := True;
// check arguments
writeln('Testing arguments...');
DispCallByIDProc := @DoDispCallByIDArg;
cur_restype := varempty;
cur_argtype := varunknown;
II.DispArg1(nil);
cur_argtype := vardispatch;
II.DispArg2(nil);
cur_restype := varolestr;
cur_argtype := varboolean or $80;
B := False;
II.DispArg3(B);
writeln('Testing properties...');
DispCallByIDProc := @DoDispCallByIDProp;
cur_calltype := 2; // propertyget
cur_argtype := varvariant;
cur_restype := varinteger;
II.DispProp[1];
II.DispProp['abc'];
cur_calltype := 4; // propertyput
II.DispProp[1] := 11;
II.DispProp['abc'] := 12;
end.
|
