From 1d6b591872ae5b33f75f54c4c821069f749aef09 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Thu, 16 May 2019 21:44:54 +0000 Subject: [PATCH] * add tests for TVirtualInterface git-svn-id: trunk@42089 - --- packages/rtl-objpas/tests/tests.rtti.impl.pas | 259 ++++++++++++++++++ 1 file changed, 259 insertions(+) diff --git a/packages/rtl-objpas/tests/tests.rtti.impl.pas b/packages/rtl-objpas/tests/tests.rtti.impl.pas index fe067e2e4c..411ccba377 100644 --- a/packages/rtl-objpas/tests/tests.rtti.impl.pas +++ b/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(aIntf: T; aIndex: LongInt; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue); {$ifdef fpc}generic{$endif} procedure GenDoMethodImpl(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue); {$ifdef fpc}generic{$endif} procedure GenDoProcImpl(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(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(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(intf, 1, [], [], [], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 2, [GetIntValue(42)], [], [], GetIntValue(21)); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 3, [GetAnsiString('Hello World')], [], [], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 4, [GetShortString('Hello World')], [], [], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 5, [], [], [], GetAnsiString('Hello World')); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 6, [], [], [], GetShortString('Hello World')); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 7, [ + GetIntValue(1234), GetIntValue(4321), GetIntValue(0), GetIntValue(9876) + ], [ + GetIntValue(5678), GetIntValue(6789) + ], [1, 2], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 8, [ + GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta') + ], [ + GetAnsiString('Gamma'), GetAnsiString('Epsilon') + ], [1, 2], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 9, [ + GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta') + ], [ + GetShortString('Gamma'), GetShortString('Epsilon') + ], [1, 2], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 10, [ + GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4) + ], [ + GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out) + ], [1, 2], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 11, [ + GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4) + ], [ + GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out) + ], [1, 2], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 12, [ + GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4) + ], [ + GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out) + ], [1, 2], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 13, [ + GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4) + ], [ + GetCompValue(CompArg2Out), GetCompValue(CompArg3Out) + ], [1, 2], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(intf, 14, [ + GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4) + ], [ + GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out) + ], [1, 2], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(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(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(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(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(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(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(intf, 21, [ + GetIntValue(1234), GetIntValue(4321), GetIntValue(0), GetIntValue(9876) + ], [ + GetIntValue(5678), GetIntValue(6789) + ], [0, 1], TValue.Empty); + + {$ifdef fpc}specialize{$endif}GenDoIntfImpl(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(intf, 21, [ + GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta') + ], [ + GetShortString('Gamma'), GetShortString('Epsilon') + ], [0, 1], TValue.Empty);} +end; + {$ifdef fpc} procedure TTestImpl.TestMethodVars; begin