paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-30 15:00:16 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ system messages unit added

Browse Source
This commit is contained in:
pierre 2002-05-21 11:59:57 +00:00
parent d9027c7e63
commit ecf9c55c76
8 changed files with 880 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
fv/go32smsg.inc Normal file
View File

@ -0,0 +1,100 @@
{
$Id$
System independent system interface for go32v2
Copyright (c) 2000 by Pierre Muller
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
Const
SystemEventActive : Boolean = false;
procedure InitSystemMsg;
var
res : word;
begin
if SystemEventActive then
exit;
{ enable close }
asm
movl $0x168f,%eax
movl $1,%edx
int $0x2f
movw %ax,Res
end;
SystemEventActive:=(Res=0);
end;
procedure DoneSystemMsg;
begin
if not SystemEventActive then
exit;
{ disable close }
asm
movl $0x168f,%eax
movl $0,%edx
int $0x2f
end;
SystemEventActive:=false;
end;
procedure GetSystemEvent(var SystemEvent: TSystemEvent);
begin
PollSystemEvent(SystemEvent);
end;
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
var
CloseState : word;
begin
SystemEvent.typ:=SysNothing;
if not SystemEventActive then
exit(false);
{ Query close }
asm
movl $0x168f,%eax
movl $100,%edx
int $0x2f
movw %ax,CloseState
end;
if (CloseState = 0) then
begin
{ acknowledge Close }
asm
movl $0x168f,%eax
movl $200,%edx
int $0x2f
movw %ax,CloseState
end;
{ non zero means error ! }
if CloseState=0 then
begin
PollSystemEvent:=true;
SystemEvent.typ:=SysClose;
end;
end;
end;
{
$Log$
Revision 1.1 2002-05-21 11:59:57 pierre
+ system messages unit added
}

127
fv/sysmsg.pas Normal file
View File

@ -0,0 +1,127 @@
{
$Id$
Unit to handle system events
Copyright 2000 by Pierre Muller <muller@ics.u-strasbg.fr>
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************}
Unit sysmsg;
interface
type
TSystemMessage = (
SysNothing,
SysSetFocus,
SysReleaseFocus,
SysClose,
SysResize );
TSystemEvent = Record
case typ : TSystemMessage of
SysClose : ( CloseTyp : Longint);
SysResize : (X,Y : Longint);
end;
PSystemEvent = ^TSystemEvent;
const
SystemEventBufSize = 16;
var
PendingSystemEvent : array[0..SystemEventBufSize-1] of TSystemEvent;
PendingSystemHead,
PendingSystemTail : PSystemEvent;
PendingSystemEvents : byte;
LastSystemEvent : TSystemEvent;
procedure InitSystemMsg;
procedure DoneSystemMsg;
procedure GetSystemEvent(var SystemEvent:TSystemEvent);
{ Returns the last SystemEvent, and waits for one if not available }
procedure PutSystemEvent(const SystemEvent: TSystemEvent);
{ Adds the given SystemEvent to the input queue. }
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
{ Checks if a SystemEvent is available, and returns it if one is found. If no
event is pending, it returns 0 }
implementation
{$undef HAS_SYSMSG}
{$ifdef go32v2}
{$i go32smsg.inc}
{$define HAS_SYSMSG}
{$endif go32v2}
{$ifdef win32}
{$i w32smsg.inc}
{$define HAS_SYSMSG}
{$endif win32}
{$ifdef unix}
{$i unixsmsg.inc}
{$define HAS_SYSMSG}
{$endif unix}
{$ifndef HAS_SYSMSG}
procedure InitSystemMsg;
begin
end;
procedure DoneSystemMsg;
begin
end;
procedure GetSystemEvent(var SystemEvent:TSystemEvent);
begin
FillChar(SystemEvent,SizeOf(SystemEvent),#0);
end;
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
begin
FillChar(SystemEvent,SizeOf(SystemEvent),#0);
PollSystemEvent:=false;
end;
{$endif not HAS_SYSMSG}
procedure PutSystemEvent(const SystemEvent: TSystemEvent);
begin
if PendingSystemEvents<SystemEventBufSize then
begin
PendingSystemTail^:=SystemEvent;
inc(PendingSystemTail);
if longint(PendingSystemTail)=longint(@PendingSystemEvent)+sizeof(PendingSystemEvent) then
PendingSystemTail:=@PendingSystemEvent;
inc(PendingSystemEvents);
end;
end;
end.
{
$Log$
Revision 1.1 2002-05-21 11:59:57 pierre
+ system messages unit added
}

68
fv/unixsmsg.inc Normal file
View File

@ -0,0 +1,68 @@
{
$Id$
System dependent system messages for unix
Copyright (c) 2002 by Pierre Muller
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
{ This file is still a dummy,
it should use ioctl to get information about resizing of windows }
Const
SystemEventActive : Boolean = false;
procedure InitSystemMsg;
begin
If SystemEventActive then
exit;
{ Code to enable size tracking should go here }
SystemEventActive:=true;
end;
procedure DoneSystemMsg;
begin
if not SystemEventActive then
exit;
{ Code to disable size tracking should go here }
SystemEventActive:=false;
end;
procedure GetSystemEvent(var SystemEvent: TSystemEvent);
begin
PollSystemEvent(SystemEvent);
end;
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
var
CloseState : word;
begin
SystemEvent.typ:=SysNothing;
if not SystemEventActive then
exit(false);
PollSystemEvent:=false;
end;
{
$Log$
Revision 1.1 2002-05-21 11:59:57 pierre
+ system messages unit added
}

145
fv/w32smsg.inc Normal file
View File

@ -0,0 +1,145 @@
{
$Id$
System independent system interface for win32
Copyright (c) 2000 by Pierre Muller
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
uses
windows,dos,winevent;
var
ChangeSystemEvents : TCriticalSection;
Const
SystemEventActive : Boolean = false;
procedure SystemEventHandler(var ir:INPUT_RECORD);
var
e : TSystemEvent;
begin
if (ir.EventType in [FOCUS_EVENT,WINDOW_BUFFER_SIZE_EVENT]) then
begin
EnterCriticalSection(ChangeSystemEvents);
if (ir.EventType=FOCUS_EVENT) then
begin
if ir.Event.FocusEvent.bSetFocus then
e.typ:=SysSetFocus
else
e.typ:=SysReleaseFocus;
end
else
begin
e.typ:=SysResize;
e.x:=ir.Event.WindowBufferSizeEvent.dwSize.x;
e.y:=ir.Event.WindowBufferSizeEvent.dwSize.y;
end;
PutSystemEvent(e);
LeaveCriticalSection(ChangeSystemEvents);
end;
end;
procedure InitSystemMsg;
var
mode : dword;
begin
if SystemEventActive then
exit;
// enable Window events
GetConsoleMode(TextRec(Input).Handle,@mode);
mode:=mode or ENABLE_WINDOW_INPUT;
SetConsoleMode(TextRec(Input).Handle,mode);
PendingSystemHead:=@PendingSystemEvent;
PendingSystemTail:=@PendingSystemEvent;
PendingSystemEvents:=0;
FillChar(LastSystemEvent,sizeof(TSystemEvent),0);
InitializeCriticalSection(ChangeSystemEvents);
SetResizeEventHandler(@SystemEventHandler);
SetFocusEventHandler(@SystemEventHandler);
SystemEventActive:=true;
end;
procedure DoneSystemMsg;
var
mode : dword;
begin
if not SystemEventActive then
exit;
// disable System events
GetConsoleMode(TextRec(Input).Handle,@mode);
mode:=mode and (not ENABLE_WINDOW_INPUT);
SetConsoleMode(TextRec(Input).Handle,mode);
SetResizeEventHandler(nil);
SetFocusEventHandler(nil);
DeleteCriticalSection(ChangeSystemEvents);
SystemEventActive:=false;
end;
procedure GetSystemEvent(var SystemEvent: TSystemEvent);
var
b : byte;
begin
repeat
EnterCriticalSection(ChangeSystemEvents);
b:=PendingSystemEvents;
LeaveCriticalSection(ChangeSystemEvents);
if b>0 then
break
else
sleep(50);
until false;
EnterCriticalSection(ChangeSystemEvents);
SystemEvent:=PendingSystemHead^;
inc(PendingSystemHead);
if longint(PendingSystemHead)=longint(@PendingSystemEvent)+sizeof(PendingSystemEvent) then
PendingSystemHead:=@PendingSystemEvent;
dec(PendingSystemEvents);
LastSystemEvent:=SystemEvent;
LeaveCriticalSection(ChangeSystemEvents);
end;
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
begin
EnterCriticalSection(ChangeSystemEvents);
if PendingSystemEvents>0 then
begin
SystemEvent:=PendingSystemHead^;
PollSystemEvent:=true;
end
else
PollSystemEvent:=false;
LeaveCriticalSection(ChangeSystemEvents);
end;
{
$Log$
Revision 1.1 2002-05-21 11:59:57 pierre
+ system messages unit added
}

100
fvision/go32smsg.inc Normal file
View File

@ -0,0 +1,100 @@
{
$Id$
System independent system interface for go32v2
Copyright (c) 2000 by Pierre Muller
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
Const
SystemEventActive : Boolean = false;
procedure InitSystemMsg;
var
res : word;
begin
if SystemEventActive then
exit;
{ enable close }
asm
movl $0x168f,%eax
movl $1,%edx
int $0x2f
movw %ax,Res
end;
SystemEventActive:=(Res=0);
end;
procedure DoneSystemMsg;
begin
if not SystemEventActive then
exit;
{ disable close }
asm
movl $0x168f,%eax
movl $0,%edx
int $0x2f
end;
SystemEventActive:=false;
end;
procedure GetSystemEvent(var SystemEvent: TSystemEvent);
begin
PollSystemEvent(SystemEvent);
end;
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
var
CloseState : word;
begin
SystemEvent.typ:=SysNothing;
if not SystemEventActive then
exit(false);
{ Query close }
asm
movl $0x168f,%eax
movl $100,%edx
int $0x2f
movw %ax,CloseState
end;
if (CloseState = 0) then
begin
{ acknowledge Close }
asm
movl $0x168f,%eax
movl $200,%edx
int $0x2f
movw %ax,CloseState
end;
{ non zero means error ! }
if CloseState=0 then
begin
PollSystemEvent:=true;
SystemEvent.typ:=SysClose;
end;
end;
end;
{
$Log$
Revision 1.1 2002-05-21 11:59:57 pierre
+ system messages unit added
}

127
fvision/sysmsg.pas Normal file
View File

@ -0,0 +1,127 @@
{
$Id$
Unit to handle system events
Copyright 2000 by Pierre Muller <muller@ics.u-strasbg.fr>
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************}
Unit sysmsg;
interface
type
TSystemMessage = (
SysNothing,
SysSetFocus,
SysReleaseFocus,
SysClose,
SysResize );
TSystemEvent = Record
case typ : TSystemMessage of
SysClose : ( CloseTyp : Longint);
SysResize : (X,Y : Longint);
end;
PSystemEvent = ^TSystemEvent;
const
SystemEventBufSize = 16;
var
PendingSystemEvent : array[0..SystemEventBufSize-1] of TSystemEvent;
PendingSystemHead,
PendingSystemTail : PSystemEvent;
PendingSystemEvents : byte;
LastSystemEvent : TSystemEvent;
procedure InitSystemMsg;
procedure DoneSystemMsg;
procedure GetSystemEvent(var SystemEvent:TSystemEvent);
{ Returns the last SystemEvent, and waits for one if not available }
procedure PutSystemEvent(const SystemEvent: TSystemEvent);
{ Adds the given SystemEvent to the input queue. }
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
{ Checks if a SystemEvent is available, and returns it if one is found. If no
event is pending, it returns 0 }
implementation
{$undef HAS_SYSMSG}
{$ifdef go32v2}
{$i go32smsg.inc}
{$define HAS_SYSMSG}
{$endif go32v2}
{$ifdef win32}
{$i w32smsg.inc}
{$define HAS_SYSMSG}
{$endif win32}
{$ifdef unix}
{$i unixsmsg.inc}
{$define HAS_SYSMSG}
{$endif unix}
{$ifndef HAS_SYSMSG}
procedure InitSystemMsg;
begin
end;
procedure DoneSystemMsg;
begin
end;
procedure GetSystemEvent(var SystemEvent:TSystemEvent);
begin
FillChar(SystemEvent,SizeOf(SystemEvent),#0);
end;
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
begin
FillChar(SystemEvent,SizeOf(SystemEvent),#0);
PollSystemEvent:=false;
end;
{$endif not HAS_SYSMSG}
procedure PutSystemEvent(const SystemEvent: TSystemEvent);
begin
if PendingSystemEvents<SystemEventBufSize then
begin
PendingSystemTail^:=SystemEvent;
inc(PendingSystemTail);
if longint(PendingSystemTail)=longint(@PendingSystemEvent)+sizeof(PendingSystemEvent) then
PendingSystemTail:=@PendingSystemEvent;
inc(PendingSystemEvents);
end;
end;
end.
{
$Log$
Revision 1.1 2002-05-21 11:59:57 pierre
+ system messages unit added
}

68
fvision/unixsmsg.inc Normal file
View File

@ -0,0 +1,68 @@
{
$Id$
System dependent system messages for unix
Copyright (c) 2002 by Pierre Muller
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
{ This file is still a dummy,
it should use ioctl to get information about resizing of windows }
Const
SystemEventActive : Boolean = false;
procedure InitSystemMsg;
begin
If SystemEventActive then
exit;
{ Code to enable size tracking should go here }
SystemEventActive:=true;
end;
procedure DoneSystemMsg;
begin
if not SystemEventActive then
exit;
{ Code to disable size tracking should go here }
SystemEventActive:=false;
end;
procedure GetSystemEvent(var SystemEvent: TSystemEvent);
begin
PollSystemEvent(SystemEvent);
end;
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
var
CloseState : word;
begin
SystemEvent.typ:=SysNothing;
if not SystemEventActive then
exit(false);
PollSystemEvent:=false;
end;
{
$Log$
Revision 1.1 2002-05-21 11:59:57 pierre
+ system messages unit added
}

145
fvision/w32smsg.inc Normal file
View File

@ -0,0 +1,145 @@
{
$Id$
System independent system interface for win32
Copyright (c) 2000 by Pierre Muller
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
uses
windows,dos,winevent;
var
ChangeSystemEvents : TCriticalSection;
Const
SystemEventActive : Boolean = false;
procedure SystemEventHandler(var ir:INPUT_RECORD);
var
e : TSystemEvent;
begin
if (ir.EventType in [FOCUS_EVENT,WINDOW_BUFFER_SIZE_EVENT]) then
begin
EnterCriticalSection(ChangeSystemEvents);
if (ir.EventType=FOCUS_EVENT) then
begin
if ir.Event.FocusEvent.bSetFocus then
e.typ:=SysSetFocus
else
e.typ:=SysReleaseFocus;
end
else
begin
e.typ:=SysResize;
e.x:=ir.Event.WindowBufferSizeEvent.dwSize.x;
e.y:=ir.Event.WindowBufferSizeEvent.dwSize.y;
end;
PutSystemEvent(e);
LeaveCriticalSection(ChangeSystemEvents);
end;
end;
procedure InitSystemMsg;
var
mode : dword;
begin
if SystemEventActive then
exit;
// enable Window events
GetConsoleMode(TextRec(Input).Handle,@mode);
mode:=mode or ENABLE_WINDOW_INPUT;
SetConsoleMode(TextRec(Input).Handle,mode);
PendingSystemHead:=@PendingSystemEvent;
PendingSystemTail:=@PendingSystemEvent;
PendingSystemEvents:=0;
FillChar(LastSystemEvent,sizeof(TSystemEvent),0);
InitializeCriticalSection(ChangeSystemEvents);
SetResizeEventHandler(@SystemEventHandler);
SetFocusEventHandler(@SystemEventHandler);
SystemEventActive:=true;
end;
procedure DoneSystemMsg;
var
mode : dword;
begin
if not SystemEventActive then
exit;
// disable System events
GetConsoleMode(TextRec(Input).Handle,@mode);
mode:=mode and (not ENABLE_WINDOW_INPUT);
SetConsoleMode(TextRec(Input).Handle,mode);
SetResizeEventHandler(nil);
SetFocusEventHandler(nil);
DeleteCriticalSection(ChangeSystemEvents);
SystemEventActive:=false;
end;
procedure GetSystemEvent(var SystemEvent: TSystemEvent);
var
b : byte;
begin
repeat
EnterCriticalSection(ChangeSystemEvents);
b:=PendingSystemEvents;
LeaveCriticalSection(ChangeSystemEvents);
if b>0 then
break
else
sleep(50);
until false;
EnterCriticalSection(ChangeSystemEvents);
SystemEvent:=PendingSystemHead^;
inc(PendingSystemHead);
if longint(PendingSystemHead)=longint(@PendingSystemEvent)+sizeof(PendingSystemEvent) then
PendingSystemHead:=@PendingSystemEvent;
dec(PendingSystemEvents);
LastSystemEvent:=SystemEvent;
LeaveCriticalSection(ChangeSystemEvents);
end;
function PollSystemEvent(var SystemEvent: TSystemEvent):boolean;
begin
EnterCriticalSection(ChangeSystemEvents);
if PendingSystemEvents>0 then
begin
SystemEvent:=PendingSystemHead^;
PollSystemEvent:=true;
end
else
PollSystemEvent:=false;
LeaveCriticalSection(ChangeSystemEvents);
end;
{
$Log$
Revision 1.1 2002-05-21 11:59:57 pierre
+ system messages unit added
}