MycLib/Src/Myc.Data.Records.pas

unit Myc.Data.Records;

interface

uses
    System.SysUtils,
    System.TypInfo;

type
    TDataRecord = record
    public
        type
            TFieldType = (dfFloat, dfInteger, dfString, dfTimestamp, dfRecord);

            TField = record
            private
                FFieldType: TFieldType;
                FName: string;
                FOffset: Integer;

                procedure FromType(const [ref] Buffer: TBytes; SrcType: PTypeInfo; const Src);
                procedure ToType(const [ref] Buffer: TBytes; DstType: PTypeInfo; var Dst);

                procedure InitField(const [ref] Buffer: TBytes);
                procedure AssignField(const [ref] Dest: TBytes; const [ref] Source: TBytes);
                procedure FinalizeField(const [ref] Buffer: TBytes);

                procedure CopyField(Src, Dst: Pointer);

                property Offset: Integer read FOffset;

                constructor Create(const AName: string; AFieldType: TFieldType; AOffset: Integer);

                function GetSize: Integer; inline;
                function GetAlignedSize: Integer; inline;

            public
                property FieldType: TFieldType read FFieldType;
                property Name: string read FName;
                property Size: Integer read GetSize;
                property AlignedSize: Integer read GetAlignedSize;
            end;

            TFieldDef = record
            public
                Name: String;
                FieldType: TFieldType
            end;

            TLayout = record
            private
                FFields: TArray<TField>;

                constructor Create(const AFields: TArray<TField>);

            public
                class function FromRecord<T>: TLayout; static;
                class function Construct(const Def: TArray<TFieldDef>): TLayout; static;

                function IndexOf(const Name: String): Integer;
                property Fields: TArray<TField> read FFields;
            end;

        const
            Align = sizeof(Pointer);

    private
        FLayout: TLayout;
        FBuffer: TBytes;

    public
        constructor Create(const ALayout: TLayout);

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

        class function FromRecord<T>: TDataRecord; overload; static;
        class function FromRecord<T>(const Src: T): TDataRecord; overload; static;

        procedure SetValue<T>(const Name: String; const Value: T); overload;
        procedure SetValue(Idx: Integer; const Value); overload;

        function GetValue<T>(const Name: String): T; overload;
        procedure GetValue(Idx: Integer; out Value); overload;

        procedure CopyValue(const SrcRec: TDataRecord; SrcIdx, DstIdx: Integer);

        property Layout: TLayout read FLayout;
    end;

implementation

uses
    System.Rtti;

const
    DataSize: array[TDataRecord.TFieldType] of Integer =
        (sizeof(Double), sizeof(Int64), sizeof(String), sizeof(TDateTime), sizeof(TDataRecord));

{ TDataRecord }

constructor TDataRecord.Create(const ALayout: TLayout);
begin
    FLayout := ALayout;

    var bufSize := 0;
    if Length(FLayout.Fields) > 0 then
        with FLayout.Fields[High(FLayout.Fields)] do
            bufSize := Offset + AlignedSize;

    SetLength(FBuffer, bufSize);
    for var i := 0 to High(FLayout.Fields) do
        FLayout.Fields[i].InitField(FBuffer);
end;

procedure TDataRecord.CopyValue(const SrcRec: TDataRecord; SrcIdx, DstIdx: Integer);
begin
    Assert(SrcRec.Layout.Fields[SrcIdx].FieldType = FLayout.Fields[SrcIdx].FieldType);

    var Src := @SrcRec.FBuffer[SrcRec.Layout.Fields[SrcIdx].Offset];
    var Dst := @FBuffer[FLayout.Fields[DstIdx].Offset];

    FLayout.Fields[SrcIdx].CopyField(Src, Dst);
end;

class function TDataRecord.FromRecord<T>: TDataRecord;
begin
    Result.Create(TLayout.FromRecord<T>);
end;

class function TDataRecord.FromRecord<T>(const Src: T): TDataRecord;
begin
    Result.Create(TLayout.FromRecord<T>);

    var ctx := TRttiContext.Create;
    var rttiType := ctx.GetType(TypeInfo(T));
    var rttiFields := rttiType.GetFields;
    var fields: TArray<TField>;

    for var i := 0 to High(rttiFields) do
    begin
        var rf := rttiFields[i];
        var idx := Result.Layout.IndexOf(rf.Name);

        if (idx >= 0) then
        begin
            var S: PByte := @Src;
            inc(S, rf.Offset);
            Result.Layout.Fields[idx].FromType(Result.FBuffer, rf.FieldType.Handle, S^);
        end;
    end;
end;

procedure TDataRecord.GetValue(Idx: Integer; out Value);
begin
    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)^;
        dfRecord: TDataRecord(Value) := TDataRecord(Value);
    else
        Assert(false);
    end;
end;

procedure TDataRecord.SetValue(Idx: Integer; const Value);
begin
    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);
        dfRecord: TDataRecord(P^) := TDataRecord(Value);
    else
        Assert(false);
    end;
end;

function TDataRecord.GetValue<T>(const Name: String): T;
begin
    var idx := FLayout.IndexOf(Name);
    if (idx >= 0) then
        FLayout.Fields[idx].ToType(FBuffer, TypeInfo(T), Result);
end;

procedure TDataRecord.SetValue<T>(const Name: String; const Value: T);
begin
    var idx := FLayout.IndexOf(Name);
    if (idx >= 0) then
        FLayout.Fields[idx].FromType(FBuffer, TypeInfo(T), Value);
end;

class operator TDataRecord.Assign(var Dest: TDataRecord; const [ref] Src: TDataRecord);
begin
    if Dest.FLayout.FFields <> Src.FLayout.FFields then
    begin
        Finalize(Dest);
        Dest.Create(Src.Layout);
    end;

    for var i := 0 to High(Dest.Layout.Fields) do
        Dest.Layout.Fields[i].AssignField(Dest.FBuffer, Src.FBuffer);
end;

class operator TDataRecord.Finalize(var Dest: TDataRecord);
begin
    for var i := High(Dest.FLayout.Fields) downto 0 do
        Dest.Layout.Fields[i].FinalizeField(Dest.FBuffer);
end;

constructor TDataRecord.TField.Create(const AName: string; AFieldType: TFieldType; AOffset: Integer);
begin
    FName := AName;
    FFieldType := AFieldType;
    FOffset := AOffset;
end;

procedure TDataRecord.TField.InitField(const [ref] Buffer: TBytes);
begin
    if not (FFieldType in [dfString, dfRecord]) then
        exit;

    Assert(FOffset + Size <= Length(Buffer));

    var P := @Buffer[FOffset];
    case FFieldType of
        dfString: Initialize(PString(P)^);
        dfRecord: Initialize(TDataRecord(P^));
    end;
end;

procedure TDataRecord.TField.FinalizeField(const [ref] Buffer: TBytes);
begin
    if not (FFieldType in [dfString, dfRecord]) then
        exit;

    Assert(FOffset + Size <= Length(Buffer));

    var P := @Buffer[FOffset];
    case FFieldType of
        dfString: Finalize(PString(P)^);
        dfRecord: Finalize(TDataRecord(P^));
    end;
end;

procedure TDataRecord.TField.FromType(const [ref] Buffer: TBytes; SrcType: PTypeInfo; const Src);
begin
    Assert(FOffset + Size <= Length(Buffer));

    var Dst := @Buffer[FOffset];
    case FFieldType of
        dfFloat:
        begin
            Assert(SrcType.Kind = tkFloat);
            case GetTypeData(SrcType).FloatType of
                ftSingle: PDouble(Dst)^ := PSingle(@Src)^;
                ftDouble: PDouble(Dst)^ := PDouble(@Src)^;
            else
                Assert(false);
            end;
        end;
        dfInteger:
        begin
            case SrcType.Kind of
                tkInteger: PInt64(Dst)^ := PInteger(@Src)^;
                tkInt64: PInt64(Dst)^ := PInt64(@Src)^;
            else
                Assert(false);
            end;
        end;
        dfString:
        begin
            Assert(SrcType.Kind in [tkString, tkLString, tkUString, tkWString]);
            PString(Dst)^ := PString(@Src)^;
        end;
        dfTimestamp:
        begin
            Assert(SrcType.Kind = tkFloat);
            Assert(SrcType.Name = PTypeInfo(TypeInfo(TDateTime)).Name);
            PDateTime(Dst)^ := PDateTime(@Src)^;
        end;
        dfRecord:
        begin
            Assert(SrcType = TypeInfo(TDataRecord));
            Assert(SrcType.Name = PTypeInfo(TypeInfo(TDataRecord)).Name);
            TDataRecord(Dst^) := TDataRecord(Src);
        end;
    else
        Assert(false);
    end;
end;

function TDataRecord.TField.GetSize: Integer;
begin
    Result := DataSize[FFieldType];
end;

function TDataRecord.TField.GetAlignedSize: Integer;
begin
    Result := (GetSize + (Align - 1)) and not (Align - 1);
end;

procedure TDataRecord.TField.ToType(const [ref] Buffer: TBytes; DstType: PTypeInfo; var Dst);
begin
    var Src := @Buffer[FOffset];
    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);
            Assert(DstType.Name = PTypeInfo(TypeInfo(TDateTime)).Name);
            PDateTime(@Dst)^ := PDateTime(Src)^;
        end;
        dfRecord:
        begin
            Assert(DstType = TypeInfo(TDataRecord));
            TDataRecord(Dst) := TDataRecord(Src^);
        end;
    else
        Assert(false);
    end;
end;

procedure TDataRecord.TField.AssignField(const [ref] Dest: TBytes; const [ref] Source: TBytes);
begin
    Assert(FOffset + Size <= Length(Dest));

    var Dst := @Dest[FOffset];
    var Src := @Source[FOffset];

    CopyField(Src, Dst);
end;

procedure TDataRecord.TField.CopyField(Src, Dst: Pointer);
begin
    case FFieldType of
        dfFloat: PDouble(Dst)^ := PDouble(Src)^;
        dfInteger: PInt64(Dst)^ := PInt64(Src)^;
        dfString: PString(Dst)^ := PString(Src)^;
        dfTimestamp: PDateTime(Dst)^ := PDateTime(Src)^;
        dfRecord: TDataRecord(Dst^) := TDataRecord(Src^);
    else
        Assert(false);
    end;
end;

constructor TDataRecord.TLayout.Create(const AFields: TArray<TField>);
begin
    FFields := AFields;
end;

class function TDataRecord.TLayout.Construct(const Def: TArray<TFieldDef>): TLayout;
var
    Fields: TArray<TField>;
begin
    SetLength(Fields, Length(Def));
    var ofs := 0;
    for var i := 0 to High(Fields) do
    begin
        Fields[i] := TField.Create(Def[i].Name, Def[i].FieldType, ofs);
        inc(ofs, Fields[i].AlignedSize);
    end;
end;

{ TLayout }

class function TDataRecord.TLayout.FromRecord<T>: TLayout;
begin
    var ctx := TRttiContext.Create;
    var rttiType := ctx.GetType(TypeInfo(T));
    var rttiFields := rttiType.GetFields;
    var fields: TArray<TField>;

    // 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];
        var ft: TFieldType := Default(TFieldType);
        var supported := true;

        case rf.FieldType.TypeKind of
            tkInteger, tkInt64: ft := dfInteger;
            tkFloat:
                if rf.FieldType.HasName(GetTypeName(TypeInfo(TDateTime))) then
                    ft := dfTimestamp
                else
                    ft := dfFloat;
            tkString, tkWString, tkLString, tkUString: ft := dfString;
            tkMRecord:
            begin
                if rf.FieldType.HasName(GetTypeName(TypeInfo(TDataRecord))) then
                    ft := dfRecord
                else
                    supported := false;
            end;
        else
            supported := false;
        end;

        if not supported then
            raise Exception.Create('Type ' + rf.FieldType.Name + ' not supported in data records');

        fields[i] := TField.Create(rf.Name, ft, ofs);
        inc(ofs, fields[i].AlignedSize);
    end;

    Result.Create(fields);
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.