Callback mit externer C-dll

[NicoDE]

So, weil an-Delphi-rumhacken doch irgendwie Spaß macht...
...hier Dein Thunk für cdecl-Methodenzeiger

Delphi-Quellcode:

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.