unit CnCallBack;

interface

uses
  Classes, Windows, SysUtils;

type
  ECallBackException = class(Exception)
  end;

function StdcallMethodToCallBack(ASelf: Pointer; AMethodAddr: Pointer): Pointer;
{* Ѕ« stdcall µДАаіЙФ±єЇКэєНКµАэјУТФ°ьЧ°Ј¬·µ»ШТ»ёцРВµД stdcall µД»ШµчєЇКэµШЦ· }

{* К№УГУп·Ё:
  @AStdCallbackFunc := StdcallMethodToCallBack(AObject, @TAObject.CallbackMethod);
  ЖдЦР AStdCallbackFunc єН CallbackMethod ¶ј±ШРлК№УГ stdcall ЙщГчЎЈ
}

implementation

type
  TCnCallback = array [1..18] of Byte; // °ґґъВлЦРЧоі¤µДАґ
  PCnCallback = ^TCnCallback;
  
const
  THUNK_SIZE = 4096; // x86 ТіґуРЎЈ¬ДїЗ°Ц»ЕЄТ»ёцТіГж

  StdcallCode: TCnCallback =
    ($8B,$04,$24,$50,$B8,$00,$00,$00,$00,$89,$44,$24,$04,$E9,$00,$00,$00,$00);

  {----------------------------}
  { Stdcall CallbackCode ASM   }
  {----------------------------}
  {    MOV EAX, [ESP];         }
  {    PUSH EAX;               }
  {    MOV EAX, ASelf;         }
  {    MOV [ESP+4], EAX;       }
  {    JMP AMethodAddr;        }
  {----------------------------}

var
  FCallBackPool: Pointer = nil;
  FEmptyPtr: Integer = 0;
  FCS: TRTLCriticalSection;

procedure InitCallBackPool;
begin
  FCallBackPool := VirtualAlloc(nil, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  if FCallBackPool = nil then
    raise ECallBackException.Create('Callback Pool Init Error!');
end;

function StdcallMethodToCallBack(ASelf: Pointer; AMethodAddr: Pointer): Pointer;
var
  Instance: PCnCallback;
begin
  Result := nil;
  Instance := nil;
  
  try
    EnterCriticalSection(FCS);

    if FCallBackPool = nil then
    begin
      InitCallBackPool;
      Instance := FCallBackPool;
    end
    else
    begin
      if FEmptyPtr = (THUNK_SIZE div SizeOf(TCnCallback)) then
        raise ECallBackException.Create('Callback Pool Overflow!');

      Inc(FEmptyPtr);
      Instance := PCnCallback(Integer(FCallBackPool) + FEmptyPtr * SizeOf(TCnCallback));
    end;
  finally
    LeaveCriticalSection(FCS);
  end;

  if Instance <> nil then
  begin
    Move(StdcallCode, Instance^, SizeOf(TCnCallback));
    PInteger(@(Instance^[6]))^ := Integer(ASelf);
    PInteger(@(Instance^[15]))^ := Integer(Integer(AMethodAddr) - Integer(Instance) - 18);
    Result := Instance;
  end;
end;

initialization
  InitializeCriticalSection(FCS);

finalization
  DeleteCriticalSection(FCS);
  if FCallBackPool <> nil then
    VirtualFree(FCallBackPool, 0, MEM_RELEASE);

end.

unit CnCallBack;

interface

uses
  Classes, Windows, SysUtils;

type
  ECallBackException = class(Exception)
  end;

function StdcallMethodToCallBack(ASelf: Pointer; AMethodAddr: Pointer): Pointer;
{* Ѕ« stdcall µДАаіЙФ±єЇКэєНКµАэјУТФ°ьЧ°Ј¬·µ»ШТ»ёцРВµД stdcall µД»ШµчєЇКэµШЦ· }

{* К№УГУп·Ё:
  @AStdCallbackFunc := StdcallMethodToCallBack(AObject, @TAObject.CallbackMethod);
  ЖдЦР AStdCallbackFunc єН CallbackMethod ¶ј±ШРлК№УГ stdcall ЙщГчЎЈ
}

implementation

type
  TCnCallback = array [1..18] of Byte; // °ґґъВлЦРЧоі¤µДАґ
  PCnCallback = ^TCnCallback;
  
const
  THUNK_SIZE = 4096; // x86 ТіґуРЎЈ¬ДїЗ°Ц»ЕЄТ»ёцТіГж

  StdcallCode: TCnCallback =
    ($8B,$04,$24,$50,$B8,$00,$00,$00,$00,$89,$44,$24,$04,$E9,$00,$00,$00,$00);

  {----------------------------}
  { Stdcall CallbackCode ASM   }
  {----------------------------}
  {    MOV EAX, [ESP];         }
  {    PUSH EAX;               }
  {    MOV EAX, ASelf;         }
  {    MOV [ESP+4], EAX;       }
  {    JMP AMethodAddr;        }
  {----------------------------}

var
  FCallBackPool: Pointer = nil;
  FEmptyPtr: Integer = 0;
  FCS: TRTLCriticalSection;

procedure InitCallBackPool;
begin
  FCallBackPool := VirtualAlloc(nil, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  if FCallBackPool = nil then
    raise ECallBackException.Create('Callback Pool Init Error!');
end;

function StdcallMethodToCallBack(ASelf: Pointer; AMethodAddr: Pointer): Pointer;
var
  Instance: PCnCallback;
begin
  Result := nil;
  Instance := nil;
  
  try
    EnterCriticalSection(FCS);

    if FCallBackPool = nil then
    begin
      InitCallBackPool;
      Instance := FCallBackPool;
    end
    else
    begin
      if FEmptyPtr = (THUNK_SIZE div SizeOf(TCnCallback)) then
        raise ECallBackException.Create('Callback Pool Overflow!');

      Inc(FEmptyPtr);
      Instance := PCnCallback(Integer(FCallBackPool) + FEmptyPtr * SizeOf(TCnCallback));
    end;
  finally
    LeaveCriticalSection(FCS);
  end;

  if Instance <> nil then
  begin
    Move(StdcallCode, Instance^, SizeOf(TCnCallback));
    PInteger(@(Instance^[6]))^ := Integer(ASelf);
    PInteger(@(Instance^[15]))^ := Integer(Integer(AMethodAddr) - Integer(Instance) - 18);
    Result := Instance;
  end;
end;

initialization
  InitializeCriticalSection(FCS);

finalization
  DeleteCriticalSection(FCS);
  if FCallBackPool <> nil then
    VirtualFree(FCallBackPool, 0, MEM_RELEASE);

end.