MycLib/Src/Myc.DataRecord.pas

unit Myc.DataRecord;

interface

uses
    System.Rtti,
    System.TypInfo,
    System.SysUtils,
    System.Generics.Collections,
    System.Generics.Defaults;

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
                function GetValue: T;
                procedure SetValue(const Value: T);
                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;
                Size: Integer;
                TypeInfo: PTypeInfo;
            end;

            // Builder for dynamically creating a TDataRecord.
            TBuilder = record
            private
                FStagedValues: TList<TPair<string, TValue>>;
                class operator Initialize(out Dest: TBuilder);
                class operator Finalize(var Dest: TBuilder);
            public
                procedure AddField<T>(const Name: String; const Value: T); overload;
                procedure AddField(const Name: String; const Value: TValue); overload;
                function CreateRec: TDataRecord;
            end;
    private
        FLayout: TArray<TFieldLayout>;
        FBuffer: TBytes;
    public
        class operator Initialize(out Dest: TDataRecord);
        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>;

        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;

{$region 'TFieldLayoutComparer'}
class constructor TFieldLayoutComparer.CreateClass;
begin
    FDefault := TFieldLayoutComparer.Create;
end;

class destructor TFieldLayoutComparer.DestroyClass;
begin
    FDefault := nil;
end;

function TFieldLayoutComparer.Compare(const Left, Right: TDataRecord.TFieldLayout): Integer;
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;
end;

function TByteAccessor<T>.GetValue: T;
type
    PT = ^T;
begin
    Result := PT(@FBuffer[FField.Offset])^;
end;

procedure TByteAccessor<T>.SetValue(const Value: T);
type
    PT = ^T;
begin
    PT(@FBuffer[FField.Offset])^ := Value;
end;
{$endregion}

{$region 'TDataRecord'}
function TDataRecord.GetField<T>(const Name: String): IField<T>;
var
    dummyLayout: TFieldLayout;
    index: 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;
end;

class function TDataRecord.CreateBuilder: TDataRecord.TBuilder;
begin
    Result := Default(TDataRecord.TBuilder);
end;

class function TDataRecord.CreateFromRec<T>(const Rec: T): TDataRecord;
var
    ctx: TRttiContext;
    recType: TRttiRecordType;
    field: TRttiField;
    recValue: TValue;
    builder: TBuilder;
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));
    end;
    Result := builder.CreateRec;
end;

class operator TDataRecord.Assign(var Dest: TDataRecord; const [ref] Src: TDataRecord);
begin
    Finalize(Dest);

    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);
    end;
end;

class operator TDataRecord.Initialize(out Dest: TDataRecord);
begin
    Dest.FLayout := nil;
    Dest.FBuffer := nil;
end;

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.
        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.