[FreePascal] Fenstercallback in einer Klasse

[Mithrandir]

Moinsen,

Hier im Forum gibts ja einige Beispiele, wie man aus einem Methodenzeiger einen Funktionszeiger machen kann. Ich möchte jetzt SmallTune komplett auf FreePascal/Lazarus programmieren. Doch irgendwie steckt in diesem Quelltext der Wurm:

(Basiert auf diesen Code von SirThornberry)

Delphi-Quellcode:

{$mode objfpc}
{$ASMMODE intel}
 
interface
 
uses
  Windows;
Type
 
  TObjWndProc = function(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LResult of Object;
  TNonVCLMsgProcObj = class(TObject)
  private
    fAllocedMem: Pointer;
    fMethodRef: TObjWndProc;
    fSelfRef: TObject;
    procedure FSetMethodRef(ARef: TObjWndProc);
    procedure FSetSelfRef(ARef: TObject);
  public
    constructor Create(ASelfRef: TObject=nil; AMethod: TObjWndProc=nil);
    destructor Destroy; override;
 
    property SelfRef: TObject read fSelfRef write FSetSelfRef default nil;
    property WndProc: Pointer read fAllocedMem;
    property WndMethod: TObjWndProc read fMethodRef write FSetMethodRef;
  end;
 
  { TstMainWindow }
 
  TstMainWindow = class
    private
      fwc : TWndClass;
      fWndExFlags,
      fWndFlags: DWORD;
      fWnd: HWND;
      fwndClassName: String;
      fAppName: String;
 
      fWindowHeight,
      fWindowWidth: LongInt;
 
      fOSVersion : TOSVERSIONINFO;
 
      fMsgProcObj: TNonVCLMsgProcObj;
 
      function FWndProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LResult; stdcall;
    public
      property OSVersion : TOSVERSIONINFO read fOSVersion write fOSVersion;
      property wndClassName : String read fwndClassName write fwndClassName;
      property AppName : String read fAppName write fAppName;
      property WindowHeight : LongInt read fWindowHeight write fWindowHeight;
      property WindowWidth : LongInt read fWindowWidth write fWindowWidth;
 
      procedure CreateWindow;
 
      Constructor Create;
      Destructor Destroy; override;
  end;
 
implementation
 
{ TNonVCLObjMsgProc }
 
constructor TNonVCLMsgProcObj.Create(ASelfRef: TObject; AMethod: TObjWndProc);
  procedure LWrite(AVal: Integer; var APtr: Pointer; ASize: Integer);
  begin
    move(AVal, APtr^, ASize);
    inc(APtr, ASize);
  end;
var LPtr: Pointer;
begin
  inherited Create;
  fMethodRef := AMethod;
  fSelfRef   := ASelfRef;
  //erstellt folgende Funktion im speicher
  {
  function LTmpProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LRESULT; stdcall;
  type
    TObjWndProc = function(Self: Pointer; wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LResult;
  var LObjProc: TObjWndProc;
      LSelfRef: Pointer;
  begin
    LObjProc := [ASELF];
    LSelfRef := [AProc];
    result := LObjProc(LSelfRef, wnd, uMsg, wp, lp);
  end;
  }
  LPtr := VirtualAlloc(nil, 4096, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  fAllocedMem := LPtr;
  //Begin
  LWrite($55, LPtr, 1);
  LWrite($EC8B, LPtr, 2);
  LWrite($53, LPtr, 1);
  //LObjProc zuweisen
  LWrite($B8, LPtr, 1);
  LWrite(Integer(@fMethodRef), LPtr, 4);
  //LSelfProc zuwiesen
  LWrite($BA, LPtr, 1);
  LWrite(Integer(fSelfRef), LPtr, 4);
  //Aufruf
  LWrite($104D8B, LPtr, 3);
  LWrite($51, LPtr, 1);
  LWrite($144D8B, LPtr, 3);
  LWrite($51, LPtr, 1);
  LWrite($D88B, LPtr, 2);
  LWrite($0C4D8B, LPtr, 3);
  LWrite($C28B, LPtr, 2);
  LWrite($08558B, LPtr, 3);
  LWrite($D3FF, LPtr, 2);
 
  //end
  LWrite($5B, LPtr, 1);
  LWrite($5D, LPtr, 1);
  LWrite($0010C2, LPtr, 3);
  LWrite($90, LPtr, 1);
end;
 
{==============================================================================}
 
destructor TNonVCLMsgProcObj.Destroy;
begin
  VirtualFree(fAllocedMem, 0, MEM_RELEASE);
  inherited Destroy;
end;
 
{==============================================================================}
 
procedure TNonVCLMsgProcObj.FSetMethodRef(ARef: TObjWndProc);
var LAddr: Pointer;
begin
  if @fMethodRef <> @ARef then
  begin
    fMethodRef := ARef;
    LAddr := Pointer(fAllocedMem + 5);
    move(Pointer(Pointer(@fMethodRef))^, LAddr^, 4);
  end;
end;
 
{==============================================================================}
 
procedure TNonVCLMsgProcObj.FSetSelfRef(ARef: TObject);
var LAddr: Pointer;
begin
  if @fSelfRef <> @ARef then
  begin
    fSelfRef := ARef;
    LAddr := Pointer(fAllocedMem + 10);
    move(Pointer(@fSelfRef)^, LAddr^, 4);
  end;
end;
 
{ TstMainWindow }
 
function TstMainWindow.FWndProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM
  ): LResult; stdcall;
begin
  FWndProc := 0;
  case uMsg of
    WM_DESTROY: PostQuitMessage(0);
    else FWndProc := DefWindowProc(wnd,uMsg,wp,lp);
  end;
end;
 
procedure TstMainWindow.CreateWindow;
begin
  fMsgProcObj           := TNonVCLMsgProcObj.Create;
  fMsgProcObj.SelfRef   := Self;
  fMsgProcObj.WndMethod := TObjWndProc(@FWndProc);
  (* You use a version below XP? Sorry, wont work... *)
  if (fOSVersion.dwMajorVersion < 5) or (fOSVersion.dwMajorVersion = 5) and (fOSVersion.dwMinorVersion = 0) then
  begin
    exit;
  end;
 
  {* Set the Window Flags *}
  fWndFlags   :=  WS_POPUP or WS_THICKFRAME;
  {...}
  fWndExFlags := 0;
 
  (* Init WndClass struct *)
  ZeroMemory(@fwc, sizeof(TWndClass));
  With fwc do
  begin
    Style         := CS_HREDRAW or CS_VREDRAW;
    lpfnWndProc   := @DefWindowProcW;
    cbClsExtra    := 0;
    cbWndExtra    := 0;
    hInstance     := system.MainInstance;
    lpszMenuName  := nil;
    lpszClassName := @fwndClassName[0];
    hIcon         := LoadIcon(hInstance, MAKEINTRESOURCE(1));
    hCursor       := LoadCursor(0, IDC_ARROW);
    hbrBackground := GetSysColorBrush(COLOR_3DFACE);
  end;
 
  (* Register Window class *)
  if(RegisterClass(fwc) = 0) then exit;
 
  (* Create Window Class, but dont set size *)
  fWnd := CreateWindowEx(fWndExFlags, @fwndClassname[0], @fAppName[0],
    fWndFlags, integer(CW_USEDEFAULT), integer(CW_USEDEFAULT),
    fWindowWidth, fWindowHeight, 0, 0 , system.MainInstance, nil);
 
   if fWnd <> 0 then
    SetWindowLong(fWnd, GWL_WNDPROC, Longint(fMsgProcObj.WndProc));
 
  UpdateWindow(fwnd);
  SetForegroundWindow(fwnd);
  ShowWindow(fwnd, SW_SHOW);
end;
 
destructor TstMainWindow.Destroy;
begin
  inherited Destroy;
end;
 
constructor TstMainWindow.Create;
begin
 
end;
 
end.

Aufgerufen wird sie in einer anderen Klasse so:

Delphi-Quellcode:

{* Create the window class *}
  fMainWindow := TstMainWindow.Create;
  {* Assign some vars *}
  fMainWindow.AppName := fAppName;
  fMainWindow.wndClassName:=fAppClassName;
  fMainWindow.OSVersion := fOSVersion;
  fMainWindow.WindowHeight:=MAINWINDOWHEIGHT;
  fMainWindow.WindowWidth:=MAINWINDOWWIDTH;
  {* Finally, create Main application window *}
  fMainWindow.CreateWindow;

Starte ich das Programm über die IDE, bekomme ich den "EXTERNAL: SIGSEV" - Fehler, zusammen mit einem Assemblerfenster, das Adressen, beginnend bei 0000000, ohne Inhalt, anzeigt. Außerhalb der IDE beendet sich das Programm offensichtlich wieder, ich bekomme keinerlei Feedback.

Hat jemand von euch ne Idee, woran es liegen kann? Und vielleicht auch einen praktikablen Vorschlag, wie ich mein Ziel, ein Fenster mit Nachrichtenfunktion in einer Klasse zu verwalten, unter Lazarus/Free Pascal erreichen kann?

Bei Bedarf kann ich auch das komplette Projekt anhängen, wobei das wichtigste imho schon hier steht....

P.S.: Mein allererstes Crossposting...

[Mithrandir]

Und so gehts:

Delphi-Quellcode:

{$mode objfpc}
{$ASMMODE intel}

interface

uses
  Windows;
Type
  { TstMainWindow }

  TstMainWindow = class
    private
      {* Window Class *}
      fwc : TWndClass;
      {* Flags *}
      fWndExFlags,
      fWndFlags: DWORD;
      fWnd: HWND;
      fwndClassName: String;
      fAppName: String;
      {* Pointer to the main window callback *}
      fMainWindowProc: Pointer;
      {* Public: Height and Width *}
      fWindowHeight,
      fWindowWidth: LongInt;
      {* OS Version *}
      fOSVersion : TOSVERSIONINFO;
      {* Helpers *}
      function MakeProcInstance(M: TMethod): Pointer;
      procedure FreeProcInstance(ProcInstance: Pointer);

      function FWndProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LResult; stdcall;
    public
      property OSVersion : TOSVERSIONINFO read fOSVersion write fOSVersion;
      property wndClassName : String read fwndClassName write fwndClassName;
      property AppName : String read fAppName write fAppName;
      property WindowHeight : LongInt read fWindowHeight write fWindowHeight;
      property WindowWidth : LongInt read fWindowWidth write fWindowWidth;

      procedure CreateWindow;

      Constructor Create;
      Destructor Destroy; override;
  end;

implementation

{ TstMainWindow }

function TstMainWindow.MakeProcInstance(M: TMethod): Pointer;
begin
  // Speicher alloziieren fü 15 Byte an Code
  //GetMem(Result, 15);
  VirtualAlloc(nil, $15, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  asm
    // MOV ECX,
    MOV BYTE PTR [EAX], $B9
    MOV ECX, M.Data
    MOV DWORD PTR [EAX+$1], ECX
    // POP EDX (bisherige Rücksprungadresse nach edx)
    MOV BYTE PTR [EAX+$5], $5A
    // PUSH ECX (self als Parameter 0 anfügen)
    MOV BYTE PTR [EAX+$6], $51
    // PUSH EDX (Rücksprungadresse zurück auf den Stack)
    MOV BYTE PTR [EAX+$7], $52
    // MOV ECX, (Adresse nach ecx laden)
    MOV BYTE PTR [EAX+$8], $B9
    MOV ECX, M.Code
    MOV DWORD PTR [EAX+$9], ECX
    // JMP ECX (Sprung an den ersten abgelegten Befehl und Methode aufrufen)
    MOV BYTE PTR [EAX+$D], $FF
    MOV BYTE PTR [EAX+$E], $E1
    // hier kein Call, ansonsten würde noch eine Rücksprungadresse auf den Stack gelegt
  end;
end;

procedure TstMainWindow.FreeProcInstance(ProcInstance: Pointer);
begin
  // free memory
  VirtualFree(ProcInstance, 0, MEM_RELEASE);
  //FreeMem(ProcInstance, 15);
end;

function TstMainWindow.FWndProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM
  ): LResult; stdcall;
begin
  FWndProc := 0;
  case uMsg of
    WM_DESTROY: PostQuitMessage(0);
    else FWndProc := DefWindowProc(wnd,uMsg,wp,lp);
  end;
end;

procedure TstMainWindow.CreateWindow;
begin
  (* You use a version below XP? Sorry, wont work... *)
  if (fOSVersion.dwMajorVersion < 5) or (fOSVersion.dwMajorVersion = 5) and (fOSVersion.dwMinorVersion = 0) then
  begin
    exit;
  end;

  {* Set the Window Flags *}
  fWndFlags   :=  WS_POPUP or WS_THICKFRAME;
  {...}
  fWndExFlags := 0;

  (* Init WndClass struct *)
  ZeroMemory(@fwc, sizeof(TWndClass));
  With fwc do
  begin
    Style         := CS_HREDRAW or CS_VREDRAW;
    lpfnWndProc   := WNDPROC(fMainWindowProc);
    cbClsExtra    := 0;
    cbWndExtra    := 0;
    hInstance     := system.MainInstance;
    lpszMenuName  := nil;
    lpszClassName := @fwndClassName[0];
    hIcon         := LoadIcon(hInstance, MAKEINTRESOURCE(1));
    hCursor       := LoadCursor(0, IDC_ARROW);
    hbrBackground := GetSysColorBrush(COLOR_3DFACE);
  end;

  (* Register Window class *)
  if(RegisterClass(fwc) = 0) then exit;

  (* Create Window Class, but dont set size *)
  fWnd := CreateWindowEx(fWndExFlags, @fwndClassname[0], @fAppName[0],
    fWndFlags, integer(CW_USEDEFAULT), integer(CW_USEDEFAULT),
    fWindowWidth, fWindowHeight, 0, 0 , system.MainInstance, nil);

  UpdateWindow(fwnd);
  SetForegroundWindow(fwnd);
  ShowWindow(fwnd, SW_SHOW);
end;

destructor TstMainWindow.Destroy;
begin
  FreeProcInstance(fMainWindowProc);
  inherited Destroy;
end;

constructor TstMainWindow.Create;
var
  Method: TMethod;
begin
  Method.Code := @TstMainWindow.FWndProc;
  Method.Data := Self;
  fMainWindowProc := MakeProcInstance(Method);
end;

end.