Расширенная RTTI информация классов

Как я упоминал ранее, Delphi (начиная с версии 7) поддерживает генерацию расширенной RTTI информации о методах класса - через компиляцию класса в режиме $METHODINFO ON. Эта RTTI информация включает в себя информацию о сигнатуре public и published методов. Delphi использует её для реализации поддержки скриптинга в фреймворке WebSnap - см. модуль ObjAuto и его друзей для более подробных сведений.

Я сумел написать свои собственные определения и подпрограммы, которые выдёргивают и сохраняют расширенную RTTI информацию классов в формат, удобный для внешнего использования. Как обычно, моё тестовое приложение будет дампить тестовый класс, воссоздавая его псевдо-объявление.

Пока я писал модуль HVMethodInfoClasses, я подправил и улучшил некоторый старый код и структуры, так что я могу использовать больше общего кода с HVIntefaceMethods и HVMethodSignature.

Мы уже привыкли раскапывать внутренние структуры RTTI, так что давайте лишь поверхностно пробежимся по новому коду. Итак, для начала у нас есть новые определения записей, описывающих приблизительную раскладку по памяти внутренних структур RTTI, генерируемых компилятором - выцарапанные из "официального" источника: ObjAuto:

type
  PReturnInfo = ^TReturnInfo;
  TReturnInfo = packed record
    Version: Byte; 
    CallingConvention: TCallConv;
    ReturnType: PPTypeInfo;
    ParamSize: Word;
  end;

  PParamInfo = ^TParamInfo;
  TParamInfo = packed record
    Flags: TParamFlags;
    ParamType: PPTypeInfo;
    Access: Word;
    Name: ShortString;
  end;

Как найти начала этих структур - это немного сложный вопрос. Помните статью Под капотом published методов? В то время я не знал про расширенную RTTI информацию и директиву $MethodInfo, поэтому написал:

Как вы можете видеть выше, таблица published методов теперь имеет тип PPmt. Это указатель на запись, которая содержит число published методов в классе, за которым следует массив из этого количества записей TPublishedMethod. Каждая запись содержит размер (используется для перехода к следующему элементу), указатель на точку входа метода и ShortString, содержащую имя метода.

Заметьте, что поле Size избыточно: во всех случаях значение Size равно:

Size :=  SizeOf(Size) + SizeOf(Address) + SizeOf(Name[0]) + Length(Name);

Другими словами, следующая запись TPublishedMethod начинается прямо за последним байтом текущей записи (т.е. последним байтом имени метода). Я не уверен, почему Borland решила добавить поле Size, но возможной причиной может быть расширение записи TPublishedMethod в будущем. Естественное расширение - добавить информацию по количеству и типам параметров, а также соглашению вызова метода. Тогда поле Size было бы увеличено, а старый код, который не в курсе новых возможностей, продолжал работать бы дальше.

Как оказалось сейчас, поле Size в самом деле используется для вставки дополнительных записей (TReturnInfo и TParamInfo) прямо за полем Name записи TPublishedMethod:

type
  PPublishedMethod = ^TPublishedMethod;
  TPublishedMethod = packed record
    Size: Word;  
    Address: Pointer;
    Name: {packed} ShortString;
  end;

Чтобы найти и декодировать сигнатуру метода, нам необходимо определить число дополнительных байт, указанных в поле Size. Мы скоро увидим код для этого.

Далее у нас есть структуры, которые могут хранить декодированную RTTI информацию одного класса, включая информацию по методам секций public/published со всеми их параметрами и возвращаемыми типами:

type
  // Просто-используемые структуры фиксированного размера
  PClassInfo = ^TClassInfo;
  TClassInfo = record
    UnitName: string; 
    Name: string;
    ClassType: TClass;
    ParentClass: TClass;
    MethodCount: Word;
    Methods: array of TMethodSignature;  
  end;

Это определение должно быть в большой степени само-документирующимся. Как вы можете видеть, мы использовали ту же запись TMethodSignature, которую мы использовали для интерфейсов. Ладно, теперь мы более-менее готовы к написанию кода для конвертирования информации типа класса в наши структуры выше. Это подразумевает испачкать наши руки итерацией по всем public/published методам и дополнительной RTTI информации. После нескольких неудачных попыток и подсматриваний в ObjAuto, я пришёл к такому коду:

function ClassOfTypeInfo(P: PPTypeInfo): TClass;
begin
  Result := nil;
  if Assigned(P) and (P^.Kind = tkClass) then
    Result := GetTypeData(P^).ClassType;
end;  
  
procedure GetClassInfo(ClassTypeInfo: PTypeInfo; var ClassInfo: TClassInfo);
// Конвертирует raw структуры RTTI в наши user-friendly структуры
var
  TypeData: PTypeData;
  i, j: integer;
  MethodInfo: PMethodSignature;
  PublishedMethod: PPublishedMethod;
  MethodParam: PMethodParam;
  ReturnRTTI: PReturnInfo;
  ParameterRTTI: PParamInfo;
  SignatureEnd: Pointer;
begin
  Assert(Assigned(ClassTypeInfo));
  Assert(ClassTypeInfo.Kind = tkClass);

  // Класс
  TypeData  := GetTypeData(ClassTypeInfo);
  ClassInfo.UnitName        := TypeData.UnitName;
  ClassInfo.ClassType       := TypeData.ClassType;
  ClassInfo.Name            := TypeData.ClassType.ClassName;
  ClassInfo.ParentClass     := ClassOfTypeInfo(TypeData.ParentInfo);  
  ClassInfo.MethodCount     := GetPublishedMethodCount(ClassInfo.ClassType);
  SetLength(ClassInfo.Methods, ClassInfo.MethodCount);

  // Методы
  PublishedMethod := GetFirstPublishedMethod(ClassInfo.ClassType);
  for i := Low(ClassInfo.Methods) to High(ClassInfo.Methods) do
  begin
    // Метод
    MethodInfo := @ClassInfo.Methods[i];
    MethodInfo.Name       := PublishedMethod.Name;
    MethodInfo.Address    := PublishedMethod.Address;
    MethodInfo.MethodKind := mkProcedure; // Предположим процедуру по умолчанию
    
    // Возвращаемое значение и соглашение вызова
    ReturnRTTI := Skip(@PublishedMethod.Name);
    SignatureEnd := Pointer(Cardinal(PublishedMethod) + PublishedMethod.Size);
    if Cardinal(ReturnRTTI) >= Cardinal(SignatureEnd) then
    begin
      MethodInfo.CallConv := ccReg; // Предположим register
      MethodInfo.HasSignatureRTTI := False;
    end
    else  
    begin
      MethodInfo.ResultTypeInfo := Dereference(ReturnRTTI.ReturnType);
      if Assigned(MethodInfo.ResultTypeInfo) then 
      begin
        MethodInfo.MethodKind := mkFunction;
        MethodInfo.ResultTypeName := MethodInfo.ResultTypeInfo.Name;
      end  
      else 
        MethodInfo.MethodKind := mkProcedure;
      MethodInfo.CallConv := ReturnRTTI.CallingConvention;
      MethodInfo.HasSignatureRTTI := True;

      // Считаем параметры
      ParameterRTTI := Pointer(Cardinal(ReturnRTTI) + SizeOf(ReturnRTTI^));
      MethodInfo.ParamCount := 0;
      while Cardinal(ParameterRTTI) < Cardinal(SignatureEnd) do
      begin
        Inc(MethodInfo.ParamCount); // Предполагаем, что будет менее 255 параметров! ;)
        ParameterRTTI := Skip(@ParameterRTTI.Name);
      end;  

      // Читаем информацию о параметрах
      ParameterRTTI := Pointer(Cardinal(ReturnRTTI) + SizeOf(ReturnRTTI^));
      SetLength(MethodInfo.Parameters, MethodInfo.ParamCount);
      for j := Low(MethodInfo.Parameters) to High(MethodInfo.Parameters) do
      begin
        MethodParam := @MethodInfo.Parameters[j];

        MethodParam.Flags       := ParameterRTTI.Flags;
        if pfResult in MethodParam.Flags then
          MethodParam.ParamName := 'Result'
        else
          MethodParam.ParamName := ParameterRTTI.Name;
        MethodParam.TypeInfo    := Dereference(ParameterRTTI.ParamType);
        if Assigned(MethodParam.TypeInfo) then
          MethodParam.TypeName  := MethodParam.TypeInfo.Name;
        MethodParam.Location    := TParamLocation(ParameterRTTI.Access);

        ParameterRTTI := Skip(@ParameterRTTI.Name);
      end;  
    end;
    PublishedMethod := GetNextPublishedMethod(ClassInfo.ClassType, PublishedMethod);
  end;  
end;

Как обычно, мы тестируем код, определяя какой-то глупый класс и используя RTTI для реконструирования его объявления. Вот упрощённый тестовый проект:

program TestHVMethodInfoClasses;
 
{$APPTYPE CONSOLE}
 
uses
  SysUtils,
  TypInfo,
  HVMethodSignature in 'HVMethodSignature.pas',
  HVMethodInfoClasses in 'HVMethodInfoClasses.pas';

procedure DumpClass(ClassTypeInfo: PTypeInfo);
var
  ClassInfo: TClassInfo;
  i: integer;
begin
  GetClassInfo(ClassTypeInfo, ClassInfo);
  WriteLn('unit ', ClassInfo.UnitName, ';');
  WriteLn('type');
  Write('  ', ClassInfo.Name, ' = '); 
    Write('class');
    if Assigned(ClassInfo.ParentClass) then
      Write(' (', ClassInfo.ParentClass.ClassName, ')');
    WriteLn;
  for i := Low(ClassInfo.Methods) to High(ClassInfo.Methods) do
    WriteLn('    ', MethodSignatureToString(ClassInfo.Methods[i]));
  WriteLn('  end;');
  WriteLn;
end;  

type
  {$METHODINFO OFF}
  TNormalClass = class
  end;
  TSetOfByte = set of byte;
  TEnum = (enOne, enTwo, enThree);

type
  {$METHODINFO ON}
  TMyClass = class
  public
    function Test1(const A: string): string; 
    function Test2(const A: string): byte;
    procedure Test3(R: integer);
    procedure Test4(R: TObject); 
    procedure Test5(R: TNormalClass); 
    procedure Test6(R: TSetOfByte); 
    procedure Test7(R: shortstring); 
    procedure Test8(R: openstring); 
    procedure Test9(R: TEnum); 
    function Test10: TNormalClass; 
    function Test11: integer; 
    function Test18: shortstring; 
    function Test19: TObject; 
    function Test20: IInterface; 
    function Test21: TSetOfByte; 
    function Test22: TEnum; 
  end;
 
// ... вырезаны реализации-пустышки методов класса TMyClass ...

procedure Test;
begin
  DumpClass(TypeInfo(TMyClass));
end;

begin
  try
    Test;
  except
    on E: Exception do
      WriteLn(E.Message);
  end;
  readln;
end.

И вывод тестового кода:

unit TestHVMethodInfoClasses;
type
  TMyClass = class (TObject)
    function Test1(A: String): String;
    function Test2(A: String): Byte;
    procedure Test3(R: Integer);
    procedure Test4(R: TObject);
    procedure Test5(R: TNormalClass);
    procedure Test6(R: TSetOfByte);
    procedure Test7(R: ShortString);
    procedure Test8(R: ShortString);
    procedure Test9(R: TEnum);
    function Test10(): TNormalClass;
    function Test11(): Integer;
    function Test18(): ShortString;
    function Test19(): TObject;
    function Test20(): IInterface;
    function Test21(): TSetOfByte;
    function Test22(): TEnum;
  end;

Полный исходный код доступен на CodeCentral.

Как отметил мой прилежный читатель, Ralf, вывод этой программы является дословной копией исходного кода. Помимо моей небрежности по не опусканию пустых скобок в функциях: строковые параметры пока не объявлены как const. Это потому, что RTTI для этих параметров не включает pfConst (duh!). Я думаю, что причина в том, что RTTI методов и параметров оптимизирована для получения возможности динамического вызова методов в run-time, а модификатор const на это не влияет (на вызывающего) - он влияет только на код метода, создаваемый компилятором (запрет изменения и опускание создания локальной копии).

Фактически я пытался (до сих пор - не успешно) уговорить Borland DevCo CodeGear Embarcadero упростить компилятор и разрешить ставить const в секции implementation и не ставить - в interface. Это может звучать, как запрос ленивого программиста, но на деле это позволило бы менять "константность" параметра, не затрагивая (не изменяя) интерфейс - что является более чем логичным поведением. Ох, ну и ладно, в любом случае, это история для другого раза.