From bf4ef71cba1f466c9bc9c7014a244d8ef13818c3 Mon Sep 17 00:00:00 2001 From: Michael Schimmel Date: Tue, 22 Jul 2025 01:13:01 +0200 Subject: [PATCH] Refactoring DataFlow, 1st Generic Data records working --- AuraTrader/AuraTrader.dproj | 8 + AuraTrader/MainForm.pas | 254 +++++++++++++- Src/Myc.DataRecord.Impl.pas | 223 ++----------- Src/Myc.DataRecord.pas | 483 +++++++++++++++------------ Src/Myc.Trade.DataPoint.Impl.pas | 117 ++++++- Src/Myc.Trade.DataPoint.pas | 84 ++++- Src/Myc.Trade.Indicators.pas | 156 +++++++++ Test/MycTests.dpr | 3 +- Test/MycTests.dproj | 1 - Test/TestDataRecord.RawAccess.pas | 120 ++++--- Test/TestDataRecord.pas | 532 ++++++------------------------ 11 files changed, 1074 insertions(+), 907 deletions(-) diff --git a/AuraTrader/AuraTrader.dproj b/AuraTrader/AuraTrader.dproj index 90ff7f2..0ded5a4 100644 --- a/AuraTrader/AuraTrader.dproj +++ b/AuraTrader/AuraTrader.dproj @@ -104,6 +104,7 @@ true true true + off false @@ -119,6 +120,7 @@ RELEASE;$(DCC_Define) 0 0 + auto PerMonitorV2 @@ -162,6 +164,12 @@ AuraTrader.dpr + + Embarcadero C++Builder Office 2000 Servers Package + Embarcadero C++Builder Office XP Servers Package + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + diff --git a/AuraTrader/MainForm.pas b/AuraTrader/MainForm.pas index c5cb176..82fcf1a 100644 --- a/AuraTrader/MainForm.pas +++ b/AuraTrader/MainForm.pas @@ -50,7 +50,9 @@ uses System.Actions, FMX.ActnList, DynamicFMXControl, - Myc.FMX.Chart; + Myc.FMX.Chart, + Myc.Trade.Indicators, + Myc.DataRecord; type TForm1 = class(TForm) @@ -108,6 +110,7 @@ type procedure NewWorkspace; function CurrLayout: T; procedure AlignControl(Control: TControl); + function CreateStrategy1(Timeframe: TTimeframe): IMycProcessor>; function CreateStrategy2(Timeframe: TTimeframe): IMycProcessor>; published @@ -124,29 +127,24 @@ type constructor Create(AEquity: Double); end; -type - TStaget1Result = record - ATR, Hull, SMA, O, H, L, C: Double - end; - var Form1: TForm1; implementation uses - TestModule, - Myc.Trade.Indicators, - Myc.DataRecord; + TestModule; {$R *.fmx} procedure TForm1.NewWorkspace; +var + tab: TTabItem; begin var ws: IAuraWorkspace := TMycAuraWorkspace.Create('New workspace', tmTesting); FApplication.Workspaces.Insert(-1, ws); - var tab := TabControl.Add; + tab := TabControl.Add; tab.Text := ws.Caption; tab.Tag := NativeInt(ws); @@ -297,7 +295,7 @@ begin Control.Align := TAlignLayout.Top; end; -function TForm1.CreateStrategy2(Timeframe: TTimeframe): IMycProcessor>; +function TForm1.CreateStrategy1(Timeframe: TTimeframe): IMycProcessor>; type TSignal = record Sig: Double; @@ -453,6 +451,12 @@ begin panel.AddDoubleSeries(Signal.Field('Entry').Sender, TAlphaColors.Green, 1); panel.AddDoubleSeries(Signal.Field('SL').Sender, TAlphaColors.Red, 2); + var mean := TConverter, Double>.CreateGeneric(TIndicators.CreateMean()); + + TConverter.Join([Hull.Sender, Sma.Sender]).Link(mean); + + panel.AddDoubleSeries(mean.Sender, TAlphaColors.Blue, 5); + var pnlChart := TMycChart.Create(Self); AlignControl(pnlChart); pnlChart.Height := Layout.ChildrenRect.Width * 9 / 24; @@ -460,8 +464,236 @@ begin pnlChart.SetXAxisCounter(equity.Sender); + //////////// + var EMAFactory := TEMA.Create; + + var Params := TDataRecord.CreateFrom(EMAFactory.Params); + Params.SetValue('Period', 20); + + var indi := EMAFActory.CreateIndicator(Params); + + var EMAConv := TConverter.CreateGeneric(indi); + + var equityEMA := + equity + .Chain(TConverter.FieldToRecord(EMAFactory.Input, 'Price')) + .Chain(EMAConv) + .Chain(TConverter.FieldOfRecord(EMAFactory.Output, 'MA')); + + ////////////// + panel := pnlChart.AddPanel; panel.AddDoubleSeries(equity.Sender, TAlphaColors.Blue, 3); + panel.AddDoubleSeries(equityEMA.Sender, TAlphaColors.Gray, 2); + + ///// +end; + +function TForm1.CreateStrategy2(Timeframe: TTimeframe): IMycProcessor>; +type + TSignal = record + Sig: Double; + SL: Double; + Entry: Double; + pnl: Double; + end; +var + panel: TMycChart.TPanel; +begin + var ticker := TConverter.CreateIdentity>; + Result := ticker; + + var OhlcPoint := ticker.Chain>(TConverter.CreateOhlcAggregation(Timeframe)); + + var Ohlc := OhlcPoint.Field('Data'); + + var Closes := Ohlc.Field('Close'); + + var Hull := Closes.Chain(TIndicators.CreateHMA(250)).MakeParallel; + var Sma := Closes.Chain(TIndicators.CreateSMA(200)).MakeParallel; + + var Lowest: Double := Double.MaxValue; + var Highest: Double := Double.MinValue; + + var ATR := Ohlc.Chain(TIndicators.CreateATR(50)).MakeParallel; + + // next stage + + var ATREndPoint := TConverter.CreateEndpoint(ATR.Sender, 5); + var ATRSeries: TSeries; + + var HullEndPoint := TConverter.CreateEndpoint(Hull.Sender, 5); + var HullSeries: TSeries; + + var SmaEndPoint := TConverter.CreateEndpoint(Sma.Sender, 5); + var SmaSeries: TSeries; + + var curr: TSignal; + curr.SL := Double.NaN; + curr.Entry := Double.NaN; + + var lastHull, lastSma: Double; + + var conv := + TConverter.Join( + [Ohlc.Field('Low').Sender, Ohlc.Field('High').Sender, Closes.Sender, ATR.Sender, Hull.Sender, Sma.Sender] + ); + + var Signal := + TConverter, TSignal>.CreateGeneric( + function(const Values: TArray): TSignal + begin + var low := Values[0]; + var high := Values[1]; + var close := Values[2]; + var atr := Values[3]; + var hull := Values[4]; + var sma := Values[5]; + + if low < Lowest then + Lowest := low; + if high > Highest then + Highest := high; + + Result := curr; + Result.Sig := 0; + var pnl: double := NaN; + + if (hull < sma) and (lastHull >= lastSma) then + begin + if curr.Sig > 0 then + pnl := close - curr.Entry; + + curr.Sig := -1; + curr.SL := Highest; + curr.Entry := close; + Result := curr; + end + else if (hull > sma) and (lastHull <= lastSma) then + begin + if curr.Sig < 0 then + pnl := curr.Entry - close; + + curr.Sig := 1; + curr.SL := Lowest; + curr.Entry := close; + Result := curr; + end; + + atr := 15 * atr; + if curr.Sig > 0 then + begin + if close > curr.SL then + begin + if curr.SL < close - atr then + curr.SL := close - atr; + Result.SL := curr.SL; + end; + + if low <= curr.SL then + begin + pnl := curr.SL - curr.Entry; + curr.Sig := 0; + Result.Sig := 0; + curr.SL := NaN; + end; + end + else if curr.Sig < 0 then + begin + if close < curr.SL then + begin + if curr.SL > close + atr then + curr.SL := close + atr; + Result.SL := curr.SL; + end; + + if high >= curr.SL then + begin + pnl := curr.Entry - curr.SL; + curr.Sig := 0; + Result.Sig := 0; + curr.SL := NaN; + end; + end; + + if Result.Sig <> 0 then + begin + Lowest := Double.MaxValue; + Highest := Double.MinValue; + Result.SL := Double.NaN; + Result.Entry := Double.NaN; + end; + + Result.pnl := pnl; + + lastHull := hull; + lastSma := sma; + end + ); + + conv.Link(Signal); + + var pnl := Signal.Field('pnl'); + + var equity: TConverter := TEquitySum.Create(10000); + pnl.Sender.Link(equity); + + var Layout := CurrLayout; + if Layout = nil then + exit; + + var Symbol := SelectedSymbol; + if Symbol = '' then + exit; + + var chart := TMycChart.Create(Self); + AlignControl(chart); + chart.Height := Layout.ChildrenRect.Width * 9 / 16; + chart.Lookback.Value := 50000; + + chart.SetXAxisSeries(M15, OhlcPoint.Field('Time').Sender); + + panel := chart.AddPanel; + panel.AddOhlcSeries(Ohlc.Sender); + panel.AddDoubleSeries(Hull.Sender, TAlphaColors.Cornflowerblue, 2); + panel.AddDoubleSeries(Sma.Sender, TAlphaColors.Brown, 1.5); + panel.AddDoubleSeries(Signal.Field('Entry').Sender, TAlphaColors.Green, 1); + panel.AddDoubleSeries(Signal.Field('SL').Sender, TAlphaColors.Red, 2); + + var mean := TConverter, Double>.CreateGeneric(TIndicators.CreateMean()); + + TConverter.Join([Hull.Sender, Sma.Sender]).Link(mean); + + panel.AddDoubleSeries(mean.Sender, TAlphaColors.Blue, 5); + + var pnlChart := TMycChart.Create(Self); + AlignControl(pnlChart); + pnlChart.Height := Layout.ChildrenRect.Width * 9 / 24; + pnlChart.Lookback.Value := 50000; + + pnlChart.SetXAxisCounter(equity.Sender); + + //////////// + var EMAFactory := TEMA.Create; + + var Params := TDataRecord.CreateFrom(EMAFactory.Params); + Params.SetValue('Period', 20); + + var indi := EMAFActory.CreateIndicator(Params); + + var EMAConv := TConverter.CreateGeneric(indi); + + var equityEMA := + equity + .Chain(TConverter.FieldToRecord(EMAFactory.Input, 'Price')) + .Chain(EMAConv) + .Chain(TConverter.FieldOfRecord(EMAFactory.Output, 'MA')); + + ////////////// + + panel := pnlChart.AddPanel; + panel.AddDoubleSeries(equity.Sender, TAlphaColors.Blue, 3); + panel.AddDoubleSeries(equityEMA.Sender, TAlphaColors.Gray, 2); ///// end; diff --git a/Src/Myc.DataRecord.Impl.pas b/Src/Myc.DataRecord.Impl.pas index 25bc6de..39285ae 100644 --- a/Src/Myc.DataRecord.Impl.pas +++ b/Src/Myc.DataRecord.Impl.pas @@ -11,238 +11,69 @@ uses Myc.DataRecord; type - // The builder implementation class, now in the global scope. - TDataRecordBuilder = class(TInterfacedObject, TDataRecord.TBuilder.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) + TFieldLayoutComparer = class(TComparer) strict private class var - FDefaultComparer: IComparer; + FDefaultComparer: IComparer; class constructor CreateClass; public - function Compare(const Left, Right: TDataRecord.TFieldLayout): Integer; override; - class property DefaultComparer: IComparer read FDefaultComparer; + function Compare(const Left, Right: TDataRecord.TField): Integer; override; + class property DefaultComparer: IComparer read FDefaultComparer; end; implementation -{ TDataRecordBuilder } - -constructor TDataRecordBuilder.Create; +(* +procedure TIntegerField.GetRaw(const [ref] Buffer: TBytes; Dst: Pointer); begin - inherited; - FStagedValues := TList>.Create; + PInteger(Dst)^ := PInteger(GetRawRef(Buffer))^; end; -destructor TDataRecordBuilder.Destroy; +procedure TIntegerField.SetRaw(const [ref] Buffer: TBytes; Src: Pointer); begin - FStagedValues.Free; - inherited; + PInteger(GetRawRef(Buffer))^ := PInteger(Src)^; end; -procedure TDataRecordBuilder.AddField(const Name: String; const Value: TValue); +procedure TSingleField.GetRaw(const [ref] Buffer: TBytes; Dst: Pointer); begin - FStagedValues.Add(TPair.Create(Name, Value)); + PSingle(Dst)^ := PSingle(GetRawRef(Buffer))^; end; -procedure TDataRecordBuilder.SetupRecord(out Layout: TArray; out Buffer: TBytes); -var - layoutList: TList; - pair: TPair; - field: TDataRecord.TFieldLayout; +procedure TSingleField.SetRaw(const [ref] Buffer: TBytes; Src: Pointer); 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; + PSingle(GetRawRef(Buffer))^ := PSingle(Src)^; end; -{ TField and descendants... } -constructor TField.Create(ABuffer: TBytes; const AField: TDataRecord.TFieldLayout); +procedure TDoubleField.GetRaw(const [ref] Buffer: TBytes; Dst: Pointer); begin - inherited Create; - FBuffer := ABuffer; - FFieldLayout := AField; + PDouble(Dst)^ := PDouble(GetRawRef(Buffer))^; end; -procedure TField.GetRaw(Dst: Pointer); -var - Val: TValue; +procedure TDoubleField.SetRaw(const [ref] Buffer: TBytes; Src: Pointer); begin - TValue.MakeWithoutCopy(GetRawRef, FFieldLayout.TypeInfo, val, true); - val.ExtractRawData(Dst); + PDouble(GetRawRef(Buffer))^ := PDouble(Src)^; end; -function TField.GetRawRef: Pointer; +procedure TInt64Field.GetRaw(const [ref] Buffer: TBytes; Dst: Pointer); begin - Result := @FBuffer[FFieldLayout.Offset]; + PInt64(Dst)^ := PInt64(GetRawRef(Buffer))^; end; -procedure TField.SetRaw(Src: Pointer); -var - Val: TValue; +procedure TInt64Field.SetRaw(const [ref] Buffer: TBytes; Src: Pointer); begin - TValue.MakeWithoutCopy(Src, FFieldLayout.TypeInfo, val, true); - val.ExtractRawData(GetRawRef); + PInt64(GetRawRef(Buffer))^ := PInt64(Src)^; end; -{ TGenericField } - -function TGenericField.GetValue: T; -type - PT = ^T; +procedure TStringField.GetRaw(const [ref] Buffer: TBytes; Dst: Pointer); begin - Result := PT(@FBuffer[FFieldLayout.Offset])^; + PString(Dst)^ := PString(GetRawRef(Buffer))^; end; -procedure TGenericField.SetValue(const Value: T); -type - PT = ^T; +procedure TStringField.SetRaw(const [ref] Buffer: TBytes; Src: Pointer); begin - PT(@FBuffer[FFieldLayout.Offset])^ := Value; + PString(GetRawRef(Buffer))^ := PString(Src)^; 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; @@ -250,7 +81,7 @@ begin FDefaultComparer := TFieldLayoutComparer.Create; end; -function TFieldLayoutComparer.Compare(const Left, Right: TDataRecord.TFieldLayout): Integer; +function TFieldLayoutComparer.Compare(const Left, Right: TDataRecord.TField): Integer; begin Result := TComparer.Default.Compare(Left.Name, Right.Name); end; diff --git a/Src/Myc.DataRecord.pas b/Src/Myc.DataRecord.pas index 5b88950..e7dd3af 100644 --- a/Src/Myc.DataRecord.pas +++ b/Src/Myc.DataRecord.pas @@ -4,280 +4,335 @@ interface uses System.SysUtils, + System.Generics.Collections, System.Rtti, System.TypInfo; type - // A record that provides field-level access to managed data, stored in a byte buffer. + TDataFieldType = (dfFloat, dfInteger, dfString, dfTimestamp); + TDataRecord = record public type - 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; - - TFieldLayout = record - Name: string; - Offset: Integer; - Size: Integer; - TypeInfo: PTypeInfo; - end; - - // The interface helper record that provides the generic AddField method. - TBuilder = record - type - IBuilder = interface - procedure AddField(const Name: String; const Value: TValue); overload; - procedure SetupRecord(out Layout: TArray; out Buffer: TBytes); - end; - + TField = record private - FBuilder: IBuilder; + FFieldType: TDataFieldType; + FName: string; + FOffset: Integer; + FSize: Integer; + + procedure Write(SrcType: PTypeInfo; const Src; P: Pointer); + procedure Read(Src: Pointer; DstType: PTypeInfo; var Dst); + procedure Finalize(P: Pointer); + property Offset: Integer read FOffset; + property Size: Integer read FSize; + public - constructor Create(const ABuilder: IBuilder); + constructor Create(const AName: string; AFieldType: TDataFieldType; AOffset, ASize: Integer); - class operator Implicit(const AValue: IBuilder): TBuilder; overload; - class operator Implicit(const AValue: TBuilder): IBuilder; overload; + class function From(const AName: string; Offset: Integer): TField; overload; static; + class function From(const AName: string; const RttiType: TRttiType; Offset: Integer): TField; overload; static; - procedure AddField(const Name: String); overload; inline; - procedure AddField(const Name: String; const Value: T); overload; inline; + property FieldType: TDataFieldType read FFieldType; + property Name: string read FName; + end; - function CreateRec: TDataRecord; inline; + TLayout = record + private + FFields: TArray; + public + constructor Create(const AFields: TArray); + class function CreateFrom: TLayout; static; + function GetBufferSize: Integer; + function IndexOf(const Name: String): Integer; + property Fields: TArray read FFields; end; private - FLayout: TArray; + FLayout: TLayout; FBuffer: TBytes; public - class operator Initialize(out Dest: TDataRecord); + constructor Create(const ALayout: TLayout; const ABuffer: TBytes); + + class function CreateFrom: TDataRecord; overload; static; + class function CreateFrom(const Src: T): TDataRecord; overload; static; + class function CreateFrom(const Layout: TLayout): TDataRecord; overload; static; + procedure CopyFrom(const Src: T); + + procedure SetValue(const Name: String; const Value: T); overload; + procedure SetValue(Idx: Integer; const Value); overload; + + function GetValue(const Name: String): T; overload; + procedure GetValue(Idx: Integer; out Value); overload; + class operator Finalize(var Dest: TDataRecord); - class operator Assign(var Dest: TDataRecord; const [ref] Src: TDataRecord); - class function CreateBuilder: TBuilder; static; - - class function CreateFrom(const Rec: T): TDataRecord; static; - procedure AssignTo(var Rec: T); - function FitsRecord: Boolean; - - 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; + property Layout: TLayout read FLayout; end; implementation uses System.Classes, - System.Generics.Collections, Myc.DataRecord.Impl; -{ TDataRecord.TBuilder } - -constructor TDataRecord.TBuilder.Create(const ABuilder: IBuilder); +constructor TDataRecord.Create(const ALayout: TLayout; const ABuffer: TBytes); begin - FBuilder := ABuilder; + FLayout := ALayout; + FBuffer := ABuffer; end; -procedure TDataRecord.TBuilder.AddField(const Name: String; const Value: T); +procedure TDataRecord.CopyFrom(const Src: T); begin - FBuilder.AddField(Name, TValue.From(Value)); -end; + var ctx := TRttiContext.Create; + var rttiType := ctx.GetType(TypeInfo(T)); + var rttiFields := rttiType.GetFields; + var fields: TArray; -procedure TDataRecord.TBuilder.AddField(const Name: String); -begin - AddField(Name, Default(T)); -end; - -function TDataRecord.TBuilder.CreateRec: TDataRecord; -begin - FBuilder.SetupRecord(Result.FLayout, Result.FBuffer); -end; - -class operator TDataRecord.TBuilder.Implicit(const AValue: IBuilder): TBuilder; -begin - Result.FBuilder := AValue; -end; - -class operator TDataRecord.TBuilder.Implicit(const AValue: TBuilder): IBuilder; -begin - Result := AValue.FBuilder; -end; - -{ TDataRecord } - -function TDataRecord.GetField(const Name: String): IField; -var - idx: Integer; -begin - 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: TBuilder; -begin - // Create the implementation class and wrap it in the helper record. - Result := TDataRecord.TBuilder.Create(TDataRecordBuilder.Create); -end; - -class function TDataRecord.CreateFrom(const Rec: T): TDataRecord; -var - ctx: TRttiContext; - rttiType: TRttiType; - builder: TBuilder.IBuilder; -begin - // Create a builder to construct the TDataRecord - builder := CreateBuilder; - - // Use RTTI to iterate over the fields of the source record/object - ctx := TRttiContext.Create; - rttiType := ctx.GetType(TypeInfo(T)); - - // Add each field and its value to the builder - for var field in rttiType.GetFields do + for var i := 0 to High(rttiFields) do begin - builder.AddField(field.Name, field.GetValue(Pointer(@Rec))); - end; + var rf := rttiFields[i]; + var idx := FLayout.IndexOf(rf.Name); - // Create the final TDataRecord from the builder - builder.SetupRecord(Result.FLayout, Result.FBuffer); -end; - -procedure TDataRecord.AssignTo(var Rec: T); -var - ctx: TRttiContext; - rttiType: TRttiType; - fieldValue: TValue; - fieldIndex: Integer; - layout: TFieldLayout; -begin - Assert(FitsRecord); - - // Use RTTI to iterate over the fields of the destination record/object - ctx := TRttiContext.Create; - rttiType := ctx.GetType(TypeInfo(T)); - - for var rttiField in rttiType.GetFields do - begin - // Find the corresponding field in the TDataRecord by name - fieldIndex := IndexOf(rttiField.Name); - if fieldIndex >= 0 then + if (idx >= 0) then begin - layout := FLayout[fieldIndex]; - // Create a TValue from the data in our buffer - TValue.Make(@FBuffer[layout.Offset], layout.TypeInfo, fieldValue); - // Assign the value to the destination record's field - rttiField.SetValue(Pointer(@Rec), fieldValue); + var fld := FLayout.Fields[idx]; + + var S: PByte := @Src; + inc(S, rf.Offset); + var P := @FBuffer[FLayout.Fields[idx].Offset]; + + fld.Write(rf.FieldType.Handle, S^, P); end; end; end; -function TDataRecord.FitsRecord: Boolean; +class function TDataRecord.CreateFrom(const Layout: TLayout): TDataRecord; begin - var ctx := TRttiContext.Create; - var rttiType := ctx.GetType(TypeInfo(T)); - - for var rttiField in rttiType.GetFields do - begin - // Find the corresponding field in the TDataRecord by name - var fieldIndex := IndexOf(rttiField.Name); - if fieldIndex < 0 then - exit(false); - - if rttiField.DataType.Handle <> FLayout[fieldIndex].TypeInfo then - exit(false); - end; - exit(true); + var buf: TBytes; + SetLength(buf, Layout.GetBufferSize); + Result.Create(Layout, buf); end; -function TDataRecord.GetField(const Name: String): IField; -var - idx: Integer; +{ TDataRecord } + +class function TDataRecord.CreateFrom: TDataRecord; begin - 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; - if not Assigned(Result) then - Result := TField.Create(FBuffer, FLayout[idx]); + Result := CreateFrom(TLayout.CreateFrom); end; -function TDataRecord.IndexOf(const Name: String): Integer; -var - dummyLayout: TFieldLayout; +class function TDataRecord.CreateFrom(const Src: T): TDataRecord; begin - dummyLayout.Name := Name; - if not TArray.BinarySearch(FLayout, dummyLayout, Result, TFieldLayoutComparer.DefaultComparer) then - Result := -1; + Result := CreateFrom; + Result.CopyFrom(Src); end; -class operator TDataRecord.Assign(var Dest: TDataRecord; const [ref] Src: TDataRecord); +procedure TDataRecord.GetValue(Idx: Integer; out Value); begin - Finalize(Dest); - - Dest.FLayout := Src.FLayout; - SetLength(Dest.FBuffer, Length(Src.FBuffer)); - for var i := 0 to High(Dest.FLayout) do - begin - Assert(Dest.FLayout[i].Name = Src.Layout[i].Name); - Assert(Dest.FLayout[i].Offset = Src.Layout[i].Offset); - Assert(Dest.FLayout[i].Size = Src.Layout[i].Size); - Assert(Dest.FLayout[i].TypeInfo = Src.Layout[i].TypeInfo); - - var ofs := Dest.FLayout[i].Offset; - var P: PByte := @Dest.FBuffer[ofs]; - var Q: PByte := @Src.FBuffer[ofs]; - var Val: TValue; - TValue.Make(Q, Dest.FLayout[i].TypeInfo, val); - val.ExtractRawData(P); + var P := @FBuffer[FLayout.Fields[Idx].Offset]; + case FLayout.Fields[Idx].FieldType of + dfFloat: Double(Value) := PDouble(P)^; + dfInteger: Int64(Value) := PInt64(Value)^; + dfString: String(Value) := PString(Value)^; + dfTimestamp: TDateTime(Value) := PDateTime(Value)^; + else + Assert(false); end; end; -class operator TDataRecord.Initialize(out Dest: TDataRecord); +procedure TDataRecord.SetValue(Idx: Integer; const Value); begin - Dest.FLayout := nil; - Dest.FBuffer := nil; + var P := @FBuffer[FLayout.Fields[Idx].Offset]; + case FLayout.Fields[Idx].FieldType of + dfFloat: PDouble(P)^ := Double(Value); + dfInteger: PInt64(P)^ := Int64(Value); + dfString: PString(P)^ := String(Value); + dfTimestamp: PDateTime(P)^ := TDateTime(Value); + else + Assert(false); + end; +end; + +function TDataRecord.GetValue(const Name: String): T; +begin + var idx := FLayout.IndexOf(Name); + if (idx >= 0) then + FLayout.Fields[idx].Read(@FBuffer[FLayout.Fields[idx].Offset], TypeInfo(T), Result); +end; + +procedure TDataRecord.SetValue(const Name: String; const Value: T); +begin + var idx := FLayout.IndexOf(Name); + if (idx >= 0) then + FLayout.Fields[idx].Write(TypeInfo(T), Value, @FBuffer[FLayout.Fields[idx].Offset]); end; class operator TDataRecord.Finalize(var Dest: TDataRecord); begin - if (Dest.FBuffer = nil) or (Dest.FLayout = nil) then - Exit; + for var i := 0 to High(Dest.FLayout.Fields) do + Dest.FLayout.Fields[i].Finalize(@Dest.FBuffer[Dest.FLayout.Fields[i].Offset]); +end; - for var layout in Dest.FLayout do - begin - var P: PByte := @Dest.FBuffer[layout.Offset]; - var Val: TValue; - // 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); +constructor TDataRecord.TField.Create(const AName: string; AFieldType: TDataFieldType; AOffset, ASize: Integer); +begin + FName := AName; + FFieldType := AFieldType; + FOffset := AOffset; + FSize := ASize; +end; + +procedure TDataRecord.TField.Finalize(P: Pointer); +begin + case FFieldType of + dfFloat: PDouble(P)^ := 0; + dfInteger: PInt64(P)^ := 0; + dfString: PString(P)^ := ''; + dfTimestamp: PDateTime(P)^ := 0; + else + Assert(false); end; - Dest.FLayout := nil; - Dest.FBuffer := nil; +end; + +procedure TDataRecord.TField.Write(SrcType: PTypeInfo; const Src; P: Pointer); +begin + case FFieldType of + dfFloat: + begin + Assert(SrcType.Kind = tkFloat); + case GetTypeData(SrcType).FloatType of + ftSingle: PDouble(P)^ := PSingle(@Src)^; + ftDouble: PDouble(P)^ := PDouble(@Src)^; + else + Assert(false); + end; + end; + dfInteger: + begin + case SrcType.Kind of + tkInteger: PInt64(P)^ := PInteger(@Src)^; + tkInt64: PInt64(P)^ := PInt64(@Src)^; + else + Assert(false); + end; + end; + dfString: + begin + Assert(SrcType.Kind in [tkString, tkLString, tkUString, tkWString]); + PString(P)^ := PString(@Src)^; + end; + dfTimestamp: + begin + Assert(SrcType.Kind = tkFloat); + PDateTime(P)^ := PDateTime(@Src)^; + end; + else + Assert(false); + end; +end; + +class function TDataRecord.TField.From(const AName: string; const RttiType: TRttiType; Offset: Integer): TField; +begin + case rttiType.TypeKind of + tkInteger, tkInt64: Result.Create(AName, dfInteger, Offset, sizeof(Int64)); + tkFloat: + if (rttiType.Name = 'TDateTime') then + Result.Create(AName, dfTimestamp, Offset, sizeof(TDateTime)) + else + Result.Create(AName, dfFloat, Offset, sizeof(Double)); + tkString, tkWString, tkLString, tkUString: Result.Create(AName, dfString, Offset, sizeof(String)); + else + raise Exception.Create('Type not supported'); + end; +end; + +class function TDataRecord.TField.From(const AName: string; Offset: Integer): TField; +begin + var ctx := TRttiContext.Create; + Result := From(AName, ctx.GetType(TypeInfo(T)), Offset); +end; + +procedure TDataRecord.TField.Read(Src: Pointer; DstType: PTypeInfo; var Dst); +begin + case FFieldType of + dfFloat: + begin + Assert(DstType.Kind = tkFloat); + case GetTypeData(DstType).FloatType of + ftSingle: PSingle(@Dst)^ := PDouble(Src)^; + ftDouble: PDouble(@Dst)^ := PDouble(Src)^; + else + Assert(false); + end; + end; + dfInteger: + begin + case DstType.Kind of + tkInteger: PInteger(@Dst)^ := PInt64(Src)^; + tkInt64: PInt64(@Dst)^ := PInt64(Src)^; + else + Assert(false); + end; + end; + dfString: + begin + Assert(DstType.Kind in [tkString, tkLString, tkUString, tkWString]); + PString(@Dst)^ := PString(Src)^; + end; + dfTimestamp: + begin + Assert(DstType.Kind = tkFloat); + PDateTime(@Dst)^ := PDateTime(Src)^; + end; + else + Assert(false); + end; +end; + +constructor TDataRecord.TLayout.Create(const AFields: TArray); +begin + FFields := AFields; +end; + +{ TLayout } + +class function TDataRecord.TLayout.CreateFrom: TLayout; +begin + var ctx := TRttiContext.Create; + var rttiType := ctx.GetType(TypeInfo(T)); + var rttiFields := rttiType.GetFields; + var fields: TArray; + + // Add each field and its value to the builder + var ofs := 0; + SetLength(fields, Length(rttiFields)); + for var i := 0 to High(rttiFields) do + begin + var rf := rttiFields[i]; + fields[i] := TField.From(rf.Name, rf.FieldType, ofs); + inc(ofs, fields[i].Size); + ofs := (ofs + 7) and not 7; + end; + + Result.Create(fields); +end; + +function TDataRecord.TLayout.GetBufferSize: Integer; +begin + if (Length(FFields) = 0) then + exit(0); + + var n := High(FFields); + Result := FFields[n].FOffset + FFields[n].Size; + Result := (Result + 7) and not 7; +end; + +function TDataRecord.TLayout.IndexOf(const Name: String): Integer; +begin + for var i := 0 to High(FFields) do + if (FFields[i].Name = Name) then + exit(i); + exit(-1); end; end. diff --git a/Src/Myc.Trade.DataPoint.Impl.pas b/Src/Myc.Trade.DataPoint.Impl.pas index 4aca7c8..f2fa550 100644 --- a/Src/Myc.Trade.DataPoint.Impl.pas +++ b/Src/Myc.Trade.DataPoint.Impl.pas @@ -5,6 +5,7 @@ interface uses System.SysUtils, System.SyncObjs, + System.Generics.Collections, Myc.Signals, Myc.Mutable, Myc.Core.Notifier, @@ -147,13 +148,11 @@ type // A processor implementation that is owned by a controller. TMycContainedProcessor = class(TContainedObject, IMycProcessor) - type - TProc = function(const Value: T): TState of object; private - FProc: TProc; + FProc: TConstFunc; function ProcessData(const Value: T): TState; public - constructor Create(const Controller: IInterface; const AProc: TProc); + constructor Create(const Controller: IInterface; const AProc: TConstFunc); end; // Endpoint that collects data into a series. @@ -216,6 +215,33 @@ type property Timeframe: TTimeframe read GetTimeframe; end; + // Endpoint that collects data into a series. + TMycDataJoin = class(TInterfacedObject, TDataProvider>.IDataProvider) + type + PItem = ^TItem; + TItem = record + Next: PItem; + Value: T; + end; + + private + FReceivers: array of record + DataProvider: TDataProvider; + Processor: TMycContainedProcessor; + Tag: TDataProvider.TTag; + Queue: TQueue; + end; + + FSender: TMycContainedDataProvider>; + FLock: TSpinLock; + FCount: Integer; + function ProcessData(Idx: Integer; const Value: T): TState; + public + constructor Create(const ADataProviders: TArray>); + destructor Destroy; override; + property Sender: TMycContainedDataProvider> read FSender implements TDataProvider>.IDataProvider; + end; + implementation uses @@ -401,12 +427,6 @@ begin var TypeT := Context.GetType(TypeInfo(T)); var Fields := Context.GetType(TypeInfo(S)).GetFields; - var name := ''; - if AFieldName = 'Time' then - for var i := 0 to High(Fields) do - begin - name := name + ' ' + Fields[i].Name; - end; Assert(Assigned(Field), 'Field ' + AFieldName + ' not found'); Assert(Field.FieldType.TypeKind = TypeT.TypeKind, 'Incorrect type'); @@ -444,7 +464,7 @@ end; { TMycContainedProcessor } -constructor TMycContainedProcessor.Create(const Controller: IInterface; const AProc: TProc); +constructor TMycContainedProcessor.Create(const Controller: IInterface; const AProc: TConstFunc); begin inherited Create(Controller); FProc := AProc; @@ -803,4 +823,79 @@ begin end; end; +{ TMycDataJoin } + +constructor TMycDataJoin.Create(const ADataProviders: TArray>); +begin + inherited Create; + + SetLength(FReceivers, Length(ADataProviders)); + + FLock := TSpinLock.Create(false); + FCount := Length(FReceivers); + + FSender := TMycContainedDataProvider>.Create(Self); + + var cFunc := + function(Idx: Integer): TConstFunc + begin + Result := function(const Value: T): TState begin ProcessData(Idx, Value); end + end; + + for var i := 0 to High(FReceivers) do + with FReceivers[i] do + begin + Queue := TQueue.Create; + DataProvider := ADataProviders[i]; + Processor := TMycContainedProcessor.Create(Self, cFunc(i)); + Tag := DataProvider.Link(Processor); + end; +end; + +destructor TMycDataJoin.Destroy; +begin + for var i := High(FReceivers) downto 0 do + with FReceivers[i] do + begin + DataProvider.Unlink(FReceivers[i].Tag); + Processor.Free; + Queue.Free; + end; + + FSender.Free; + inherited; +end; + +function TMycDataJoin.ProcessData(Idx: Integer; const Value: T): TState; +begin + var Arr: TArray; + + FLock.Enter; + try + if FReceivers[Idx].Queue.Count = 0 then + dec(FCount); + + if FCount = 0 then + begin + SetLength(Arr, Length(FReceivers)); + Arr[Idx] := Value; + FCount := Length(FReceivers); + for var i := 0 to High(FReceivers) do + if i <> Idx then + begin + Arr[i] := FReceivers[i].Queue.Dequeue; + if FReceivers[i].Queue.Count > 0 then + dec(FCount); + end; + end + else + FReceivers[Idx].Queue.Enqueue(Value); + finally + FLock.Exit; + end; + + if Arr <> nil then + FSender.Broadcast(Arr); +end; + end. diff --git a/Src/Myc.Trade.DataPoint.pas b/Src/Myc.Trade.DataPoint.pas index d4ce1ce..060eb50 100644 --- a/Src/Myc.Trade.DataPoint.pas +++ b/Src/Myc.Trade.DataPoint.pas @@ -6,7 +6,8 @@ uses Myc.Signals, Myc.Mutable, Myc.Trade.Types, - Myc.Trade.DataArray; + Myc.Trade.DataArray, + Myc.DataRecord; type // A generic interface for components that process data of type T. @@ -119,6 +120,24 @@ type class function CreateSequence(Count: Integer; const Parent: TDataProvider): TArray>; overload; static; class function Parallel(Parent: TDataProvider): TConverter; static; + + class function FieldToRecord(const Layout: TDataRecord.TLayout; const Name: String): TConverter; static; + class function FieldOfRecord(const Layout: TDataRecord.TLayout; const Name: String): TConverter; static; + + type + TRecordMapping = record + Layout: TDataRecord.TLayout; + Fields: array of record + FromField, ToField: String + end; + end; + + class function DataMapping( + const Inputs: TArray; + const Output: TDataRecord.TLayout + ): TConverter, TDataRecord>; static; + + class function Join(const DataProviders: TArray>): TDataProvider>; static; end; implementation @@ -315,6 +334,69 @@ begin Result := TOhlcAggregation.Create(Timeframe); end; +class function TConverter.DataMapping( + const Inputs: TArray; + const Output: TDataRecord.TLayout +): TConverter, TDataRecord>; +var + Idxs: array of array of record + FromIdx, ToIdx: Integer + end; +begin + SetLength(Idxs, Length(Inputs)); + for var i := 0 to High(Idxs) do + begin + SetLength(Idxs[i], Length(Inputs[i].Fields)); + for var j := 0 to High(Idxs[i]) do + begin + Idxs[i][j].FromIdx := Inputs[i].Layout.IndexOf(Inputs[i].Fields[j].FromField); + Idxs[i][j].ToIdx := Output.IndexOf(Inputs[i].Fields[j].ToField); + end; + end; + + Result := + TConverter, TDataRecord>.CreateGeneric( + function(const Inputs: TArray): TDataRecord + var + tmp: array[0..63] of Byte; + begin + Result := TDataRecord.CreateFrom(Output); + for var i := 0 to High(Idxs) do + begin + for var j := 0 to High(Idxs[i]) do + begin + Inputs[i].GetValue(Idxs[i][j].FromIdx, tmp); + Result.SetValue(Idxs[i][j].ToIdx, tmp); + end; + end; + end + ); +end; + +class function TConverter.FieldOfRecord(const Layout: TDataRecord.TLayout; const Name: String): TConverter; +begin + var idx := Layout.IndexOf(Name); + Result := TConverter.CreateGeneric(function(const Value: TDataRecord): T begin Value.GetValue(idx, Result); end); +end; + +class function TConverter.FieldToRecord(const Layout: TDataRecord.TLayout; const Name: String): TConverter; +begin + var idx := Layout.IndexOf(Name); + Result := + TConverter.CreateGeneric( + function(const Value: T): TDataRecord + begin + Result := TDataRecord.CreateFrom(Layout); + Result.SetValue(idx, Value); + end + ); +end; + +class function TConverter.Join(const DataProviders: TArray>): TDataProvider>; +begin + Result := TMycDataJoin.Create(DataProviders); +end; + class function TConverter.Parallel(Parent: TDataProvider): TConverter; begin Result := TMycParallelConverter.Create; diff --git a/Src/Myc.Trade.Indicators.pas b/Src/Myc.Trade.Indicators.pas index 0e20f68..3508e1a 100644 --- a/Src/Myc.Trade.Indicators.pas +++ b/Src/Myc.Trade.Indicators.pas @@ -5,6 +5,9 @@ interface uses System.SysUtils, System.Math, + System.Generics.Collections, + System.Rtti, + Myc.DataRecord, Myc.Trade.Types, Myc.Trade.DataArray; @@ -78,8 +81,72 @@ type const AtrFunc: TConstFunc; Multiplier: Double ): TConstFunc; overload; static; + + class function CreateMean: TConstFunc, Double>; static; end; + TIndicatorFactory = class + type + TFunc = TConstFunc; + private + FParams: TDataRecord.TLayout; + FInput: TDataRecord.TLayout; + FOutput: TDataRecord.TLayout; + + public + constructor Create(const AParams, AInput, AOutput: TDataRecord.TLayout); + + function CreateIndicator(const Params: TDataRecord): TFunc; virtual; abstract; + + property Params: TDataRecord.TLayout read FParams; + property Input: TDataRecord.TLayout read FInput; + property Output: TDataRecord.TLayout read FOutput; + end; + + TEMA = class(TIndicatorFactory) + type + TParam = record + Period: Integer; + end; + + TInput = record + Price: Double; + end; + + TResult = record + MA: Double; + end; + + public + constructor Create; + function CreateIndicator(const Params: TDataRecord): TIndicatorFactory.TFunc; override; + end; + + TMACD = class + type + TParam = record + Fast: TConstFunc; + Slow: TConstFunc; + Signal: TConstFunc; + end; + + TInput = record + Price: Double; + end; + + TResult = record + MacdLine: Double; + SignalLine: Double; + Histogram: Double; + end; + + public + class function CreateMACD(const Param: TParam): TConstFunc; static; + end; + +var + Registry: TList; + implementation { TIndicators } @@ -466,4 +533,93 @@ begin end; end; +class function TIndicators.CreateMean: TConstFunc, Double>; +begin + Result := + function(const Value: TArray): Double + begin + if Length(Value) = 0 then + exit(NaN); + Result := Value[0]; + for var i := 1 to High(Value) do + Result := Result + Value[i]; + Result := Result / Length(Value); + end; +end; + +// Creates a MACD indicator from three provided moving average functions. +class function TMACD.CreateMACD(const Param: TParam): TConstFunc; +begin + Result := + function(const Input: TInput): TResult + var + fastVal, slowVal: Double; + begin + fastVal := Param.Fast(Input.Price); + slowVal := Param.Slow(Input.Price); + + if IsNan(slowVal) then // slowVal will be the last one to become non-NaN + begin + Result.MacdLine := Double.NaN; + Result.SignalLine := Double.NaN; + Result.Histogram := Double.NaN; + end + else + begin + Result.MacdLine := fastVal - slowVal; + Result.SignalLine := Param.Signal(Result.MacdLine); + if not IsNan(Result.SignalLine) then + Result.Histogram := Result.MacdLine - Result.SignalLine + else + Result.Histogram := Double.NaN; + end; + end; +end; + +constructor TEMA.Create; +begin + inherited + Create(TDataRecord.TLayout.CreateFrom, TDataRecord.TLayout.CreateFrom, TDataRecord.TLayout.CreateFrom) +end; + +function TEMA.CreateIndicator(const Params: TDataRecord): TIndicatorFactory.TFunc; +begin + var Period := Params.GetValue('Period'); + + var Input := TDataRecord.TLayout.CreateFrom; + var inPrice := Input.IndexOf('Price'); + + var Output := TDataRecord.TLayout.CreateFrom; + var outMA := Output.IndexOf('MA'); + + var CalcEMA := TIndicators.CreateEMA(Period); + + Result := + function(const Input: TDataRecord): TDataRecord + begin + var Price: Double; + Input.GetValue(inPrice, Price); + + var MA := CalcEMA(Price); + + Result := TDataRecord.CreateFrom(Output); + Result.SetValue(outMA, MA); + end; +end; + +constructor TIndicatorFactory.Create(const AParams, AInput, AOutput: TDataRecord.TLayout); +begin + inherited Create; + FParams := AParams; + FInput := AInput; + FOutput := AOutput; +end; + +initialization + Registry := TList.Create; + Registry.Add(TEMA.Create); + +finalization + Registry.Free; + end. diff --git a/Test/MycTests.dpr b/Test/MycTests.dpr index d8677e5..81ac9d0 100644 --- a/Test/MycTests.dpr +++ b/Test/MycTests.dpr @@ -30,8 +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', - TestDataRecord in 'TestDataRecord.pas', - TestDataRecord.RawAccess in 'TestDataRecord.RawAccess.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 a85868c..a956259 100644 --- a/Test/MycTests.dproj +++ b/Test/MycTests.dproj @@ -131,7 +131,6 @@ $(PreBuildEvent)]]> - Base diff --git a/Test/TestDataRecord.RawAccess.pas b/Test/TestDataRecord.RawAccess.pas index 63c12c7..2e5f63f 100644 --- a/Test/TestDataRecord.RawAccess.pas +++ b/Test/TestDataRecord.RawAccess.pas @@ -3,6 +3,7 @@ unit TestDataRecord.RawAccess; interface uses + System.SysuTils, DUnitX.TestFramework, Myc.DataRecord; @@ -26,6 +27,7 @@ uses type // A simple interface for testing managed type behavior. IMyTestInterface = interface + ['{1D23E456-AB78-4CD9-89EF-0123456789AB}'] // GUID for good practice, not strictly needed here function GetValue: integer; end; @@ -38,6 +40,8 @@ type function GetValue: integer; end; +{ TMyTestInterfaceImpl } + constructor TMyTestInterfaceImpl.Create(const AValue: Integer); begin inherited Create; @@ -52,86 +56,118 @@ end; procedure TTestDataRecordRawAccess.TestRawAccess_Integer; var rec: TDataRecord; + buffer: TBytes; field: TDataRecord.IField; - readValue, newValue: Integer; + initialValue, readValue, newValue: Integer; begin - // Arrange: Create a record with an integer field. + // Arrange: Create a record layout and its buffer. var builder := TDataRecord.CreateBuilder; - builder.AddField('IntField', 123); + builder.AddField('IntField'); rec := builder.CreateRec; field := rec.GetField('IntField'); Assert.IsNotNull(field, 'Field should exist'); - // Act & Assert (GetRaw): Read the initial value via raw pointer. - readValue := 0; - field.GetRaw(@readValue); - Assert.AreEqual(123, readValue, 'GetRaw should retrieve the correct integer value'); + SetLength(buffer, rec.GetBufferSize); + rec.Initialize(buffer); + try + // Set initial value using raw access + initialValue := 123; + field.SetRaw(buffer, @initialValue); - // Act (SetRaw): Set a new value via raw pointer. - newValue := 456; - field.SetRaw(@newValue); + // Act & Assert (GetRaw): Read the initial value via raw pointer. + readValue := 0; + field.GetRaw(buffer, @readValue); + Assert.AreEqual(123, readValue, 'GetRaw should retrieve the correct integer value'); - // Assert: Verify the new value using the typed accessor. - var typedField := rec.GetField('IntField'); - Assert.AreEqual(456, typedField.Value, 'SetRaw should update the integer value correctly'); + // Act (SetRaw): Set a new value via raw pointer. + newValue := 456; + field.SetRaw(buffer, @newValue); + + // Assert: Verify the new value using the typed accessor. + var typedField := rec.GetField('IntField'); + Assert.AreEqual(456, typedField.Value[buffer], 'SetRaw should update the integer value correctly'); + finally + rec.Finalize(buffer); + end; end; procedure TTestDataRecordRawAccess.TestRawAccess_Interface; var rec: TDataRecord; + buffer: TBytes; field: TDataRecord.IField; initialObj, readObj, newObj: IMyTestInterface; begin - // Arrange: Create a record with an interface field. - initialObj := TMyTestInterfaceImpl.Create(10); + // Arrange: Create a record layout and its buffer. var builder := TDataRecord.CreateBuilder; - builder.AddField('IField', initialObj); + builder.AddField('IField'); rec := builder.CreateRec; field := rec.GetField('IField'); Assert.IsNotNull(field, 'Field should exist'); - // Act & Assert (GetRaw): Read the initial interface via raw pointer. - readObj := nil; - field.GetRaw(@readObj); - Assert.IsNotNull(readObj, 'GetRaw should retrieve a non-nil interface'); - Assert.AreSame(initialObj, readObj, 'GetRaw should retrieve the same interface instance'); - Assert.AreEqual(10, readObj.GetValue, 'Value of retrieved interface should be correct'); + SetLength(buffer, rec.GetBufferSize); + rec.Initialize(buffer); + try + // Set initial value + initialObj := TMyTestInterfaceImpl.Create(10); + field.SetRaw(buffer, @initialObj); - // Act (SetRaw): Set a new interface via raw pointer. - newObj := TMyTestInterfaceImpl.Create(20); - field.SetRaw(@newObj); + // Act & Assert (GetRaw): Read the initial interface via raw pointer. + readObj := nil; + field.GetRaw(buffer, @readObj); + Assert.IsNotNull(readObj, 'GetRaw should retrieve a non-nil interface'); + Assert.AreSame(initialObj, readObj, 'GetRaw should retrieve the same interface instance'); + Assert.AreEqual(10, readObj.GetValue, 'Value of retrieved interface should be correct'); - // Assert: Verify the new interface is set correctly. - var typedField := rec.GetField('IField'); - Assert.AreSame(newObj, typedField.Value, 'SetRaw should update to the new interface instance'); - Assert.AreEqual(20, typedField.Value.GetValue, 'Value of new interface should be correct'); + // Act (SetRaw): Set a new interface via raw pointer. + newObj := TMyTestInterfaceImpl.Create(20); + field.SetRaw(buffer, @newObj); + + // Assert: Verify the new interface is set correctly. + var typedField := rec.GetField('IField'); + Assert.AreSame(newObj, typedField.Value[buffer], 'SetRaw should update to the new interface instance'); + Assert.AreEqual(20, typedField.Value[buffer].GetValue, 'Value of new interface should be correct'); + finally + rec.Finalize(buffer); + end; end; procedure TTestDataRecordRawAccess.TestRawAccess_String; var rec: TDataRecord; + buffer: TBytes; field: TDataRecord.IField; - readString, newString: string; + initialString, readString, newString: string; begin - // Arrange: Create a record with a string field. + // Arrange: Create a record layout and its buffer. var builder := TDataRecord.CreateBuilder; - builder.AddField('StrField', 'Hello'); + builder.AddField('StrField'); rec := builder.CreateRec; field := rec.GetField('StrField'); Assert.IsNotNull(field, 'Field should exist'); - // Act & Assert (GetRaw): Read the initial string via raw pointer. - readString := ''; - field.GetRaw(@readString); - Assert.AreEqual('Hello', readString, 'GetRaw should retrieve the correct string value'); + SetLength(buffer, rec.GetBufferSize); + rec.Initialize(buffer); + try + // Set initial value + initialString := 'Hello'; + field.SetRaw(buffer, @initialString); - // Act (SetRaw): Set a new string via raw pointer. - newString := 'World'; - field.SetRaw(@newString); + // Act & Assert (GetRaw): Read the initial string via raw pointer. + readString := ''; + field.GetRaw(buffer, @readString); + Assert.AreEqual('Hello', readString, 'GetRaw should retrieve the correct string value'); - // Assert: Verify the new string using the typed accessor. - var typedField := rec.GetField('StrField'); - Assert.AreEqual('World', typedField.Value, 'SetRaw should update the string value correctly'); + // Act (SetRaw): Set a new string via raw pointer. + newString := 'World'; + field.SetRaw(buffer, @newString); + + // Assert: Verify the new string using the typed accessor. + var typedField := rec.GetField('StrField'); + Assert.AreEqual('World', typedField.Value[buffer], 'SetRaw should update the string value correctly'); + finally + rec.Finalize(buffer); + end; end; initialization diff --git a/Test/TestDataRecord.pas b/Test/TestDataRecord.pas index 7139c57..e17f62d 100644 --- a/Test/TestDataRecord.pas +++ b/Test/TestDataRecord.pas @@ -3,472 +3,146 @@ unit TestDataRecord; interface uses + DunitX.TestFramework, System.SysUtils, - System.Classes, - System.Variants, - DUnitX.TestFramework, + System.DateUtils, 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; + // A record that contains all supported data types for testing + TMyTestRecord = record + MyInteger: Integer; + MyInt64: Int64; + MySingle: Single; + MyDouble: Double; + MyString: string; + MyTimestamp: TDateTime; end; [TestFixture] - TDataRecordTests = class - private - function CreateRecord(const FieldName: string; const Value: T): TDataRecord; + TTestDataRecord = class(TObject) public - // Test procedures are unchanged [Test] - [TestCase('TestZero', '0')] - [TestCase('TestPositive', '123')] - [TestCase('TestNegative', '-456')] - procedure Test_tkInteger_Succeeds(const AValue: Integer); + procedure TestLayoutCreation; [Test] - [TestCase('TestZero', '0')] - [TestCase('TestPositive', '1234567890123')] - [TestCase('TestNegative', '-9876543210987')] - procedure Test_tkInt64_Succeeds(const AValue: Int64); + procedure TestCreateFromInstanceAndGetValue; [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 Test_Assign_CreatesIndependentCopy; - - [Test] - procedure Test_Reassign_ReleasesOldData; - - // New tests for RTTI-based creation and assignment - [Test] - [IgnoreMemoryLeaks] - procedure Test_CreateFrom_AssignTo_Succeeds; - - [Test] - [IgnoreMemoryLeaks] - procedure Test_Assign_FromCreateFrom_IsIndependentCopy; + procedure TestSetValueAndGetValue; end; implementation uses - System.TypInfo, System.Rtti; -{ TDataRecordTests } +{ TTestDataRecord } -function TDataRecordTests.CreateRecord(const FieldName: string; const Value: T): TDataRecord; +procedure TTestDataRecord.TestLayoutCreation; var - // Use the TBuilder helper record. Its lifetime is managed automatically. - builder: TDataRecord.TBuilder; + layout: TDataRecord.TRecordLayout; + idx: Integer; + expectedSize: Integer; begin - builder := TDataRecord.CreateBuilder; - builder.AddField(FieldName, Value); - Result := builder.CreateRec; + // Test: Create layout from a record type + layout := TDataRecord.TRecordLayout.CreateFrom; + + // Assert: Check field count + Assert.IsTrue(Length(layout.Fields) = 6, 'Layout should have 6 fields'); + + // Assert: Check specific fields for correct type mapping + idx := layout.IndexOf('MyInteger'); + Assert.IsTrue(idx > -1, 'Field MyInteger not found'); + Assert.AreEqual(TDataFieldType.dfInteger, layout.Fields[idx].FieldType, 'MyInteger should be mapped to dfInteger'); + + idx := layout.IndexOf('MyString'); + Assert.IsTrue(idx > -1, 'Field MyString not found'); + Assert.AreEqual(TDataFieldType.dfString, layout.Fields[idx].FieldType, 'MyString should be mapped to dfString'); + + idx := layout.IndexOf('MySingle'); + Assert.IsTrue(idx > -1, 'Field MySingle not found'); + Assert.AreEqual(TDataFieldType.dfFloat, layout.Fields[idx].FieldType, 'MySingle should be mapped to dfFloat'); + + idx := layout.IndexOf('MyTimestamp'); + Assert.IsTrue(idx > -1, 'Field MyTimestamp not found'); + Assert.AreEqual(TDataFieldType.dfTimestamp, layout.Fields[idx].FieldType, 'MyTimestamp should be mapped to dfTimestamp'); + + // Assert: Check total buffer size (6 fields * 8 bytes each on x64 due to type promotion and alignment) + expectedSize := (sizeof(Int64) * 2) + (sizeof(Double) * 2) + sizeof(String) + sizeof(TDateTime); + Assert.AreEqual(expectedSize, layout.GetBufferSize, 'Buffer size calculation is incorrect'); end; -procedure TDataRecordTests.Test_tkInteger_Succeeds(const AValue: Integer); +procedure TTestDataRecord.TestCreateFromInstanceAndGetValue; var - rec: TDataRecord; - field: TDataRecord.IField; + srcRecord: TMyTestRecord; + dataRecord: TDataRecord; 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'); + // Setup: Create and populate a source record + srcRecord.MyInteger := 12345; + srcRecord.MyInt64 := 9876543210; + srcRecord.MySingle := 123.456; + srcRecord.MyDouble := 789.012345; + srcRecord.MyString := 'Hello Delphi!'; + srcRecord.MyTimestamp := EncodeDateTime(2024, 7, 19, 10, 30, 0, 0); + + // Test: Create a TDataRecord from the source record instance + dataRecord := TDataRecord.CreateFrom(srcRecord); + + // Assert: Retrieve each value and check for correctness + Assert.AreEqual(srcRecord.MyInt64, dataRecord.GetValue('MyInt64'), 'Int64 value mismatch'); + Assert.AreEqual(srcRecord.MyInteger, dataRecord.GetValue('MyInteger'), 'Integer value mismatch'); + Assert.AreEqual(srcRecord.MyString, dataRecord.GetValue('MyString'), 'String value mismatch'); + Assert.AreEqual(srcRecord.MyTimestamp, dataRecord.GetValue('MyTimestamp'), 'TDateTime value mismatch'); + + // Assert: Check float values with a tolerance for precision differences + Assert.AreEqual(srcRecord.MySingle, dataRecord.GetValue('MySingle'), 1e-6, 'Single value mismatch'); + Assert.AreEqual(srcRecord.MyDouble, dataRecord.GetValue('MyDouble'), 1e-9, 'Double value mismatch'); + + // Assert: Test type promotion (reading an Integer as Int64) + Assert.IsTrue(srcRecord.MyInteger = dataRecord.GetValue('MyInteger'), 'Integer to Int64 promotion failed'); end; -procedure TDataRecordTests.Test_tkInt64_Succeeds(const AValue: Int64); +procedure TTestDataRecord.TestSetValueAndGetValue; var - rec: TDataRecord; - field: TDataRecord.IField; + dataRecord: TDataRecord; + testInt: Integer; + testInt64: Int64; + testSingle: Single; + testDouble: Double; + testString: string; + testTimestamp: TDateTime; 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; + // Setup: Create an empty TDataRecord with the layout of TMyTestRecord + dataRecord := TDataRecord.CreateFrom; -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; + // Setup: Define test values + testInt := 54321; + testInt64 := 12345678901; + testSingle := 987.654; + testDouble := 543.210987; + testString := 'Testing SetValue'; + testTimestamp := Now; -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; + // Test: Set values for each field by name + dataRecord.SetValue('MyInteger', testInt); + dataRecord.SetValue('MyInt64', testInt64); + dataRecord.SetValue('MySingle', testSingle); + dataRecord.SetValue('MyDouble', testDouble); + dataRecord.SetValue('MyString', testString); + dataRecord.SetValue('MyTimestamp', testTimestamp); -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; + // Assert: Retrieve the values and check if they match what was set + Assert.AreEqual(testInt, dataRecord.GetValue('MyInteger'), 'SetValue failed for Integer'); + Assert.AreEqual(testInt64, dataRecord.GetValue('MyInt64'), 'SetValue failed for Int64'); + Assert.AreEqual(testString, dataRecord.GetValue('MyString'), 'SetValue failed for String'); + Assert.AreEqual(testTimestamp, dataRecord.GetValue('MyTimestamp'), 'SetValue failed for TDateTime'); -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.Test_Assign_CreatesIndependentCopy; -var - rec1, rec2: TDataRecord; - field1, field2: TDataRecord.IField; -begin - // Create original record - rec1 := CreateRecord('Value', 'Original'); - - // Assign to a new record, invoking operator Assign. This covers 'CreateFromRec'. - rec2 := rec1; - - // Verify the copy - Assert.IsTrue(Length(rec2.Layout) = 1, 'Copied record should have one field'); - Assert.AreEqual('Value', rec2.Layout[0].Name, 'Field name should be copied'); - field2 := rec2.GetField('Value'); - Assert.IsNotNull(field2, 'Field should exist in copied record'); - Assert.AreEqual('Original', field2.Value, 'Field value should be copied'); - - // Modify the copy and check for independence (deep copy) - field2.Value := 'Modified'; - - field1 := rec1.GetField('Value'); - Assert.AreEqual('Original', field1.Value, 'Original record should not be modified'); - Assert.AreEqual('Modified', field2.Value, 'Copied record should reflect modification'); -end; - -procedure TDataRecordTests.Test_Reassign_ReleasesOldData; -var - rec1, rec2: TDataRecord; - field: TDataRecord.IField; -begin - // Create two independent records with managed string fields. - // DUnitX will report a leak if the memory for rec1 is not freed upon reassignment. - rec1 := CreateRecord('OldValue', 'This should be released'); - rec2 := CreateRecord('NewValue', 'This should remain'); - - // Re-assign rec1. This should Finalize the old rec1 and Assign the new data. - rec1 := rec2; - - // Verify the state of the reassigned rec1 - Assert.AreEqual(-1, rec1.IndexOf('OldValue'), 'Old field should not exist anymore'); - Assert.AreNotEqual(-1, rec1.IndexOf('NewValue'), 'New field should exist'); - - field := rec1.GetField('NewValue'); - Assert.AreEqual('This should remain', field.Value, 'Value should be from the new record'); - - // Also check that rec2 is unaffected by the assignment - field := rec2.GetField('NewValue'); - Assert.AreEqual('This should remain', field.Value, 'Source record for assignment should be unchanged'); -end; - -procedure TDataRecordTests.Test_CreateFrom_AssignTo_Succeeds; -var - srcRec, dstRec: TTestRecord; - dataRec: TDataRecord; - fieldI: TDataRecord.IField; - fieldS: TDataRecord.IField; -begin - // Setup a standard record with data - srcRec.I := 123; - srcRec.S := 'Hello from RTTI'; - - // Create a TDataRecord from the standard record via RTTI - dataRec := TDataRecord.CreateFrom(srcRec); - - // Verify that the data was correctly transferred into the TDataRecord - Assert.IsTrue(Length(dataRec.Layout) = 2, 'Layout should have 2 fields'); - fieldI := dataRec.GetField('I'); - Assert.IsNotNull(fieldI, 'Integer field should exist'); - Assert.AreEqual(srcRec.I, fieldI.Value, 'Integer value should match'); - - fieldS := dataRec.GetField('S'); - Assert.IsNotNull(fieldS, 'String field should exist'); - Assert.AreEqual(srcRec.S, fieldS.Value, 'String value should match'); - - // Assign the data back from the TDataRecord to another standard record - dataRec.AssignTo(dstRec); - - // Verify that the data was correctly restored - Assert.AreEqual(srcRec.I, dstRec.I, 'Assigned back record integer should match'); - Assert.AreEqual(srcRec.S, dstRec.S, 'Assigned back record string should match'); -end; - -procedure TDataRecordTests.Test_Assign_FromCreateFrom_IsIndependentCopy; -var - srcRec: TTestRecord; - rec1, rec2: TDataRecord; - field1, field2: TDataRecord.IField; -begin - // Setup a record and create a TDataRecord from it - srcRec.I := 456; - srcRec.S := 'Original RTTI value'; - rec1 := TDataRecord.CreateFrom(srcRec); - - // Assign the TDataRecord to another, invoking operator Assign - rec2 := rec1; - - // Modify the string field in the copy - field2 := rec2.GetField('S'); - Assert.IsNotNull(field2, 'Field must exist in copy'); - field2.Value := 'Modified in copy'; - - // Verify that the original TDataRecord is unchanged - field1 := rec1.GetField('S'); - Assert.IsNotNull(field1, 'Field must exist in original'); - Assert.AreEqual('Original RTTI value', field1.Value, 'Original record should not be modified'); - Assert.AreEqual('Modified in copy', field2.Value, 'Copied record should reflect modification'); -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; + Assert.AreEqual(testSingle, dataRecord.GetValue('MySingle'), 1e-6, 'SetValue failed for Single'); + Assert.AreEqual(testDouble, dataRecord.GetValue('MyDouble'), 1e-9, 'SetValue failed for Double'); end; initialization - TDUnitX.RegisterTestFixture(TDataRecordTests); + TDUnitX.RegisterTestFixture(TTestDataRecord); end.