Delphi从接口查询自定义属性

Question

我声明了以下自定义属性

unit SpecialAttribute;

interface

type
  TSpecialAttribute = class(TCustomAttribute)
  procedure SetValue(aValue: String);
  public
    FValue: String;
    property Value: String read FValue write SetValue;
    constructor Create(const AValue: String);
  end;

implementation

{ TSpecialAttribute }

constructor TSpecialAttribute.Create(const AValue: String);
begin
  FValue := aValue;
end;

procedure TSpecialAttribute.SetValue(aValue: String);
begin
  FValue := aValue;
end;

end.

并用于装饰以下界面：

unit ITestInterface;

interface

uses
  SpecialAttribute;

type
  ITestIntf = interface(IInvokable)
    [TSpecialAttribute('IntfAttribute')]
    procedure Test;
  end;

implementation

end.

我正在尝试使用RTTI从接口中获取属性：

unit Unit17;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
    SpecialAttribute,ITestInterface;

  type
    TTestClass = class(TInterfacedObject, ITestIntf)
    [TSpecialAttribute('TestClass')]
       procedure Test;
    end;

  TForm17 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form17: TForm17;

implementation

uses
  Rtti;

{$R *.dfm}

procedure TForm17.FormCreate(Sender: TObject);
var
  LContext: TRttiContext;
  LType: TRttiType;
  LAttr: TCustomAttribute;
begin    
  try
  LContext := TRttiContext.Create;

  LType := LContext.GetType(TypeInfo(ITestIntf)); 

  for LAttr in LType.GetAttributes() do
    if LAttr is TSpecialAttribute then
      Memo1.Lines.Add(TSpecialAttribute(LAttr).FValue)
    else
     Memo1.Lines.Add(LAttr.ClassName);
  finally
    LContext.Free;
  end;
end;


end.

在自定义属性构造函数上设置断点时，代码永远不会停止。如何从接口中获取属性？

Answer 1

根据雷米·莱博的评论，我设法解决了这个问题。具有下列接口声明：

unit ITestInterface;

interface

uses
  SpecialAttribute;

type
 [TSpecialAttribute('IntfAttribute - class')]
  ITestIntf = interface(IInvokable)
  [TSpecialAttribute('IntfAttribute - method')]
    procedure Test([TSpecialAttribute('IntfAttribute - params')]i: Integer);
  end;

implementation

end.

1)获取修饰方法的属性：

var
  LContext: TRttiContext;
  LType: TRttiType;
  LAttr: TCustomAttribute;
  lMethod: TRttiMethod;
begin
  try
    LContext := TRttiContext.Create;

    LType := LContext.GetType(TypeInfo(ITestIntf));

    for lMethod in LType.GetMethods do
    begin
      for LAttr in lMethod.GetAttributes do
      if LAttr.ClassType = TSpecialAttribute then
      begin
        Memo1.Lines.Add(LAttr.ClassName + ' value ' + TSpecialAttribute(LAttr).Value);
      end
      else
        Memo1.Lines.Add(LAttr.ClassName);
    end;
  finally
    LContext.Free;
  end;

返回- TSpecialAttribute值IntfAttribute -方法

2)获取修饰参数的属性：

var
  LContext: TRttiContext;
  LType: TRttiType;
  lMethod: TRttiMethod;
  lParam: TRttiParameter;
  lAttr: TCustomAttribute;
begin
  try
  LContext := TRttiContext.Create;

  LType := LContext.GetType(TypeInfo(ITestIntf));
   for lMethod in LType.GetMethods do
   begin
     for lParam in lMethod.GetParameters do
      for lAttr in lParam.GetAttributes do
      begin
        Memo1.Lines.Add('Attribute ' + lAttr.ClassName + ' found on parameter '+ lParam.Name);
        if lAttr.ClassType = TSpecialAttribute then
          Memo1.Lines.Add( '  value ' + TSpecialAttribute(lAttr).Value);
      end;
   end;
  finally
    LContext.Free;
  end;
end;

返回在参数i值TSpecialAttribute - params上找到的属性IntfAttribute

3)获取修饰类的属性

 var
  LContext: TRttiContext;
  LType: TRttiType;
  LAttr: TCustomAttribute;
begin
  try
  LContext := TRttiContext.Create;

  LType := LContext.GetType(TypeInfo(ITestIntf));

  for LAttr in LType.GetAttributes() do
    if LAttr is TSpecialAttribute then
      Memo1.Lines.Add(TSpecialAttribute(LAttr).FValue)
    else
     Memo1.Lines.Add(LAttr.ClassName);
  finally
    LContext.Free;
  end;
end;

返回IntfAttribute类