paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 08:09:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

tests: test arguments passing for dispinterfaces

Browse Source 
git-svn-id: trunk@14784 -
This commit is contained in:
paul 2010-01-23 19:46:11 +00:00
parent 8511a3e1e4
commit d08508419d
1 changed files with 32 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
tests/test/tdispinterface2.pp
View File

@ -16,22 +16,40 @@ type
property Disp1: integer;
procedure Disp2;
property Disp402: wordbool dispid 402;
procedure DispArg1(Arg: IUnknown);
procedure DispArg2(Arg: IDispatch);
procedure DispArg3(var Arg: wordbool);
end;
var
cur_dispid: longint;
cur_argtype: 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 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);
end;
{$HINTS ON}
var
II: IIE;
B: wordbool;
begin
// check dispid values
DispCallByIDProc := @DoDispCallByID;
cur_dispid := 300;
II.Disp300;
@ -41,4 +59,13 @@ begin
II.Disp2;
cur_dispid := 402;
II.Disp402 := True;
// check arguments
DispCallByIDProc := @DoDispCallByIDArg;
cur_argtype := varunknown;
II.DispArg1(nil);
cur_argtype := vardispatch;
II.DispArg2(nil);
cur_argtype := varboolean or $80;
B := False;
II.DispArg3(B);
end.