unit Bcl.Rtti.Utils;

{$I Bcl.Inc}

interface

uses
  SysUtils, Rtti, TypInfo;

type
  TMemberKind = (Field, Prop);

  TCustomAttributeClass = class of TCustomAttribute;

  TRttiUtils = class
  strict private
    class var
      FInstance: TRttiUtils;
  strict private
    FContext: TRttiContext;
    procedure PrivateCreate;
    procedure PrivateDestroy;
    function GenericTypePrefix(const S: string): string;
  protected
    function IsGenericOfSimpleName(Clazz: TClass; const Name: string): Boolean; overload;
    {$IFDEF DELPHIXE2_LVL}
    function IsGenericOfQualifiedName(Clazz: TClass; const Name: string): Boolean; overload;
    {$ENDIF}

    function IsGenericOfSimpleName(RttiType: TRttiType; const Name: string): Boolean; overload;
    function IsGenericOfQualifiedName(RttiType: TRttiType; const Name: string): Boolean; overload;

    function ReachGenericClass(Clazz: TClass): TClass;
  public
    class function GetInstance: TRttiUtils; static;
    class destructor Destroy;
    function GetType(Clazz: TClass): TRttiType;
    function FindMember(Clazz: TClass; MemberName: string): TRttiMember;
    function GetMember(Clazz: TClass; MemberName: string): TRttiMember;
    function GetMemberKind(Member: TRttiMember): TMemberKind;
    function GetMemberRttiType(Member: TRttiMember): TRttiType;
    function GetRealType(RttiType: TRttiType): TRttiType; overload;
    function GetRealType(ATypeInfo: PTypeInfo): PTypeInfo; overload;
    function GetSurroundedClass(ListClass: TClass): TClass;
    function GetSurroundedType(RttiType: TRttiType): TRttiType;
    function IsNullable(RttiType: TRttiType): boolean; overload;
    function IsNullable(ATypeInfo: PTypeInfo): boolean; overload;
    function IsProxy(RttiType: TRttiType): boolean;
    function GetValue(Member: TRttiMember; Instance: Pointer): TValue;
    procedure SetValue(Member: TRttiMember; Instance: Pointer; Value: TValue);
    function GetAttribute(ARttiObj: TRttiObject; AAttributeClass: TCustomAttributeClass): TCustomAttribute;
    function TryGetAttribute<T: TCustomAttribute>(ARttiObj: TRttiObject; out AAttribute: T): Boolean;
    function IsString(const AValue: TValue): Boolean;

    // Be careful when using "ExtractGeneric*" functions passing a string as parameter.
    // If you pass the name of a type
    // that inherits from a generic type, it will fail (because there will be no "<" character)
    function ExtractGenericParameters(const TypeName: string): TArray<string>; overload;
    function ExtractGenericTypes(const TypeName: string): TArray<TRttiType>; overload;

    function ExtractGenericParameters(Clazz: TClass): TArray<string>; overload;
    function ExtractGenericTypes(Clazz: TClass): TArray<TRttiType>; overload;

    // Check if RttiType is or inherits from a type where name starts with Name.
    // Name can be simple or qualified name. For Delphi 2010 and XE, it will
    // ignore qualified names and use only simple names.
    // Example: IsGenericOf(RttiType, 'TList<')
    //          IsGenericOf(RttiType, 'System.Generics.Collections.TDictionary<')
    function IsGenericOf(RttiType: TRttiType; const Name: string): Boolean; overload;

    // Check if RttiType is a generic type of same type TargetClass. Generic parameter
    // of TargetClass is ignored.
    // Example:
    //   { The following tests are equivalent because it will just check if it's a TList< }
    //   IsGenericOf(RttiType, TList<TObject>)
    //   IsGenericOf(RttiType, TList<Integer>)
    function IsGenericOf(RttiType: TRttiType; TargetClass: TClass): Boolean; overload;

    // Check if InspectedClass is a generic type of same type TargetClass. Generic parameter
    // of TargetClass is ignored.
    // Example:
    //   { The following tests are equivalent because it will just check if it's a TList< }
    //   IsGenericOf(SomeClass, TList<TObject>)
    //   IsGenericOf(SomeClass, TList<Integer>)
    function IsGenericOf(InspectedClass, TargetClass: TClass): Boolean; overload;

    // Get the type name specified by ATypeName and replace the name of generic param specified
    // by index APAramIndex by the name AParamTypeName.
    // Example:
    //  ReplaceGenericParam('TList<TObject>', 0, 'TComponent') // Returns 'TList<TComponent>'
    function ReplaceGenericParam(const ATypeName: string; AParamIndex: Integer; const AParamTypeName: string): string;
  end;

  ERttiUtilsException = class(Exception)
  end;

  ERttiMemberNotFound = class(ERttiUtilsException)
  end;

  ERttiMemberNotFieldOrProperty = class(ERttiUtilsException)
  end;

  ECannotGetSurroundedType = class(ERttiUtilsException)
  public
    constructor Create(TypeName: string);
  end;

function SafeFindType(ARtti: TRttiContext; const AQualifiedName: string): TRttiInstanceType; overload;
function SafeFindType(ARtti: TRttiContext; AClass: TClass): TRttiInstanceType; overload;
function SafeInvoke(Instance: TObject; const MethodName: string; const Args: array of TValue): TValue;
function SafeGetProp(Instance: TObject; const PropName: string): TValue;
procedure SafeSetProp(Instance: TObject; const PropName: string; const Value: TValue);
function SafeGetIndexedProp(Instance: TObject; const PropName: string; const Args: array of TValue): TValue;

implementation

uses
  StrUtils;

function SafeFindType(ARtti: TRttiContext; AClass: TClass): TRttiInstanceType; overload;
var
  LocalType: TRttiType;
begin
  LocalType := ARtti.GetType(AClass);
  if (LocalType <> nil) and LocalType.IsInstance then
    Result := LocalType.AsInstance
  else
    raise ERttiUtilsException.CreateFmt('Could not find class %s', [AClass.ClassName]);
end;

function SafeFindType(ARtti: TRttiContext; const AQualifiedName: string): TRttiInstanceType;
var
  LocalType: TRttiType;
begin
  LocalType := ARtti.FindType(AQualifiedName);
  if (LocalType <> nil) and LocalType.IsInstance then
    Result := LocalType.AsInstance
  else
    raise ERttiUtilsException.CreateFmt('Could not find class %s', [AQualifiedName]);
end;

function SafeInvoke(Instance: TObject; const MethodName: string; const Args: array of TValue): TValue;
var
  Ctxt: TRttiContext;
  Method: TRttiMethod;
begin
  Ctxt := TRttiContext.Create;
  try
    Method := SafeFindType(Ctxt, Instance.ClassType).GetMethod(MethodName);
    if Method = nil then
      raise ERttiUtilsException.CreateFmt('Could not find method %s on type %s', [MethodName, Instance.ClassName]);
    Result := Method.Invoke(Instance, Args);
  finally
    Ctxt.Free;
  end;
end;

function SafeGetProp(Instance: TObject; const PropName: string): TValue;
var
  Ctxt: TRttiContext;
  Prop: TRttiProperty;
begin
  Ctxt := TRttiContext.Create;
  try
    Prop := SafeFindType(Ctxt, Instance.ClassType).GetProperty(PropName);
    if Prop = nil then
      raise ERttiUtilsException.CreateFmt('Could not find property %s on type %s', [PropName, Instance.ClassName]);
    Result := Prop.GetValue(Instance);
  finally
    Ctxt.Free;
  end;
end;

procedure SafeSetProp(Instance: TObject; const PropName: string; const Value: TValue);
var
  Ctxt: TRttiContext;
  Prop: TRttiProperty;
begin
  Ctxt := TRttiContext.Create;
  try
    Prop := SafeFindType(Ctxt, Instance.ClassType).GetProperty(PropName);
    if Prop = nil then
      raise ERttiUtilsException.CreateFmt('Could not find property %s on type %s', [PropName, Instance.ClassName]);
    Prop.SetValue(Instance, Value);
  finally
    Ctxt.Free;
  end;
end;

function SafeGetIndexedProp(Instance: TObject; const PropName: string; const Args: array of TValue): TValue;
var
  Ctxt: TRttiContext;
  Prop: TRttiIndexedProperty;
begin
  Ctxt := TRttiContext.Create;
  try
    Prop := SafeFindType(Ctxt, Instance.ClassType).GetIndexedProperty(PropName);
    if Prop = nil then
      raise ERttiUtilsException.CreateFmt('Could not find indexed property %s on type %s', [PropName, Instance.ClassName]);
    Result := Prop.GetValue(Instance, Args);
  finally
    Ctxt.Free;
  end;
end;

{ ECannotGetSurroundedType }

constructor ECannotGetSurroundedType.Create(TypeName: string);
begin
  inherited CreateFmt('Cannot get surrounded type of type "%s". ' +
    'Type "%s" must be a generic type.',
    [TypeName, TypeName]);
end;

{ TRttiUtils }

class destructor TRttiUtils.Destroy;
begin
  if FInstance <> nil then
  begin
    FInstance.PrivateDestroy;
    FInstance.Free;
    FInstance := nil;
  end;
end;

function TRttiUtils.ExtractGenericParameters(
  const TypeName: string): TArray<string>;
var
  Start: Integer;
  Index: Integer;
  Level: Integer;
  ArrayLen: Integer;
begin
  Result := nil;
  Start := Pos('<', TypeName);
  if Start = 0 then Exit;
  Inc(Start);
  repeat
    Level := 0;
    Index := Start;
    while Index <= Length(TypeName) do
    begin
      case TypeName[Index] of
        '<': Inc(Level);
        '>':
          begin
            if Level = 0 then Break;
            Dec(Level);
          end;
        ',': if Level = 0 then Break;
      end;
      Inc(Index);
    end;              

    ArrayLen := Length(Result);
    SetLength(Result, ArrayLen + 1);
    Result[ArrayLen] := Copy(TypeName, Start, Index - Start);
    Start := Index + 1;
  until Index >= Length(TypeName);
end;

function TRttiUtils.ExtractGenericTypes(const TypeName: string): TArray<TRttiType>;
var
  Params: TArray<string>;
  I: Integer;
begin
  Params := ExtractGenericParameters(TypeName);
  SetLength(Result, Length(Params));
  for I := 0 to Length(Params) - 1 do
    Result[I] := FContext.FindType(Params[I]);
end;

function TRttiUtils.FindMember(Clazz: TClass; MemberName: string): TRttiMember;
var
  RttiType: TRttiType;
begin
  RttiType := FContext.GetType(Clazz);
  Result := RttiType.GetField(MemberName);
  if Result = nil then
    Result := RttiType.GetProperty(MemberName);
end;

function TRttiUtils.GetType(Clazz: TClass): TRttiType;
begin
  Result := FContext.GetType(Clazz);
end;

function TRttiUtils.GenericTypePrefix(const S: string): string;
var
  P: Integer;
begin
  P := Pos('<', S);
  if P > 0 then
    Result := Copy(S, 1, P - 1)
  else
    Result := S;
end;

function TRttiUtils.GetAttribute(ARttiObj: TRttiObject;
  AAttributeClass: TCustomAttributeClass): TCustomAttribute;
var
  A: TCustomAttribute;
begin
  for A in ARttiObj.GetAttributes do
    if A.InheritsFrom(AAttributeClass) then
      Exit(A);
  Result := nil;
end;

class function TRttiUtils.GetInstance: TRttiUtils;
begin
  if FInstance = nil then
  begin
    FInstance := TRttiUtils.Create;
    FInstance.PrivateCreate;
  end;
  Result := FInstance;
end;

function TRttiUtils.GetMember(Clazz: TClass; MemberName: string): TRttiMember;
begin
  Result := FindMember(Clazz, MemberName);
  if Result = nil then
    raise ERttiMemberNotFound.CreateFmt('Member "%s" not found on class "%s".',
      [MemberName, Clazz.ClassName]);
end;

function TRttiUtils.GetMemberKind(Member: TRttiMember): TMemberKind;
begin
  if Member is TRttiField then
    Exit(TMemberKind.Field);

  if Member is TRttiProperty then
    Exit(TMemberKind.Prop);

  raise ERttiMemberNotFieldOrProperty.Create('Unexpected member type.');
end;

function TRttiUtils.GetMemberRttiType(Member: TRttiMember): TRttiType;
begin
  if Member is TRttiField then
    Exit(TRttiField(Member).FieldType);

  if Member is TRttiProperty then
    Exit(TRttiProperty(Member).PropertyType);

  raise ERttiMemberNotFieldOrProperty.CreateFmt('Unexpected member type: %s.',
    [Member.ClassName]);
end;

function TRttiUtils.GetRealType(ATypeInfo: PTypeInfo): PTypeInfo;
begin
  Result := GetRealType(FContext.GetType(ATypeInfo)).Handle;
end;

function TRttiUtils.GetRealType(RttiType: TRttiType): TRttiType;
begin
  if IsNullable(RttiType) then
    Result := GetRealType(RttiType.GetField('FValue').FieldType)
  else
  if IsProxy(RttiType) then
    Result := GetRealType(RttiType.GetField('FValue').FieldType)
  else
    Result := RttiType;
end;

function TRttiUtils.GetSurroundedClass(ListClass: TClass): TClass;
var
  SurroundedType: TRttiType;
begin
  SurroundedType := GetSurroundedType(FContext.GetType(ListClass));

  if not SurroundedType.IsInstance then
    raise ERttiUtilsException.CreateFmt('Invalid surrounded type: "%s".',
      [SurroundedType.ToString]);

  Result := SurroundedType.AsInstance.MetaclassType;
end;

function TRttiUtils.GetSurroundedType(RttiType: TRttiType): TRttiType;
var
  TypeName: string;
begin
  repeat
    TypeName := RttiType.ToString;
    if StartsStr('TList<', TypeName) and EndsStr('>', TypeName) then
    begin
      TypeName := AnsiRightStr(TypeName, Length(TypeName) - Length('TList<'));
      TypeName := AnsiLeftStr(TypeName, Length(TypeName) - Length('>'));
      Exit(FContext.FindType(TypeName));
    end;

    if StartsStr('TObjectList<', TypeName) and EndsStr('>', TypeName) then
    begin
      TypeName := AnsiRightStr(TypeName, Length(TypeName) - Length('TObjectList<'));
      TypeName := AnsiLeftStr(TypeName, Length(TypeName) - Length('>'));
      Exit(FContext.FindType(TypeName));
    end;
    RttiType := RttiType.AsInstance.BaseType;
  until RttiType = nil;

  raise ECannotGetSurroundedType.Create(TypeName);
end;

function TRttiUtils.GetValue(Member: TRttiMember; Instance: Pointer): TValue;
begin
  if Member is TRttiField then
    Exit(TRttiField(Member).GetValue(Instance));

  if Member is TRttiProperty then
    Exit(TRttiProperty(Member).GetValue(Instance));

  Assert(False);
end;

function TRttiUtils.IsGenericOf(RttiType: TRttiType;
  const Name: string): Boolean;
begin
  if Pos('.', Name) > 0 then
    Result := IsGenericOfQualifiedName(RttiType, Name)
  else
    Result := IsGenericOfSimpleName(RttiType, Name);
end;

{$IFDEF DELPHIXE2_LVL}
function TRttiUtils.IsGenericOfQualifiedName(Clazz: TClass;
  const Name: string): Boolean;
begin
  if Clazz = nil then Exit(False);
  Result := StartsStr(Name, Clazz.QualifiedClassName) or IsGenericOfQualifiedName(Clazz.ClassParent, Name);
end;
{$ENDIF}

function TRttiUtils.IsGenericOf(RttiType: TRttiType;
  TargetClass: TClass): Boolean;
begin
  {$IFDEF DELPHIXE2_LVL}
  Result := IsGenericOf(RttiType, GenericTypePrefix(TargetClass.QualifiedClassName));
  {$ELSE}
  Result := IsGenericOf(RttiType, GenericTypePrefix(TargetClass.ClassName));
  {$ENDIF}
end;

function TRttiUtils.IsGenericOfQualifiedName(RttiType: TRttiType;
  const Name: string): Boolean;
begin
  if RttiType = nil then Exit(False);
  Result := StartsStr(Name, RttiType.QualifiedName) or IsGenericOfQualifiedName(RttiType.BaseType, Name);
end;

function TRttiUtils.IsGenericOfSimpleName(Clazz: TClass;
  const Name: string): Boolean;
begin
  if Clazz = nil then Exit(False);
  Result := StartsStr(Name, Clazz.ClassName) or IsGenericOfSimpleName(Clazz.ClassParent, Name);
end;

function TRttiUtils.IsGenericOfSimpleName(RttiType: TRttiType;
  const Name: string): Boolean;
begin
  if RttiType = nil then Exit(False);
  Result := StartsStr(Name, RttiType.Name) or IsGenericOfSimpleName(RttiType.BaseType, Name);
end;

function TRttiUtils.IsNullable(ATypeInfo: PTypeInfo): boolean;
begin
  Result := IsNullable(FContext.GetType(ATypeInfo));
end;

function TRttiUtils.IsNullable(RttiType: TRttiType): Boolean;
begin
  Result := (RttiType is TRttiRecordType) and
    (Pos('Nullable', RttiType.QualifiedName) > 0);
end;

function TRttiUtils.IsProxy(RttiType: TRttiType): boolean;
begin
  Result := (RttiType is TRttiRecordType) and
    (Pos('Proxy', RttiType.Name) > 0);
end;

function TRttiUtils.IsString(const AValue: TValue): Boolean;
begin
  Result := AValue.Kind in [tkString, tkLString, tkWString, tkUString, tkChar, tkWChar];
end;

procedure TRttiUtils.PrivateCreate;
begin
  FContext := TRttiContext.Create;
end;

procedure TRttiUtils.PrivateDestroy;
begin
  FContext.Free;
end;

function TRttiUtils.ReachGenericClass(Clazz: TClass): TClass;
begin
  if Clazz = nil then Exit(nil);
  if Pos('<', Clazz.ClassName) > 0 then
    Result := Clazz
  else
    Result := Clazz.ClassParent;
end;

function TRttiUtils.ReplaceGenericParam(const ATypeName: string;
  AParamIndex: Integer; const AParamTypeName: string): string;
var
  Params: TArray<string>;
begin
  Result := ATypeName;
  Params := ExtractGenericParameters(ATypeName);
  if (AParamIndex >= 0) and (AParamIndex < Length(Params)) then
    Result := StringReplace(Result, Params[AParamIndex], AParamTypeName, []);
end;

procedure TRttiUtils.SetValue(Member: TRttiMember; Instance: Pointer;
  Value: TValue);
begin
  if Member is TRttiField then
    TRttiField(Member).SetValue(Instance, Value)
  else
  if Member is TRttiProperty then
    TRttiProperty(Member).SetValue(Instance, Value)
  else
    Assert(False);
end;

function TRttiUtils.TryGetAttribute<T>(ARttiObj: TRttiObject;
  out AAttribute: T): Boolean;
begin
  AAttribute := T(GetAttribute(ARttiObj, TCustomAttributeClass(T)));
  Result := AAttribute <> nil;
end;

function TRttiUtils.IsGenericOf(InspectedClass, TargetClass: TClass): Boolean;
begin
  {$IFDEF DELPHIXE2_LVL}
  Result := IsGenericOfQualifiedName(InspectedClass, GenericTypePrefix(TargetClass.QualifiedClassName))
  {$ELSE}
  Result := IsGenericOfSimpleName(InspectedClass, GenericTypePrefix(TargetClass.ClassName))
  {$ENDIF}
end;

function TRttiUtils.ExtractGenericParameters(Clazz: TClass): TArray<string>;
begin
  Clazz := ReachGenericClass(Clazz);
  if Clazz <> nil then
    Result := ExtractGenericParameters(Clazz.ClassName)
  else
    Result := nil;
end;

function TRttiUtils.ExtractGenericTypes(Clazz: TClass): TArray<TRttiType>;
begin
  Clazz := ReachGenericClass(Clazz);
  if Clazz <> nil then
    Result := ExtractGenericTypes(Clazz.ClassName)
  else
    Result := nil;
end;

end.
