mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-09 06:08:55 +02:00
+ interactive test for bug #2002
This commit is contained in:
parent
ca424bbc32
commit
b5cc48ecac
22
tests/webtbs/tu2002.pp
Normal file
22
tests/webtbs/tu2002.pp
Normal file
@ -0,0 +1,22 @@
|
||||
unit {vidutil}tu2002;
|
||||
Interface
|
||||
uses
|
||||
video;
|
||||
Procedure TextOut(X,Y : Word;Const S :
|
||||
String);
|
||||
Implementation
|
||||
|
||||
Procedure TextOut(X,Y : Word;Const S :
|
||||
String);
|
||||
Var
|
||||
W,P,I,M : Word;
|
||||
begin
|
||||
P:=((X-1)+(Y-1)*ScreenWidth);
|
||||
M:=Length(S);
|
||||
If P+M>ScreenWidth*ScreenHeight then
|
||||
M:=ScreenWidth*ScreenHeight-P;
|
||||
For I:=1 to M do
|
||||
VideoBuf^[P+I-1]:=Ord(S[i])+($07 shl 8);
|
||||
end;
|
||||
|
||||
end.
|
22
tests/webtbs/tw2002.pp
Normal file
22
tests/webtbs/tw2002.pp
Normal file
@ -0,0 +1,22 @@
|
||||
{ %INTERACTIVE }
|
||||
|
||||
program testvideo;
|
||||
uses video,keyboard,{vidutil}tu2002;
|
||||
Var
|
||||
i : longint;
|
||||
k : TkeyEvent;
|
||||
|
||||
begin
|
||||
InitVideo;
|
||||
InitKeyboard;
|
||||
For I:=1 to 10 do
|
||||
TextOut(i,i, 'Press any key to clear screen');
|
||||
UpdateScreen(false);
|
||||
K:=GetKeyEvent;
|
||||
ClearScreen;
|
||||
TextOut(1,1,'Cleared screen. Press any key to end');
|
||||
UpdateScreen(true);
|
||||
K:=GetKeyEvent;
|
||||
DoneKeyBoard;
|
||||
DoneVideo;
|
||||
end.
|
Loading…
Reference in New Issue
Block a user