RtfLabel, Version 1.3a (alt)

{
  ThiscallWrapper.pas

  Pascal unit to wrap stdcall around incoming (foreign) and outgoing (own)
  interfaces that use the MS Visual C++ `thiscall´ calling convention.

  Both functions below allow up to 207 virtual methods (including
  QueryInterface, AddRef and Release, which are handled in a special way).

  Version 1.2 - always find the most current version at
  http://flocke.vssd.de/prog/code/pascal/rtflabel/

  Copyright (C) 2005, 2006 Volker Siebert <flocke@vssd.de>
  All rights reserved.

  Permission is hereby granted, free of charge, to any person obtaining a
  copy of this software and associated documentation files (the "Software"),
  to deal in the Software without restriction, including without limitation
  the rights to use, copy, modify, merge, publish, distribute, sublicense,
  and/or sell copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following conditions:

  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
}

unit ThiscallWrapper;

{$RANGECHECKS OFF}
{$TYPEDADDRESS OFF}
{$LONGSTRINGS ON}
{$EXTENDEDSYNTAX ON}

interface

uses
  SysUtils, Windows;

{ Use `QueryThiscallInterface´ instead of `QueryInterface´ or the `as´
  operator to get an `stdcall´ proxy for a `thiscall´ interface. Example:

  Instead of   Svc := Obj as ITextServices;
  simply use   QueryThiscallInterface(Obj, IID_ITextServices, Svc);

  After that, just use the returned interface like the original one (using
  `stdcall´).

  Note: you should *NOT* pass such an interface back to a C/C++ function
  that expects it to be `thiscall´. You must use the original object for
  this instead.
}
function QueryThiscallInterface(const Intf: IUnknown; const IID: TGUID;
  out Obj): HRESULT;

{ Use `CreateThiscallInterface´ to build a proxy around an `stdcall´ interface
  created with Delphi and a foreign caller that expects a `thiscall´ interface.
  Example:

  Instead of

    Host := Obj as ITextHost;
    CreateTextServices(nil, Host, Unk);

  simply use

    CreateThiscallInterface(Obj, IID_ITextHost, Host);
    CreateTextServices(nil, Host, Unk);

  If `Obj´ itself is an independent interface, you can use it just like this
  and the final `Release´ on `Host´ will also do a `Release´ on `Obj´.

  If `Obj´ itself controls the `Host´ variable's lifetime, you should pass
  TRUE as additional parameter and use `FreeThiscallInterface´ to free `Host´.
  Otherwise setting `Host´ to NIL will cause `Obj´s destruction in its own
  destructor.
}
function CreateThiscallInterface(const Intf: IUnknown; const IID: TGUID;
  out Obj; Controlled: Boolean = False): HRESULT;

procedure FreeThiscallInterface(var Intf);

implementation

{------------------------------------------------------------}
{ Common things for both, incoming and outgoing interfaces }

type
  // Classless types of IUnknown methods
  TInterfaceQuery = function(This: Pointer; const IID: TGUID; out Obj): HRESULT;
    stdcall;
  TInterfaceAddRef = function(This: Pointer): LongInt; stdcall;
  TInterfaceRelease = function(This: Pointer): LongInt; stdcall;

  // The base VMT for IUnknown
  PUnknownVMT = ^TUnknownVMT;
  TUnknownVMT = packed record
    // IUnknown interface (stdcall)
    QueryInterface: TInterfaceQuery;
    AddRef: TInterfaceAddRef;
    Release: TInterfaceRelease;
  end;

  // The base wrapper class we use for both wrappers
  PUnknownWrapper = ^TUnknownWrapper;
  TUnknownWrapper = packed record
    VMT: PUnknownVMT;                           // Virtual method table
    Intf: PUnknownWrapper;                      // Original interface pointer
    RefCount: LongInt;                          // Reference counter
    GUID: PGUID;                                // Pointer to GUID
  end;

{ Wrapper for `AddRef´: first call the original interface and additionally
  increment our own reference counter.
}
function Unk_AddRef(This: PUnknownWrapper): LongInt; stdcall;
begin
  Result := InterlockedIncrement(This^.RefCount);
end;

{ Wrapper for `QueryInterface´, just replaces `this´ and jumps to the original
  procedure. Note that this function will always return our own interface
  (AddRef'd) when asked for our own GUID.
}
function Unk_QueryInterface(This: PUnknownWrapper; const IID: TGUID;
  out Obj): HRESULT; stdcall;
begin
  if IsEqualGUID(This^.GUID^, IID) then
  begin
    Unk_AddRef(This);
    Pointer(Obj) := This;
    Result := S_OK;
  end
  else
  begin
    { Note that interfaces returned by QueryInterface are automatically
      AddRef'fed, but since the foreign QueryInterface will never return
      our interface, we do not increment our reference counter in that case.
    }
    Result := This^.Intf^.VMT^.QueryInterface(This^.Intf, IID, Obj);
  end;
end;

{ Wrapper for `Release´: first call the original interface and additionally
  decrement our own reference counter. If it becomes zero, free the whole
  structure
}
function Unk_Release(This: PUnknownWrapper): LongInt; stdcall;
begin
  Result := InterlockedDecrement(This^.RefCount);
  if Result = 0 then
  begin
    This^.Intf^.VMT^.Release(This^.Intf);
    This^.Intf := nil;
    This^.VMT := nil;
    FreeMem(This);
  end;
end;

{------------------------------------------------------------}
{ Incoming (foreign) `thiscall´ interfaces.

  The following assembler code fragment is used to build a proxy between
  Delphi expecting an `stdcall´ interface and a foreign `thiscall´ interface.

  Each VMT index needs its own fragment with exactly the same offset in
  `Index´ as in the original VMT, but *ALL* such interfaces can share the same
  function for the same index.
}

type
  TCallingWrapper = packed record
    Before: packed array [0 .. 9] of Byte;
    Index: Integer;
    After: packed array [0 .. 1] of Byte;
  end;

const
  CCallingWrapper: TCallingWrapper = (
    Before: (
      // Get `Self´ off the stack -> ECX
      $58,                      // 00: pop  eax    ; return address
      $59,                      // 01: pop  ecx    ; Self
      $50,                      // 02: push eax    ; return address
      // Dereference This := Self^.Intf
      $8B,$49,$04,              // 03: mov  ecx, [ecx + 4]
      // Now call This^.VMT^.proc_XX(This)
      $8B,$01,                  // 06: mov  eax, [ecx]
      $FF,$A0{,xx,xx,xx,xx}     // 08: jmp  [eax + *]
    );
    Index: 0;
    After: (
      $90,$90                   // 0E: nop, nop
    )
  );

const
  // 4096 Bytes -> 207 Entries (including the 3 base interfaces)
  CNumCallingMethods = 3 + (4096 - 12) div (SizeOf(TCallingWrapper) + 4);

type
  PCallingWrapperVMT = ^TCallingWrapperVMT;
  TCallingWrapperVMT = packed record
    BaseVMT: array [0 .. 2] of Pointer;
    DynVMT: array [0 .. CNumCallingMethods - 4] of Pointer;
    Wraps: array [0 .. CNumCallingMethods - 4] of TCallingWrapper;
  end;

var
  CallingWrapperVMT: PCallingWrapperVMT;

function GetCallingWrapperVMT: PUnknownVMT;
var
  p: PCallingWrapperVMT;
  k: Integer;
begin
  if CallingWrapperVMT = nil then
  begin
    p := VirtualAlloc(nil, SizeOf(TCallingWrapperVMT),
      MEM_COMMIT, PAGE_EXECUTE_READWRITE);
    if p = nil then
      RaiseLastOSError;

    p^.BaseVMT[0] := @Unk_QueryInterface;
    p^.BaseVMT[1] := @Unk_AddRef;
    p^.BaseVMT[2] := @Unk_Release;

    for k := 0 to CNumCallingMethods - 4 do
    begin
      p^.Wraps[k] := CCallingWrapper;
      p^.Wraps[k].Index := 4 * (k + 3);
      p^.DynVMT[k] := @p^.Wraps[k];
    end;

    CallingWrapperVMT := p;
  end;

  Result := PUnknownVMT(CallingWrapperVMT);
end;

function QueryThiscallInterface(const Intf: IUnknown; const IID: TGUID;
  out Obj): HRESULT;
var
  Res: PUnknownWrapper;
begin
  Res := AllocMem(SizeOf(TUnknownWrapper));
  Res^.VMT := GetCallingWrapperVMT;
  Result := Intf.QueryInterface(IID, Res^.Intf);
  if Result = S_OK then
  begin
    Res^.RefCount := 1;
    Res^.GUID := @IID;
    PUnknownWrapper(Obj) := Res;
  end
  else
  begin
    FreeMem(Res);
    Pointer(Obj) := nil;
  end;
end;

{------------------------------------------------------------}
{ Outgoing (own) `thiscall´ interfaces.

  The following assembler code fragment is used to build a proxy between
  a foreign caller expecting a `thiscall´ interface and an `stdcall´
  interface built using Delphi.

  Each VMT index needs its own fragment with exactly the same offset in
  `Index´ as in the original VMT, but *ALL* such interfaces can share the same
  function for the same index.
}

type
  TCalledWrapper = packed record
    Before: packed array [0 .. 9] of Byte;
    Index: Integer;
    After: packed array [0 .. 1] of Byte;
  end;

const
  CCalledWrapper: TCalledWrapper = (
    Before: (
      // Dereference Self := This^.Intf
      $8B,$49,$04,              // 00: mov  ecx, [ecx + 4]
      // Push `Self´ onto the stack
      $58,                      // 03: pop  eax
      $51,                      // 04: push ecx
      $50,                      // 05: push eax
      // Now call Self^.VMT^.proc_XX(Self)
      $8B,$01,                  // 06: mov  eax, [ecx]
      $FF,$A0{,xx,xx,xx,xx}     // 08: jmp  [eax + *]
    );
    Index: 0;
    After: (
      $90,$90                   // 0C: nop, nop
    )
  );

const
  // 4096 Bytes -> 207 Entries (including the 3 base interfaces)
  CNumCalledMethods = 3 + (4096 - 12) div (SizeOf(TCalledWrapper) + 4);

type
  PCalledWrapperVMT = ^TCalledWrapperVMT;
  TCalledWrapperVMT = packed record
    BaseVMT: array [0 .. 2] of Pointer;
    DynVMT: array [0 .. CNumCalledMethods - 4] of Pointer;
    Wraps: array [0 .. CNumCalledMethods - 4] of TCalledWrapper;
  end;

var
  CalledWrapperVMT: PCalledWrapperVMT;

function GetCalledWrapperVMT: PUnknownVMT;
var
  p: PCalledWrapperVMT;
  k: Integer;
begin
  if CalledWrapperVMT = nil then
  begin
    p := VirtualAlloc(nil, SizeOf(TCalledWrapperVMT),
      MEM_COMMIT, PAGE_EXECUTE_READWRITE);
    if p = nil then
      RaiseLastOSError;

    p^.BaseVMT[0] := @Unk_QueryInterface;
    p^.BaseVMT[1] := @Unk_AddRef;
    p^.BaseVMT[2] := @Unk_Release;

    for k := 0 to CNumCalledMethods - 4 do
    begin
      p^.Wraps[k] := CCalledWrapper;
      p^.Wraps[k].Index := 4 * (k + 3);
      p^.DynVMT[k] := @p^.Wraps[k];
    end;

    CalledWrapperVMT := p;
  end;

  Result := PUnknownVMT(CalledWrapperVMT);
end;

function CreateThiscallInterface(const Intf: IUnknown; const IID: TGUID;
  out Obj; Controlled: Boolean): HRESULT;
var
  Res: PUnknownWrapper;
begin
  Res := AllocMem(SizeOf(TUnknownWrapper));
  Res^.VMT := GetCalledWrapperVMT;
  Result := Intf.QueryInterface(IID, Res^.Intf);
  if Result = S_OK then
  begin
    Res^.RefCount := 1;
    Res^.GUID := @IID;
    if Controlled then
    begin
      Intf._Release;
      inc(Res^.RefCount);
    end;
    PUnknownWrapper(Obj) := Res;
  end
  else
  begin
    FreeMem(Res);
    Pointer(Obj) := nil;
  end;
end;

procedure FreeThiscallInterface(var Intf);
begin
  if Pointer(Intf) <> nil then
    if PUnknownWrapper(Intf)^.Intf <> nil then
    begin
      PUnknownWrapper(Intf)^.Intf := nil;
      PUnknownWrapper(Intf)^.VMT := nil;
      FreeMem(Pointer(Intf));
      Pointer(Intf) := nil;
    end;
end;

end.