Difference between revisions of "Intuition window goes OOP(ish)"
(→Move around message handling: Add content) |
(→Dispatching messages: Add content) |
||
Line 512: | Line 512: | ||
== Dispatching messages == | == Dispatching messages == | ||
+ | |||
+ | Here is where things become a bit more interesting, as we're going to add a (IDCMP) message dispatcher to our class. | ||
+ | |||
+ | <source lang="pascal"> | ||
+ | unit IntWinClass; | ||
+ | |||
+ | {$MODE OBJFPC}{$H+} | ||
+ | |||
+ | interface | ||
+ | |||
+ | uses | ||
+ | Intuition; | ||
+ | |||
+ | type | ||
+ | TIntuitionMessageRec = record | ||
+ | MsgCode : DWord; | ||
+ | IMsg : PIntuiMessage; | ||
+ | end; | ||
+ | |||
+ | type | ||
+ | TOnCloseWindowProc = procedure(var DoClose: boolean); | ||
+ | TOnMouseMoveProc = procedure(const IMsg: PIntuiMessage); | ||
+ | TOnMouseButtonsProc = procedure(const IMsg: PIntuiMessage); | ||
+ | |||
+ | TIntuitionWindowClass = class | ||
+ | private | ||
+ | FHandle : PWindow; | ||
+ | FLeft : LongInt; | ||
+ | FTop : LongInt; | ||
+ | FWidth : LongInt; | ||
+ | FHeight : LongInt; | ||
+ | FTitle : AnsiString; | ||
+ | FStopped : boolean; | ||
+ | FOnCloseWindow : TOnCloseWindowProc; | ||
+ | FOnMouseMove : TOnMouseMoveProc; | ||
+ | FOnMouseButtons : TOnMouseButtonsProc; | ||
+ | protected | ||
+ | procedure MsgCloseWindow(var msg: TIntuitionMessageRec); Message IDCMP_CLOSEWINDOW; | ||
+ | procedure MsgMouseMove(var msg: TIntuitionMessageRec); Message IDCMP_MOUSEMOVE; | ||
+ | procedure MsgMouseButtons(var msg: TIntuitionMessageRec); Message IDCMP_MOUSEBUTTONS; | ||
+ | public // creator/destructor | ||
+ | constructor Create; | ||
+ | destructor Destroy; override; | ||
+ | public // methods | ||
+ | procedure Open; | ||
+ | procedure Close; | ||
+ | procedure HandleMessages; | ||
+ | procedure DefaultHandler(var message); override; | ||
+ | public // properties | ||
+ | property Left : LongInt read FLeft write FLeft; | ||
+ | property Top : LongInt read FTop write FTop; | ||
+ | property Width : LongInt read FWidth write FWidth; | ||
+ | property Height : LongInt read FHeight write FHeight; | ||
+ | property Title : String read FTitle write FTitle; | ||
+ | property Handle : PWindow read FHandle; | ||
+ | public // events | ||
+ | property OnCloseWindow : TOnCloseWindowProc read FOnCloseWindow write FOnCloseWindow; | ||
+ | property OnMouseMove : TOnMouseMoveProc read FOnMouseMove write FOnMouseMove; | ||
+ | property OnMouseButtons : TOnMouseButtonsProc read FOnMouseButtons write FOnMouseButtons; | ||
+ | end; | ||
+ | |||
+ | |||
+ | implementation | ||
+ | |||
+ | uses | ||
+ | SysUtils, Exec, AGraphics, InputEvent; | ||
+ | |||
+ | |||
+ | function AsTag(tag: LongWord): LongInt; inline; | ||
+ | begin | ||
+ | Result := LongInt(tag); | ||
+ | end; | ||
+ | |||
+ | |||
+ | procedure error(Const msg : string); | ||
+ | begin | ||
+ | raise exception.create(Msg) at | ||
+ | get_caller_addr(get_frame), | ||
+ | get_caller_frame(get_frame); | ||
+ | end; | ||
+ | |||
+ | |||
+ | Constructor TIntuitionWindowClass.Create; | ||
+ | begin | ||
+ | Inherited; | ||
+ | |||
+ | FHandle := nil; | ||
+ | FLeft := 10; | ||
+ | FTop := 10; | ||
+ | FHeight := 30; | ||
+ | FWidth := 30; | ||
+ | FTitle := ''; | ||
+ | FStopped := false; | ||
+ | end; | ||
+ | |||
+ | |||
+ | Destructor TIntuitionWindowClass.Destroy; | ||
+ | begin | ||
+ | inherited; | ||
+ | end; | ||
+ | |||
+ | |||
+ | procedure TIntuitionWindowClass.Open; | ||
+ | var | ||
+ | aTitle : PChar; | ||
+ | begin | ||
+ | if FTitle <> '' then aTitle := PChar(FTitle) else aTitle := nil; | ||
+ | |||
+ | FHandle := OpenWindowTags( nil, | ||
+ | [ | ||
+ | AsTag(WA_Left) , FLeft, | ||
+ | AsTag(WA_Top) , FTop, | ||
+ | AsTag(WA_Width) , FWidth, | ||
+ | AsTag(WA_Height) , FHeight, | ||
+ | AsTag(WA_Title) , aTitle, | ||
+ | // Non use settable flags (for now) | ||
+ | AsTag(WA_Flags) , AsTag(WFLG_CLOSEGADGET or WFLG_DRAGBAR or WFLG_DEPTHGADGET or WFLG_ACTIVATE or WFLG_GIMMEZEROZERO or WFLG_NOCAREREFRESH or WFLG_RMBTRAP or WFLG_REPORTMOUSE), | ||
+ | AsTag(WA_IDCMP) , AsTag(IDCMP_CLOSEWINDOW or IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS), | ||
+ | TAG_END | ||
+ | ]); | ||
+ | if not Assigned(FHandle) then Error('Unable to Open Window'); | ||
+ | end; | ||
+ | |||
+ | |||
+ | procedure TIntuitionWindowClass.Close; | ||
+ | begin | ||
+ | if Assigned(FHandle) | ||
+ | then Intuition.CloseWindow(FHandle) | ||
+ | else Error('Unable to Close Window because the handle is invalid'); | ||
+ | end; | ||
+ | |||
+ | |||
+ | procedure TIntuitionWindowClass.HandleMessages; | ||
+ | var | ||
+ | msg : PIntuiMessage; | ||
+ | msgrec : TIntuitionMessageRec; | ||
+ | begin | ||
+ | while not FStopped do | ||
+ | begin | ||
+ | WaitPort(FHandle^.UserPort); | ||
+ | |||
+ | while true do | ||
+ | begin | ||
+ | msg := PIntuiMessage(GetMsg(FHandle^.UserPort)); | ||
+ | if not Assigned(msg) then break; | ||
+ | |||
+ | // WriteLn('ReplyMsg'); | ||
+ | ReplyMsg(pMessage(msg)); | ||
+ | // WriteLn('Dispatch'); | ||
+ | MsgRec.MsgCode := msg^.IClass; | ||
+ | MsgRec.IMsg := msg; | ||
+ | Dispatch(msgrec); | ||
+ | end; | ||
+ | end; | ||
+ | end; | ||
+ | |||
+ | |||
+ | (* | ||
+ | http://www.freepascal.org/docs-html/rtl/system/tobject.defaulthandler.html | ||
+ | DefaultHandler is the default handler for messages. If a message has an | ||
+ | unknown message ID (i.e. does not appear in the table with integer message | ||
+ | handlers), then it will be passed to DefaultHandler by the Dispatch method. | ||
+ | *) | ||
+ | |||
+ | (* | ||
+ | http://www.freepascal.org/docs-html/rtl/system/tobject.dispatch.html | ||
+ | Dispatch looks in the message handler table for a handler that handles | ||
+ | message. The message is identified by the first dword (cardinal) in the | ||
+ | message structure. | ||
+ | |||
+ | If no matching message handler is found, the message is passed to the | ||
+ | DefaultHandler method, which can be overridden by descendent classes to add | ||
+ | custom handling of messages. | ||
+ | *) | ||
+ | procedure TIntuitionWindowClass.DefaultHandler(var message); | ||
+ | begin | ||
+ | WriteLn('invoked default handler'); | ||
+ | end; | ||
+ | |||
+ | |||
+ | procedure TIntuitionWindowClass.MsgCloseWindow(var msg: TIntuitionMessageRec); | ||
+ | var | ||
+ | DoClose: boolean = true; | ||
+ | begin | ||
+ | WriteLn('IDCMP_CLOSEWINDOW message received'); | ||
+ | |||
+ | if Assigned(FOnCloseWindow) then FOnCloseWindow(DoClose); | ||
+ | FStopped := DoClose; | ||
+ | end; | ||
+ | |||
+ | |||
+ | procedure TIntuitionWindowClass.MsgMouseMove(var msg: TIntuitionMessageRec); | ||
+ | begin | ||
+ | WriteLn('IDCMP_MOUSEMOVE message received'); | ||
+ | |||
+ | if assigned(FOnMouseMove) then FOnMouseMove(msg.IMsg); | ||
+ | end; | ||
+ | |||
+ | |||
+ | procedure TIntuitionWindowClass.MsgMouseButtons(var msg: TIntuitionMessageRec); | ||
+ | begin | ||
+ | WriteLn('IDCMP_MOUSEBUTTONS message received'); | ||
+ | if Assigned(FOnMouseButtons) then FOnMouseButtons(msg.Imsg); | ||
+ | end; | ||
+ | |||
+ | end. | ||
+ | |||
+ | </source> | ||
+ | |||
+ | Looks difficult perhaps but, it actually isn't. | ||
+ | |||
+ | First we needed to add a new structure TIntuitionMessageRec that follows the Free Pascal Dispatch message, and at the same time can hold our intuition message information. | ||
+ | |||
+ | Then we've defined 3 new event procedures that act as type-casts for the events. The events FOnCloseWindow, FOnMouseMove | ||
+ | and FOnMouseButtons are added to our private variables. | ||
+ | |||
+ | We override the DefaultHandler that is standard part of TObject so that we can give some feedback to the suer in case none of our message is intercepted correctly (and the default handler is invoked) | ||
+ | |||
+ | Finally we adjust our HandleMessages method to call the TObject dispatcher. | ||
+ | |||
+ | It might be a surprise, but there is nothing changed inside our main program. For the sake of completeness we post the code. | ||
+ | |||
+ | <source lang="pascal"> | ||
+ | |||
+ | {$MODE OBJFPC}{$H+} | ||
+ | |||
+ | uses | ||
+ | IntWinClass, Exec, AGraphics, Intuition, InputEvent; | ||
+ | |||
+ | //*-------------------------------------------------------------------------*/ | ||
+ | //* Main routine */ | ||
+ | //*-------------------------------------------------------------------------*/ | ||
+ | |||
+ | function main: integer; | ||
+ | var | ||
+ | Window1 : TIntuitionWindowClass; | ||
+ | begin | ||
+ | Window1 := TIntuitionWindowClass.Create; | ||
+ | Window1.Left := 10; | ||
+ | Window1.Top := 20; | ||
+ | Window1.Height := 200; | ||
+ | Window1.Width := 320; | ||
+ | Window1.Title := 'This is window 1'; | ||
+ | Window1.Open; | ||
+ | |||
+ | Window1.HandleMessages; | ||
+ | |||
+ | Window1.Close; | ||
+ | Window1.Free; | ||
+ | |||
+ | result := (0); | ||
+ | end; | ||
+ | |||
+ | begin | ||
+ | ExitCode := Main; | ||
+ | end. | ||
+ | </source> | ||
== Implement message handlers == | == Implement message handlers == |
Revision as of 20:58, 27 March 2017
A long while ago, someone on the aros-exec forums suggested to use some (more) OOP to create f.i. native Intuition Windows.
Although i already knew it is possible to do, i never managed to create a example for those wanting to have a look. So here we go :-)
Do note however, that the code showed herein is not complete, nor does it show good programing practice (even far from that). It is merely shown as a possible solution to the problem. Much more abstraction is required in order to be able to make practical use of these examples.
The beginning
Let's start out with a simple intuition window example, this example was taken from Thomas Rapp.
program SimpleWindow;
{$MODE OBJFPC}{$H+}
Uses
Exec, AGraphics, Intuition, InputEvent, Utility;
Function AsTag(tag: LongWord): LongInt; inline;
begin
Result := LongInt(tag);
end;
//*-------------------------------------------------------------------------*/
//* */
//*-------------------------------------------------------------------------*/
procedure print_text(rp: PRastPort; x: LongInt; y: LongInt; txt: PChar);
begin
GfxMove(rp, x, y);
SetABPenDrMd(rp, 1, 0, JAM2);
GfxText(rp, txt, strlen(txt));
ClearEOL(rp);
end;
//*-------------------------------------------------------------------------*/
//* Main routine */
//*-------------------------------------------------------------------------*/
function main: integer;
var
win : PWindow;
cont : Boolean;
msg : PIntuiMessage;
buffer : String[80];
begin
win := OpenWindowTags( nil,
[
AsTag(WA_Left) , 100,
AsTag(WA_Top) , 100,
AsTag(WA_Width) , 250,
AsTag(WA_Height) , 150,
AsTag(WA_Flags) , AsTag(WFLG_CLOSEGADGET or WFLG_DRAGBAR or WFLG_DEPTHGADGET or WFLG_ACTIVATE or WFLG_GIMMEZEROZERO or WFLG_NOCAREREFRESH or WFLG_RMBTRAP or WFLG_REPORTMOUSE),
AsTag(WA_IDCMP) , AsTag(IDCMP_CLOSEWINDOW or IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS),
TAG_END
]);
if Assigned(win) then
begin
cont := TRUE;
while (cont) do
begin
WaitPort(win^.UserPort);
while true do
begin
msg := PIntuiMessage(GetMsg(win^.UserPort));
if not Assigned(msg) then break;
case (msg^.IClass) of
IDCMP_CLOSEWINDOW:
cont := FALSE;
IDCMP_MOUSEMOVE:
begin
WriteStr(buffer, 'Mouseposition: x=', msg^.MouseX, ' y=', msg^.MouseY, #0);
print_text(win^.RPort, 10, 30, @buffer[1]);
end;
IDCMP_MOUSEBUTTONS:
case (msg^.Code) of
IECODE_LBUTTON : print_text(win^.RPort, 10, 60, 'Left mousebutton pressed');
IECODE_LBUTTON or IECODE_UP_PREFIX : print_text(win^.RPort, 10, 60, 'Left mousebutton released');
IECODE_RBUTTON : print_text(win^.RPort, 10, 90, 'Right mousebutton pressed');
IECODE_RBUTTON or IECODE_UP_PREFIX : print_text(win^.RPort, 10, 90, 'Right mousebutton released');
end;
end; // case
ReplyMsg(pMessage(msg));
end;
end; // while
CloseWindow(win);
end;
result := (0);
end;
begin
ExitCode := Main;
end.
The code itself doesn't do anything difficult to understand. It opens a Intuition Window and reacts to some IDCMP messages and based on those messages give some feedback to the user.
We need a class
Now that we have seen what properties are part of the window we can create a class based on that. We put the class in a separate unit.
unit IntWinClass;
{$MODE OBJFPC}{$H+}
interface
uses
Intuition;
type
TIntuitionWindowClass = class
private
FHandle : PWindow;
FLeft : LongInt;
FTop : LongInt;
FWidth : LongInt;
FHeight : LongInt;
FTitle : String;
protected
public
Constructor Create;
Destructor Destroy; override;
public
procedure Open;
procedure Close;
public
property Left : LongInt read FLeft write FLeft;
property Top : LongInt read FTop write FTop;
property Width : LongInt read FWidth write FWidth;
property Height: LongInt read FHeight write FHeight;
property Title : String read FTitle write FTitle;
property Handle : PWindow read FHandle;
end;
implementation
uses
SysUtils;
Function AsTag(tag: LongWord): LongInt; inline;
begin
Result := LongInt(tag);
end;
procedure error(Const msg : string);
begin
raise exception.create(Msg) at
get_caller_addr(get_frame),
get_caller_frame(get_frame);
end;
Constructor TIntuitionWindowClass.Create;
begin
Inherited;
FHandle := nil;
FLeft := 10;
FTop := 10;
FHeight := 30;
FWidth := 30;
FTitle := '';
end;
Destructor TIntuitionWindowClass.Destroy;
begin
inherited;
end;
procedure TIntuitionWindowClass.Open;
begin
FHandle := OpenWindowTags( nil,
[
AsTag(WA_Left) , FLeft,
AsTag(WA_Top) , FTop,
AsTag(WA_Width) , FWidth,
AsTag(WA_Height) , FHeight,
AsTag(WA_Title) , PChar(FTitle),
// Non use settable flags (for now)
AsTag(WA_Flags) , AsTag(WFLG_CLOSEGADGET or WFLG_DRAGBAR or WFLG_DEPTHGADGET or WFLG_ACTIVATE or WFLG_GIMMEZEROZERO or WFLG_NOCAREREFRESH or WFLG_RMBTRAP or WFLG_REPORTMOUSE),
AsTag(WA_IDCMP) , AsTag(IDCMP_CLOSEWINDOW or IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS),
TAG_END
]);
if not Assigned(FHandle) then Error('Unable to Open Window');
end;
procedure TIntuitionWindowClass.Close;
begin
if Assigned(FHandle)
then CloseWindow(FHandle)
else Error('Unable to Close Window because the handle is invalid');
end;
end.
We've added a constructor (Create) which initializes some default values for the FHandle and private window dimension variables as well as clear the private title variable.
Other then that we've added two methods, one to Open the Intuition Window and one to Close the Intuition Window and added code that actually perform these actions.
Now, we're going to make use of this new class and create a new program:
program ClassWindow;
{$MODE OBJFPC}{$H+}
uses
IntWinClass, Exec, AGraphics, Intuition, InputEvent;
//*-------------------------------------------------------------------------*/
//* */
//*-------------------------------------------------------------------------*/
procedure print_text(rp: PRastPort; x: LongInt; y: LongInt; txt: PChar);
begin
GfxMove(rp, x, y);
SetABPenDrMd(rp, 1, 0, JAM2);
GfxText(rp, txt, strlen(txt));
ClearEOL(rp);
end;
//*-------------------------------------------------------------------------*/
//* Main routine */
//*-------------------------------------------------------------------------*/
function main: integer;
var
Window1 : TIntuitionWindowClass;
cont : Boolean;
msg : PIntuiMessage;
buffer : String[80];
begin
Window1 := TIntuitionWindowClass.Create;
Window1.Left := 10;
Window1.Top := 20;
Window1.Height := 200;
Window1.Width := 320;
Window1.Title := 'This is window 1';
Window1.Open;
WaitPort(Window1.Handle^.UserPort);
cont := TRUE;
while (cont) do
begin
while true do
begin
msg := PIntuiMessage(GetMsg(Window1.Handle^.UserPort));
if not Assigned(msg) then break;
case (msg^.IClass) of
IDCMP_CLOSEWINDOW:
cont := FALSE;
IDCMP_MOUSEMOVE:
begin
WriteStr(buffer, 'Mouseposition: x=', msg^.MouseX, ' y=', msg^.MouseY, #0);
print_text(Window1.Handle^.RPort, 10, 30, @buffer[1]);
end;
IDCMP_MOUSEBUTTONS:
case (msg^.Code) of
IECODE_LBUTTON : print_text(Window1.Handle^.RPort, 10, 60, 'Left mousebutton pressed');
IECODE_LBUTTON or IECODE_UP_PREFIX : print_text(Window1.Handle^.RPort, 10, 60, 'Left mousebutton released');
IECODE_RBUTTON : print_text(Window1.Handle^.RPort, 10, 90, 'Right mousebutton pressed');
IECODE_RBUTTON or IECODE_UP_PREFIX : print_text(Window1.Handle^.RPort, 10, 90, 'Right mousebutton released');
end;
end; // case
ReplyMsg(pMessage(msg));
end;
end;
Window1.Close;
Window1.Free;
result := (0);
end;
begin
ExitCode := Main;
end.
Also here, no real rocket science. We have to take care of Creating and Destroying our class and we've replaced the 'normal' code that opened and closed the intuition Window by calling the Methods that we've just implemented. The message handling itself is still part of our main program.
Move around message handling
We're going to add to our class again, by moving the message handling from our main program to our class.
unit IntWinClass;
{$MODE OBJFPC}{$H+}
interface
uses
Intuition;
type
TIntuitionWindowClass = class
private
FHandle : PWindow;
FLeft : LongInt;
FTop : LongInt;
FWidth : LongInt;
FHeight : LongInt;
FTitle : AnsiString;
protected
public
Constructor Create;
Destructor Destroy; override;
public
procedure Open;
procedure Close;
procedure HandleMessages;
public
property Left : LongInt read FLeft write FLeft;
property Top : LongInt read FTop write FTop;
property Width : LongInt read FWidth write FWidth;
property Height: LongInt read FHeight write FHeight;
property Title : String read FTitle write FTitle;
property Handle : PWindow read FHandle;
end;
implementation
uses
SysUtils, Exec, AGraphics, InputEvent;
Function AsTag(tag: LongWord): LongInt; inline;
begin
Result := LongInt(tag);
end;
procedure error(Const msg : string);
begin
raise exception.create(Msg) at
get_caller_addr(get_frame),
get_caller_frame(get_frame);
end;
Constructor TIntuitionWindowClass.Create;
begin
Inherited;
FHandle := nil;
FLeft := 10;
FTop := 10;
FHeight := 30;
FWidth := 30;
FTitle := '';
end;
Destructor TIntuitionWindowClass.Destroy;
begin
inherited;
end;
procedure TIntuitionWindowClass.Open;
var
aTitle : PChar;
begin
if FTitle <> '' then aTitle := PChar(FTitle) else aTitle := nil;
FHandle := OpenWindowTags( nil,
[
AsTag(WA_Left) , FLeft,
AsTag(WA_Top) , FTop,
AsTag(WA_Width) , FWidth,
AsTag(WA_Height) , FHeight,
AsTag(WA_Title) , aTitle,
// Non use settable flags (for now)
AsTag(WA_Flags) , AsTag(WFLG_CLOSEGADGET or WFLG_DRAGBAR or WFLG_DEPTHGADGET or WFLG_ACTIVATE or WFLG_GIMMEZEROZERO or WFLG_NOCAREREFRESH or WFLG_RMBTRAP or WFLG_REPORTMOUSE),
AsTag(WA_IDCMP) , AsTag(IDCMP_CLOSEWINDOW or IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS),
TAG_END
]);
if not Assigned(FHandle) then Error('Unable to Open Window');
end;
procedure TIntuitionWindowClass.Close;
begin
if Assigned(FHandle)
then CloseWindow(FHandle)
else Error('Unable to Close Window because the handle is invalid');
end;
procedure print_text(rp: PRastPort; x: LongInt; y: LongInt; txt: PChar);
begin
GfxMove(rp, x, y);
SetABPenDrMd(rp, 1, 0, JAM2);
GfxText(rp, txt, strlen(txt));
ClearEOL(rp);
end;
procedure TIntuitionWindowClass.HandleMessages;
var
cont : Boolean;
msg : PIntuiMessage;
buffer : String[80];
begin
cont := TRUE;
while (cont) do
begin
WaitPort(FHandle^.UserPort);
while true do
begin
msg := PIntuiMessage(GetMsg(FHandle^.UserPort));
if not Assigned(msg) then break;
case (msg^.IClass) of
IDCMP_CLOSEWINDOW:
cont := FALSE;
IDCMP_MOUSEMOVE:
begin
WriteStr(buffer, 'Mouseposition: x=', msg^.MouseX, ' y=', msg^.MouseY, #0);
print_text(FHandle^.RPort, 10, 30, @buffer[1]);
end;
IDCMP_MOUSEBUTTONS:
case (msg^.Code) of
IECODE_LBUTTON : print_text(FHandle^.RPort, 10, 60, 'Left mousebutton pressed');
IECODE_LBUTTON or IECODE_UP_PREFIX : print_text(FHandle^.RPort, 10, 60, 'Left mousebutton released');
IECODE_RBUTTON : print_text(FHandle^.RPort, 10, 90, 'Right mousebutton pressed');
IECODE_RBUTTON or IECODE_UP_PREFIX : print_text(FHandle^.RPort, 10, 90, 'Right mousebutton released');
end;
end; // case
ReplyMsg(pMessage(msg));
end;
end;
end;
end.
The message handling is performed by our newly added method HandleMessages and as you can see the code is literally the code that was used in the main program before.
Now we have to make our main program make use of this new method.
program ClassWindow;
{$MODE OBJFPC}{$H+}
uses
IntWinClass, Exec, AGraphics, Intuition, InputEvent;
//*-------------------------------------------------------------------------*/
//* */
//*-------------------------------------------------------------------------*/
//*-------------------------------------------------------------------------*/
//* Main routine */
//*-------------------------------------------------------------------------*/
function main: integer;
var
Window1 : TIntuitionWindowClass;
begin
Window1 := TIntuitionWindowClass.Create;
Window1.Left := 10;
Window1.Top := 20;
Window1.Height := 200;
Window1.Width := 320;
Window1.Title := 'This is window 1';
Window1.Open;
Window1.HandleMessages;
Window1.Close;
Window1.Free;
result := (0);
end;
begin
ExitCode := Main;
end.
Easy enough, and things still work. A bit awkward perhaps, but it works (for this one window).
Dispatching messages
Here is where things become a bit more interesting, as we're going to add a (IDCMP) message dispatcher to our class.
unit IntWinClass;
{$MODE OBJFPC}{$H+}
interface
uses
Intuition;
type
TIntuitionMessageRec = record
MsgCode : DWord;
IMsg : PIntuiMessage;
end;
type
TOnCloseWindowProc = procedure(var DoClose: boolean);
TOnMouseMoveProc = procedure(const IMsg: PIntuiMessage);
TOnMouseButtonsProc = procedure(const IMsg: PIntuiMessage);
TIntuitionWindowClass = class
private
FHandle : PWindow;
FLeft : LongInt;
FTop : LongInt;
FWidth : LongInt;
FHeight : LongInt;
FTitle : AnsiString;
FStopped : boolean;
FOnCloseWindow : TOnCloseWindowProc;
FOnMouseMove : TOnMouseMoveProc;
FOnMouseButtons : TOnMouseButtonsProc;
protected
procedure MsgCloseWindow(var msg: TIntuitionMessageRec); Message IDCMP_CLOSEWINDOW;
procedure MsgMouseMove(var msg: TIntuitionMessageRec); Message IDCMP_MOUSEMOVE;
procedure MsgMouseButtons(var msg: TIntuitionMessageRec); Message IDCMP_MOUSEBUTTONS;
public // creator/destructor
constructor Create;
destructor Destroy; override;
public // methods
procedure Open;
procedure Close;
procedure HandleMessages;
procedure DefaultHandler(var message); override;
public // properties
property Left : LongInt read FLeft write FLeft;
property Top : LongInt read FTop write FTop;
property Width : LongInt read FWidth write FWidth;
property Height : LongInt read FHeight write FHeight;
property Title : String read FTitle write FTitle;
property Handle : PWindow read FHandle;
public // events
property OnCloseWindow : TOnCloseWindowProc read FOnCloseWindow write FOnCloseWindow;
property OnMouseMove : TOnMouseMoveProc read FOnMouseMove write FOnMouseMove;
property OnMouseButtons : TOnMouseButtonsProc read FOnMouseButtons write FOnMouseButtons;
end;
implementation
uses
SysUtils, Exec, AGraphics, InputEvent;
function AsTag(tag: LongWord): LongInt; inline;
begin
Result := LongInt(tag);
end;
procedure error(Const msg : string);
begin
raise exception.create(Msg) at
get_caller_addr(get_frame),
get_caller_frame(get_frame);
end;
Constructor TIntuitionWindowClass.Create;
begin
Inherited;
FHandle := nil;
FLeft := 10;
FTop := 10;
FHeight := 30;
FWidth := 30;
FTitle := '';
FStopped := false;
end;
Destructor TIntuitionWindowClass.Destroy;
begin
inherited;
end;
procedure TIntuitionWindowClass.Open;
var
aTitle : PChar;
begin
if FTitle <> '' then aTitle := PChar(FTitle) else aTitle := nil;
FHandle := OpenWindowTags( nil,
[
AsTag(WA_Left) , FLeft,
AsTag(WA_Top) , FTop,
AsTag(WA_Width) , FWidth,
AsTag(WA_Height) , FHeight,
AsTag(WA_Title) , aTitle,
// Non use settable flags (for now)
AsTag(WA_Flags) , AsTag(WFLG_CLOSEGADGET or WFLG_DRAGBAR or WFLG_DEPTHGADGET or WFLG_ACTIVATE or WFLG_GIMMEZEROZERO or WFLG_NOCAREREFRESH or WFLG_RMBTRAP or WFLG_REPORTMOUSE),
AsTag(WA_IDCMP) , AsTag(IDCMP_CLOSEWINDOW or IDCMP_MOUSEMOVE or IDCMP_MOUSEBUTTONS),
TAG_END
]);
if not Assigned(FHandle) then Error('Unable to Open Window');
end;
procedure TIntuitionWindowClass.Close;
begin
if Assigned(FHandle)
then Intuition.CloseWindow(FHandle)
else Error('Unable to Close Window because the handle is invalid');
end;
procedure TIntuitionWindowClass.HandleMessages;
var
msg : PIntuiMessage;
msgrec : TIntuitionMessageRec;
begin
while not FStopped do
begin
WaitPort(FHandle^.UserPort);
while true do
begin
msg := PIntuiMessage(GetMsg(FHandle^.UserPort));
if not Assigned(msg) then break;
// WriteLn('ReplyMsg');
ReplyMsg(pMessage(msg));
// WriteLn('Dispatch');
MsgRec.MsgCode := msg^.IClass;
MsgRec.IMsg := msg;
Dispatch(msgrec);
end;
end;
end;
(*
http://www.freepascal.org/docs-html/rtl/system/tobject.defaulthandler.html
DefaultHandler is the default handler for messages. If a message has an
unknown message ID (i.e. does not appear in the table with integer message
handlers), then it will be passed to DefaultHandler by the Dispatch method.
*)
(*
http://www.freepascal.org/docs-html/rtl/system/tobject.dispatch.html
Dispatch looks in the message handler table for a handler that handles
message. The message is identified by the first dword (cardinal) in the
message structure.
If no matching message handler is found, the message is passed to the
DefaultHandler method, which can be overridden by descendent classes to add
custom handling of messages.
*)
procedure TIntuitionWindowClass.DefaultHandler(var message);
begin
WriteLn('invoked default handler');
end;
procedure TIntuitionWindowClass.MsgCloseWindow(var msg: TIntuitionMessageRec);
var
DoClose: boolean = true;
begin
WriteLn('IDCMP_CLOSEWINDOW message received');
if Assigned(FOnCloseWindow) then FOnCloseWindow(DoClose);
FStopped := DoClose;
end;
procedure TIntuitionWindowClass.MsgMouseMove(var msg: TIntuitionMessageRec);
begin
WriteLn('IDCMP_MOUSEMOVE message received');
if assigned(FOnMouseMove) then FOnMouseMove(msg.IMsg);
end;
procedure TIntuitionWindowClass.MsgMouseButtons(var msg: TIntuitionMessageRec);
begin
WriteLn('IDCMP_MOUSEBUTTONS message received');
if Assigned(FOnMouseButtons) then FOnMouseButtons(msg.Imsg);
end;
end.
Looks difficult perhaps but, it actually isn't.
First we needed to add a new structure TIntuitionMessageRec that follows the Free Pascal Dispatch message, and at the same time can hold our intuition message information.
Then we've defined 3 new event procedures that act as type-casts for the events. The events FOnCloseWindow, FOnMouseMove and FOnMouseButtons are added to our private variables.
We override the DefaultHandler that is standard part of TObject so that we can give some feedback to the suer in case none of our message is intercepted correctly (and the default handler is invoked)
Finally we adjust our HandleMessages method to call the TObject dispatcher.
It might be a surprise, but there is nothing changed inside our main program. For the sake of completeness we post the code.
{$MODE OBJFPC}{$H+}
uses
IntWinClass, Exec, AGraphics, Intuition, InputEvent;
//*-------------------------------------------------------------------------*/
//* Main routine */
//*-------------------------------------------------------------------------*/
function main: integer;
var
Window1 : TIntuitionWindowClass;
begin
Window1 := TIntuitionWindowClass.Create;
Window1.Left := 10;
Window1.Top := 20;
Window1.Height := 200;
Window1.Width := 320;
Window1.Title := 'This is window 1';
Window1.Open;
Window1.HandleMessages;
Window1.Close;
Window1.Free;
result := (0);
end;
begin
ExitCode := Main;
end.