paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 18:19:45 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ add TValue.FromArray to create a TValue type for a static or dynamic array from an array of TValues

Browse Source 
+ added test
This commit is contained in:
Sven/Sarah Barth 2021-12-24 14:47:01 +01:00
parent caaed25f18
commit bf37616514
2 changed files with 77 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
packages/rtl-objpas/src/inc/rtti.pp
View File

@ -124,6 +124,7 @@ type
generic class function FromOpenArray<T>(constref aValue: array of T): TValue; static; inline;
{$endif}
class function FromOrdinal(aTypeInfo: PTypeInfo; aValue: Int64): TValue; static; {inline;}
class function FromArray(aArrayTypeInfo: PTypeInfo; const aValues: array of TValue): TValue; static;
function IsArray: boolean; inline;
function IsOpenArray: Boolean; inline;
function AsString: string; inline;
@ -800,6 +801,8 @@ type
resourcestring
SErrUnableToGetValueForType = 'Unable to get value for type %s';
SErrUnableToSetValueForType = 'Unable to set value for type %s';
SErrDimensionOutOfRange = 'Dimension index %d is out of range [0, %d[';
SErrLengthOfArrayMismatch = 'Length of static array does not match: Got %d, but expected %d';
SErrInvalidTypecast = 'Invalid class typecast';
SErrRttiObjectNoHandle = 'RTTI object instance has no valid handle property';
SErrRttiObjectAlreadyRegistered = 'A RTTI object with handle 0x%x is already registered';
@ -1841,6 +1844,30 @@ begin
{$endif}
end;
class function TValue.FromArray(aArrayTypeInfo: PTypeInfo; const aValues: array of TValue): TValue; static;
var
i, sz: SizeInt;
data: TValueDataIntImpl;
begin
Result.Init;
Result.FData.FTypeInfo := aArrayTypeInfo;
if not Assigned(aArrayTypeInfo) then
Exit;
if aArrayTypeInfo^.Kind = tkDynArray then begin
data := TValueDataIntImpl.CreateRef(Nil, aArrayTypeInfo, True);
sz := Length(aValues);
DynArraySetLength(data.FBuffer, aArrayTypeInfo, 1, @sz);
Result.FData.FValueData := data;
end else if aArrayTypeInfo^.Kind = tkArray then begin
if Result.GetArrayLength <> Length(aValues) then
raise ERtti.CreateFmt(SErrLengthOfArrayMismatch, [Length(aValues), Result.GetArrayLength]);
Result.FData.FValueData := TValueDataIntImpl.CreateCopy(Nil, Result.TypeData^.ArrayData.Size, aArrayTypeInfo, False);
end else
raise ERtti.CreateFmt(SErrTypeKindNotSupported, [aArrayTypeInfo^.Name]);
for i := 0 to High(aValues) do
Result.SetArrayElement(i, aValues[i]);
end;
function TValue.GetIsEmpty: boolean;
begin
result := (FData.FTypeInfo=nil) or

50
packages/rtl-objpas/tests/tests.rtti.pas
View File

@ -80,6 +80,8 @@ type
procedure TestMakeNativeInt;
procedure TestMakeFromArray;
procedure TestMakeGenericNil;
procedure TestMakeGenericLongInt;
procedure TestMakeGenericString;
@ -842,6 +844,54 @@ begin
o.Free;
end;
procedure TTestCase1.TestMakeFromArray;
var
arr, subarr: array of TValue;
v, varr: TValue;
ti: PTypeInfo;
i: LongInt;
begin
SetLength(arr, 3 * 4);
for i := 0 to High(arr) do
TValue.{$ifdef fpc}specialize{$endif} Make<LongInt>(i + 1, arr[i]);
ti := PTypeInfo(TypeInfo(LongInt));
v := TValue.FromArray(TypeInfo(TArrayOfLongintDyn), arr);
Check(not v.IsEmpty, 'Array is empty');
Check(v.IsArray, 'Value is not an array');
CheckEquals(Length(arr), v.GetArrayLength, 'Array length does not match');
for i := 0 to High(arr) do begin
varr := v.GetArrayElement(i);
Check(varr.TypeInfo = ti, 'Type info of array element does not match');
Check(varr.IsOrdinal, 'Array element is not an ordinal');
Check(varr.AsInteger = arr[i].AsInteger, 'Value of array element does not match');
end;
subarr := Copy(arr, 0, 4);
v := TValue.FromArray(TypeInfo(TArrayOfLongintStatic), subarr);
Check(not v.IsEmpty, 'Array is empty');
Check(v.IsArray, 'Value is not an array');
CheckEquals(Length(subarr), v.GetArrayLength, 'Array length does not match');
for i := 0 to High(subarr) do begin
varr := v.GetArrayElement(i);
Check(varr.TypeInfo = ti, 'Type info of array element does not match');
Check(varr.IsOrdinal, 'Array element is not an ordinal');
Check(varr.AsInteger = subarr[i].AsInteger, 'Value of array element does not match');
end;
v := TValue.FromArray(TypeInfo(TArrayOfLongint2DStatic), arr);
Check(not v.IsEmpty, 'Array is empty');
Check(v.IsArray, 'Value is not an array');
CheckEquals(Length(arr), v.GetArrayLength, 'Array length does not match');
for i := 0 to High(arr) do begin
varr := v.GetArrayElement(i);
Check(varr.TypeInfo = ti, 'Type info of array element does not match');
Check(varr.IsOrdinal, 'Array element is not an ordinal');
Check(varr.AsInteger = arr[i].AsInteger, 'Value of array element does not match');
end;
end;
procedure TTestCase1.TestMakeGenericNil;
var
value: TValue;