#1347. Ссылка. TVirtualInterface

http://docwiki.embarcadero.com/CodeExamples/XE8/en/Rtti.TVirtualInterface_(Delphi)

Чудесная штука. На ней можно делать свои интерфейсы на стороне собственных скриптов. Ну или другой мета-информации. Сами они его для SOAP используют.

А мне рассказывали про собственную реализацию интерфейсов для Delphi на стороне Python'а.

(+) http://docwiki.embarcadero.com/Libraries/XE8/en/System.Rtti.TRawVirtualClass

Интересный такой код:

constructor TVirtualInterface.Create(PIID: PTypeInfo);
var
  Methods: TArray<TRttiMethod>;
  Method: TRttiMethod;
  Typ: TRttiType;
  MaxIndex, I: Integer;
begin
  FIntercepts := TObjectList<TImplInfo>.Create(True);
  Typ := FContext.GetType(PIID);
  FIID := TRttiInterfaceType(Typ).GUID;
                              
  Methods := Typ.GetMethods;
  MaxIndex := 2;  // Is this the best way to do this?
  for Method in Methods do
  begin
    if MaxIndex < Method.VirtualIndex then
      MaxIndex := Method.VirtualIndex;
    FIntercepts.Add(TImplInfo.Create(Method, RawCallBack));
  end;

  VTable := AllocMem(SizeOf(Pointer)* (MaxIndex+1));
  PVtablePtr(VTable)[0] := @TVirtualInterface._QIFromIntf;
  PVtablePtr(VTable)[1] := @TVirtualInterface._AddRefFromIntf;
  PVtablePtr(VTable)[2] := @TVirtualInterface._ReleaseFromIntf;
  for I := 0 to FIntercepts.Count-1 do
    PVtablePtr(VTable)[FIntercepts[I].VirtualIndex] := FIntercepts[I].CodeAddress;
  for I := 3 to MaxIndex do
    if PVtablePtr(VTable)[I] = nil then
      PVtablePtr(VTable)[I] := @TVirtualInterface.ErrorProc;
end;

constructor TVirtualInterface.Create(PIID: PTypeInfo;
  InvokeEvent: TVirtualInterfaceInvokeEvent);
begin
  Create(PIID);
  FOnInvoke := InvokeEvent;
end;

destructor TVirtualInterface.Destroy;
begin
  if VTable <> nil then
    FreeMem(VTable);
  FIntercepts.Free;
  inherited;
end;

procedure TVirtualInterface.RawCallback(UserData: Pointer;
  const Args: TArray<TValue>; out Result: TValue);
begin
  if Assigned(FOnInvoke) then
    FOnInvoke(TImplInfo(UserData).FMethod, Args, Result);
end;

procedure TVirtualInterface.ErrorProc;
begin
  raise InsufficientRtti;
end;

function TVirtualInterface._AddRefFromIntf: Integer;
begin
  Result := TVirtualInterface(PByte(Self) -
    (PByte(@Self.VTable) - PByte(Self)))._AddRef;
end;

function TVirtualInterface._ReleaseFromIntf: Integer;
begin
  Result := TVirtualInterface(PByte(Self) -
    (PByte(@Self.VTable) - PByte(Self)))._Release;
end;

function TVirtualInterface._QIFromIntf(const IID: TGUID; out Obj): HResult;
begin
  Result := TVirtualInterface(PByte(Self) -
    (PByte(@Self.VTable) - PByte(Self))).QueryInterface(IID, Obj);
end;

function TVIrtualInterface._AddRef: Integer;
begin
  Result := inherited
end;

function TVIrtualInterface._Release: Integer;
begin
  Result := inherited
end;

function TVirtualInterface.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if iid = FIID then
  begin
    _AddRef;
    Pointer(Obj) := @VTable;
    Result := S_OK;
  end
  else
    Result := inherited
end;

Прям руки чешутся это в реальных условиях попробовать.

А в SOAP оно используется тут:

  TRIO = class(TComponent, IInterface, IRIOAccess)
  private type
    TRioVirtualInterface = class(TVirtualInterface)
    private
      FRio: TRio;
    protected
//{$IFNDEF AUTOREFCOUNT}
      function _AddRef: Integer; override; stdcall;
      function _Release: Integer; override; stdcall;
//{$ENDIF !AUTOREFCOUNT}
    public
      constructor Create(ARio: TRio; AInterface: Pointer);
//{$IFNDEF AUTOREFCOUNT}
      function QueryInterface(const IID: TGUID; out Obj): HRESULT; override; stdcall;
//{$ENDIF !AUTOREFCOUNT}
    end;
  private
    FInterface: IInterface;

{$IFNDEF AUTOREFCOUNT}
    FRefCount: Integer;
{$ENDIF !AUTOREFCOUNT}

    { Headers }
    FSOAPHeaders: TSOAPHeaders;
    FHeadersOutBound: THeaderList;
    FHeadersInbound: THeaderList;

    FOnAfterExecute: TAfterExecuteEvent;
    FOnBeforeExecute: TBeforeExecuteEvent;
    FOnSendAttachment: TOnSendAttachmentEvent;
    FOnGetAttachment: TOnGetAttachmentEvent;

    procedure Generic(Method: TRttiMethod;
      const Args: TArray; out Result: TValue);

{$IFNDEF AUTOREFCOUNT}
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
{$ENDIF !AUTOREFCOUNT}

    { IRIOAccess }
    function GetRIO: TRIO;

  protected
    FIID: TGUID;
    IntfMD: TIntfMetaData;
    FConverter: IOPConvert;
    FWebNode: IWebNode;

    procedure DoDispatch(const Context: TInvContext; MethNum: Integer; const MethMD: TIntfMethEntry);
    function InternalQI(const IID: TGUID; out Obj): HResult; stdcall;

    { Routines that derived RIOs may override }
    procedure DoAfterExecute(const MethodName: string; Response: TStream); virtual;
    procedure DoBeforeExecute(const MethodName: string; Request: TStream); virtual;
    function  GetResponseStream(BindingType: TWebServiceBindingType): TStream; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;
    { Behave like a TInterfacedObject, (only when Owner = nil) }
{$IFNDEF AUTOREFCOUNT}
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    class function NewInstance: TObject; override;

    property RefCount: Integer read FRefCount;
{$ENDIF !AUTOREFCOUNT}
    property Converter: IOPConvert read FConverter write FConverter;
    property WebNode: IWebNode read FWebNode write FWebNode;
    property SOAPHeaders: TSOAPHeaders read FSOAPHeaders;
  published
    property OnAfterExecute: TAfterExecuteEvent read FOnAfterExecute write FOnAfterExecute;
    property OnBeforeExecute: TBeforeExecuteEvent read FOnBeforeExecute write FOnBeforeExecute;
    property OnSendAttachment: TOnSendAttachmentEvent read FOnSendAttachment write FOnSendAttachment;
    property OnGetAttachment: TOnGetAttachmentEvent read FOnGetAttachment write FOnGetAttachment;
  end;

Тоже крайне забавно.

Самое, что смешное, что оно только там и используется. Хотя возможности для использования данного подхода - огромны.

Для всяческого "собственного маршалинга".

Ну и для ORM например. Хотя есть и другой путь. Несколько обратный:
http://18delphi.blogspot.ru/2013/07/blog-post.html
http://roman.yankovsky.me/?p=740