delphi – 具有接口类型约束的泛型类型的RTTI

发布时间：2020-12-15 04:13:59 所属栏目：大数据来源：网络整理

导读：是否可以检查具有接口类型约束的泛型类型实例的RTTI信息？问题可能有点模糊,所以我创建了一个示例控制台应用程序来显示我正在尝试做的事情： program Project3;{$APPTYPE CONSOLE}uses RTTI,SysUtils,TypInfo;type TMyAttribute = class(TCustomAttribute) s

是否可以检查具有接口类型约束的泛型类型实例的RTTI信息？问题可能有点模糊,所以我创建了一个示例控制台应用程序来显示我正在尝试做的事情：

program Project3;

{$APPTYPE CONSOLE}

uses
  RTTI,SysUtils,TypInfo;

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

  IMyObjectBase = interface
  ['{E063AD44-B7F1-443C-B9FE-AEB7395B39DE}']
    procedure DoSomething;
  end;

  TMyObjectBase = class(TInterfacedObject,IMyObjectBase)
  public
    procedure DoSomething; virtual;
  end;

  [TMyAttribute('First')]
  TMyFirstRealClass = class(TMyObjectBase)
  public
    procedure DoSomethingDifferent;
  end;

  [TMyAttribute('Second')]
  TMySecondRealClass = class(TMyObjectBase)
  public
    procedure BeSomethingDifferent;
  end;

  TGenericClass<I: IMyObjectBase> = class
  public
    function GetAttributeName(AObject: I): string;
  end;


{ TMyAttribute }

constructor TMyAttribute.Create(AName: string);
begin
  FName := AName;
end;

{ TMyObjectBase }

procedure TMyObjectBase.DoSomething;
begin
end;

{ TMyFirstRealClass }

procedure TMyFirstRealClass.DoSomethingDifferent;
begin
end;

{ TMySecondRealClass }

procedure TMySecondRealClass.BeSomethingDifferent;
begin
end;

{ TGenericClass<I> }

function TGenericClass<I>.GetAttributeName(AObject: I): string;
var
  LContext: TRttiContext;
  LProp: TRttiProperty;
  LAttr: TCustomAttribute;
begin
  Result := '';
  LContext := TRttiContext.Create;
  try
    for LAttr in LContext.GetType(AObject).GetAttributes do
    // ----> [DCC Error] E2250 There is no overloaded version of 'GetType' that can be called with these arguments
      if LAttr is TMyAttribute then
      begin
        Result := TMyAttribute(LAttr).Name;
        Break;
      end;
  finally
    LContext.Free;
  end;
end;

var
  LFirstObject: IMyObjectBase;
  LSecondObject: IMyObjectBase;
  LGeneric: TGenericClass<IMyObjectBase>;
begin
  try
    LFirstObject := TMyFirstRealClass.Create;
    LSecondObject := TMySecondRealClass.Create;

    LGeneric := TGenericClass<IMyObjectBase>.Create;

    Writeln(LGeneric.GetAttributeName(LFirstObject));
    Writeln(LGeneric.GetAttributeName(LSecondObject));

    LGeneric.Free;

    LFirstObject := nil;
    LSecondObject := nil;

    Readln;

  except
    on E: Exception do
      Writeln(E.ClassName,': ',E.Message);
  end;
end.

我需要检查传入的对象(AObject),而不是通用接口(I).
(Dephi 2010).
谢谢你的建议.

解决方法

两种可能的解决方案如下：

1)我用这个测试它的工作原理(XE4)：

for LAttr in LContext.GetType((AObject as TObject).ClassType).GetAttributes do

2)我用这个测试它的工作原理(XE4)：

for LAttr in LContext.GetType(TMyObjectBase(AObject).ClassType).GetAttributes do

3)在返回对象的接口上创建方法并使用它来检查对象：

IMyObjectBase = interface
['{E063AD44-B7F1-443C-B9FE-AEB7395B39DE}']
  procedure DoSomething;
  function GetObject: TObject;
end;

TMyObjectBase = class(TInterfacedObject,IMyObjectBase)
public
  procedure DoSomething; virtual;
  function GetObject: TObject;
end;

{ TMyObjectBase }

function TMyObjectBase.GetObject: TObject;
begin
  Result := Self;
end;

然后像这样调用它：

for LAttr in LContext.GetType(AObject.GetObject.ClassType).GetAttributes do

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!