From 6010f619533939077d086a1ef9850f2722c8a9bb Mon Sep 17 00:00:00 2001 From: Michael Schimmel Date: Sat, 19 Jul 2025 14:24:04 +0200 Subject: [PATCH] DataRecord almost finished --- Src/Myc.DataRecord.Impl.pas | 258 +++++++++++++++++++++++ Src/Myc.DataRecord.pas | 342 ++++++++----------------------- Test/MycTests.dpr | 2 +- Test/MycTests.dproj | 2 +- Test/Test.Core.Mutable.pas | 1 - Test/TestDataRecord.pas | 399 ++++++++++++++++++++++++++++++++++++ 6 files changed, 747 insertions(+), 257 deletions(-) create mode 100644 Src/Myc.DataRecord.Impl.pas create mode 100644 Test/TestDataRecord.pas diff --git a/Src/Myc.DataRecord.Impl.pas b/Src/Myc.DataRecord.Impl.pas new file mode 100644 index 0000000..6602eac --- /dev/null +++ b/Src/Myc.DataRecord.Impl.pas @@ -0,0 +1,258 @@ +unit Myc.DataRecord.Impl; + +interface + +uses + System.SysUtils, + System.Rtti, + System.TypInfo, + System.Generics.Collections, + System.Generics.Defaults, + Myc.DataRecord; + +type + // The builder implementation class, now in the global scope. + TDataRecordBuilder = class(TInterfacedObject, TDataRecord.IBuilder) + private + FStagedValues: TList>; + public + constructor Create; + destructor Destroy; override; + // IBuilder implementation + procedure AddField(const Name: String; const Value: TValue); overload; + procedure SetupRecord(out Layout: TArray; out Buffer: TBytes); + end; + +type + TField = class(TInterfacedObject, TDataRecord.IField) + private + FBuffer: TBytes; + FFieldLayout: TDataRecord.TFieldLayout; + protected + function GetRawRef: Pointer; inline; + public + constructor Create(ABuffer: TBytes; const AField: TDataRecord.TFieldLayout); + procedure GetRaw(Dst: Pointer); virtual; + procedure SetRaw(Src: Pointer); virtual; + property FieldLayout: TDataRecord.TFieldLayout read FFieldLayout; + end; + +type + TGenericField = class(TField, TDataRecord.IField) + public + function GetValue: T; + procedure SetValue(const Value: T); + end; + +type + TIntegerField = class(TGenericField) + public + procedure GetRaw(Dst: Pointer); override; + procedure SetRaw(Src: Pointer); override; + end; + +type + TSingleField = class(TGenericField) + public + procedure GetRaw(Dst: Pointer); override; + procedure SetRaw(Src: Pointer); override; + end; + +type + TDoubleField = class(TGenericField) + public + procedure GetRaw(Dst: Pointer); override; + procedure SetRaw(Src: Pointer); override; + end; + +type + TInt64Field = class(TGenericField) + public + procedure GetRaw(Dst: Pointer); override; + procedure SetRaw(Src: Pointer); override; + end; + +type + TStringField = class(TGenericField) + public + procedure GetRaw(Dst: Pointer); override; + procedure SetRaw(Src: Pointer); override; + end; + +type + TFieldLayoutComparer = class(TComparer) + strict private + class var + FDefaultComparer: IComparer; + class constructor CreateClass; + public + function Compare(const Left, Right: TDataRecord.TFieldLayout): Integer; override; + class property DefaultComparer: IComparer read FDefaultComparer; + end; + +implementation + +{ TDataRecordBuilder } + +constructor TDataRecordBuilder.Create; +begin + inherited; + FStagedValues := TList>.Create; +end; + +destructor TDataRecordBuilder.Destroy; +begin + FStagedValues.Free; + inherited; +end; + +procedure TDataRecordBuilder.AddField(const Name: String; const Value: TValue); +begin + FStagedValues.Add(TPair.Create(Name, Value)); +end; + +procedure TDataRecordBuilder.SetupRecord(out Layout: TArray; out Buffer: TBytes); +var + layoutList: TList; + pair: TPair; + field: TDataRecord.TFieldLayout; +begin + layoutList := TList.Create; + try + layoutList.Capacity := FStagedValues.Count; + var ofs: NativeUInt := 0; + for pair in FStagedValues do + begin + field.Name := pair.Key; + field.Size := pair.Value.DataSize; + ofs := (ofs + 15) and not 15; + field.Offset := ofs; + inc(ofs, field.Size); + field.TypeInfo := pair.Value.TypeInfo; + layoutList.Add(field); + end; + + SetLength(Buffer, ofs); + + for var i := 0 to layoutList.Count - 1 do + begin + var P: PByte := @Buffer[layoutList[i].Offset]; + FStagedValues[i].Value.ExtractRawData(P); + end; + + layoutList.Sort(TFieldLayoutComparer.DefaultComparer); + Layout := layoutList.ToArray; + finally + layoutList.Free; + end; + FStagedValues.Clear; +end; + +{ TField and descendants... } +constructor TField.Create(ABuffer: TBytes; const AField: TDataRecord.TFieldLayout); +begin + inherited Create; + FBuffer := ABuffer; + FFieldLayout := AField; +end; + +procedure TField.GetRaw(Dst: Pointer); +var + Val: TValue; +begin + TValue.MakeWithoutCopy(GetRawRef, FFieldLayout.TypeInfo, val, true); + val.ExtractRawData(Dst); +end; + +function TField.GetRawRef: Pointer; +begin + Result := @FBuffer[FFieldLayout.Offset]; +end; + +procedure TField.SetRaw(Src: Pointer); +var + Val: TValue; +begin + TValue.MakeWithoutCopy(Src, FFieldLayout.TypeInfo, val, true); + val.ExtractRawData(GetRawRef); +end; + +{ TGenericField } + +function TGenericField.GetValue: T; +type + PT = ^T; +begin + Result := PT(@FBuffer[FFieldLayout.Offset])^; +end; + +procedure TGenericField.SetValue(const Value: T); +type + PT = ^T; +begin + PT(@FBuffer[FFieldLayout.Offset])^ := Value; +end; + +procedure TIntegerField.GetRaw(Dst: Pointer); +begin + PInteger(Dst)^ := PInteger(GetRawRef)^; +end; + +procedure TIntegerField.SetRaw(Src: Pointer); +begin + PInteger(GetRawRef)^ := PInteger(Src)^; +end; + +procedure TSingleField.GetRaw(Dst: Pointer); +begin + PSingle(Dst)^ := PSingle(GetRawRef)^; +end; + +procedure TSingleField.SetRaw(Src: Pointer); +begin + PSingle(GetRawRef)^ := PSingle(Src)^; +end; + +procedure TDoubleField.GetRaw(Dst: Pointer); +begin + PDouble(Dst)^ := PDouble(GetRawRef)^; +end; + +procedure TDoubleField.SetRaw(Src: Pointer); +begin + PDouble(GetRawRef)^ := PDouble(Src)^; +end; + +procedure TInt64Field.GetRaw(Dst: Pointer); +begin + PInt64(Dst)^ := PInt64(GetRawRef)^; +end; + +procedure TInt64Field.SetRaw(Src: Pointer); +begin + PInt64(GetRawRef)^ := PInt64(Src)^; +end; + +procedure TStringField.GetRaw(Dst: Pointer); +begin + PString(Dst)^ := PString(GetRawRef)^; +end; + +procedure TStringField.SetRaw(Src: Pointer); +begin + PString(GetRawRef)^ := PString(Src)^; +end; + +{ TFieldLayoutComparer } + +class constructor TFieldLayoutComparer.CreateClass; +begin + FDefaultComparer := TFieldLayoutComparer.Create; +end; + +function TFieldLayoutComparer.Compare(const Left, Right: TDataRecord.TFieldLayout): Integer; +begin + Result := TComparer.Default.Compare(Left.Name, Right.Name); +end; + +end. diff --git a/Src/Myc.DataRecord.pas b/Src/Myc.DataRecord.pas index b75f142..ff22441 100644 --- a/Src/Myc.DataRecord.pas +++ b/Src/Myc.DataRecord.pas @@ -3,25 +3,28 @@ unit Myc.DataRecord; interface uses - System.Rtti, - System.TypInfo, System.SysUtils, - System.Generics.Collections, - System.Generics.Defaults; + System.Rtti, + System.TypInfo; type // A record that provides field-level access to data, stored in a packed byte buffer. TDataRecord = record public type - // Provides generic access to a value of type T. - IField = interface + IField = interface + procedure GetRaw(Dst: Pointer); + procedure SetRaw(Src: Pointer); + end; + + IField = interface(IField) + {$region 'private'} function GetValue: T; procedure SetValue(const Value: T); + {$endregion} property Value: T read GetValue write SetValue; end; - // Describes the field and its memory layout in the data buffer. TFieldLayout = record Name: string; Offset: Integer; @@ -29,17 +32,29 @@ type TypeInfo: PTypeInfo; end; - // Builder for dynamically creating a TDataRecord. + IBuilder = interface + procedure AddField(const Name: String; const Value: TValue); overload; + procedure SetupRecord(out Layout: TArray; out Buffer: TBytes); + end; + + // The interface helper record that provides the generic AddField method. TBuilder = record private - FStagedValues: TList>; - class operator Initialize(out Dest: TBuilder); - class operator Finalize(var Dest: TBuilder); + FBuilder: IBuilder; public - procedure AddField(const Name: String; const Value: T); overload; - procedure AddField(const Name: String; const Value: TValue); overload; - function CreateRec: TDataRecord; + constructor Create(const ABuilder: IBuilder); + + // This generic method is the reason for the helper's existence. + procedure AddField(const Name: String; const Value: T); inline; + + // Wrapper for methods on the underlying interface. + function CreateRec: TDataRecord; inline; + + // Implicit operators for seamless casting between the helper and the interface. + class operator Implicit(const AValue: IBuilder): TBuilder; overload; + class operator Implicit(const AValue: TBuilder): IBuilder; overload; end; + private FLayout: TArray; FBuffer: TBytes; @@ -48,127 +63,97 @@ type class operator Finalize(var Dest: TDataRecord); class operator Assign(var Dest: TDataRecord; const [ref] Src: TDataRecord); - class function CreateFromRec(const Rec: T): TDataRecord; static; - class function CreateBuilder: TDataRecord.TBuilder; static; - - function GetField(const Name: String): IField; - + // Factory method now returns the helper record instance. + class function CreateBuilder: TBuilder; static; + function IndexOf(const Name: String): Integer; + function GetField(const Name: String): IField; overload; + function GetField(const Name: String): IField; overload; property Layout: TArray read FLayout; end; - // Accessor for reading/writing data directly from/to the TBytes buffer. - TByteAccessor = class(TInterfacedObject, TDataRecord.IField) - private - FBuffer: TBytes; - FField: TDataRecord.TFieldLayout; - public - constructor Create(ABuffer: TBytes; const AField: TDataRecord.TFieldLayout); - function GetValue: T; - procedure SetValue(const Value: T); - end; - - // Comparer for sorting and searching field layouts by their string key (Singleton). - TFieldLayoutComparer = class(TComparer) - strict private - class var - FDefault: IComparer; - class constructor CreateClass; - class destructor DestroyClass; - public - function Compare(const Left, Right: TDataRecord.TFieldLayout): Integer; override; - class property Default: IComparer read FDefault; - end; - -procedure Testfunc; - implementation uses - System.JSON, - System.Classes; + System.Classes, + System.Generics.Collections, + Myc.DataRecord.Impl; -{$region 'TFieldLayoutComparer'} -class constructor TFieldLayoutComparer.CreateClass; +{ TDataRecord.TBuilder } + +constructor TDataRecord.TBuilder.Create(const ABuilder: IBuilder); begin - FDefault := TFieldLayoutComparer.Create; + FBuilder := ABuilder; end; -class destructor TFieldLayoutComparer.DestroyClass; +procedure TDataRecord.TBuilder.AddField(const Name: String; const Value: T); begin - FDefault := nil; + FBuilder.AddField(Name, TValue.From(Value)); end; -function TFieldLayoutComparer.Compare(const Left, Right: TDataRecord.TFieldLayout): Integer; +function TDataRecord.TBuilder.CreateRec: TDataRecord; begin - Result := TComparer.Default.Compare(Left.Name, Right.Name); -end; -{$endregion} - -{$region 'TByteAccessor'} -constructor TByteAccessor.Create(ABuffer: TBytes; const AField: TDataRecord.TFieldLayout); -begin - inherited Create; - FBuffer := ABuffer; - FField := AField; + FBuilder.SetupRecord(Result.FLayout, Result.FBuffer); end; -function TByteAccessor.GetValue: T; -type - PT = ^T; +class operator TDataRecord.TBuilder.Implicit(const AValue: IBuilder): TBuilder; begin - Result := PT(@FBuffer[FField.Offset])^; + Result.FBuilder := AValue; end; -procedure TByteAccessor.SetValue(const Value: T); -type - PT = ^T; +class operator TDataRecord.TBuilder.Implicit(const AValue: TBuilder): IBuilder; begin - PT(@FBuffer[FField.Offset])^ := Value; + Result := AValue.FBuilder; end; -{$endregion} -{$region 'TDataRecord'} +{ TDataRecord } + function TDataRecord.GetField(const Name: String): IField; var - dummyLayout: TFieldLayout; - index: Integer; + idx: Integer; begin - Result := nil; - dummyLayout.Name := Name; - - if TArray.BinarySearch(FLayout, dummyLayout, index, TFieldLayoutComparer.Default) then - begin - if (FLayout[index].TypeInfo <> nil) and (FLayout[index].TypeInfo = System.TypeInfo(T)) then - begin - Result := TByteAccessor.Create(FBuffer, FLayout[index]); - end; - end; + idx := IndexOf(Name); + if idx < 0 then + exit; + if TypeInfo(T) <> FLayout[idx].TypeInfo then + exit; + Result := TGenericField.Create(FBuffer, FLayout[idx]); end; -class function TDataRecord.CreateBuilder: TDataRecord.TBuilder; +class function TDataRecord.CreateBuilder: TBuilder; begin - Result := Default(TDataRecord.TBuilder); + // Create the implementation class and wrap it in the helper record. + Result := TDataRecord.TBuilder.Create(TDataRecordBuilder.Create); end; -class function TDataRecord.CreateFromRec(const Rec: T): TDataRecord; +function TDataRecord.GetField(const Name: String): IField; var - ctx: TRttiContext; - recType: TRttiRecordType; - field: TRttiField; - recValue: TValue; - builder: TBuilder; + idx: Integer; begin - builder := CreateBuilder; - - ctx := TRttiContext.Create; - recType := ctx.GetType(System.TypeInfo(T)) as TRttiRecordType; - recValue := TValue.From(Rec); - - for field in recType.GetFields do - begin - builder.AddField(field.Name, field.GetValue(recValue.GetReferenceToRawData)); + idx := IndexOf(Name); + if idx < 0 then + exit; + var typeInfo := FLayout[idx].TypeInfo; + case typeInfo.Kind of + tkInteger: Result := TIntegerField.Create(FBuffer, FLayout[idx]); + tkFloat: + case GetTypeData(typeInfo).FloatType of + ftSingle: Result := TSingleField.Create(FBuffer, FLayout[idx]); + ftDouble: Result := TDoubleField.Create(FBuffer, FLayout[idx]); + end; + tkInt64: Result := TInt64Field.Create(FBuffer, FLayout[idx]); + tkString: Result := TStringField.Create(FBuffer, FLayout[idx]); end; - Result := builder.CreateRec; + if not Assigned(Result) then + Result := TField.Create(FBuffer, FLayout[idx]); +end; + +function TDataRecord.IndexOf(const Name: String): Integer; +var + dummyLayout: TFieldLayout; +begin + dummyLayout.Name := Name; + if not TArray.BinarySearch(FLayout, dummyLayout, Result, TFieldLayoutComparer.DefaultComparer) then + Result := -1; end; class operator TDataRecord.Assign(var Dest: TDataRecord; const [ref] Src: TDataRecord); @@ -177,12 +162,10 @@ begin Dest.FLayout := Src.FLayout; SetLength(Dest.FBuffer, Length(Src.FBuffer)); - for var layout in Dest.FLayout do begin var P: PByte := @Dest.FBuffer[layout.Offset]; var Q: PByte := @Src.FBuffer[layout.Offset]; - var Val: TValue; TValue.Make(Q, layout.TypeInfo, val); val.ExtractRawData(P); @@ -199,164 +182,15 @@ class operator TDataRecord.Finalize(var Dest: TDataRecord); begin if (Dest.FBuffer = nil) or (Dest.FLayout = nil) then Exit; - for var layout in Dest.FLayout do begin var P: PByte := @Dest.FBuffer[layout.Offset]; var Val: TValue; - // Move instance from buffer into a managed TValue. It will be destroyed, when it gets out of scope. + // IsMoved has to be false, because we want the local TValue to own the field and destroy it when it looses scope! TValue.MakeWithoutCopy(P, layout.TypeInfo, val, false); end; - Dest.FLayout := nil; Dest.FBuffer := nil; end; -{$endregion} - -{$region 'TDataRecord.TBuilder'} -procedure TDataRecord.TBuilder.AddField(const Name: String; const Value: T); -begin - FStagedValues.Add(TPair.Create(Name, TValue.From(Value))); -end; - -procedure TDataRecord.TBuilder.AddField(const Name: String; const Value: TValue); -begin - // Overload to accept a TValue directly. - FStagedValues.Add(TPair.Create(Name, Value)); -end; - -function TDataRecord.TBuilder.CreateRec: TDataRecord; -var - layoutList: TList; - pair: TPair; - layout: TFieldLayout; -begin - layoutList := TList.Create; - try - layoutList.Capacity := FStagedValues.Count; - - var ofs: NativeUInt := 0; - for pair in FStagedValues do - begin - layout.Name := pair.Key; - layout.Size := pair.Value.DataSize; - - ofs := (ofs + 15) and not 15; - - layout.Offset := ofs; - inc(ofs, layout.Size); - - layout.TypeInfo := pair.Value.TypeInfo; - layoutList.Add(layout); - end; - - SetLength(Result.FBuffer, ofs); - - for var i := 0 to layoutList.Count - 1 do - begin - var P: PByte := @Result.FBuffer[layoutList[i].Offset]; - FStagedValues[i].Value.ExtractRawData(P); - end; - - layoutList.Sort(TFieldLayoutComparer.Default); - Result.FLayout := layoutList.ToArray; - finally - layoutList.Free; - end; - - FStagedValues.Clear; -end; - -class operator TDataRecord.TBuilder.Initialize(out Dest: TBuilder); -begin - Dest.FStagedValues := TList>.Create; -end; - -class operator TDataRecord.TBuilder.Finalize(var Dest: TBuilder); -begin - Dest.FStagedValues.Free; -end; -{$endregion} - -type - TTestRec = record - A, B, C: Integer; - Name: String; - Val: Double; - end; - -procedure Testfunc; -var - testRec: TTestRec; - R: TDataRecord; - nameAccess: TDataRecord.IField; - bAccess: TDataRecord.IField; -const - JSON_DATA = '{"IntValue": 123, "StringValue": "Hello JSON", "FloatValue": 99.9, "BoolValue": true}'; -begin - testRec.A := 1; - testRec.B := 5; - testRec.C := 10; - testRec.Name := 'Hi'; - testRec.Val := 3.14; - - R := TDataRecord.CreateFromRec(testRec); - - // Test reading a string value - nameAccess := R.GetField('Name'); - Assert(Assigned(nameAccess)); - Assert(nameAccess.Value = 'Hi'); - - // Test reading an integer value - bAccess := R.GetField('B'); - Assert(Assigned(bAccess)); - Assert(bAccess.Value = 5); - - // Test writing a value - bAccess.Value := 99; - Assert(bAccess.Value = 99); - // Verify it was written back to the buffer - var bAccess2 := R.GetField('B'); - Assert(bAccess2.Value = 99); - - // Verify that a request for a wrong type returns nil - var aAccess := R.GetField('A'); - Assert(not Assigned(aAccess)); - - // Test the builder pattern - var RecBuilder: TDataRecord.TBuilder := TDataRecord.CreateBuilder; - RecBuilder.AddField('ZValue', 222.0); - RecBuilder.AddField('AValue', 'Builder Test'); - var S := RecBuilder.CreateRec; - - var T := S; - - var dblAccess := T.GetField('ZValue'); - Assert(Assigned(dblAccess)); - Assert(dblAccess.Value = 222.0); - - var strAccess := T.GetField('AValue'); - Assert(Assigned(strAccess)); - Assert(strAccess.Value = 'Builder Test'); - { - // Test JSON parsing - var jsonRec := TDataRecord.CreateFromJSON(JSON_DATA); - var intAccess := jsonRec.GetField('IntValue'); - Assert(Assigned(intAccess)); - Assert(intAccess.Value = 123); - - strAccess := jsonRec.GetField('StringValue'); - Assert(Assigned(strAccess)); - Assert(strAccess.Value = 'Hello JSON'); - - dblAccess := jsonRec.GetField('FloatValue'); - Assert(Assigned(dblAccess)); - Assert(dblAccess.Value = 99.9); - - var boolAccess := jsonRec.GetField('BoolValue'); - Assert(Assigned(boolAccess)); - Assert(boolAccess.Value = true); - } -end; end. diff --git a/Test/MycTests.dpr b/Test/MycTests.dpr index c8b86f7..81ac9d0 100644 --- a/Test/MycTests.dpr +++ b/Test/MycTests.dpr @@ -30,7 +30,7 @@ uses Myc.Trade.DataStream in '..\Src\Myc.Trade.DataStream.pas', Myc.Mutable in '..\Src\Myc.Mutable.pas', Test.Core.Mutable in 'Test.Core.Mutable.pas', - Tests.Myc.DirectoryMonitor in 'Tests.Myc.DirectoryMonitor.pas'; + TestDataRecord in 'TestDataRecord.pas'; { keep comment here to protect the following conditional from being removed by the IDE when adding a unit } {$IFNDEF TESTINSIGHT} diff --git a/Test/MycTests.dproj b/Test/MycTests.dproj index 7c628e7..a956259 100644 --- a/Test/MycTests.dproj +++ b/Test/MycTests.dproj @@ -130,7 +130,7 @@ $(PreBuildEvent)]]> - + Base diff --git a/Test/Test.Core.Mutable.pas b/Test/Test.Core.Mutable.pas index 49694f6..ec1a338 100644 --- a/Test/Test.Core.Mutable.pas +++ b/Test/Test.Core.Mutable.pas @@ -117,7 +117,6 @@ var writeable: TWriteable; subscriber: TSignal.ISubscriber; subscription: TSignal.TSubscription; - exchangedValue: Integer; begin writeable := TWriteable.CreateWriteable(InitialValue); subscriber := TTestSubscriber.Create(SubscriberCallback); diff --git a/Test/TestDataRecord.pas b/Test/TestDataRecord.pas new file mode 100644 index 0000000..0996a47 --- /dev/null +++ b/Test/TestDataRecord.pas @@ -0,0 +1,399 @@ +unit TestDataRecord; + +interface + +uses + System.SysUtils, + System.Classes, + System.Variants, + DUnitX.TestFramework, + Myc.DataRecord; + +type + // Helper types for various TypeKind tests + TTestEnum = (teOne, teTwo, teThree); + TTestSet = set of TTestEnum; + + TTestRecord = record + I: Integer; + S: string; + end; + + TTestMRecord = record + private + FData: TArray; + class operator Initialize(out Dest: TTestMRecord); + class operator Finalize(var Dest: TTestMRecord); + end; + + ITestInterface = interface + ['{B1E5119C-A2B4-43C1-99C1-39B6A687363E}'] + function GetValue: Integer; + end; + + TTestClass = class(TInterfacedObject, ITestInterface) + private + FValue: Integer; + public + constructor Create(AValue: Integer); + function GetValue: Integer; + end; + + [TestFixture] + TDataRecordTests = class + private + function CreateRecord(const FieldName: string; const Value: T): TDataRecord; + public + // Test procedures are unchanged + [Test] + [TestCase('TestZero', '0')] + [TestCase('TestPositive', '123')] + [TestCase('TestNegative', '-456')] + procedure Test_tkInteger_Succeeds(const AValue: Integer); + + [Test] + [TestCase('TestZero', '0')] + [TestCase('TestPositive', '1234567890123')] + [TestCase('TestNegative', '-9876543210987')] + procedure Test_tkInt64_Succeeds(const AValue: Int64); + + [Test] + procedure Test_tkFloat_Single_Succeeds; + + [Test] + procedure Test_tkFloat_Double_Succeeds; + + [Test] + [TestCase('Test_A', 'A')] + procedure Test_tkChar_Succeeds(const AValue: Char); + + [Test] + [TestCase('TestEmpty', '')] + [TestCase('TestSimple', 'Hello World')] + procedure Test_tkString_NonGeneric_Succeeds(const AValue: string); + + [Test] + [TestCase('TestLeak', 'This test will leak memory')] + procedure Test_tkString_Generic_LeaksMemory(const AValue: string); + + [Test] + procedure Test_tkEnumeration_Succeeds; + + [Test] + procedure Test_tkSet_Succeeds; + + [Test] + procedure Test_tkRecord_Succeeds; + + [Test] + procedure Test_tkMRecord_Succeeds; + + [Test] + procedure Test_tkDynArray_Succeeds; + + [Test] + procedure Test_tkInterface_Succeeds; + + [Test] + procedure Test_tkClass_Succeeds_With_Manual_Cleanup; + + [Test] + procedure Test_tkVariant_Succeeds; + + [Test] + procedure TestFinalizeWithValue_True_Succeeds; + + [Test] + procedure TestFinalizeWithValue_False_Leaks; + end; + +implementation + +uses + System.TypInfo, + System.Rtti; + +{ TDataRecordTests } + +function TDataRecordTests.CreateRecord(const FieldName: string; const Value: T): TDataRecord; +var + // Use the TBuilder helper record. Its lifetime is managed automatically. + builder: TDataRecord.TBuilder; +begin + builder := TDataRecord.CreateBuilder; + builder.AddField(FieldName, Value); + Result := builder.CreateRec; +end; + +procedure TDataRecordTests.Test_tkInteger_Succeeds(const AValue: Integer); +var + rec: TDataRecord; + field: TDataRecord.IField; +begin + rec := CreateRecord('Value', AValue); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + Assert.AreEqual(AValue, field.Value, 'Value should be equal'); +end; + +procedure TDataRecordTests.Test_tkInt64_Succeeds(const AValue: Int64); +var + rec: TDataRecord; + field: TDataRecord.IField; +begin + rec := CreateRecord('Value', AValue); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + Assert.AreEqual(AValue, field.Value, 'Value should be equal'); +end; + +procedure TDataRecordTests.Test_tkFloat_Single_Succeeds; +const + TEST_VAL: Single = 3.14; +var + rec: TDataRecord; + field: TDataRecord.IField; +begin + rec := CreateRecord('Value', TEST_VAL); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + Assert.AreEqual(TEST_VAL, field.Value, 'Value should be equal'); +end; + +procedure TDataRecordTests.Test_tkFloat_Double_Succeeds; +const + TEST_VAL: Double = 123.456; +var + rec: TDataRecord; + field: TDataRecord.IField; +begin + rec := CreateRecord('Value', TEST_VAL); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + Assert.AreEqual(TEST_VAL, field.Value, 'Value should be equal'); +end; + +procedure TDataRecordTests.Test_tkChar_Succeeds(const AValue: Char); +var + rec: TDataRecord; + field: TDataRecord.IField; +begin + rec := CreateRecord('Value', AValue); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + Assert.AreEqual(AValue, field.Value, 'Value should be equal'); +end; + +procedure TDataRecordTests.Test_tkString_NonGeneric_Succeeds(const AValue: string); +var + rec: TDataRecord; + field: TDataRecord.IField; + typedField: TDataRecord.IField; +begin + rec := CreateRecord('Value', AValue); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + typedField := rec.GetField('Value'); + Assert.AreEqual(AValue, typedField.Value, 'Value should be equal'); + typedField.Value := 'New Value'; + Assert.AreEqual('New Value', typedField.Value, 'Value should be updated'); +end; + +procedure TDataRecordTests.Test_tkString_Generic_LeaksMemory(const AValue: string); +var + rec: TDataRecord; + field: TDataRecord.IField; +begin + rec := CreateRecord('Value', AValue); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + Assert.AreEqual(AValue, field.Value, 'Initial value should be correct'); + field.Value := 'A new string that will be leaked'; +end; + +procedure TDataRecordTests.Test_tkEnumeration_Succeeds; +var + rec: TDataRecord; + field: TDataRecord.IField; +begin + rec := CreateRecord('Value', teTwo); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + Assert.AreEqual(teTwo, field.Value, 'Value should be teTwo'); +end; + +procedure TDataRecordTests.Test_tkSet_Succeeds; +var + rec: TDataRecord; + field: TDataRecord.IField; + testSet: TTestSet; +begin + testSet := [teOne, teThree]; + rec := CreateRecord('Value', testSet); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + Assert.IsTrue(testSet = field.Value, 'Value should be [teOne, teThree]'); +end; + +procedure TDataRecordTests.Test_tkRecord_Succeeds; +var + rec: TDataRecord; + field: TDataRecord.IField; + testRec, resultRec: TTestRecord; +begin + testRec.I := 42; + testRec.S := 'Hello Record'; + rec := CreateRecord('Value', testRec); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + resultRec := field.Value; + Assert.AreEqual(testRec.I, resultRec.I, 'Record.I should match'); + Assert.AreEqual(testRec.S, resultRec.S, 'Record.S should match'); +end; + +procedure TDataRecordTests.Test_tkMRecord_Succeeds; +var + rec: TDataRecord; + field: TDataRecord.IField; + testMRec, resultMRec: TTestMRecord; +begin + SetLength(testMRec.FData, 10); + testMRec.FData[0] := 1; + rec := CreateRecord('Value', testMRec); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + resultMRec := field.Value; + Assert.AreEqual(Length(testMRec.FData), Length(resultMRec.FData), 'MRecord.FData length should match'); + Assert.AreEqual(testMRec.FData[0], resultMRec.FData[0], 'MRecord.FData content should match'); +end; + +procedure TDataRecordTests.Test_tkDynArray_Succeeds; +var + rec: TDataRecord; + field: TDataRecord.IField>; + testArr, resultArr: TArray; +begin + testArr := [10, 20, 30]; + rec := CreateRecord>('Value', testArr); + field := rec.GetField>('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + resultArr := field.Value; + Assert.AreEqual(Length(testArr), Length(resultArr), 'DynArray length should match'); + Assert.AreEqual(testArr[1], resultArr[1], 'DynArray content should match'); +end; + +procedure TDataRecordTests.Test_tkInterface_Succeeds; +var + rec: TDataRecord; + field: TDataRecord.IField; + testIntf, resultIntf: ITestInterface; +begin + testIntf := TTestClass.Create(1337); + rec := CreateRecord('Value', testIntf); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + resultIntf := field.Value; + Assert.IsNotNull(resultIntf, 'Result interface should not be null'); + Assert.AreEqual(1337, resultIntf.GetValue, 'Interface method should return correct value'); +end; + +procedure TDataRecordTests.Test_tkClass_Succeeds_With_Manual_Cleanup; +var + rec: TDataRecord; + field: TDataRecord.IField; + testObj, resultObj: TTestClass; +begin + testObj := TTestClass.Create(99); + try + rec := CreateRecord('Value', testObj); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + resultObj := field.Value; + Assert.AreSame(testObj, resultObj, 'Should be the same object instance'); + Assert.AreEqual(99, resultObj.GetValue, 'Object method should return correct value'); + finally + testObj.Free; + end; +end; + +procedure TDataRecordTests.Test_tkVariant_Succeeds; +var + rec: TDataRecord; + field: TDataRecord.IField; + testVar: Variant; +begin + testVar := 'Hello Variant'; + rec := CreateRecord('Value', testVar); + field := rec.GetField('Value'); + Assert.IsNotNull(field, 'Field should not be null'); + Assert.AreEqual(testVar, field.Value, 'Variant value should match'); +end; + +procedure TDataRecordTests.TestFinalizeWithValue_True_Succeeds; +var + Buffer: TBytes; + P: Pointer; + s: string; +begin + // 1. Create a managed string and place it in a raw buffer + s := 'This is a test string that should be finalized.'; + SetLength(Buffer, SizeOf(string)); + P := @Buffer[0]; + PString(P)^ := s; + s := ''; // Clear the original variable, the buffer is now the owner + + // 2. Try to finalize the string in the buffer using TValue + var Val: TValue; + TValue.MakeWithoutCopy(P, TypeInfo(string), Val, true); + + // If 'true' works as expected (takes ownership and finalizes), this test will pass without leaks. + Assert.IsTrue(true); +end; + +procedure TDataRecordTests.TestFinalizeWithValue_False_Leaks; +var + Buffer: TBytes; + P: Pointer; + s: string; +begin + // 1. Create a managed string and place it in a raw buffer + s := 'This string will be leaked.'; + SetLength(Buffer, SizeOf(string)); + P := @Buffer[0]; + PString(P)^ := s; + s := ''; // Clear the original variable, the buffer is now the owner + + // 2. Try to "finalize" the string using 'false' + var Val: TValue; + TValue.MakeWithoutCopy(P, TypeInfo(string), Val, false); + + // If 'false' does NOT take ownership, this test will report a memory leak. + // Log.Info('This test is expected to report a memory leak.'); + Assert.IsTrue(true); +end; + +{ TTestClass } +constructor TTestClass.Create(AValue: Integer); +begin + inherited Create; + FValue := AValue; +end; +function TTestClass.GetValue: Integer; +begin + Result := FValue; +end; + +{ TTestMRecord } +class operator TTestMRecord.Finalize(var Dest: TTestMRecord); +begin + Dest.FData := nil; +end; +class operator TTestMRecord.Initialize(out Dest: TTestMRecord); +begin + Dest.FData := nil; +end; + +initialization + TDUnitX.RegisterTestFixture(TDataRecordTests); + +end.