Why Gemfury?
Push, build, and install
RubyGems
npm packages
Python packages
Maven artifacts
PHP packages
Go Modules
Debian packages
RPM packages
NuGet packages
Repository URL to install this package:
|
Version:
3.0.0 ▾
|
{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********}
{ }
{ System independent clone of DRIVERS.PAS }
{ }
{ Interface Copyright (c) 1992 Borland International }
{ }
{ Copyright (c) 1996, 1997, 1998, 1999, 2000 }
{ by Leon de Boer }
{ ldeboer@attglobal.net - primary e-mail addr }
{ ldeboer@projectent.com.au - backup e-mail addr }
{ }
{ Original FormatStr kindly donated by Marco Schmidt }
{ }
{ Mouse callback hook under FPC with kind assistance of }
{ Pierre Muller, Gertjan Schouten & Florian Klaempfl. }
{ }
{****************[ THIS CODE IS FREEWARE ]*****************}
{ }
{ This sourcecode is released for the purpose to }
{ promote the pascal language on all platforms. You may }
{ redistribute it and/or modify with the following }
{ DISCLAIMER. }
{ }
{ This SOURCE CODE is distributed "AS IS" WITHOUT }
{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR }
{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. }
{ }
{*****************[ SUPPORTED PLATFORMS ]******************}
{ }
{ Only Free Pascal Compiler supported }
{ }
{**********************************************************}
UNIT Drivers;
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
INTERFACE
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{====Include file to sort compiler platform out =====================}
{$I platform.inc}
{====================================================================}
{==== Compiler directives ===========================================}
{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$IFNDEF OS_UNIX}
{$S-} { Disable Stack Checking }
{$ENDIF}
{$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings }
{====================================================================}
{$ifdef CPU68K}
{$DEFINE ENDIAN_BIG}
{$endif CPU68K}
{$ifdef FPC}
{$INLINE ON}
{$endif}
USES
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
Windows, { Standard unit }
{$ENDIF}
{$ifdef OS_DOS}
Dos,
{$endif OS_DOS}
{$IFDEF OS_OS2} { OS2 CODE }
{$IFDEF PPC_Virtual} { VIRTUAL PASCAL UNITS }
OS2Def, OS2Base, OS2PMAPI, { Standard units }
{$ENDIF}
{$IFDEF PPC_Speed} { SPEED PASCAL UNITS }
BseDos, Os2Def, { Standard units }
{$ENDIF}
{$IFDEF PPC_FPC} { FPC UNITS }
DosCalls, Os2Def, { Standard units }
{$ENDIF}
{$ENDIF}
{$IFDEF OS_UNIX}
unixtype,baseunix,unix,
{$ENDIF}
{$IFDEF OS_NETWARE_LIBC}
libc,
{$ENDIF}
{$IFDEF OS_NETWARE_CLIB}
nwserv,
{$ENDIF}
{$IFDEF OS_AMIGA}
dos, amigados,
{$ENDIF}
video,
SysMsg,
FVCommon, Objects; { GFV standard units }
{***************************************************************************}
{ PUBLIC CONSTANTS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ EVENT TYPE MASKS }
{---------------------------------------------------------------------------}
CONST
evMouseDown = $0001; { Mouse down event }
evMouseUp = $0002; { Mouse up event }
evMouseMove = $0004; { Mouse move event }
evMouseAuto = $0008; { Mouse auto event }
evKeyDown = $0010; { Key down event }
evCommand = $0100; { Command event }
evBroadcast = $0200; { Broadcast event }
{---------------------------------------------------------------------------}
{ EVENT CODE MASKS }
{---------------------------------------------------------------------------}
CONST
evNothing = $0000; { Empty event }
evMouse = $000F; { Mouse event }
evKeyboard = $0010; { Keyboard event }
evMessage = $FF00; { Message event }
{---------------------------------------------------------------------------}
{ EXTENDED KEY CODES }
{---------------------------------------------------------------------------}
CONST
kbNoKey = $0000; kbAltEsc = $0100; kbEsc = $011B;
kbAltSpace = $0200; kbCtrlIns = $0400; kbShiftIns = $0500;
kbCtrlDel = $0600; kbShiftDel = $0700; kbAltBack = $0800;
kbAltShiftBack= $0900; kbBack = $0E08; kbCtrlBack = $0E7F;
kbShiftTab = $0F00; kbTab = $0F09; kbAltQ = $1000;
kbCtrlQ = $1011; kbAltW = $1100; kbCtrlW = $1117;
kbAltE = $1200; kbCtrlE = $1205; kbAltR = $1300;
kbCtrlR = $1312; kbAltT = $1400; kbCtrlT = $1414;
kbAltY = $1500; kbCtrlY = $1519; kbAltU = $1600;
kbCtrlU = $1615; kbAltI = $1700; kbCtrlI = $1709;
kbAltO = $1800; kbCtrlO = $180F; kbAltP = $1900;
kbCtrlP = $1910; kbAltLftBrack = $1A00; kbAltRgtBrack = $1B00;
kbCtrlEnter = $1C0A; kbEnter = $1C0D; kbAltA = $1E00;
kbCtrlA = $1E01; kbAltS = $1F00; kbCtrlS = $1F13;
kbAltD = $2000; kbCtrlD = $2004; kbAltF = $2100;
kbCtrlF = $2106; kbAltG = $2200; kbCtrlG = $2207;
kbAltH = $2300; kbCtrlH = $2308; kbAltJ = $2400;
kbCtrlJ = $240A; kbAltK = $2500; kbCtrlK = $250B;
kbAltL = $2600; kbCtrlL = $260C; kbAltSemiCol = $2700;
kbAltQuote = $2800; kbAltOpQuote = $2900; kbAltBkSlash = $2B00;
kbAltZ = $2C00; kbCtrlZ = $2C1A; kbAltX = $2D00;
kbCtrlX = $2D18; kbAltC = $2E00; kbCtrlC = $2E03;
kbAltV = $2F00; kbCtrlV = $2F16; kbAltB = $3000;
kbCtrlB = $3002; kbAltN = $3100; kbCtrlN = $310E;
kbAltM = $3200; kbCtrlM = $320D; kbAltComma = $3300;
kbAltPeriod = $3400; kbAltSlash = $3500; kbAltGreyAst = $3700;
kbSpaceBar = $3920; kbF1 = $3B00; kbF2 = $3C00;
kbF3 = $3D00; kbF4 = $3E00; kbF5 = $3F00;
kbF6 = $4000; kbF7 = $4100; kbF8 = $4200;
kbF9 = $4300; kbF10 = $4400; kbHome = $4700;
kbUp = $4800; kbPgUp = $4900; kbGrayMinus = $4A2D;
kbLeft = $4B00; kbCenter = $4C00; kbRight = $4D00;
kbAltGrayPlus = $4E00; kbGrayPlus = $4E2B; kbEnd = $4F00;
kbDown = $5000; kbPgDn = $5100; kbIns = $5200;
kbDel = $5300; kbShiftF1 = $5400; kbShiftF2 = $5500;
kbShiftF3 = $5600; kbShiftF4 = $5700; kbShiftF5 = $5800;
kbShiftF6 = $5900; kbShiftF7 = $5A00; kbShiftF8 = $5B00;
kbShiftF9 = $5C00; kbShiftF10 = $5D00; kbCtrlF1 = $5E00;
kbCtrlF2 = $5F00; kbCtrlF3 = $6000; kbCtrlF4 = $6100;
kbCtrlF5 = $6200; kbCtrlF6 = $6300; kbCtrlF7 = $6400;
kbCtrlF8 = $6500; kbCtrlF9 = $6600; kbCtrlF10 = $6700;
kbAltF1 = $6800; kbAltF2 = $6900; kbAltF3 = $6A00;
kbAltF4 = $6B00; kbAltF5 = $6C00; kbAltF6 = $6D00;
kbAltF7 = $6E00; kbAltF8 = $6F00; kbAltF9 = $7000;
kbAltF10 = $7100; kbCtrlPrtSc = $7200; kbCtrlLeft = $7300;
kbCtrlRight = $7400; kbCtrlEnd = $7500; kbCtrlPgDn = $7600;
kbCtrlHome = $7700; kbAlt1 = $7800; kbAlt2 = $7900;
kbAlt3 = $7A00; kbAlt4 = $7B00; kbAlt5 = $7C00;
kbAlt6 = $7D00; kbAlt7 = $7E00; kbAlt8 = $7F00;
kbAlt9 = $8000; kbAlt0 = $8100; kbAltMinus = $8200;
kbAltEqual = $8300; kbCtrlPgUp = $8400; kbF11 = $8500;
kbF12 = $8600; kbShiftF11 = $8700; kbShiftF12 = $8800;
kbCtrlF11 = $8900; kbCtrlF12 = $8A00; kbAltF11 = $8B00;
kbAltF12 = $8C00; kbCtrlUp = $8D00; kbCtrlMinus = $8E00;
kbCtrlCenter = $8F00; kbCtrlGreyPlus= $9000; kbCtrlDown = $9100;
kbCtrlTab = $9400; kbAltHome = $9700; kbAltUp = $9800;
kbAltPgUp = $9900; kbAltLeft = $9B00; kbAltRight = $9D00;
kbAltEnd = $9F00; kbAltDown = $A000; kbAltPgDn = $A100;
kbAltIns = $A200; kbAltDel = $A300; kbAltTab = $A500;
{ ------------------------------- REMARK ------------------------------ }
{ New keys not initially defined by Borland in their unit interface. }
{ ------------------------------ END REMARK --- Leon de Boer, 15May96 - }
kbFullStop = $342E; kbComma = $332C; kbBackSlash = $352F;
kbApostrophe = $2827; kbSemiColon = $273B; kbEqual = $0D3D;
kbGreaterThan = $343E; kbLessThan = $333C; kbQuestion = $353F;
kbQuote = $2822; kbColon = $273A; kbPlus = $0D2B;
kbPipe = $2B7C; kbSlash = $2B5C; kbExclaim = $0221;
kbAt = $0340; kbNumber = $0423; kbPercent = $0625;
kbCaret = $075E; kbAmpersand = $0826; kbAsterix = $092A;
kbLeftBracket = $0A28; kbRightBracket= $0B29; kbApprox = $2960;
kbTilde = $297E; kbDollar = $0524; kbMinus = $0C2D;
kbUnderline = $0C5F; kbLeftSqBr = $1A5B; kbRightSqBr = $1B5D;
kbLeftCurlyBr = $1A7B; kbRightCurlyBr= $1B7D;
{---------------------------------------------------------------------------}
{ KEYBOARD STATE AND SHIFT MASKS }
{---------------------------------------------------------------------------}
CONST
kbRightShift = $0001; { Right shift key }
kbLeftShift = $0002; { Left shift key }
kbCtrlShift = $0004; { Control key down }
kbAltShift = $0008; { Alt key down }
kbScrollState = $0010; { Scroll lock on }
kbNumState = $0020; { Number lock on }
kbCapsState = $0040; { Caps lock on }
kbInsState = $0080; { Insert mode on }
kbBothShifts = kbRightShift + kbLeftShift; { Right & Left shifts }
{---------------------------------------------------------------------------}
{ MOUSE BUTTON STATE MASKS }
{---------------------------------------------------------------------------}
CONST
mbLeftButton = $01; { Left mouse button }
mbRightButton = $02; { Right mouse button }
mbMiddleButton = $04; { Middle mouse button }
{---------------------------------------------------------------------------}
{ SCREEN CRT MODE CONSTANTS }
{---------------------------------------------------------------------------}
CONST
smBW80 = $0002; { Black and white }
smCO80 = $0003; { Colour mode }
smMono = $0007; { Monochrome mode }
smFont8x8 = $0100; { 8x8 font mode }
{***************************************************************************}
{ PUBLIC TYPE DEFINITIONS }
{***************************************************************************}
{ ******************************* REMARK ****************************** }
{ The TEvent definition is completely compatable with all existing }
{ code but adds two new fields ID and Data into the message record }
{ which helps with WIN/NT and OS2 message processing. }
{ ****************************** END REMARK *** Leon de Boer, 11Sep97 * }
{---------------------------------------------------------------------------}
{ EVENT RECORD DEFINITION }
{---------------------------------------------------------------------------}
TYPE
TEvent =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
PACKED
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
RECORD
What: Sw_Word; { Event type }
Case Sw_Word Of
evNothing: (); { ** NO EVENT ** }
evMouse: (
Buttons: Byte; { Mouse buttons }
Double: Boolean; { Double click state }
Where: TPoint); { Mouse position }
evKeyDown: (
{ ** KEY EVENT ** }
Case Sw_Integer Of
0: (KeyCode: Word); { Full key code }
1: (
{$ifdef ENDIAN_BIG}
ScanCode: Byte;
CharCode: Char;
{$else not ENDIAN_BIG}
CharCode: Char; { Char code }
ScanCode: Byte; { Scan code }
{$endif not ENDIAN_BIG}
KeyShift: byte)); { Shift states }
evMessage: ( { ** MESSAGE EVENT ** }
Command: Sw_Word; { Message command }
Id : Sw_Word; { Message id }
Data : Real; { Message data }
Case Sw_Word Of
0: (InfoPtr: Pointer); { Message pointer }
1: (InfoLong: Longint); { Message longint }
2: (InfoWord: Word); { Message Sw_Word }
3: (InfoInt: Integer); { Message Sw_Integer }
4: (InfoByte: Byte); { Message byte }
5: (InfoChar: Char)); { Message character }
END;
PEvent = ^TEvent;
TVideoMode = Video.TVideoMode; { Screen mode }
{---------------------------------------------------------------------------}
{ ERROR HANDLER FUNCTION DEFINITION }
{---------------------------------------------------------------------------}
TYPE
TSysErrorFunc = FUNCTION (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer;
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{ Get Dos counter ticks }
Function GetDosTicks:longint; { returns ticks at 18.2 Hz, just like DOS }
procedure GiveUpTimeSlice;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ BUFFER MOVE ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-CStrLen------------------------------------------------------------
Returns the length of string S, where S is a control string using tilde
characters ('~') to designate shortcut characters. The tildes are
excluded from the length of the string, as they will not appear on
the screen. For example, given the string '~B~roccoli' as its
parameter, CStrLen returns 8.
25May96 LdB
---------------------------------------------------------------------}
FUNCTION CStrLen (Const S: String): Sw_Integer;
{-MoveStr------------------------------------------------------------
Moves a string into a buffer for use with a view's WriteBuf or WriteLine.
Dest must be a TDrawBuffer (or an equivalent array of Sw_Words). The
characters in Str are moved into the low bytes of corresponding Sw_Words
in Dest. The high bytes of the Sw_Words are set to Attr, or remain
unchanged if Attr is zero.
25May96 LdB
---------------------------------------------------------------------}
PROCEDURE MoveStr (Var Dest; Const Str: String; Attr: Byte);
{-MoveCStr-----------------------------------------------------------
The characters in Str are moved into the low bytes of corresponding
Sw_Words in Dest. The high bytes of the Sw_Words are set to Lo(Attr) or
Hi(Attr). Tilde characters (~) in the string toggle between the two
attribute bytes passed in the Attr Sw_Word.
25May96 LdB
---------------------------------------------------------------------}
PROCEDURE MoveCStr (Var Dest; Const Str: String; Attrs: Word);
{-MoveBuf------------------------------------------------------------
Count bytes are moved from Source into the low bytes of corresponding
Sw_Words in Dest. The high bytes of the Sw_Words in Dest are set to Attr,
or remain unchanged if Attr is zero.
25May96 LdB
---------------------------------------------------------------------}
PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; Count: Sw_Word);
{-MoveChar------------------------------------------------------------
Moves characters into a buffer for use with a view's WriteBuf or
WriteLine. Dest must be a TDrawBuffer (or an equivalent array of Sw_Words).
The low bytes of the first Count Sw_Words of Dest are set to C, or
remain unchanged if Ord(C) is zero. The high bytes of the Sw_Words are
set to Attr, or remain unchanged if Attr is zero.
25May96 LdB
---------------------------------------------------------------------}
PROCEDURE MoveChar (Var Dest; C: Char; Attr: Byte; Count: Sw_Word);
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ KEYBOARD SUPPORT ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-GetAltCode---------------------------------------------------------
Returns the scancode corresponding to Alt+Ch key that is given.
25May96 LdB
---------------------------------------------------------------------}
FUNCTION GetAltCode (Ch: Char): Word;
{-GetCtrlCode--------------------------------------------------------
Returns the scancode corresponding to Alt+Ch key that is given.
25May96 LdB
---------------------------------------------------------------------}
FUNCTION GetCtrlCode (Ch: Char): Word;
{-GetAltChar---------------------------------------------------------
Returns the ascii character for the Alt+Key scancode that was given.
25May96 LdB
---------------------------------------------------------------------}
FUNCTION GetAltChar (KeyCode: Word): Char;
{-GetCtrlChar--------------------------------------------------------
Returns the ascii character for the Ctrl+Key scancode that was given.
25May96 LdB
---------------------------------------------------------------------}
FUNCTION GetCtrlChar (KeyCode: Word): Char;
{-CtrlToArrow--------------------------------------------------------
Converts a WordStar-compatible control key code to the corresponding
cursor key code.
25May96 LdB
---------------------------------------------------------------------}
FUNCTION CtrlToArrow (KeyCode: Word): Word;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ KEYBOARD CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-GetShiftState------------------------------------------------------
Returns a byte containing the current Shift key state. The return
value contains a combination of the kbXXXX constants for shift states.
08Jul96 LdB
---------------------------------------------------------------------}
FUNCTION GetShiftState: Byte;
{-GetKeyEvent--------------------------------------------------------
Checks whether a keyboard event is available. If a key has been pressed,
Event.What is set to evKeyDown and Event.KeyCode is set to the scan
code of the key. Otherwise, Event.What is set to evNothing.
19May98 LdB
---------------------------------------------------------------------}
PROCEDURE GetKeyEvent (Var Event: TEvent);
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ MOUSE CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-ShowMouse----------------------------------------------------------
Decrements the hide counter and if zero the mouse is shown on screen.
30Jun98 LdB
---------------------------------------------------------------------}
PROCEDURE ShowMouse;
{-HideMouse----------------------------------------------------------
If mouse hide counter is zero it removes the cursor from the screen.
The hide counter is then incremented by one count.
30Jun98 LdB
---------------------------------------------------------------------}
PROCEDURE HideMouse;
{-GetMouseEvent------------------------------------------------------
Checks whether a mouse event is available. If a mouse event has occurred,
Event.What is set to evMouseDown, evMouseUp, evMouseMove, or evMouseAuto
and the button and double click variables are set appropriately.
06Jan97 LdB
---------------------------------------------------------------------}
PROCEDURE GetMouseEvent (Var Event: TEvent);
{-GetSystemEvent------------------------------------------------------
Checks whether a system event is available. If a system event has occurred,
Event.What is set to evCommand appropriately
10Oct2000 PM
---------------------------------------------------------------------}
procedure GetSystemEvent (Var Event: TEvent);
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ EVENT HANDLER CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-InitEvents---------------------------------------------------------
Initializes the event manager, enabling the mouse handler routine and
under DOS/DPMI shows the mouse on screen. It is called automatically
by TApplication.Init.
02May98 LdB
---------------------------------------------------------------------}
PROCEDURE InitEvents;
{-DoneEvents---------------------------------------------------------
Terminates event manager and disables the mouse and under DOS hides
the mouse. It is called automatically by TApplication.Done.
02May98 LdB
---------------------------------------------------------------------}
PROCEDURE DoneEvents;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ VIDEO CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-Initkeyboard-------------------------------------------------------
Initializes the keyboard. Before it is called read(ln)/write(ln)
are functional, after it is called FV's keyboard routines are
functional.
---------------------------------------------------------------------}
procedure initkeyboard;
{-Donekeyboard-------------------------------------------------------
Restores keyboard to original state. FV's keyboard routines may not
be used after a call to this. Read(ln)/write(ln) can be used again.
---------------------------------------------------------------------}
procedure donekeyboard;
{-DetectVideo---------------------------------------------------------
Detects the current video mode without initializing or otherwise
changing the current screen.
---------------------------------------------------------------------}
procedure DetectVideo;
{-InitVideo---------------------------------------------------------
Initializes the video manager, Saves the current screen mode in
StartupMode, and switches to the mode indicated by ScreenMode.
19May98 LdB
---------------------------------------------------------------------}
function InitVideo:boolean;
{-DoneVideo---------------------------------------------------------
Terminates the video manager by restoring the initial screen mode
(given by StartupMode), clearing the screen, and restoring the cursor.
Called automatically by TApplication.Done.
03Jan97 LdB
---------------------------------------------------------------------}
PROCEDURE DoneVideo;
{-ClearScreen--------------------------------------------------------
Does nothing provided for compatability purposes only.
04Jan97 LdB
---------------------------------------------------------------------}
PROCEDURE ClearScreen;
{-SetVideoMode-------------------------------------------------------
Does nothing provided for compatability purposes only.
04Jan97 LdB
---------------------------------------------------------------------}
PROCEDURE SetVideoMode (Mode: Sw_Word);
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ ERROR CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-InitSysError-------------------------------------------------------
Error handling is not yet implemented so this simply sets
SysErrActive=True (ie it lies) and exits.
20May98 LdB
---------------------------------------------------------------------}
PROCEDURE InitSysError;
{-DoneSysError-------------------------------------------------------
Error handling is not yet implemented so this simply sets
SysErrActive=False and exits.
20May98 LdB
---------------------------------------------------------------------}
PROCEDURE DoneSysError;
{-SystemError---------------------------------------------------------
Error handling is not yet implemented so this simply drops through.
20May98 LdB
---------------------------------------------------------------------}
FUNCTION SystemError (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ STRING FORMAT ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-PrintStr-----------------------------------------------------------
Does nothing provided for compatability purposes only.
30Jun98 LdB
---------------------------------------------------------------------}
PROCEDURE PrintStr (CONST S: String);
{-FormatStr----------------------------------------------------------
A string formatting routine that given a string that includes format
specifiers and a list of parameters in Params, FormatStr produces a
formatted output string in Result.
18Feb99 LdB
---------------------------------------------------------------------}
PROCEDURE FormatStr (Var Result: String; CONST Format: String; Var Params);
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ >> NEW QUEUED EVENT HANDLER ROUTINES << }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-PutEventInQueue-----------------------------------------------------
If there is room in the queue the event is placed in the next vacant
position in the queue manager.
17Mar98 LdB
---------------------------------------------------------------------}
FUNCTION PutEventInQueue (Var Event: TEvent): Boolean;
{-NextQueuedEvent----------------------------------------------------
If there are queued events the next event is loaded into event else
evNothing is returned.
17Mar98 LdB
---------------------------------------------------------------------}
PROCEDURE NextQueuedEvent(Var Event: TEvent);
{***************************************************************************}
{ INITIALIZED PUBLIC VARIABLES }
{***************************************************************************}
PROCEDURE HideMouseCursor;
PROCEDURE ShowMouseCursor;
{---------------------------------------------------------------------------}
{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES }
{---------------------------------------------------------------------------}
CONST
CheckSnow : Boolean = False; { Compatability only }
MouseEvents : Boolean = False; { Mouse event state }
MouseReverse : Boolean = False; { Mouse reversed }
HiResScreen : Boolean = False; { Compatability only }
CtrlBreakHit : Boolean = False; { Compatability only }
SaveCtrlBreak: Boolean = False; { Compatability only }
SysErrActive : Boolean = False; { Compatability only }
FailSysErrors: Boolean = False; { Compatability only }
ButtonCount : Byte = 0; { Mouse button count }
DoubleDelay : Sw_Word = 8; { Double click delay }
RepeatDelay : Sw_Word = 8; { Auto mouse delay }
SysColorAttr : Sw_Word = $4E4F; { System colour attr }
SysMonoAttr : Sw_Word = $7070; { System mono attr }
StartupMode : Sw_Word = $FFFF; { Compatability only }
CursorLines : Sw_Word = $FFFF; { Compatability only }
ScreenBuffer : Pointer = Nil; { Compatability only }
SaveInt09 : Pointer = Nil; { Compatability only }
SysErrorFunc : TSysErrorFunc = {$ifdef FPC}@{$endif}SystemError; { System error ptr }
{***************************************************************************}
{ UNINITIALIZED PUBLIC VARIABLES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES }
{---------------------------------------------------------------------------}
VAR
MouseIntFlag: Byte; { Mouse in int flag }
MouseButtons: Byte; { Mouse button state }
ScreenWidth : Byte; { Screen text width }
ScreenHeight: Byte; { Screen text height }
ScreenMode : TVideoMode; { Screen mode }
MouseWhere : TPoint; { Mouse position }
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{ API Units }
USES
FVConsts,
Keyboard,Mouse;
{***************************************************************************}
{ PRIVATE INTERNAL CONSTANTS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ DOS/DPMI MOUSE INTERRUPT EVENT QUEUE SIZE }
{---------------------------------------------------------------------------}
CONST EventQSize = 16; { Default int bufsize }
{---------------------------------------------------------------------------}
{ DOS/DPMI/WIN/NT/OS2 NEW EVENT QUEUE MAX SIZE }
{---------------------------------------------------------------------------}
CONST QueueMax = 64; { Max new queue size }
{---------------------------------------------------------------------------}
{ MAX WIEW WIDTH to avoid TDrawBuffer overrun in views unit }
{---------------------------------------------------------------------------}
CONST MaxViewWidth = 255; { Max view width }
{***************************************************************************}
{ PRIVATE INTERNAL TYPES }
{***************************************************************************}
{***************************************************************************}
{ PRIVATE INTERNAL INITIALIZED VARIABLES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ DOS/DPMI/WIN/NT/OS2 ALT KEY SCANCODES FROM KEYS (0-127) }
{---------------------------------------------------------------------------}
CONST AltCodes: Array [0..127] Of Byte = (
$00, $00, $00, $00, $00, $00, $00, $00, { $00 - $07 }
$00, $00, $00, $00, $00, $00, $00, $00, { $08 - $0F }
$00, $00, $00, $00, $00, $00, $00, $00, { $10 - $17 }
$00, $00, $00, $00, $00, $00, $00, $00, { $18 - $1F }
$00, $00, $00, $00, $00, $00, $00, $00, { $20 - $27 }
$00, $00, $00, $00, $00, $82, $00, $00, { $28 - $2F }
$81, $78, $79, $7A, $7B, $7C, $7D, $7E, { $30 - $37 }
$7F, $80, $00, $00, $00, $83, $00, $00, { $38 - $3F }
$00, $1E, $30, $2E, $20, $12, $21, $22, { $40 - $47 }
$23, $17, $24, $25, $26, $32, $31, $18, { $48 - $4F }
$19, $10, $13, $1F, $14, $16, $2F, $11, { $50 - $57 }
$2D, $15, $2C, $00, $00, $00, $00, $00, { $58 - $5F }
$00, $00, $00, $00, $00, $00, $00, $00, { $60 - $67 }
$00, $00, $00, $00, $00, $00, $00, $00, { $68 - $6F }
$00, $00, $00, $00, $00, $00, $00, $00, { $70 - $77 }
$00, $00, $00, $00, $00, $00, $00, $00); { $78 - $7F }
{***************************************************************************}
{ PRIVATE INTERNAL INITIALIZED VARIABLES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ NEW CONTROL VARIABLES }
{---------------------------------------------------------------------------}
CONST
HideCount : Sw_Integer = 0; { Cursor hide count }
QueueCount: Sw_Word = 0; { Queued message count }
QueueHead : Sw_Word = 0; { Queue head pointer }
QueueTail : Sw_Word = 0; { Queue tail pointer }
{***************************************************************************}
{ PRIVATE INTERNAL UNINITIALIZED VARIABLES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ UNINITIALIZED DOS/DPMI/API VARIABLES }
{---------------------------------------------------------------------------}
VAR
LastDouble : Boolean; { Last double buttons }
LastButtons: Byte; { Last button state }
DownButtons: Byte; { Last down buttons }
EventCount : Sw_Word; { Events in queue }
AutoDelay : Sw_Word; { Delay time count }
DownTicks : Sw_Word; { Down key tick count }
AutoTicks : Sw_Word; { Held key tick count }
LastWhereX : Sw_Word; { Last x position }
LastWhereY : Sw_Word; { Last y position }
DownWhereX : Sw_Word; { Last x position }
DownWhereY : Sw_Word; { Last y position }
LastWhere : TPoint; { Last mouse position }
DownWhere : TPoint; { Last down position }
EventQHead : Pointer; { Head of queue }
EventQTail : Pointer; { Tail of queue }
EventQueue : Array [0..EventQSize - 1] Of TEvent; { Event queue }
EventQLast : RECORD END; { Simple end marker }
StartupScreenMode : TVideoMode;
{$ifdef OS_AMIGA}
StartupTicks: Int64; // ticks at Startup for GetDOSTicks
{$endif}
{---------------------------------------------------------------------------}
{ GetDosTicks (18.2 Hz) }
{---------------------------------------------------------------------------}
Function GetDosTicks:longint; { returns ticks at 18.2 Hz, just like DOS }
{$IFDEF OS_OS2}
const
QSV_MS_COUNT = 14;
var
L: longint;
begin
DosQuerySysInfo (QSV_MS_COUNT, QSV_MS_COUNT, L, 4);
GetDosTicks := L div 55;
end;
{$ENDIF}
{$IFDEF OS_UNIX}
var
tv : TimeVal;
{ tz : TimeZone;}
begin
FPGetTimeOfDay(@tv,nil{,tz});
GetDosTicks:=((tv.tv_Sec mod 86400) div 60)*1092+((tv.tv_Sec mod 60)*1000000+tv.tv_USec) div 54945;
end;
{$ENDIF OS_UNIX}
{$IFDEF OS_WINDOWS}
begin
GetDosTicks:=GetTickCount div 55;
end;
{$ENDIF OS_WINDOWS}
{$IFDEF OS_DOS}
begin
GetDosTicks:=MemL[$40:$6c];
end;
{$ENDIF OS_DOS}
{$IFDEF OS_NETWARE_LIBC}
var
tv : TTimeVal;
tz : TTimeZone;
begin
fpGetTimeOfDay(tv,tz);
GetDosTicks:=((tv.tv_sec mod 86400) div 60)*1092+((tv.tv_Sec mod 60)*1000000+tv.tv_USec) div 549
end;
{$ENDIF}
{$IFDEF OS_NETWARE_CLIB}
begin
GetDosTicks := Nwserv.GetCurrentTicks;
end;
{$ENDIF}
{$IFDEF OS_AMIGA}
begin
GetDosTicks:= ((dos.GetMsCount div 55) - StartupTicks) and $7FFFFFFF;
end;
{$ENDIF OS_AMIGA}
procedure GiveUpTimeSlice;
{$IFDEF OS_DOS}
var r: registers;
begin
Intr ($28, R); (* This is supported everywhere. *)
r.ax:=$1680;
intr($2f,r);
end;
{$ENDIF}
{$IFDEF OS_UNIX}
var
req,rem : timespec;
begin
req.tv_sec:=0;
req.tv_nsec:=10000000;{ 10 ms }
fpnanosleep(@req,@rem);
end;
{$ENDIF}
{$IFDEF OS_OS2}
begin
DosSleep (5);
end;
{$ENDIF}
{$IFDEF OS_WINDOWS}
begin
{ if the return value of this call is non zero then
it means that a ReadFileEx or WriteFileEx have completed
unused for now ! }
{ wait for 10 ms }
if SleepEx(10,true)=WAIT_IO_COMPLETION then
begin
{ here we should handle the completion of the routines
if we use them }
end;
end;
{$ENDIF}
{$IFDEF OS_NETWARE_LIBC}
begin
Delay (10);
end;
{$ENDIF}
{$IFDEF OS_NETWARE_CLIB}
begin
Delay (10);
end;
{$ENDIF}
{$IFDEF OS_AMIGA}
begin
{ AmigaOS Delay() wait's argument in 1/50 seconds }
{ DOSDelay(2); // the old solution... }
Keyboard.WaitForSystemEvent(150);
end;
{$ENDIF OS_AMIGA}
{---------------------------------------------------------------------------}
{ UNINITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES }
{---------------------------------------------------------------------------}
VAR
SaveExit: Pointer; { Saved exit pointer }
Queue : Array [0..QueueMax-1] Of TEvent; { New message queue }
{***************************************************************************}
{ PRIVATE INTERNAL ROUTINES }
{***************************************************************************}
PROCEDURE ShowMouseCursor;inline;
BEGIN
ShowMouse;
END;
PROCEDURE HideMouseCursor;inline;
BEGIN
HideMouse;
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ DOS/DPMI/WIN/NT/OS2 PRIVATE INTERNAL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ ExitDrivers -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jun98 LdB }
{---------------------------------------------------------------------------}
PROCEDURE ExitDrivers; {$IFNDEF PPC_FPC}{$IFNDEF OS_UNIX} FAR; {$ENDIF}{$ENDIF}
BEGIN
DoneSysError; { Relase error trap }
DoneEvents; { Close event driver }
{ DoneKeyboard;}
DoneVideo;
ExitProc := SaveExit; { Restore old exit }
END;
{---------------------------------------------------------------------------}
{ DetectVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB }
{---------------------------------------------------------------------------}
procedure DetectVideo;
VAR
CurrMode : TVideoMode;
begin
{ Video.InitVideo; Incompatible with BP
and forces a screen clear which is often a bad thing PM }
GetVideoMode(CurrMode);
ScreenMode:=CurrMode;
end;
{---------------------------------------------------------------------------}
{ DetectMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB }
FUNCTION DetectMouse: Byte;inline;
begin
DetectMouse:=Mouse.DetectMouse;
end;
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ BUFFER MOVE ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ CStrLen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION CStrLen (Const S: String): Sw_Integer;
VAR I, J: Sw_Integer;
BEGIN
J := 0; { Set result to zero }
For I := 1 To Length(S) Do
If (S[I] <> '~') Then Inc(J); { Inc count if not ~ }
CStrLen := J; { Return length }
END;
{---------------------------------------------------------------------------}
{ MoveStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE MoveStr (Var Dest; Const Str: String; Attr: Byte);
VAR I: Word; P: PWord;
BEGIN
For I := 1 To Length(Str) Do Begin { For each character }
P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word }
If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute }
WordRec(P^).Lo := Byte(Str[I]); { Copy string char }
End;
END;
{---------------------------------------------------------------------------}
{ MoveCStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE MoveCStr (Var Dest; Const Str: String; Attrs: Word);
VAR B: Byte; I, J: Sw_Word; P: PWord;
BEGIN
J := 0; { Start position }
For I := 1 To Length(Str) Do Begin { For each character }
If (Str[I] <> '~') Then Begin { Not tilde character }
P := @TWordArray(Dest)[J]; { Pointer to Sw_Word }
If (Lo(Attrs) <> 0) Then
WordRec(P^).Hi := Lo(Attrs); { Copy attribute }
WordRec(P^).Lo := Byte(Str[I]); { Copy string char }
Inc(J); { Next position }
End Else Begin
B := Hi(Attrs); { Hold attribute }
WordRec(Attrs).Hi := Lo(Attrs); { Copy low to high }
WordRec(Attrs).Lo := B; { Complete exchange }
End;
End;
END;
{---------------------------------------------------------------------------}
{ MoveBuf -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE MoveBuf (Var Dest, Source; Attr: Byte; Count: Sw_Word);
VAR I: Word; P: PWord;
BEGIN
For I := 1 To Count Do Begin
P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word }
If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute }
WordRec(P^).Lo := TByteArray(Source)[I-1]; { Copy source data }
End;
END;
{---------------------------------------------------------------------------}
{ MoveChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Jul99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE MoveChar (Var Dest; C: Char; Attr: Byte; Count: Sw_Word);
VAR I: Word; P: PWord;
BEGIN
For I := 1 To Count Do Begin
P := @TWordArray(Dest)[I-1]; { Pointer to Sw_Word }
If (Attr <> 0) Then WordRec(P^).Hi := Attr; { Copy attribute }
If (Ord(C) <> 0) Then WordRec(P^).Lo := Byte(C); { Copy character }
End;
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ KEYBOARD SUPPORT ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ GetAltCode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION GetAltCode (Ch: Char): Word;
BEGIN
GetAltCode := 0; { Preset zero return }
Ch := UpCase(Ch); { Convert upper case }
If (Ch < #128) Then
GetAltCode := AltCodes[Ord(Ch)] SHL 8 { Return code }
Else If (Ch = #240) Then GetAltCode := $0200 { Return code }
Else GetAltCode := 0; { Return zero }
END;
{---------------------------------------------------------------------------}
{ GetCtrlCode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION GetCtrlCode (Ch: Char): Word;
BEGIN
GetCtrlCode := GetAltCode(Ch) OR (Ord(Ch) - $40); { Ctrl+key code }
END;
{---------------------------------------------------------------------------}
{ GetAltChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION GetAltChar (KeyCode: Word): Char;
VAR I: Sw_Integer;
BEGIN
GetAltChar := #0; { Preset fail return }
If (Lo(KeyCode) = 0) Then Begin { Extended key }
If (Hi(KeyCode) <= $83) Then Begin { Highest value in list }
I := 0; { Start at first }
While (I < 128) AND (Hi(KeyCode) <> AltCodes[I])
Do Inc(I); { Search for match }
If (I < 128) Then GetAltChar := Chr(I); { Return character }
End Else
If (Hi(KeyCode)=$02) Then GetAltChar := #240; { Return char }
End;
END;
{---------------------------------------------------------------------------}
{ GetCtrlChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION GetCtrlChar (KeyCode: Word): Char;
VAR C: Char;
BEGIN
C := #0; { Preset #0 return }
If (Lo(KeyCode) > 0) AND (Lo(KeyCode) <= 26) Then { Between 1-26 }
C := Chr(Lo(KeyCode) + $40); { Return char A-Z }
GetCtrlChar := C; { Return result }
END;
{---------------------------------------------------------------------------}
{ CtrlToArrow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25May96 LdB }
{---------------------------------------------------------------------------}
FUNCTION CtrlToArrow (KeyCode: Word): Word;
CONST NumCodes = 11;
CtrlCodes : Array [0..NumCodes-1] Of Char =
(#19, #4, #5, #24, #1, #6, #7, #22, #18, #3, #8);
ArrowCodes: Array [0..NumCodes-1] Of Sw_Word =
(kbLeft, kbRight, kbUp, kbDown, kbHome, kbEnd, kbDel, kbIns,
kbPgUp, kbPgDn, kbBack);
VAR I: Sw_Integer;
BEGIN
CtrlToArrow := KeyCode; { Preset key return }
For I := 0 To NumCodes - 1 Do
If WordRec(KeyCode).Lo = Byte(CtrlCodes[I]) { Matches a code }
Then Begin
CtrlToArrow := ArrowCodes[I]; { Return key stroke }
Exit; { Now exit }
End;
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ KEYBOARD CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ GetShiftState -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Jul96 LdB }
{---------------------------------------------------------------------------}
FUNCTION GetShiftState: Byte;
begin
GetShiftState:=Keyboard.GetKeyEventShiftState(Keyboard.PollShiftStateEvent);
end;
{---------------------------------------------------------------------------}
{ GetKeyEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB }
{---------------------------------------------------------------------------}
procedure GetKeyEvent (Var Event: TEvent);
var
key : TKeyEvent;
keycode : Word;
keyshift : byte;
begin
if Keyboard.PollKeyEvent<>0 then
begin
key:=Keyboard.GetKeyEvent;
keycode:=Keyboard.GetKeyEventCode(key);
keyshift:=KeyBoard.GetKeyEventShiftState(key);
// some kbds still honour old XT E0 prefix. (org IBM ps/2, win98?) bug #8978
if (keycode and $FF = $E0) and
(byte(keycode shr 8) in
[$1C,$1D,$2A,$35..$38,$46..$49,$4b,$4d,$4f,$50..$53]) Then
keycode := keycode and $FF00;
{ fixup shift-keys }
if keyshift and kbShift<>0 then
begin
case keycode of
$5200 : keycode:=kbShiftIns;
$5300 : keycode:=kbShiftDel;
$8500 : keycode:=kbShiftF1;
$8600 : keycode:=kbShiftF2;
end;
end
{ fixup ctrl-keys }
else if keyshift and kbCtrl<>0 then
begin
case keycode of
$5200,
$9200 : keycode:=kbCtrlIns;
$5300,
$9300 : keycode:=kbCtrlDel;
end;
end
{ fixup alt-keys }
else if keyshift and kbAlt<>0 then
begin
case keycode of
$0e08,
$0e00 : keycode:=kbAltBack;
end;
end
{ fixup normal keys }
else
begin
case keycode of
$e00d : keycode:=kbEnter;
end;
end;
Event.What:=evKeyDown;
Event.KeyCode:=keycode;
{$ifdef ENDIAN_LITTLE}
Event.CharCode:=chr(keycode and $ff);
Event.ScanCode:=keycode shr 8;
{$endif ENDIAN_LITTLE}
Event.KeyShift:=keyshift;
end
else
Event.What:=evNothing;
end;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ MOUSE CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ HideMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun98 LdB }
{---------------------------------------------------------------------------}
procedure HideMouse;
begin
{ Is mouse hidden yet?
If (HideCount = 0) Then}
Mouse.HideMouse;
{ Inc(HideCount);}
end;
{---------------------------------------------------------------------------}
{ ShowMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jun98 LdB }
{---------------------------------------------------------------------------}
procedure ShowMouse;
begin
{ if HideCount>0 then
dec(HideCount);
if (HideCount=0) then}
Mouse.ShowMouse;
end;
{---------------------------------------------------------------------------}
{ GetMouseEvent -> Platforms DOS/DPMI/WINDOWS/OS2 - Updated 30Jun98 LdB }
{---------------------------------------------------------------------------}
procedure GetMouseEvent (Var Event: TEvent);
var
e : Mouse.TMouseEvent;
begin
if Mouse.PollMouseEvent(e) then
begin
Mouse.GetMouseEvent(e);
MouseWhere.X:=e.x;
MouseWhere.Y:=e.y;
Event.Double:=false;
case e.Action of
MouseActionMove :
Event.What:=evMouseMove;
MouseActionDown :
begin
Event.What:=evMouseDown;
if (DownButtons=e.Buttons) and (LastWhere.X=MouseWhere.X) and (LastWhere.Y=MouseWhere.Y) and
(GetDosTicks-DownTicks<=DoubleDelay) then
Event.Double:=true;
DownButtons:=e.Buttons;
DownWhere.X:=MouseWhere.x;
DownWhere.Y:=MouseWhere.y;
DownTicks:=GetDosTicks;
AutoTicks:=GetDosTicks;
if AutoTicks=0 then
AutoTicks:=1;
AutoDelay:=RepeatDelay;
end;
MouseActionUp :
begin
AutoTicks:=0;
Event.What:=evMouseUp;
AutoTicks:=0;
end;
end;
Event.Buttons:=e.Buttons;
Event.Where.X:=MouseWhere.x;
Event.Where.Y:=MouseWhere.y;
LastButtons:=Event.Buttons;
LastWhere.x:=Event.Where.x;
LastWhere.y:=Event.Where.y;
end
else if (AutoTicks <> 0) and (GetDosTicks >= AutoTicks + AutoDelay) then
begin
Event.What:=evMouseAuto;
Event.Buttons:=LastButtons;
Event.Where.X:=LastWhere.x;
Event.Where.Y:=LastWhere.y;
AutoTicks:=GetDosTicks;
AutoDelay:=1;
end
else
FillChar(Event,sizeof(TEvent),0);
if MouseReverse and ((Event.Buttons and 3) in [1,2]) then
Event.Buttons := Event.Buttons xor 3;
end;
{---------------------------------------------------------------------------}
{ GetSystemEvent }
{---------------------------------------------------------------------------}
procedure GetSystemEvent (Var Event: TEvent);
var
SysEvent : TsystemEvent;
begin
if PollSystemEvent(SysEvent) then
begin
SysMsg.GetSystemEvent(SysEvent);
case SysEvent.typ of
SysNothing :
Event.What:=evNothing;
SysSetFocus :
begin
Event.What:=evBroadcast;
Event.Command:=cmReceivedFocus;
end;
SysReleaseFocus :
begin
Event.What:=evBroadcast;
Event.Command:=cmReleasedFocus;
end;
SysClose :
begin
Event.What:=evCommand;
Event.Command:=cmQuitApp;
end;
SysResize :
begin
Event.What:=evCommand;
Event.Command:=cmResizeApp;
Event.Id:=SysEvent.x;
Event.InfoWord:=SysEvent.y;
end;
else
Event.What:=evNothing;
end;
end
else
Event.What:=evNothing;
end;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ EVENT HANDLER CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ InitEvents -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 07Sep99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE InitEvents;
BEGIN
If (ButtonCount <> 0) Then
begin { Mouse is available }
Mouse.InitMouse; { Hook the mouse }
{ this is required by the use of HideCount variable }
Mouse.ShowMouse; { visible by default }
{ HideCount:=0; }
LastButtons := 0; { Clear last buttons }
DownButtons := 0; { Clear down buttons }
MouseWhere.X:=Mouse.GetMouseX;
MouseWhere.Y:=Mouse.GetMouseY; { Get mouse position }
LastWhere.x:=MouseWhere.x;
LastWhereX:=MouseWhere.x;
LastWhere.y:=MouseWhere.y;
LastWhereY:=MouseWhere.y;
MouseEvents := True; { Set initialized flag }
end;
InitSystemMsg;
END;
{---------------------------------------------------------------------------}
{ DoneEvents -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 30Jul99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE DoneEvents;
BEGIN
DoneSystemMsg;
Mouse.DoneMouse;
MouseEvents:=false;
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ VIDEO CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
const
VideoInitialized : boolean = false;
{---------------------------------------------------------------------------}
{ InitKeyboard -> Platforms ALL - 07May06 DM }
{---------------------------------------------------------------------------}
procedure initkeyboard;inline;
begin
keyboard.initkeyboard;
end;
{---------------------------------------------------------------------------}
{ DoneKeyboard -> Platforms ALL - 07May06 DM }
{---------------------------------------------------------------------------}
procedure donekeyboard;inline;
begin
keyboard.donekeyboard;
end;
{---------------------------------------------------------------------------}
{ InitVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Nov99 LdB }
{---------------------------------------------------------------------------}
function InitVideo:boolean;
var StoreScreenMode : TVideoMode;
begin
initvideo:=false;
if VideoInitialized then
begin
StoreScreenMode:=ScreenMode;
DoneVideo;
end
else
StoreScreenMode.Col:=0;
Video.InitVideo;
if video.errorcode<>viook then
exit;
GetVideoMode(StartupScreenMode);
GetVideoMode(ScreenMode);
{$ifdef OS_WINDOWS}
{ Force the console to the current screen mode }
Video.SetVideoMode(ScreenMode);
{$endif OS_WINDOWS}
If (StoreScreenMode.Col<>0) and
((StoreScreenMode.color<>ScreenMode.color) or
(StoreScreenMode.row<>ScreenMode.row) or
(StoreScreenMode.col<>ScreenMode.col)) then
begin
Video.SetVideoMode(StoreScreenMode);
GetVideoMode(ScreenMode);
end;
if ScreenWidth > MaxViewWidth then
ScreenWidth := MaxViewWidth;
ScreenWidth:=Video.ScreenWidth;
ScreenHeight:=Video.ScreenHeight;
VideoInitialized:=true;
initvideo:=true;
end;
{---------------------------------------------------------------------------}
{ DoneVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB }
{---------------------------------------------------------------------------}
PROCEDURE DoneVideo;
BEGIN
if not VideoInitialized then
exit;
Video.SetVideoMode(StartupScreenMode);
Video.ClearScreen;
Video.SetCursorPos(0,0);
Video.DoneVideo;
VideoInitialized:=false;
END;
{---------------------------------------------------------------------------}
{ ClearScreen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 04Jan97 LdB }
{---------------------------------------------------------------------------}
PROCEDURE ClearScreen;
BEGIN
Video.ClearScreen;
END;
{---------------------------------------------------------------------------}
{ SetVideoMode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10Nov99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE SetVideoMode (Mode: Sw_Word);
BEGIN
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ ERROR CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ InitSysError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB }
{---------------------------------------------------------------------------}
PROCEDURE InitSysError;
BEGIN
SysErrActive := True; { Set active flag }
END;
{---------------------------------------------------------------------------}
{ DoneSysError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB }
{---------------------------------------------------------------------------}
PROCEDURE DoneSysError;
BEGIN
SysErrActive := False; { Clear active flag }
END;
{---------------------------------------------------------------------------}
{ SystemError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 20May98 LdB }
{---------------------------------------------------------------------------}
FUNCTION SystemError (ErrorCode: Sw_Integer; Drive: Byte): Sw_Integer;
BEGIN
If (FailSysErrors = False) Then Begin { Check error ignore }
End Else SystemError := 1; { Return 1 for ignored }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ STRING FORMAT ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ PrintStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18Feb99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE PrintStr (CONST S: String);
BEGIN
Write(S); { Write to screen }
END;
{---------------------------------------------------------------------------}
{ FormatStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 13Jul99 LdB }
{---------------------------------------------------------------------------}
procedure FormatStr (Var Result: String; CONST Format: String; Var Params);
TYPE TLongArray = Array[0..0] Of PtrInt;
VAR W, ResultLength : integer;
FormatIndex, Justify, Wth: Byte;
Fill: Char; S: String;
FUNCTION LongToStr (L: Longint; Radix: Byte): String;
CONST HexChars: Array[0..15] Of Char =
('0', '1', '2', '3', '4', '5', '6', '7',
'8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
VAR I: LongInt; S: String; Sign: String[1];
begin
LongToStr := ''; { Preset empty return }
If (L < 0) Then begin { If L is negative }
Sign := '-'; { Sign is negative }
L := Abs(L); { Convert to positive }
end Else Sign := ''; { Sign is empty }
S := ''; { Preset empty string }
Repeat
I := L MOD Radix; { Radix mod of value }
S := HexChars[I] + S; { Add char to string }
L := L DIV Radix; { Divid by radix }
Until (L = 0); { Until no remainder }
LongToStr := Sign + S; { Return result }
end;
procedure HandleParameter (I : LongInt);
begin
While (FormatIndex <= Length(Format)) Do begin { While length valid }
if ResultLength>=High(Result) then
exit;
While (FormatIndex <= Length(Format)) and
(Format[FormatIndex] <> '%') { Param char not found }
Do begin
Result[ResultLength+1] := Format[FormatIndex]; { Transfer character }
Inc(ResultLength); { One character added }
Inc(FormatIndex); { Next param char }
end;
If (FormatIndex < Length(Format)) and { Not last char and }
(Format[FormatIndex] = '%') Then begin { '%' char found }
Fill := ' '; { Default fill char }
Justify := 0; { Default justify }
Wth := 0; { Default 0=no width }
Inc(FormatIndex); { Next character }
If (Format[FormatIndex] = '0') Then
Fill := '0'; { Fill char to zero }
If (Format[FormatIndex] = '-') Then begin { Optional just char }
Justify := 1; { Right justify }
Inc(FormatIndex); { Next character }
end;
While ((FormatIndex <= Length(Format)) and { Length still valid }
(Format[FormatIndex] >= '0') and
(Format[FormatIndex] <= '9')) Do begin { Numeric character }
Wth := Wth * 10; { Multiply x10 }
Wth := Wth + Ord(Format[FormatIndex])-$30; { Add numeric value }
Inc(FormatIndex); { Next character }
end;
If ((FormatIndex <= Length(Format)) and { Length still valid }
(Format[FormatIndex] = '#')) Then begin { Parameter marker }
Inc(FormatIndex); { Next character }
HandleParameter(Wth); { Width is param idx }
end;
If (FormatIndex <= Length(Format)) Then begin{ Length still valid }
Case Format[FormatIndex] Of
'%': begin { Literal % }
S := '%';
Inc(FormatIndex);
Move(S[1], Result[ResultLength+1], 1);
Inc(ResultLength,Length(S));
Continue;
end;
'c': S := Char(TLongArray(Params)[I]); { Character parameter }
'd': S := LongToStr(TLongArray(Params)[I],
10); { Decimal parameter }
's': S := PString(TLongArray(Params)[I])^;{ String parameter }
'x': S := LongToStr(TLongArray(Params)[I],
16); { Hex parameter }
end;
Inc(FormatIndex); { Next character }
If (Wth > 0) Then begin { Width control active }
If (Length(S) > Wth) Then begin { We must shorten S }
If (Justify=1) Then { Check right justify }
S := Copy(S, Length(S)-Wth+1, Wth) { Take right side data }
Else S := Copy(S, 1, Wth); { Take left side data }
end Else begin { We must pad out S }
If (Justify=1) Then { Right justify }
While (Length(S) < Wth) Do
S := S+Fill Else { Right justify fill }
While (Length(S) < Wth) Do
S := Fill + S; { Left justify fill }
end;
end;
W:=Length(S);
if W+ResultLength+1>High(Result) then
W:=High(Result)-ResultLength;
Move(S[1], Result[ResultLength+1],
W); { Move data to result }
Inc(ResultLength,W); { Adj result length }
Inc(I);
end;
end;
end;
end;
begin
ResultLength := 0; { Zero result length }
FormatIndex := 1; { Format index to 1 }
HandleParameter(0); { Handle parameter }
Result[0] := Chr(ResultLength); { Set string length }
end;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ NEW QUEUED EVENT HANDLER ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ PutEventInQueue -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Mar98 LdB }
{---------------------------------------------------------------------------}
FUNCTION PutEventInQueue (Var Event: TEvent): Boolean;
BEGIN
If (QueueCount < QueueMax) Then Begin { Check room in queue }
Queue[QueueHead] := Event; { Store event }
Inc(QueueHead); { Inc head position }
If (QueueHead = QueueMax) Then QueueHead := 0; { Roll to start check }
Inc(QueueCount); { Inc queue count }
PutEventInQueue := True; { Return successful }
End Else PutEventInQueue := False; { Return failure }
END;
{---------------------------------------------------------------------------}
{ NextQueuedEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 17Mar98 LdB }
{---------------------------------------------------------------------------}
PROCEDURE NextQueuedEvent(Var Event: TEvent);
BEGIN
If (QueueCount > 0) Then Begin { Check queued event }
Event := Queue[QueueTail]; { Fetch next event }
Inc(QueueTail); { Inc tail position }
If (QueueTail = QueueMax) Then QueueTail := 0; { Roll to start check }
Dec(QueueCount); { Dec queue count }
End Else Event.What := evNothing; { Return empty event }
END;
{***************************************************************************}
{ UNIT INITIALIZATION ROUTINE }
{***************************************************************************}
BEGIN
{$IFDEF OS_AMIGA}
StartupTicks := (dos.GetMsCount div 55);
{$ENDIF}
ButtonCount := DetectMouse; { Detect mouse }
DetectVideo; { Detect video }
{ InitKeyboard;}
InitSystemMsg;
{$ifdef OS_WINDOWS}
SetFileApisToOEM;
{$endif}
SaveExit := ExitProc; { Save old exit }
ExitProc := @ExitDrivers; { Set new exit }
END.