mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-26 18:23:42 +02:00
436 lines
12 KiB
ObjectPascal
436 lines
12 KiB
ObjectPascal
{
|
|
$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
|
|
|
|
Video unit for OS/2
|
|
|
|
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 Video;
|
|
|
|
interface
|
|
|
|
{$i videoh.inc}
|
|
|
|
implementation
|
|
|
|
uses
|
|
DosCalls, VioCalls;
|
|
|
|
{$i video.inc}
|
|
|
|
|
|
const
|
|
InitVideoCalled: boolean = false;
|
|
LastCursorType: word = crUnderline;
|
|
EmptyCell: cardinal = $0720;
|
|
OrigScreen: PVideoBuf = nil;
|
|
OrigScreenSize: cardinal = 0;
|
|
|
|
var OrigCurType: TVioCursorInfo;
|
|
OrigVioMode: TVioModeInfo;
|
|
OrigHighBit: TVioIntensity;
|
|
OrigCurRow: word;
|
|
OrigCurCol: word;
|
|
CellHeight: byte;
|
|
OldVideoBuf: PVideoBuf;
|
|
|
|
procedure TargetEntry;
|
|
|
|
var P: PVideoModeList;
|
|
PScr: pointer;
|
|
|
|
begin
|
|
{Remember original video mode, cursor type and high bit behaviour setting}
|
|
OrigVioMode.cb := SizeOf (OrigVioMode);
|
|
VioGetMode (OrigVioMode, 0);
|
|
VioGetCurType (OrigCurType, 0);
|
|
VioGetCurPos (OrigCurRow, OrigCurCol, 0);
|
|
with OrigHighBit do
|
|
begin
|
|
cb := 6;
|
|
rType := 2;
|
|
end;
|
|
VioGetState (OrigHighBit, 0);
|
|
{Register the curent video mode in Modes if not there yet}
|
|
with OrigVioMode do
|
|
begin
|
|
P := Modes;
|
|
while (P <> nil) and ((P^.Row <> Row) or (P^.Col <> Col)
|
|
or (P^.Color <> (Color >= Colors_16))) do
|
|
P := P^.Next;
|
|
if P = nil then
|
|
{Assume we have at least 16 colours available in "colour" modes}
|
|
RegisterVideoMode (Col, Row, Color >= Colors_16,
|
|
@DefaultVideoModeSelector, 0);
|
|
end;
|
|
{Get the address of the original videobuffer and size.}
|
|
if VioGetBuf (PScr, PWord (@OrigScreenSize)^, 0) = 0 then
|
|
begin
|
|
PScr := SelToFlat (TFarPtr (PScr));
|
|
GetMem (OrigScreen, OrigScreenSize);
|
|
Move (PScr^, OrigScreen^, OrigScreenSize);
|
|
end;
|
|
end;
|
|
|
|
procedure CheckCellHeight;
|
|
|
|
var OldCD, CD: TVioCursorInfo;
|
|
|
|
begin
|
|
VioGetCurType (OldCD, 0);
|
|
Move (OldCD, CD, SizeOf (CD));
|
|
with CD do
|
|
begin
|
|
Attr := 0;
|
|
yStart := word (-90);
|
|
cEnd := word (-100);
|
|
end;
|
|
VioSetCurType (CD, 0);
|
|
VioGetCurType (CD, 0);
|
|
CellHeight := CD.cEnd;
|
|
VioSetCurType (OldCD, 0);
|
|
end;
|
|
|
|
|
|
procedure RegisterVideoModes;
|
|
begin
|
|
{ BW modes are rejected on my (colour) configuration. I can't imagine
|
|
OS/2 running on MCGA anyway... ;-)
|
|
|
|
RegisterVideoMode (40, 25, False, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 25, False, @DefaultVideoModeSelector, 0);
|
|
}
|
|
RegisterVideoMode (40, 25, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 25, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 30, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 43, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (80, 50, True, @DefaultVideoModeSelector, 0);
|
|
|
|
{ The following modes wouldn't work on plain VGA; is it useful to check
|
|
for their availability on the program startup?
|
|
|
|
RegisterVideoMode (132, 25, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (132, 30, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (132, 43, True, @DefaultVideoModeSelector, 0);
|
|
RegisterVideoMode (132, 50, True, @DefaultVideoModeSelector, 0);
|
|
}
|
|
end;
|
|
|
|
|
|
procedure SetHighBitBlink (Blink: boolean);
|
|
|
|
var VI: TVioIntensity;
|
|
|
|
begin
|
|
with VI do
|
|
begin
|
|
cb := 6;
|
|
rType := 2;
|
|
fs := byte (not (Blink));
|
|
end;
|
|
VioSetState (VI, 0);
|
|
end;
|
|
|
|
|
|
procedure InitVideo;
|
|
|
|
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);
|
|
end;
|
|
|
|
|
|
procedure SetCursorPos (NewCursorX, NewCursorY: word);
|
|
|
|
begin
|
|
if VioSetCurPos (NewCursorY, NewCursorX, 0) = 0 then
|
|
begin
|
|
CursorX := NewCursorX;
|
|
CursorY := NewCursorY;
|
|
end
|
|
else
|
|
{Do not set an error code; people should fix invalid NewCursorX
|
|
or NewCursorY values when designing, there is no need for detecting
|
|
these errors at runtime.}
|
|
RunError (225);
|
|
end;
|
|
|
|
|
|
function GetCursorType: word;
|
|
|
|
var CD: TVioCursorInfo;
|
|
|
|
begin
|
|
VioGetCurType (CD, 0); {Never fails, because handle is default handle.}
|
|
with CD do
|
|
begin
|
|
CursorLines := Succ (cEnd) - yStart;
|
|
if Attr = word (-1) then
|
|
GetCursorType := 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
|
|
else if CursorLines <= Succ (CellHeight div 4) then
|
|
GetCursorType := crUnderline
|
|
else if CursorLines <= Succ (CellHeight div 2) then
|
|
GetCursorType := crHalfBlock
|
|
else
|
|
GetCursorType := crBlock;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure SetCursorType (NewType: word);
|
|
|
|
var CD: TVioCursorInfo;
|
|
|
|
begin
|
|
VioGetCurType (CD, 0);
|
|
with CD do
|
|
begin
|
|
case NewType of
|
|
crHidden: Attr := word (-1);
|
|
crUnderline:
|
|
begin
|
|
Attr := 0;
|
|
yStart := word (-90);
|
|
cEnd := word (-100);
|
|
end;
|
|
crHalfBlock:
|
|
begin
|
|
Attr := 0;
|
|
yStart := word (-50);
|
|
cEnd := word (-100);
|
|
end;
|
|
crBlock:
|
|
begin
|
|
Attr := 0;
|
|
yStart := 0;
|
|
cEnd := word (-100);
|
|
end;
|
|
end;
|
|
VioSetCurType (CD, 0);
|
|
VioGetCurType (CD, 0);
|
|
CursorLines := Succ (cEnd) - yStart;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure DoneVideo;
|
|
|
|
var PScr: pointer;
|
|
ScrSize: cardinal;
|
|
|
|
begin
|
|
if InitVideoCalled then
|
|
begin
|
|
LastCursorType := GetCursorType;
|
|
ClearScreen;
|
|
{Restore original settings}
|
|
VioSetMode (OrigVioMode, 0);
|
|
CheckCellHeight;
|
|
{Set CursorX and CursorY}
|
|
SetCursorPos (0, 0);
|
|
VioSetState (OrigHighBit, 0);
|
|
VioSetCurType (OrigCurType, 0);
|
|
VioSetCurPos (OrigCurRow, OrigCurCol, 0);
|
|
FreeMem (OldVideoBuf, VideoBufSize);
|
|
OldVideoBuf := nil;
|
|
VideoBufSize := 0;
|
|
InitVideoCalled := false;
|
|
if (OrigScreenSize <> 0) and (OrigScreen <> nil) then
|
|
begin
|
|
ScrSize := 0;
|
|
if (VioGetBuf (PScr, PWord (@ScrSize)^, 0) = 0)
|
|
and (ScrSize = OrigScreenSize) then
|
|
begin
|
|
PScr := SelToFlat (TFarPtr (PScr));
|
|
Move (OrigScreen^, PScr^, OrigScreenSize);
|
|
VioShowBuf (0, ScrSize, 0);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function GetCapabilities: word;
|
|
|
|
begin
|
|
GetCapabilities := $3F;
|
|
end;
|
|
|
|
|
|
function DefaultVideoModeSelector (const VideoMode: TVideoMode; Params: longint): boolean;
|
|
|
|
var OldMI, MI: TVioModeInfo;
|
|
|
|
begin
|
|
OldMI.cb := SizeOf (OldMI);
|
|
if VioGetMode (OldMI, 0) <> 0 then
|
|
DefaultVideoModeSelector := false
|
|
else
|
|
begin
|
|
with MI do
|
|
begin
|
|
cb := 8;
|
|
fbType := 1;
|
|
if VideoMode.Color then
|
|
Color := Colors_16
|
|
else
|
|
Color := Colors_2;
|
|
Col := VideoMode.Col;
|
|
Row := VideoMode.Row;
|
|
end;
|
|
if VioSetMode (MI, 0) = 0 then
|
|
if VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0) = 0 then
|
|
begin
|
|
VideoBuf := SelToFlat (TFarPtr (VideoBuf));
|
|
DefaultVideoModeSelector := true;
|
|
SetHighBitBlink (true);
|
|
CheckCellHeight;
|
|
SetCursorType (LastCursorType);
|
|
ClearScreen;
|
|
end
|
|
else
|
|
begin
|
|
DefaultVideoModeSelector := false;
|
|
VioSetMode (OldMI, 0);
|
|
VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0);
|
|
VideoBuf := SelToFlat (TFarPtr (VideoBuf));
|
|
SetHighBitBlink (true);
|
|
CheckCellHeight;
|
|
SetCursorType (LastCursorType);
|
|
ClearScreen;
|
|
end
|
|
else
|
|
begin
|
|
DefaultVideoModeSelector := false;
|
|
VioGetBuf (VideoBuf, PWord (@VideoBufSize)^, 0);
|
|
VideoBuf := SelToFlat (TFarPtr (VideoBuf));
|
|
SetHighBitBlink (true);
|
|
SetCursorType (LastCursorType);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure ClearScreen;
|
|
|
|
begin
|
|
VioScrollDn (0, 0, word (-1), word (-1), word (-1), PWord (@EmptyCell)^, 0);
|
|
Move (VideoBuf^, OldVideoBuf^, VideoBufSize);
|
|
end;
|
|
|
|
|
|
{$ASMMODE INTEL}
|
|
|
|
procedure UpdateScreen (Force: boolean);
|
|
|
|
var SOfs, CLen: cardinal;
|
|
|
|
begin
|
|
if LockUpdateScreen = 0 then
|
|
begin
|
|
if not (Force) then
|
|
begin
|
|
asm
|
|
cld
|
|
mov esi, VideoBuf
|
|
mov edi, OldVideoBuf
|
|
mov eax, VideoBufSize
|
|
mov ecx, eax
|
|
shr ecx
|
|
shr ecx
|
|
repe
|
|
cmpsd
|
|
je @no_update
|
|
inc cx
|
|
mov SOfs, ecx
|
|
mov Force, 1
|
|
std
|
|
mov edi, eax
|
|
mov esi, VideoBuf
|
|
add eax, esi
|
|
sub eax, 4
|
|
mov esi, eax
|
|
mov eax, OldVideoBuf
|
|
add eax, edi
|
|
sub eax, 4
|
|
mov edi, eax
|
|
repe
|
|
cmpsd
|
|
inc ecx
|
|
shl ecx
|
|
shl ecx
|
|
mov CLen, ecx
|
|
cld
|
|
@no_update:
|
|
end;
|
|
SOfs := VideoBufSize - (SOfs shl 2);
|
|
end else
|
|
begin
|
|
SOfs := 0;
|
|
CLen := VideoBufSize;
|
|
end;
|
|
if Force then
|
|
begin
|
|
VioShowBuf (SOfs, CLen, 0);
|
|
Move (VideoBuf^ [SOfs div SizeOf (TVideoCell)],
|
|
OldVideoBuf^ [SOfs div SizeOf (TVideoCell)], CLen);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
RegisterVideoModes;
|
|
TargetEntry;
|
|
|
|
finalization
|
|
UnRegisterVideoModes;
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.1 2001-01-13 11:03:58 peter
|
|
* API 2 RTL commit
|
|
|
|
}
|
|
|