Mega Code Archive
Turbo Pascal Compatibility CRT
<![CDATA[
Title: Turbo Pascal Compatibility: CRT
One of my interests of late has been compatibility routines for Delphi. I thought I'd share what I've come up with so far, in case it might help anyone wanting to do some of the things that they knew to do in Turbo Pascal but haven't figured out the Win32 way to do it.
Here's the first one. I started from a CRT unit by Frank Zimmer, but I tested and made changes to it to try to make it act like the old Turbo Pascal CRT unit. I'm sure there probably is an error I haven't found, so by all means let me know if you do find one.
Anything that is missing from this unit that is in the TP CRT unit is not there because I couldn't figure out a good way to do it (or it's not a smart thing to do under Win32).
Hope this helps.
CODE
unit crt;
{ Copied from freeware CRT unit by Frank Zimmer, 01.18.1997
various fixes and edits done to the file by Glenn9999
helps from swisscenter version of CRT }
interface
uses windows,messages;
const
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
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 }
C40 = CO40;
C80 = CO80;
Win32Platform: Cardinal = VER_PLATFORM_WIN32_WINDOWS; {VER_PLATFORM_WIN32_NT;}
Function WhereX: integer;
Function WhereY: integer;
procedure ClrEol;
procedure ClrScr;
procedure InsLine;
Procedure DelLine;
Procedure GotoXY(const x,y:integer);
procedure HighVideo;
procedure LowVideo;
procedure NormVideo;
procedure TextBackground(const Color:word);
procedure TextColor(const Color:word);
procedure delay(ms: integer);
function KeyPressed:boolean;
function ReadKey:Char;
Procedure Sound(SF: Smallint);
Procedure NoSound;
procedure ConsoleEnd;
procedure FlushInputBuffer;
Function Pipe:boolean;
procedure TextMode(mode: integer);
procedure Window(X1, Y1, X2, Y2: Byte);
var
HConsoleInput:thandle;
HConsoleOutput:thandle;
HConsoleError:Thandle;
WindMin:tcoord;
WindMax:tcoord;
ViewMax:tcoord;
TextAttr : Word;
LastMode : Word;
OldConsoleMode: DWord;
SoundFrequency: Integer;
SoundDuration: integer;
soundcalled: boolean; // flag for delay on usage for sound & nosound
tbcolor: word; // backup text background for ribbon code
implementation
uses sysutils;
var
StartAttr:word;
OldCP:integer;
CrtPipe : Boolean;
procedure ClrEol;
var tC :tCoord;
Len,Nw: integer;
Cbi : TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(HConsoleOutput,cbi);
len := cbi.dwsize.x-cbi.dwcursorposition.x;
tc.x := cbi.dwcursorposition.x;
tc.y := cbi.dwcursorposition.y;
FillConsoleOutputAttribute(HConsoleOutput,textattr,len,tc,nw);
FillConsoleOutputCharacter(HConsoleOutput,#32,len,tc,nw);
end;
procedure ClrScr;
var tc :tcoord;
nw: integer;
cbi : TConsoleScreenBufferInfo;
begin
getConsoleScreenBufferInfo(HConsoleOutput,cbi);
tc.x := 0;
tc.y := 0;
FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,tc,nw);
FillConsoleOutputCharacter(HConsoleOutput,#32,cbi.dwsize.x*cbi.dwsize.y,tc,nw);
setConsoleCursorPosition(hconsoleoutput,tc);
end;
Function WhereX: integer;
var cbi : TConsoleScreenBufferInfo;
begin
getConsoleScreenBufferInfo(HConsoleOutput,cbi);
result := tcoord(cbi.dwCursorPosition).x+1
end;
Function WhereY: integer;
var cbi : TConsoleScreenBufferInfo;
begin
getConsoleScreenBufferInfo(HConsoleOutput,cbi);
result := tcoord(cbi.dwCursorPosition).y+1
end;
Procedure GotoXY(const x,y:integer);
var coord :tcoord;
begin
coord.x := x-1;
coord.y := y-1;
setConsoleCursorPosition(hconsoleoutput,coord);
end;
procedure InsLine;
var
cbi : TConsoleScreenBufferInfo;
ssr:tsmallrect;
coord :tcoord;
ci :tcharinfo;
nw:integer;
begin
getConsoleScreenBufferInfo(HConsoleOutput,cbi);
coord := cbi.dwCursorPosition;
ssr.left := 0;
ssr.top := coord.y;
ssr.right := cbi.srwindow.right;
ssr.bottom := cbi.srwindow.bottom;
ci.asciichar := #32;
ci.attributes := cbi.wattributes;
coord.x := 0;
coord.y := coord.y+1;
ScrollConsoleScreenBuffer(HconsoleOutput,ssr,nil,coord,ci);
coord.y := coord.y-1;
FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,coord,nw);
end;
procedure DelLine;
var
cbi : TConsoleScreenBufferInfo;
ssr:tsmallrect;
coord :tcoord;
ci :tcharinfo;
nw:integer;
begin
getConsoleScreenBufferInfo(HConsoleOutput,cbi);
coord := cbi.dwCursorPosition;
ssr.left := 0;
ssr.top := coord.y+1;
ssr.right := cbi.srwindow.right;
ssr.bottom := cbi.srwindow.bottom;
ci.asciichar := #32;
ci.attributes := cbi.wattributes;
coord.x := 0;
coord.y := coord.y;
ScrollConsoleScreenBuffer(HconsoleOutput,ssr,nil,coord,ci);
FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,coord,nw);
end;
procedure TextBackground(const Color:word);
begin
tbcolor := color;
LastMode := TextAttr;
textattr := (color shl 4) or (textattr and $f);
SetConsoleTextAttribute(hconsoleoutput,textattr);
end;
procedure TextColor(const Color:word);
begin
LastMode := TextAttr;
textattr := (color and $f) or (textattr and $f0);
SetConsoleTextAttribute(hconsoleoutput,textattr);
end;
procedure HighVideo;
begin
LastMode := TextAttr;
textattr := textattr or $8;
SetConsoleTextAttribute(hconsoleoutput,textattr);
end;
procedure LowVideo;
begin
LastMode := TextAttr;
textattr := textattr and $f7;
SetConsoleTextAttribute(hconsoleoutput,textattr);
end;
procedure NormVideo;
begin
LastMode := TextAttr;
textattr := startAttr;
SetConsoleTextAttribute(hconsoleoutput,textattr);
end;
procedure FlushInputBuffer;
begin
FlushConsoleInputBuffer(hconsoleinput);
end;
function keypressed:boolean;
{ handles ANY events - might need restrict it to only keyboard }
var
NumberOfEvents:integer;
begin
GetNumberOfConsoleInputEvents(hconsoleinput,NumberOfEvents);
result := NumberOfEvents 0;
end;
function ReadKey: Char;
{ rewritten to support as DOS did
Zimmer did not handle keycodes properly for DOS CRT. His version:
1) Returned multiple key events, for keypress and release.
2) Did not handle function keys adequately (eg "F1" or "Delete")
3) Did not lock out keys that DOS did (eg "CTRL" or "SHIFT")
}
var
NumRead: Integer;
InputRec: TInputRecord;
ExtendedCode: Char;
outputchar: char;
eligible_key: boolean;
begin
eligible_key := false; { to not return ALL keys }
repeat
while ReadConsoleInput(HConsoleInput, InputRec, 1, NumRead) do
if (InputRec.EventType = KEY_EVENT) then break;
outputchar := InputRec.KeyEvent.AsciiChar;
ReadConsoleInput(HConsoleInput, InputRec, 1, NumRead);
ExtendedCode := #0;
if outputchar = #0 then
case InputRec.Keyevent.wVirtualKeyCode of
$21: ExtendedCode := #73; { PageUp}
$22: ExtendedCode := #81; { PageDown}
$23: ExtendedCode := #79; { End}
$24: ExtendedCode := #71; { Home }
$25: ExtendedCode := #75; { left arrow }
$26: ExtendedCode := #72; { Up arrow}
$27: ExtendedCode := #77; { right arrow }
$28: ExtendedCode := #80; { down arrow }
$2D: ExtendedCode := #82; { insert }
$2E: ExtendedCode := #83; { delete }
$70: ExtendedCode := #59; { F1 }
$71: ExtendedCode := #60; { F2 }
$72: ExtendedCode := #61; { F3 }
$73: ExtendedCode := #62; { F4 }
$74: ExtendedCode := #63; { F5 }
$75: ExtendedCode := #64; { F6 }
$76: ExtendedCode := #65; { F7 }
$77: ExtendedCode := #66; { F8 }
$78: ExtendedCode := #67; { F9 }
$79: ExtendedCode := #68; { F10 }
$7A: ExtendedCode := #133; { F11 }
$7B: ExtendedCode := #134; { F12 }
end
else
eligible_key := true;
if ExtendedCode #0 then
begin
InputRec.EventType := KEY_EVENT;
InputRec.KeyEvent.AsciiChar := ExtendedCode;
WriteConsoleInput(HConsoleInput, InputRec, 1, NumRead);
WriteConsoleInput(HConsoleInput, InputRec, 1, NumRead);
eligible_key := true;
end
until eligible_key;
Result := outputchar;
end;
procedure dossound(Hz: Word);
{ from R. Velthuis code }
begin
asm
MOV AL,$B6
OUT $43,AL
MOV AX,$3540
MOV DX,$0012
MOV CX,Hz
DIV CX
OUT $42,AL
MOV AL,AH
OUT $42,AL
MOV AL,3
OUT $61,AL
end;
end;
procedure dossoundend;
{ from R. Velthuis code }
begin
asm
MOV AL,0
OUT $61,AL
end;
end;
Procedure Sound(SF: Smallint);
{ rewritten to be compatible with DOS sound/delay/nosound call }
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
// store frequency for later
soundfrequency := SF;
soundcalled := true;
end
else
DosSound(SF);
end;
procedure delay(ms: integer);
{ rewritten to support sound call }
begin
if soundcalled then
windows.beep(SoundFrequency, ms)
else
windows.sleep(ms);
end;
Procedure NoSound;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
soundcalled := false
else
dossoundend;
end;
procedure ConsoleEnd;
begin
if isconsole and not crtpipe then
begin
if wherex 1 then writeln;
textcolor(green);
setfocus(GetCurrentProcess);
normvideo;
FlushInputBuffer;
ReadKey;
FlushInputBuffer;
end;
end;
function Pipe:boolean;
begin
result := crtpipe;
end;
function CRTOutput(var F: TTextRec): integer;
{ output function for CRT, writes BufPos bytes and resets the buffer position
done to be able to format output
1) To not "ribbon" textbackground - textbackground(black) before #13#10 }
const
crlf: array[1..2] of char = #13#10;
var
numtowrite, numwritten: integer;
res: integer;
begin
if (F.Buffer[F.BufPos-2] = #13) and (F.Buffer[F.BufPos-1] = #10) then
// handle CR/LF combination, this is writeln
begin
if F.BufPos-2
]]>