Delphi RTTI für Mapping ohne Magie: Attribute, Mapping-Plan und Debugbarkeit

unit NbRttiMap;

interface

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

type
  MapFromAttribute = class(TCustomAttribute)
  private
    FName: string;
  public
    constructor Create(const AName: string);
    property Name: string read FName;
  end;

  IValueReader = interface
    ['{E7A76C4E-5E3E-4F2D-8F7B-5F92C2F6A6D3}']
    function HasValue(const AName: string): Boolean; // Feld vorhanden?
    function IsNull(const AName: string): Boolean;   // Feld ist NULL?
    function GetValue(const AName: string): Variant; // Wert (Variant)
  end;

  TRttiMapOptions = set of (moDebug, moIgnoreMissing, moFailOnNull);

  ERttiMapError = class(Exception);

  TRttiMapper = class
  private
    type
      TPropMap = record
        Prop: TRttiProperty;
        SourceName: string;
      end;

      TTypeCache = class
      public
        Props: TArray<TPropMap>;
      end;
  private
    class var FCache: TObjectDictionary<PTypeInfo, TTypeCache>;
    class var FLock: TObject;

    class function BuildCache(ATypeInfo: PTypeInfo): TTypeCache; static;
    class function GetCache(ATypeInfo: PTypeInfo): TTypeCache; static;

    class function MapNameOf(const P: TRttiProperty): string; static;
    class function VariantToBoolean(const V: Variant): Boolean; static;
    class function VariantToEnumOrdinal(AEnumType: TRttiType; const V: Variant): Integer; static;

    class procedure SetPropValue(const Target: TObject; const P: TRttiProperty; const V: Variant); static;
  public
    class constructor Create;
    class destructor Destroy;

    class procedure MapToObject(const Reader: IValueReader; const Target: TObject;
      const Options: TRttiMapOptions = [moIgnoreMissing]); static;
  end;

implementation

constructor MapFromAttribute.Create(const AName: string);
begin
  inherited Create;
  FName := AName;
end;

class constructor TRttiMapper.Create;
begin
  FCache := TObjectDictionary<PTypeInfo, TTypeCache>.Create([doOwnsValues]);
  FLock := TObject.Create;
end;

class destructor TRttiMapper.Destroy;
begin
  FCache.Free;
  FLock.Free;
end;

class function TRttiMapper.MapNameOf(const P: TRttiProperty): string;
var
  A: TCustomAttribute;
begin
  Result := '';
  for A in P.GetAttributes do
    if A is MapFromAttribute then
      Exit(MapFromAttribute(A).Name);
end;

class function TRttiMapper.BuildCache(ATypeInfo: PTypeInfo): TTypeCache;
var
  Ctx: TRttiContext;
  T: TRttiType;
  P: TRttiProperty;
  L: TList<TPropMap>;
  M: TPropMap;
  Src: string;
begin
  Result := TTypeCache.Create;

  Ctx := TRttiContext.Create;
  T := Ctx.GetType(ATypeInfo);

  L := TList<TPropMap>.Create;
  try
    for P in T.GetProperties do
    begin
      if not P.IsWritable then
        Continue;

      Src := MapNameOf(P);
      if Src = '' then
        Continue; // Opt-in

      M.Prop := P;
      M.SourceName := Src;
      L.Add(M);
    end;

    Result.Props := L.ToArray;
  finally
    L.Free;
  end;
end;

class function TRttiMapper.GetCache(ATypeInfo: PTypeInfo): TTypeCache;
begin
  TMonitor.Enter(FLock);
  try
    if not FCache.TryGetValue(ATypeInfo, Result) then
    begin
      Result := BuildCache(ATypeInfo);
      FCache.Add(ATypeInfo, Result);
    end;
  finally
    TMonitor.Exit(FLock);
  end;
end;

class function TRttiMapper.VariantToBoolean(const V: Variant): Boolean;
var
  S: string;
begin
  if VarIsBool(V) then
    Exit(Boolean(V));

  if VarIsNumeric(V) then
    Exit(V <> 0);

  S := Trim(VarToStr(V)).ToLower;
  if (S = '1') or (S = 'true') or (S = 't') or (S = 'y') or (S = 'yes') then Exit(True);
  if (S = '0') or (S = 'false') or (S = 'f') or (S = 'n') or (S = 'no') then Exit(False);

  raise ERttiMapError.CreateFmt('Boolean-Konvertierung fehlgeschlagen: "%s"', [VarToStr(V)]);
end;

class function TRttiMapper.VariantToEnumOrdinal(AEnumType: TRttiType; const V: Variant): Integer;
var
  OrdV: Integer;
  Name: string;
  TD: PTypeData;
begin
  TD := GetTypeData(AEnumType.Handle);

  if VarIsNumeric(V) then
  begin
    OrdV := Integer(V);
    if (OrdV < TD^.MinValue) or (OrdV > TD^.MaxValue) then
      raise ERttiMapError.CreateFmt('Enum-Ordinal außerhalb Bereich: %d', [OrdV]);
    Exit(OrdV);
  end;

  Name := VarToStr(V);
  OrdV := GetEnumValue(AEnumType.Handle, Name);
  if OrdV < 0 then
    raise ERttiMapError.CreateFmt('Enum-Name unbekannt: "%s"', [Name]);

  Result := OrdV;
end;

class procedure TRttiMapper.SetPropValue(const Target: TObject; const P: TRttiProperty; const V: Variant);
var
  T: TRttiType;
  TV: TValue;
  OrdV: Integer;
begin
  T := P.PropertyType;

  case T.TypeKind of
    tkUString, tkString, tkLString, tkWString:
      TV := TValue.From<string>(VarToStr(V));

    tkInteger:
      TV := TValue.From<Integer>(VarAsType(V, varInteger));

    tkInt64:
      TV := TValue.From<Int64>(VarAsType(V, varInt64));

    tkFloat:
      TV := TValue.From<Double>(VarAsType(V, varDouble));

    tkEnumeration:
      begin
        if T.Handle = TypeInfo(Boolean) then
          TV := TValue.From<Boolean>(VariantToBoolean(V))
        else
        begin
          OrdV := VariantToEnumOrdinal(T, V);
          TV := TValue.FromOrdinal(T.Handle, OrdV);
        end;
      end;

  else
    raise ERttiMapError.CreateFmt('Nicht unterstützter Zieltyp (%s) für Property %s',
      [GetEnumName(TypeInfo(TTypeKind), Ord(T.TypeKind)), P.Name]);
  end;

  P.SetValue(Target, TV);
end;

class procedure TRttiMapper.MapToObject(const Reader: IValueReader; const Target: TObject;
  const Options: TRttiMapOptions);
var
  C: TTypeCache;
  M: TPropMap;
  V: Variant;
  Info: string;
begin
  if (Reader = nil) or (Target = nil) then
    raise ERttiMapError.Create('MapToObject: Reader oder Target ist nil');

  C := GetCache(Target.ClassInfo);

  for M in C.Props do
  begin
    if not Reader.HasValue(M.SourceName) then
    begin
      if not (moIgnoreMissing in Options) then
        raise ERttiMapError.CreateFmt('Quelle fehlt: "%s" für Property %s', [M.SourceName, M.Prop.Name]);
      Continue;
    end;

    if Reader.IsNull(M.SourceName) then
    begin
      if moFailOnNull in Options then
        raise ERttiMapError.CreateFmt('Quelle ist NULL: "%s" für Property %s', [M.SourceName, M.Prop.Name]);
      Continue;
    end;

    V := Reader.GetValue(M.SourceName);

    try
      SetPropValue(Target, M.Prop, V);
      if moDebug in Options then
      begin
        Info := Format('Mapped %s <- %s (VariantType=%d)', [M.Prop.Name, M.SourceName, VarType(V)]);
        OutputDebugString(PChar(Info));
      end;
    except
      on E: Exception do
        raise ERttiMapError.CreateFmt('Mapping-Fehler %s <- %s: %s', [M.Prop.Name, M.SourceName, E.Message]);
    end;
  end;
end;

end.

unit NbDataSetReader;

interface

uses
  Data.DB, System.Variants, NbRttiMap;

type
  TDataSetValueReader = class(TInterfacedObject, IValueReader)
  private
    FDS: TDataSet;
  public
    constructor Create(ADS: TDataSet);
    function HasValue(const AName: string): Boolean;
    function IsNull(const AName: string): Boolean;
    function GetValue(const AName: string): Variant;
  end;

implementation

constructor TDataSetValueReader.Create(ADS: TDataSet);
begin
  inherited Create;
  FDS := ADS;
end;

function TDataSetValueReader.HasValue(const AName: string): Boolean;
begin
  Result := (FDS <> nil) and (FDS.FindField(AName) <> nil);
end;

function TDataSetValueReader.IsNull(const AName: string): Boolean;
var
  F: TField;
begin
  F := FDS.FindField(AName);
  Result := (F = nil) or F.IsNull;
end;

function TDataSetValueReader.GetValue(const AName: string): Variant;
begin
  Result := FDS.FieldByName(AName).Value;
end;

end.

type
  TOrderState = (osOpen, osClosed);

  TOrderRow = class
  private
    FId: Int64;
    FCustomerNo: string;
    FIsClosed: Boolean;
    FState: TOrderState;
  public
    [MapFrom('order_id')]
    property Id: Int64 read FId write FId;

    [MapFrom('customer_no')]
    property CustomerNo: string read FCustomerNo write FCustomerNo;

    [MapFrom('is_closed')]
    property IsClosed: Boolean read FIsClosed write FIsClosed;

    [MapFrom('state')]
    property State: TOrderState read FState write FState; // z. B. 'osClosed' oder 1
  end;

var
  Row: TOrderRow;
  Reader: IValueReader;
begin
  Row := TOrderRow.Create;
  try
    Reader := TDataSetValueReader.Create(MyQuery);
    TRttiMapper.MapToObject(Reader, Row, [moIgnoreMissing, moDebug]);
  finally
    Row.Free;
  end;
end;