Расширенная RTTI информация интерфейсов

Это перевод Extended Interface RTTI. Автор: Hallvard Vassbotn.

Чтобы поддерживать базовые механизмы SOAP архитектуры, Delphi добавила поддержку расширенной RTTI информации для интерфейсов начиная с версии 7. Как мы видели в предыдущей статье, все интерфейсы поддерживают базовую информацию RTTI: имя интерфейса, его GUID, имя модуля с объявлением, родительский интерфейс и число методов.

Чтобы добавить к интерфейсу расширенную RTTI информацию, его нужно собрать в режиме {$M+}/{$TYPINFO ON} или {$METHODINFO ON}. Альтернативно, вы можете просто унаследовать свой интерфейс от IInvokable (определённого в модуле System с $M+). Это расширит генерируемую RTTI для интерфейса информацией по сигнатуре каждого метода.

Код поддержки как клиентской, так и серверной стороны SOAP в Delphi используют эту расширенную RTTI информацию. Некоторые из самых базовых подпрограмм можно найти в модуле IntfInfo (исходный код которого доступен в Delphi 2005 и выше, но отсутствует в предыдущих версиях Delphi) - к примеру, посмотрите на подпрограммы FillMethodArray и GetIntfMetaData.

Есть также код генерации WSDL (Web Service Description Language - язык описания web-сервисов) по списку зарегистрированных интерфейсов в web сервисе (см. WSDLPub.pas), а также код динамической генерации интерфейсов (таблицы методов интерфейса - interface method table, IVT) по WSDL описанию интерфейса с методами-заглушками, которые вызывают TRIO.Generic. Эти методы-заглушки ответственны за упаковку параметров вызова на клиентской стороне в XML-форматированное SOAP сообщение, отправку его для выполнения серверу, ожидание ответа, декодирования возвращённого SOAP ответа (снова XML) и обновление out и var параметров, включая Result (в методе TOPToSoapDomConvert.ProcessSuccess из OPToSOAPDomConv). Весьма "неслабый" код! Заметьте, что TRIO не поддерживает соглашение вызова register – рекомендуется использовать stdcall.

Это была некоторая вводная информация о том, как используется расширенная RTTI информация для интерфейсов и где можно найти код, работающий с ней. Хотя в модуле IntfInfo есть низкоуровневые подпрограммы доступа (экспортируемые, если определена директива условной компиляции DEVELOPERS), мы бы хотели запачкать свои руки и реализовать их самостоятельно.

Как обычно, RTTI структуры для методов интерфейсов содержат множество упакованных ShortString – что означает невозможность написать прямые объявления подобных структур данных на Pascal. Копаясь в расширенной RTTI интерфейсов Borland-а, пошагово проходясь по коду SOAP в отладчике, дампя raw данные RTTI и логически выводя (динамические) размеры полей, мне удалось воссоздать исходные структуры и написать псевдо-Pascal объявления для проецирования на RTTI структуры. К примеру, вот ASCII-дамп, который я сделал вручную при исследовании одного интерфейса:

{ MethodCount:1; HasMethodRTTI:1; 
Test:(
Name: #3, 'F', 'o', 'o', 
Kind: #0, 
CallConv: #0, 
ParamCount: #3, 
Flags: #8, 
ParamName: #4, 'S', 'e', 'l', 'f', 
TypeName: #14, 'I', 'M', 'y', 'M', 'P', 'I', 'n', 't', 'e', 'r', 'f', 'a', 'c', 'e', 
TypeInfo: #24, 'T', 'O', #0, 
Flags: #0, 
Name: #1, 'A', 
TypeName: #7, 'I', 'n', 't', 'e', 'g', 'e', 'r', }

На внешнем уровне мы начинаем с записи, которая следует за полем IntfUnit блока tkInterface в вариантной части записи TTypeData из модуля TypInfo:

  PExtraInterfaceData = ^TExtraInterfaceData;
  TExtraInterfaceData = packed record
    MethodCount: Word;   // число методов
    HasMethodRTTI: Word; // $FFFF, если нет RTTI для методов, 
                         // и снова число методов, если есть RTTI 
    Methods: packed array[0..High(Word) - 1] of TInterfaceMethodRTTI;
  end;

Для всех интерфейсов поле MethodCount содержит число методов интерфейса. Для "обычных" интерфейсов (компилируемых с $METHODINFO OFF) поле HasMethodRTTI будет равно $FFFF - указывая, что для интерфейса нет дополнительной RTTI. Расширенная RTTI интерфейсов (для интерфейсов, собранных с $METHODINFO ON) поле HasMethodRTTI будет равно полю MethodCount, а за ним будет упакованный массив информации о каждом методе:

  PInterfaceMethodRTTI = ^TInterfaceMethodRTTI;
  TInterfaceMethodRTTI = packed record
    Name: TPackedShortString; 
    Kind: TMethodKind; // mkProcedure или mkFunction
    CallConv: TCallConv;
    ParamCount: Byte;  // включая Self
    Parameters: packed array[0..High(Byte) - 1] of TInterfaceParameterRTTI;
    case TMethodKind of
      mkFunction: 
        (Result: TInterfaceResultRTTI);
  end;

RTTI одного метода интерфейса содержит имя метода, вид метода (procedure или function), соглашение вызова, число параметров (включая неявный параметр Self) и упакованный массив информации о каждом параметре. Если метод является функцией, то после массива есть ещё одно дополнительное поле о результате функции.

  PInterfaceParameterRTTI = ^TInterfaceParameterRTTI;
  TInterfaceParameterRTTI = packed record
    Flags: TParamFlags;
    ParamName: TPackedShortString; 
    TypeName: TPackedShortString; 
    TypeInfo: PPTypeInfo;
  end;

Объявление записи для параметров содержит флаги (указывая на вид параметра - var, const, out или обычный, параметр-массив или ссылка), имя параметра, имя типа параметра и указатель на RTTI информацию о типе (если тип имеет RTTI).

Наконец, у нас есть запись для результата функции:

  PInterfaceResultRTTI = ^TInterfaceResultRTTI;
  TInterfaceResultRTTI = packed record
    Name: TPackedShortString;
    TypeInfo: PPTypeInfo;
  end;

И снова у нас есть имя типа и указатель на его RTTI.

Запись TExtraInterfaceData выше показывает приблизительную раскладку генерируемой компилятором RTTI информации в памяти. Для внешнего кода нам бы хотелось трансформировать это во что-то более удобное для использования. Заметьте, что это будет очень похоже на то, что мы делали с published методами. И методы интерфейсов и published методы имеют сигнатуры с информацией о параметрах и возвращаемом типе. Так что я решил переделать связанные с сигнатурами определения из модуля HVPublishedMethodParams в отдельный модуль HVMethodSignature:

unit HVMethodSignature;

interface

uses 
  Classes, SysUtils, TypInfo, HVVMT;

type  
  TCallConv = (ccReg, ccCdecl, ccPascal, ccStdCall, ccSafeCall);

  PMethodParam = ^TMethodParam;
  TMethodParam = record
    Flags: TParamFlags;
    ParamName: PShortString;
    TypeName: PShortString;
    TypeInfo: PTypeInfo;
  end;
  TMethodParamList = array of TMethodParam;

  PMethodSignature = ^TMethodSignature;
  TMethodSignature = record
    Name: PShortString;
    MethodKind: TMethodKind;
    CallConv: TCallConv;
    ParamCount: Byte;
    Parameters: TMethodParamList;
    ResultTypeName: PShortString;
    ResultTypeInfo: PTypeInfo;
  end;  
  
function MethodKindString(MethodKind: TMethodKind): String;

function MethodParamString(const MethodParam: TMethodParam; ExcoticFlags: Boolean = False): String;

function MethodParametesString(const MethodSignature: TMethodSignature; SkipSelf: Boolean = True): String;

function MethodSignatureToString(const Name: String; const MethodSignature: TMethodSignature): String; overload;

function MethodSignatureToString(const MethodSignature: TMethodSignature): String; overload;

implementation

function MethodKindString(MethodKind: TMethodKind): String;
begin
  case MethodKind of
    mkSafeProcedure, 
    mkProcedure     : Result := 'procedure';
    mkSafeFunction,
    mkFunction      : Result := 'function';
    mkConstructor   : Result := 'constructor';
    mkDestructor    : Result := 'destructor';
    mkClassProcedure: Result := 'class procedure'; 
    mkClassFunction : Result := 'class function';
  end;  
end;  

function MethodParamString(const MethodParam: TMethodParam; ExcoticFlags: Boolean = False): String;
begin
       if pfVar       in MethodParam.Flags then Result := 'var '
  else if pfConst     in MethodParam.Flags then Result := 'const '
  else if pfOut       in MethodParam.Flags then Result := 'out '
  else                                          Result := '';
  if ExcoticFlags then
  begin
    if pfAddress   in MethodParam.Flags then 
      Result := '{addr} ' + Result;
    if pfReference in MethodParam.Flags then 
      Result := '{ref} ' + Result;
  end;  
  
  Result := Result + MethodParam.ParamName^ + ': ';
  if pfArray in MethodParam.Flags then 
    Result := Result + 'array of ';
  Result := Result + MethodParam.TypeName^;
  if Assigned(MethodParam.TypeInfo) then
    Result := Result + ' {' + MethodParam.TypeInfo.Name + '} ';
end;  

function MethodParametesString(const MethodSignature: TMethodSignature; SkipSelf: Boolean = True): String;
var
  i: integer;
  MethodParam: PMethodParam;
begin
  Result := '';
  for i := 0 to MethodSignature.ParamCount - 1 do
  begin
    MethodParam := @MethodSignature.Parameters[i];
    // Пропускаем неявный параметр Self для методов классов и интерфейсов
    // Заметьте, что Self не включается в типы событий
    if SkipSelf and 
       (i = 0) and 
       (MethodParam.Flags = [pfAddress]) and
       (MethodParam.ParamName^ = 'Self') and 
       (MethodParam.TypeInfo.Kind in [tkInterface, tkClass]) then
      Continue;
    Result := Result + MethodParamString(MethodParam^);
    if i < MethodSignature.ParamCount - 1 then
      Result := Result + '; ';
  end;  
end;  

function CallingConventionToString(CallConv: TCallConv): String;
begin
  case CallConv of
    ccReg     : Result := 'register';
    ccCdecl   : Result := 'cdecl';
    ccPascal  : Result := 'pascal';
    ccStdCall : Result := 'stdcall';
    ccSafeCall: Result := 'safecall';
    else        Result := 'TCallConv('+IntToStr(Ord(CallConv))+')';
  end;  
end;

function MethodSignatureToString(const Name: String; const MethodSignature: TMethodSignature): String; overload;
begin
  Result := Format('%s %s(%s)', 
    [MethodKindString(MethodSignature.MethodKind), 
     Name, 
     MethodParametesString(MethodSignature)]); 
  if MethodSignature.MethodKind = mkFunction then
  begin
    Result := Result + ': ' + MethodSignature.ResultTypeName^;
    if Assigned(MethodSignature.ResultTypeInfo) then
      Result := Result + ' {' + MethodSignature.ResultTypeInfo.Name + '} ';
  end;  
  Result := Result + ';' ;    
  if MethodSignature.CallConv <> ccReg then
    Result := Result + ' ' + 
      CallingConventionToString(MethodSignature.CallConv) + ';';
end;  

function MethodSignatureToString(const MethodSignature: TMethodSignature): String; overload;
begin
  Result := MethodSignatureToString(MethodSignature.Name^, 
  MethodSignature);
end;  

end.

Этот код является простым расширением кода, который мы видели в статье про хак получения параметров published методов через их ассоциацию с событиями. Расширенная RTTI интерфейсов содержит более детализированную информацию, чем сигнатура события, так что мы добавили обработку PTypeInfo параметров и возвращаемых типов, а также соглашения вызова и имени метода. Эти подпрограммы являются достаточно прямолинейной трактовкой информации из структур RTTI в строковое представление. Мы говорили про эти моменты в предыдущих статьях.

Единственный пропущенный кусок - это код из середины цепочки трансляции, который переводит внутреннюю raw информацию RTTI в наши более удобные структуры:

unit HVInterfaceMethods;

interface

uses 
  TypInfo, HVMethodSignature;

type
  // Просто-используемые записи фиксированного размера
  PInterfaceInfo = ^TInterfaceInfo;
  TInterfaceInfo = record
    UnitName: String; 
    Name: String;
    Flags: TIntfFlags;
    ParentInterface: PTypeInfo;
    Guid: TGUID;
    MethodCount: Word;
    HasMethodRTTI: Boolean;
    Methods: array of TMethodSignature;
  end;

procedure GetInterfaceInfo(InterfaceTypeInfo: PTypeInfo; var InterfaceInfo: TInterfaceInfo);
  
implementation

type
  // … сюда вставляем определение TExtraInterfaceData …

function Skip(Value: PShortString): Pointer; overload;
begin
  Result := Value;
  Inc(PChar(Result), SizeOf(Value^[0]) + Length(Value^));
end;  

function Skip(Value: PPackedShortString; var NextField{: Pointer}): PShortString; overload;
begin
  Result := PShortString(Value);
  Inc(PChar(NextField), SizeOf(Char) + Length(Result^) - SizeOf(TPackedShortString));
end;  

function Skip(CurrField: Pointer; FieldSize: Integer): Pointer; overload;
begin
  Result := PChar(Currfield) + FieldSize;
end;

function Dereference(P: PPTypeInfo): PTypeInfo;
begin
  if Assigned(P) then
    Result := P^
  else
    Result := nil;
end;  

procedure GetInterfaceInfo(InterfaceTypeInfo: PTypeInfo; var InterfaceInfo: TInterfaceInfo);
// Конвертирует из raw структур RTTI в наши user-friendly структуры
var
  TypeData: PTypeData;
  ExtraData: PExtraInterfaceData;
  i, j: integer;
  MethodInfo: PMethodSignature;
  MethodRTTI: PInterfaceMethodRTTI;
  ParameterInfo: PMethodParam;
  ParameterRTTI: PInterfaceParameterRTTI;
  InterfaceResultRTTI: PInterfaceResultRTTI;
begin
  Assert(Assigned(InterfaceTypeInfo));
  Assert(InterfaceTypeInfo.Kind = tkInterface);
  TypeData  := GetTypeData(InterfaceTypeInfo);
  ExtraData := Skip(@TypeData.IntfUnit);

  // Интерфейс
  InterfaceInfo.UnitName        := TypeData.IntfUnit;
  InterfaceInfo.Name            := InterfaceTypeInfo.Name;
  InterfaceInfo.Flags           := TypeData.IntfFlags;   
  InterfaceInfo.ParentInterface := Dereference(TypeData.IntfParent);
  InterfaceInfo.Guid            := TypeData.Guid;
  InterfaceInfo.MethodCount     := ExtraData.MethodCount;
  InterfaceInfo.HasMethodRTTI   := (ExtraData.HasMethodRTTI = ExtraData.MethodCount);
  if InterfaceInfo.HasMethodRTTI then 
    SetLength(InterfaceInfo.Methods, InterfaceInfo.MethodCount)
  else 
    SetLength(InterfaceInfo.Methods, 0);

  // Методы
  MethodRTTI := @ExtraData.Methods[0];
  for i := Low(InterfaceInfo.Methods) to High(InterfaceInfo.Methods) do
  begin
    MethodInfo := @InterfaceInfo.Methods[i];
    MethodInfo.Name       := Skip(@MethodRTTI.Name, MethodRTTI);
    MethodInfo.MethodKind := MethodRTTI.Kind;
    MethodInfo.CallConv   := MethodRTTI.CallConv;
    MethodInfo.ParamCount := MethodRTTI.ParamCount;
    SetLength(MethodInfo.Parameters, MethodInfo.ParamCount);

    // Параметры
    ParameterRTTI := @MethodRTTI.Parameters;
    for j := Low(MethodInfo.Parameters) to High(MethodInfo.Parameters) do
    begin
      ParameterInfo := @MethodInfo.Parameters[j];
      ParameterInfo.Flags      := ParameterRTTI.Flags;
      ParameterInfo.ParamName  := Skip(@ParameterRTTI.ParamName, ParameterRTTI);
      ParameterInfo.TypeName   := Skip(@ParameterRTTI.TypeName, ParameterRTTI);
      ParameterInfo.TypeInfo   := Dereference(ParameterRTTI.TypeInfo);
      ParameterRTTI := Skip(@ParameterRTTI.TypeInfo, SizeOf(ParameterRTTI.TypeInfo));
    end;  
    
    // Результат функции
    if MethodInfo.MethodKind = mkFunction then
    begin
      InterfaceResultRTTI := Pointer(ParameterRTTI);
      MethodInfo.ResultTypeName := Skip(@InterfaceResultRTTI.Name, InterfaceResultRTTI);
      MethodInfo.ResultTypeInfo := Dereference(InterfaceResultRTTI.TypeInfo);
      MethodRTTI := Skip(@InterfaceResultRTTI.TypeInfo, SizeOf(InterfaceResultRTTI.TypeInfo));
    end
    else
      MethodRTTI := Pointer(ParameterRTTI);
  end;  
end;  

end.

Код получился немножко хитрым и сложным для чтения из-за необходимости пропускать строковые поля переменной длины. Низкоуровневый код модуля IntfInfo использует иной подход - модель с ReadString, ReadByte, ReadWord, ReadLong. Но мне нравится само-документирующий аспект псевдо-записей, и я хотел использовать их и в коде доступа. Заметьте, что в некоторых точках, только одно поле записи находится на своём месте и может быть прочитано.

Имея такую основательную базу кода, теперь мы можем написать небольшую подпрограмму дампа интерфейса, которая будет печатать псевдо-определение интерфейса:

procedure DumpInterface(InterfaceTypeInfo: PTypeInfo);
var
  InterfaceInfo: TInterfaceInfo;
  i: integer;
begin
  GetInterfaceInfo(InterfaceTypeInfo, InterfaceInfo);

  WriteLn('unit ', InterfaceInfo.UnitName, ';');
  WriteLn('type');
  Write('  ', InterfaceInfo.Name, ' = '); 
  if not (ifDispInterface in InterfaceInfo.Flags) then
  begin
    Write('interface');
    if Assigned(InterfaceInfo.ParentInterface) then
      Write(' (', InterfaceInfo.ParentInterface.Name, ')');
    WriteLn;
  end
  else  
    WriteLn('dispinterface');
  if ifHasGuid in InterfaceInfo.Flags then
    WriteLn('    [''', GuidToString(InterfaceInfo.Guid), ''']');
  if InterfaceInfo.HasMethodRTTI then  
    for i := Low(InterfaceInfo.Methods) to High(InterfaceInfo.Methods) do
      WriteLn('    ', MethodSignatureToString(InterfaceInfo.Methods[i]))
  else
    for i := 1 to InterfaceInfo.MethodCount do  
      WriteLn('    procedure UnknownName',i,';');
  WriteLn('  end;');
  WriteLn;
end;

И, наконец, нам нужен код для теста:

type
  TNumber = Integer;
  TNewNumber = type Integer;
  TIntegerArray = array of Integer;
  TNormalClass = class
  end;
  TPersistentClass = class(TPersistent)
  end;
  TSetOfByte = set of byte;
  TEnum = (enOne, enTwo, enThree);

type
  {.$M+} {.$TYPEINFO ON}
// В отношении RTTI интерфейсов, METHODINFO имеет тот же эффект, что и $M/$TYPEINFO
  {$METHODINFO ON}
  IMyMPInterface = interface
    ['{AA503475-0187-4108-8E27-41475F4EF818}']
    procedure TestRegister(A: Integer; var B: String); register;
    procedure TestStdCall(LongParaName: TObject; const B: String; var C: Integer; out D: Byte); stdcall;
    procedure TestSafeCall(out R: Integer); safecall;
    function Number: TNumber; cdecl;
    function NewNumber: TNewNumber; cdecl;
    function AsString: String; pascal;
    function AsString2: String; safecall;
    // Поддерживаемые возвращаемые типы
    procedure A2(const A: TIntegerArray);
    procedure OkParam1(Value: TSetOfByte); 
    procedure OkParam2(Value: TSetOfByte); 
    procedure OkParam3(Value: Variant);
    procedure OkParam4(Value: TNormalClass);
    function OkReturn1: ShortString; 
    function OkReturn2: TObject; 
    function OkReturn3: IInterface; 
    function OkReturn4: TSetOfByte; 
    function OkReturn5: TNormalClass; 
    function OkReturn6: TEnum; 
    function OkReturn7: TClass; 
    function OkReturn8: Pointer; 
    function OkReturn9: PChar; 
    function OkReturn10: TIntegerArray; 
  end;
  {$M-}

{$WARN SYMBOL_PLATFORM OFF}
procedure Test;
begin
  DumpInterface(TypeInfo(IMyMPInterface));
end;

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

И получаемый вывод:

unit TestExtendedInterfaceRTTI;
type
  IMyMPInterface = interface (IInterface)
    ['{AA503475-0187-4108-8E27-41475F4EF818}']
    procedure TestRegister(A: Integer {Integer} ; var B: String {String} );
    procedure TestStdCall(LongParaName: TObject {TObject} ; const B: String {String} ; var C: Integer {Integer} ; out D: Byte {Byte} ); stdcall;
    procedure TestSafeCall(out R: Integer {Integer} ); safecall;
    function Number(): Integer {Integer} ; cdecl;
    function NewNumber(): TNewNumber {TNewNumber} ; cdecl;
    function AsString(): String {String} ; pascal;
    function AsString2(): String {String} ; safecall;
    procedure A2(const A: TIntegerArray {TIntegerArray} );
    procedure OkParam1(Value: TSetOfByte {TSetOfByte} );
    procedure OkParam2(Value: TSetOfByte {TSetOfByte} );
    procedure OkParam3(Value: Variant {Variant} );
    procedure OkParam4(Value: TNormalClass {TNormalClass} );
    function OkReturn1(): ShortString {ShortString} ;
    function OkReturn2(): TObject {TObject} ;
    function OkReturn3(): IInterface {IInterface} ;
    function OkReturn4(): TSetOfByte {TSetOfByte} ;
    function OkReturn5(): TNormalClass {TNormalClass} ;
    function OkReturn6(): TEnum {TEnum} ;
    function OkReturn7(): TClass;
    function OkReturn8(): Pointer;
    function OkReturn9(): PAnsiChar;
    function OkReturn10(): TIntegerArray {TIntegerArray} ;
  end;

Код, включающий вспомогательные модуля и тестовый код этого примера, а также других моих статей по RTTI, можно найти на CodeCentral здесь. Тестовый код также содержит некоторый дополнительный код по тестированию поддержки дополнительных типов параметров. Мои эксперименты показали, что следующие типы параметров не поддерживаются в расширенном RTTI методов интерфейсов (прим.пер.: Hallvard проверял в Delphi 7-Delphi 2006):

• Все типы указатели (прим.пер.: поддерживается Delphi XE)
• Открытые массивы (array of Type), динамические массивы - OK (прим.пер.: поддерживается Delphi XE)
• Классовые ссылки (вроде TClass) (прим.пер.: поддерживается Delphi XE)
• Записи (вроде TRect) (прим.пер.: поддерживается Delphi XE)
• Нетипизированные var и out

Если компилятор встречает какой-то из этих типов в объявлении интерфейса в режиме расширенного RTTI, он генерирует ошибку компиляции вроде "[Error] : Type '%s' has no type info" в конце объявления интерфейса (т.е. он не указывает на метод-виновник).

Из-за моего летнего отдыха и общей вялости эта статья была представлена ​​вам немного позже, чем планировалось изначально. Надеюсь, я смогу довести до конца следующую статью о расширенной RTTI информации для public и published методов класса в разумные сроки.

P.S. Директива $METHODINFO впервые появилась в Delphi 7, а не Delphi 6.