mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 10:07:54 +02:00
* partial fix for Mantis #36358: apply partial, adjusted patch by Imants Gulbis to extend TRttiProperty.SetValue and TRttiProperty.GetValue
* extended test suite git-svn-id: trunk@43780 -
This commit is contained in:
svenbarth
parent
be1439e93e
commit
9853ed53e8
@ -3914,16 +3914,30 @@ function TRttiProperty.GetValue(Instance: pointer): TValue;
|
||||
end;
|
||||
|
||||
var
|
||||
s: string;
|
||||
Values: record
|
||||
case Integer of
|
||||
0: (Enum: Int64);
|
||||
1: (Bool: Int64);
|
||||
2: (Int: Int64);
|
||||
3: (Ch: Byte);
|
||||
4: (Wch: Word);
|
||||
5: (I64: Int64);
|
||||
6: (Si: Single);
|
||||
7: (Db: Double);
|
||||
8: (Ex: Extended);
|
||||
9: (Cur: Currency);
|
||||
10: (Cp: Comp);
|
||||
11: (A: Pointer;)
|
||||
end;
|
||||
s: String;
|
||||
ss: ShortString;
|
||||
i: int64;
|
||||
c: Char;
|
||||
wc: WideChar;
|
||||
O: TObject;
|
||||
Int: IUnknown;
|
||||
begin
|
||||
case FPropinfo^.PropType^.Kind of
|
||||
tkSString:
|
||||
begin
|
||||
ss := GetStrProp(TObject(Instance), FPropInfo);
|
||||
ss := ShortString(GetStrProp(TObject(Instance), FPropInfo));
|
||||
TValue.Make(@ss, FPropInfo^.PropType, result);
|
||||
end;
|
||||
tkAString:
|
||||
@ -3931,38 +3945,100 @@ begin
|
||||
s := GetStrProp(TObject(Instance), FPropInfo);
|
||||
TValue.Make(@s, FPropInfo^.PropType, result);
|
||||
end;
|
||||
tkEnumeration:
|
||||
begin
|
||||
Values.Enum := Integer(GetOrdProp(TObject(Instance), FPropInfo));
|
||||
TValue.Make(@Values.Enum, FPropInfo^.PropType, result);
|
||||
end;
|
||||
tkBool:
|
||||
begin
|
||||
i := GetOrdProp(TObject(Instance), FPropInfo);
|
||||
ValueFromBool(i);
|
||||
Values.Bool := GetOrdProp(TObject(Instance), FPropInfo);
|
||||
ValueFromBool(Values.Bool);
|
||||
end;
|
||||
tkInteger:
|
||||
begin
|
||||
i := GetOrdProp(TObject(Instance), FPropInfo);
|
||||
ValueFromInt(i);
|
||||
Values.Int := GetOrdProp(TObject(Instance), FPropInfo);
|
||||
ValueFromInt(Values.Int);
|
||||
end;
|
||||
tkChar:
|
||||
begin
|
||||
c := AnsiChar(GetOrdProp(TObject(Instance), FPropInfo));
|
||||
TValue.Make(@c, FPropInfo^.PropType, result);
|
||||
Values.Ch := Byte(GetOrdProp(TObject(Instance), FPropInfo));
|
||||
TValue.Make(@Values.Ch, FPropInfo^.PropType, result);
|
||||
end;
|
||||
tkWChar:
|
||||
begin
|
||||
wc := WideChar(GetOrdProp(TObject(Instance), FPropInfo));
|
||||
TValue.Make(@wc, FPropInfo^.PropType, result);
|
||||
Values.Wch := Word(GetOrdProp(TObject(Instance), FPropInfo));
|
||||
TValue.Make(@Values.Wch, FPropInfo^.PropType, result);
|
||||
end;
|
||||
tkInt64,
|
||||
tkQWord:
|
||||
begin
|
||||
i := GetOrdProp(TObject(Instance), FPropInfo);
|
||||
TValue.Make(@i, FPropInfo^.PropType, result);
|
||||
Values.I64 := GetOrdProp(TObject(Instance), FPropInfo);
|
||||
TValue.Make(@Values.I64, FPropInfo^.PropType, result);
|
||||
end;
|
||||
tkClass:
|
||||
begin
|
||||
O := GetObjectProp(TObject(Instance), FPropInfo);
|
||||
TValue.Make(@O, FPropInfo^.PropType, Result);
|
||||
end;
|
||||
tkInterface:
|
||||
begin
|
||||
Int := GetInterfaceProp(TObject(Instance), FPropInfo);
|
||||
TValue.Make(@Int, FPropInfo^.PropType, Result);
|
||||
end;
|
||||
tkFloat:
|
||||
begin
|
||||
case GetTypeData(FPropInfo^.PropType)^.FloatType of
|
||||
ftCurr :
|
||||
begin
|
||||
{$IfDef FPC_CURRENCY_IS_INT64}
|
||||
Values.Cur := Currency(GetOrdProp(TObject(Instance), FPropInfo)) / 10000;
|
||||
{$Else}
|
||||
Values.Cur := Currency(GetFloatProp(TObject(Instance), FPropInfo));
|
||||
{$EndIf}
|
||||
TValue.Make(@Values.Cur, FPropInfo^.PropType, Result);
|
||||
end;
|
||||
ftSingle :
|
||||
begin
|
||||
Values.Si := Single(GetFloatProp(TObject(Instance), FPropInfo));
|
||||
TValue.Make(@Values.Si, FPropInfo^.PropType, Result);
|
||||
end;
|
||||
ftDouble :
|
||||
begin
|
||||
Values.Db := Double(GetFloatProp(TObject(Instance), FPropInfo));
|
||||
TValue.Make(@Values.Db, FPropInfo^.PropType, Result);
|
||||
end;
|
||||
ftExtended:
|
||||
begin
|
||||
Values.Ex := GetFloatProp(TObject(Instance), FPropInfo);
|
||||
TValue.Make(@Values.Ex, FPropInfo^.PropType, Result);
|
||||
end;
|
||||
ftComp :
|
||||
begin
|
||||
{$IfDef FPC_COMP_IS_INT64}
|
||||
Values.Cp := Comp(GetOrdProp(TObject(Instance), FPropInfo));
|
||||
{$Else}
|
||||
Values.Cp := Comp(GetFloatProp(TObject(Instance), FPropInfo));
|
||||
{$EndIf}
|
||||
TValue.Make(@Values.Cp, FPropInfo^.PropType, Result);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
tkDynArray:
|
||||
begin
|
||||
Values.A := GetDynArrayProp(TObject(Instance), FPropInfo);
|
||||
TValue.Make(@Values.A, FPropInfo^.PropType, Result);
|
||||
end
|
||||
else
|
||||
result := TValue.Empty;
|
||||
end
|
||||
end;
|
||||
|
||||
procedure TRttiProperty.SetValue(Instance: pointer; const AValue: TValue);
|
||||
{$if defined(FPC_CURRENCY_IS_INT64) or defined(FPC_COMP_IS_INT64)}
|
||||
var
|
||||
td: PTypeData;
|
||||
{$endif}
|
||||
begin
|
||||
case FPropinfo^.PropType^.Kind of
|
||||
tkSString,
|
||||
@ -3973,8 +4049,31 @@ begin
|
||||
tkQWord,
|
||||
tkChar,
|
||||
tkBool,
|
||||
tkWChar:
|
||||
tkWChar,
|
||||
tkEnumeration:
|
||||
SetOrdProp(TObject(Instance), FPropInfo, AValue.AsOrdinal);
|
||||
tkClass:
|
||||
SetObjectProp(TObject(Instance), FPropInfo, AValue.AsObject);
|
||||
tkInterface:
|
||||
SetInterfaceProp(TObject(Instance), FPropInfo, AValue.AsInterface);
|
||||
tkFloat: begin
|
||||
{$if defined(FPC_CURRENCY_IS_INT64) or defined(FPC_COMP_IS_INT64)}
|
||||
td := GetTypeData(FPropInfo^.PropType);
|
||||
{$if defined(FPC_CURRENCY_IS_INT64)}
|
||||
if td^.FloatType = ftCurr then
|
||||
SetOrdProp(TObject(Instance), FPropInfo, Trunc(AValue.AsExtended * 10000))
|
||||
else
|
||||
{$endif}
|
||||
{$if defined(FPC_COMP_IS_INT64)}
|
||||
if td^.FloatType = ftComp then
|
||||
SetOrdProp(TObject(Instance), FPropInfo, Trunc(AValue.AsExtended))
|
||||
else
|
||||
{$endif}
|
||||
{$endif}
|
||||
SetFloatProp(TObject(Instance), FPropInfo, AValue.AsExtended);
|
||||
end;
|
||||
tkDynArray:
|
||||
SetDynArrayProp(TObject(Instance), FPropInfo, PPointer(AValue.GetReferenceToRawData)^);
|
||||
else
|
||||
raise exception.createFmt(SErrUnableToSetValueForType, [PropertyType.Name]);
|
||||
end
|
||||
|
||||
@ -38,11 +38,23 @@ type
|
||||
procedure TestPropGetValueProcInteger;
|
||||
procedure TestPropGetValueProcBoolean;
|
||||
procedure TestPropGetValueProcShortString;
|
||||
procedure TestPropGetValueObject;
|
||||
procedure TestPropGetValueInterface;
|
||||
procedure TestPropGetValueFloat;
|
||||
procedure TestPropGetValueDynArray;
|
||||
procedure TestPropGetValueEnumeration;
|
||||
procedure TestPropGetValueChars;
|
||||
|
||||
procedure TestPropSetValueString;
|
||||
procedure TestPropSetValueInteger;
|
||||
procedure TestPropSetValueBoolean;
|
||||
procedure TestPropSetValueShortString;
|
||||
procedure TestPropSetValueObject;
|
||||
procedure TestPropSetValueInterface;
|
||||
procedure TestPropSetValueFloat;
|
||||
procedure TestPropSetValueDynArray;
|
||||
procedure TestPropSetValueEnumeration;
|
||||
procedure TestPropSetValueChars;
|
||||
|
||||
procedure TestGetValueStringCastError;
|
||||
procedure TestGetIsReadable;
|
||||
@ -116,6 +128,9 @@ type
|
||||
TGetClassPropertiesSub = class(TGetClassProperties)
|
||||
|
||||
end;
|
||||
|
||||
TTestDynArray = array of Integer;
|
||||
TTestEnumeration = (en1, en2, en3, en4);
|
||||
{$M-}
|
||||
|
||||
{ TTestValueClass }
|
||||
@ -123,18 +138,38 @@ type
|
||||
{$M+}
|
||||
TTestValueClass = class
|
||||
private
|
||||
FAArray: TTestDynArray;
|
||||
FAChar: AnsiChar;
|
||||
FAComp: Comp;
|
||||
FACurrency: Currency;
|
||||
FADouble: Double;
|
||||
FAEnumeration: TTestEnumeration;
|
||||
FAExtended: Extended;
|
||||
FAInteger: integer;
|
||||
FAObject: TObject;
|
||||
FASingle: Single;
|
||||
FAString: string;
|
||||
FABoolean: boolean;
|
||||
FAShortString: ShortString;
|
||||
FAUnknown: IUnknown;
|
||||
FAWideChar: WideChar;
|
||||
function GetAInteger: integer;
|
||||
function GetAString: string;
|
||||
function GetABoolean: boolean;
|
||||
function GetAShortString: ShortString;
|
||||
procedure SetWriteOnly(AValue: integer);
|
||||
published
|
||||
property AArray: TTestDynArray read FAArray write FAArray;
|
||||
property AEnumeration: TTestEnumeration read FAEnumeration write FAEnumeration;
|
||||
property AInteger: Integer read FAInteger write FAInteger;
|
||||
property AString: string read FAString write FAString;
|
||||
property ASingle: Single read FASingle write FASingle;
|
||||
property ADouble: Double read FADouble write FADouble;
|
||||
property AExtended: Extended read FAExtended write FAExtended;
|
||||
property ACurrency: Currency read FACurrency write FACurrency;
|
||||
property AObject: TObject read FAObject write FAObject;
|
||||
property AUnknown: IUnknown read FAUnknown write FAUnknown;
|
||||
property AComp: Comp read FAComp write FAComp;
|
||||
property ABoolean: boolean read FABoolean write FABoolean;
|
||||
property AShortString: ShortString read FAShortString write FAShortString;
|
||||
property AGetInteger: Integer read GetAInteger;
|
||||
@ -142,6 +177,8 @@ type
|
||||
property AGetBoolean: boolean read GetABoolean;
|
||||
property AGetShortString: ShortString read GetAShortString;
|
||||
property AWriteOnly: integer write SetWriteOnly;
|
||||
property AChar: AnsiChar read FAChar write FAChar;
|
||||
property AWideChar: WideChar read FAWideChar write FAWideChar;
|
||||
end;
|
||||
{$M-}
|
||||
|
||||
@ -1061,6 +1098,225 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropGetValueObject;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValue: TValue;
|
||||
O: TObject;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
O := TObject.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
ATestClass.AObject := O;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
Check(assigned(ARttiType));
|
||||
AProperty := ARttiType.GetProperty('AObject');
|
||||
AValue := AProperty.GetValue(ATestClass);
|
||||
CheckEquals(O.GetHashCode, AValue.AsObject.GetHashCode);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
CheckEquals(O.GetHashCode, AValue.AsObject.GetHashCode);
|
||||
finally
|
||||
c.Free;
|
||||
O.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropGetValueInterface;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValue: TValue;
|
||||
i: IInterface;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
i := TInterfacedObject.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
ATestClass.AUnknown := i;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
Check(assigned(ARttiType));
|
||||
AProperty := ARttiType.GetProperty('AUnknown');
|
||||
AValue := AProperty.GetValue(ATestClass);
|
||||
Check(i = AValue.AsInterface);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
Check(i = AValue.AsInterface);
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropGetValueFloat;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValueS, AValueD, AValueE, AValueC, AValueCm: TValue;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
ATestClass.ASingle := 1.1;
|
||||
ATestClass.ADouble := 2.2;
|
||||
ATestClass.AExtended := 3.3;
|
||||
ATestClass.ACurrency := 4;
|
||||
ATestClass.AComp := 5;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
Check(assigned(ARttiType));
|
||||
|
||||
AProperty := ARttiType.GetProperty('ASingle');
|
||||
AValueS := AProperty.GetValue(ATestClass);
|
||||
CheckEquals(1.1, AValueS.AsExtended, 0.001);
|
||||
|
||||
AProperty := ARttiType.GetProperty('ADouble');
|
||||
AValueD := AProperty.GetValue(ATestClass);
|
||||
CheckEquals(2.2, AValueD.AsExtended, 0.001);
|
||||
|
||||
AProperty := ARttiType.GetProperty('AExtended');
|
||||
AValueE := AProperty.GetValue(ATestClass);
|
||||
CheckEquals(3.3, AValueE.AsExtended, 0.001);
|
||||
|
||||
AProperty := ARttiType.GetProperty('ACurrency');
|
||||
AValueC := AProperty.GetValue(ATestClass);
|
||||
CheckEquals(4.0, AValueC.AsExtended, 0.001);
|
||||
|
||||
AProperty := ARttiType.GetProperty('AComp');
|
||||
AValueCm := AProperty.GetValue(ATestClass);
|
||||
CheckEquals(5.0, AValueCm.AsExtended, 0.001);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
|
||||
CheckEquals(1.1, AValueS.AsExtended, 0.001);
|
||||
CheckEquals(2.2, AValueD.AsExtended, 0.001);
|
||||
CheckEquals(3.3, AValueE.AsExtended, 0.001);
|
||||
CheckEquals(4.0, AValueC.AsExtended, 0.001);
|
||||
CheckEquals(5.0, AValueCm.AsExtended, 0.001);
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropGetValueDynArray;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValue: TValue;
|
||||
A: TTestDynArray;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
A := [1, 2, 3, 4];
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
ATestClass.AArray := A;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
Check(assigned(ARttiType));
|
||||
AProperty := ARttiType.GetProperty('AArray');
|
||||
AValue := AProperty.GetValue(ATestClass);
|
||||
|
||||
CheckEquals(A[0], AValue.GetArrayElement(0).AsInteger);
|
||||
CheckEquals(A[1], AValue.GetArrayElement(1).AsInteger);
|
||||
CheckEquals(A[2], AValue.GetArrayElement(2).AsInteger);
|
||||
CheckEquals(A[3], AValue.GetArrayElement(3).AsInteger);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropGetValueEnumeration;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValue: TValue;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
ATestClass.AEnumeration := en3;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
Check(assigned(ARttiType));
|
||||
AProperty := ARttiType.GetProperty('AEnumeration');
|
||||
AValue := AProperty.GetValue(ATestClass);
|
||||
CheckEquals(Ord(en3),AValue.AsOrdinal);
|
||||
ATestClass.AEnumeration := en1;
|
||||
CheckEquals(Ord(en3), AValue.AsOrdinal);
|
||||
CheckEquals('en3', AValue.ToString);
|
||||
CheckEquals(True, AValue.IsOrdinal);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
|
||||
CheckEquals(Ord(en3),AValue.AsOrdinal);
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropGetValueChars;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValueC, AValueW: TValue;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
ATestClass.AChar := 'C';
|
||||
ATestClass.AWideChar := 'W';
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
Check(assigned(ARttiType));
|
||||
|
||||
AProperty := ARttiType.GetProperty('AChar');
|
||||
AValueC := AProperty.GetValue(ATestClass);
|
||||
CheckEquals('C',AValueC.AsAnsiChar);
|
||||
ATestClass.AChar := 'N';
|
||||
CheckEquals('C', AValueC.AsAnsiChar);
|
||||
CheckEquals('C', AValueC.ToString);
|
||||
CheckEquals(True, AValueC.IsOrdinal);
|
||||
|
||||
AProperty := ARttiType.GetProperty('AWideChar');
|
||||
AValueW := AProperty.GetValue(ATestClass);
|
||||
CheckEquals('W',AValueW.AsWideChar);
|
||||
ATestClass.AWideChar := 'Z';
|
||||
CheckEquals('W', AValueW.AsWideChar);
|
||||
CheckEquals('W', AValueW.ToString);
|
||||
CheckEquals(True, AValueW.IsOrdinal);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
|
||||
CheckEquals('C',AValueC.AsAnsiChar);
|
||||
CheckEquals('W',AValueW.AsWideChar);
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropSetValueString;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
@ -1184,6 +1440,9 @@ begin
|
||||
CheckEquals(ATestClass.AShortString, ss);
|
||||
ss := 'Foobar';
|
||||
CheckEquals(ATestClass.AShortString, 'Hello World');
|
||||
|
||||
AProperty.SetValue(ATestClass, 'Another string');
|
||||
CheckEquals(ATestClass.AShortString, 'Another string');
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
@ -1192,6 +1451,258 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropSetValueObject;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValue: TValue;
|
||||
O: TObject;
|
||||
TypeInfo: PTypeInfo;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
AProperty := ARttiType.GetProperty('AObject');
|
||||
TypeInfo := GetPropInfo(ATestClass, 'AObject')^.PropType;
|
||||
|
||||
O := TPersistent.Create;
|
||||
TValue.Make(@O, TypeInfo, AValue);
|
||||
AProperty.SetValue(ATestClass, AValue);
|
||||
CheckEquals(ATestClass.AObject.GetHashCode, O.GetHashCode);
|
||||
O.Free;
|
||||
|
||||
O := TPersistent.Create;
|
||||
AProperty.SetValue(ATestClass, O);
|
||||
CheckEquals(ATestClass.AObject.GetHashCode, O.GetHashCode);
|
||||
O.Free;
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropSetValueInterface;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValue: TValue;
|
||||
TypeInfo: PTypeInfo;
|
||||
i: IInterface;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
AProperty := ARttiType.GetProperty('AUnknown');
|
||||
TypeInfo := GetPropInfo(ATestClass, 'AUnknown')^.PropType;
|
||||
|
||||
i := TInterfacedObject.Create;
|
||||
TValue.Make(@i, TypeInfo, AValue);
|
||||
AProperty.SetValue(ATestClass, AValue);
|
||||
Check(ATestClass.AUnknown = i);
|
||||
|
||||
i := TInterfacedObject.Create;
|
||||
AProperty.SetValue(ATestClass, i);
|
||||
Check(ATestClass.AUnknown = i);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropSetValueFloat;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValue: TValue;
|
||||
TypeInfo: PTypeInfo;
|
||||
S: Single;
|
||||
D: Double;
|
||||
E: Extended;
|
||||
Cur: Currency;
|
||||
Cmp: Comp;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
|
||||
AProperty := ARttiType.GetProperty('ASingle');
|
||||
TypeInfo := GetPropInfo(ATestClass, 'ASingle')^.PropType;
|
||||
|
||||
S := 1.1;
|
||||
TValue.Make(@S, TypeInfo, AValue);
|
||||
AProperty.SetValue(ATestClass, AValue);
|
||||
CheckEquals(S, ATestClass.ASingle, 0.001);
|
||||
|
||||
S := 1.2;
|
||||
AProperty.SetValue(ATestClass, S);
|
||||
CheckEquals(S, ATestClass.ASingle, 0.001);
|
||||
|
||||
AProperty := ARttiType.GetProperty('ADouble');
|
||||
TypeInfo := GetPropInfo(ATestClass, 'ADouble')^.PropType;
|
||||
|
||||
D := 2.1;
|
||||
TValue.Make(@D, TypeInfo, AValue);
|
||||
AProperty.SetValue(ATestClass, AValue);
|
||||
CheckEquals(D, ATestClass.ADouble, 0.001);
|
||||
|
||||
D := 2.2;
|
||||
AProperty.SetValue(ATestClass, D);
|
||||
CheckEquals(D, ATestClass.ADouble, 0.001);
|
||||
|
||||
AProperty := ARttiType.GetProperty('AExtended');
|
||||
TypeInfo := GetPropInfo(ATestClass, 'AExtended')^.PropType;
|
||||
|
||||
E := 3.1;
|
||||
TValue.Make(@E, TypeInfo, AValue);
|
||||
AProperty.SetValue(ATestClass, AValue);
|
||||
CheckEquals(E, ATestClass.AExtended, 0.001);
|
||||
|
||||
E := 3.2;
|
||||
AProperty.SetValue(ATestClass, E);
|
||||
CheckEquals(E, ATestClass.AExtended, 0.001);
|
||||
|
||||
AProperty := ARttiType.GetProperty('ACurrency');
|
||||
TypeInfo := GetPropInfo(ATestClass, 'ACurrency')^.PropType;
|
||||
|
||||
Cur := 40;
|
||||
TValue.Make(@Cur, TypeInfo, AValue);
|
||||
AProperty.SetValue(ATestClass, AValue);
|
||||
CheckEquals(Cur, ATestClass.ACurrency, 0.001);
|
||||
|
||||
Cur := 41;
|
||||
AProperty.SetValue(ATestClass, Cur);
|
||||
CheckEquals(Cur, ATestClass.ACurrency, 0.001);
|
||||
|
||||
AProperty := ARttiType.GetProperty('AComp');
|
||||
TypeInfo := GetPropInfo(ATestClass, 'AComp')^.PropType;
|
||||
|
||||
Cmp := 50;
|
||||
TValue.Make(@Cmp, TypeInfo, AValue);
|
||||
AProperty.SetValue(ATestClass, AValue);
|
||||
CheckEquals(Cmp, ATestClass.AComp, 0.001);
|
||||
|
||||
Cmp := 51;
|
||||
AProperty.SetValue(ATestClass, Cmp);
|
||||
CheckEquals(Cmp, ATestClass.AComp, 0.001);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropSetValueDynArray;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValue: TValue;
|
||||
A: TTestDynArray;
|
||||
TypeInfo: PTypeInfo;
|
||||
i: Integer;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
AProperty := ARttiType.GetProperty('AArray');
|
||||
TypeInfo := GetPropInfo(ATestClass, 'AArray')^.PropType;
|
||||
|
||||
A := [1, 2, 3, 4, 5];
|
||||
TValue.Make(@A, TypeInfo, AValue);
|
||||
AProperty.SetValue(ATestClass, AValue);
|
||||
|
||||
for i := 0 to High(A) do
|
||||
CheckEquals(A[i], ATestClass.AArray[i]);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropSetValueEnumeration;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValue: TValue;
|
||||
E: TTestEnumeration;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
AProperty := ARttiType.GetProperty('AEnumeration');
|
||||
|
||||
E := en2;
|
||||
TValue.Make(@E, TypeInfo(TTestEnumeration), AValue);
|
||||
AProperty.SetValue(ATestClass, AValue);
|
||||
CheckEquals(Ord(E), Ord(ATestClass.AEnumeration));
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropSetValueChars;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
c: TRttiContext;
|
||||
ARttiType: TRttiType;
|
||||
AProperty: TRttiProperty;
|
||||
AValueC, AValueW: TValue;
|
||||
begin
|
||||
c := TRttiContext.Create;
|
||||
try
|
||||
ATestClass := TTestValueClass.Create;
|
||||
ATestClass.AChar := 'C';
|
||||
ATestClass.AWideChar := 'W';
|
||||
try
|
||||
ARttiType := c.GetType(ATestClass.ClassInfo);
|
||||
Check(assigned(ARttiType));
|
||||
|
||||
AProperty := ARttiType.GetProperty('AChar');
|
||||
AValueC := AProperty.GetValue(ATestClass);
|
||||
CheckEquals('C', AValueC.AsAnsiChar);
|
||||
|
||||
AProperty := ARttiType.GetProperty('AWideChar');
|
||||
AValueW := AProperty.GetValue(ATestClass);
|
||||
CheckEquals('W', AValueW.AsWideChar);
|
||||
finally
|
||||
AtestClass.Free;
|
||||
end;
|
||||
CheckEquals('C', AValueC.AsAnsiChar);
|
||||
CheckEquals('W', AValueW.AsWideChar);
|
||||
finally
|
||||
c.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestPropGetValueProcInteger;
|
||||
var
|
||||
ATestClass : TTestValueClass;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user