Brummel/MycLib
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects 1 Releases Wiki Activity

DataRecord almost finished

Browse Source
This commit is contained in:
Michael Schimmel
2025-07-19 14:24:04 +02:00
parent 57319a55c1
commit 6010f61953
6 changed files with 747 additions and 257 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Src/Myc.DataRecord.pas
+88 -254
View File
@@ -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<T> = interface
IField = interface
procedure GetRaw(Dst: Pointer);
procedure SetRaw(Src: Pointer);
end;
IField<T> = 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<TFieldLayout>; out Buffer: TBytes);
end;
// The interface helper record that provides the generic AddField<T> method.
TBuilder = record
private
FStagedValues: TList<TPair<string, TValue>>;
class operator Initialize(out Dest: TBuilder);
class operator Finalize(var Dest: TBuilder);
FBuilder: IBuilder;
public
procedure AddField<T>(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<T>(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<TFieldLayout>;
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<T>(const Rec: T): TDataRecord; static;
class function CreateBuilder: TDataRecord.TBuilder; static;
function GetField<T>(const Name: String): IField<T>;
// 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<T>(const Name: String): IField<T>; overload;
property Layout: TArray<TFieldLayout> read FLayout;
end;
// Accessor for reading/writing data directly from/to the TBytes buffer.
TByteAccessor<T> = class(TInterfacedObject, TDataRecord.IField<T>)
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<TDataRecord.TFieldLayout>)
strict private
class var
FDefault: IComparer<TDataRecord.TFieldLayout>;
class constructor CreateClass;
class destructor DestroyClass;
public
function Compare(const Left, Right: TDataRecord.TFieldLayout): Integer; override;
class property Default: IComparer<TDataRecord.TFieldLayout> 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<T>(const Name: String; const Value: T);
begin
FDefault := nil;
FBuilder.AddField(Name, TValue.From<T>(Value));
end;
function TFieldLayoutComparer.Compare(const Left, Right: TDataRecord.TFieldLayout): Integer;
function TDataRecord.TBuilder.CreateRec: TDataRecord;
begin
Result := TComparer<string>.Default.Compare(Left.Name, Right.Name);
end;
{$endregion}
{$region 'TByteAccessor<T>'}
constructor TByteAccessor<T>.Create(ABuffer: TBytes; const AField: TDataRecord.TFieldLayout);
begin
inherited Create;
FBuffer := ABuffer;
FField := AField;
FBuilder.SetupRecord(Result.FLayout, Result.FBuffer);
end;
function TByteAccessor<T>.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<T>.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<T>(const Name: String): IField<T>;
var
dummyLayout: TFieldLayout;
index: Integer;
idx: Integer;
begin
Result := nil;
dummyLayout.Name := Name;
if TArray.BinarySearch<TFieldLayout>(FLayout, dummyLayout, index, TFieldLayoutComparer.Default) then
begin
if (FLayout[index].TypeInfo <> nil) and (FLayout[index].TypeInfo = System.TypeInfo(T)) then
begin
Result := TByteAccessor<T>.Create(FBuffer, FLayout[index]);
end;
end;
idx := IndexOf(Name);
if idx < 0 then
exit;
if TypeInfo(T) <> FLayout[idx].TypeInfo then
exit;
Result := TGenericField<T>.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<T>(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<T>(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<TFieldLayout>(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<T>(const Name: String; const Value: T);
begin
FStagedValues.Add(TPair<string, TValue>.Create(Name, TValue.From<T>(Value)));
end;
procedure TDataRecord.TBuilder.AddField(const Name: String; const Value: TValue);
begin
// Overload to accept a TValue directly.
FStagedValues.Add(TPair<string, TValue>.Create(Name, Value));
end;
function TDataRecord.TBuilder.CreateRec: TDataRecord;
var
layoutList: TList<TFieldLayout>;
pair: TPair<string, TValue>;
layout: TFieldLayout;
begin
layoutList := TList<TFieldLayout>.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<TPair<string, TValue>>.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<String>;
bAccess: TDataRecord.IField<Integer>;
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<TTestRec>(testRec);
// Test reading a string value
nameAccess := R.GetField<String>('Name');
Assert(Assigned(nameAccess));
Assert(nameAccess.Value = 'Hi');
// Test reading an integer value
bAccess := R.GetField<Integer>('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<Integer>('B');
Assert(bAccess2.Value = 99);
// Verify that a request for a wrong type returns nil
var aAccess := R.GetField<String>('A');
Assert(not Assigned(aAccess));
// Test the builder pattern
var RecBuilder: TDataRecord.TBuilder := TDataRecord.CreateBuilder;
RecBuilder.AddField<Double>('ZValue', 222.0);
RecBuilder.AddField<string>('AValue', 'Builder Test');
var S := RecBuilder.CreateRec;
var T := S;
var dblAccess := T.GetField<Double>('ZValue');
Assert(Assigned(dblAccess));
Assert(dblAccess.Value = 222.0);
var strAccess := T.GetField<String>('AValue');
Assert(Assigned(strAccess));
Assert(strAccess.Value = 'Builder Test');
{
// Test JSON parsing
var jsonRec := TDataRecord.CreateFromJSON(JSON_DATA);
var intAccess := jsonRec.GetField<Int64>('IntValue');
Assert(Assigned(intAccess));
Assert(intAccess.Value = 123);
strAccess := jsonRec.GetField<string>('StringValue');
Assert(Assigned(strAccess));
Assert(strAccess.Value = 'Hello JSON');
dblAccess := jsonRec.GetField<Double>('FloatValue');
Assert(Assigned(dblAccess));
Assert(dblAccess.Value = 99.9);
var boolAccess := jsonRec.GetField<Boolean>('BoolValue');
Assert(Assigned(boolAccess));
Assert(boolAccess.Value = true);
}
end;
end.