8

在运行时是否有办法找到从特定基类派生的所有类？

例如，假设有一个类：

TLocalization = class(TObject)
...
public
   function GetLanguageName: string;
end;

或假装有一堂课：

TTestCase = class(TObject)
...
public
   procedure Run; virtual;
end;

或假装有一堂课：

TPlugIn = class(TObject)
...
public
   procedure Execute; virtual;
end;

或假装有一堂课：

TTheClassImInterestedIn = class(TObject)
...
public
   procedure Something;
end;

在运行时，我想找到所有派生的类，TTestCase以便我可以对它们进行处理。

可以向 RTTI 查询此类信息吗？

或者：德尔福有没有办法走每节课？然后我可以简单地调用：

RunClass: TClass;

if (RunClass is TTestCase) then
begin
   TTestCase(RunClass).Something;
end;

也可以看看

4

3 回答 3

10

它可以用 RTTI 完成，但不能在 Delphi 5 中完成。为了找到所有符合特定条件的类，您首先需要能够找到所有类，并且在 Delphi 2010 中引入了所需的 RTTI API。你会这样做：

function FindAllDescendantsOf(basetype: TClass): TList<TClass>;
var
  ctx: TRttiContext;
  lType: TRttiType;
begin
  result := TList<TClass>.Create;
  ctx := TRttiContext.Create;
  for lType in ctx.GetTypes do
    if (lType is TRttiInstanceType) and
       (TRttiInstanceType(lType).MetaclassType.InheritsFrom(basetype)) then
      result.add(TRttiInstanceType(lType).MetaclassType);
end;
于 2010-09-26T03:19:30.787 回答
9

嗯，是的，有一种方法，但你不会喜欢它。（显然，我需要这样的免责声明，以防止我原本非常有用的评论被知识渊博但不那么宽容的“高级” SO 成员否决。）

仅供参考：以下描述是对我在 Delphi 5 最新和最好时实际编写的一段代码的高级概述。从那时起，该代码被移植到较新的 Delphi 版本（目前直到 Delphi 2010）并且仍然有效！

对于初学者，您需要知道一个类只不过是 VMT 和随附函数的组合（可能还有一些类型信息，取决于编译器版本和设置）。您可能知道，一个类（由 TClass 类型标识）只是一个指向该类的 VMT 内存地址的指针。换句话说：如果你知道一个类的 VMT 的地址，那也是 TClass 指针。

牢牢记住这些知识，您实际上可以扫描您的可执行内存，并针对每个地址测试它是否“看起来像”VMT。所有看起来是 VMT 的地址都可以添加到列表中，从而完整地概述包含在您的可执行文件中的所有类！（实际上，这甚至使您可以访问仅在单元的实现部分中声明的类，以及从作为二进制文件分发的组件和库中链接的类！）

当然，有些地址似乎是有效的 VMT，但实际上是一些随机的其他数据（或代码）是有风险的——但是根据我提出的测试，这还没有发生在我身上（大约 6 年）在十多个积极维护的应用程序中运行此代码）。

所以这是你应该做的检查（按照这个确切的顺序！）：

  1. 地址是否等于 TObject 的地址？如果是这样，这个地址就是一个 VMT，我们就完成了！
  2. 读取 TClass(address).ClassInfo; 如果已分配：
    1. 它应该属于代码段（不，我不会对此进行详细介绍 - 只需用谷歌搜索）
    2. 这个 ClassInfo 的最后一个字节（通过添加 SizeOf(TTypeInfo) + SizeOf(TTypeData) 来确定）也应该落在那个代码段内
    3. 这个 ClassInfo（它是 PTypeInfo 类型）应该将它的 Kind 字段设置为 tkClass
    4. 在这个 ClassInfo 上调用 GetTypeData，产生一个 PTypeData
      1. 这也应该属于有效的代码段
      2. 它的最后一个字节（通过添加 SizeOf(TTypeData) 确定）也应该落在该代码段内
      3. 在这个 TypeData 中，它的 ClassType 字段应该等于被测试的地址。
  3. 现在读取偏移量 vmtSelfPtr 处的 VMT-to-be 并测试这是否导致正在测试的地址（应该指向自身）
  4. 读取 vmtClassName 并检查它是否指向有效的类名（再次检查指针以驻留在有效段中，字符串长度是否可接受，并且 IsValidIdent 应返回 True）
  5. 读取 vmtParent - 它也应该属于有效的代码段
  6. 现在转换为 TClass 并读取 ClassParent - 它也应该属于有效的代码段
  7. 读取 vmtInstanceSize，它应该是 >= TObject.InstanceSize 和 <= MAX_INSTANCE_SIZE （你自己确定）
  8. 从它的 ClassParent 中读取 vmtInstanceSize，它也应该 >= TObject.InstanceSize 并且 <= 之前读取的实例大小（父类永远不能大于子类）
  9. 或者，您可以检查索引 0 及以上的所有 VMT 条目是否都是有效的代码指针（尽管确定 VMT 中的条目数有点问题......没有指示符）。
  10. 使用 ClassParent 递归这些检查。（这应该达到上面的 TObject 测试，否则惨败！）

如果所有这些检查都成立，则测试地址是有效的 VMT（就我而言）并且可以添加到列表中。

祝你好运实现这一切，我花了大约一周的时间才把它做好。

请告诉你它是如何工作的。干杯!

于 2010-09-26T19:35:01.990 回答
2

Ian，正如 Mason 所说，该TRttiContext.GetTypes函数获取提供类型信息的所有 RTTI 对象的列表。但是这个功能是在 Delphi 2010 中引入的。

作为解决方法，您可以从该类继承您的基类TPersistent，然后使用该RegisterClass函数手动注册每个类（我知道这很烦人）。

然后使用该TClassFinder对象，您可以检索所有已注册的类。

看到这个样本

type
  TForm12 = class(TForm)
    Memo1: TMemo; // a TMemo to show the classes in this example
    ButtonInhertisFrom: TButton;
    procedure FormCreate(Sender: TObject);
    procedure ButtonInhertisFromClick(Sender: TObject);
  private
    { Private declarations }
    RegisteredClasses : TStrings; //The list of classes
    procedure GetClasses(AClass: TPersistentClass); //a call procedure used by TClassFinder.GetClasses
  public
    { Public declarations }
  end;

  TTestCase = class (TPersistent) //Here is your base class 
  end;

  TTestCaseChild1 = class (TTestCase) //a child class , can be in any place in your application
  end;

  TTestCaseChild2 = class (TTestCase)//another child class
  end;

  TTestCaseChild3 = class (TTestCase)// and another child class
  end;

var
  Form12: TForm12;

implementation

{$R *.dfm}

//Function to determine if a class Inherits directly from another given class
function InheritsFromExt(Instance: TPersistentClass;AClassName: string): Boolean; 
var
  DummyClass : TClass;
begin
  Result := False;
  if Assigned(Instance) then
  begin
    DummyClass := Instance.ClassParent;
    while DummyClass <> nil do
    begin
      if SameText(DummyClass.ClassName,AClassName) then
      begin
        Result := True;
        Break;
      end;
      DummyClass := DummyClass.ClassParent;
    end;
  end;
end;

procedure TForm12.ButtonInhertisFromClick(Sender: TObject);
var
Finder       : TClassFinder;
i            : Integer;
begin
  Finder     := TClassFinder.Create();
  try
   RegisteredClasses.Clear; //Clear the list
   Finder.GetClasses(GetClasses);//Get all registered classes
   for i := 0 to RegisteredClasses.Count-1 do
     //check if inherits directly from TTestCase
     if InheritsFromExt(TPersistentClass(RegisteredClasses.Objects[i]),'TTestCase') then
     //or you can use , if (TPersistentClass(RegisteredClasses.Objects[i]).ClassName<>'TTestCase') and  (TPersistentClass(RegisteredClasses.Objects[i]).InheritsFrom(TTestCase)) then //to check if a  class derive from TTestCase not only directly
     Memo1.Lines.Add(RegisteredClasses[i]); //add the classes to the Memo 
  finally
  Finder.Free;
  end;
end;

procedure TForm12.FormCreate(Sender: TObject);
begin
  RegisteredClasses := TStringList.Create;
end;

procedure TForm12.GetClasses(AClass: TPersistentClass);//The cllaback function to fill the list of classes
begin
  RegisteredClasses.AddObject(AClass.ClassName,TObject(AClass));
end;


initialization
//Now the important part, register the classes, you can do this in any place in your app , i choose this location just for the example
  RegisterClass(TTestCase);
  RegisterClass(TTestCaseChild1);
  RegisterClass(TTestCaseChild2);
  RegisterClass(TTestCaseChild3);
end.

更新

我很抱歉，但显然这个TClassFinder类是在 Delphi 6 中引入的

于 2010-09-26T04:08:54.240 回答