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

* Patch from Евгений Савин to fix TValue.From<managedrecord>. Fixes issue #41013

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-11-25 14:01:06 +01:00
parent e1e301dea8
commit 8ffbbe6a93
2 changed files with 57 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3517,10 +3517,10 @@ begin
tkUString,
tkAString : result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True);
tkDynArray : result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True);
tkArray : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.ArrayData.Size, ATypeInfo, False);
tkArray : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.ArrayData.Size, ATypeInfo, IsManaged(ATypeInfo));
tkObject,
tkRecord : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.RecSize, ATypeInfo, False);
tkVariant : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, SizeOf(Variant), ATypeInfo, False);
tkRecord : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.RecSize, ATypeInfo, IsManaged(ATypeInfo));
tkVariant : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, SizeOf(Variant), ATypeInfo, True);
tkInterface: result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True);
else
// Silence compiler warning

55
packages/rtl-objpas/tests/tests.rtti.value.pas
View File

@ -53,6 +53,9 @@ Type
procedure TestFromOrdinal;
Procedure TestTryCastUnicodeString;
procedure TestMakeManagedRecord;
procedure TestMakeStaticArrayOfManagedRecord;
end;
{ TTestValueArray }
@ -1545,6 +1548,57 @@ begin
CheckTrue(V.TryCast(TypeInfo(UnicodeString), V2),'Cast OK');
end;
type
TMyManagedRecord = record
I: IntPtr;
Intf: IUnknown;
end;
TTestIntfObject = class(TInterfacedObject);
procedure TTestValueSimple.TestMakeManagedRecord;
function GetValue: TValue;
var
R: TMyManagedRecord;
begin
R.Intf := TTestIntfObject.Create;
Result := TValue.{$ifdef fpc}specialize{$endif} From<TMyManagedRecord>(R);
end;
var
P: Pointer;
R: TMyManagedRecord;
V: TValue;
begin
V := GetValue();
P := AllocMem(64);
R := V.{$ifdef fpc}specialize{$endif} AsType<TMyManagedRecord>;
Check((R.Intf as TTestIntfObject).RefCount >= 2, 'RefCount should be >= 2. One ref in in V, and another one is in R');
FreeMem(P);
end;
procedure TTestValueSimple.TestMakeStaticArrayOfManagedRecord;
type
TArrayOfRec = array[0..0] of TMyManagedRecord;
function GetValue: TValue;
var
Arr: TArrayOfRec;
begin
Arr[0].Intf := TTestIntfObject.Create;
Result := TValue.{$ifdef fpc}specialize{$endif} From<TArrayOfRec>(Arr);
end;
var
P: Pointer;
Arr: TArrayOfRec;
V: TValue;
begin
V := GetValue();
P := AllocMem(64);
Arr := V.{$ifdef fpc}specialize{$endif} AsType<TArrayOfRec>;
Check((Arr[0].Intf as TTestIntfObject).RefCount >= 2, 'RefCount should be >= 2. One ref in in V, and another one is in Arr');
FreeMem(P);
end;
{ TTestValueArray }
@ -1986,4 +2040,3 @@ initialization
RegisterTest(TTestValueSimple);
RegisterTest(TTestValueVariant);
end.