unit tests.rtti; {$ifdef fpc} {$mode objfpc}{$H+} {$modeswitch advancedrecords} {$endif} interface uses {$IFDEF FPC} fpcunit,testregistry, testutils, {$ELSE FPC} TestFramework, {$ENDIF FPC} Classes, SysUtils, typinfo, Rtti; type { TTestCase1 } TTestCase1= class(TTestCase) published //procedure GetTypes; procedure GetTypeInteger; procedure GetTypePointer; procedure GetClassProperties; procedure GetClassPropertiesValue; procedure TestTRttiTypeProperties; procedure TestPropGetValueString; procedure TestPropGetValueInteger; procedure TestPropGetValueBoolean; procedure TestPropGetValueShortString; procedure TestPropGetValueProcString; procedure TestPropGetValueProcInteger; procedure TestPropGetValueProcBoolean; procedure TestPropGetValueProcShortString; procedure TestPropSetValueString; procedure TestPropSetValueInteger; procedure TestPropSetValueBoolean; procedure TestPropSetValueShortString; procedure TestGetValueStringCastError; procedure TestGetIsReadable; procedure TestIsWritable; procedure TestIsType; procedure TestMakeNil; procedure TestMakeObject; procedure TestMakeArrayDynamic; procedure TestMakeArrayStatic; {$ifdef fpc} procedure TestMakeArrayOpen; {$endif} procedure TestMakeSingle; procedure TestMakeDouble; procedure TestMakeExtended; procedure TestMakeCurrency; procedure TestMakeComp; procedure TestMakeEnum; procedure TestMakeAnsiChar; procedure TestMakeWideChar; procedure TestFromOrdinal; procedure TestDataSize; procedure TestDataSizeEmpty; procedure TestReferenceRawData; procedure TestReferenceRawDataEmpty; procedure TestIsManaged; {$ifdef fpc} procedure TestOpenArrayToDyn; {$endif} procedure TestInterface; {$ifdef fpc} procedure TestInterfaceRaw; {$endif} procedure TestProcVar; procedure TestMethod; procedure TestRawThunk; private procedure MakeFromOrdinalTObject; procedure MakeFromOrdinalSet; procedure MakeFromOrdinalString; procedure MakeFromOrdinalNil; end; implementation uses Tests.Rtti.Util; type {$M+} TGetClassProperties = class private FPubPropRO: integer; FPubPropRW: integer; published property PubPropRO: integer read FPubPropRO; property PubPropRW: integer read FPubPropRW write FPubPropRW; property PubPropSetRO: integer read FPubPropRO; property PubPropSetRW: integer read FPubPropRW write FPubPropRW; end; TGetClassPropertiesSub = class(TGetClassProperties) end; {$M-} { TTestValueClass } {$M+} TTestValueClass = class private FAInteger: integer; FAString: string; FABoolean: boolean; FAShortString: ShortString; function GetAInteger: integer; function GetAString: string; function GetABoolean: boolean; function GetAShortString: ShortString; procedure SetWriteOnly(AValue: integer); published property AInteger: Integer read FAInteger write FAInteger; property AString: string read FAString write FAString; property ABoolean: boolean read FABoolean write FABoolean; property AShortString: ShortString read FAShortString write FAShortString; property AGetInteger: Integer read GetAInteger; property AGetString: string read GetAString; property AGetBoolean: boolean read GetABoolean; property AGetShortString: ShortString read GetAShortString; property AWriteOnly: integer write SetWriteOnly; end; {$M-} {$M+} ITestInterface = interface procedure Test; function Test2: LongInt; procedure Test3(aArg1: LongInt; const aArg2: AnsiString; var aArg3: Boolean; out aArg4: Word); function Test4(aArg1: array of LongInt; aArg2: array of const): AnsiString; end; {$M-} TManagedRec = record s: string; end; {$ifdef fpc} TManagedRecOp = record class operator AddRef(var a: TManagedRecOp); end; {$endif} TNonManagedRec = record i: Integer; end; TManagedObj = object i: IInterface; end; TNonManagedObj = object d: double; end; TTestEnum = (te1, te2, te3, te4, te5); TTestSet = set of TTestEnum; TTestProc = procedure; TTestFunc1 = function: LongInt; TTestFunc2 = function(aArg1: LongInt; aArg2: array of LongInt): String; TTestMethod = procedure of object; TTestMethod1 = function: LongInt of object; TTestMethod2 = function(aArg1: LongInt; aArg2: array of LongInt): String of object; TTestHelper = class helper for TObject end; TArrayOfString = array[0..0] of string; TArrayOfManagedRec = array[0..0] of TManagedRec; TArrayOfNonManagedRec = array[0..0] of TNonManagedRec; TArrayOfByte = array[0..0] of byte; TArrayOfLongintDyn = array of LongInt; TArrayOfLongintStatic = array[0..3] of LongInt; TTestRecord = record Value1: LongInt; Value2: String; end; PTestRecord = ^TTestRecord; {$ifdef fpc} {$PUSH} {$INTERFACES CORBA} ICORBATest = interface end; {$POP} {$endif} {$ifdef fpc} class operator TManagedRecOp.AddRef(var a: TManagedRecOp); begin end; {$endif} { TTestValueClass } function TTestValueClass.GetAInteger: integer; begin result := FAInteger; end; function TTestValueClass.GetAString: string; begin result := FAString; end; function TTestValueClass.GetABoolean: boolean; begin result := FABoolean; end; function TTestValueClass.GetAShortString: ShortString; begin Result := FAShortString; end; procedure TTestValueClass.SetWriteOnly(AValue: integer); begin // Do nothing end; { Note: GetTypes currently only returns those types that had been acquired using GetType, so GetTypes itself can't be really tested currently } (*procedure TTestCase1.GetTypes; var LContext: TRttiContext; LType: TRttiType; IsTestCaseClassFound: boolean; begin LContext := TRttiContext.Create; { Enumerate all types declared in the application } for LType in LContext.GetTypes() do begin if LType.Name='TTestCase1' then IsTestCaseClassFound:=true; end; LContext.Free; CheckTrue(IsTestCaseClassFound, 'RTTI information does not contain class of testcase.'); end;*) procedure TTestCase1.TestGetValueStringCastError; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AValue: TValue; i: integer; HadException: boolean; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; ATestClass.AString := '12'; try ARttiType := c.GetType(ATestClass.ClassInfo); AValue := ARttiType.GetProperty('astring').GetValue(ATestClass); HadException := false; try i := AValue.AsInteger; except on E: Exception do if E.ClassType=EInvalidCast then HadException := true; end; Check(HadException, 'No or invalid exception on invalid cast'); finally AtestClass.Free; end; finally c.Free; end; end; procedure TTestCase1.TestMakeNil; var value: TValue; begin TValue.Make(Nil, Nil, value); CheckTrue(value.Kind = tkUnknown); CheckTrue(value.IsEmpty); CheckTrue(value.IsObject); CheckTrue(value.IsClass); CheckTrue(value.IsOrdinal); CheckFalse(value.IsArray); CheckTrue(value.AsObject = Nil); CheckTrue(value.AsClass = Nil); CheckTrue(value.AsInterface = Nil); CheckEquals(0, value.AsOrdinal); TValue.Make(Nil, TypeInfo(TObject), value); CheckTrue(value.IsEmpty); CheckTrue(value.IsObject); CheckTrue(value.IsClass); CheckTrue(value.IsOrdinal); CheckFalse(value.IsArray); CheckTrue(value.AsObject=Nil); CheckTrue(value.AsClass=Nil); CheckTrue(value.AsInterface=Nil); CheckEquals(0, value.AsOrdinal); TValue.Make(Nil, TypeInfo(TClass), value); CheckTrue(value.IsEmpty); CheckTrue(value.IsClass); CheckTrue(value.IsOrdinal); CheckFalse(value.IsArray); CheckTrue(value.AsObject=Nil); CheckTrue(value.AsClass=Nil); CheckTrue(value.AsInterface=Nil); CheckEquals(0, value.AsOrdinal); TValue.Make(Nil, TypeInfo(LongInt), value); CheckTrue(value.IsOrdinal); CheckFalse(value.IsEmpty); CheckFalse(value.IsClass); CheckFalse(value.IsObject); CheckFalse(value.IsArray); CheckEquals(0, value.AsOrdinal); CheckEquals(0, value.AsInteger); CheckEquals(0, value.AsInt64); CheckEquals(0, value.AsUInt64); TValue.Make(Nil, TypeInfo(String), value); CheckFalse(value.IsEmpty); CheckFalse(value.IsObject); CheckFalse(value.IsClass); CheckFalse(value.IsArray); CheckEquals('', value.AsString); end; procedure TTestCase1.TestMakeObject; var AValue: TValue; ATestClass: TTestValueClass; begin ATestClass := TTestValueClass.Create; ATestClass.AInteger := 54329; TValue.Make(@ATestClass, TypeInfo(TTestValueClass),AValue); CheckEquals(AValue.IsClass, False); CheckEquals(AValue.IsObject, True); Check(AValue.AsObject=ATestClass); Check(PPointer(AValue.GetReferenceToRawData)^ = Pointer(ATestClass)); CheckEquals(TTestValueClass(AValue.AsObject).AInteger, 54329); ATestClass.Free; end; procedure TTestCase1.TestMakeArrayDynamic; var arr: TArrayOfLongintDyn; value: TValue; begin SetLength(arr, 2); arr[0] := 42; arr[1] := 21; TValue.Make(@arr, TypeInfo(TArrayOfLongintDyn), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); Check(PPointer(value.GetReferenceToRawData)^ = Pointer(arr)); value.SetArrayElement(0, 84); CheckEquals(arr[0], 84); end; procedure TTestCase1.TestMakeArrayStatic; type TArrStat = array[0..1] of LongInt; TArrStat2D = array[0..1, 0..1] of LongInt; var arr: TArrStat; arr2D: TArrStat2D; value: TValue; begin arr[0] := 42; arr[1] := 21; TValue.Make(@arr, TypeInfo(TArrStat), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); value.SetArrayElement(0, 84); { since this is a static array the original array isn't touched! } CheckEquals(arr[0], 42); arr2D[0, 0] := 42; arr2D[0, 1] := 21; arr2D[1, 0] := 84; arr2D[1, 1] := 63; TValue.Make(@arr2D, TypeInfo(TArrStat2D), value); CheckEquals(value.IsArray, True); CheckEquals(value.GetArrayLength, 4); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); CheckEquals(value.GetArrayElement(2).AsInteger, 84); CheckEquals(value.GetArrayElement(3).AsInteger, 63); end; {$ifdef fpc} procedure TTestCase1.TestMakeArrayOpen; procedure TestOpenArrayValueCopy(aArr: array of LongInt); var value: TValue; begin TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsOpenArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); value.SetArrayElement(0, 84); { since this is an open array the original array is modified! } CheckEquals(aArr[0], 84); end; procedure TestOpenArrayValueVar(var aArr: array of LongInt); var value: TValue; begin TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsOpenArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); value.SetArrayElement(0, 84); { since this is an open array the original array is modified! } CheckEquals(aArr[0], 84); end; procedure TestOpenArrayValueOut(var aArr: array of LongInt); var value: TValue; begin TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsOpenArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); value.SetArrayElement(0, 84); value.SetArrayElement(1, 128); { since this is an open array the original array is modified! } CheckEquals(aArr[0], 84); CheckEquals(aArr[1], 128); CheckEquals(value.GetArrayElement(0).AsInteger, 84); CheckEquals(value.GetArrayElement(1).AsInteger, 128); end; var arr: array of LongInt; begin TestOpenArrayValueCopy([42, 21]); arr := [42, 21]; TestOpenArrayValueVar(arr); CheckEquals(arr[0], 84); CheckEquals(arr[1], 21); arr := [42, 21]; TestOpenArrayValueOut(arr); CheckEquals(arr[0], 84); CheckEquals(arr[1], 128); end; {$endif} procedure TTestCase1.TestMakeSingle; var fs: Single; v: TValue; hadexcept: Boolean; begin fs := 3.14; TValue.Make(@fs, TypeInfo(fs), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=fs); Check(v.GetReferenceToRawData <> @fs); try hadexcept := False; v.AsInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No signed type conversion exception'); try hadexcept := False; v.AsUInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No unsigned type conversion exception'); end; procedure TTestCase1.TestMakeDouble; var fd: Double; v: TValue; hadexcept: Boolean; begin fd := 3.14; TValue.Make(@fd, TypeInfo(fd), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=fd); Check(v.GetReferenceToRawData <> @fd); try hadexcept := False; v.AsInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No signed type conversion exception'); try hadexcept := False; v.AsUInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No unsigned type conversion exception'); end; procedure TTestCase1.TestMakeExtended; var fe: Extended; v: TValue; hadexcept: Boolean; begin fe := 3.14; TValue.Make(@fe, TypeInfo(fe), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=fe); Check(v.GetReferenceToRawData <> @fe); try hadexcept := False; v.AsInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No signed type conversion exception'); try hadexcept := False; v.AsUInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No unsigned type conversion exception'); end; procedure TTestCase1.TestMakeCurrency; var fcu: Currency; v: TValue; hadexcept: Boolean; begin fcu := 3.14; TValue.Make(@fcu, TypeInfo(fcu), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=Extended(fcu)); Check(v.AsCurrency=fcu); Check(v.GetReferenceToRawData <> @fcu); try hadexcept := False; v.AsInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No signed type conversion exception'); try hadexcept := False; v.AsUInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No unsigned type conversion exception'); end; procedure TTestCase1.TestMakeComp; var fco: Comp; v: TValue; hadexcept: Boolean; begin fco := 314; TValue.Make(@fco, TypeInfo(fco), v); if v.Kind <> tkFloat then Exit; CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=Extended(fco)); Check(v.GetReferenceToRawData <> @fco); try hadexcept := False; CheckEquals(v.AsInt64, 314); except hadexcept := True; end; CheckFalse(hadexcept, 'Had signed type conversion exception'); try hadexcept := False; CheckEquals(v.AsUInt64, 314); except hadexcept := True; end; CheckFalse(hadexcept, 'Had unsigned type conversion exception'); end; procedure TTestCase1.TestMakeEnum; var e: TTestEnum; v: TValue; begin e := te1; TValue.Make(@e, TypeInfo(e), v); Check(not v.IsClass); Check(not v.IsArray); Check(not v.IsEmpty); Check(not v.IsOpenArray); Check(not v.IsObject); Check(v.IsOrdinal); Check(v.GetReferenceToRawData <> @e); Check(TTestEnum(v.AsOrdinal) = te1); end; procedure TTestCase1.TestMakeAnsiChar; var c: AnsiChar; v: TValue; begin c := #20; TValue.Make(@c, TypeInfo(c), v); Check(not v.IsClass); Check(not v.IsArray); Check(not v.IsEmpty); Check(not v.IsOpenArray); Check(not v.IsObject); Check(v.IsOrdinal); Check(v.GetReferenceToRawData <> @c); Check(AnsiChar(v.AsOrdinal) = #20); end; procedure TTestCase1.TestMakeWideChar; var c: WideChar; v: TValue; begin c := #$1234; TValue.Make(@c, TypeInfo(c), v); Check(not v.IsClass); Check(not v.IsArray); Check(not v.IsEmpty); Check(not v.IsOpenArray); Check(not v.IsObject); Check(v.IsOrdinal); Check(v.GetReferenceToRawData <> @c); Check(WideChar(v.AsOrdinal) = #$1234); end; procedure TTestCase1.MakeFromOrdinalTObject; begin TValue.FromOrdinal(TypeInfo(TObject), 42); end; procedure TTestCase1.MakeFromOrdinalSet; begin TValue.FromOrdinal(TypeInfo(TTestSet), 42); end; procedure TTestCase1.MakeFromOrdinalString; begin TValue.FromOrdinal(TypeInfo(AnsiString), 42); end; procedure TTestCase1.MakeFromOrdinalNil; begin TValue.FromOrdinal(Nil, 42); end; procedure TTestCase1.TestFromOrdinal; var v: TValue; begin v := TValue.FromOrdinal(TypeInfo(LongInt), 42); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, 42); v := TValue.FromOrdinal(TypeInfo(Boolean), Ord(True)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(True)); v := TValue.FromOrdinal(TypeInfo(Int64), $1234123412341234); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, $1234123412341234); v := TValue.FromOrdinal(TypeInfo(QWord), $1234123412341234); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, $1234123412341234); v := TValue.FromOrdinal(TypeInfo(LongBool), Ord(True)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(True)); v := TValue.FromOrdinal(TypeInfo(TTestEnum), Ord(te1)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(te1)); v := TValue.FromOrdinal(TypeInfo(AnsiChar), Ord(#20)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(#20)); v := TValue.FromOrdinal(TypeInfo(WideChar), Ord(#$1234)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(#$1234)); CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalNil, EInvalidCast); CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalTObject, EInvalidCast); CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalSet, EInvalidCast); CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalString, EInvalidCast); end; procedure TTestCase1.TestGetIsReadable; var c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; begin c := TRttiContext.Create; try ARttiType := c.GetType(TTestValueClass); AProperty := ARttiType.GetProperty('aBoolean'); CheckEquals(AProperty.IsReadable, true); AProperty := ARttiType.GetProperty('aGetBoolean'); CheckEquals(AProperty.IsReadable, true); AProperty := ARttiType.GetProperty('aWriteOnly'); CheckEquals(AProperty.IsReadable, False); finally c.Free; end; end; procedure TTestCase1.TestIsWritable; var c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; begin c := TRttiContext.Create; try ARttiType := c.GetType(TTestValueClass); AProperty := ARttiType.GetProperty('aBoolean'); CheckEquals(AProperty.IsWritable, true); AProperty := ARttiType.GetProperty('aGetBoolean'); CheckEquals(AProperty.IsWritable, false); AProperty := ARttiType.GetProperty('aWriteOnly'); CheckEquals(AProperty.IsWritable, True); finally c.Free; end; end; procedure TTestCase1.TestIsType; type TMyLongInt = type LongInt; var v: TValue; l: LongInt; ml: TMyLongInt; begin l := 42; ml := 42; TValue.Make(@l, TypeInfo(l), v); Check(v.IsType(TypeInfo(l))); Check(not v.IsType(TypeInfo(ml))); Check(not v.IsType(TypeInfo(String))); Check(v.specialize IsType); Check(not v.specialize IsType); Check(not v.specialize IsType); TValue.Make(@ml, TypeInfo(ml), v); Check(v.IsType(TypeInfo(ml))); Check(not v.IsType(TypeInfo(l))); Check(not v.IsType(TypeInfo(String))); Check(v.specialize IsType); Check(not v.specialize IsType); Check(not v.specialize IsType); end; procedure TTestCase1.TestPropGetValueBoolean; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; ATestClass.ABoolean := true; try ARttiType := c.GetType(ATestClass.ClassInfo); Check(assigned(ARttiType)); AProperty := ARttiType.GetProperty('aBoolean'); AValue := AProperty.GetValue(ATestClass); CheckEquals(true,AValue.AsBoolean); ATestClass.ABoolean := false; CheckEquals(true, AValue.AsBoolean); CheckEquals('True', AValue.ToString); CheckEquals(True, AValue.IsOrdinal); CheckEquals(1, AValue.AsOrdinal); finally AtestClass.Free; end; CheckEquals(True,AValue.AsBoolean); finally c.Free; end; end; procedure TTestCase1.TestPropGetValueShortString; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; ATestClass.AShortString := 'Hello World'; try ARttiType := c.GetType(ATestClass.ClassInfo); Check(assigned(ARttiType)); AProperty := ARttiType.GetProperty('aShortString'); AValue := AProperty.GetValue(ATestClass); CheckEquals('Hello World',AValue.AsString); ATestClass.AShortString := 'Foobar'; CheckEquals('Hello World', AValue.AsString); CheckEquals(False, AValue.IsOrdinal); CheckEquals(False, AValue.IsObject); CheckEquals(False, AValue.IsArray); CheckEquals(False, AValue.IsClass); finally AtestClass.Free; end; CheckEquals('Hello World',AValue.AsString); finally c.Free; end; end; procedure TTestCase1.TestPropGetValueInteger; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; ATestClass.AInteger := 472349; try ARttiType := c.GetType(ATestClass.ClassInfo); Check(assigned(ARttiType)); AProperty := ARttiType.GetProperty('ainteger'); AValue := AProperty.GetValue(ATestClass); CheckEquals(472349,AValue.AsInteger); ATestClass.AInteger := 12; CheckEquals(472349, AValue.AsInteger); CheckEquals('472349', AValue.ToString); CheckEquals(True, AValue.IsOrdinal); finally AtestClass.Free; end; CheckEquals(472349,AValue.AsInteger); finally c.Free; end; end; procedure TTestCase1.TestPropGetValueString; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; i: int64; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; ATestClass.AString := 'Hello World'; try ARttiType := c.GetType(ATestClass.ClassInfo); Check(assigned(ARttiType)); AProperty := ARttiType.GetProperty('astring'); AValue := AProperty.GetValue(ATestClass); CheckEquals('Hello World',AValue.AsString); ATestClass.AString := 'Goodbye World'; CheckEquals('Hello World',AValue.AsString); CheckEquals('Hello World',AValue.ToString); Check(TypeInfo(string)=AValue.TypeInfo); Check(AValue.TypeData=GetTypeData(AValue.TypeInfo)); Check(AValue.IsEmpty=false); Check(AValue.IsObject=false); Check(AValue.IsClass=false); CheckEquals(AValue.IsOrdinal, false); CheckEquals(AValue.TryAsOrdinal(i), false); CheckEquals(AValue.IsType(TypeInfo(string)), true); CheckEquals(AValue.IsType(TypeInfo(integer)), false); CheckEquals(AValue.IsArray, false); finally AtestClass.Free; end; CheckEquals('Hello World',AValue.AsString); finally c.Free; end; end; procedure TTestCase1.TestPropGetValueProcBoolean; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; ATestClass.ABoolean := true; try ARttiType := c.GetType(ATestClass.ClassInfo); Check(assigned(ARttiType)); AProperty := ARttiType.GetProperty('aGetBoolean'); AValue := AProperty.GetValue(ATestClass); CheckEquals(true,AValue.AsBoolean); finally AtestClass.Free; end; CheckEquals(True,AValue.AsBoolean); finally c.Free; end; end; procedure TTestCase1.TestPropGetValueProcShortString; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; ATestClass.AShortString := 'Hello World'; try ARttiType := c.GetType(ATestClass.ClassInfo); Check(assigned(ARttiType)); AProperty := ARttiType.GetProperty('aGetShortString'); AValue := AProperty.GetValue(ATestClass); CheckEquals('Hello World',AValue.AsString); finally AtestClass.Free; end; CheckEquals('Hello World',AValue.AsString); finally c.Free; end; end; procedure TTestCase1.TestPropSetValueString; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; s: string; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; try ARttiType := c.GetType(ATestClass.ClassInfo); AProperty := ARttiType.GetProperty('astring'); s := 'ipse lorem or something like that'; TValue.Make(@s, TypeInfo(string), AValue); AProperty.SetValue(ATestClass, AValue); CheckEquals(ATestClass.AString, s); s := 'Another string'; CheckEquals(ATestClass.AString, 'ipse lorem or something like that'); finally AtestClass.Free; end; finally c.Free; end; end; procedure TTestCase1.TestPropSetValueInteger; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; i: integer; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; try ARttiType := c.GetType(ATestClass.ClassInfo); AProperty := ARttiType.GetProperty('aInteger'); i := -43573; TValue.Make(@i, TypeInfo(Integer), AValue); AProperty.SetValue(ATestClass, AValue); CheckEquals(ATestClass.AInteger, i); i := 1; CheckEquals(ATestClass.AInteger, -43573); finally AtestClass.Free; end; finally c.Free; end; end; procedure TTestCase1.TestPropSetValueBoolean; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; b: boolean; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; try ARttiType := c.GetType(ATestClass.ClassInfo); AProperty := ARttiType.GetProperty('aboolean'); b := true; TValue.Make(@b, TypeInfo(Boolean), AValue); AProperty.SetValue(ATestClass, AValue); CheckEquals(ATestClass.ABoolean, b); b := false; CheckEquals(ATestClass.ABoolean, true); TValue.Make(@b, TypeInfo(Boolean), AValue); AProperty.SetValue(ATestClass, AValue); CheckEquals(ATestClass.ABoolean, false); finally AtestClass.Free; end; finally c.Free; end; end; procedure TTestCase1.TestPropSetValueShortString; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; s: string; ss: ShortString; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; try ARttiType := c.GetType(ATestClass.ClassInfo); AProperty := ARttiType.GetProperty('aShortString'); s := 'ipse lorem or something like that'; TValue.Make(@s, TypeInfo(String), AValue); AProperty.SetValue(ATestClass, AValue); CheckEquals(ATestClass.AShortString, s); s := 'Another string'; CheckEquals(ATestClass.AShortString, 'ipse lorem or something like that'); ss := 'Hello World'; TValue.Make(@ss, TypeInfo(ShortString), AValue); AProperty.SetValue(ATestClass, AValue); CheckEquals(ATestClass.AShortString, ss); ss := 'Foobar'; CheckEquals(ATestClass.AShortString, 'Hello World'); finally AtestClass.Free; end; finally c.Free; end; end; procedure TTestCase1.TestPropGetValueProcInteger; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; ATestClass.AInteger := 472349; try ARttiType := c.GetType(ATestClass.ClassInfo); Check(assigned(ARttiType)); AProperty := ARttiType.GetProperty('agetinteger'); AValue := AProperty.GetValue(ATestClass); CheckEquals(472349,AValue.AsInteger); finally AtestClass.Free; end; CheckEquals(472349,AValue.AsInteger); finally c.Free; end; end; procedure TTestCase1.TestPropGetValueProcString; var ATestClass : TTestValueClass; c: TRttiContext; ARttiType: TRttiType; AProperty: TRttiProperty; AValue: TValue; begin c := TRttiContext.Create; try ATestClass := TTestValueClass.Create; ATestClass.AString := 'Hello World'; try ARttiType := c.GetType(ATestClass.ClassInfo); Check(assigned(ARttiType)); AProperty := ARttiType.GetProperty('agetstring'); AValue := AProperty.GetValue(ATestClass); CheckEquals('Hello World',AValue.AsString); finally AtestClass.Free; end; CheckEquals('Hello World',AValue.AsString); finally c.Free; end; end; procedure TTestCase1.TestTRttiTypeProperties; var c: TRttiContext; ARttiType: TRttiType; begin c := TRttiContext.Create; try ARttiType := c.GetType(TTestValueClass); Check(assigned(ARttiType)); CheckEquals(ARttiType.Name,'TTestValueClass'); Check(ARttiType.TypeKind=tkClass); // CheckEquals(ARttiType.IsPublicType,false); CheckEquals(ARttiType.TypeSize,SizeOf(TObject)); CheckEquals(ARttiType.IsManaged,false); CheckEquals(ARttiType.BaseType.classname,'TRttiInstanceType'); CheckEquals(ARttiType.IsInstance,True); CheckEquals(ARttiType.AsInstance.DeclaringUnitName,'tests.rtti'); Check(ARttiType.BaseType.Name='TObject'); Check(ARttiType.AsInstance.BaseType.Name='TObject'); CheckEquals(ARttiType.IsOrdinal,False); CheckEquals(ARttiType.IsRecord,False); CheckEquals(ARttiType.IsSet,False); finally c.Free; end; end; procedure TTestCase1.GetTypeInteger; var LContext: TRttiContext; LType: TRttiType; begin LContext := TRttiContext.Create; LType := LContext.GetType(TypeInfo(integer)); {$ifdef fpc} CheckEquals(LType.Name, 'LongInt'); {$else} CheckEquals(LType.Name, 'Integer'); {$endif} LContext.Free; end; procedure TTestCase1.GetTypePointer; var context: TRttiContext; t: TRttiType; p: TRttiPointerType absolute t; begin context := TRttiContext.Create; try t := context.GetType(TypeInfo(Pointer)); Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType'); Assert(not Assigned(p.ReferredType), 'ReferredType of Pointer is not Nil'); t := context.GetType(TypeInfo(PLongInt)); Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType'); Assert(Assigned(p.ReferredType), 'ReferredType of PLongInt is Nil'); Assert(p.ReferredType = context.GetType(TypeInfo(LongInt)), 'ReferredType of PLongInt is not a LongInt'); t := context.GetType(TypeInfo(PWideChar)); Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType'); Assert(Assigned(p.ReferredType), 'ReferredType of PWideChar is Nil'); Assert(p.ReferredType = context.GetType(TypeInfo(WideChar)), 'ReferredType of PWideChar is not a WideChar'); finally context.Free; end; end; procedure TTestCase1.GetClassProperties; var LContext: TRttiContext; LType: TRttiType; PropList, PropList2: {$ifdef fpc}specialize{$endif} TArray; i: LongInt; begin LContext := TRttiContext.Create; LType := LContext.GetType(TypeInfo(TGetClassProperties)); PropList := LType.GetProperties; CheckEquals(4, length(PropList)); CheckEquals('PubPropRO', PropList[0].Name); CheckEquals('PubPropRW', PropList[1].Name); CheckEquals('PubPropSetRO', PropList[2].Name); CheckEquals('PubPropSetRW', PropList[3].Name); LType := LContext.GetType(TypeInfo(TGetClassPropertiesSub)); PropList2 := LType.GetProperties; CheckEquals(Length(PropList), Length(PropList2)); for i := 0 to High(PropList) do Check(PropList[i] = PropList2[i], 'Property instances are not equal'); LContext.Free; end; procedure TTestCase1.GetClassPropertiesValue; var AGetClassProperties: TGetClassProperties; LContext: TRttiContext; LType: TRttiType; AValue: TValue; begin LContext := TRttiContext.Create; LType := LContext.GetType(TGetClassProperties); AGetClassProperties := TGetClassProperties.Create; try AGetClassProperties.PubPropRW:=12345; AValue := LType.GetProperty('PubPropRW').GetValue(AGetClassProperties); CheckEquals(12345, AValue.AsInteger); finally AGetClassProperties.Free; end; LContext.Free; end; procedure TTestCase1.TestReferenceRawData; var value: TValue; str: String; intf: IInterface; i: LongInt; test: TTestRecord; arrdyn: TArrayOfLongintDyn; arrstat: TArrayOfLongintStatic; begin str := 'Hello World'; UniqueString(str); TValue.Make(@str, TypeInfo(String), value); Check(PPointer(value.GetReferenceToRawData)^ = Pointer(str), 'Reference to string data differs'); intf := TInterfacedObject.Create; TValue.Make(@intf, TypeInfo(IInterface), value); Check(PPointer(value.GetReferenceToRawData)^ = Pointer(intf), 'Reference to interface data differs'); i := 42; TValue.Make(@i, TypeInfo(LongInt), value); Check(value.GetReferenceToRawData <> @i, 'Reference to longint is equal'); Check(PLongInt(value.GetReferenceToRawData)^ = PLongInt(@i)^, 'Reference to longint data differs'); test.value1 := 42; test.value2 := 'Hello World'; TValue.Make(@test, TypeInfo(TTestRecord), value); Check(value.GetReferenceToRawData <> @test, 'Reference to record is equal'); Check(PTestRecord(value.GetReferenceToRawData)^.value1 = PTestRecord(@test)^.value1, 'Reference to record data value1 differs'); Check(PTestRecord(value.GetReferenceToRawData)^.value2 = PTestRecord(@test)^.value2, 'Reference to record data value2 differs'); SetLength(arrdyn, 3); arrdyn[0] := 42; arrdyn[1] := 23; arrdyn[2] := 49; TValue.Make(@arrdyn, TypeInfo(TArrayOfLongintDyn), value); Check(PPointer(value.GetReferenceToRawData)^ = Pointer(arrdyn), 'Reference to dynamic array data differs'); arrstat[0] := 42; arrstat[1] := 23; arrstat[2] := 49; arrstat[3] := 59; TValue.Make(@arrstat, TypeInfo(TArrayOfLongintStatic), value); Check(value.GetReferenceToRawData <> @arrstat, 'Reference to static array is equal'); Check(PLongInt(value.GetReferenceToRawData)^ = PLongInt(@arrstat)^, 'Reference to static array data differs'); end; procedure TTestCase1.TestReferenceRawDataEmpty; var value: TValue; begin TValue.Make(Nil, TypeInfo(String), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty String is not assigned'); Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty String data is assigned'); TValue.Make(Nil, TypeInfo(IInterface), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty interface is not assigned'); Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty interface data is assigned'); TValue.Make(Nil, TypeInfo(LongInt), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty LongInt is not assigned'); Check(PLongInt(value.GetReferenceToRawData)^ = 0, 'Empty longint data is not 0'); TValue.Make(Nil, TypeInfo(TTestRecord), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty record is not assigned'); Check(PTestRecord(value.GetReferenceToRawData)^.value1 = 0, 'Empty record data value1 is not 0'); Check(PTestRecord(value.GetReferenceToRawData)^.value2 = '', 'Empty record data value2 is not empty'); TValue.Make(Nil, TypeInfo(TArrayOfLongintDyn), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty dynamic array is not assigned'); Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty dynamic array data is assigned'); TValue.Make(Nil, TypeInfo(TArrayOfLongintStatic), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty static array is not assigned'); Check(PLongInt(value.GetReferenceToRawData)^ = 0, 'Empty static array data is not 0'); end; procedure TTestCase1.TestDataSize; var u8: UInt8; u16: UInt16; u32: UInt32; u64: UInt64; s8: Int8; s16: Int16; s32: Int32; s64: Int64; f32: Single; f64: Double; {$ifdef FPC_HAS_TYPE_EXTENDED} f80: Extended; {$endif} fco: Comp; fcu: Currency; ss: ShortString; sa: AnsiString; su: UnicodeString; sw: WideString; o: TObject; c: TClass; i: IInterface; ad: TArrayOfLongintDyn; _as: TArrayOfLongintStatic; b8: Boolean; {$ifdef fpc} b16: Boolean16; b32: Boolean32; b64: Boolean64; {$endif} bl8: ByteBool; bl16: WordBool; bl32: LongBool; {$ifdef fpc} bl64: QWordBool; {$endif} e: TTestEnum; s: TTestSet; t: TTestRecord; p: Pointer; proc: TTestProc; method: TTestMethod; value: TValue; begin u8:=245; TValue.Make(@u8, TypeInfo(UInt8), value); CheckEquals(1, value.DataSize, 'Size of UInt8 differs'); u16:=789; TValue.Make(@u16, TypeInfo(UInt16), value); CheckEquals(2, value.DataSize, 'Size of UInt16 differs'); u32:=568789; TValue.Make(@u32, TypeInfo(UInt32), value); CheckEquals(4, value.DataSize, 'Size of UInt32 differs'); u64:=$abdcefadbcef; TValue.Make(@u64, TypeInfo(UInt64), value); CheckEquals(8, value.DataSize, 'Size of UInt64 differs'); s8:=-32; TValue.Make(@s8, TypeInfo(Int8), value); CheckEquals(1, value.DataSize, 'Size of Int8 differs'); s16:=-5345; TValue.Make(@s16, TypeInfo(Int16), value); CheckEquals(2, value.DataSize, 'Size of Int16 differs'); s32:=-234567; TValue.Make(@s32, TypeInfo(Int32), value); CheckEquals(4, value.DataSize, 'Size of Int32 differs'); s64:=23456789012; TValue.Make(@s64, TypeInfo(Int64), value); CheckEquals(8, value.DataSize, 'Size of Int64 differs'); b8:=false; TValue.Make(@b8, TypeInfo(Boolean), value); CheckEquals(1, value.DataSize, 'Size of Boolean differs'); {$ifdef fpc} b16:=true; TValue.Make(@b16, TypeInfo(Boolean16), value); CheckEquals(2, value.DataSize, 'Size of Boolean16 differs'); b32:=false; TValue.Make(@b32, TypeInfo(Boolean32), value); CheckEquals(4, value.DataSize, 'Size of Boolean32 differs'); b64:=true; TValue.Make(@b64, TypeInfo(Boolean64), value); CheckEquals(8, value.DataSize, 'Size of Boolean64 differs'); {$endif} bl8:=true; TValue.Make(@bl8, TypeInfo(ByteBool), value); CheckEquals(1, value.DataSize, 'Size of ByteBool differs'); bl16:=false; TValue.Make(@bl16, TypeInfo(WordBool), value); CheckEquals(2, value.DataSize, 'Size of WordBool differs'); bl32:=false; TValue.Make(@bl32, TypeInfo(LongBool), value); CheckEquals(4, value.DataSize, 'Size of LongBool differs'); {$ifdef fpc} bl64:=true; TValue.Make(@bl64, TypeInfo(QWordBool), value); CheckEquals(8, value.DataSize, 'Size of QWordBool differs'); {$endif} f32:=4.567; TValue.Make(@f32, TypeInfo(Single), value); CheckEquals(4, value.DataSize, 'Size of Single differs'); f64:=-3456.678; TValue.Make(@f64, TypeInfo(Double), value); CheckEquals(8, value.DataSize, 'Size of Double differs'); {$ifdef FPC_HAS_TYPE_EXTENDED} f80:=-2345.678; TValue.Make(@f80, TypeInfo(Extended), value); CheckEquals(10, value.DataSize, 'Size of Extended differs'); {$endif} fcu:=56.78; TValue.Make(@fcu, TypeInfo(Currency), value); CheckEquals(SizeOf(Currency), value.DataSize, 'Size of Currency differs'); fco:=456; TValue.Make(@fco, TypeInfo(Comp), value); CheckEquals(SizeOf(Comp), value.DataSize, 'Size of Comp differs'); ss := ''; TValue.Make(@ss, TypeInfo(ShortString), value); CheckEquals(254, value.DataSize, 'Size ofShortString differs'); sa:= ''; TValue.Make(@sa, TypeInfo(AnsiString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of AnsiString differs'); sw := ''; TValue.Make(@sw, TypeInfo(WideString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of WideString differs'); su:=''; TValue.Make(@su, TypeInfo(UnicodeString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of UnicodeString differs'); o := TTestValueClass.Create; TValue.Make(@o, TypeInfo(TObject), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TObject differs'); o.Free; c := TObject; TValue.Make(@c, TypeInfo(TClass), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TClass differs'); i := Nil; TValue.Make(@i, TypeInfo(IInterface), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of IInterface differs'); TValue.Make(@t, TypeInfo(TTestRecord), value); CheckEquals(SizeOf(TTestRecord), value.DataSize, 'Size of TTestRecord differs'); proc := Nil; TValue.Make(@proc, TypeInfo(TTestProc), value); CheckEquals(SizeOf(TTestProc), value.DataSize, 'Size of TTestProc differs'); method := Nil; TValue.Make(@method, TypeInfo(TTestMethod), value); CheckEquals(SizeOf(TTestMethod), value.DataSize, 'Size of TTestMethod differs'); TValue.Make(@_as, TypeInfo(TArrayOfLongintStatic), value); CheckEquals(SizeOf(TArrayOfLongintStatic), value.DataSize, 'Size of TArrayOfLongintStatic differs'); TValue.Make(@ad, TypeInfo(TArrayOfLongintDyn), value); CheckEquals(SizeOf(TArrayOfLongintDyn), value.DataSize, 'Size of TArrayOfLongintDyn differs'); e:=low(TTestEnum); TValue.Make(@e, TypeInfo(TTestEnum), value); CheckEquals(SizeOf(TTestEnum), value.DataSize, 'Size of TTestEnum differs'); s:=[low(TTestEnum),high(TTestEnum)]; TValue.Make(@s, TypeInfo(TTestSet), value); CheckEquals(SizeOf(TTestSet), value.DataSize, 'Size of TTestSet differs'); p := Nil; TValue.Make(@p, TypeInfo(Pointer), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs'); end; procedure TTestCase1.TestDataSizeEmpty; var value: TValue; begin TValue.Make(Nil, TypeInfo(UInt8), value); CheckEquals(1, value.DataSize, 'Size of UInt8 differs'); TValue.Make(Nil, TypeInfo(UInt16), value); CheckEquals(2, value.DataSize, 'Size of UInt16 differs'); TValue.Make(Nil, TypeInfo(UInt32), value); CheckEquals(4, value.DataSize, 'Size of UInt32 differs'); TValue.Make(Nil, TypeInfo(UInt64), value); CheckEquals(8, value.DataSize, 'Size of UInt64 differs'); TValue.Make(Nil, TypeInfo(Int8), value); CheckEquals(1, value.DataSize, 'Size of Int8 differs'); TValue.Make(Nil, TypeInfo(Int16), value); CheckEquals(2, value.DataSize, 'Size of Int16 differs'); TValue.Make(Nil, TypeInfo(Int32), value); CheckEquals(4, value.DataSize, 'Size of Int32 differs'); TValue.Make(Nil, TypeInfo(Int64), value); CheckEquals(8, value.DataSize, 'Size of Int64 differs'); TValue.Make(Nil, TypeInfo(Boolean), value); CheckEquals(1, value.DataSize, 'Size of Boolean differs'); {$ifdef fpc} TValue.Make(Nil, TypeInfo(Boolean16), value); CheckEquals(2, value.DataSize, 'Size of Boolean16 differs'); TValue.Make(Nil, TypeInfo(Boolean32), value); CheckEquals(4, value.DataSize, 'Size of Boolean32 differs'); TValue.Make(Nil, TypeInfo(Boolean64), value); CheckEquals(8, value.DataSize, 'Size of Boolean64 differs'); {$endif} TValue.Make(Nil, TypeInfo(ByteBool), value); CheckEquals(1, value.DataSize, 'Size of ByteBool differs'); TValue.Make(Nil, TypeInfo(WordBool), value); CheckEquals(2, value.DataSize, 'Size of WordBool differs'); TValue.Make(Nil, TypeInfo(LongBool), value); CheckEquals(4, value.DataSize, 'Size of LongBool differs'); {$ifdef fpc} TValue.Make(Nil, TypeInfo(QWordBool), value); CheckEquals(8, value.DataSize, 'Size of QWordBool differs'); {$endif} TValue.Make(Nil, TypeInfo(Single), value); CheckEquals(4, value.DataSize, 'Size of Single differs'); TValue.Make(Nil, TypeInfo(Double), value); CheckEquals(8, value.DataSize, 'Size of Double differs'); {$ifdef FPC_HAS_TYPE_EXTENDED} TValue.Make(Nil, TypeInfo(Extended), value); CheckEquals(10, value.DataSize, 'Size of Extended differs'); {$endif} TValue.Make(Nil, TypeInfo(Currency), value); CheckEquals(SizeOf(Currency), value.DataSize, 'Size of Currency differs'); TValue.Make(Nil, TypeInfo(Comp), value); CheckEquals(SizeOf(Comp), value.DataSize, 'Size of Comp differs'); TValue.Make(Nil, TypeInfo(ShortString), value); CheckEquals(254, value.DataSize, 'Size of ShortString differs'); TValue.Make(Nil, TypeInfo(AnsiString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs'); TValue.Make(Nil, TypeInfo(WideString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of WideString differs'); TValue.Make(Nil, TypeInfo(UnicodeString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of UnicodeString differs'); TValue.Make(Nil, TypeInfo(TObject), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TObject differs'); TValue.Make(Nil, TypeInfo(TClass), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TClass differs'); TValue.Make(Nil, TypeInfo(IInterface), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of IInterface differs'); TValue.Make(Nil, TypeInfo(TTestRecord), value); CheckEquals(SizeOf(TTestRecord), value.DataSize, 'Size of TTestRecord differs'); TValue.Make(Nil, TypeInfo(TTestProc), value); CheckEquals(SizeOf(TTestProc), value.DataSize, 'Size of TTestProc differs'); TValue.Make(Nil, TypeInfo(TTestMethod), value); CheckEquals(SizeOf(TTestMethod), value.DataSize, 'Size of TTestMethod differs'); TValue.Make(Nil, TypeInfo(TArrayOfLongintStatic), value); CheckEquals(SizeOf(TArrayOfLongintStatic), value.DataSize, 'Size of TArrayOfLongintStatic differs'); TValue.Make(Nil, TypeInfo(TArrayOfLongintDyn), value); CheckEquals(SizeOf(TArrayOfLongintDyn), value.DataSize, 'Size of TArrayOfLongintDyn differs'); TValue.Make(Nil, TypeInfo(TTestEnum), value); CheckEquals(SizeOf(TTestEnum), value.DataSize, 'Size of TTestEnum differs'); TValue.Make(Nil, TypeInfo(TTestSet), value); CheckEquals(SizeOf(TTestSet), value.DataSize, 'Size of TTestSet differs'); TValue.Make(Nil, TypeInfo(Pointer), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs'); end; procedure TTestCase1.TestIsManaged; begin CheckEquals(true, IsManaged(TypeInfo(ansistring)), 'IsManaged for tkAString'); CheckEquals(true, IsManaged(TypeInfo(widestring)), 'IsManaged for tkWString'); CheckEquals(true, IsManaged(TypeInfo(Variant)), 'IsManaged for tkVariant'); CheckEquals(true, IsManaged(TypeInfo(TArrayOfManagedRec)), 'IsManaged for tkArray (with managed ElType)'); CheckEquals(true, IsManaged(TypeInfo(TArrayOfString)), 'IsManaged for tkArray (with managed ElType)'); CheckEquals(true, IsManaged(TypeInfo(TManagedRec)), 'IsManaged for tkRecord'); {$ifdef fpc} CheckEquals(true, IsManaged(TypeInfo(TManagedRecOp)), 'IsManaged for tkRecord'); {$endif} CheckEquals(true, IsManaged(TypeInfo(IInterface)), 'IsManaged for tkInterface'); CheckEquals(true, IsManaged(TypeInfo(TManagedObj)), 'IsManaged for tkObject'); {$ifdef fpc} CheckEquals(true, IsManaged(TypeInfo(specialize TArray)), 'IsManaged for tkDynArray'); {$else} CheckEquals(true, IsManaged(TypeInfo(TArray)), 'IsManaged for tkDynArray'); {$endif} CheckEquals(true, IsManaged(TypeInfo(unicodestring)), 'IsManaged for tkUString'); CheckEquals(false, IsManaged(TypeInfo(shortstring)), 'IsManaged for tkSString'); CheckEquals(false, IsManaged(TypeInfo(Byte)), 'IsManaged for tkInteger'); CheckEquals(false, IsManaged(TypeInfo(Char)), 'IsManaged for tkChar'); CheckEquals(false, IsManaged(TypeInfo(TTestEnum)), 'IsManaged for tkEnumeration'); CheckEquals(false, IsManaged(TypeInfo(Single)), 'IsManaged for tkFloat'); CheckEquals(false, IsManaged(TypeInfo(TTestSet)), 'IsManaged for tkSet'); {$ifdef fpc} CheckEquals(false, IsManaged(TypeInfo(TTestMethod)), 'IsManaged for tkMethod'); {$else} { Delphi bug (or sabotage). For some reason Delphi considers method pointers to be managed (only in newer versions, probably since XE7) :/ } CheckEquals({$if RTLVersion>=28}true{$else}false{$endif}, IsManaged(TypeInfo(TTestMethod)), 'IsManaged for tkMethod'); {$endif} CheckEquals(false, IsManaged(TypeInfo(TArrayOfByte)), 'IsManaged for tkArray (with non managed ElType)'); CheckEquals(false, IsManaged(TypeInfo(TArrayOfNonManagedRec)), 'IsManaged for tkArray (with non managed ElType)'); CheckEquals(false, IsManaged(TypeInfo(TNonManagedRec)), 'IsManaged for tkRecord'); CheckEquals(false, IsManaged(TypeInfo(TObject)), 'IsManaged for tkClass'); CheckEquals(false, IsManaged(TypeInfo(TNonManagedObj)), 'IsManaged for tkObject'); CheckEquals(false, IsManaged(TypeInfo(WideChar)), 'IsManaged for tkWChar'); CheckEquals(false, IsManaged(TypeInfo(Boolean)), 'IsManaged for tkBool'); CheckEquals(false, IsManaged(TypeInfo(Int64)), 'IsManaged for tkInt64'); CheckEquals(false, IsManaged(TypeInfo(UInt64)), 'IsManaged for tkQWord'); {$ifdef fpc} CheckEquals(false, IsManaged(TypeInfo(ICORBATest)), 'IsManaged for tkInterfaceRaw'); {$endif} CheckEquals(false, IsManaged(TypeInfo(TTestProc)), 'IsManaged for tkProcVar'); CheckEquals(false, IsManaged(TypeInfo(TTestHelper)), 'IsManaged for tkHelper'); {$ifdef fpc} CheckEquals(false, IsManaged(TypeInfo(file)), 'IsManaged for tkFile'); {$endif} CheckEquals(false, IsManaged(TypeInfo(TClass)), 'IsManaged for tkClassRef'); CheckEquals(false, IsManaged(TypeInfo(Pointer)), 'IsManaged for tkPointer'); CheckEquals(false, IsManaged(nil), 'IsManaged for nil'); end; {$ifdef fpc} procedure TTestCase1.TestOpenArrayToDyn; procedure OpenArrayProc(aArr: array of LongInt); var value: TValue; begin {$ifndef InLazIDE} value := specialize OpenArrayToDynArrayValue(aArr); {$endif} CheckEquals(value.IsArray, True); CheckEquals(value.IsOpenArray, False); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 84); value.SetArrayElement(0, 21); { since this is a copy the original array is not modified! } CheckEquals(aArr[0], 42); end; begin OpenArrayProc([42, 84]); end; {$endif} procedure TTestCase1.TestInterface; var context: TRttiContext; t: TRttiType; ti1, ti2: TRttiInterfaceType; methods: {$ifdef fpc}specialize{$endif} TArray; params: {$ifdef fpc}specialize{$endif} TArray; method: TRttiMethod; param: TRttiParameter; flag: TParamFlag; begin context := TRttiContext.Create; try t := context.GetType(TypeInfo(IInterface)); Check(t is TRttiInterfaceType, 'Type is not an interface type'); Check(not Assigned(t.BaseType), 'Base type is assigned'); ti1 := TRttiInterfaceType(t); Check(not Assigned(ti1.BaseType), 'Base type is assigned'); methods := t.GetMethods; CheckEquals(0, Length(methods), 'Overall method count does not match'); methods := t.GetDeclaredMethods; CheckEquals(0, Length(methods), 'Declared method conut does not match'); t := context.GetType(TypeInfo(ITestInterface)); Check(t is TRttiInterfaceType, 'Type is not an interface type'); Check(Assigned(t.BaseType), 'Base type is not assigned'); Check(t.BaseType = TRttiType(ti1), 'Base type does not match'); ti2 := TRttiInterfaceType(t); Check(Assigned(ti2.BaseType), 'Base type is not assigned'); Check(ti2.BaseType = ti1, 'Base type does not match'); methods := t.GetMethods; CheckEquals(4, Length(methods), 'Overall method count does not match'); methods := t.GetDeclaredMethods; CheckEquals(4, Length(methods), 'Declared method count does not match'); method := methods[0]; CheckEquals(method.Name, 'Test', 'Method name of Test does not match'); Check(method.CallingConvention = DefaultCC, 'Calling convention of Test does not match'); Check(method.MethodKind = mkProcedure, 'Method kind of Test does not match'); Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test does not match'); Check(not Assigned(method.CodeAddress), 'Code address of Test is not Nil'); CheckEquals(method.VirtualIndex, 3, 'Virtual index of Test does not match'); Check(not Assigned(method.ReturnType), 'Return type of Test is not Nil'); params := method.GetParameters; CheckEquals(0, Length(params), 'Parameter count of Test does not match'); method := methods[1]; CheckEquals(method.Name, 'Test2', 'Method name of Test2 does not match'); Check(method.CallingConvention = DefaultCC, 'Calling convention of Test2 does not match'); Check(method.MethodKind = mkFunction, 'Method kind of Test2 does not match'); Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test2 does not match'); Check(not Assigned(method.CodeAddress), 'Code address of Test2 is not Nil'); CheckEquals(method.VirtualIndex, 4, 'Virtual index of Test2 does not match'); Check(Assigned(method.ReturnType), 'Return type of Test2 is Nil'); Check(method.ReturnType.TypeKind = tkInteger, 'Return type of Test2 is not an ordinal'); params := method.GetParameters; CheckEquals(0, Length(params), 'Parameter count of Test2 does not match'); method := methods[2]; CheckEquals(method.Name, 'Test3', 'Method name of Test3 does not match'); Check(method.CallingConvention = DefaultCC, 'Calling convention of Test3 does not match'); Check(method.MethodKind = mkProcedure, 'Method kind of Test3 does not match'); Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test3 does not match'); Check(not Assigned(method.CodeAddress), 'Code address of Test3 is not Nil'); CheckEquals(method.VirtualIndex, 5, 'Virtual index of Test3 does not match'); Check(not Assigned(method.ReturnType), 'Return type of Test3 is not Nil'); params := method.GetParameters; CheckEquals(4, Length(params), 'Parameter count of Test3 does not match'); param := params[0]; CheckEquals(param.Name, 'aArg1', 'Parameter name of Test3.aArg1 does not match'); Check(param.Flags = [], 'Parameter flags of Test3.aArg1 do not match'); Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg1 is Nil'); Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test3.aArg1 is not an ordinal'); param := params[1]; CheckEquals(param.Name, 'aArg2', 'Parameter name of Test3.aArg2 does not match'); Check(param.Flags = [pfConst], 'Parameter flags of Test3.aArg2 do not match'); Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg2 is Nil'); Check(param.ParamType.TypeKind = tkAnsiString, 'Parameter type of Test3.aArg2 is not a string'); param := params[2]; CheckEquals(param.Name, 'aArg3', 'Parameter name of Test3.aArg3 does not match'); Check(param.Flags = [pfVar], 'Parameter flags of Test3.aArg3 do not match'); Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg3 is Nil'); Check(param.ParamType.TypeKind = {$ifdef fpc}tkBool{$else}tkEnumeration{$endif}, 'Parameter type of Test3.aArg3 is not a boolean'); param := params[3]; CheckEquals(param.Name, 'aArg4', 'Parameter name of Test3.aArg4 does not match'); Check(param.Flags = [pfOut], 'Parameter flags of Test3.aArg4 do not match'); Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg4 is Nil'); Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test3.aArg4 is not a string'); method := methods[3]; CheckEquals(method.Name, 'Test4', 'Method name of Test4 does not match'); Check(method.CallingConvention = DefaultCC, 'Calling convention of Test4 does not match'); Check(method.MethodKind = mkFunction, 'Method kind of Test4 does not match'); Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test4 does not match'); Check(not Assigned(method.CodeAddress), 'Code address of Test4 is not Nil'); CheckEquals(method.VirtualIndex, 6, 'Virtual index of Test4 does not match'); Check(Assigned(method.ReturnType), 'Return type of Test4 is not Nil'); Check(method.ReturnType.TypeKind = tkAnsiString, 'Return type of Test4 is not a string'); params := method.GetParameters; CheckEquals(2, Length(params), 'Parameter count of Test4 does not match'); param := params[0]; CheckEquals(param.Name, 'aArg1', 'Parameter name of Test4.aArg1 does not match'); Check(param.Flags = [pfArray, pfReference], 'Parameter flags of Test4.aArg1 do not match'); Check(Assigned(param.ParamType), 'Parameter type of Test4.aArg1 is Nil'); Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test4.aArg1 is not an ordinal'); param := params[1]; CheckEquals(param.Name, 'aArg2', 'Parameter name of Test4.aArg2 does not match'); Check(param.Flags = [pfArray, pfReference], 'Parameter flags of Test4.aArg2 do not match'); Check(Assigned(param.ParamType), 'Parameter type of Test4.aArg2 is Nil'); Check(param.ParamType.TypeKind = tkRecord, 'Parameter type of Test4.aArg2 is not a record'); finally context.Free; end; end; procedure TTestCase1.TestRawThunk; var intf: IInterface; begin { we test the raw thunking by instantiating a TVirtualInterface of IInterface } { this does not require a function call manager as the thunking is implemented directly inside the RTTI unit } try intf := TVirtualInterface.Create(PTypeInfo(TypeInfo(IInterface))) as IInterface; except on e: ENotImplemented do Ignore('RawThunk not implemented'); end; { if all went well QueryInterface and _AddRef were called and now we call _Release as well } intf := Nil; end; {$ifdef fpc} procedure TTestCase1.TestInterfaceRaw; var context: TRttiContext; t: TRttiType; ti: TRttiInterfaceType; begin context := TRttiContext.Create; try t := context.GetType(TypeInfo(ICORBATest)); Check(t is TRttiInterfaceType, 'Type is not a raw interface type'); Check(not Assigned(t.BaseType), 'Base type is assigned'); ti := TRttiInterfaceType(t); Check(not Assigned(ti.BaseType), 'Base type is assigned'); finally context.Free; end; end; {$endif} procedure TTestCase1.TestProcVar; var context: TRttiContext; t: TRttiType; p: TRttiProcedureType; params: {$ifdef fpc}specialize{$endif} TArray; begin context := TRttiContext.Create; try t := context.GetType(PTypeInfo(TypeInfo(TTestProc))); Check(Assigned(t), 'Rtti Type is Nil'); Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable'); Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type'); p := t as TRttiProcedureType; Check(p.CallingConvention = DefaultCC, 'Calling convention does not match'); Check(not Assigned(p.ReturnType), 'Return type is assigned'); CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters'); t := context.GetType(PTypeInfo(TypeInfo(TTestFunc1))); Check(Assigned(t), 'Rtti Type is Nil'); Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable'); Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type'); p := t as TRttiProcedureType; Check(p.CallingConvention = DefaultCC, 'Calling convention does not match'); Check(Assigned(p.ReturnType), 'Return type is not assigned'); //Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type'); CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters'); t := context.GetType(PTypeInfo(TypeInfo(TTestFunc2))); Check(Assigned(t), 'Rtti Type is Nil'); Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable'); Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type'); p := t as TRttiProcedureType; Check(p.CallingConvention = DefaultCC, 'Calling convention does not match'); Check(Assigned(p.ReturnType), 'Return type is not assigned'); Check(p.ReturnType is TRttiStringType, 'Return type is not a string type'); params := p.GetParameters; CheckEquals(2, Length(params), 'Procedure variable has incorrect amount of parameters'); Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type'); //Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type'); Check(pfArray in params[1].Flags, 'Parameter 2 is not an array'); Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array'); finally context.Free; end; end; procedure TTestCase1.TestMethod; var context: TRttiContext; t: TRttiType; m: TRttiMethodType; params: {$ifdef fpc}specialize{$endif} TArray; begin context := TRttiContext.Create; try t := context.GetType(PTypeInfo(TypeInfo(TTestMethod))); Check(Assigned(t), 'Rtti Type is Nil'); Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable'); Check(t is TRttiMethodType, 'Rtti Type is not a method type'); m := t as TRttiMethodType; Check(m.CallingConvention = DefaultCC, 'Calling convention does not match'); Check(not Assigned(m.ReturnType), 'Return type is assigned'); CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters'); t := context.GetType(PTypeInfo(TypeInfo(TTestMethod1))); Check(Assigned(t), 'Rtti Type is Nil'); Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable'); Check(t is TRttiMethodType, 'Rtti Type is not a method type'); m := t as TRttiMethodType; Check(m.CallingConvention = DefaultCC, 'Calling convention does not match'); Check(Assigned(m.ReturnType), 'Return type is not assigned'); //Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type'); CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters'); t := context.GetType(PTypeInfo(TypeInfo(TTestMethod2))); Check(Assigned(t), 'Rtti Type is Nil'); Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable'); Check(t is TRttiMethodType, 'Rtti Type is not a method type'); m := t as TRttiMethodType; Check(m.CallingConvention = DefaultCC, 'Calling convention does not match'); Check(Assigned(m.ReturnType), 'Return type is not assigned'); Check(m.ReturnType is TRttiStringType, 'Return type is not a string type'); params := m.GetParameters; CheckEquals(2, Length(params), 'Method variable has incorrect amount of parameters'); Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type'); //Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type'); Check(pfArray in params[1].Flags, 'Parameter 2 is not an array'); Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array'); finally context.Free; end; end; initialization {$ifdef fpc} RegisterTest(TTestCase1); {$else fpc} RegisterTest(TTestCase1.Suite); {$endif fpc} end.