Fenstercallback in einer Klasse [gelöst]

[Sauron]

Hi ihr,

ich habe folgendes Problem:
Ich möchte ein Programm für Windows erstellen. Dabei verzichte ich auf die LCL und mache das per Hand über die Windows-API. Dabei möchte ich aber nicht auf die Objekt-orientierte Programmierung verzichten. Dummerweise sind Funktionen und Methoden inkompatibel zueinander (versteckter SELF-Parameter). Ein Fenster benötigt aber eine Callbackfunktion, sonst wird es unmöglich, auf Nachrichten zu reagieren. Um aus einem Methodenzeiger einen Funktionszeiger zu machen, habe ich diesen Quellcode gefunden, allerdings für Delphi. Da ich ein "Umsteiger" bin, möchte ich das Programm komplett neu in Free Pascal schreiben, und damit nicht mit dem Parameter {$mode delphi} arbeiten wollen.

Ich habe mir jetzt, auf Basis des obigen, eine Klasse erstelle, die aussieht:

Code: Alles auswählen

{$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:

Code: Alles auswählen

{* 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....

//Edit: Ich war mal so frei, und habe die Frage auch bei den Kollegen drüben in der Delphi-PRAXiS gestellt... Hier.

[theo]

Das hat eigentlich mit Lazarus nicht viel zu tun.
Vielleicht hast du auf den FPC Mailing Lists mehr Glück:
http://www.freepascal.org/maillist.var

[Sauron]

Moin theo,

Schade, ich hatte gehofft, hier würden sich auch ein paar FPC-Experten herumtreiben. Bin aber deinem Hinweis nachgegangen und hab mich jetzt bei der Mailinglist eingetragen. Mal sehen, hab mit sowas noch nie gearbeitet...

Danke für den Tipp...

[Sauron]

So, manchmal reicht ein Tag Pause und ne Tass Kaff, dann gehts auch.

Dieser Code tut das Gewünschte:

Code: Alles auswählen

{$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.

"GetMem" habe ich durch "VirtualAlloc" ersetzt, denn sonst würde die "Data Execution Prevention" zuschlagen.