mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-14 10:49:09 +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:
parent
be1439e93e
commit
9853ed53e8
@ -3914,16 +3914,30 @@ function TRttiProperty.GetValue(Instance: pointer): TValue;
|
|||||||
end;
|
end;
|
||||||
|
|
||||||
var
|
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;
|
ss: ShortString;
|
||||||
i: int64;
|
O: TObject;
|
||||||
c: Char;
|
Int: IUnknown;
|
||||||
wc: WideChar;
|
|
||||||
begin
|
begin
|
||||||
case FPropinfo^.PropType^.Kind of
|
case FPropinfo^.PropType^.Kind of
|
||||||
tkSString:
|
tkSString:
|
||||||
begin
|
begin
|
||||||
ss := GetStrProp(TObject(Instance), FPropInfo);
|
ss := ShortString(GetStrProp(TObject(Instance), FPropInfo));
|
||||||
TValue.Make(@ss, FPropInfo^.PropType, result);
|
TValue.Make(@ss, FPropInfo^.PropType, result);
|
||||||
end;
|
end;
|
||||||
tkAString:
|
tkAString:
|
||||||
@ -3931,38 +3945,100 @@ begin
|
|||||||
s := GetStrProp(TObject(Instance), FPropInfo);
|
s := GetStrProp(TObject(Instance), FPropInfo);
|
||||||
TValue.Make(@s, FPropInfo^.PropType, result);
|
TValue.Make(@s, FPropInfo^.PropType, result);
|
||||||
end;
|
end;
|
||||||
|
tkEnumeration:
|
||||||
|
begin
|
||||||
|
Values.Enum := Integer(GetOrdProp(TObject(Instance), FPropInfo));
|
||||||
|
TValue.Make(@Values.Enum, FPropInfo^.PropType, result);
|
||||||
|
end;
|
||||||
tkBool:
|
tkBool:
|
||||||
begin
|
begin
|
||||||
i := GetOrdProp(TObject(Instance), FPropInfo);
|
Values.Bool := GetOrdProp(TObject(Instance), FPropInfo);
|
||||||
ValueFromBool(i);
|
ValueFromBool(Values.Bool);
|
||||||
end;
|
end;
|
||||||
tkInteger:
|
tkInteger:
|
||||||
begin
|
begin
|
||||||
i := GetOrdProp(TObject(Instance), FPropInfo);
|
Values.Int := GetOrdProp(TObject(Instance), FPropInfo);
|
||||||
ValueFromInt(i);
|
ValueFromInt(Values.Int);
|
||||||
end;
|
end;
|
||||||
tkChar:
|
tkChar:
|
||||||
begin
|
begin
|
||||||
c := AnsiChar(GetOrdProp(TObject(Instance), FPropInfo));
|
Values.Ch := Byte(GetOrdProp(TObject(Instance), FPropInfo));
|
||||||
TValue.Make(@c, FPropInfo^.PropType, result);
|
TValue.Make(@Values.Ch, FPropInfo^.PropType, result);
|
||||||
end;
|
end;
|
||||||
tkWChar:
|
tkWChar:
|
||||||
begin
|
begin
|
||||||
wc := WideChar(GetOrdProp(TObject(Instance), FPropInfo));
|
Values.Wch := Word(GetOrdProp(TObject(Instance), FPropInfo));
|
||||||
TValue.Make(@wc, FPropInfo^.PropType, result);
|
TValue.Make(@Values.Wch, FPropInfo^.PropType, result);
|
||||||
end;
|
end;
|
||||||
tkInt64,
|
tkInt64,
|
||||||
tkQWord:
|
tkQWord:
|
||||||
begin
|
begin
|
||||||
i := GetOrdProp(TObject(Instance), FPropInfo);
|
Values.I64 := GetOrdProp(TObject(Instance), FPropInfo);
|
||||||
TValue.Make(@i, FPropInfo^.PropType, result);
|
TValue.Make(@Values.I64, FPropInfo^.PropType, result);
|
||||||
end;
|
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
|
else
|
||||||
result := TValue.Empty;
|
result := TValue.Empty;
|
||||||
end
|
end
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TRttiProperty.SetValue(Instance: pointer; const AValue: TValue);
|
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
|
begin
|
||||||
case FPropinfo^.PropType^.Kind of
|
case FPropinfo^.PropType^.Kind of
|
||||||
tkSString,
|
tkSString,
|
||||||
@ -3973,8 +4049,31 @@ begin
|
|||||||
tkQWord,
|
tkQWord,
|
||||||
tkChar,
|
tkChar,
|
||||||
tkBool,
|
tkBool,
|
||||||
tkWChar:
|
tkWChar,
|
||||||
|
tkEnumeration:
|
||||||
SetOrdProp(TObject(Instance), FPropInfo, AValue.AsOrdinal);
|
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
|
else
|
||||||
raise exception.createFmt(SErrUnableToSetValueForType, [PropertyType.Name]);
|
raise exception.createFmt(SErrUnableToSetValueForType, [PropertyType.Name]);
|
||||||
end
|
end
|
||||||
|
@ -38,11 +38,23 @@ type
|
|||||||
procedure TestPropGetValueProcInteger;
|
procedure TestPropGetValueProcInteger;
|
||||||
procedure TestPropGetValueProcBoolean;
|
procedure TestPropGetValueProcBoolean;
|
||||||
procedure TestPropGetValueProcShortString;
|
procedure TestPropGetValueProcShortString;
|
||||||
|
procedure TestPropGetValueObject;
|
||||||
|
procedure TestPropGetValueInterface;
|
||||||
|
procedure TestPropGetValueFloat;
|
||||||
|
procedure TestPropGetValueDynArray;
|
||||||
|
procedure TestPropGetValueEnumeration;
|
||||||
|
procedure TestPropGetValueChars;
|
||||||
|
|
||||||
procedure TestPropSetValueString;
|
procedure TestPropSetValueString;
|
||||||
procedure TestPropSetValueInteger;
|
procedure TestPropSetValueInteger;
|
||||||
procedure TestPropSetValueBoolean;
|
procedure TestPropSetValueBoolean;
|
||||||
procedure TestPropSetValueShortString;
|
procedure TestPropSetValueShortString;
|
||||||
|
procedure TestPropSetValueObject;
|
||||||
|
procedure TestPropSetValueInterface;
|
||||||
|
procedure TestPropSetValueFloat;
|
||||||
|
procedure TestPropSetValueDynArray;
|
||||||
|
procedure TestPropSetValueEnumeration;
|
||||||
|
procedure TestPropSetValueChars;
|
||||||
|
|
||||||
procedure TestGetValueStringCastError;
|
procedure TestGetValueStringCastError;
|
||||||
procedure TestGetIsReadable;
|
procedure TestGetIsReadable;
|
||||||
@ -116,6 +128,9 @@ type
|
|||||||
TGetClassPropertiesSub = class(TGetClassProperties)
|
TGetClassPropertiesSub = class(TGetClassProperties)
|
||||||
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
TTestDynArray = array of Integer;
|
||||||
|
TTestEnumeration = (en1, en2, en3, en4);
|
||||||
{$M-}
|
{$M-}
|
||||||
|
|
||||||
{ TTestValueClass }
|
{ TTestValueClass }
|
||||||
@ -123,18 +138,38 @@ type
|
|||||||
{$M+}
|
{$M+}
|
||||||
TTestValueClass = class
|
TTestValueClass = class
|
||||||
private
|
private
|
||||||
|
FAArray: TTestDynArray;
|
||||||
|
FAChar: AnsiChar;
|
||||||
|
FAComp: Comp;
|
||||||
|
FACurrency: Currency;
|
||||||
|
FADouble: Double;
|
||||||
|
FAEnumeration: TTestEnumeration;
|
||||||
|
FAExtended: Extended;
|
||||||
FAInteger: integer;
|
FAInteger: integer;
|
||||||
|
FAObject: TObject;
|
||||||
|
FASingle: Single;
|
||||||
FAString: string;
|
FAString: string;
|
||||||
FABoolean: boolean;
|
FABoolean: boolean;
|
||||||
FAShortString: ShortString;
|
FAShortString: ShortString;
|
||||||
|
FAUnknown: IUnknown;
|
||||||
|
FAWideChar: WideChar;
|
||||||
function GetAInteger: integer;
|
function GetAInteger: integer;
|
||||||
function GetAString: string;
|
function GetAString: string;
|
||||||
function GetABoolean: boolean;
|
function GetABoolean: boolean;
|
||||||
function GetAShortString: ShortString;
|
function GetAShortString: ShortString;
|
||||||
procedure SetWriteOnly(AValue: integer);
|
procedure SetWriteOnly(AValue: integer);
|
||||||
published
|
published
|
||||||
|
property AArray: TTestDynArray read FAArray write FAArray;
|
||||||
|
property AEnumeration: TTestEnumeration read FAEnumeration write FAEnumeration;
|
||||||
property AInteger: Integer read FAInteger write FAInteger;
|
property AInteger: Integer read FAInteger write FAInteger;
|
||||||
property AString: string read FAString write FAString;
|
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 ABoolean: boolean read FABoolean write FABoolean;
|
||||||
property AShortString: ShortString read FAShortString write FAShortString;
|
property AShortString: ShortString read FAShortString write FAShortString;
|
||||||
property AGetInteger: Integer read GetAInteger;
|
property AGetInteger: Integer read GetAInteger;
|
||||||
@ -142,6 +177,8 @@ type
|
|||||||
property AGetBoolean: boolean read GetABoolean;
|
property AGetBoolean: boolean read GetABoolean;
|
||||||
property AGetShortString: ShortString read GetAShortString;
|
property AGetShortString: ShortString read GetAShortString;
|
||||||
property AWriteOnly: integer write SetWriteOnly;
|
property AWriteOnly: integer write SetWriteOnly;
|
||||||
|
property AChar: AnsiChar read FAChar write FAChar;
|
||||||
|
property AWideChar: WideChar read FAWideChar write FAWideChar;
|
||||||
end;
|
end;
|
||||||
{$M-}
|
{$M-}
|
||||||
|
|
||||||
@ -1061,6 +1098,225 @@ begin
|
|||||||
end;
|
end;
|
||||||
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;
|
procedure TTestCase1.TestPropSetValueString;
|
||||||
var
|
var
|
||||||
ATestClass : TTestValueClass;
|
ATestClass : TTestValueClass;
|
||||||
@ -1184,6 +1440,9 @@ begin
|
|||||||
CheckEquals(ATestClass.AShortString, ss);
|
CheckEquals(ATestClass.AShortString, ss);
|
||||||
ss := 'Foobar';
|
ss := 'Foobar';
|
||||||
CheckEquals(ATestClass.AShortString, 'Hello World');
|
CheckEquals(ATestClass.AShortString, 'Hello World');
|
||||||
|
|
||||||
|
AProperty.SetValue(ATestClass, 'Another string');
|
||||||
|
CheckEquals(ATestClass.AShortString, 'Another string');
|
||||||
finally
|
finally
|
||||||
AtestClass.Free;
|
AtestClass.Free;
|
||||||
end;
|
end;
|
||||||
@ -1192,6 +1451,258 @@ begin
|
|||||||
end;
|
end;
|
||||||
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;
|
procedure TTestCase1.TestPropGetValueProcInteger;
|
||||||
var
|
var
|
||||||
ATestClass : TTestValueClass;
|
ATestClass : TTestValueClass;
|
||||||
|
Loading…
Reference in New Issue
Block a user