mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-12 12:26:02 +02:00
+ Merged driver support from fixbranch
This commit is contained in:
michael
parent
d038536ca8
commit
148dbc6022
@ -4,7 +4,7 @@
|
||||
Copyright (c) 1999-2000 by Florian Klaempfl
|
||||
member of the Free Pascal development team
|
||||
|
||||
Video unit for linux
|
||||
Video unit for DOS
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
@ -58,9 +58,11 @@ var r: trealregs;
|
||||
L: longint;
|
||||
LSel,LSeg: word;
|
||||
B: array[0..63] of byte;
|
||||
type TWord = word; PWord = ^TWord;
|
||||
var Size: word;
|
||||
OK: boolean;
|
||||
type
|
||||
TWord = word;
|
||||
PWord = ^TWord;
|
||||
var
|
||||
OK: boolean;
|
||||
begin
|
||||
L:=global_dos_alloc(64);
|
||||
LSeg:=(L shr 16);
|
||||
@ -80,7 +82,7 @@ begin
|
||||
BIOSGetScreenMode:=OK;
|
||||
end;
|
||||
|
||||
procedure InitVideo;
|
||||
procedure SysInitVideo;
|
||||
var
|
||||
regs : trealregs;
|
||||
begin
|
||||
@ -122,7 +124,6 @@ begin
|
||||
VideoBufSize:=ScreenWidth*ScreenHeight*2;
|
||||
GetMem(VideoBuf,VideoBufSize);
|
||||
GetMem(OldVideoBuf,VideoBufSize);
|
||||
InitVideoCalled:=true;
|
||||
SetHighBitBlink;
|
||||
SetCursorType(LastCursorType);
|
||||
{ ClearScreen; removed here
|
||||
@ -130,31 +131,27 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure DoneVideo;
|
||||
procedure SysDoneVideo;
|
||||
begin
|
||||
If InitVideoCalled then
|
||||
Begin
|
||||
LastCursorType:=GetCursorType;
|
||||
ClearScreen;
|
||||
SetCursorType(crUnderLine);
|
||||
SetCursorPos(0,0);
|
||||
FreeMem(VideoBuf,VideoBufSize);
|
||||
VideoBuf:=nil;
|
||||
FreeMem(OldVideoBuf,VideoBufSize);
|
||||
OldVideoBuf:=nil;
|
||||
InitVideoCalled:=false;
|
||||
VideoBufSize:=0;
|
||||
End;
|
||||
LastCursorType:=GetCursorType;
|
||||
ClearScreen;
|
||||
SetCursorType(crUnderLine);
|
||||
SetCursorPos(0,0);
|
||||
FreeMem(VideoBuf,VideoBufSize);
|
||||
VideoBuf:=nil;
|
||||
FreeMem(OldVideoBuf,VideoBufSize);
|
||||
OldVideoBuf:=nil;
|
||||
VideoBufSize:=0;
|
||||
end;
|
||||
|
||||
|
||||
function GetCapabilities: Word;
|
||||
function SysGetCapabilities: Word;
|
||||
begin
|
||||
GetCapabilities := $3F;
|
||||
SysGetCapabilities := $3F;
|
||||
end;
|
||||
|
||||
|
||||
procedure SetCursorPos(NewCursorX, NewCursorY: Word);
|
||||
procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
|
||||
var
|
||||
regs : trealregs;
|
||||
begin
|
||||
@ -170,28 +167,28 @@ end;
|
||||
{ I don't know the maximum value for the scan line
|
||||
probably 7 or 15 depending on resolution !!
|
||||
}
|
||||
function GetCursorType: Word;
|
||||
function SysGetCursorType: Word;
|
||||
var
|
||||
regs : trealregs;
|
||||
begin
|
||||
regs.ah:=$03;
|
||||
regs.bh:=0;
|
||||
realintr($10,regs);
|
||||
GetCursorType:=crHidden;
|
||||
SysGetCursorType:=crHidden;
|
||||
if (regs.ch and $60)=0 then
|
||||
begin
|
||||
GetCursorType:=crBlock;
|
||||
SysGetCursorType:=crBlock;
|
||||
if (regs.ch and $1f)<>0 then
|
||||
begin
|
||||
GetCursorType:=crHalfBlock;
|
||||
SysGetCursorType:=crHalfBlock;
|
||||
if regs.cl+1=(regs.ch and $1F) then
|
||||
GetCursorType:=crUnderline;
|
||||
SysGetCursorType:=crUnderline;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure SetCursorType(NewType: Word);
|
||||
procedure SysSetCursorType(NewType: Word);
|
||||
var
|
||||
regs : trealregs;
|
||||
const
|
||||
@ -254,14 +251,14 @@ begin
|
||||
DoCustomMouse(false);
|
||||
end;
|
||||
|
||||
procedure ClearScreen;
|
||||
procedure SysClearScreen;
|
||||
begin
|
||||
FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
|
||||
UpdateScreen(true);
|
||||
end;
|
||||
|
||||
|
||||
procedure UpdateScreen(Force: Boolean);
|
||||
procedure SysUpdateScreen(Force: Boolean);
|
||||
begin
|
||||
if LockUpdateScreen<>0 then
|
||||
exit;
|
||||
@ -294,8 +291,22 @@ begin
|
||||
RegisterVideoMode(80, 50, True, @VideoModeSelector8x8, 0);
|
||||
end;
|
||||
|
||||
Const
|
||||
SysVideoDriver : TVideoDriver = (
|
||||
InitDriver : @SysInitVideo;
|
||||
DoneDriver : @SysDoneVideo;
|
||||
UpdateScreen : @SysUpdateScreen;
|
||||
ClearScreen : @SysClearScreen;
|
||||
SetVideoMode : Nil;
|
||||
HasVideoMode : Nil;
|
||||
SetCursorPos : @SysSetCursorPos;
|
||||
GetCursorType : @SysGetCursorType;
|
||||
SetCursorType : @SysSetCursorType;
|
||||
GetCapabilities : @SysGetCapabilities
|
||||
);
|
||||
|
||||
initialization
|
||||
SetVideoDriver(SysVideoDriver);
|
||||
RegisterVideoModes;
|
||||
|
||||
finalization
|
||||
@ -303,9 +314,25 @@ finalization
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2001-05-09 19:53:28 peter
|
||||
Revision 1.3 2001-09-21 19:50:18 michael
|
||||
+ Merged driver support from fixbranch
|
||||
|
||||
|
||||
Revision 1.2 2001/05/09 19:53:28 peter
|
||||
* removed asm for copy, use dosmemput (merged)
|
||||
|
||||
Revision 1.1.2.4 2001/09/21 18:42:08 michael
|
||||
+ Implemented support for custom video drivers.
|
||||
|
||||
Revision 1.1.2.3 2001/05/06 21:54:23 carl
|
||||
* bugfix of Windows NT double exception crash
|
||||
|
||||
Revision 1.1.2.2 2001/04/16 10:56:13 peter
|
||||
* fixes for stricter compiler
|
||||
|
||||
Revision 1.1.2.1 2001/01/30 21:52:01 peter
|
||||
* moved api utils to rtl
|
||||
|
||||
Revision 1.1 2001/01/13 11:03:58 peter
|
||||
* API 2 RTL commit
|
||||
|
||||
|
||||
@ -12,6 +12,128 @@
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
Const
|
||||
LockUpdateScreen : Integer = 0;
|
||||
|
||||
Procedure LockScreenUpdate;
|
||||
|
||||
begin
|
||||
Inc(LockUpdateScreen);
|
||||
end;
|
||||
|
||||
Procedure UnLockScreenUpdate;
|
||||
|
||||
begin
|
||||
Dec(LockUpdateScreen);
|
||||
end;
|
||||
|
||||
Var
|
||||
CurrentVideoDriver : TVideoDriver;
|
||||
|
||||
Const
|
||||
VideoInitialized : Boolean = False;
|
||||
|
||||
Procedure SetVideoDriver (Const Driver : TVideoDriver);
|
||||
{ Sets the videodriver to be used }
|
||||
begin
|
||||
If Not VideoInitialized then
|
||||
CurrentVideoDriver:=Driver;
|
||||
end;
|
||||
|
||||
Procedure GetVideoDriver (Var Driver : TVideoDriver);
|
||||
{ Retrieves the current videodriver }
|
||||
begin
|
||||
Driver:=CurrentVideoDriver;
|
||||
end;
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
External functions that use the video driver.
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
Procedure InitVideo;
|
||||
|
||||
begin
|
||||
If Not VideoInitialized then
|
||||
begin
|
||||
If Assigned(CurrentVideoDriver.InitDriver) then
|
||||
CurrentVideoDriver.InitDriver;
|
||||
VideoInitialized:=True;
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure DoneVideo;
|
||||
|
||||
begin
|
||||
If VideoInitialized then
|
||||
begin
|
||||
If Assigned(CurrentVideoDriver.DoneDriver) then
|
||||
CurrentVideoDriver.DoneDriver;
|
||||
VideoInitialized:=False;
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure UpdateScreen (Force : Boolean);
|
||||
|
||||
begin
|
||||
If (LockUpdateScreen<=0) and
|
||||
Assigned(CurrentVideoDriver.UpdateScreen) then
|
||||
CurrentVideoDriver.UpdateScreen(Force);
|
||||
end;
|
||||
|
||||
Procedure ClearScreen;
|
||||
|
||||
begin
|
||||
If Assigned(CurrentVideoDriver.ClearScreen) then
|
||||
CurrentVideoDriver.ClearScreen
|
||||
else
|
||||
begin
|
||||
FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
|
||||
UpdateScreen(True);
|
||||
// Is this needed ?
|
||||
{
|
||||
CurrentX:=1;
|
||||
CurrentY:=1;
|
||||
}
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure SetCursorType (NewType : Word);
|
||||
|
||||
begin
|
||||
if Assigned(CurrentVideoDriver.SetCursorType) then
|
||||
CurrentVideoDriver.SetCursorType(NewType)
|
||||
end;
|
||||
|
||||
Function GetCursorType : Word;
|
||||
|
||||
begin
|
||||
if Assigned(CurrentVideoDriver.GetCursorType) then
|
||||
GetCursorType:=CurrentVideoDriver.GetCursorType()
|
||||
else
|
||||
GetCursorType:=0;
|
||||
end;
|
||||
|
||||
procedure SetCursorPos(NewCursorX, NewCursorY: Word);
|
||||
|
||||
begin
|
||||
If Assigned(CurrentVideoDriver.SetCursorPos) then
|
||||
CurrentVideoDriver.SetCursorPos(NewCursorX, NewCursorY)
|
||||
end;
|
||||
|
||||
function GetCapabilities: Word;
|
||||
begin
|
||||
If Assigned(CurrentVideoDriver.GetCapabilities) then
|
||||
GetCapabilities:=CurrentVideoDriver.GetCapabilities()
|
||||
else
|
||||
GetCapabilities:=0;
|
||||
end;
|
||||
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
General functions
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
|
||||
procedure GetVideoMode(var Mode: TVideoMode);
|
||||
begin
|
||||
Mode.Col := ScreenWidth;
|
||||
@ -19,6 +141,8 @@ begin
|
||||
Mode.Color := ScreenColor;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure SetVideoMode(Mode: TVideoMode);
|
||||
var
|
||||
P: PVideoModeList;
|
||||
@ -72,9 +196,20 @@ begin
|
||||
DefaultErrorHandler := errAbort; { return error code }
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2001-01-13 11:13:12 peter
|
||||
Revision 1.2 2001-09-21 19:50:18 michael
|
||||
+ Merged driver support from fixbranch
|
||||
|
||||
Revision 1.1.2.2 2001/09/21 18:42:08 michael
|
||||
+ Implemented support for custom video drivers.
|
||||
|
||||
Revision 1.1.2.1 2001/01/30 22:21:22 peter
|
||||
* move api to rtl
|
||||
|
||||
Revision 1.1 2001/01/13 11:13:12 peter
|
||||
* API 2 RTL
|
||||
|
||||
}
|
||||
|
||||
@ -26,6 +26,19 @@ type
|
||||
TVideoBuf = array[0..32759] of TVideoCell;
|
||||
PVideoBuf = ^TVideoBuf;
|
||||
|
||||
TVideoDriver = Record
|
||||
InitDriver : Procedure;
|
||||
DoneDriver : Procedure;
|
||||
UpdateScreen : Procedure(Force : Boolean);
|
||||
ClearScreen : Procedure;
|
||||
SetVideoMode : Procedure (Const Mode : TVideoMode; Params : Longint);
|
||||
HasVideoMode : Function (Const Mode : TVideoMode; Params : Longint) : Boolean;
|
||||
SetCursorPos : procedure (NewCursorX, NewCursorY: Word);
|
||||
GetCursorType : function : Word;
|
||||
SetCursorType : procedure (NewType: Word);
|
||||
GetCapabilities : Function : Word;
|
||||
end;
|
||||
|
||||
const
|
||||
{ Foreground and background color constants }
|
||||
Black = 0;
|
||||
@ -80,15 +93,24 @@ var
|
||||
ScreenColor : Boolean;
|
||||
CursorX,
|
||||
CursorY : Word;
|
||||
LockUpdateScreen : Word;
|
||||
VideoBuf : PVideoBuf;
|
||||
VideoBufSize : Longint;
|
||||
CursorLines : Byte;
|
||||
|
||||
const
|
||||
LowAscii : Boolean = true;
|
||||
NoExtendedFrame : Boolean = false;
|
||||
FVMaxWidth = 132;
|
||||
|
||||
Procedure LockScreenUpdate;
|
||||
{ Increments the screen update lock count with one.}
|
||||
Procedure UnlockScreenUpdate;
|
||||
{ Decrements the screen update lock count with one.}
|
||||
Procedure SetVideoDriver (Const Driver : TVideoDriver);
|
||||
{ Sets the videodriver to be used }
|
||||
Procedure GetVideoDriver (Var Driver : TVideoDriver);
|
||||
{ Retrieves the current videodriver }
|
||||
|
||||
procedure InitVideo;
|
||||
{ Initializes the video subsystem }
|
||||
procedure DoneVideo;
|
||||
@ -152,7 +174,15 @@ const
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2001-06-06 17:20:22 jonas
|
||||
Revision 1.3 2001-09-21 19:50:18 michael
|
||||
+ Merged driver support from fixbranch
|
||||
|
||||
Revision 1.2 2001/06/06 17:20:22 jonas
|
||||
|
||||
Revision 1.1.2.3 2001/09/21 18:42:08 michael
|
||||
+ Implemented support for custom video drivers.
|
||||
|
||||
Revision 1.1.2.2 2001/06/06 14:27:14 jonas
|
||||
* fixed wrong typed constant procvars in preparation of my fix which will
|
||||
disallow them in FPC mode (plus some other unmerged changes since
|
||||
LAST_MERGE)
|
||||
|
||||
109
rtl/os2/video.pp
109
rtl/os2/video.pp
@ -29,7 +29,6 @@ uses
|
||||
|
||||
|
||||
const
|
||||
InitVideoCalled: boolean = false;
|
||||
LastCursorType: word = crUnderline;
|
||||
EmptyCell: cardinal = $0720;
|
||||
OrigScreen: PVideoBuf = nil;
|
||||
@ -141,41 +140,39 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure InitVideo;
|
||||
procedure SysInitVideo;
|
||||
|
||||
var MI: TVioModeInfo;
|
||||
|
||||
begin
|
||||
if InitVideoCalled then
|
||||
FreeMem (OldVideoBuf, VideoBufSize);
|
||||
OldVideoBuf := nil;
|
||||
InitVideoCalled := true;
|
||||
VideoBufSize := 0;
|
||||
MI.cb := SizeOf (MI);
|
||||
VioGetMode (MI, 0);
|
||||
with MI do
|
||||
begin
|
||||
ScreenWidth := Col;
|
||||
ScreenHeight := Row;
|
||||
ScreenColor := Color >= Colors_16;
|
||||
end;
|
||||
VioGetCurPos (CursorY, CursorX, 0);
|
||||
LowAscii := true;
|
||||
SetCursorType (LastCursorType);
|
||||
{Get the address of the videobuffer.}
|
||||
if VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0) = 0 then
|
||||
begin
|
||||
VideoBuf := SelToFlat (TFarPtr (VideoBuf));
|
||||
SetHighBitBlink (true);
|
||||
GetMem (OldVideoBuf, VideoBufSize);
|
||||
Move (VideoBuf^, OldVideoBuf^, VideoBufSize);
|
||||
end
|
||||
else
|
||||
ErrorHandler (errVioInit, nil);
|
||||
FreeMem (OldVideoBuf, VideoBufSize);
|
||||
OldVideoBuf := nil;
|
||||
VideoBufSize := 0;
|
||||
MI.cb := SizeOf (MI);
|
||||
VioGetMode (MI, 0);
|
||||
with MI do
|
||||
begin
|
||||
ScreenWidth := Col;
|
||||
ScreenHeight := Row;
|
||||
ScreenColor := Color >= Colors_16;
|
||||
end;
|
||||
VioGetCurPos (CursorY, CursorX, 0);
|
||||
LowAscii := true;
|
||||
SetCursorType (LastCursorType);
|
||||
{ Get the address of the videobuffer.}
|
||||
if VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0) = 0 then
|
||||
begin
|
||||
VideoBuf := SelToFlat (TFarPtr (VideoBuf));
|
||||
SetHighBitBlink (true);
|
||||
GetMem (OldVideoBuf, VideoBufSize);
|
||||
Move (VideoBuf^, OldVideoBuf^, VideoBufSize);
|
||||
end
|
||||
else
|
||||
ErrorHandler (errVioInit, nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure SetCursorPos (NewCursorX, NewCursorY: word);
|
||||
procedure SysSetCursorPos (NewCursorX, NewCursorY: word);
|
||||
|
||||
begin
|
||||
if VioSetCurPos (NewCursorY, NewCursorX, 0) = 0 then
|
||||
@ -191,7 +188,7 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
function GetCursorType: word;
|
||||
function SysGetCursorType: word;
|
||||
|
||||
var CD: TVioCursorInfo;
|
||||
|
||||
@ -201,24 +198,24 @@ begin
|
||||
begin
|
||||
CursorLines := Succ (cEnd) - yStart;
|
||||
if Attr = word (-1) then
|
||||
GetCursorType := crHidden
|
||||
SysGetCursorType := crHidden
|
||||
else
|
||||
{Because the cursor's start and end lines are returned, we'll have
|
||||
to guess heuristically what cursor type we have.}
|
||||
if CursorLines = 0 then
|
||||
{Probably this does not occur, but you'll never know.}
|
||||
GetCursorType := crHidden
|
||||
SysGetCursorType := crHidden
|
||||
else if CursorLines <= Succ (CellHeight div 4) then
|
||||
GetCursorType := crUnderline
|
||||
SysGetCursorType := crUnderline
|
||||
else if CursorLines <= Succ (CellHeight div 2) then
|
||||
GetCursorType := crHalfBlock
|
||||
SysGetCursorType := crHalfBlock
|
||||
else
|
||||
GetCursorType := crBlock;
|
||||
SysGetCursorType := crBlock;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure SetCursorType (NewType: word);
|
||||
procedure SysSetCursorType (NewType: word);
|
||||
|
||||
var CD: TVioCursorInfo;
|
||||
|
||||
@ -254,14 +251,12 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure DoneVideo;
|
||||
procedure SysDoneVideo;
|
||||
|
||||
var PScr: pointer;
|
||||
ScrSize: cardinal;
|
||||
|
||||
begin
|
||||
if InitVideoCalled then
|
||||
begin
|
||||
LastCursorType := GetCursorType;
|
||||
ClearScreen;
|
||||
{Restore original settings}
|
||||
@ -275,7 +270,6 @@ begin
|
||||
FreeMem (OldVideoBuf, VideoBufSize);
|
||||
OldVideoBuf := nil;
|
||||
VideoBufSize := 0;
|
||||
InitVideoCalled := false;
|
||||
if (OrigScreenSize <> 0) and (OrigScreen <> nil) then
|
||||
begin
|
||||
ScrSize := 0;
|
||||
@ -287,14 +281,13 @@ begin
|
||||
VioShowBuf (0, ScrSize, 0);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function GetCapabilities: word;
|
||||
function SysGetCapabilities: word;
|
||||
|
||||
begin
|
||||
GetCapabilities := $3F;
|
||||
SysGetCapabilities := $3F;
|
||||
end;
|
||||
|
||||
|
||||
@ -352,7 +345,7 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure ClearScreen;
|
||||
procedure SysClearScreen;
|
||||
|
||||
begin
|
||||
VioScrollDn (0, 0, word (-1), word (-1), word (-1), PWord (@EmptyCell)^, 0);
|
||||
@ -362,7 +355,7 @@ end;
|
||||
|
||||
{$ASMMODE INTEL}
|
||||
|
||||
procedure UpdateScreen (Force: boolean);
|
||||
procedure SysUpdateScreen (Force: boolean);
|
||||
|
||||
var SOfs, CLen: cardinal;
|
||||
|
||||
@ -421,7 +414,22 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
Const
|
||||
SysVideoDriver : TVideoDriver = (
|
||||
InitDriver : @SysInitVideo;
|
||||
DoneDriver : @SysDoneVideo;
|
||||
UpdateScreen : @SysUpdateScreen;
|
||||
ClearScreen : @SysClearScreen;
|
||||
SetVideoMode : Nil;
|
||||
HasVideoMode : Nil;
|
||||
SetCursorPos : @SysSetCursorPos;
|
||||
GetCursorType : @SysGetCursorType;
|
||||
SetCursorType : @SysSetCursorType;
|
||||
GetCapabilities : @SysGetCapabilities
|
||||
);
|
||||
|
||||
initialization
|
||||
SetVideoDriver(SysVideoDriver);
|
||||
RegisterVideoModes;
|
||||
TargetEntry;
|
||||
|
||||
@ -431,9 +439,18 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.4 2001-02-04 01:55:05 hajny
|
||||
Revision 1.5 2001-09-21 19:50:19 michael
|
||||
+ Merged driver support from fixbranch
|
||||
|
||||
Revision 1.4 2001/02/04 01:55:05 hajny
|
||||
* one more correction (not crucial)
|
||||
|
||||
Revision 1.2.2.3 2001/09/21 18:42:08 michael
|
||||
+ Implemented support for custom video drivers.
|
||||
|
||||
Revision 1.2.2.2 2001/02/04 02:02:28 hajny
|
||||
* corrections from the main branch merged
|
||||
|
||||
Revision 1.3 2001/02/01 21:35:36 hajny
|
||||
* correction of a previously introduced bug
|
||||
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{
|
||||
$Id$
|
||||
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by Florian Klaempfl
|
||||
member of the Free Pascal development team
|
||||
@ -46,6 +47,7 @@ const
|
||||
{$endif I386}
|
||||
|
||||
const
|
||||
|
||||
can_delete_term : boolean = false;
|
||||
ACSIn : string = '';
|
||||
ACSOut : string = '';
|
||||
@ -554,7 +556,7 @@ begin
|
||||
restoreRawSettings(preInitVideoTio);
|
||||
end;
|
||||
|
||||
procedure InitVideo;
|
||||
procedure SysInitVideo;
|
||||
const
|
||||
fontstr : string[3]=#27'(K';
|
||||
var
|
||||
@ -671,7 +673,7 @@ begin
|
||||
ErrorCode:=errVioInit; { not a TTY }
|
||||
end;
|
||||
|
||||
procedure DoneVideo;
|
||||
procedure SysDoneVideo;
|
||||
begin
|
||||
if VideoBufSize=0 then
|
||||
exit;
|
||||
@ -705,7 +707,7 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure ClearScreen;
|
||||
procedure SysClearScreen;
|
||||
begin
|
||||
FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
|
||||
if Console then
|
||||
@ -718,14 +720,12 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure UpdateScreen(Force: Boolean);
|
||||
procedure SysUpdateScreen(Force: Boolean);
|
||||
var
|
||||
DoUpdate : boolean;
|
||||
i : longint;
|
||||
p1,p2 : plongint;
|
||||
begin
|
||||
if LockUpdateScreen<>0 then
|
||||
exit;
|
||||
if not force then
|
||||
begin
|
||||
{$ifdef i386}
|
||||
@ -772,14 +772,14 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
function GetCapabilities: Word;
|
||||
function SysGetCapabilities: Word;
|
||||
begin
|
||||
{ about cpColor... we should check the terminfo database... }
|
||||
GetCapabilities:=cpUnderLine + cpBlink + cpColor;
|
||||
SysGetCapabilities:=cpUnderLine + cpBlink + cpColor;
|
||||
end;
|
||||
|
||||
|
||||
procedure SetCursorPos(NewCursorX, NewCursorY: Word);
|
||||
procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
|
||||
var
|
||||
Pos : array [1..2] of Byte;
|
||||
begin
|
||||
@ -800,13 +800,13 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
function GetCursorType: Word;
|
||||
function SysGetCursorType: Word;
|
||||
begin
|
||||
GetCursorType:=LastCursorType;
|
||||
SysGetCursorType:=LastCursorType;
|
||||
end;
|
||||
|
||||
|
||||
procedure SetCursorType(NewType: Word);
|
||||
procedure SysSetCursorType(NewType: Word);
|
||||
begin
|
||||
LastCursorType:=NewType;
|
||||
case NewType of
|
||||
@ -839,7 +839,22 @@ procedure RegisterVideoModes;
|
||||
begin
|
||||
end;
|
||||
|
||||
Const
|
||||
SysVideoDriver : TVideoDriver = (
|
||||
InitDriver : @SysInitVideo;
|
||||
DoneDriver : @SysDoneVideo;
|
||||
UpdateScreen : @SysUpdateScreen;
|
||||
ClearScreen : @SysClearScreen;
|
||||
SetVideoMode : Nil;
|
||||
HasVideoMode : Nil;
|
||||
SetCursorPos : @SysSetCursorPos;
|
||||
GetCursorType : @SysGetCursorType;
|
||||
SetCursorType : @SysSetCursorType;
|
||||
GetCapabilities : @SysGetCapabilities
|
||||
);
|
||||
|
||||
initialization
|
||||
SetVideoDriver(SysVideoDriver);
|
||||
RegisterVideoModes;
|
||||
|
||||
finalization
|
||||
@ -847,7 +862,10 @@ finalization
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.7 2001-08-30 20:55:08 peter
|
||||
Revision 1.8 2001-09-21 19:50:19 michael
|
||||
+ Merged driver support from fixbranch
|
||||
|
||||
Revision 1.7 2001/08/30 20:55:08 peter
|
||||
* v10 merges
|
||||
|
||||
Revision 1.6 2001/08/01 21:42:05 peter
|
||||
@ -859,6 +877,27 @@ end.
|
||||
Revision 1.4 2001/07/30 21:38:55 peter
|
||||
* m68k updates merged
|
||||
|
||||
Revision 1.2.2.8 2001/09/21 18:42:09 michael
|
||||
+ Implemented support for custom video drivers.
|
||||
|
||||
Revision 1.2.2.7 2001/08/28 12:23:15 pierre
|
||||
* set skipped to true if changing line and force is false to avoid problems if terminal reports less columns as available
|
||||
|
||||
Revision 1.2.2.6 2001/08/01 10:50:59 pierre
|
||||
* avoid warning for m68k cpu
|
||||
|
||||
Revision 1.2.2.5 2001/07/30 23:34:51 pierre
|
||||
* make tchattr record endian dependant
|
||||
|
||||
Revision 1.2.2.4 2001/07/29 20:25:18 pierre
|
||||
* fix wrong deref in generic compare code
|
||||
|
||||
Revision 1.2.2.3 2001/07/13 14:49:08 pierre
|
||||
+ implement videobuf comparaison for non i386 cpus
|
||||
|
||||
Revision 1.2.2.2 2001/01/30 22:23:44 peter
|
||||
* unix back to linux
|
||||
|
||||
Revision 1.3 2001/07/13 22:05:09 peter
|
||||
* cygwin updates
|
||||
|
||||
|
||||
@ -32,13 +32,10 @@ var
|
||||
ConsoleCursorInfo : TConsoleCursorInfo;
|
||||
MaxVideoBufSize : DWord;
|
||||
|
||||
const
|
||||
VideoInitialized : boolean = false;
|
||||
|
||||
procedure InitVideo;
|
||||
procedure SysInitVideo;
|
||||
|
||||
begin
|
||||
if VideoInitialized then
|
||||
DoneVideo;
|
||||
ScreenColor:=true;
|
||||
GetConsoleScreenBufferInfo(TextRec(Output).Handle, ConsoleInfo);
|
||||
GetConsoleCursorInfo(TextRec(Output).Handle, ConsoleCursorInfo);
|
||||
@ -78,30 +75,26 @@ begin
|
||||
|
||||
GetMem(VideoBuf,MaxVideoBufSize);
|
||||
GetMem(OldVideoBuf,MaxVideoBufSize);
|
||||
VideoInitialized:=true;
|
||||
end;
|
||||
|
||||
|
||||
procedure DoneVideo;
|
||||
procedure SysDoneVideo;
|
||||
begin
|
||||
SetCursorType(crUnderLine);
|
||||
if VideoInitialized then
|
||||
begin
|
||||
FreeMem(VideoBuf,MaxVideoBufSize);
|
||||
FreeMem(OldVideoBuf,MaxVideoBufSize);
|
||||
end;
|
||||
FreeMem(VideoBuf,MaxVideoBufSize);
|
||||
FreeMem(OldVideoBuf,MaxVideoBufSize);
|
||||
VideoBufSize:=0;
|
||||
VideoInitialized:=false;
|
||||
end;
|
||||
|
||||
|
||||
function GetCapabilities: Word;
|
||||
function SysGetCapabilities: Word;
|
||||
begin
|
||||
GetCapabilities:=cpColor or cpChangeCursor;
|
||||
SysGetCapabilities:=cpColor or cpChangeCursor;
|
||||
end;
|
||||
|
||||
|
||||
procedure SetCursorPos(NewCursorX, NewCursorY: Word);
|
||||
procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
|
||||
var
|
||||
pos : COORD;
|
||||
begin
|
||||
@ -113,24 +106,24 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
function GetCursorType: Word;
|
||||
function SysGetCursorType: Word;
|
||||
begin
|
||||
GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
|
||||
if not ConsoleCursorInfo.bvisible then
|
||||
GetCursorType:=crHidden
|
||||
SysGetCursorType:=crHidden
|
||||
else
|
||||
case ConsoleCursorInfo.dwSize of
|
||||
1..30:
|
||||
GetCursorType:=crUnderline;
|
||||
SysGetCursorType:=crUnderline;
|
||||
31..70:
|
||||
GetCursorType:=crHalfBlock;
|
||||
SysGetCursorType:=crHalfBlock;
|
||||
71..100:
|
||||
GetCursorType:=crBlock;
|
||||
SysGetCursorType:=crBlock;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure SetCursorType(NewType: Word);
|
||||
procedure SysSetCursorType(NewType: Word);
|
||||
begin
|
||||
GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo);
|
||||
if newType=crHidden then
|
||||
@ -159,7 +152,7 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure ClearScreen;
|
||||
procedure SysClearScreen;
|
||||
begin
|
||||
FillWord(VideoBuf^,VideoBufSize div 2,$0720);
|
||||
UpdateScreen(true);
|
||||
@ -171,7 +164,7 @@ function WriteConsoleOutput(hConsoleOutput:HANDLE; lpBuffer:pointer; dwBufferSiz
|
||||
var lpWriteRegion:SMALL_RECT):WINBOOL; external 'kernel32' name 'WriteConsoleOutputA';
|
||||
{$ENDIF}
|
||||
|
||||
procedure UpdateScreen(Force: Boolean);
|
||||
procedure SysUpdateScreen(Force: Boolean);
|
||||
type TmpRec = Array[0..(1024*32) - 1] of TCharInfo;
|
||||
|
||||
type WordRec = record
|
||||
@ -242,8 +235,6 @@ var
|
||||
x1,y1,x2,y2 : longint;
|
||||
|
||||
begin
|
||||
if LockUpdateScreen<>0 then
|
||||
exit;
|
||||
if force then
|
||||
smallforce:=true
|
||||
else
|
||||
@ -357,8 +348,23 @@ begin
|
||||
RegisterVideoMode(80, 25, True, @DefaultVideoModeSelector, $00000003);
|
||||
end;
|
||||
|
||||
Const
|
||||
SysVideoDriver : TVideoDriver = (
|
||||
InitDriver : @SysInitVideo;
|
||||
DoneDriver : @SysDoneVideo;
|
||||
UpdateScreen : @SysUpdateScreen;
|
||||
ClearScreen : @SysClearScreen;
|
||||
SetVideoMode : Nil;
|
||||
HasVideoMode : Nil;
|
||||
SetCursorPos : @SysSetCursorPos;
|
||||
GetCursorType : @SysGetCursorType;
|
||||
SetCursorType : @SysSetCursorType;
|
||||
GetCapabilities : @SysGetCapabilities
|
||||
|
||||
);
|
||||
|
||||
initialization
|
||||
SetVideoDriver(SysVideoDriver);
|
||||
RegisterVideoModes;
|
||||
|
||||
finalization
|
||||
@ -366,7 +372,10 @@ finalization
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.5 2001-08-01 18:01:20 peter
|
||||
Revision 1.6 2001-09-21 19:50:19 michael
|
||||
+ Merged driver support from fixbranch
|
||||
|
||||
Revision 1.5 2001/08/01 18:01:20 peter
|
||||
* WChar fix to compile also with 1.0.x
|
||||
|
||||
Revision 1.4 2001/07/30 15:01:12 marco
|
||||
@ -378,6 +387,21 @@ end.
|
||||
Revision 1.2 2001/04/10 21:28:36 peter
|
||||
* removed warnigns
|
||||
|
||||
Revision 1.1.2.5 2001/09/21 18:42:09 michael
|
||||
+ Implemented support for custom video drivers.
|
||||
|
||||
Revision 1.1.2.4 2001/06/12 22:34:20 pierre
|
||||
* avoid crash at exit of IDE
|
||||
|
||||
Revision 1.1.2.3 2001/04/10 20:33:04 peter
|
||||
* remove some warnings
|
||||
|
||||
Revision 1.1.2.2 2001/04/02 13:29:41 pierre
|
||||
* avoid crash if DoneVideo called twice
|
||||
|
||||
Revision 1.1.2.1 2001/01/30 21:52:03 peter
|
||||
* moved api utils to rtl
|
||||
|
||||
Revision 1.1 2001/01/13 11:03:59 peter
|
||||
* API 2 RTL commit
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user