paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-09 22:58:26 +02:00
Code Issues Packages Projects Releases Wiki Activity
a8a89995bd
fpc/rtl/win32/crt.pp
peter e34e13439e * Use Widechar in the Windows unit
2002-10-06 20:00:22 +00:00

849 lines
21 KiB
ObjectPascal
Raw Blame History

{
$Id$
Borland Pascal 7 Compatible CRT Unit for win32
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program 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.
**********************************************************************}
unit crt;
interface
const
{ CRT modes }
BW40 = 0; { 40x25 B/W on Color Adapter }
CO40 = 1; { 40x25 Color on Color Adapter }
BW80 = 2; { 80x25 B/W on Color Adapter }
CO80 = 3; { 80x25 Color on Color Adapter }
Mono = 7; { 80x25 on Monochrome Adapter }
Font8x8 = 256; { Add-in for ROM font }
{ Mode constants for 3.0 compatibility }
C40 = CO40;
C80 = CO80;
{ Foreground and background color constants }
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
{ Foreground color constants }
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
{ Add-in for blinking }
Blink = 128;
var
{ Interface variables }
CheckBreak: Boolean; { Enable Ctrl-Break }
CheckEOF: Boolean; { Enable Ctrl-Z }
DirectVideo: Boolean; { Enable direct video addressing }
CheckSnow: Boolean; { Enable snow filtering }
LastMode: Word; { Current text mode }
TextAttr: Byte; { Current text attribute }
WindMin: Word; { Window upper left coordinates }
WindMax: Word; { Window lower right coordinates }
{ FPC Specific for large screen support }
WindMinX : Longint;
WindMaxX : Longint;
WindMinY : Longint;
WindMaxY : Longint;
{ Interface procedures }
procedure AssignCrt(var F: Text);
function KeyPressed: Boolean;
function ReadKey: Char;
procedure TextMode(Mode: Integer);
procedure Window(X1,Y1,X2,Y2: DWord);
procedure GotoXY(X,Y: DWord);
function WhereX: DWord;
function WhereY: DWord;
procedure ClrScr;
procedure ClrEol;
procedure InsLine;
procedure DelLine;
procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
procedure Delay(MS: Word);
procedure Sound(Hz: Word);
procedure NoSound;
{Extra Functions}
procedure cursoron;
procedure cursoroff;
procedure cursorbig;
implementation
uses
windows;
var
SaveCursorSize: Longint;
{
definition of textrec is in textrec.inc
}
{$i textrec.inc}
{****************************************************************************
Low level Routines
****************************************************************************}
procedure TurnMouseOff;
var Mode: DWORD;
begin
if GetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), @Mode) then begin { Turn the mouse-cursor off }
Mode := Mode AND cardinal(NOT enable_processed_input)
AND cardinal(NOT enable_mouse_input);
SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), Mode);
end; { if }
end; { proc. TurnMouseOff }
function GetScreenHeight : longint;
var
ConsoleInfo: TConsoleScreenBufferinfo;
begin
if (not GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo)) then begin
{$ifdef SYSTEMDEBUG}
Writeln(stderr,'GetScreenHeight failed GetLastError returns ',GetLastError);
Halt(1);
{$endif SYSTEMDEBUG}
// ts: this is really silly assumption; imho better: issue a halt
GetScreenHeight:=25;
end else
GetScreenHeight := ConsoleInfo.dwSize.Y;
end; { func. GetScreenHeight }
function GetScreenWidth : longint;
var
ConsoleInfo: TConsoleScreenBufferInfo;
begin
if (not GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo)) then begin
{$ifdef SYSTEMDEBUG}
Writeln(stderr,'GetScreenWidth failed GetLastError returns ',GetLastError);
Halt(1);
{$endif SYSTEMDEBUG}
// ts: this is really silly assumption; imho better: issue a halt
GetScreenWidth:=80;
end else
GetScreenWidth := ConsoleInfo.dwSize.X;
end; { func. GetScreenWidth }
procedure GetScreenCursor(var x : longint; var y : longint);
var
ConsoleInfo : TConsoleScreenBufferInfo;
begin
FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0);
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo);
X := ConsoleInfo.dwCursorPosition.X + 1;
Y := ConsoleInfo.dwCursorPosition.Y + 1;
end;
procedure SetScreenCursor(x,y : longint);
var
CurInfo: TCoord;
begin
FillChar(Curinfo, SizeOf(Curinfo), 0);
CurInfo.X := X - 1;
CurInfo.Y := Y - 1;
SetConsoleCursorPosition(GetStdHandle(STD_OUTPUT_HANDLE), CurInfo);
end;
{****************************************************************************
Public Crt Functions
****************************************************************************}
procedure textmode(mode : integer);
begin
{!!! Not done yet !!! }
end;
Procedure TextColor(Color: Byte);
{ Switch foregroundcolor }
Begin
TextAttr:=(Color and $8f) or (TextAttr and $70);
End;
Procedure TextBackground(Color: Byte);
{ Switch backgroundcolor }
Begin
TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) );
End;
Procedure HighVideo;
{ Set highlighted output. }
Begin
TextColor(TextAttr Or $08);
End;
Procedure LowVideo;
{ Set normal output }
Begin
TextColor(TextAttr And $77);
End;
Procedure NormVideo;
{ Set normal back and foregroundcolors. }
Begin
TextColor(7);
TextBackGround(0);
End;
Procedure GotoXY(X: DWord; Y: DWord);
{ Go to coordinates X,Y in the current window. }
Begin
If (X > 0) and (X <= (WindMaxX - WindMinX + 1)) and
(Y > 0) and (Y <= (WindMaxY - WindMinY + 1)) Then Begin
Inc(X, WindMinX - 1);
Inc(Y, WindMinY - 1);
SetScreenCursor(x,y);
End;
End;
Procedure Window(X1, Y1, X2, Y2: DWord);
{
Set screen window to the specified coordinates.
}
Begin
if (X1 > X2) or (X2 > GetScreenWidth) or
(Y1 > Y2) or (Y2 > GetScreenHeight) then
exit;
WindMinY := Y1;
WindMaxY := Y2;
WindMinX := X1;
WindMaxX := X2;
WindMin:=((Y1-1) Shl 8)+(X1-1);
WindMax:=((Y2-1) Shl 8)+(X2-1);
GotoXY(1, 1);
End;
procedure ClrScr;
var
DestCoor: TCoord;
numChars, x : DWord;
begin
DestCoor.X := WindMinX - 1;
DestCoor.Y := WindMinY - 1;
numChars := (WindMaxX - WindMinX + 1) * (WindMaxY - WindMinY + 1);
FillConsoleOutputAttribute(GetStdHandle(STD_OUTPUT_HANDLE), TextAttr,
numChars, DestCoor, x);
FillConsoleOutputCharacter(GetStdHandle(STD_OUTPUT_HANDLE), #32,
numChars, DestCoor, x);
GotoXY(1, 1);
end; { proc. ClrScr }
procedure ClrEol;
{
Clear from current position to end of line.
}
var
Temp: DWord;
CharInfo: Char;
Coord: TCoord;
X,Y: Longint;
begin
GetScreenCursor(x, y);
CharInfo := #32;
Coord.X := X - 1;
Coord.Y := Y - 1;
FillConsoleOutputCharacter(GetStdHandle(STD_OUTPUT_HANDLE), CharInfo, WindMaxX - X + 1,
Coord, @Temp);
FillConsoleOutputAttribute(GetStdHandle(STD_OUTPUT_HANDLE), TextAttr, WindMaxX - X + 1,
Coord, @Temp);
end;
Function WhereX: DWord;
{
Return current X-position of cursor.
}
var
x,y : longint;
Begin
GetScreenCursor(x, y);
WhereX:= x - WindMinX +1;
End;
Function WhereY: DWord;
{
Return current Y-position of cursor.
}
var
x, y : longint;
Begin
GetScreenCursor(x, y);
WhereY:= y - WindMinY + 1;
End;
{*************************************************************************
KeyBoard
*************************************************************************}
var
ScanCode : char;
SpecialKey : boolean;
DoingNumChars: Boolean;
DoingNumCode: Byte;
Function RemapScanCode (ScanCode: byte; CtrlKeyState: byte; keycode:longint): 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 begin
Case KeyCode of
VK_NUMPAD0 ..
VK_NUMPAD9 : begin
DoingNumChars := true;
DoingNumCode := Byte((DoingNumCode * 10) + (KeyCode - VK_NUMPAD0));
end;
end; { case }
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
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;
RemapScanCode := ScanCode;
end;
function KeyPressed : boolean;
var
nevents,nread : dword;
buf : TINPUTRECORD;
AltKey: Boolean;
begin
KeyPressed := FALSE;
if ScanCode <> #0 then
KeyPressed := TRUE
else
begin
GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents);
while nevents>0 do
begin
ReadConsoleInputA(TextRec(input).Handle,buf,1,nread);
if buf.EventType = KEY_EVENT then
if buf.Event.KeyEvent.bKeyDown then
begin
{ Alt key is VK_MENU }
{ Capslock key is VK_CAPITAL }
AltKey := ((Buf.Event.KeyEvent.dwControlKeyState AND
(RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
if not(Buf.Event.KeyEvent.wVirtualKeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL,
VK_CAPITAL, VK_NUMLOCK,
VK_SCROLL]) then
begin
keypressed:=true;
if (ord(buf.Event.KeyEvent.AsciiChar) = 0) or (buf.Event.KeyEvent.dwControlKeyState and
(LEFT_ALT_PRESSED or ENHANCED_KEY) > 0) then
begin
SpecialKey := TRUE;
ScanCode := Chr(RemapScanCode(Buf.Event.KeyEvent.wVirtualScanCode, Buf.Event.KeyEvent.dwControlKeyState,
Buf.Event.KeyEvent.wVirtualKeyCode));
end
else
begin
SpecialKey := FALSE;
ScanCode := Chr(Ord(buf.Event.KeyEvent.AsciiChar));
end;
if Buf.Event.KeyEvent.wVirtualKeyCode in [VK_NUMPAD0..VK_NUMPAD9] then
if AltKey then
begin
Keypressed := false;
Specialkey := false;
ScanCode := #0;
end
else break;
end;
end
else if (Buf.Event.KeyEvent.wVirtualKeyCode in [VK_MENU]) then
if DoingNumChars then
if DoingNumCode > 0 then
begin
ScanCode := Chr(DoingNumCode);
Keypressed := true;
DoingNumChars := false;
DoingNumCode := 0;
break
end; { if }
{ if we got a key then we can exit }
if keypressed then
exit;
GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents);
end;
end;
end;
function ReadKey: char;
begin
while (not KeyPressed) do
Sleep(1);
if SpecialKey then begin
ReadKey := #0;
SpecialKey := FALSE;
end else begin
ReadKey := ScanCode;
ScanCode := #0;
end;
end;
{*************************************************************************
Delay
*************************************************************************}
procedure Delay(MS: Word);
begin
Sleep(ms);
end; { proc. Delay }
procedure sound(hz : word);
begin
MessageBeep(0); { lame ;-) }
end;
procedure nosound;
begin
end;
{****************************************************************************
HighLevel Crt Functions
****************************************************************************}
procedure removeline(y : longint);
var
ClipRect: TSmallRect;
SrcRect: TSmallRect;
DestCoor: TCoord;
CharInfo: TCharInfo;
begin
CharInfo.UnicodeChar := #32;
CharInfo.Attributes := TextAttr;
Y := (WindMinY - 1) + (Y - 1) + 1;
SrcRect.Top := Y;
SrcRect.Left := WindMinX - 1;
SrcRect.Right := WindMaxX - 1;
SrcRect.Bottom := WindMaxY - 1;
DestCoor.X := WindMinX - 1;
DestCoor.Y := Y - 1;
ClipRect := SrcRect;
cliprect.top := destcoor.y;
ScrollConsoleScreenBuffer(GetStdHandle(STD_OUTPUT_HANDLE), SrcRect, ClipRect,
DestCoor, CharInfo);
end; { proc. RemoveLine }
procedure delline;
begin
removeline(wherey);
end; { proc. DelLine }
procedure insline;
var
ClipRect: TSmallRect;
SrcRect: TSmallRect;
DestCoor: TCoord;
CharInfo: TCharInfo;
X,Y: Longint;
begin
GetScreenCursor(X, Y);
CharInfo.UnicodeChar := #32;
CharInfo.Attributes := TextAttr;
SrcRect.Top := Y - 1;
SrcRect.Left := WindMinX - 1;
SrcRect.Right := WindMaxX - 1;
SrcRect.Bottom := WindMaxY - 1 + 1;
DestCoor.X := WindMinX - 1;
DestCoor.Y := Y;
ClipRect := SrcRect;
ClipRect.Bottom := WindMaxY - 1;
ScrollConsoleScreenBuffer(GetStdHandle(STD_OUTPUT_HANDLE), SrcRect, ClipRect,
DestCoor, CharInfo);
end; { proc. InsLine }
{****************************************************************************
Extra Crt Functions
****************************************************************************}
procedure cursoron;
var CursorInfo: TConsoleCursorInfo;
begin
GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
CursorInfo.dwSize := SaveCursorSize;
CursorInfo.bVisible := true;
SetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
end;
procedure cursoroff;
var CursorInfo: TConsoleCursorInfo;
begin
GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
CursorInfo.bVisible := false;
SetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
end;
procedure cursorbig;
var CursorInfo: TConsoleCursorInfo;
begin
GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
CursorInfo.dwSize := 100;
CursorInfo.bVisible := true;
SetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
end;
{*****************************************************************************
Read and Write routines
*****************************************************************************}
var
CurrX, CurrY : longint;
procedure WriteChar(c : char);
var
WritePos: Coord; { Upper-left cell to write from }
numWritten : DWord;
WinAttr : word;
begin
Case C of
#10 : begin
Inc(CurrY);
end;
#13 : begin
CurrX := WindMinX;
end; { if }
#08 : begin
if CurrX > WindMinX then Dec(CurrX);
end; { ^H }
#07 : begin
//MessagBeep(0);
end; { ^G }
else begin
WritePos.X := currX - 1;
WritePos.Y := currY - 1;
WriteConsoleOutputCharacter(GetStdhandle(STD_OUTPUT_HANDLE),
@c, 1, writePos, numWritten);
WinAttr:=TextAttr;
WriteConsoleOutputAttribute(GetStdhandle(STD_OUTPUT_HANDLE),
@WinAttr, 1, writePos, numWritten);
Inc(CurrX);
end; { else }
end; { case }
if CurrX > WindMaxX then begin
CurrX := WindMinX;
Inc(CurrY);
end; { if }
While CurrY > WindMaxY do begin
RemoveLine(1);
Dec(CurrY);
end; { while }
end;
Function CrtWrite(var f : textrec) : integer;
var
i : longint;
begin
GetScreenCursor(CurrX, CurrY);
for i:=0 to f.bufpos-1 do
WriteChar(f.buffer[i]);
SetScreenCursor(CurrX, CurrY);
f.bufpos:=0;
CrtWrite:=0;
end;
Function CrtRead(Var F: TextRec): Integer;
procedure BackSpace;
begin
if (f.bufpos>0) and (f.bufpos=f.bufend) then begin
WriteChar(#8);
WriteChar(' ');
WriteChar(#8);
dec(f.bufpos);
dec(f.bufend);
end;
end;
var
ch : Char;
Begin
GetScreenCursor(CurrX,CurrY);
f.bufpos:=0;
f.bufend:=0;
repeat
if f.bufpos>f.bufend then
f.bufend:=f.bufpos;
SetScreenCursor(CurrX,CurrY);
ch:=readkey;
case ch of
#0 : case readkey of
#71 : while f.bufpos>0 do begin
dec(f.bufpos);
WriteChar(#8);
end;
#75 : if f.bufpos>0 then begin
dec(f.bufpos);
WriteChar(#8);
end;
#77 : if f.bufpos<f.bufend then begin
WriteChar(f.bufptr^[f.bufpos]);
inc(f.bufpos);
end;
#79 : while f.bufpos<f.bufend do begin
WriteChar(f.bufptr^[f.bufpos]);
inc(f.bufpos);
end;
end;
^S,
#8 : BackSpace;
^Y,
#27 : begin
f.bufpos:=f.bufend;
while f.bufend>0 do
BackSpace;
end;
#13 : begin
WriteChar(#13);
WriteChar(#10);
f.bufptr^[f.bufend]:=#13;
f.bufptr^[f.bufend+1]:=#10;
inc(f.bufend,2);
break;
end;
#26 : if CheckEOF then begin
f.bufptr^[f.bufend]:=#26;
inc(f.bufend);
break;
end;
else begin
if f.bufpos<f.bufsize-2 then begin
f.buffer[f.bufpos]:=ch;
inc(f.bufpos);
WriteChar(ch);
end;
end;
end;
until false;
f.bufpos:=0;
SetScreenCursor(CurrX, CurrY);
CrtRead:=0;
End;
Function CrtReturn(Var F:TextRec):Integer;
Begin
CrtReturn:=0;
end;
Function CrtClose(Var F: TextRec): Integer;
Begin
F.Mode:=fmClosed;
CrtClose:=0;
End;
Function CrtOpen(Var F: TextRec): Integer;
Begin
If F.Mode=fmOutput Then begin
TextRec(F).InOutFunc:=@CrtWrite;
TextRec(F).FlushFunc:=@CrtWrite;
end Else begin
F.Mode:=fmInput;
TextRec(F).InOutFunc:=@CrtRead;
TextRec(F).FlushFunc:=@CrtReturn;
end;
TextRec(F).CloseFunc:=@CrtClose;
CrtOpen:=0;
End;
procedure AssignCrt(var F: Text);
begin
Assign(F,'');
TextRec(F).OpenFunc:=@CrtOpen;
end;
var
CursorInfo : TConsoleCursorInfo;
ConsoleInfo : TConsoleScreenBufferinfo;
// ts
begin
{ Initialize the output handles }
LastMode := 3;
SetActiveWindow(0);
{--------------------- Get the cursor size and such -----------------------}
FillChar(CursorInfo, SizeOf(CursorInfo), 00);
GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
SaveCursorSize := CursorInfo.dwSize;
{------------------ Get the current cursor position and attr --------------}
FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0);
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo);
TextAttr := ConsoleInfo.wAttributes;
{ Not required, the dos crt does also not touch the mouse }
{TurnMouseOff;}
WindMinX := (ConsoleInfo.srWindow.Left) + 1;
WindMinY := (ConsoleInfo.srWindow.Top) + 1;
WindMaxX := (ConsoleInfo.srWindow.Right) + 1;
WindMaxY := (ConsoleInfo.srWindow.Bottom) + 1;
DoingNumChars := false;
DoingNumCode := 0;
{ Redirect the standard output }
AssignCrt(Output);
Rewrite(Output);
TextRec(Output).Handle:= GetStdHandle(STD_OUTPUT_HANDLE);
AssignCrt(Input);
Reset(Input);
TextRec(Input).Handle:= GetStdHandle(STD_INPUT_HANDLE);
end. { unit Crt }
{
$Log$
Revision 1.18 2002-10-06 20:00:22 peter
* Use Widechar in the Windows unit
Revision 1.17 2002/09/07 16:01:28 peter
* old logs removed and tabs fixed
Revision 1.16 2002/01/19 11:56:34 peter
* fixed clrscr for small windows
* no turnoffmouse
}
Reference in New Issue View Git Blame Copy Permalink