fpc/rtl/win32/crt.pp

1004 lines
22 KiB
ObjectPascal

{
$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;
{$mode objfpc}
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 }
{ Interface procedures }
procedure AssignCrt(var F: Text);
function KeyPressed: Boolean;
function ReadKey: Char;
procedure TextMode(Mode: Integer);
procedure Window(X1,Y1,X2,Y2: Byte);
procedure GotoXY(X,Y: Byte);
function WhereX: Byte;
function WhereY: Byte;
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
dos,
windows;
var
OutHandle : THandle;
InputHandle : THandle;
CursorSaveX : Longint;
CursorSaveY : Longint;
ScreenWidth : Longint;
ScreenHeight : Longint;
IsWindowsNT : Boolean;
SaveCursorSize: Longint;
{
definition of textrec is in textrec.inc
}
{$i textrec.inc}
{****************************************************************************
Low level Routines
****************************************************************************}
function GetPlatformID: Longint;
var OsVersion: TOSVersionInfo;
begin
OsVersion.dwOsVersionInfoSize := SizeOf(OsVersion);
GetVersionEx(OsVersion);
Result := OsVersion.dwPlatformID;
end; { func. GetPlatformID }
procedure TurnMouseOff;
var Mode: DWORD;
begin
if GetConsoleMode(InputHandle, @Mode) then { Turn the mouse-cursor off }
begin
Mode := Mode AND NOT enable_processed_input
AND NOT enable_mouse_input;
SetConsoleMode(InputHandle, Mode);
end; { if }
end; { proc. TurnMouseOff }
function GetScreenHeight : longint;
var ConsoleInfo: TConsoleScreenBufferinfo;
begin
GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
Result := ConsoleInfo.dwSize.Y;
end; { func. GetScreenHeight }
function GetScreenWidth : longint;
var ConsoleInfo: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
Result := ConsoleInfo.dwSize.X;
end; { func. GetScreenWidth }
procedure SetScreenCursor(x,y : longint);
var CurInfo: TCoord;
begin
FillChar(Curinfo, SizeOf(Curinfo), 0);
CurInfo.X := X - 1;
CurInfo.Y := Y - 1;
SetConsoleCursorPosition(OutHandle, CurInfo);
CursorSaveX := X - 1;
CursorSaveY := Y - 1;
end;
procedure GetScreenCursor(var x,y : longint);
begin
X := CursorSaveX + 1;
Y := CursorSaveY + 1;
end;
{****************************************************************************
Helper Routines
****************************************************************************}
Function WinMinX: Byte;
{
Current Minimum X coordinate
}
Begin
WinMinX:=(WindMin and $ff)+1;
End;
Function WinMinY: Byte;
{
Current Minimum Y Coordinate
}
Begin
WinMinY:=(WindMin shr 8)+1;
End;
Function WinMaxX: Byte;
{
Current Maximum X coordinate
}
Begin
WinMaxX:=(WindMax and $ff)+1;
End;
Function WinMaxY: Byte;
{
Current Maximum Y coordinate;
}
Begin
WinMaxY:=(WindMax shr 8) + 1;
End;
Function FullWin:boolean;
{
Full Screen 80x25? Window(1,1,80,25) is used, allows faster routines
}
begin
FullWin:=(WinMinX=1) and (WinMinY=1) and
(WinMaxX=ScreenWidth) and (WinMaxY=ScreenHeight);
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: Byte; Y: Byte);
{
Go to coordinates X,Y in the current window.
}
Begin
If (X>0) and (X<=WinMaxX- WinMinX+1) and
(Y>0) and (Y<=WinMaxY-WinMinY+1) Then
Begin
Inc(X,WinMinX-1);
Inc(Y,WinMinY-1);
SetScreenCursor(x,y);
End;
End;
Procedure Window(X1, Y1, X2, Y2: Byte);
{
Set screen window to the specified coordinates.
}
Begin
if (X1>X2) or (X2>ScreenWidth) or
(Y1>Y2) or (Y2>ScreenHeight) then
exit;
WindMin:=((Y1-1) Shl 8)+(X1-1);
WindMax:=((Y2-1) Shl 8)+(X2-1);
GoToXY(1,1);
End;
procedure ClrScr;
var
ClipRect: TSmallRect;
SrcRect: TSmallRect;
DestCoor: TCoord;
CharInfo: TCharInfo;
begin
CharInfo.UnicodeChar := 32;
CharInfo.Attributes := TextAttr;
SrcRect.Left := WinMinX - 1;
SrcRect.Top := WinMinY - 1;
SrcRect.Right := WinMaxX - 1;
SrcRect.Bottom := WinMaxY - 1;
ClipRect := SrcRect;
if IsWindowsNT then
begin
DestCoor.X := -WinMaxX;
DestCoor.Y := -WinMaxY;
ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
DestCoor, CharInfo);
end
else begin { Win95 seems to have a bug in scrolling, unfortunately }
{ This routine 3 times copies the bottom 12 lines to the }
{ top part of the screen. This eventually will clear the }
{ screen. }
DestCoor.X := WinMinX - 1;
DestCoor.Y := WinMinY - (Succ((WinMaxY - WinMinY) div 2));
{-------- Scroll 1st part }
ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
DestCoor, CharInfo);
{-------- Scroll 2nd part }
ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
DestCoor, CharInfo);
{-------- Scroll 3rd part (last line) }
ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
DestCoor, CharInfo);
end; { if in Windows95 }
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(OutHandle, CharInfo, WinMaxX - (X + 01), Coord, @Temp);
end;
Function WhereX: Byte;
{
Return current X-position of cursor.
}
var
x,y : longint;
Begin
GetScreenCursor(x,y);
WhereX:=x-WinMinX+1;
End;
Function WhereY: Byte;
{
Return current Y-position of cursor.
}
var
x,y : longint;
Begin
GetScreenCursor(x,y);
WhereY:=y-WinMinY+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;
Result := ScanCode;
end;
function KeyPressed : boolean;
var
nevents, nread, i: longint;
buf : TINPUTRECORD;
AltKey: Boolean;
begin
KeyPressed := FALSE;
if ScanCode <> #0 then
KeyPressed := TRUE
else
begin
nevents:=0;
GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents);
For i := 1 to nevents do
begin
ReadConsoleInputA(TextRec(input).Handle,buf,1,nread);
if buf.EventType = KEY_EVENT then
if buf.KeyEvent.bKeyDown then
begin
{ Alt key is VK_MENU }
{ Capslock key is VK_CAPITAL }
AltKey := ((Buf.KeyEvent.dwControlKeyState AND
(RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
if (Buf.KeyEvent.wVirtualKeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL,
VK_CAPITAL, VK_NUMLOCK,
VK_SCROLL]) then
begin
{ Discard this key }
end
else begin
KeyPressed := TRUE;
if ord(buf.KeyEvent.AsciiChar) = 0 then
begin
SpecialKey := TRUE;
ScanCode := Chr(RemapScanCode(Buf.KeyEvent.wVirtualScanCode, Buf.KeyEvent.dwControlKeyState,
Buf.KeyEvent.wVirtualKeyCode));
end
else
begin
SpecialKey := FALSE;
ScanCode := Chr(Ord(buf.KeyEvent.AsciiChar));
end;
if Buf.KeyEvent.wVirtualKeyCode in [VK_NUMPAD0..VK_NUMPAD9] then
if AltKey then
begin
Keypressed := false;
Specialkey := false;
ScanCode := #0;
end
else BREAK;
end;
end { if }
else if (Buf.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 }
end;
end;
end;
function ReadKey: char;
begin
repeat
Sleep(1);
until KeyPressed;
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 := WinMinY + Y-1;
SrcRect.Top := Y - 01;
SrcRect.Left := WinMinX - 1;
SrcRect.Right := WinMaxX - 1;
SrcRect.Bottom := WinMaxY - 1;
DestCoor.X := WinMinX - 1;
DestCoor.Y := Y - 2;
ClipRect := SrcRect;
ScrollConsoleScreenBuffer(OutHandle, 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 := WinMinX - 1;
SrcRect.Right := WinMaxX - 1;
SrcRect.Bottom := WinMaxY - 1;
DestCoor.X := WinMinX - 1;
DestCoor.Y := Y;
ClipRect := SrcRect;
ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect, DestCoor, CharInfo);
end; { proc. InsLine }
{****************************************************************************
Extra Crt Functions
****************************************************************************}
procedure cursoron;
var CursorInfo: TConsoleCursorInfo;
begin
GetConsoleCursorInfo(OutHandle, CursorInfo);
CursorInfo.dwSize := SaveCursorSize;
CursorInfo.bVisible := true;
SetConsoleCursorInfo(OutHandle, CursorInfo);
end;
procedure cursoroff;
var CursorInfo: TConsoleCursorInfo;
begin
GetConsoleCursorInfo(OutHandle, CursorInfo);
CursorInfo.bVisible := false;
SetConsoleCursorInfo(OutHandle, CursorInfo);
end;
procedure cursorbig;
var CursorInfo: TConsoleCursorInfo;
begin
GetConsoleCursorInfo(OutHandle, CursorInfo);
CursorInfo.dwSize := 100;
CursorInfo.bVisible := true;
SetConsoleCursorInfo(OutHandle, CursorInfo);
end;
{*****************************************************************************
Read and Write routines
*****************************************************************************}
var
CurrX, CurrY : longint;
procedure WriteChar(c:char);
var
Cell : TCharInfo;
BufSize : Coord; { Column-row size of source buffer }
WritePos: TCoord; { Upper-left cell to write from }
DestRect: TSmallRect;
begin
Case C of
#10 : begin
Inc(CurrY);
end;
#13 : begin
CurrX := WinMinX;
end; { if }
#08 : begin
if CurrX > WinMinX then Dec(CurrX);
end; { ^H }
#07 : begin
// MessagBeep(0);
end; { ^G }
else begin
BufSize.X := 01;
BufSize.Y := 01;
WritePos.X := 0;
WritePos.Y := 0;
Cell.UniCodeChar := Ord(c);
Cell.Attributes := TextAttr;
DestRect.Left := (CurrX - 01);
DestRect.Top := (CurrY - 01);
DestRect.Right := (CurrX - 01) + 01;
DestRect.Bottom := (CurrY - 01);
WriteConsoleOutput(OutHandle, Cell, BufSize, WritePos, @DestRect);
Inc(CurrX);
end; { else }
end; { case }
if CurrX > WinMaxX then
begin
CurrX := WinMinX;
Inc(CurrY);
end; { if }
While CurrY > WinMaxY 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;
begin
{ Initialize the output handles }
OutHandle := GetStdHandle(STD_OUTPUT_HANDLE);
InputHandle := GetStdHandle(STD_INPUT_HANDLE);
LastMode := 3;
{--------------------- Get the cursor size and such -----------------------}
FillChar(CursorInfo, SizeOf(CursorInfo), 00);
GetConsoleCursorInfo(OutHandle, CursorInfo);
SaveCursorSize := CursorInfo.dwSize;
{------------------ Get the current cursor position and attr --------------}
FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0);
GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
CursorSaveX := ConsoleInfo.dwCursorPosition.X;
CursorSaveY := ConsoleInfo.dwCursorPosition.Y;
TextAttr := ConsoleInfo.wAttributes;
{ Load startup values }
ScreenWidth := GetScreenWidth;
ScreenHeight := GetScreenHeight;
IsWindowsNT := (GetPlatformID = VER_PLATFORM_WIN32_NT);
TurnMouseOff;
WindMax := (ScreenWidth - 1) OR ((ScreenHeight - 1) SHL 8);
DoingNumChars := false;
DoingNumCode := 0;
{ Redirect the standard output }
AssignCrt(Output);
Rewrite(Output);
TextRec(Output).Handle:= OutHandle;
AssignCrt(Input);
Reset(Input);
TextRec(Input).Handle:= InputHandle;
end. { unit Crt }
{
$Log$
Revision 1.12 1999-10-22 14:36:20 peter
* crtreturn also needs f:textrec as parameter
Revision 1.11 1999/08/28 09:30:39 peter
* fixes from Maarten Bekers
Revision 1.10 1999/08/24 13:15:44 peter
* Removeline fixed
Revision 1.9 1999/07/06 22:44:11 florian
* some fixes to compile ddraw units from the jedi project
Revision 1.8 1999/06/09 16:46:11 peter
* fixed fullwin,textbackground
Revision 1.7 1999/05/22 14:01:01 peter
* more fixed from Maarten Bekkers
Revision 1.6 1999/05/19 16:22:02 peter
* fixed left crt bugs
Revision 1.5 1999/05/01 13:18:26 peter
* changed back fixes
Revision 1.4 1999/04/30 11:34:27 michael
+ Fixed some compiling errors
Revision 1.3 1999/04/23 09:06:17 michael
+ now it REALLY compiles
Revision 1.2 1999/04/20 11:34:12 peter
+ crt unit that compiles
}