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: во время выполнения найдите в приложении все классы, расширяющие базовый класс

Answer 1

Ну, да, есть способ, но он тебе не понравится. (По-видимому, мне нужен такой отказ от ответственности, чтобы не допустить, чтобы мой в противном случае совершенно полезный комментарий был отвергнут ой-таким знающим, но не таким прощающим «старшим» SO-членом.)

К вашему сведению: Следующее описание представляет собой общий обзор фрагмента кода, который я действительно написал, когда Delphi 5 был последним и лучшим. С тех пор этот код был перенесен на более новые версии Delphi (в настоящее время до Delphi 2010) и все еще работает!

Для начала вам нужно знать, что класс - это не что иное, как комбинация VMT и сопутствующих функций (и, возможно, некоторой информации типа, в зависимости от версии компилятора и -settings). Как вы, вероятно, знаете, класс, идентифицируемый типом TClass, - это просто указатель на адрес памяти VMT этого класса. Другими словами: если вы знаете адрес VMT класса, это также указатель TClass.

Имея эти знания, которые прочно удерживаются в памяти, вы можете сканировать свою исполняемую память и для каждого теста адреса, если он «выглядит» как VMT. Все адреса, которые кажутся VMT, могут быть добавлены в список, что дает полный обзор всех классов, содержащихся в вашем исполняемом файле! (На самом деле, это даже дает вам доступ к классам, объявленным исключительно в разделе реализации модуля, и классам, связанным из компонентов и библиотек, которые распространяются как двоичные файлы!)

Конечно, есть риск, что некоторые адреса кажутся действительными VMT, но на самом деле это какие-то случайные другие данные (или код) - но с тестами, которые я придумал, со мной такого еще никогда не случалось (в около 6 лет работает с этим кодом в более чем десяти активно поддерживаемых приложениях).

Итак, вот проверки, которые вы должны сделать (в этом точном порядке!):

1. Адрес равен адресу TObject? Если это так, этот адрес является VMT, и мы закончили!
2. Чтение TClass (адрес) .ClassInfo; Если это назначено:
   1. он должен попадать в сегмент кода (нет, я не буду вдаваться в подробности - просто погуглите его)
   2. последний байт этого ClassInfo (определяется путем добавления SizeOf (TTypeInfo) + SizeOf (TTypeData)) также должен попадать в этот сегмент кода
   3. для этого ClassInfo (типа PTypeInfo) в поле Kind должно быть установлено значение tkClass
   4. Вызовите GetTypeData для этого ClassInfo, что приведет к PTypeData
      1. Это также должно попадать в допустимый сегмент кода
      2. Последний байт (определяется путем добавления SizeOf (TTypeData)) также должен попадать в этот сегмент кода
      3. Из этого TypeData его поле ClassType должно быть равно адресу проверяемого.
   1036 **
3. Теперь прочитайте существующий VMT со смещением vmtSelfPtr и проверьте, приводит ли это к проверяемому адресу (должен указывать на себя)
4. Прочитайте vmtClassName и проверьте, указывает ли это на допустимое имя класса (проверьте, чтобы указатель снова находился в допустимом сегменте, чтобы длина строки была приемлемой, а IsValidIdent должен вернуть True)
5. Чтение vmtParent - оно также должно попадать в допустимый сегмент кода
6. Теперь приведите к TClass и прочитайте ClassParent - он также должен попадать в допустимый сегмент кода
7. Прочитайте vmtInstanceSize, это должно быть> = TObject.InstanceSize и <= MAX_INSTANCE_SIZE (ваш, чтобы определить) </li>
8. Считайте vmtInstanceSize из его ClassParent, оно также должно быть> = TObject.InstanceSize и <= ранее прочитанный размер экземпляра (родительские классы никогда не могут быть больше дочерних классов) </li>
9. При желании вы можете проверить, являются ли все записи VMT от индекса 0 и выше действительными указателями кода (хотя определить количество записей в VMT немного проблематично ... для этого нет индикатора).
10. Заполните эти проверки с ClassParent. (Это должно пройти тест TObject выше или потерпеть неудачу!)

Если все эти проверки выполняются, тест-адрес является действительным VMT (насколько мне известно) и может быть добавлен в список.

Удачи в реализации всего этого, мне потребовалось около недели, чтобы понять это правильно.

Пожалуйста, расскажите, как это работает для вас. Ура!

Answer 2

Это можно сделать с помощью RTTI, но не в Delphi 5. Чтобы найти все классы, которые соответствуют определенным критериям, сначала нужно иметь возможность найти все классы и необходимые API-интерфейсы RTTIчтобы сделать это, были представлены в 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 3

Ян, как говорит Мейсон, функция 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