问题
Is there at way, at runtime, to find all classes that descend from a particular base class?
For example, pretend there is a class:
TLocalization = class(TObject)
...
public
function GetLanguageName: string;
end;
or pretend there is a class:
TTestCase = class(TObject)
...
public
procedure Run; virtual;
end;
or pretend there is a class:
TPlugIn = class(TObject)
...
public
procedure Execute; virtual;
end;
or pretend there is a class:
TTheClassImInterestedIn = class(TObject)
...
public
procedure Something;
end;
At runtime i want to find all classes that descend from TTestCase so that i may do stuff with them.
Can the RTTI be queried for such information?
Alternatively: Is there a way in Delphi to walk every class? i can then simply call:
RunClass: TClass;
if (RunClass is TTestCase) then
begin
TTestCase(RunClass).Something;
end;
See also
- 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
回答1:
Well, yes, there is a way, but you're not going to like it. (Appearantly, I need a disclaimer like this, to prevent my otherwise perfectly helpfull comment getting downvoted by the oh-so knowledgable, but not so forgiving 'senior' SO members.)
FYI : The following description is a high-level overview of a piece of code I actually wrote when Delphi 5 was the latest & greatest. Since then, that code was ported over to newer Delphi versions (currently up until Delphi 2010) and still works!
For starters, you need to know that a class is nothing more than a combination of a VMT and the accompanying functions (and maybe some type-info, depending on compiler-version and -settings). As you probably know, a class - as identified by the type TClass - is just a pointer to the memory address of that classes' VMT. In other words : If you known the address of the VMT of a class, that's the TClass pointer as well.
With that piece of knowledge stuck firmly in your mind, you can actually scan your executable memory, and for each address test if it 'looks like' a VMT. All addresses that seem to be a VMT can than be added to a list, resulting in a complete overview of all classes contained in your executable! (Actually, this even gives you access to classes declared solely in the implementation-section of a unit, and classes linked-in from components & libraries that are distributed as binaries!)
Sure, there's a risk that some addresses seem to be a valid VMT, but are actually some random other data (or code) - but with the tests I've come up with, this has never happened to me yet (in about 6 years running this code in more than ten actively maintained applications).
So here's the checks you should do (in this exact order!) :
- Is the address equal to the address of TObject? If so, this address is a VMT and we're done!
- Read TClass(address).ClassInfo; If it's assigned :
- it should fall inside a code-segment (no, I won't go into details on that - just google it up)
- the last byte of this ClassInfo (determined by adding SizeOf(TTypeInfo) + SizeOf(TTypeData)) should also fall inside that code-segment
- this ClassInfo (which is of type PTypeInfo) should have it's Kind field set to tkClass
- Call GetTypeData on this ClassInfo, resulting in a PTypeData
- This should also fall inside a valid code segment
- It's last byte (determined by adding SizeOf(TTypeData)) should also fall inside that code-segment
- Of this TypeData it's ClassType field should be equal to the address being tested.
- Now read the VMT-to-be at the offset vmtSelfPtr and test if this results in the address being tested (should point to itself)
- Read vmtClassName and check if that points to a valid classname (check pointer to reside in a valid segment again, that the string length is acceptable, and IsValidIdent should return True)
- Read vmtParent - it should also fall in a valid code segment
- Now cast to a TClass and read ClassParent - it should also fall in a valid code segment
- Read vmtInstanceSize, it should be >= TObject.InstanceSize and <= MAX_INSTANCE_SIZE (yours to determine)
- Read vmtInstanceSize from it's ClassParent, it should also be >= TObject.InstanceSize and <= the previously read instance size (parent classes can never be larger than child classes)
- Optionally, you could check if all VMT entries from index 0 and upwards are valid code pointers (although it's a bit problematic to determine the number of entries in a VMT... there's no indicator for this).
- Recurse these checks with the ClassParent. (This should reach the TObject test above, or fail miserably!)
If all these checks hold, the test-address is a valid VMT (as far as I'm concerned) and can be added to the list.
Good luck implementing this all, it took me about a week to get this right.
Please tell how it works out for you. Cheers!
回答2:
It can be done with RTTI, but not in Delphi 5. In order to find all classes that match a certain criteria, you first need to be able to find all classes, and the RTTI APIs necessary to do that were introduced in Delphi 2010. You'd do it something like this:
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;
回答3:
Ian, as Mason says the TRttiContext.GetTypes function get the list of all RTTI objects that provide type information . but this function was introduced in Delphi 2010.
As workaround you can inherit your base class from the TPersistent class and then register manually every class using the RegisterClass function (i know wich this is annoying).
then using the TClassFinder object you can retrieve all the registered classes.
see this sample
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.
UPDATE
I'm sorry, but apparently the TClassFinder class was introduced in Delphi 6
来源：https://stackoverflow.com/questions/3796353/delphi-at-runtime-find-classes-that-descend-from-a-given-base-class