mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-19 22:02:40 +02:00
581 lines
15 KiB
ObjectPascal
581 lines
15 KiB
ObjectPascal
unit WinCrt;
|
|
|
|
interface
|
|
|
|
Uses Windows;
|
|
|
|
type
|
|
WinReadKeyRecord = record
|
|
KeyStatus: byte;
|
|
AsciiChar: char;
|
|
KeyCode: word;
|
|
end;
|
|
|
|
const
|
|
|
|
// Foreground color constants
|
|
|
|
fBlack = 0;
|
|
fBlue = FOREGROUND_BLUE;
|
|
fGreen = FOREGROUND_GREEN;
|
|
fCyan = FOREGROUND_BLUE OR FOREGROUND_GREEN;
|
|
fRed = FOREGROUND_RED;
|
|
fMagenta = FOREGROUND_BLUE OR FOREGROUND_RED;
|
|
fBrown = FOREGROUND_GREEN OR FOREGROUND_RED;
|
|
fLightGray = FOREGROUND_BLUE OR FOREGROUND_GREEN OR FOREGROUND_RED;
|
|
fDarkGray = fBlack OR FOREGROUND_INTENSITY;
|
|
fLightBlue = fBlue OR FOREGROUND_INTENSITY;
|
|
fLightGreen = fGreen OR FOREGROUND_INTENSITY;
|
|
fLightCyan = fCyan OR FOREGROUND_INTENSITY;
|
|
fLightRed = fRed OR FOREGROUND_INTENSITY;
|
|
fLightMagenta = fMagenta OR FOREGROUND_INTENSITY;
|
|
fYellow = fBrown OR FOREGROUND_INTENSITY;
|
|
fWhite = fLightGray OR FOREGROUND_INTENSITY;
|
|
|
|
// Background color constants
|
|
|
|
bBlack = 0;
|
|
bBlue = BACKGROUND_BLUE;
|
|
bGreen = BACKGROUND_GREEN;
|
|
bCyan = BACKGROUND_BLUE OR BACKGROUND_GREEN;
|
|
bRed = BACKGROUND_RED;
|
|
bMagenta = BACKGROUND_BLUE OR BACKGROUND_RED;
|
|
bBrown = BACKGROUND_GREEN OR BACKGROUND_RED;
|
|
bLightGray = BACKGROUND_BLUE OR BACKGROUND_GREEN OR BACKGROUND_RED;
|
|
bDarkGray = bBlack OR BACKGROUND_INTENSITY;
|
|
bLightBlue = bBlue OR BACKGROUND_INTENSITY;
|
|
bLightGreen = bGreen OR BACKGROUND_INTENSITY;
|
|
bLightCyan = bCyan OR BACKGROUND_INTENSITY;
|
|
bLightRed = bRed OR BACKGROUND_INTENSITY;
|
|
bLightMagenta = bMagenta OR BACKGROUND_INTENSITY;
|
|
bYellow = bBrown OR BACKGROUND_INTENSITY;
|
|
bWhite = bLightGray OR BACKGROUND_INTENSITY;
|
|
|
|
// Constants designating input events
|
|
|
|
NO_EVENT = 0;
|
|
KEY_EVENT_IN_PROGRESS = $100;
|
|
_MOUSE_EVENT_IN_PROGRESS = $200;
|
|
|
|
procedure ClrEol;
|
|
{ Clears all characters from cursor position to end of line without
|
|
moving the cursor by filling character cells with blanks
|
|
and attribute cells with the current screen buffer attribute.
|
|
}
|
|
procedure ClrScr;
|
|
{ Clears screen buffer by filling character cells with blanks
|
|
and attribute cells with the current screen buffer attribute.
|
|
The cursor is positioned in the top left corner of the screen
|
|
buffer
|
|
}
|
|
procedure FlushInputBuffer;
|
|
function GetTextBackground: byte;
|
|
function GetTextColor: byte;
|
|
Procedure GotoXY(X, Y: integer);
|
|
Procedure HighVideo;
|
|
Procedure HighVideoBackground;
|
|
Function InputEvent: word;
|
|
{ Returns
|
|
NO_EVENT if input buffer is empty ;
|
|
KEY_EVENT if there is a pending key event with
|
|
key released again,
|
|
and key is not one of the control keys;
|
|
KEY_EVENT_IN_PROGRESS if there is another pending key event;
|
|
_MOUSE_EVENT if there is a pending mouse event
|
|
without moving the mouse;
|
|
_MOUSE_EVENT_IN_PROGRESS if there is another pending mouse event;
|
|
WINDOW_BUFFER_SIZE_EVENT is the user resized the screen buffer
|
|
and window input is enabled (default mode disabled).
|
|
}
|
|
function KeyPressed: boolean;
|
|
{ Returns
|
|
TRUE if there is a pending key event with
|
|
key released again,
|
|
and key is not one of the control keys;
|
|
FALSE otherwise.
|
|
}
|
|
Procedure LowVideo;
|
|
Procedure LowVideoBackground;
|
|
Procedure NormVideo;
|
|
Procedure NormVideoBackground;
|
|
Function ReadKey: char;
|
|
Procedure TextBackground (Color: Byte);
|
|
Procedure TextColor (Color: Byte);
|
|
Function WhereX: integer;
|
|
Function WhereY: integer;
|
|
Function WinReadKey: WinReadKeyRecord;
|
|
{ Return value in KeyStatus element:
|
|
- bit 0: shift key pressed
|
|
- bit 1: ctrl key pressed
|
|
- bit 2: alt key pressed
|
|
The KeyCode element has the virtual key code.
|
|
|
|
N.B. nog regelen: extended ASCII via Alt-keypad toetsen.
|
|
}
|
|
|
|
implementation
|
|
|
|
type
|
|
PInputBuffer = ^TInputBuffer;
|
|
TInputBuffer = array[word] of TInputRecord;
|
|
|
|
var
|
|
StartTextIntensity, StartBackgroundIntensity: byte;
|
|
pCsbi: PConsoleScreenBufferInfo;
|
|
|
|
function GetScreenInfo: TConsoleScreenBufferInfo; forward;
|
|
Function RemapScanCode (ScanCode: byte; CtrlKeyState: byte): byte; forward;
|
|
|
|
procedure ClrEol;
|
|
var
|
|
hConsoleOutput: THandle;
|
|
cCharacter: Char;
|
|
wAttribute: word;
|
|
nLength: dword;
|
|
dwWriteCoord: TCoord;
|
|
lpWritten: dword;
|
|
begin
|
|
hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);
|
|
cCharacter := ' ';
|
|
New(pCsbi);
|
|
GetConsoleScreenBufferInfo(hConsoleOutput, pCsbi^);
|
|
wAttribute := pCsbi^.wAttributes;
|
|
nLength := pCsbi^.dwSize.X - pCsbi^.dwCursorPosition.X + 1;
|
|
dwWriteCoord.X := pCsbi^.dwCursorPosition.X;
|
|
dwWriteCoord.Y := pCsbi^.dwCursorPosition.Y;
|
|
Dispose(pCsbi);
|
|
FillConsoleOutputCharacter(hConsoleOutput, cCharacter, nLength,
|
|
dwWriteCoord, lpWritten);
|
|
FillConsoleOutputAttribute(hConsoleOutput, wAttribute, nLength,
|
|
dwWriteCoord, lpWritten);
|
|
end;
|
|
|
|
procedure ClrScr;
|
|
var
|
|
hConsoleOutput: THandle;
|
|
cCharacter: Char;
|
|
wAttribute: word;
|
|
nLength: dword;
|
|
dwWriteCoord: TCoord;
|
|
lpWritten: dword;
|
|
begin
|
|
hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);
|
|
cCharacter := ' ';
|
|
New(pCsbi);
|
|
GetConsoleScreenBufferInfo(hConsoleOutput, pCsbi^);
|
|
wAttribute := pCsbi^.wAttributes;
|
|
nLength := pCsbi^.dwSize.X * pCsbi^.dwSize.Y;
|
|
Dispose(pCsbi);
|
|
dwWriteCoord.X := 0;
|
|
dwWriteCoord.Y := 0;
|
|
FillConsoleOutputCharacter(hConsoleOutput, cCharacter, nLength,
|
|
dwWriteCoord, lpWritten);
|
|
FillConsoleOutputAttribute(hConsoleOutput, wAttribute, nLength,
|
|
dwWriteCoord, lpWritten);
|
|
SetConsoleCursorPosition(hConsoleOutput, dwWriteCoord);
|
|
end;
|
|
|
|
procedure FlushInputBuffer;
|
|
begin
|
|
FlushConsoleInputBuffer(GetStdHandle(STD_INPUT_HANDLE));
|
|
end;
|
|
|
|
function GetTextBackground: byte;
|
|
begin
|
|
Result := GetScreenInfo.wAttributes AND bWhite;
|
|
end;
|
|
|
|
function GetTextColor: byte;
|
|
begin
|
|
Result := GetScreenInfo.wAttributes AND fWhite;
|
|
end;
|
|
|
|
function GetScreenInfo: TConsoleScreenBufferInfo;
|
|
begin
|
|
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), Result);
|
|
end;
|
|
|
|
Procedure GotoXY(X, Y: integer);
|
|
var
|
|
CoordCursor: TCoord;
|
|
begin
|
|
CoordCursor.X := X - 1;
|
|
CoordCursor.Y := Y - 1;
|
|
SetConsoleCursorPosition(GetStdHandle(STD_OUTPUT_HANDLE), CoordCursor);
|
|
end;
|
|
|
|
Procedure HighVideo;
|
|
var
|
|
Attribute: word;
|
|
begin
|
|
Attribute := GetScreenInfo.wAttributes;
|
|
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
|
|
Attribute OR FOREGROUND_INTENSITY);
|
|
end;
|
|
|
|
Procedure HighVideoBackground;
|
|
var
|
|
Attribute: word;
|
|
begin
|
|
Attribute := GetScreenInfo.wAttributes;
|
|
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
|
|
Attribute OR BACKGROUND_INTENSITY);
|
|
end;
|
|
|
|
Function InputEvent: word;
|
|
var
|
|
hConsoleInput: THandle;
|
|
pInput: pInputBuffer;
|
|
lpNumberOfEvents: dword;
|
|
lpNumberRead: integer;
|
|
i: word;
|
|
|
|
const
|
|
KeysToSkip: set of byte =
|
|
[VK_SHIFT, VK_CONTROL, VK_MENU, VK_CAPITAL, VK_NUMLOCK, VK_SCROLL];
|
|
|
|
begin
|
|
hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
|
|
GetNumberOfConsoleInputEvents(hConsoleInput, lpNumberOfEvents);
|
|
Result := NO_EVENT;
|
|
if lpNumberOfEvents > 0 then
|
|
try
|
|
GetMem(pInput, lpNumberOfEvents * SizeOf(TInputRecord));
|
|
PeekConsoleInput(hConsoleInput, pInput^[0], lpNumberOfEvents, lpNumberRead);
|
|
i := 0;
|
|
repeat
|
|
with pInput^[i] do begin
|
|
case EventType of
|
|
KEY_EVENT:
|
|
if (KeyEvent.bKeyDown = false) and
|
|
not (KeyEvent.wVirtualKeyCode in KeysToSkip) then
|
|
Result := EventType
|
|
else
|
|
Result := KEY_EVENT_IN_PROGRESS;
|
|
_MOUSE_EVENT:
|
|
if (MouseEvent.dwEventFlags <> MOUSE_MOVED) then
|
|
Result := EventType
|
|
else
|
|
Result := _MOUSE_EVENT_IN_PROGRESS;
|
|
else
|
|
Result := EventType;
|
|
end;
|
|
end;
|
|
inc(i);
|
|
until (Result <> NO_EVENT) or (i >= lpNumberOfEvents);
|
|
finally
|
|
FreeMem(pInput);
|
|
end;
|
|
end;
|
|
|
|
Function KeyPressed: boolean;
|
|
var
|
|
hConsoleInput: THandle;
|
|
pInput: pInputBuffer;
|
|
lpNumberOfEvents: dword;
|
|
lpNumberRead: integer;
|
|
i: word;
|
|
|
|
const
|
|
KeysToSkip: set of byte =
|
|
[VK_SHIFT, VK_CONTROL, VK_MENU, VK_CAPITAL, VK_NUMLOCK, VK_SCROLL];
|
|
|
|
begin
|
|
hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
|
|
GetNumberOfConsoleInputEvents(hConsoleInput, lpNumberOfEvents);
|
|
Result := FALSE;
|
|
if lpNumberOfEvents > 0 then
|
|
try
|
|
GetMem(pInput, lpNumberOfEvents * SizeOf(TInputRecord));
|
|
PeekConsoleInput(hConsoleInput, pInput^[0], lpNumberOfEvents, lpNumberRead);
|
|
i := 0;
|
|
repeat
|
|
with pInput^[i] do begin
|
|
if EventType = KEY_EVENT then
|
|
Result := (KeyEvent.bKeyDown = false) and
|
|
not (KeyEvent.wVirtualKeyCode in KeysToSkip);
|
|
end;
|
|
inc(i);
|
|
until (Result = TRUE) or (i >= lpNumberOfEvents);
|
|
finally
|
|
FreeMem(pInput);
|
|
end;
|
|
end;
|
|
|
|
Procedure LowVideo;
|
|
var
|
|
Attribute: word;
|
|
begin
|
|
Attribute := GetScreenInfo.wAttributes;
|
|
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
|
|
Attribute AND NOT FOREGROUND_INTENSITY);
|
|
end;
|
|
|
|
Procedure LowVideoBackground;
|
|
var
|
|
Attribute: word;
|
|
begin
|
|
Attribute := GetScreenInfo.wAttributes;
|
|
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
|
|
Attribute AND NOT BACKGROUND_INTENSITY);
|
|
end;
|
|
Procedure NormVideo;
|
|
var
|
|
Attribute: word;
|
|
begin
|
|
Attribute := GetScreenInfo.wAttributes;
|
|
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
|
|
Attribute AND (fLightGray OR bWhite) OR StartTextIntensity);
|
|
end;
|
|
|
|
Procedure NormVideoBackground;
|
|
var
|
|
Attribute: word;
|
|
begin
|
|
Attribute := GetScreenInfo.wAttributes;
|
|
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
|
|
Attribute AND (fWhite OR bLightGray) OR StartBackgroundIntensity);
|
|
end;
|
|
|
|
Function ReadKey: char;
|
|
var
|
|
hConsoleInput: THandle;
|
|
pInput: pInputRecord;
|
|
lpcRead: integer;
|
|
AltKey, CtrlKey, ShiftKey: boolean;
|
|
|
|
const
|
|
ExtendedChar: boolean = false;
|
|
Scancode: byte = 0;
|
|
{
|
|
Scancodes to skip:
|
|
|
|
$1D - Ctrl keys
|
|
$2A - left Shift key
|
|
$36 - right Shift key
|
|
$38 - Alt keys
|
|
$3A - Caps lock key
|
|
$45 - Num lock key
|
|
$46 - Scroll lock key
|
|
}
|
|
ScanCodesToSkip: set of 0..255 =
|
|
[$1D, $2A, $36, $38, $3A, $45, $46];
|
|
|
|
begin
|
|
if not ExtendedChar then begin
|
|
hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
|
|
try
|
|
New(pInput);
|
|
with pInput^.KeyEvent do begin
|
|
Repeat
|
|
ReadConsoleInput(hConsoleInput, pInput^, 1, lpcRead);
|
|
until (pInput^.EventType = KEY_EVENT)
|
|
and (bKeyDown = false)
|
|
and not (wVirtualScanCode in ScanCodesToSkip);
|
|
|
|
{ Get state of control keys }
|
|
|
|
AltKey := ((dwControlKeyState AND
|
|
(RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
|
|
CtrlKey := ((dwControlKeyState AND
|
|
(RIGHT_CTRL_PRESSED OR LEFT_CTRL_PRESSED)) > 0);
|
|
ShiftKey := ((dwControlKeyState AND SHIFT_PRESSED) > 0);
|
|
|
|
{ Get key value, making some corrections to comply with MSDOS}
|
|
|
|
if AltKey then
|
|
Result := #0
|
|
else begin
|
|
Result := AsciiChar;
|
|
if CtrlKey then
|
|
case wVirtualScanCode of
|
|
$07: Result := #$1E; // ^_6 (Win32 gives ASCII = 0)
|
|
$0C: Result := #$1F; // ^_- (Win32 gives ASCII = 0)
|
|
end
|
|
else if ShiftKey then
|
|
case wVirtualScanCode of
|
|
$01: Result := #$1B; // Shift Esc (Win32 gives ASCII = 0)
|
|
$0F: Result := #0; // Shift Tab (Win32 gives ASCII = 9)
|
|
end;
|
|
end;
|
|
|
|
{Save scancode of non-ASCII keys for second call}
|
|
|
|
if (Result = #0) then begin
|
|
ExtendedChar := true;
|
|
ScanCode := RemapScanCode(wVirtualScanCode, dwControlKeyState);
|
|
end;
|
|
end;
|
|
finally
|
|
Dispose(pInput);
|
|
end;
|
|
end
|
|
else begin
|
|
Result := char(ScanCode);
|
|
ExtendedChar := false;
|
|
end;
|
|
end;
|
|
|
|
Function RemapScanCode (ScanCode: byte; CtrlKeyState: byte): byte;
|
|
|
|
{ Several remappings of scancodes are necessary to comply with what
|
|
we get with MSDOS. Special Windows keys, as Alt-Tab, Ctrl-Esc etc.
|
|
are excluded }
|
|
|
|
var
|
|
AltKey, CtrlKey, ShiftKey: boolean;
|
|
const
|
|
{
|
|
Keypad key scancodes:
|
|
|
|
Ctrl Norm
|
|
|
|
$77 $47 - Home
|
|
$8D $48 - Up arrow
|
|
$84 $49 - PgUp
|
|
$8E $4A - -
|
|
$73 $4B - Left Arrow
|
|
$8F $4C - 5
|
|
$74 $4D - Right arrow
|
|
$4E $4E - +
|
|
$75 $4F - End
|
|
$91 $50 - Down arrow
|
|
$76 $51 - PgDn
|
|
$92 $52 - Ins
|
|
$93 $53 - Del
|
|
}
|
|
CtrlKeypadKeys: array[$47..$53] of byte =
|
|
($77, $8D, $84, $8E, $73, $8F, $74, $4E, $75, $91, $76, $92, $93);
|
|
|
|
begin
|
|
AltKey := ((CtrlKeyState AND
|
|
(RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
|
|
CtrlKey := ((CtrlKeyState AND
|
|
(RIGHT_CTRL_PRESSED OR LEFT_CTRL_PRESSED)) > 0);
|
|
ShiftKey := ((CtrlKeyState AND SHIFT_PRESSED) > 0);
|
|
if AltKey then
|
|
case ScanCode of
|
|
// Digits, -, =
|
|
$02..$0D: inc(ScanCode, $76);
|
|
// Function keys
|
|
$3B..$44: inc(Scancode, $2D);
|
|
$57..$58: inc(Scancode, $34);
|
|
// Extended cursor block keys
|
|
$47..$49, $4B, $4D, $4F..$53:
|
|
inc(Scancode, $50);
|
|
// Other keys
|
|
$1C: Scancode := $A6; // Enter
|
|
$35: Scancode := $A4; // / (keypad and normal!)
|
|
end
|
|
else if CtrlKey then
|
|
case Scancode of
|
|
// Tab key
|
|
$0F: Scancode := $94;
|
|
// Function keys
|
|
$3B..$44: inc(Scancode, $23);
|
|
$57..$58: inc(Scancode, $32);
|
|
// Keypad keys
|
|
$35: Scancode := $95; // \
|
|
$37: Scancode := $96; // *
|
|
$47..$53: Scancode := CtrlKeypadKeys[Scancode];
|
|
end
|
|
else if ShiftKey then
|
|
case Scancode of
|
|
// Function keys
|
|
$3B..$44: inc(Scancode, $19);
|
|
$57..$58: inc(Scancode, $30);
|
|
end
|
|
else
|
|
case Scancode of
|
|
// Function keys
|
|
$57..$58: inc(Scancode, $2E); // F11 and F12
|
|
end;
|
|
Result := ScanCode;
|
|
end;
|
|
|
|
|
|
Procedure TextBackground (Color: Byte);
|
|
var
|
|
Background, Foreground: byte;
|
|
begin
|
|
Background := Color AND bWhite;
|
|
Foreground := GetScreenInfo.wAttributes AND fWhite;
|
|
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
|
|
Background OR Foreground);
|
|
end;
|
|
|
|
Procedure TextColor (Color: Byte);
|
|
var
|
|
Background, Foreground: byte;
|
|
begin
|
|
Background := GetScreenInfo.wAttributes AND bWhite;
|
|
Foreground := Color AND fWhite;
|
|
SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
|
|
Background OR Foreground);
|
|
end;
|
|
|
|
Function WhereX: integer;
|
|
begin
|
|
Result := GetScreenInfo.dwCursorPosition.X + 1;
|
|
end;
|
|
|
|
Function WhereY: integer;
|
|
begin
|
|
Result := GetScreenInfo.dwCursorPosition.Y + 1;
|
|
end;
|
|
|
|
Function WinReadKey: WinReadKeyRecord;
|
|
var
|
|
hConsoleInput: THandle;
|
|
pInput: pInputRecord;
|
|
lpcRead: integer;
|
|
|
|
const
|
|
KeysToSkip: set of byte =
|
|
[VK_SHIFT, VK_CONTROL, VK_MENU, VK_CAPITAL, VK_NUMLOCK, VK_SCROLL];
|
|
|
|
begin
|
|
hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
|
|
try
|
|
New(pInput);
|
|
with pInput^.KeyEvent do begin
|
|
Repeat
|
|
ReadConsoleInput(hConsoleInput, pInput^, 1, lpcRead);
|
|
until (pInput^.EventType = KEY_EVENT)
|
|
and (bKeyDown = TRUE)
|
|
and not (wVirtualKeyCode in KeysToSkip);
|
|
|
|
{ Get key value }
|
|
|
|
with Result do begin
|
|
|
|
KeyStatus := 0;
|
|
AsciiChar := pInput^.KeyEvent.AsciiChar;
|
|
KeyCode := wVirtualKeyCode;
|
|
|
|
{ Set bits 0..2 of KeyStatus to indicate control key state}
|
|
|
|
if ((dwControlKeyState AND SHIFT_PRESSED) > 0) then
|
|
KeyStatus := (KeyStatus OR $01);
|
|
if ((dwControlKeyState AND
|
|
(RIGHT_CTRL_PRESSED OR LEFT_CTRL_PRESSED)) > 0) then
|
|
KeyStatus := (KeyStatus OR $02);
|
|
if ((dwControlKeyState AND
|
|
(RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0) then
|
|
KeyStatus := (KeyStatus OR $04);
|
|
|
|
end;
|
|
end;
|
|
finally
|
|
Dispose(pInput);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
New(pCsbi);
|
|
pCsbi^ := GetScreenInfo;
|
|
StartTextIntensity := pCsbi^.wAttributes AND FOREGROUND_INTENSITY;
|
|
StartBackgroundIntensity := pCsbi^.wAttributes AND BACKGROUND_INTENSITY;
|
|
Dispose(pCsbi);
|
|
end.
|