Callback mit externer C-dll

[oXmoX]

Hallo Forum!

Hab mal eine Frage zu Funktionspointern. Ich verwende eine externe C-Bibliothek. Um ein Callback zu realisieren nimmt eine der verwendeten Funktionen ein Funktionspointer entgegen. Dieser ist vom Typ void* - also Pointer in Delphi.

Jetzt habe ich eine Prozedur "CallbackProc" erstellt, die nun als Pointer übergeben werden soll. Dazu wiederum ist die Funktion "SetupCallback" zuständig. Das Problem ist nur, dass meine Callback-Prozedur vom Typ "TCallbackProc" ist und ich keine Ahnung hab, wie ich daraus einen Pointer für die C-Funktion machen soll.

Code:

unit CallbackTest;

interface
  
type
  TCallbackProc = procedure(ImageIpl: P_IplImage);

function setCallback(callback: Pointer); cdecl;
procedure SetupCallback;
procedure CallbackProc(ImageIpl: P_IplImage);


implementation

var
  CallbackProcVar: TCallbackProc;

function setCallback(callback: Pointer); external 'abc.dll';

procedure CallbackProc(ImageIpl: P_IplImage);
begin
  ; // nix
end;

procedure SetupCallback;
begin
  CallbackProcVar := CallbackProc;
  setCallback(CallbackProcVar);
end;

end.

Bei dem oben abgebildeten Code sagt mir der Compiler jedenfalls "Nicht genügend wirkliche Parameter" in der Zeile "setCallback(CallbackProcVar);" ...kein Wunder: Ich übergebe ja auch einen Pointer, wie gefordert.

Was nun?

[c113plpbr]

Probiers doch mal so:

Delphi-Quellcode:

procedure SetupCallback;
begin
  setCallback(@CallbackProc);
end;

ciao, Philipp

[NicoDE]

Zitat:

Zitat von oXmoX

"setCallback(CallbackProcVar);" ...kein Wunder: Ich übergebe ja auch einen Pointer, wie gefordert.

Delphi ist in diesem Falle etwas übereifrig (bei der automatischen Dereferenzierung von (Funktions-)Zeigern) und versucht CallbackProcVar aufzurufen (es ist kein () nötig wie in C).

Zitat:

Zitat von oXmoX

Was nun?

Siehe vorherigen Beitrag,
oder Pointer(CallbackProcVar).

[oXmoX]

Sowas blöse von mir. Vielen Dank für eure Hilfe. Da war ich eigentlich auch schon selbst drauf gekommen ...hat aber nicht funktioniert ...jetzt schon. Wer weis, das ich da wieder durcheinandergebracht habe.

...So, jetzt kommt der schwierige Teil. Schön wäre jetzt, wenn ich nicht eine Funktion, sondern eine Objekt-Methode als Funktionpointer übergeben kann. Hab mal Gegoogelt und folgenden Code gefunden, der mir angeblich aus einer Methode einen Funktionszeiger machen soll.

Code:

unit MethodPointer;

interface

//type TMyMethod = procedure of object;

function MakeProcInstance(M: TMethod): Pointer;
procedure FreeProcInstance(ProcInstance: Pointer);


implementation

function MakeProcInstance(M: TMethod): Pointer;
begin
  // allocate memory
  GetMem(Result, 15);
  asm
    // MOV ECX, 
    MOV BYTE PTR [EAX], $B9
    MOV ECX, M.Data
    MOV DWORD PTR [EAX+$1], ECX
    // POP EDX
    MOV BYTE PTR [EAX+$5], $5A
    // PUSH ECX
    MOV BYTE PTR [EAX+$6], $51
    // PUSH EDX
    MOV BYTE PTR [EAX+$7], $52
    // MOV ECX, 
    MOV BYTE PTR [EAX+$8], $B9
    MOV ECX, M.Code
    MOV DWORD PTR [EAX+$9], ECX
    // JMP ECX
    MOV BYTE PTR [EAX+$D], $FF
    MOV BYTE PTR [EAX+$E], $E1
  end;
end;


procedure FreeProcInstance(ProcInstance: Pointer);
begin
  // free memory
  FreeMem(ProcInstance, 15);
end;

end.

Hier noch der Link.

Wenn ich das jetzt mit folgendem Code aufrufe...

Code:

Self.FCallbackProcVar :=      // ist vom Typ procedure of object;
    Self.MyCallbackProc;
Self.FCallbackProcPtr := // ist vom Typ Pointer
    MakeProcInstance(TMethod(Self.FCallbackProcVar));
setCallback(FCallbackProcPtr);

...dann springt das Programm beim Aufrufen der Calback-Methode mit einer Access Violation raus und der Debugger präsentiert mir das CPU-Fenster. Das macht der bei der vorherigen Version nicht.

[oXmoX]

Ok ...habs grad selbst rausgefunden: die Methode muss STDCALL sein ...meine dll benutzt aber CDECL.
(Das kommt davon wenn man den Text nicht ordentlich durchliest)

Tja, ist wohl pech für mich. Oder hat jemand noch eine Idee.

[NicoDE]

Zitat:

Zitat von oXmoX

Tja, ist wohl pech für mich. Oder hat jemand noch eine Idee.

Man könnte den Code anpassen...
Allerdings wird's aus Zeitmangel bei mir nichts vor heute Nacht oder morgen; aber es gibt ja genug Freaks in diesem Forum :D

ps: zudem muss der Code für WinXP SP2 angepasst werden (Code auf dem Heap mag die DEP nicht...)

[oXmoX]

Zitat:

Zitat von NicoDE

Allerdings wird's aus Zeitmangel bei mir nichts vor heute Nacht oder morgen; aber es gibt ja genug Freaks in diesem Forum :D

Hey, mach dir keinen Stress NicoDE. Zur Not kann ich auch mit der obigen Lösung leben. Ich selbst werde da jedenfalls die Finger von lassen. Ich programmiere erst seit zwei Monaten in Delphi und von Inline-Assembler habe ich schonmal überhaupt keine Ahnung.

[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.

[oXmoX]

Genial Meister!

Kann's im Moment nicht ausprobieren.
Sollte es aber bei mir nicht funktionieren, dann weiß ich ja, wo ich meckern kann ;) .

An den Service hier könnte ich mich gewöhnen :) .

Gruß,
oXmoX

[NicoDE]

Apropos Service, hier ist eine Version die mit 'pascal', 'stdcall' und 'safecall' (auch unter WinXP SP2) funktioniert:
(falls es mal jemand brauchen sollte)

Delphi-Quellcode:

////////////////////////////////////////////////////////////////////////////////
//
//  MakeStdcallCallback (thunk to use stdcall method as static callback)
//  (works too for pascal and safecall, but NOT for cdecl and register!)

function MakeStdcallCallback(const Method: TMethod): Pointer;
{$IFDEF WIN32}
type
  PCallbackCode = ^TCallbackCode;
  TCallbackCode = packed record
    Ops1: array [0..2] of Longword;
    Val1: Pointer;
    Ops2: array [0..1] of Longword;
    Val2: Pointer;
  end;
{$ENDIF}
begin
{$IFDEF WIN32}
  Result := VirtualAlloc(nil, $100, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  if Assigned(Result) then
    try
      with PCallbackCode(Result)^ do
      begin
        // ; do not change registers!
        // push    eax                         ; stack space (Self)
        // push    eax                         ; backup accumulator 
        // mov     eax, [esp+8]                ; get return address
        // mov     [esp+4], eax                ; save at lower addr
        // mov     eax, [x].TMethod.Data       ; get x.Self pointer
        // mov     [esp+8], eax                ; save it into space
        // pop     eax                         ; get eax from stack
        // nop                                 ; think about it *g*
        // jmp     dword ptr [x].TMethod.Code  ; now jump to method
        // ; no need to cleanup stack
        Ops1[0] := $448B5050;
        Ops1[1] := $44890824;
        Ops1[2] := $058B0424;
        Val1 := Addr(Method.Data);
        Ops2[0] := $08244489;
        Ops2[1] := $25FF9058;
        Val2 := Addr(Method.Code);
      end;
    except
      VirtualFree(Result, 0, MEM_RELEASE);
      Result := nil;
    end;
{$ELSE}
  Result := nil;
{$ENDIF}
end;

procedure FreeCallback(Callback: Pointer);
begin
{$IFDEF WIN32}
  if Assigned(Callback) then
    VirtualFree(Callback, 0, MEM_RELEASE);
{$ENDIF}
end;

Fehlt nur noch 'register', aber dazu bin ich heute zu faul.