paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-18 05:39:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Unix video unit character set conversion overhaul

Browse Source 
git-svn-id: trunk@3243 -
This commit is contained in:
daniel 2006-04-17 12:39:02 +00:00
parent e8e0d2b6eb
commit f009b5700a
4 changed files with 275 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
rtl/inc/video.inc
View File

@ -76,6 +76,7 @@ begin
end;
end;
(*
Procedure AssignVideoBuf (OldCols, OldRows : Word);
Var NewVideoBuf,NewOldVideoBuf : PVideoBuf;
@ -109,6 +110,37 @@ begin
VideoBuf:=NewVideoBuf;
OldVideoBuf:=NewOldVideoBuf;
end;
*)
Procedure AssignVideoBuf (OldCols, OldRows : Word);
var NewVideoBuf,NewOldVideoBuf:PVideoBuf;
C,R,old_rowstart,new_rowstart:word;
begin
VideoBufSize:=ScreenWidth*ScreenHeight*sizeof(TVideoCell);
GetMem(NewVideoBuf,VideoBufSize);
GetMem(NewOldVideoBuf,VideoBufSize);
{Move contents of old videobuffers to new if there are any.}
if VideoBuf<>nil then
begin
if ScreenWidth<OldCols then
OldCols:=ScreenWidth;
if ScreenHeight<OldRows then
OldRows:=ScreenHeight;
old_rowstart:=0;
new_rowstart:=0;
repeat
move(VideoBuf^[old_rowstart],NewVideoBuf^[new_rowstart],C*sizeof(TVideoCell));
move(OldVideoBuf^[old_rowstart],NewOldVideoBuf^[new_rowstart],C*sizeof(TVideoCell));
inc(old_rowstart,OldCols);
inc(new_rowstart,ScreenWidth);
dec(OldRows);
until OldRows=0;
end;
FreeVideoBuf;
VideoBuf:=NewVideoBuf;
OldVideoBuf:=NewOldVideoBuf;
end;
Procedure InitVideo;

17
rtl/inc/videoh.inc
View File

@ -98,10 +98,19 @@ var
VideoBufSize : Longint;
CursorLines : Byte;
const
LowAscii : Boolean = true;
NoExtendedFrame : Boolean = false;
FVMaxWidth = 132;
const {The following constants were variables in the past.
- Lowascii was set to true if ASCII characters < 32 were available
- NoExtendedFrame was set to true if the double with line drawing
characters were set to true.
These variables did exist because of VT100 limitations on Unix. However,
only part of the character set problem was solved this way. Nowadays, the
video unit converts characters to the output character set (which might be
VT100) automatically, so the user does not need to worry about it anymore.}
LowAscii = true;
NoExtendedFrame = false;
FVMaxWidth = 132;
Procedure LockScreenUpdate;
{ Increments the screen update lock count with one.}

1
rtl/os2/video.pp
View File

@ -94,7 +94,6 @@ begin
ScreenColor := Color >= Colors_16;
end;
VioGetCurPos (CursorY, CursorX, 0);
LowAscii := true;
SetCursorType (LastCursorType);
{ Get the address of the videobuffer.}
if VioGetBuf (SysVideoBuf, PWord (@VideoBufSize)^, 0) = 0 then

356
rtl/unix/video.pp
View File

@ -13,7 +13,7 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit Video;
unit video;
{$I-}
{$GOTO on}
@ -24,6 +24,35 @@ unit Video;
{$i videoh.inc}
type Tencoding=(cp437, {Codepage 437}
cp850, {Codepage 850}
cp852, {Codepage 852}
cp866, {Codepage 866}
koi8r, {KOI8-R codepage}
iso01, {ISO 8859-1}
iso02, {ISO 8859-2}
iso03, {ISO 8859-3}
iso04, {ISO 8859-4}
iso05, {ISO 8859-5}
iso06, {ISO 8859-6}
iso07, {ISO 8859-7}
iso08, {ISO 8859-8}
iso09, {ISO 8859-9}
iso10, {ISO 8859-10}
iso13, {ISO 8859-13}
iso14, {ISO 8859-14}
iso15); {ISO 8859-15}
const {Contains all code pages that can be considered a normal vga font.
Note: KOI8-R has line drawing characters in wrong place. Support
can perhaps be added, for now we'll let it rest.}
vga_codepages=[cp437,cp850,cp852,cp866];
iso_codepages=[iso01,iso02,iso03,iso04,iso05,iso06,iso07,iso08,
iso09,iso10,iso13,iso14,iso15];
var internal_codepage,external_codepage:Tencoding;
{*****************************************************************************}
implementation
{*****************************************************************************}
@ -32,7 +61,7 @@ uses baseunix,termio,strings
{$ifdef linux},linuxvcs{$endif};
{$i video.inc}
{$i convert.inc}
type Tconsole_type=(ttyNetwork
{$ifdef linux},ttyLinux{$endif}
@ -40,7 +69,9 @@ type Tconsole_type=(ttyNetwork
,ttyNetBSD);
Tconversion=(cv_none,
cv_vga_to_acs);
cv_cp437_to_iso01,
cv_cp850_to_iso01,
cv_linuxlowascii_to_vga);
Ttermcode=(
enter_alt_charset_mode,
@ -48,7 +79,8 @@ type Tconsole_type=(ttyNetwork
clear_screen,
cursor_home,
cursor_normal,
cursor_visible,
cursor_visible_underline,
cursor_visible_block,
cursor_invisible,
enter_ca_mode,
exit_ca_mode,
@ -64,7 +96,8 @@ const term_codes_ansi:Ttermcodes=
#$1B#$5B#$48#$1B#$5B#$4A, {clear_screen}
#$1B#$5B#$48, {cursor_home}
nil, {cursor_normal}
nil, {cursor_visible}
nil, {cursor visible, underline}
nil, {cursor visible, block}
nil, {cursor_invisible}
nil, {enter_ca_mode}
nil, {exit_ca_mode}
@ -77,7 +110,8 @@ const term_codes_ansi:Ttermcodes=
#$1B#$5B#$48#$1B#$5B#$4A, {clear_screen}
#$1B#$5B#$48, {cursor_home}
#$1B#$5B#$3D#$30#$43, {cursor_normal}
#$1B#$5B#$3D#$31#$43, {cursor_visible}
#$1B#$5B#$3D#$31#$43, {cursor visible, underline}
#$1B#$5B#$3D#$31#$43, {cursor visible, block}
nil, {cursor_invisible}
nil, {enter_ca_mode}
nil, {exit_ca_mode}
@ -89,9 +123,10 @@ const term_codes_ansi:Ttermcodes=
#$1B#$5B#$31#$30#$6D, {exit_alt_charset_mode}
#$1B#$5B#$48#$1B#$5B#$4A, {clear_screen}
#$1B#$5B#$48, {cursor_home}
#$1B#$5B#$3F#$32#$35#$68#$1B#$5B#$3F#$30#$63, {cursor_normal}
#$1B#$5B#$3F#$32#$35#$68#$1B#$5B#$3F#$30#$63, {cursor_visible}
#$1B#$5B#$3F#$32#$35#$6C, {cursor_invisible}
#$1B'[?25h'#$1B'[?0c', {cursor_normal}
#$1B'[?0c', {cursor visible, underline}
#$1B'[?17;0;127c', {cursor visible, block}
#$1B'[?1c', {cursor_invisible}
nil, {enter_ca_mode}
nil, {exit_ca_mode}
nil, {exit_am_mode}
@ -103,7 +138,8 @@ const term_codes_ansi:Ttermcodes=
#$1B#$5B#$48#$1B#$5B#$4A{#$24#$3C#$35#$30#$3E}, {clear_screen}
#$1B#$5B#$48, {cursor_home}
nil, {cursor_normal}
nil, {cursor_visible}
nil, {cursor visible, underline}
nil, {cursor visible, block}
nil, {cursor_invisible}
nil, {enter_ca_mode}
nil, {exit_ca_mode}
@ -116,7 +152,8 @@ const term_codes_ansi:Ttermcodes=
#$1B#$5B#$48#$1B#$5B#$4A, {clear_screen}
#$1B#$5B#$48, {cursor_home}
nil, {cursor_normal}
nil, {cursor_visible}
nil, {cursor visible, underline}
nil, {cursor visible, block}
nil, {cursor_invisible}
nil, {enter_ca_mode}
nil, {exit_ca_mode}
@ -129,7 +166,8 @@ const term_codes_ansi:Ttermcodes=
#$1B#$5B#$48#$1B#$5B#$32#$4A, {clear_screen}
#$1B#$5B#$48, {cursor_home}
#$1B#$5B#$3F#$31#$32#$6C#$1B#$5B#$3F#$32#$35#$68, {cursor_normal}
#$1B#$5B#$3F#$31#$32#$3B#$32#$35#$68, {cursor_visible}
#$1B#$5B#$3F#$31#$32#$3B#$32#$35#$68, {cursor visible, underline}
#$1B#$5B#$3F#$31#$32#$3B#$32#$35#$68, {cursor visible, block}
#$1B#$5B#$3F#$32#$35#$6C, {cursor_invisible}
#$1B#$5B#$3F#$31#$30#$34#$39#$68, {enter_ca_mode}
#$1B#$5B#$3F#$31#$30#$34#$39#$6C, {exit_ca_mode}
@ -242,24 +280,17 @@ begin
end;
function SendEscapeSeqNdx(Ndx:Ttermcode) : boolean;
var
P{,pdelay}:PChar;
procedure SendEscapeSeqNdx(ndx:Ttermcode);
var p:PChar;
begin
SendEscapeSeqNdx:=false;
{ Always true because of vt100 default.
if not assigned(cur_term_Strings) then
exit{RunError(219)};
P:=cur_term_Strings^[Ndx];
if assigned(p) then
begin { Do not transmit the delays }
{ pdelay:=strpos(p,'$<');
if assigned(pdelay) then
pdelay^:=#0;}
fpWrite(stdoutputhandle, P^, StrLen(P));
SendEscapeSeqNdx:=true;
{ if assigned(pdelay) then
pdelay^:='$';}
end;
exit}{RunError(219)};
p:=cur_term_strings^[ndx];
if p<>nil then
fpwrite(stdoutputhandle,p^,strlen(p));
end;
@ -325,8 +356,6 @@ begin
xy2ansi:=#27'['+movement+direction;
end;
const ansitbl:array[0..7] of char='04261537';
Function Attr2Ansi(Attr,OAttr:longint):string;
@ -412,24 +441,30 @@ var
p,pold : pvideocell;
LastLineWidth : Longint;
procedure transform_using_acs(var st:string);
function transform_cp437_to_iso01(const st:string):string;
var res:string;
i:byte;
var i:byte;
c:char;
converted:word;
begin
res:='';
transform_cp437_to_iso01:='';
for i:=1 to length(st) do
begin
c:=st[i];
converted:=convert_vga_to_acs(c);
case c of
#0..#31:
converted:=convert_lowascii_to_iso01[c];
#128..#255:
converted:=convert_cp437_to_iso01[c];
else
converted:=byte(c);
end;
if converted and $ff00=$f800 then
begin
if not in_ACS then
begin
res:=res+ACSIn;
transform_cp437_to_iso01:=transform_cp437_to_iso01+ACSIn;
in_ACS:=true;
end;
c:=char(converted and $ff);
@ -437,17 +472,92 @@ var
else
if in_ACS then
begin
res:=res+ACSOut+Attr2Ansi(LastAttr,0);
transform_cp437_to_iso01:=transform_cp437_to_iso01+ACSOut+
Attr2Ansi(LastAttr,0);
in_ACS:=false;
end;
res:=res+c;
transform_cp437_to_iso01:=transform_cp437_to_iso01+c;
end;
st:=res;
end;
function transform_cp850_to_iso01(const st:string):string;
var i:byte;
c:char;
converted:word;
begin
transform_cp850_to_iso01:='';
for i:=1 to length(st) do
begin
c:=st[i];
case c of
#0..#31:
converted:=convert_lowascii_to_iso01[c];
#128..#255:
converted:=convert_cp850_to_iso01[c];
else
converted:=byte(c);
end;
if converted and $ff00=$f800 then
begin
if not in_ACS then
begin
transform_cp850_to_iso01:=transform_cp850_to_iso01+ACSIn;
in_ACS:=true;
end;
end
else
if in_ACS then
begin
transform_cp850_to_iso01:=transform_cp850_to_iso01+ACSOut+
Attr2Ansi(LastAttr,0);
in_ACS:=false;
end;
c:=char(converted and $ff);
transform_cp850_to_iso01:=transform_cp850_to_iso01+c;
end;
end;
function transform_linuxlowascii_to_vga(const st:string):string;
var i:byte;
c:char;
converted:word;
begin
transform_linuxlowascii_to_vga:='';
for i:=1 to length(st) do
begin
c:=st[i];
case c of
#0..#31:
converted:=convert_linuxlowascii_to_vga[c];
else
converted:=byte(c);
end;
c:=char(converted and $ff);
transform_linuxlowascii_to_vga:=transform_linuxlowascii_to_vga+c;
end;
end;
function transform(const hstr:string):string;
begin
case convert of
cv_linuxlowascii_to_vga:
transform:=transform_linuxlowascii_to_vga(hstr);
cv_cp437_to_iso01:
transform:=transform_cp437_to_iso01(hstr);
cv_cp850_to_iso01:
transform:=transform_cp850_to_iso01(hstr);
else
transform:=hstr;
end;
end;
procedure outdata(hstr:string);
begin
If Length(HStr)>0 Then
Begin
@ -456,8 +566,8 @@ var
hstr:=#13#10+hstr;
dec(eol);
end;
if (convert=cv_vga_to_acs) and (ACSIn<>'') and (ACSOut<>'') then
transform_using_acs(Hstr);
{ if (convert=cv_vga_to_acs) and (ACSIn<>'') and (ACSOut<>'') then
transform_using_acs(Hstr);}
move(hstr[1],outbuf[outptr],length(hstr));
inc(outptr,length(hstr));
if outptr>=1024 then
@ -553,8 +663,8 @@ begin
skipped:=false;
end;
chattr:=tchattr(p^);
if chattr.ch in [#0,#255] then
chattr.ch:=' ';
{ if chattr.ch in [#0,#255] then
chattr.ch:=' ';}
if chattr.ch=' ' then
begin
if Spaces=0 then
@ -572,14 +682,14 @@ begin
begin
if (Spaces>0) then
OutSpaces;
if ord(chattr.ch)<32 then
{ if ord(chattr.ch)<32 then
begin
Chattr.Attr:= $ff xor Chattr.Attr;
ChAttr.ch:= chr(ord(chattr.ch)+ord('A')-1);
end;
ChAttr.ch:=chr(ord(chattr.ch)+ord('A')-1);
end;}
if LastAttr<>chattr.Attr then
OutClr(chattr.Attr);
OutData(chattr.ch);
OutData(transform(chattr.ch));
LastX:=x+1;
LastY:=y;
end;
@ -597,15 +707,15 @@ begin
end;
eol:=0;
{if am in capabilities? Then}
If (Console=ttyFreeBSD) and (Plongint(p)^<>plongint(pold)^) Then
Begin
if (Console=ttyFreeBSD) and (Plongint(p)^<>plongint(pold)^) Then
begin
OutData(XY2Ansi(ScreenWidth,ScreenHeight,LastX,LastY));
OutData(#8);
{Output last char}
chattr:=tchattr(p[1]);
if LastAttr<>chattr.Attr then
OutClr(chattr.Attr);
OutData(chattr.ch);
OutData(transform(chattr.ch));
inc(LastX);
// OutData(XY2Ansi(ScreenWidth-1,ScreenHeight,LastX,LastY));
// OutData(GetTermString(Insert_character));
@ -614,7 +724,7 @@ begin
chattr:=tchattr(p^);
if LastAttr<>chattr.Attr then
OutClr(chattr.Attr);
OutData(chattr.ch);
OutData(transform(chattr.ch));
inc(LastX);
end;
OutData(XY2Ansi(CursorX+1,CursorY+1,LastX,LastY));
@ -689,7 +799,8 @@ var
inputRaw, outputRaw: boolean;
procedure saveRawSettings(const tio: termio.termios);
Begin
begin
with tio do
begin
inputRaw :=
@ -725,6 +836,45 @@ begin
TCSetAttr(1,TCSANOW,tio);
end;
procedure decide_codepages;
var s:string;
begin
{$ifdef linux}
if console=ttyLinux then
begin
s:=upcase(fpgetenv('CONSOLEFONT_CP'));
if s='CP437' then
external_codepage:=cp437
else if s='CP850' then
external_codepage:=cp850;
end;
{$endif}
{A non-vcsa Linux console can display most control characters, but not all.}
if {$ifdef linux}(console<>ttyLinux) and{$endif}
(cur_term_strings=@term_codes_linux) then
convert:=cv_linuxlowascii_to_vga;
case external_codepage of
iso01: {West Europe}
begin
internal_codepage:=cp850;
convert:=cv_cp850_to_iso01;
end;
iso02: {East Europe}
internal_codepage:=cp852;
iso05: {Cyrillic}
internal_codepage:=cp866;
else
if internal_codepage in vga_codepages then
internal_codepage:=external_codepage
else
{We don't know how to convert to the external codepage. Use codepage
437 in the hope that the actual font has similarity to codepage 437.}
internal_codepage:=cp437;
end;
end;
procedure prepareInitVideo;
begin
@ -769,7 +919,7 @@ var
ThisTTY: String[30];
{$endif}
const font_vga:array[0..6] of char=#15#27'%@'#27'(U';
const font_vga:array[0..11] of char=#15#27'%@'#27'(U'#27'[3h';
font_custom:array[0..2] of char=#27'(K';
begin
@ -782,6 +932,7 @@ begin
TTyfd:=-1;
Console:=TTyNetwork; {Default: Network or other vtxxx tty}
cur_term_strings:=@term_codes_vt100; {Default: vt100}
external_codepage:=iso01; {Default: ISO-8859-1}
{$ifdef linux}
if vcs_device>=0 then
begin
@ -796,7 +947,10 @@ begin
begin
ttyfd:=fpopen(fname,$1b6,O_RDWR);
if ttyfd<>-1 then
console:=ttylinux;
begin
console:=ttylinux;
external_codepage:=cp437; {VCSA defaults to codepage 437.}
end;
end;
end;
{$endif}
@ -824,11 +978,12 @@ begin
{Executed in case ttylinux is false (i.e. no vcsa), but
TERM=linux.}
{Enable the VGA character set (codepage 437,850,....)}
fpwrite(stdoutputhandle,font_vga,7);
fpwrite(stdoutputhandle,font_vga,sizeof(font_vga));
external_codepage:=cp437; {Now default to codepage 437.}
end
else
{No VGA font :( }
fpwrite(stdoutputhandle,font_custom,3);
fpwrite(stdoutputhandle,font_custom,sizeof(font_vga));
{ running on a remote terminal, no error with /dev/vcsa }
{$ifdef linux}
end;
@ -855,7 +1010,7 @@ begin
{$endif}
SendEscapeSeqNdx(cursor_home);
SendEscapeSeqNdx(cursor_normal);
SendEscapeSeqNdx(cursor_visible);
SendEscapeSeqNdx(cursor_visible_underline);
SendEscapeSeqNdx(enter_ca_mode);
SetCursorType(crUnderLine);
If Console=ttyFreeBSD Then
@ -863,24 +1018,21 @@ begin
{$ifdef linux}
end;
{$endif}
if assigned(cur_term_Strings) then
begin
{ Always true because of vt100 default...
if assigned(cur_term_Strings) then
begin}
ACSIn:=StrPas(cur_term_strings^[enter_alt_charset_mode]);
ACSOut:=StrPas(cur_term_strings^[exit_alt_charset_mode]);
if (ACSIn<>'') and (ACSOut<>'') then
SendEscapeSeqNdx(ena_acs);
{ if pos('$<',ACSIn)>0 then
ACSIn:=Copy(ACSIn,1,Pos('$<',ACSIn)-1);
if pos('$<',ACSOut)>0 then
ACSOut:=Copy(ACSOut,1,Pos('$<',ACSOut)-1);}
If fpGetEnv('TERM')='xterm' then
convert:=cv_vga_to_acs; {use of acs for xterm is ok}
end
(* If fpGetEnv('TERM')='xterm' then
convert:=cv_vga_to_acs; {use of acs for xterm is ok}*)
{ end
else
begin
ACSIn:='';
ACSOut:='';
end;
end;}
{$ifdef logging}
assign(f,'video.log');
rewrite(f,1);
@ -890,6 +1042,8 @@ begin
end
else
ErrorCode:=errVioInit; { not a TTY }
decide_codepages;
end;
procedure SysDoneVideo;
@ -908,7 +1062,7 @@ begin
SendEscapeSeqNdx(exit_ca_mode);
SendEscapeSeqNdx(cursor_home);
SendEscapeSeqNdx(cursor_normal);
SendEscapeSeqNdx(cursor_visible);
SendEscapeSeqNdx(cursor_visible_underline);
SendEscapeSeq(#27'[H');
if cur_term_strings=@term_codes_linux then
begin
@ -951,51 +1105,13 @@ var
i : longint;
p1,p2 : plongint;
begin
(*
if not force then
begin
{$ifdef cpui386}
asm
pushl %esi
pushl %edi
movl VideoBuf,%esi
movl OldVideoBuf,%edi
movl VideoBufSize,%ecx
shrl $2,%ecx
repe
cmpsl
setne DoUpdate
popl %edi
popl %esi
end;
{$else not cpui386}
p1:=plongint(VideoBuf);
p2:=plongint(OldVideoBuf);
for i:=0 to VideoBufSize div 2 do
if (p1^<>p2^) then
begin
DoUpdate:=true;
break;
end
else
begin
{ Inc does add sizeof(longint) to both pointer values }
inc(p1);
inc(p2);
end;
{$endif not cpui386}
end
else
DoUpdate:=true;
if not DoUpdate then
exit;*)
{$ifdef linux}
if Console=ttylinux then
if console=ttylinux then
update_vcsa(force)
else
{$endif}
UpdateTTY(force);
Move(VideoBuf^, OldVideoBuf^, VideoBufSize);
updateTTY(force);
move(VideoBuf^,OldVideoBuf^,VideoBufSize);
end;
@ -1040,24 +1156,12 @@ begin
exit;
LastCursorType:=NewType;
case NewType of
crBlock :
Begin
If not SendEscapeSeqNdx(cursor_visible) then
If Console<>ttyFreeBSD Then // should be done only for linux?
SendEscapeSeq(#27'[?17;0;64c');
End;
crHidden :
Begin
If not SendEscapeSeqNdx(cursor_invisible) then
If Console<>ttyFreeBSD Then
SendEscapeSeq(#27'[?1c');
End;
crBlock:
SendEscapeSeqNdx(cursor_visible_block);
crHidden:
SendEscapeSeqNdx(cursor_invisible);
else
begin
If not SendEscapeSeqNdx(cursor_normal) then
If Console<>ttyFreeBSD Then
SendEscapeSeq(#27'[?2c');
end;
SendEscapeSeqNdx(cursor_normal);
end;
end;