mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-27 07:53:43 +02:00
eac9bbd068
init/donevideo
* del_term() is now called in donevideo
* if initvideo is called while the video is already initialized, the
screen is cleared and the cursor is set home, instead of going
through the whole donevideo and then initvideo
(merged from fixes branch)
614 lines
13 KiB
PHP
614 lines
13 KiB
PHP
{
|
|
System independent low-level video interface for linux
|
|
|
|
$Id$
|
|
}
|
|
uses
|
|
Linux, Strings, FileCtrl, TermInfo;
|
|
|
|
var
|
|
LastCursorType : byte;
|
|
TtyFd: Longint;
|
|
Console: Boolean;
|
|
OldVideoBuf: PVideoBuf;
|
|
{$ifdef logging}
|
|
f: file;
|
|
|
|
const
|
|
logstart: string = '';
|
|
nl: char = #10;
|
|
logend: string = #10#10;
|
|
{$endif logging}
|
|
{$ASMMODE ATT}
|
|
|
|
procedure SendEscapeSeqNdx(Ndx: Word);
|
|
var
|
|
P: PChar;
|
|
begin
|
|
P:=cur_term_Strings^[Ndx];
|
|
if assigned(p) then
|
|
fdWrite(TTYFd, P^, StrLen(P));
|
|
end;
|
|
|
|
|
|
procedure SendEscapeSeq(const S: String);
|
|
begin
|
|
fdWrite(TTYFd, S[1], Length(S));
|
|
end;
|
|
|
|
|
|
Function IntStr(l:longint):string;
|
|
var
|
|
s : string;
|
|
begin
|
|
Str(l,s);
|
|
IntStr:=s;
|
|
end;
|
|
|
|
|
|
Function XY2Ansi(x,y,ox,oy:longint):String;
|
|
{
|
|
Returns a string with the escape sequences to go to X,Y on the screen
|
|
}
|
|
Begin
|
|
if y=oy then
|
|
begin
|
|
if x=ox then
|
|
begin
|
|
XY2Ansi:='';
|
|
exit;
|
|
end;
|
|
if x=1 then
|
|
begin
|
|
XY2Ansi:=#13;
|
|
exit;
|
|
end;
|
|
if x>ox then
|
|
begin
|
|
XY2Ansi:=#27'['+IntStr(x-ox)+'C';
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
XY2Ansi:=#27'['+IntStr(ox-x)+'D';
|
|
exit;
|
|
end;
|
|
end;
|
|
if x=ox then
|
|
begin
|
|
if y>oy then
|
|
begin
|
|
XY2Ansi:=#27'['+IntStr(y-oy)+'B';
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
XY2Ansi:=#27'['+IntStr(oy-y)+'A';
|
|
exit;
|
|
end;
|
|
end;
|
|
if (x=1) and (oy+1=y) then
|
|
XY2Ansi:=#13#10
|
|
else
|
|
XY2Ansi:=#27'['+IntStr(y)+';'+IntStr(x)+'H';
|
|
End;
|
|
|
|
|
|
|
|
const
|
|
AnsiTbl : string[8]='04261537';
|
|
Function Attr2Ansi(Attr,OAttr:longint):string;
|
|
{
|
|
Convert Attr to an Ansi String, the Optimal code is calculate
|
|
with use of the old OAttr
|
|
}
|
|
var
|
|
hstr : string[16];
|
|
OFg,OBg,Fg,Bg : longint;
|
|
|
|
procedure AddSep(ch:char);
|
|
begin
|
|
if length(hstr)>0 then
|
|
hstr:=hstr+';';
|
|
hstr:=hstr+ch;
|
|
end;
|
|
|
|
begin
|
|
if Attr=OAttr then
|
|
begin
|
|
Attr2Ansi:='';
|
|
exit;
|
|
end;
|
|
Hstr:='';
|
|
Fg:=Attr and $f;
|
|
Bg:=Attr shr 4;
|
|
OFg:=Attr and $f;
|
|
OBg:=Attr shr 4;
|
|
if (OFg<>7) or (Fg=7) or ((OFg>7) and (Fg<8)) or ((OBg>7) and (Bg<8)) then
|
|
begin
|
|
hstr:='0';
|
|
OFg:=7;
|
|
OBg:=0;
|
|
end;
|
|
if (Fg>7) and (OFg<8) then
|
|
begin
|
|
AddSep('1');
|
|
OFg:=OFg or 8;
|
|
end;
|
|
if (Bg and 8)<>(OBg and 8) then
|
|
begin
|
|
AddSep('5');
|
|
OBg:=OBg or 8;
|
|
end;
|
|
if (Fg<>OFg) then
|
|
begin
|
|
AddSep('3');
|
|
hstr:=hstr+AnsiTbl[(Fg and 7)+1];
|
|
end;
|
|
if (Bg<>OBg) then
|
|
begin
|
|
AddSep('4');
|
|
hstr:=hstr+AnsiTbl[(Bg and 7)+1];
|
|
end;
|
|
if hstr='0' then
|
|
hstr:='';
|
|
Attr2Ansi:=#27'['+hstr+'m';
|
|
end;
|
|
|
|
|
|
procedure UpdateTTY(Force:boolean);
|
|
type
|
|
tchattr=packed record
|
|
ch : char;
|
|
attr : byte;
|
|
end;
|
|
var
|
|
outbuf : array[0..1023+255] of char;
|
|
chattr : tchattr;
|
|
skipped : boolean;
|
|
outptr,
|
|
spaces,
|
|
eol,
|
|
LastX,LastY,
|
|
x,y,
|
|
SpaceAttr,
|
|
LastAttr : longint;
|
|
p,pold : pvideocell;
|
|
|
|
procedure outdata(hstr:string);
|
|
begin
|
|
while (eol>0) do
|
|
begin
|
|
hstr:=#13#10+hstr;
|
|
dec(eol);
|
|
end;
|
|
move(hstr[1],outbuf[outptr],length(hstr));
|
|
inc(outptr,length(hstr));
|
|
if outptr>=1024 then
|
|
begin
|
|
{$ifdef logging}
|
|
blockwrite(f,logstart[1],length(logstart));
|
|
blockwrite(f,nl,1);
|
|
blockwrite(f,outptr,sizeof(outptr));
|
|
blockwrite(f,nl,1);
|
|
blockwrite(f,outbuf,outptr);
|
|
blockwrite(f,nl,1);
|
|
{$endif logging}
|
|
fdWrite(TTYFd,outbuf,outptr);
|
|
outptr:=0;
|
|
end;
|
|
end;
|
|
|
|
procedure OutClr(c:byte);
|
|
begin
|
|
if c=LastAttr then
|
|
exit;
|
|
OutData(Attr2Ansi(c,LastAttr));
|
|
LastAttr:=c;
|
|
end;
|
|
|
|
procedure OutSpaces;
|
|
begin
|
|
if (Spaces=0) then
|
|
exit;
|
|
OutClr(SpaceAttr);
|
|
OutData(Space(Spaces));
|
|
LastX:=x;
|
|
LastY:=y;
|
|
Spaces:=0;
|
|
end;
|
|
|
|
begin
|
|
OutPtr:=0;
|
|
Eol:=0;
|
|
skipped:=true;
|
|
p:=PVideoCell(VideoBuf);
|
|
pold:=PVideoCell(OldVideoBuf);
|
|
{ init Attr and X,Y }
|
|
OutData(#27'[m'#27'[H');
|
|
LastAttr:=7;
|
|
LastX:=1;
|
|
LastY:=1;
|
|
for y:=1 to ScreenHeight do
|
|
begin
|
|
SpaceAttr:=0;
|
|
Spaces:=0;
|
|
for x:=1 to ScreenWidth do
|
|
begin
|
|
if (not force) and (p^=pold^) then
|
|
begin
|
|
if (Spaces>0) then
|
|
OutSpaces;
|
|
skipped:=true;
|
|
end
|
|
else
|
|
begin
|
|
if skipped then
|
|
begin
|
|
OutData(XY2Ansi(x,y,LastX,LastY));
|
|
LastX:=x;
|
|
LastY:=y;
|
|
skipped:=false;
|
|
end;
|
|
chattr:=tchattr(p^);
|
|
if chattr.ch in [#0,#255] then
|
|
chattr.ch:=' ';
|
|
if chattr.ch=' ' then
|
|
begin
|
|
if Spaces=0 then
|
|
SpaceAttr:=chattr.Attr;
|
|
if (chattr.attr and $f0)=(spaceattr and $f0) then
|
|
chattr.Attr:=SpaceAttr
|
|
else
|
|
begin
|
|
OutSpaces;
|
|
SpaceAttr:=chattr.Attr;
|
|
end;
|
|
inc(Spaces);
|
|
end
|
|
else
|
|
begin
|
|
if (Spaces>0) then
|
|
OutSpaces;
|
|
if LastAttr<>chattr.Attr then
|
|
OutClr(chattr.Attr);
|
|
OutData(chattr.ch);
|
|
LastX:=x+1;
|
|
LastY:=y;
|
|
end;
|
|
p^:=tvideocell(chattr);
|
|
end;
|
|
inc(p);
|
|
inc(pold);
|
|
end;
|
|
if (Spaces>0) then
|
|
OutSpaces;
|
|
if force then
|
|
inc(eol);
|
|
end;
|
|
eol:=0;
|
|
OutData(XY2Ansi(CursorX,CursorY,LastX,LastY));
|
|
{$ifdef logging}
|
|
blockwrite(f,logstart[1],length(logstart));
|
|
blockwrite(f,nl,1);
|
|
blockwrite(f,outptr,sizeof(outptr));
|
|
blockwrite(f,nl,1);
|
|
blockwrite(f,outbuf,outptr);
|
|
blockwrite(f,nl,1);
|
|
{$endif logging}
|
|
fdWrite(TTYFd,outbuf,outptr);
|
|
end;
|
|
|
|
var
|
|
preInitVideoTio, postInitVideoTio: linux.termios;
|
|
inputRaw, outputRaw: boolean;
|
|
|
|
procedure saveRawSettings(const tio: linux.termios);
|
|
Begin
|
|
with tio do
|
|
begin
|
|
inputRaw :=
|
|
((c_iflag and (IGNBRK or BRKINT or PARMRK or ISTRIP or
|
|
INLCR or IGNCR or ICRNL or IXON)) = 0) and
|
|
((c_lflag and (ECHO or ECHONL or ICANON or ISIG or IEXTEN)) = 0);
|
|
outPutRaw :=
|
|
((c_oflag and OPOST) = 0) and
|
|
((c_cflag and (CSIZE or PARENB)) = 0) and
|
|
((c_cflag and CS8) <> 0);
|
|
end;
|
|
end;
|
|
|
|
procedure restoreRawSettings(tio: linux.termios);
|
|
begin
|
|
with tio do
|
|
begin
|
|
if inputRaw then
|
|
begin
|
|
c_iflag := c_iflag and (not (IGNBRK or BRKINT or PARMRK or ISTRIP or
|
|
INLCR or IGNCR or ICRNL or IXON));
|
|
c_lflag := c_lflag and
|
|
(not (ECHO or ECHONL or ICANON or ISIG or IEXTEN));
|
|
end;
|
|
if outPutRaw then
|
|
begin
|
|
c_oflag := c_oflag and not(OPOST);
|
|
c_cflag := c_cflag and not(CSIZE or PARENB) or CS8;
|
|
end;
|
|
end;
|
|
TCSetAttr(1,TCSANOW,tio);
|
|
end;
|
|
|
|
procedure prepareInitVideo;
|
|
begin
|
|
TCGetAttr(1,preInitVideoTio);
|
|
saveRawSettings(preInitVideoTio);
|
|
end;
|
|
|
|
procedure videoInitDone;
|
|
begin
|
|
TCGetAttr(1,postInitVideoTio);
|
|
restoreRawSettings(postInitVideoTio);
|
|
end;
|
|
|
|
procedure prepareDoneVideo;
|
|
var
|
|
tio: linux.termios;
|
|
begin
|
|
TCGetAttr(1,tio);
|
|
saveRawSettings(tio);
|
|
TCSetAttr(1,TCSANOW,postInitVideoTio);
|
|
end;
|
|
|
|
procedure doneVideoDone;
|
|
begin
|
|
restoreRawSettings(preInitVideoTio);
|
|
end;
|
|
|
|
procedure InitVideo;
|
|
const
|
|
fontstr : string[3]=#27'(K';
|
|
var
|
|
ThisTTY: String[30];
|
|
FName: String;
|
|
WS: packed record
|
|
ws_row, ws_col, ws_xpixel, ws_ypixel: Word;
|
|
end;
|
|
Err: Longint;
|
|
begin
|
|
LowAscii:=false;
|
|
if VideoBufSize<>0 then
|
|
begin
|
|
clearscreen;
|
|
if Console then
|
|
SetCursorPos(1,1)
|
|
else
|
|
begin
|
|
SendEscapeSeqNdx(cursor_home);
|
|
SendEscapeSeq(#27'[H');
|
|
end;
|
|
exit;
|
|
end;
|
|
{ check for tty }
|
|
ThisTTY:=TTYName(stdin);
|
|
if IsATTY(stdin) then
|
|
begin
|
|
{ save current terminal characteristics and remove rawness }
|
|
prepareInitVideo;
|
|
{ write code to set a correct font }
|
|
fdWrite(stdout,fontstr[1],length(fontstr));
|
|
{ running on a tty, find out whether locally or remotely }
|
|
if (Copy(ThisTTY, 1, 8) = '/dev/tty') and
|
|
(ThisTTY[9] >= '0') and (ThisTTY[9] <= '9') then
|
|
begin
|
|
{ running on the console }
|
|
FName:='/dev/vcsa' + ThisTTY[9];
|
|
TTYFd:=OpenFile(FName, filReadWrite); { open console }
|
|
end
|
|
else
|
|
TTYFd:=-1;
|
|
if TTYFd<>-1 then
|
|
Console:=true
|
|
else
|
|
begin
|
|
{ running on a remote terminal, no error with /dev/vcsa }
|
|
Console:=False;
|
|
TTYFd:=stdout;
|
|
end;
|
|
ioctl(stdin, TIOCGWINSZ, @WS);
|
|
ScreenWidth:=WS.ws_Col;
|
|
ScreenHeight:=WS.ws_Row;
|
|
if WS.ws_Col=0 then
|
|
WS.ws_Col:=80;
|
|
if WS.ws_Row=0 then
|
|
WS.ws_Row:=25;
|
|
CursorX:=1;
|
|
CursorY:=1;
|
|
ScreenColor:=True;
|
|
{ allocate pmode memory buffer }
|
|
VideoBufSize:=ScreenWidth*ScreenHeight*2;
|
|
GetMem(VideoBuf,VideoBufSize);
|
|
GetMem(OldVideoBuf,VideoBufSize);
|
|
{ Start with a clear screen }
|
|
if not Console then
|
|
begin
|
|
setupterm(nil, stdout, err);
|
|
SendEscapeSeqNdx(cursor_home);
|
|
SendEscapeSeqNdx(cursor_normal);
|
|
SendEscapeSeqNdx(cursor_visible);
|
|
SendEscapeSeqNdx(enter_ca_mode);
|
|
SetCursorType(crUnderLine);
|
|
end;
|
|
ClearScreen;
|
|
{$ifdef logging}
|
|
assign(f,'video.log');
|
|
rewrite(f,1);
|
|
{$endif logging}
|
|
{ save new terminal characteristics and possible restore rawness }
|
|
videoInitDone;
|
|
end
|
|
else
|
|
ErrorCode:=errVioInit; { not a TTY }
|
|
end;
|
|
|
|
procedure DoneVideo;
|
|
begin
|
|
if VideoBufSize=0 then
|
|
exit;
|
|
prepareDoneVideo;
|
|
ClearScreen;
|
|
if Console then
|
|
SetCursorPos(1,1)
|
|
else
|
|
begin
|
|
SendEscapeSeqNdx(exit_ca_mode);
|
|
SendEscapeSeqNdx(cursor_home);
|
|
SendEscapeSeqNdx(cursor_normal);
|
|
SendEscapeSeqNdx(cursor_visible);
|
|
SetCursorType(crUnderLine);
|
|
SendEscapeSeq(#27'[H');
|
|
end;
|
|
FreeMem(VideoBuf,VideoBufSize);
|
|
FreeMem(OldVideoBuf,VideoBufSize);
|
|
VideoBufSize:=0;
|
|
doneVideoDone;
|
|
del_curterm(cur_term);
|
|
{$ifdef logging}
|
|
close(f);
|
|
{$endif logging}
|
|
end;
|
|
|
|
|
|
procedure ClearScreen;
|
|
begin
|
|
FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
|
|
if Console then
|
|
UpdateScreen(true)
|
|
else
|
|
begin
|
|
SendEscapeSeq(#27'[0m');
|
|
SendEscapeSeqNdx(clear_screen);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure UpdateScreen(Force: Boolean);
|
|
var
|
|
DoUpdate : boolean;
|
|
begin
|
|
if LockUpdateScreen<>0 then
|
|
exit;
|
|
if not force then
|
|
begin
|
|
{$ifdef i386}
|
|
asm
|
|
movl VideoBuf,%esi
|
|
movl OldVideoBuf,%edi
|
|
movl VideoBufSize,%ecx
|
|
shrl $2,%ecx
|
|
repe
|
|
cmpsl
|
|
orl %ecx,%ecx
|
|
setne DoUpdate
|
|
end;
|
|
{$endif i386}
|
|
end
|
|
else
|
|
DoUpdate:=true;
|
|
if not DoUpdate then
|
|
exit;
|
|
if Console then
|
|
begin
|
|
fdSeek(TTYFd, 4, skBeg);
|
|
fdWrite(TTYFd, VideoBuf^,VideoBufSize);
|
|
end
|
|
else
|
|
begin
|
|
UpdateTTY(force);
|
|
end;
|
|
Move(VideoBuf^, OldVideoBuf^, VideoBufSize);
|
|
end;
|
|
|
|
|
|
function GetCapabilities: Word;
|
|
begin
|
|
{ about cpColor... we should check the terminfo database... }
|
|
GetCapabilities:=cpUnderLine + cpBlink + cpColor;
|
|
end;
|
|
|
|
|
|
procedure SetCursorPos(NewCursorX, NewCursorY: Word);
|
|
var
|
|
Pos : array [1..2] of Byte;
|
|
begin
|
|
if Console then
|
|
begin
|
|
fdSeek(TTYFd, 2, skBeg);
|
|
Pos[1]:=NewCursorX;
|
|
Pos[2]:=NewCursorY;
|
|
fdWrite(TTYFd, Pos, 2);
|
|
end
|
|
else
|
|
begin
|
|
{ newcursorx,y is 0 based ! }
|
|
SendEscapeSeq(XY2Ansi(NewCursorX+1,NewCursorY+1,0,0));
|
|
end;
|
|
CursorX:=NewCursorX+1;
|
|
CursorY:=NewCursorY+1;
|
|
end;
|
|
|
|
|
|
function GetCursorType: Word;
|
|
begin
|
|
GetCursorType:=LastCursorType;
|
|
end;
|
|
|
|
|
|
procedure SetCursorType(NewType: Word);
|
|
begin
|
|
LastCursorType:=NewType;
|
|
case NewType of
|
|
crBlock :
|
|
SendEscapeSeq(#27'[?17;0;64c');
|
|
crHidden :
|
|
SendEscapeSeq(#27'[?1c');
|
|
else
|
|
SendEscapeSeq(#27'[?2c');
|
|
end;
|
|
end;
|
|
|
|
|
|
function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean;
|
|
begin
|
|
DefaultVideoModeSelector:=false;
|
|
end;
|
|
|
|
|
|
procedure RegisterVideoModes;
|
|
begin
|
|
end;
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.4 2000-09-26 08:18:29 jonas
|
|
+ added preserving of rawness of terminal when going though
|
|
init/donevideo
|
|
* del_term() is now called in donevideo
|
|
* if initvideo is called while the video is already initialized, the
|
|
screen is cleared and the cursor is set home, instead of going
|
|
through the whole donevideo and then initvideo
|
|
(merged from fixes branch)
|
|
|
|
Revision 1.3 2000/08/02 12:39:22 jonas
|
|
* fixed crashes under ncurses 4 by adding auto-detection for ncurses 4/5
|
|
* cur_term is not directly usable anymore for the largest part because
|
|
of a different record layout in ncurses 4/5, therefore the pointers
|
|
cur_term_booleans, cur_term_numbers, cur_term_strings and
|
|
cur_term_common are now available
|
|
* adapted video.inc to use the new naming convention
|
|
(merged from fixes branch)
|
|
|
|
Revision 1.2 2000/07/13 11:32:25 michael
|
|
+ removed logs
|
|
|
|
}
|