fpc/tests/test/testihr.pp

{ %CPU=wasm32 }
{$mode objfpc}
{$H+}
{$Interfaces CORBA}
uses typinfo, sysutils;

{
  Test for invoke helper generated by compiler in combination with CallInvokeHelper from Typinfo unit.
  Test using COM interface
}

Type

  {$M+}
  I1 = interface ['{76DC0D03-376C-45AA-9E0C-B3546B0C7208}']
    Procedure T2(a : Integer);
    Function T3(a : Integer) : Integer;
    procedure T4(var a : integer);
    procedure T5(s : ansistring);
    procedure T6(var s : ansistring);
    procedure T7(sar : array of ansistring);
  end;
  
  TT1 = Class(TObject,I1)
  Protected
    Procedure T2(a : Integer);
    Function T3(a : Integer) : Integer;
    procedure T4(var a : integer);
    procedure T5(s : ansistring);
    procedure T6(var s : ansistring);
    procedure T7(sar : array of ansistring);
  Published
    Procedure Test;  
  end;

  { TTestInvokeHelper }

  TTestInvokeHelper = class
  Public
    FTest : string;
    C : TT1;
    I : I1;
    TI : PTypeInfo;
    function GetInterfaceAsPtr: Pointer;
    Procedure Fail(const S : String);
    Procedure AssertEquals(Msg : string; aExpect,aActual : Integer);
    Procedure AssertEquals(Msg : string; aExpect,aActual : Ansistring);
    Procedure AssertTrue(Msg : string; aValue : Boolean);
    Procedure AssertNotNull(Msg : string; aValue : Pointer);
    procedure StartTest(const aName : string);
    Constructor Create;
    Destructor destroy; override;
  Published
    Procedure DoTest2;
    Procedure DoTest3;
    Procedure DoTest4;
    Procedure DoTest5;
    Procedure DoTest6;
    Procedure DoTest7;
  end;
  
var
  sa : Integer;  
  ss : ansistring;
  ssa : array of ansistring;
  
Procedure TT1.T2(a : Integer);

begin
  Writeln('in T2');
  sa:=a;
end;

Function TT1.T3(a : Integer) : Integer;

begin
  Writeln('in t3');
  result:=a;
end;

  
Procedure TT1.Test;

begin
  Writeln('This is a test');  
end;  

procedure TT1.T4(var a : integer);

begin
  writeln('in t4');
  sa:=a;
  a:=321;
end;

procedure TT1.T5(s : ansistring);
begin 
  Writeln('In T5');
  ss:=s;
end;

procedure TT1.T6(var s : ansistring);

begin
  ss:=s;
  Writeln('In t6 : ',S);
  S:='more testing';
end;

procedure TT1.T7(sar : array of ansistring);
 
var
  I : Integer;
 
begin
  writeln('T7');
  setlength(ssa,length(sar));
  for i:=0 to Length(sar)-1 do
    ssa[i]:=sar[i];
end;

procedure TTestInvokeHelper.AssertEquals(Msg: string; aExpect, aActual: Integer);
begin
  AssertTrue(Msg+': '+IntToStr(aExpect)+'<>'+IntToStr(aActual),aExpect=aActual);
end;

procedure TTestInvokeHelper.AssertEquals(Msg: string; aExpect,
  aActual: Ansistring);
begin
  AssertTrue(Msg+': "'+aExpect+'" <> "'+aActual+'"',aExpect=aActual);
end;

procedure TTestInvokeHelper.AssertTrue(Msg: string; aValue: Boolean);
begin
  if not aValue then
    Fail(' failed: '+Msg);
end;

procedure TTestInvokeHelper.AssertNotNull(Msg: string; aValue: Pointer);
begin
  AssertTrue(Msg+': not null',Assigned(aValue));
end;

procedure TTestInvokeHelper.StartTest(const aName: string);
begin
  FTest:=aName;
  I:=Nil;
end;

constructor TTestInvokeHelper.Create;
begin
  TI:=TypeInfo(I1);
  C:=Nil;
end;

destructor TTestInvokeHelper.destroy;
begin
  FreeAndNil(C);
  inherited destroy;
end;


function TTestInvokeHelper.GetInterfaceAsPtr: Pointer;

begin
  // Clear previous
  I:=Nil;
  FreeAndNil(C);
  C:=TT1.Create;
  if Not Supports(C,I1,I) then
    Fail('No I1');
  Result:=Pointer(I);
end;

procedure TTestInvokeHelper.Fail(const S : String);

begin
  Writeln(FTest,' '+S);
  Halt(1);
end;
  

procedure TTestInvokeHelper.DoTest2;

var
  a : Integer;
  args : Array of pointer;
  
begin
  StartTest('DoTest2');
  A:=123;
  Setlength(Args,2);
  Args[0]:=Nil;
  Args[1]:=@A;
  CallInvokeHelper(TI,GetInterfaceAsPtr,'T2',PPointer(Args));
  AssertEquals('Value passed',A,sa);
end;

procedure TTestInvokeHelper.DoTest3;

var
  a,ra : Integer;
  args : Array of pointer;

begin
  StartTest('DoTest3');
  A:=123;
  Setlength(Args,2);
  Args[0]:=@RA;
  Args[1]:=@A;
  CallInvokeHelper(TI,GetInterfaceAsPtr,'T3',PPointer(Args));
  AssertEquals('Return result',A,Ra);
end;

procedure TTestInvokeHelper.DoTest4;

var
  a : Integer;
  args : Array of pointer;
  
begin
  StartTest('DoTest4');
  A:=123;
  Setlength(Args,2);
  Args[0]:=Nil;
  Args[1]:=@A;
  CallInvokeHelper(TI,GetInterfaceAsPtr,'T4',PPointer(Args));
  AssertEquals('Value passed',123,sa);
  AssertEquals('Value returned',321,A);
end;

procedure TTestInvokeHelper.DoTest5;

var
  s : ansistring;
  args : Array of pointer;
  
begin
  StartTest('DoTest5');
  s:='123';
  Setlength(Args,2);
  Args[0]:=Nil;
  Args[1]:=@S;
  CallInvokeHelper(TI,GetInterfaceAsPtr,'T5',PPointer(Args));
  AssertEquals('Value passed',s,ss);
end;

procedure TTestInvokeHelper.DoTest6;

var
  s : ansistring;
  args : Array of pointer;
  
begin
  StartTest('DoTest6');
  s:='123';
  Setlength(Args,2);
  Args[0]:=Nil;
  Args[1]:=@S;
  CallInvokeHelper(TI,GetInterfaceAsPtr,'T6',PPointer(Args));
  AssertEquals('Value passed','123',ss);
  AssertEquals('Value returned','more testing',s);
end;

procedure TTestInvokeHelper.DoTest7;

var
  sar : array of ansistring;
  args : Array of pointer;
  
begin
  StartTest('DoTest7');
  setlength(sar,3);
  sar[0]:='123';
  sar[1]:='456';
  sar[2]:='789';
  Setlength(Args,2);
  Args[0]:=Nil;
  Args[1]:=@Sar;
  CallInvokeHelper(TI,GetInterfaceAsPTR,'T7',PPointer(Args));
  AssertEquals('Length value passed',3,length(ssa));
  AssertEquals('Value 0 passed','123',ssa[0]);
  AssertEquals('Value 1 passed','456',ssa[1]);
  AssertEquals('Value 2 passed','789',ssa[2]);
end;
  

begin
  With TTestInvokeHelper.Create do
    try
      DoTest2;
      DoTest3;
      DoTest4;
      DoTest5;
      DoTest6;
      DoTest7;
      Writeln('All OK');
    finally
      Free;
    end;   
end.