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