Selaa lähdekoodia

* add tests for TVirtualInterface

git-svn-id: trunk@42089 -
svenbarth 6 vuotta sitten
vanhempi
commit
1d6b591872
1 muutettua tiedostoa jossa 259 lisäystä ja 0 poistoa
  1. 259 0
      packages/rtl-objpas/tests/tests.rtti.impl.pas

+ 259 - 0
packages/rtl-objpas/tests/tests.rtti.impl.pas

@@ -28,12 +28,16 @@ type
     ResultValue: TValue;
     InOutMapping: array of SizeInt;
     InputUntypedTypes: array of PTypeInfo;
+    InvokedMethodName: String;
 
+    procedure OnHandleIntfMethod(aMethod: TRttiMethod; const aArgs: TValueArray; out aResult: TValue);
+    procedure DoIntfImpl(aIntf: IInterface; aTypeInfo: PTypeInfo; aIndex: LongInt; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
 {$ifdef fpc}
     procedure OnHandleInvokable(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue);
     procedure DoMethodImpl(aTypeInfo: PTypeInfo; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
     procedure DoProcImpl(aTypeInfo: PTypeInfo; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
 {$ifndef InLazIDE}
+    {$ifdef fpc}generic{$endif} procedure GenDoIntfImpl<T: IInterface>(aIntf: T; aIndex: LongInt; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
     {$ifdef fpc}generic{$endif} procedure GenDoMethodImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
     {$ifdef fpc}generic{$endif} procedure GenDoProcImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
 {$endif}
@@ -43,6 +47,7 @@ type
     procedure Status(const aMsg: String; const aArgs: array of const); inline;
 {$endif}
   published
+    procedure TestIntfMethods;
 {$ifdef fpc}
     procedure TestMethodVars;
     procedure TestProcVars;
@@ -52,6 +57,34 @@ type
 implementation
 
 type
+  {$push}
+  {$M+}
+  ITestInterface = interface
+    ['{1DE799BB-BEE9-405F-9AF3-D55DE978C793}']
+    procedure TestMethod1;
+    function  TestMethod2(aArg1: SizeInt): SizeInt;
+    procedure TestMethod3(aArg1: AnsiString);
+    procedure TestMethod4(aArg1: ShortString);
+    function  TestMethod5: AnsiString;
+    function  TestMethod6: ShortString;
+    procedure TestMethod7(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: SizeInt);
+    procedure TestMethod8(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: AnsiString);
+    procedure TestMethod9(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: ShortString);
+    procedure TestMethod10(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Single);
+    procedure TestMethod11(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Double);
+    procedure TestMethod12(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Extended);
+    procedure TestMethod13(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Comp);
+    procedure TestMethod14(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Currency);
+    function  TestMethod15(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
+    function  TestMethod16(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
+    function  TestMethod17(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
+    function  TestMethod18(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
+    function  TestMethod19(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
+    function  TestMethod20(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
+    procedure TestMethod21(var aArg1; out aArg2; const aArg3; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4);
+  end;
+  {$pop}
+
   TTestMethod1 = procedure of object;
   TTestMethod2 = function(aArg1: SizeInt): SizeInt of object;
   TTestMethod3 = procedure(aArg1: AnsiString) of object;
@@ -210,6 +243,110 @@ begin
 end;
 {$endif}
 
+procedure TTestImpl.OnHandleIntfMethod(aMethod: TRttiMethod; const aArgs: TValueArray; out aResult: TValue);
+var
+  selfofs, i: SizeInt;
+  name: String;
+begin
+  selfofs := 1;
+
+  Status('In Callback');
+  InvokedMethodName :=  aMethod.Name;
+  Status('Self: ' + HexStr(Self));
+  if Assigned(aMethod.ReturnType) then
+    aResult := CopyValue(ResultValue);
+  Status('Setting input args');
+  SetLength(InputArgs, Length(aArgs));
+  for i := 0 to High(aArgs) do begin
+    Status('Arg %d: %p %p', [i, aArgs[i].GetReferenceToRawData, PPointer(aArgs[i].GetReferenceToRawData)^]);
+    if Assigned(InputUntypedTypes[i]) then
+      TValue.Make(PPointer(aArgs[i].GetReferenceToRawData)^, InputUntypedTypes[i], InputArgs[i])
+    else
+      InputArgs[i] := CopyValue(aArgs[i]);
+  end;
+  Status('Setting output args');
+  { Note: account for Self }
+  for i := 0 to High(InOutMapping) do begin
+    Status('OutputArg %d -> Arg %d', [i, InOutMapping[i] + selfofs]);
+    { check input arg type? }
+    Move(OutputArgs[i].GetReferenceToRawData^, aArgs[InOutMapping[i] + selfofs].GetReferenceToRawData^, OutputArgs[i].DataSize);
+  end;
+  Status('Callback done');
+end;
+
+procedure TTestImpl.DoIntfImpl(aIntf: IInterface; aTypeInfo: PTypeInfo; aIndex: LongInt; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+var
+  context: TRttiContext;
+  t: TRttiType;
+  instance, res: TValue;
+  method: TRttiMethod;
+  i: SizeInt;
+  input: array of TValue;
+  intf: TRttiInterfaceType;
+  mrec: TMethod;
+  name: String;
+  params: array of TRttiParameter;
+begin
+  name := 'TestMethod' + IntToStr(aIndex);
+
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(aTypeInfo);
+    Check(t is TRttiInterfaceType, 'Not a interface type: ' + aTypeInfo^.Name);
+    intf := t as TRttiInterfaceType;
+
+    method := intf.GetMethod(name);
+    Check(Assigned(method), 'Method not found: ' + name);
+
+    Status('Executing method %s', [name]);
+
+    CheckEquals(Length(aOutputArgs), Length(aInOutMapping), 'Invalid in/out mapping');
+    Check(Length(aOutputArgs) <= Length(aInputArgs), 'Output args not part of input args');
+
+    params := method.GetParameters;
+
+    TValue.Make(@aIntf, aTypeInfo, instance);
+
+    { arguments might be modified by Invoke (Note: Copy() does not uniquify the
+      IValueData of managed types) }
+    SetLength(input, Length(aInputArgs) + 1);
+    SetLength(InputUntypedTypes, Length(aInputArgs) + 1);
+    input[0] := instance;
+    InputUntypedTypes[0] := Nil;
+    for i := 0 to High(aInputArgs) do begin
+      input[i + 1] := CopyValue(aInputArgs[i]);
+      if not Assigned(params[i].ParamType) then
+        InputUntypedTypes[i + 1] := aInputArgs[i].TypeInfo
+      else
+        InputUntypedTypes[i + 1] := Nil;
+    end;
+
+    SetLength(InOutMapping, Length(aInOutMapping));
+    for i := 0 to High(InOutMapping) do
+      InOutMapping[i] := aInOutMapping[i];
+    SetLength(OutputArgs, Length(aOutputArgs));
+    for i := 0 to High(OutputArgs) do
+      OutputArgs[i] := CopyValue(aOutputArgs[i]);
+    ResultValue := aResult;
+
+    res := method.Invoke(instance, aInputArgs);
+    Status('After invoke');
+
+    CheckEquals(name, InvokedMethodName, 'Invoked method name differs for ' + name);
+    Check(EqualValues(ResultValue, res), 'Reported result value differs from returned for ' + name);
+    Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
+    CheckEquals(Length(input), Length(InputArgs), 'Count of input args differs for ' + name);
+    for i := 0 to High(input) do begin
+      Check(EqualValues(input[i], InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
+    end;
+    for i := 0 to High(aOutputArgs) do begin
+      Check(EqualValues(aOutputArgs[i], aInputArgs[InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
+    end;
+  finally
+    context.Free;
+  end;
+end;
+
 {$ifdef fpc}
 procedure TTestImpl.OnHandleInvokable(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out
   aResult: TValue);
@@ -398,6 +535,11 @@ end;
 {$endif}
 
 {$ifndef InLazIDE}
+{$ifdef fpc}generic{$endif} procedure TTestImpl.GenDoIntfImpl<T>(aIntf: T; aIndex: LongInt; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+begin
+  DoIntfImpl(aIntf, TypeInfo(T), aIndex, aInputArgs, aOutputArgs, aInOutMapping, aResult);
+end;
+
 {$ifdef fpc}generic{$endif} procedure TTestImpl.GenDoMethodImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
 begin
   DoMethodImpl(TypeInfo(T), aInputArgs, aOutputArgs, aInOutMapping, aResult);
@@ -409,6 +551,123 @@ begin
 end;
 {$endif}
 
+procedure TTestImpl.TestIntfMethods;
+var
+  intf: ITestInterface;
+begin
+  intf := TVirtualInterface.Create(PTypeInfo(TypeInfo(ITestInterface)), {$ifdef fpc}@{$endif}OnHandleIntfMethod) as ITestInterface;
+  Check(Assigned(intf), 'ITestInterface instance is Nil');
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 1, [], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 2, [GetIntValue(42)], [], [], GetIntValue(21));
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 3, [GetAnsiString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 4, [GetShortString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 5, [], [], [], GetAnsiString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 6, [], [], [], GetShortString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 7, [
+    GetIntValue(1234), GetIntValue(4321), GetIntValue(0), GetIntValue(9876)
+  ], [
+    GetIntValue(5678), GetIntValue(6789)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 8, [
+    GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
+  ], [
+    GetAnsiString('Gamma'), GetAnsiString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 9, [
+    GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
+  ], [
+    GetShortString('Gamma'), GetShortString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 10, [
+    GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
+  ], [
+    GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 11, [
+    GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
+  ], [
+    GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 12, [
+    GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
+  ], [
+    GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 13, [
+    GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
+  ], [
+    GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 14, [
+    GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
+  ], [
+    GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 15, [
+    GetIntValue(1), GetIntValue(2), GetIntValue(3), GetIntValue(4), GetIntValue(5),
+    GetIntValue(6), GetIntValue(7), GetIntValue(8), GetIntValue(9), GetIntValue(10)
+  ], [], [], GetIntValue(11));
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 16, [
+    GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
+    GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
+  ], [], [], GetSingleValue(SingleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 17, [
+    GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
+    GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
+  ], [], [], GetDoubleValue(DoubleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 18, [
+    GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
+    GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
+  ], [], [], GetExtendedValue(ExtendedAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 19, [
+    GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
+    GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
+  ], [], [], GetCompValue(CompAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 20, [
+    GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
+    GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
+  ], [], [], GetCurrencyValue(CurrencyAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 21, [
+    GetIntValue(1234), GetIntValue(4321), GetIntValue(0), GetIntValue(9876)
+  ], [
+    GetIntValue(5678), GetIntValue(6789)
+  ], [0, 1], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 21, [
+    GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
+  ], [
+    GetAnsiString('Gamma'), GetAnsiString('Epsilon')
+  ], [0, 1], TValue.Empty);
+
+  { for some reason this fails, though it fails in Delphi as well :/ }
+  {{$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 21, [
+    GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
+  ], [
+    GetShortString('Gamma'), GetShortString('Epsilon')
+  ], [0, 1], TValue.Empty);}
+end;
+
 {$ifdef fpc}
 procedure TTestImpl.TestMethodVars;
 begin