mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-30 17:02:29 +02:00
802 lines
21 KiB
ObjectPascal
802 lines
21 KiB
ObjectPascal
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 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 TestMakeObject;
|
|
procedure TestGetIsReadable;
|
|
procedure TestIsWritable;
|
|
|
|
procedure TestIsManaged;
|
|
end;
|
|
|
|
implementation
|
|
|
|
type
|
|
|
|
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;
|
|
|
|
{ TTestValueClass }
|
|
|
|
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;
|
|
|
|
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;
|
|
TTestMethod = procedure 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;
|
|
|
|
{$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.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);
|
|
CheckEquals(TTestValueClass(AValue.AsObject).AInteger, 54329);
|
|
ATestClass.Free;
|
|
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.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));
|
|
CheckEquals(LType.Name, 'LongInt');
|
|
|
|
LContext.Free;
|
|
end;
|
|
|
|
procedure TTestCase1.GetClassProperties;
|
|
var
|
|
LContext: TRttiContext;
|
|
LType: TRttiType;
|
|
PropList: {$ifdef fpc}specialize{$endif} TArray<TRttiProperty>;
|
|
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);
|
|
|
|
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.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<byte>)), 'IsManaged for tkDynArray');
|
|
{$else}
|
|
CheckEquals(true, IsManaged(TypeInfo(TArray<byte>)), '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');
|
|
CheckEquals(false, IsManaged(TypeInfo(TTestMethod)), 'IsManaged for tkMethod');
|
|
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');
|
|
CheckEquals(false, IsManaged(TypeInfo(file)), 'IsManaged for tkFile');
|
|
CheckEquals(false, IsManaged(TypeInfo(TClass)), 'IsManaged for tkClassRef');
|
|
CheckEquals(false, IsManaged(TypeInfo(Pointer)), 'IsManaged for tkPointer');
|
|
CheckEquals(false, IsManaged(nil), 'IsManaged for nil');
|
|
end;
|
|
|
|
initialization
|
|
{$ifdef fpc}
|
|
RegisterTest(TTestCase1);
|
|
{$else fpc}
|
|
RegisterTest(TTestCase1.Suite);
|
|
{$endif fpc}
|
|
end.
|
|
|