Delphi RTTI למיפוי ללא קסמים: מבוסס מאפיינים, ניתן לניפוי שגיאות ותואם למערכות ישנות

unit RttiMapping;

interface

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

type
  // Explizites Mapping: Property <- Quellname
  MapFromAttribute = class(TCustomAttribute)
  private
    FName: string;
  public
    constructor Create(const AName: string);
    property Name: string read FName;
  end;

  // Kleine Abstraktion: Wert liefern + Existenz/NULL unterscheiden
  IValueReader = interface
    ['{7D1E5864-7D3A-4D30-BD1C-0A94F7E6C0EF}']
    function HasValue(const AName: string): Boolean;
    function IsNull(const AName: string): Boolean;
    function GetValue(const AName: string): Variant;
  end;

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

  ERttiMappingError = class(Exception);

  TRttiMapper = class
  private
    type
      TPropMap = record
        Prop: TRttiProperty;
        SourceName: string;
      end;
      TTypeCache = class
        Props: TArray<TPropMap>;
      end;
  private
    class var FCache: TObjectDictionary<PTypeInfo, TTypeCache>;
    class var FCacheLock: TObject;

    class function GetOrBuildCache(ATypeInfo: PTypeInfo): TTypeCache; static;
    class function FindMapFromAttr(const AProp: TRttiProperty): string; static;
    class procedure SetPropertyValue(const AInstance: TObject; const AProp: TRttiProperty;
      const AValue: Variant); static;
    class function VariantToBoolean(const V: Variant): Boolean; static;
    class function VariantToEnumOrdinal(AEnumType: TRttiType; const V: Variant): Integer; static;
  public
    class constructor Create;
    class destructor Destroy;

    class procedure MapToObject(const AReader: IValueReader; const ATarget: TObject;
      const AOptions: TRttiMapOptions = [moIgnoreMissing]); static;
  end;

implementation

{ MapFromAttribute }

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

{ TRttiMapper }

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

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

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

class function TRttiMapper.GetOrBuildCache(ATypeInfo: PTypeInfo): TTypeCache;
var
  Ctx: TRttiContext;
  RType: TRttiType;
  P: TRttiProperty;
  L: TList<TPropMap>;
  Src: string;
  M: TPropMap;
begin
  TMonitor.Enter(FCacheLock);
  try
    if FCache.TryGetValue(ATypeInfo, Result) then
      Exit;

    Result := TTypeCache.Create;

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

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

        // Opt-in: Nur Properties mit Attribut
        Src := FindMapFromAttr(P);
        if Src = '' then
          Continue;

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

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

    FCache.Add(ATypeInfo, Result);
  finally
    TMonitor.Exit(FCacheLock);
  end;
end;

class function TRttiMapper.VariantToBoolean(const V: Variant): Boolean;
var
  S: string;
begin
  if VarIsBool(V) then
    Exit(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 ERttiMappingError.CreateFmt('Boolean-Konvertierung fehlgeschlagen: "%s"', [VarToStr(V)]);
end;

class function TRttiMapper.VariantToEnumOrdinal(AEnumType: TRttiType; const V: Variant): Integer;
var
  Ord: Integer;
  Name: string;
begin
  if VarIsNumeric(V) then
  begin
    Ord := Integer(V);
    if (Ord < GetTypeData(AEnumType.Handle)^.MinValue) or
       (Ord > GetTypeData(AEnumType.Handle)^.MaxValue) then
      raise ERttiMappingError.CreateFmt('Enum-Ordinal außerhalb des Bereichs: %d', [Ord]);
    Exit(Ord);
  end;

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

class procedure TRttiMapper.SetPropertyValue(const AInstance: TObject;
  const AProp: TRttiProperty; const AValue: Variant);
var
  V: TValue;
  T: TRttiType;
  Ord: Integer;
begin
  T := AProp.PropertyType;

  // Konvertierung bewusst selektiv: lieber klar scheitern als still "irgendwie".
  case T.TypeKind of
    tkUString, tkString, tkLString, tkWString:
      V := TValue.From<string>(VarToStr(AValue));

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

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

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

    tkSet:
      raise ERttiMappingError.CreateFmt('Set-Mapping nicht implementiert für %s', [AProp.Name]);

    tkClass:
      raise ERttiMappingError.CreateFmt('Class-Property Mapping nicht implementiert für %s', [AProp.Name]);
  else
    raise ERttiMappingError.CreateFmt('TypeKind nicht unterstützt (%s) für %s',
      [GetEnumName(TypeInfo(TTypeKind), Ord(T.TypeKind)), AProp.Name]);
  end;

  AProp.SetValue(AInstance, V);
end;

class procedure TRttiMapper.MapToObject(const AReader: IValueReader;
  const ATarget: TObject; const AOptions: TRttiMapOptions);
var
  Cache: TTypeCache;
  M: TPropMap;
  V: Variant;
  Msg: string;
begin
  if (ATarget = nil) or (AReader = nil) then
    raise ERttiMappingError.Create('MapToObject: Reader oder Target ist nil');

  Cache := GetOrBuildCache(ATarget.ClassInfo);

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

    if AReader.IsNull(M.SourceName) then
    begin
      if moIgnoreNull in AOptions then
        Continue;
      // Ohne Nullable/Optional-Mechanik kann man NULL nicht sinnvoll setzen.
      Continue;
    end;

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

    try
      SetPropertyValue(ATarget, M.Prop, V);
      if moDebug in AOptions then
      begin
        Msg := Format('Mapped %s <- %s (%s)', [M.Prop.Name, M.SourceName, VarTypeAsText(VarType(V))]);
        OutputDebugString(PChar(Msg));
      end;
    except
      on E: Exception do
        raise ERttiMappingError.CreateFmt('Mapping-Fehler bei %s <- %s: %s',
          [M.Prop.Name, M.SourceName, E.Message]);
    end;
  end;
end;

end.

uses Data.DB, System.Variants, RttiMapping;

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;

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;

type
  TOrderRow = class
  private
    FId: Int64;
    FCustomerNo: string;
    FIsClosed: Boolean;
  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;
  end;

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