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;

参考资料

• 在Python中找到所有继承自给定基类的类
• Java：在运行时查找应用程序中所有扩展基类的类

- Ian Boyd

---

问题可能是如何枚举应用程序拥有的所有对象。 - rajeemcariazo

@rajeem_cariazo 我可以用多种方式表达这个问题。希望其中一种表述方式能给我一个解决方案。 - Ian Boyd

如果您提供的示例与您想要使用它的原因有关，即您主要对所有DUnit测试用例类感兴趣，那么您当然可以简单地“遍历”DUnit本身构建的RegisteredTests注册表以运行所有测试。我现在看到您的TTestCase是从TObject继承而来的 - 并且可能与DUnit没有关系，所以请忘记我的评论。如果SO允许我，我会将其删除... - Marjan Venema

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;

- Mason Wheeler

Answer 2

是的，有一种方法，但你可能不会喜欢它。（显然，我需要这样的免责声明，以避免被那些自以为知道一切但又不太宽容的“资深”SO会员贬低。）

顺便说一下：以下描述是我在Delphi 5时编写的代码的高级概述。从那时起，该代码已移植到更新的Delphi版本（目前到Delphi 2010），仍然有效！

首先，您需要知道类只是一个VMT和相应函数（根据编译器版本和设置可能还包括某些类型信息）的组合。正如您可能知道的，类 - 如TClass所表示的 - 只是指向该类VMT内存地址的指针。换句话说：如果您知道类的VMT地址，那么就是TClass指针。

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

当然，有风险某些地址似乎是有效的VMT，但实际上是一些随机的其他数据（或代码）- 但是通过我提出的测试，这在我使用这个代码超过十个活跃维护的应用程序六年中从未发生过。

因此，以下是您应该执行的检查（按照确切的顺序！）：

1. 地址是否等于TObject的地址？如果是，则此地址是VMT，我们完成了！
2. 读取TClass（address）。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的内容，并测试是否会导致正在测试的地址（应该指向自身）
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（就我而言），并且可以将其添加到列表中。

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

请告诉我它对您有何作用。干杯！

- PatrickvL

---

有趣的方法，但是这不是在安全的情况下通过创建自己的类注册表来实现同样的目标吗？为什么要采用如此复杂且具有风险的解决方案呢？ - David

@David：不，它们远远不同。使用自己的注册表时，您始终只能限制于主动注册的类。而使用Patrick的方法，您可以检测您的exe中存在的所有类……无需RTTI或注册表。在D2010+中，没有RTTI是一个优势，因为它有助于避免exe的代码膨胀。 - Marjan Venema

你说得对：我不会喜欢它 :) 但是作为（唯一的）答案被接受。+1 因为聪明 +1 因为解释详尽。 - Ian Boyd

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

- RRUZ

---

但是您的想法仍然是有效的。他不必使用Delphi提供的注册表向注册类，而只需要自己创建一个带有适当方法的注册表即可。这并不难...而且它还有一个优点，就是他不必要求所有“可发现”的类都继承自TPersistent。TObject就足够了。 - Marjan Venema

@Marjan Venema 我本来可以这样做的，但我问这个问题是为了避免需要一个初始化部分。 - Ian Boyd

@Ian: 如果你使用单独的“注册”单元，就不需要初始化部分。它必须引用定义注册表的单元以及包含要注册的类的每个单元。优点：没有初始化部分，所有已注册的类都在一个地方，并且更容易发现不再使用的单元。缺点：每次添加需要注册的类时，该单元都需要更改。 - Marjan Venema