Delphi：在运行时查找来自给定基类的类？

Question

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

例如，假设有一个类：

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 查询此类信息吗？

备选方案： Delphi 有没有一种方法可以走每节课？然后我可以简单地调用：

RunClass: TClass;

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

另见

• Finding all classes that derive from a given base class in python
• Java: At runtime, find all classes in app that extend a base class

Answer 1

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

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;

Answer 2

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

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

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

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

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

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

1. 地址是否等于TObject的地址？如果是这样，这个地址就是一个 VMT，我们就完成了！
2. 读取 TClass(地址).ClassInfo;如果已分配：
   1. 它应该属于代码段（不，我不会对此进行详细介绍 - 只需 google 即可）
   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 和
8. 从它的 ClassParent 中读取 vmtInstanceSize，它也应该 >= TObject.InstanceSize 并且
9. （可选）您可以检查索引 0 及以上的所有 VMT 条目是否都是有效的代码指针（尽管确定 VMT 中的条目数有点问题......没有指示符）。
10. 使用 ClassParent 递归这些检查。 （这应该会达到上面的 TObject 测试，否则会惨败！）

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

祝你一切顺利，我花了大约一周的时间才把它做好。

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

Answer 3

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 中引入的