paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-25 13:29:38 +02:00
Code Issues Packages Projects Releases Wiki Activity

* updates from Tomas Schatzl so it works better with w2k virtual

Browse Source 
consoles
This commit is contained in:
peter 2001-07-13 17:43:25 +00:00
parent 8c8e53ffa0
commit 68d1090318
1 changed files with 235 additions and 382 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

427
rtl/win32/crt.pp
View File

@ -13,8 +13,6 @@
**********************************************************************} **********************************************************************}
unit crt; unit crt;
{$mode objfpc}
interface interface
const const
@ -65,29 +63,31 @@ var
WindMin: Word; { Window upper left coordinates } WindMin: Word; { Window upper left coordinates }
WindMax: Word; { Window lower right coordinates } WindMax: Word; { Window lower right coordinates }
{ FPC Specific for large screen support } { FPC Specific for large screen support }
WinMinX, WindMinX : Longint;
WinMinY, WindMaxX : Longint;
WinMaxX, WindMinY : Longint;
WinMaxY : Longint; WindMaxY : Longint;
{ Interface procedures } { Interface procedures }
procedure AssignCrt(var F: Text); procedure AssignCrt(var F: Text);
function KeyPressed: Boolean; function KeyPressed: Boolean;
function ReadKey: Char; function ReadKey: Char;
procedure TextMode(Mode: Integer); procedure TextMode(Mode: Integer);
procedure Window(X1,Y1,X2,Y2: Byte); procedure Window(X1,Y1,X2,Y2: DWord);
procedure GotoXY(X,Y: Byte); procedure GotoXY(X,Y: DWord);
function WhereX: Byte; function WhereX: DWord;
function WhereY: Byte; function WhereY: DWord;
procedure ClrScr; procedure ClrScr;
procedure ClrEol; procedure ClrEol;
procedure InsLine; procedure InsLine;
procedure DelLine; procedure DelLine;
procedure TextColor(Color: Byte); procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte); procedure TextBackground(Color: Byte);
procedure LowVideo; procedure LowVideo;
procedure HighVideo; procedure HighVideo;
procedure NormVideo; procedure NormVideo;
procedure Delay(MS: Word); procedure Delay(MS: Word);
procedure Sound(Hz: Word); procedure Sound(Hz: Word);
procedure NoSound; procedure NoSound;
@ -101,21 +101,9 @@ procedure cursorbig;
implementation implementation
uses uses
dos,
windows; windows;
var var
OutHandle : THandle;
InputHandle : THandle;
CursorSaveX : Longint;
CursorSaveY : Longint;
ScreenWidth : Longint;
ScreenHeight : Longint;
IsWindowsNT : Boolean;
SaveCursorSize: Longint; SaveCursorSize: Longint;
@ -128,64 +116,58 @@ var
Low level Routines Low level Routines
****************************************************************************} ****************************************************************************}
function GetPlatformID: Longint;
var OsVersion: TOSVersionInfo;
begin
OsVersion.dwOsVersionInfoSize := SizeOf(OsVersion);
GetVersionEx(OsVersion);
Result := OsVersion.dwPlatformID;
end; { func. GetPlatformID }
procedure TurnMouseOff; procedure TurnMouseOff;
var Mode: DWORD; var Mode: DWORD;
begin begin
if GetConsoleMode(InputHandle, @Mode) then { Turn the mouse-cursor off } if GetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), @Mode) then begin { Turn the mouse-cursor off }
begin
Mode := Mode AND cardinal(NOT enable_processed_input) Mode := Mode AND cardinal(NOT enable_processed_input)
AND cardinal(NOT enable_mouse_input); AND cardinal(NOT enable_mouse_input);
SetConsoleMode(InputHandle, Mode); SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), Mode);
end; { if } end; { if }
end; { proc. TurnMouseOff } end; { proc. TurnMouseOff }
function GetScreenHeight : longint; function GetScreenHeight : longint;
var var
ConsoleInfo: TConsoleScreenBufferinfo; ConsoleInfo: TConsoleScreenBufferinfo;
begin begin
if not GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo) then if (not GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo)) then begin
begin
{$ifdef SYSTEMDEBUG} {$ifdef SYSTEMDEBUG}
Writeln(stderr,'GetScreenHeight failed GetLastError returns ',GetLastError); Writeln(stderr,'GetScreenHeight failed GetLastError returns ',GetLastError);
Halt(1); Halt(1);
{$endif SYSTEMDEBUG} {$endif SYSTEMDEBUG}
Result:=25; // ts: this is really silly assumption; imho better: issue a halt
end GetScreenHeight:=25;
else end else
Result := ConsoleInfo.dwSize.Y; GetScreenHeight := ConsoleInfo.dwSize.Y;
end; { func. GetScreenHeight } end; { func. GetScreenHeight }
function GetScreenWidth : longint; function GetScreenWidth : longint;
var var
ConsoleInfo: TConsoleScreenBufferInfo; ConsoleInfo: TConsoleScreenBufferInfo;
begin begin
if not GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo) then if (not GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo)) then begin
begin
{$ifdef SYSTEMDEBUG} {$ifdef SYSTEMDEBUG}
Writeln(stderr,'GetScreenWidth failed GetLastError returns ',GetLastError); Writeln(stderr,'GetScreenWidth failed GetLastError returns ',GetLastError);
Halt(1); Halt(1);
{$endif SYSTEMDEBUG} {$endif SYSTEMDEBUG}
Result:=80; // ts: this is really silly assumption; imho better: issue a halt
end GetScreenWidth:=80;
else end else
Result := ConsoleInfo.dwSize.X; GetScreenWidth := ConsoleInfo.dwSize.X;
end; { func. GetScreenWidth } 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); procedure SetScreenCursor(x,y : longint);
var var
CurInfo: TCoord; CurInfo: TCoord;
@ -193,36 +175,9 @@ begin
FillChar(Curinfo, SizeOf(Curinfo), 0); FillChar(Curinfo, SizeOf(Curinfo), 0);
CurInfo.X := X - 1; CurInfo.X := X - 1;
CurInfo.Y := Y - 1; CurInfo.Y := Y - 1;
SetConsoleCursorPosition(GetStdHandle(STD_OUTPUT_HANDLE), CurInfo);
SetConsoleCursorPosition(OutHandle, CurInfo);
CursorSaveX := X - 1;
CursorSaveY := Y - 1;
end; end;
procedure GetScreenCursor(var x,y : longint);
begin
X := CursorSaveX + 1;
Y := CursorSaveY + 1;
end;
{****************************************************************************
Helper Routines
****************************************************************************}
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 Public Crt Functions
****************************************************************************} ****************************************************************************}
@ -233,135 +188,79 @@ begin
{!!! Not done yet !!! } {!!! Not done yet !!! }
end; end;
Procedure TextColor(Color: Byte); Procedure TextColor(Color: Byte);
{ { Switch foregroundcolor }
Switch foregroundcolor
}
Begin Begin
TextAttr:=(Color and $8f) or (TextAttr and $70); TextAttr:=(Color and $8f) or (TextAttr and $70);
End; End;
Procedure TextBackground(Color: Byte); Procedure TextBackground(Color: Byte);
{ { Switch backgroundcolor }
Switch backgroundcolor
}
Begin Begin
TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) ); TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) );
End; End;
Procedure HighVideo; Procedure HighVideo;
{ { Set highlighted output. }
Set highlighted output.
}
Begin Begin
TextColor(TextAttr Or $08); TextColor(TextAttr Or $08);
End; End;
Procedure LowVideo; Procedure LowVideo;
{ { Set normal output }
Set normal output
}
Begin Begin
TextColor(TextAttr And $77); TextColor(TextAttr And $77);
End; End;
Procedure NormVideo; Procedure NormVideo;
{ { Set normal back and foregroundcolors. }
Set normal back and foregroundcolors.
}
Begin Begin
TextColor(7); TextColor(7);
TextBackGround(0); TextBackGround(0);
End; End;
Procedure GotoXY(X: DWord; Y: DWord);
Procedure GotoXy(X: Byte; Y: Byte); { Go to coordinates X,Y in the current window. }
{
Go to coordinates X,Y in the current window.
}
Begin Begin
If (X>0) and (X<=WinMaxX- WinMinX+1) and If (X > 0) and (X <= (WindMaxX - WindMinX + 1)) and
(Y>0) and (Y<=WinMaxY-WinMinY+1) Then (Y > 0) and (Y <= (WindMaxY - WindMinY + 1)) Then Begin
Begin Inc(X, WindMinX - 1);
Inc(X,WinMinX-1); Inc(Y, WindMinY - 1);
Inc(Y,WinMinY-1);
SetScreenCursor(x,y); SetScreenCursor(x,y);
End; End;
End; End;
Procedure Window(X1, Y1, X2, Y2: Byte); Procedure Window(X1, Y1, X2, Y2: DWord);
{ {
Set screen window to the specified coordinates. Set screen window to the specified coordinates.
} }
Begin Begin
if (X1>X2) or (X2>ScreenWidth) or if (X1 > X2) or (X2 > GetScreenWidth) or
(Y1>Y2) or (Y2>ScreenHeight) then (Y1 > Y2) or (Y2 > GetScreenHeight) then
exit; exit;
WinMinX:=X1; WindMinY := Y1;
WinMaxX:=X2; WindMaxY := Y2;
WinMinY:=Y1; WindMinX := X1;
WinMaxY:=Y2; WindMaxX := X2;
WindMin:=((Y1-1) Shl 8)+(X1-1); WindMin:=((Y1-1) Shl 8)+(X1-1);
WindMax:=((Y2-1) Shl 8)+(X2-1); WindMax:=((Y2-1) Shl 8)+(X2-1);
GoToXY(1,1); GotoXY(1, 1);
End; End;
procedure ClrScr; procedure ClrScr;
var var
ClipRect: TSmallRect;
SrcRect: TSmallRect;
DestCoor: TCoord; DestCoor: TCoord;
CharInfo: TCharInfo; numChars, x : DWord;
begin begin
CharInfo.UnicodeChar := 32; DestCoor.X := WindMinX - 1;
CharInfo.Attributes := TextAttr; DestCoor.Y := WindMinY - 1;
numChars := (WindMaxX - WindMinX + 1) * (WindMaxY - WindMinY + 1);
SrcRect.Left := WinMinX - 1; FillConsoleOutputAttribute(GetStdHandle(STD_OUTPUT_HANDLE), TextAttr,
SrcRect.Top := WinMinY - 1; numChars, DestCoor, x);
SrcRect.Right := WinMaxX - 1; FillConsoleOutputCharacter(GetStdHandle(STD_OUTPUT_HANDLE), #32,
SrcRect.Bottom := WinMaxY - 1; numChars, DestCoor, x);
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); GotoXY(1, 1);
end; { proc. ClrScr } end; { proc. ClrScr }
@ -371,7 +270,8 @@ procedure ClrEol;
{ {
Clear from current position to end of line. Clear from current position to end of line.
} }
var Temp: Dword; var
Temp: DWord;
CharInfo: Char; CharInfo: Char;
Coord: TCoord; Coord: TCoord;
X,Y: Longint; X,Y: Longint;
@ -379,17 +279,16 @@ begin
GetScreenCursor(x, y); GetScreenCursor(x, y);
CharInfo := #32; CharInfo := #32;
Coord.X := X - 1; Coord.X := X - 1;
Coord.Y := Y - 1; Coord.Y := Y - 1;
FillConsoleOutputCharacter(OutHandle, CharInfo, WinMaxX - X + 1, Coord, @Temp); FillConsoleOutputCharacter(GetStdHandle(STD_OUTPUT_HANDLE), CharInfo, WindMaxX - X + 1,
FillConsoleOutputAttribute(OutHandle, TextAttr, WinMaxX - X + 1, Coord, @Temp); Coord, @Temp);
FillConsoleOutputAttribute(GetStdHandle(STD_OUTPUT_HANDLE), TextAttr, WindMaxX - X + 1,
Coord, @Temp);
end; end;
Function WhereX: DWord;
Function WhereX: Byte;
{ {
Return current X-position of cursor. Return current X-position of cursor.
} }
@ -397,12 +296,10 @@ var
x,y : longint; x,y : longint;
Begin Begin
GetScreenCursor(x, y); GetScreenCursor(x, y);
WhereX:=x-WinMinX+1; WhereX:= x - WindMinX +1;
End; End;
Function WhereY: DWord;
Function WhereY: Byte;
{ {
Return current Y-position of cursor. Return current Y-position of cursor.
} }
@ -410,7 +307,7 @@ var
x, y : longint; x, y : longint;
Begin Begin
GetScreenCursor(x, y); GetScreenCursor(x, y);
WhereY:=y-WinMinY+1; WhereY:= y - WindMinY + 1;
End; End;
@ -506,7 +403,7 @@ begin
// Function keys // Function keys
$57..$58: inc(Scancode, $2E); // F11 and F12 $57..$58: inc(Scancode, $2E); // F11 and F12
end; end;
Result := ScanCode; RemapScanCode := ScanCode;
end; end;
@ -584,15 +481,12 @@ end;
function ReadKey: char; function ReadKey: char;
begin begin
repeat while (not KeyPressed) do
Sleep(1); Sleep(1);
until KeyPressed;
if SpecialKey then begin if SpecialKey then begin
ReadKey := #0; ReadKey := #0;
SpecialKey := FALSE; SpecialKey := FALSE;
end end else begin
else begin
ReadKey := ScanCode; ReadKey := ScanCode;
ScanCode := #0; ScanCode := #0;
end; end;
@ -623,7 +517,6 @@ end;
{**************************************************************************** {****************************************************************************
HighLevel Crt Functions HighLevel Crt Functions
****************************************************************************} ****************************************************************************}
procedure removeline(y : longint); procedure removeline(y : longint);
var var
ClipRect: TSmallRect; ClipRect: TSmallRect;
@ -634,18 +527,21 @@ begin
CharInfo.UnicodeChar := 32; CharInfo.UnicodeChar := 32;
CharInfo.Attributes := TextAttr; CharInfo.Attributes := TextAttr;
Y := WinMinY + Y-1; Y := (WindMinY - 1) + (Y - 1) + 1;
SrcRect.Top := Y - 01; SrcRect.Top := Y;
SrcRect.Left := WinMinX - 1; SrcRect.Left := WindMinX - 1;
SrcRect.Right := WinMaxX - 1; SrcRect.Right := WindMaxX - 1;
SrcRect.Bottom := WinMaxY - 1; SrcRect.Bottom := WindMaxY - 1;
DestCoor.X := WindMinX - 1;
DestCoor.Y := Y - 1;
DestCoor.X := WinMinX - 1;
DestCoor.Y := Y - 2;
ClipRect := SrcRect; ClipRect := SrcRect;
cliprect.top := destcoor.y;
ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect, DestCoor, CharInfo); ScrollConsoleScreenBuffer(GetStdHandle(STD_OUTPUT_HANDLE), SrcRect, ClipRect,
DestCoor, CharInfo);
end; { proc. RemoveLine } end; { proc. RemoveLine }
@ -669,20 +565,20 @@ begin
CharInfo.Attributes := TextAttr; CharInfo.Attributes := TextAttr;
SrcRect.Top := Y - 1; SrcRect.Top := Y - 1;
SrcRect.Left := WinMinX - 1; SrcRect.Left := WindMinX - 1;
SrcRect.Right := WinMaxX - 1; SrcRect.Right := WindMaxX - 1;
SrcRect.Bottom := WinMaxY - 1; SrcRect.Bottom := WindMaxY - 1 + 1;
DestCoor.X := WinMinX - 1; DestCoor.X := WindMinX - 1;
DestCoor.Y := Y; DestCoor.Y := Y;
ClipRect := SrcRect; ClipRect := SrcRect;
ClipRect.Bottom := WindMaxY - 1;
ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect, DestCoor, CharInfo); ScrollConsoleScreenBuffer(GetStdHandle(STD_OUTPUT_HANDLE), SrcRect, ClipRect,
DestCoor, CharInfo);
end; { proc. InsLine } end; { proc. InsLine }
{**************************************************************************** {****************************************************************************
Extra Crt Functions Extra Crt Functions
****************************************************************************} ****************************************************************************}
@ -690,29 +586,29 @@ end; { proc. InsLine }
procedure cursoron; procedure cursoron;
var CursorInfo: TConsoleCursorInfo; var CursorInfo: TConsoleCursorInfo;
begin begin
GetConsoleCursorInfo(OutHandle, CursorInfo); GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
CursorInfo.dwSize := SaveCursorSize; CursorInfo.dwSize := SaveCursorSize;
CursorInfo.bVisible := true; CursorInfo.bVisible := true;
SetConsoleCursorInfo(OutHandle, CursorInfo); SetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
end; end;
procedure cursoroff; procedure cursoroff;
var CursorInfo: TConsoleCursorInfo; var CursorInfo: TConsoleCursorInfo;
begin begin
GetConsoleCursorInfo(OutHandle, CursorInfo); GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
CursorInfo.bVisible := false; CursorInfo.bVisible := false;
SetConsoleCursorInfo(OutHandle, CursorInfo); SetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
end; end;
procedure cursorbig; procedure cursorbig;
var CursorInfo: TConsoleCursorInfo; var CursorInfo: TConsoleCursorInfo;
begin begin
GetConsoleCursorInfo(OutHandle, CursorInfo); GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
CursorInfo.dwSize := 100; CursorInfo.dwSize := 100;
CursorInfo.bVisible := true; CursorInfo.bVisible := true;
SetConsoleCursorInfo(OutHandle, CursorInfo); SetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
end; end;
@ -725,65 +621,57 @@ var
procedure WriteChar(c : char); procedure WriteChar(c : char);
var var
Cell : TCharInfo; WritePos: Coord; { Upper-left cell to write from }
BufSize : Coord; { Column-row size of source buffer } numWritten : DWord;
WritePos: TCoord; { Upper-left cell to write from } WinAttr : word;
DestRect: TSmallRect;
begin begin
Case C of Case C of
#10 : begin #10 : begin
Inc(CurrY); Inc(CurrY);
end; end;
#13 : begin #13 : begin
CurrX := WinMinX; CurrX := WindMinX;
end; { if } end; { if }
#08 : begin #08 : begin
if CurrX > WinMinX then Dec(CurrX); if CurrX > WindMinX then Dec(CurrX);
end; { ^H } end; { ^H }
#07 : begin #07 : begin
//MessagBeep(0); //MessagBeep(0);
end; { ^G } end; { ^G }
else begin else begin
BufSize.X := 01; WritePos.X := currX - 1;
BufSize.Y := 01; WritePos.Y := currY - 1;
WritePos.X := 0; WriteConsoleOutputCharacter(GetStdhandle(STD_OUTPUT_HANDLE),
WritePos.Y := 0; @c, 1, writePos, numWritten);
Cell.UniCodeChar := Ord(c); WinAttr:=TextAttr;
Cell.Attributes := TextAttr; WriteConsoleOutputAttribute(GetStdhandle(STD_OUTPUT_HANDLE),
@WinAttr, 1, writePos, numWritten);
DestRect.Left := (CurrX - 01);
DestRect.Top := (CurrY - 01);
DestRect.Right := (CurrX - 01);
DestRect.Bottom := (CurrY - 01);
WriteConsoleOutput(OutHandle, @Cell, BufSize, WritePos, DestRect);
Inc(CurrX); Inc(CurrX);
end; { else } end; { else }
end; { case } end; { case }
if CurrX > WinMaxX then if CurrX > WindMaxX then begin
begin CurrX := WindMinX;
CurrX := WinMinX;
Inc(CurrY); Inc(CurrY);
end; { if } end; { if }
While CurrY > WinMaxY do While CurrY > WindMaxY do begin
begin
RemoveLine(1); RemoveLine(1);
Dec(CurrY); Dec(CurrY);
end; { while } end; { while }
end; end;
Function CrtWrite(var f : textrec) : integer; Function CrtWrite(var f : textrec) : integer;
var var
i : longint; i : longint;
begin begin
GetScreenCursor(CurrX, CurrY); GetScreenCursor(CurrX, CurrY);
for i:=0 to f.bufpos-1 do for i:=0 to f.bufpos-1 do
WriteChar(f.buffer[i]); WriteChar(f.buffer[i]);
SetScreenCursor(CurrX, CurrY); SetScreenCursor(CurrX, CurrY);
f.bufpos:=0; f.bufpos:=0;
CrtWrite:=0; CrtWrite:=0;
end; end;
@ -793,8 +681,7 @@ Function CrtRead(Var F: TextRec): Integer;
procedure BackSpace; procedure BackSpace;
begin begin
if (f.bufpos>0) and (f.bufpos=f.bufend) then if (f.bufpos>0) and (f.bufpos=f.bufend) then begin
begin
WriteChar(#8); WriteChar(#8);
WriteChar(' '); WriteChar(' ');
WriteChar(#8); WriteChar(#8);
@ -816,23 +703,19 @@ Begin
ch:=readkey; ch:=readkey;
case ch of case ch of
#0 : case readkey of #0 : case readkey of
#71 : while f.bufpos>0 do #71 : while f.bufpos>0 do begin
begin
dec(f.bufpos); dec(f.bufpos);
WriteChar(#8); WriteChar(#8);
end; end;
#75 : if f.bufpos>0 then #75 : if f.bufpos>0 then begin
begin
dec(f.bufpos); dec(f.bufpos);
WriteChar(#8); WriteChar(#8);
end; end;
#77 : if f.bufpos<f.bufend then #77 : if f.bufpos<f.bufend then begin
begin
WriteChar(f.bufptr^[f.bufpos]); WriteChar(f.bufptr^[f.bufpos]);
inc(f.bufpos); inc(f.bufpos);
end; end;
#79 : while f.bufpos<f.bufend do #79 : while f.bufpos<f.bufend do begin
begin
WriteChar(f.bufptr^[f.bufpos]); WriteChar(f.bufptr^[f.bufpos]);
inc(f.bufpos); inc(f.bufpos);
end; end;
@ -853,16 +736,13 @@ Begin
inc(f.bufend,2); inc(f.bufend,2);
break; break;
end; end;
#26 : if CheckEOF then #26 : if CheckEOF then begin
begin
f.bufptr^[f.bufend]:=#26; f.bufptr^[f.bufend]:=#26;
inc(f.bufend); inc(f.bufend);
break; break;
end; end;
else else begin
begin if f.bufpos<f.bufsize-2 then begin
if f.bufpos<f.bufsize-2 then
begin
f.buffer[f.bufpos]:=ch; f.buffer[f.bufpos]:=ch;
inc(f.bufpos); inc(f.bufpos);
WriteChar(ch); WriteChar(ch);
@ -891,13 +771,10 @@ End;
Function CrtOpen(Var F: TextRec): Integer; Function CrtOpen(Var F: TextRec): Integer;
Begin Begin
If F.Mode=fmOutput Then If F.Mode=fmOutput Then begin
begin
TextRec(F).InOutFunc:=@CrtWrite; TextRec(F).InOutFunc:=@CrtWrite;
TextRec(F).FlushFunc:=@CrtWrite; TextRec(F).FlushFunc:=@CrtWrite;
end end Else begin
Else
begin
F.Mode:=fmInput; F.Mode:=fmInput;
TextRec(F).InOutFunc:=@CrtRead; TextRec(F).InOutFunc:=@CrtRead;
TextRec(F).FlushFunc:=@CrtReturn; TextRec(F).FlushFunc:=@CrtReturn;
@ -913,78 +790,54 @@ begin
TextRec(F).OpenFunc:=@CrtOpen; TextRec(F).OpenFunc:=@CrtOpen;
end; end;
const
conout : pchar = 'CONOUT$';
var var
CursorInfo : TConsoleCursorInfo; CursorInfo : TConsoleCursorInfo;
ConsoleInfo : TConsoleScreenBufferinfo; ConsoleInfo : TConsoleScreenBufferinfo;
// ts
begin begin
{ Initialize the output handles } { Initialize the output handles }
OutHandle := GetStdHandle(STD_OUTPUT_HANDLE);
InputHandle := GetStdHandle(STD_INPUT_HANDLE);
LastMode := 3; LastMode := 3;
SetActiveWindow(0);
{--------------------- Get the cursor size and such -----------------------} {--------------------- Get the cursor size and such -----------------------}
FillChar(CursorInfo, SizeOf(CursorInfo), 00); FillChar(CursorInfo, SizeOf(CursorInfo), 00);
GetConsoleCursorInfo(OutHandle, CursorInfo); GetConsoleCursorInfo(GetStdHandle(STD_OUTPUT_HANDLE), CursorInfo);
SaveCursorSize := CursorInfo.dwSize; SaveCursorSize := CursorInfo.dwSize;
{------------------ Get the current cursor position and attr --------------} {------------------ Get the current cursor position and attr --------------}
FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0); FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0);
if not GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo) then GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), ConsoleInfo);
begin
OutHandle:=CreateFile(ConOut, generic_read or generic_write,
file_share_read or file_share_write,nil,
open_existing,0,0);
If (OutHandle=Invalid_handle_value) then
begin
Writeln(stderr,'No way to get the console handle');
Halt(1);
end;
if not GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo) then
begin
Writeln(stderr,'No way to get console screen buffer info');
Halt(1);
end;
end;
CursorSaveX := ConsoleInfo.dwCursorPosition.X;
CursorSaveY := ConsoleInfo.dwCursorPosition.Y;
TextAttr := ConsoleInfo.wAttributes; TextAttr := ConsoleInfo.wAttributes;
{ Load startup values } { Load startup values }
ScreenWidth := GetScreenWidth;
ScreenHeight := GetScreenHeight;
IsWindowsNT := (GetPlatformID = VER_PLATFORM_WIN32_NT);
TurnMouseOff; TurnMouseOff;
WinMinX:=1; WindMinX := (ConsoleInfo.srWindow.Left) + 1;
WinMinY:=1; WindMinY := (ConsoleInfo.srWindow.Top) + 1;
WinMaxX:=ScreenWidth; WindMaxX := (ConsoleInfo.srWindow.Right) + 1;
WinMaxY:=ScreenHeight; WindMaxY := (ConsoleInfo.srWindow.Bottom) + 1;
WindMax := (ScreenWidth - 1) OR ((ScreenHeight - 1) SHL 8);
DoingNumChars := false; DoingNumChars := false;
DoingNumCode := 0; DoingNumCode := 0;
{ Redirect the standard output } { Redirect the standard output }
AssignCrt(Output); AssignCrt(Output);
Rewrite(Output); Rewrite(Output);
TextRec(Output).Handle:= OutHandle; TextRec(Output).Handle:= GetStdHandle(STD_OUTPUT_HANDLE);
AssignCrt(Input); AssignCrt(Input);
Reset(Input); Reset(Input);
TextRec(Input).Handle:= InputHandle; TextRec(Input).Handle:= GetStdHandle(STD_INPUT_HANDLE);
end. { unit Crt } end. { unit Crt }
{ {
$Log$ $Log$
Revision 1.10 2001-06-29 19:43:40 peter Revision 1.11 2001-07-13 17:43:25 peter
* fixed clreol * updates from Tomas Schatzl so it works better with w2k virtual
consoles
Revision 1.9 2001/06/27 20:21:47 peter
* support large screens
Revision 1.8 2001/04/14 14:05:42 peter Revision 1.8 2001/04/14 14:05:42 peter
* fixed for stricter checking * fixed for stricter checking