MycLib/Src/Myc.DataRecord.pas

unit Myc.DataRecord;

interface

uses
    System.SysUtils,
    System.Rtti,
    System.TypInfo;

type
    // A record that provides field-level access to managed data, stored in a byte buffer.
    TDataRecord = record
    public
        type
            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;

            TFieldLayout = record
                Name: string;
                Offset: Integer;
                Size: Integer;
                TypeInfo: PTypeInfo;
            end;

            // The interface helper record that provides the generic AddField<T> method.
            TBuilder = record
                type
                    IBuilder = interface
                        procedure AddField(const Name: String; const Value: TValue); overload;
                        procedure SetupRecord(out Layout: TArray<TFieldLayout>; out Buffer: TBytes);
                    end;

            private
                FBuilder: IBuilder;
            public
                constructor Create(const ABuilder: IBuilder);

                class operator Implicit(const AValue: IBuilder): TBuilder; overload;
                class operator Implicit(const AValue: TBuilder): IBuilder; overload;

                procedure AddField<T>(const Name: String); overload; inline;
                procedure AddField<T>(const Name: String; const Value: T); overload; inline;

                function CreateRec: TDataRecord; inline;
            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 CreateBuilder: TBuilder; static;

        class function CreateFrom<T>(const Rec: T): TDataRecord; static;
        procedure AssignTo<T>(var Rec: T);
        function FitsRecord<T>: Boolean;

        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;

implementation

uses
    System.Classes,
    System.Generics.Collections,
    Myc.DataRecord.Impl;

{ TDataRecord.TBuilder }

constructor TDataRecord.TBuilder.Create(const ABuilder: IBuilder);
begin
    FBuilder := ABuilder;
end;

procedure TDataRecord.TBuilder.AddField<T>(const Name: String; const Value: T);
begin
    FBuilder.AddField(Name, TValue.From<T>(Value));
end;

procedure TDataRecord.TBuilder.AddField<T>(const Name: String);
begin
    AddField<T>(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<T>(const Name: String): IField<T>;
var
    idx: Integer;
begin
    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: TBuilder;
begin
    // Create the implementation class and wrap it in the helper record.
    Result := TDataRecord.TBuilder.Create(TDataRecordBuilder.Create);
end;

class function TDataRecord.CreateFrom<T>(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
    begin
        builder.AddField(field.Name, field.GetValue(Pointer(@Rec)));
    end;

    // Create the final TDataRecord from the builder
    builder.SetupRecord(Result.FLayout, Result.FBuffer);
end;

procedure TDataRecord.AssignTo<T>(var Rec: T);
var
    ctx: TRttiContext;
    rttiType: TRttiType;
    fieldValue: TValue;
    fieldIndex: Integer;
    layout: TFieldLayout;
begin
    Assert(FitsRecord<T>);

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

function TDataRecord.FitsRecord<T>: Boolean;
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);
end;

function TDataRecord.GetField(const Name: String): IField;
var
    idx: Integer;
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]);
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);
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);
    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;
        // 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;

end.