unit Unit1;
interface
uses
Windows, Classes, Controls, Forms, Dialogs, StdCtrls;
type
TFNCallback =
procedure(Text: PChar);
cdecl;
TFNMethodCallback =
procedure(Text: PChar)
of object;
cdecl;
type
TForm1 =
class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure MethodCallback(Text: PChar);
cdecl;
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FNCallback: TFNCallback;
FNMethodCallback: TFNMethodCallback;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
////////////////////////////////////////////////////////////////////////////////
//
// MakeCdeclCallback (build thunk to use cdecl methods as static callback)
//
function MakeCdeclCallback(
const Method: TMethod; StackSize: Shortint): Pointer;
{$IFDEF WIN32}
type
PCallbackPush = ^TCallbackPush;
TCallbackPush =
packed record
// push dword ptr [esp+x]
PushParmOps:
array [0..2]
of Byte;
PushParmVal: Shortint;
end;
PCallbackCall = ^TCallbackCall;
TCallbackCall =
packed record
// push dword ptr [offset]
PushDataOps:
array [0..1]
of Byte;
PushDataVal: Pointer;
// call [offset]
CallCodeOps:
array [0..1]
of Byte;
CallCodeVal: Pointer;
// add esp,x
AddEspXXOps:
array [0..1]
of Byte;
AddEspXXVal: Shortint;
// ret
Return : Byte;
end;
var
Size: Shortint;
Loop: Shortint;
Buff: Pointer;
{$ENDIF}
begin
{$IFDEF WIN32}
if (StackSize < 0)
or // check for invalid parameter and Shortint overflow
(StackSize > High(Shortint) + 1 - 2 * SizeOf(Longword))
then
begin
Result :=
nil;
Exit;
end;
Result := VirtualAlloc(
nil, $100, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
if Assigned(Result)
then
try
Buff := Result;
if StackSize <= 0
then
Size := 0
else
begin
// Copy parameters (used Longwords)
Size := ((StackSize - 1)
div SizeOf(Longword) + 1) * SizeOf(Longword);
for Loop := 1
to Size
div SizeOf(Longword)
do
begin
with PCallbackPush(Buff)^
do
begin
PushParmOps[0] := $FF;
PushParmOps[1] := $74;
PushParmOps[2] := $24;
PushParmVal := Size;
end;
Inc(PCallbackPush(Buff));
end;
end;
with PCallbackCall(Buff)^
do
begin
// Push Self
PushDataOps[0] := $FF;
PushDataOps[1] := $35;
PushDataVal := Addr(Method.Data);
// Call Method
CallCodeOps[0] := $FF;
CallCodeOps[1] := $15;
CallCodeVal := Addr(Method.Code);
// Fix Stack
AddEspXXOps[0] := $83;
AddEspXXOps[1] := $C4;
AddEspXXVal := Size + SizeOf(Longword);
// Return
Return := $C3;
end;
except
VirtualFree(Result, 0, MEM_RELEASE);
Result :=
nil;
end;
{$ELSE}
Result :=
nil;
{$ENDIF}
end;
procedure FreeCdeclCallback(Callback: Pointer);
begin
{$IFDEF WIN32}
if Assigned(Callback)
then
VirtualFree(Callback, 0, MEM_RELEASE);
{$ENDIF}
end;
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
// Create callback thunk for FNMethodCallback
FNCallback := TFNCallback(MakeCdeclCallback(TMethod(FNMethodCallback), 4));
// afterwards to show that the thunk works even if the value changes!
FNMethodCallback := MethodCallback;
end;
procedure TForm1.MethodCallback(Text: PChar);
cdecl;
begin
ShowMessage('
MethodCallback: ' +
string(Text));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
FNCallback('
foo');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeCdeclCallback(@FNCallback);
end;
end.