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

zusammenfalten · markieren

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:

markieren

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:

zusammenfalten · markieren

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.

[FreePascal] Fenstercallback in einer Klasse

[FreePascal] Fenstercallback in einer Klasse

Re: [FreePascal] Fenstercallback in einer Klasse

Forumregeln