home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 31
/
CDASC_31_1996_juillet_aout.iso
/
internet
/
rnr214.zip
/
RNRIO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-01-30
|
15KB
|
808 lines
unit rnrio;
{
rnrio.pas - nonconsole input/output routines
assumes a fossil (if the nonconsole routines will ever be used)
requires:
uses dos,crt,rnrglob,rnrmous ( , and possibly rnrtime ) ;
shortcomings:
minimal ansi/vt100 hard-coded in
}
{$I rnr-def.pas}
interface
uses dos,crt,genericf,rnrglob,rnrconf,rnrmous
{$ifdef timeout}
,rnrtime
{$endif}
{$ifdef mouse}
,mouse
{$endif}
;
const
yespreserve=true;
nopreserve=false;
endkeysnospace= #13#27#10; { CR, ESC, LF }
endkeyswithspace=#13#27#10' '#9; { CR, ESC, LF, SPACE, TAB }
procedure xwrites(s: string);
procedure xwritesw(s: string; w: integer);
procedure xwritei(i: integer);
procedure xwriteiw(i,w: integer);
procedure xwritess(s1,s2: string);
procedure xwritesss(s1,s2,s3: string);
procedure xwritessss(s1,s2,s3,s4: string);
procedure xwritesis(s1: string; i2: integer; s3: string);
procedure xwritessis(s1,s2: string; i3: integer; s4: string);
procedure xwriteln;
procedure xwritelns(s: string);
procedure xwritelnss(s1,s2: string);
procedure xwritelnsss(s1,s2,s3: string);
procedure xwritelnssss(s1,s2,s3,s4: string);
procedure xwritelnsi(s1: string; i2: integer);
{
procedure xwritelnsssisis(s1,s2,s3: string; i4: integer; s5: string;
i6: integer; s7: string);
}
procedure xgotoxy(x,y: integer);
procedure writexy(x,y: integer; s: string);
procedure xclreol;
procedure xclreolxy(x,y: integer);
procedure xclrscr;
function xkeypressed: boolean;
function xreadkeyextended(forcecolumn: integer; forcerow: integer;
beginrow, endrow: integer): char;
function xreadkey: char;
procedure xreadlnseh(var s: string; maxlen: integer; keepcurrent: boolean;
endlist: string; readlnhistoryp: readlnhistorypt);
procedure xreadlnse(var s: string; maxlen: integer; keepcurrent: boolean;
endlist: string);
procedure xreadlns(var s: string; maxlen: integer; keepcurrent: boolean);
procedure xsetcolor(color: byte);
procedure xhighvideo;
procedure xlowvideo;
{
procedure xquotevideo;
procedure xalternatevideo;
procedure xdatevideo;
}
procedure xwritehighlights(s: string);
procedure hwritexy(x,y: integer; s: string);
implementation
procedure noncwritec(c: char);
var
regs: registers;
begin
regs.dx := port;
regs.ah := 1;
regs.al := ord(c);
intr($14,regs);
end;
function noncreadc: char;
var
regs: registers;
begin
regs.dx := port;
regs.ah := 2;
intr($14,regs);
noncreadc := chr(regs.al);
end;
function noncinready: boolean;
var
regs: registers;
begin
regs.dx := port;
regs.ah := 3;
intr($14,regs);
noncinready := odd(regs.ah);
end;
procedure xwrites;
var
i: integer;
begin
if console then
begin
mousehide;
write(s);
mouseshow;
end
else
begin
for i := 1 to length(s) do
noncwritec(s[i]);
if shadow>0 then
begin
write(s);
delay(shadow);
end;
end;
end;
procedure xwritesw;
var
paddeds: string;
i: integer;
begin
paddeds := s;
for i := 1 to w-length(s) do
paddeds := ' '+paddeds;
xwrites(paddeds);
end;
procedure xwritei;
var
s: string;
begin
{
if console then
begin
mousehide;
write(i);
mouseshow;
end
else
begin
}
str(i,s);
xwrites(s);
{
end;
}
end;
procedure xwriteiw;
var
s: string;
begin
{
if console then
begin
mousehide;
write(i:w);
mouseshow;
end
else
begin
str(i:w,s);
xwrites(s);
end;
}
str(i,s);
xwritesw(s,w);
end;
procedure xwritess;
begin
xwrites(s1);
xwrites(s2);
end;
procedure xwritesss;
begin
xwrites(s1);
xwrites(s2);
xwrites(s3);
end;
procedure xwritessss;
begin
xwrites(s1);
xwrites(s2);
xwrites(s3);
xwrites(s4);
end;
procedure xwritesis;
begin
xwrites(s1);
xwritei(i2);
xwrites(s3);
end;
procedure xwritessis;
begin
xwritess(s1,s2);
xwritei(i3);
xwrites(s4);
end;
procedure xwriteln;
begin
if console then
begin
mousehide;
writeln;
mouseshow;
end
else
xwritess(chr(13),chr(10));
end;
procedure xwritelns;
begin
xwrites(s);
xwriteln;
end;
procedure xwritelnss;
begin
xwrites(s1);
xwrites(s2);
xwriteln;
end;
procedure xwritelnsss;
begin
xwrites(s1);
xwrites(s2);
xwrites(s3);
xwriteln;
end;
procedure xwritelnssss;
begin
xwrites(s1);
xwrites(s2);
xwrites(s3);
xwrites(s4);
xwriteln;
end;
procedure xwritelnsi;
begin
xwrites(s1);
xwritei(i2);
xwriteln;
end;
{
procedure xwritelnsssisis;
begin
xwritesss(s1,s2,s3);
xwritei(i4);
xwrites(s5);
xwritei(i6);
xwritelns(s7);
end;
}
procedure xgotoxy;
begin
if console then
begin
mousehide;
gotoxy(x,y);
mouseshow;
end
else
begin
xwritess(esc,'[');
xwritei(y);
xwrites(';');
xwritei(x);
xwrites('f');
end;
end;
procedure writexy;
begin
xgotoxy(x,y);
xwrites(s);
end;
procedure xclreol;
begin
if console then
begin
mousehide;
clreol;
mouseshow;
end
else
xwritess(esc,'[0K');
end;
procedure xclreolxy;
begin
xgotoxy(x,y);
xclreol;
end;
procedure xclrscr;
begin
if console then
begin
mousehide;
clrscr;
mouseshow;
end
else
begin
xwritess(esc,'[2J');
xgotoxy(1,1);
end;
end;
function xkeypressed;
var
result: boolean;
{$ifdef timeout}
minnow: integer;
{$endif}
begin
result := false;
if console then
begin
{$ifdef mouse}
if hasmouse then
result := keypressed or (mousevent.event<>0)
else
result := keypressed;
{$else}
result := keypressed;
{$endif}
end
else
begin
{check for timeout _before_ checking if a key is ready - modems can spew}
{now also checks for trusted users! but not on the console}
{$ifdef timeout}
minnow := mitoday;
if minnow<minstart then
inc(minnow,24*60);
if (minutestorun>=0) and (minnow-minstart>=minutestorun) then
begin
{$ifdef timeoutreturnscr}
didtimeout := true;
result := true;
{$else}
xwriteln;
xwritelns('time up');
xwriteln;
halt(2);
{$endif}
end;
if minnow<minlastinput then
inc(minnow,24*60);
if minnow-minlastinput>idleminutes then
begin
xwriteln;
xwritelns('idle timeout');
xwriteln;
halt(2);
end;
{$endif}
{$ifdef mouse}
if hasmouse then
result := noncinready or keypressed or (mousevent.event<>0)
else
result := noncinready or keypressed;
{$else}
result := noncinready or keypressed;
{$endif}
end;
{$ifdef timeout}
if result then
minlastinput := mitoday;
{$endif}
xkeypressed := result;
end;
function xreadkeyextended;
var
result: char;
{$ifdef mouse}
regs: registers;
wasx, wasy: byte;
newx, newy: byte;
{$endif}
begin
if console then
begin
{ ignore function keys, alt keys, numeric pad keys - translate to ' ' }
repeat
{$ifdef mouse}
repeat
{ nothing - we're on the console }
until xkeypressed;
if keypressed then
begin
result := readkey;
end
else
begin
wasx := wherex;
wasy := wherey;
newx := 1+(mousevent.horiz div 8);
newy := 1+(mousevent.vert div 8);
if (newy>=beginrow) and (newy<=endrow) then
newx := 1;
if forcecolumn<>0 then
newx := forcecolumn;
if forcerow<>0 then
newy := forcerow;
gotoxy(newx,newy);
{read character from screen}
regs.ah := 8;
regs.bh := 0;
intr($10,regs);
result := chr(regs.al);
gotoxy(wasx,wasy);
mousevent.event := 0;
end;
{$else}
result := readkey;
{$endif}
if (result=#0) and keypressed then
begin
result := readkey;
{ change these extended keys: }
{ 2nd Char key pressed code returned }
{ -------- ----------- ------------- }
{ I 73 PgUp < }
{ Q 81 PgDn space (or >) }
{ G 71 Home ^A (or ^) }
{ O 79 End ^E (or $) }
{ ; 59 F1 ? }
{ K 75 left arrow ^B (or backspace) }
{ M 77 right arrow ^F }
{ H 72 up arrow ^P }
{ P 80 down arrow ^N }
{ S 83 del ^D }
{ $ 36 alt-J ! }
if result='I' then
result := '<'
else if result='Q' then
{$ifdef pgdnbecomesgt}
result := '>'
{$else}
result := ' '
{$endif}
else if result='G' then
{$ifdef homebecomescarat}
result := '^'
{$else}
result := ^A
{$endif}
else if result='O' then
{$ifdef endbecomesdollar}
result := '$'
{$else}
result := ^E
{$endif}
else if result=';' then
result := '?'
else if result='K' then
{$ifdef leftbecomesbackspace}
result := #8
{$else}
result := ^B
{$endif}
else if result='M' then
result := ^F
else if result='H' then
result := ^P
else if result='P' then
result := ^N
else if result='S' then
result := ^D
else if result='$' then
result := '!'
else
{ ignore other extended keys }
result := #0;
end;
until result<>#0;
end
else
begin
while not xkeypressed do
;
if keypressed then
result := readkey
else
result := noncreadc;
end;
xreadkeyextended := mainmap[result];
end;
function xreadkey;
begin
xreadkey := xreadkeyextended(0,0,0,0);
end;
procedure xreadlnseh; {readln, can end with some non-RETURN keys, history}
{acceptable lists are RETURN plus some of LF, SPACE, TAB, ESC}
{readlnhistoryp can be nil to indicate no history}
var
result: string;
done: boolean;
len: integer; {the length of the string}
position: integer; {the position in the string, or len+1}
onekey: char; {one key from the keyboard}
tempint: integer;
begin
if keepcurrent then
result := s
else
result := '';
len := length(result);
xwrites(result);
position := len+1; {+1 since we're appending at the end}
done := false;
while not done do
begin
onekey := xreadkey;
if (onekey=#127) or (onekey=#8) then {backspace}
begin
if position>1 then
begin
dec(position);
dec(len);
if len=0 then
result := ''
else
result :=
copy(result,1,position-1)+copy(result,position+1,255);
xwrites(^H);
xclreol;
xwrites(copy(result,position,255));
for tempint := 0 to (len-position) do
xwrites(^H);
end;
end
else if onekey=^D then {delete}
begin
if position<=len then
begin
dec(len);
if len=0 then
result := ''
else
result :=
copy(result,1,position-1)+copy(result,position+1,255);
xclreol;
xwrites(copy(result,position,255));
for tempint := 0 to (len-position) do
xwrites(^H);
end;
end
else if onekey=^B then {back a character}
begin
if position>1 then
begin
xwrites(#8);
dec(position);
end;
end
else if onekey=^F then {forward a character}
begin
if position<len+1 then
begin
if position<=len then
xwrites(copy(result,position,1));
inc(position);
end;
end
else if onekey=^A then {beginning}
begin
for tempint := position-1 downto 1 do
begin
xwrites(#8);
dec(position);
end;
end
else if onekey=^E then {end}
begin
for tempint := position+1 to len+1 do
begin
xwrites(copy(result,position,1));
inc(position);
end;
end
else if pos(onekey,endlist)<>0 then {finished}
begin
{$ifdef xwritelnafterxreadln}
xwriteln;
{$endif}
done := true;
end
else if onekey=^U then {erase it all}
begin
for tempint := 1 to position-1 do
xwrites(^H);
xclreol;
result := '';
len := 0;
position := 1;
end
else if (ord(onekey)>=32) and (eightbitclean or (ord(onekey)<128))
and (len<maxlen) then {insert a character}
begin
inc(len);
result := copy(result,1,position-1)+onekey+copy(result,position,255);
xwrites(copy(result,position,255));
inc(position);
for tempint := 0 to (len-position) do
xwrites(^H);
end;
end;
s := result;
end;
procedure xreadlnse;
{acceptable lists are RETURN plus some of LF, SPACE, TAB, ESC}
begin
xreadlnseh(s,maxlen,keepcurrent,endlist,nil);
end;
procedure xreadlns;
begin
xreadlnse(s,maxlen,keepcurrent,endkeysnospace);
end;
procedure xsetcolor;
{color is 0-15, background is 0-7}
begin
if console then
begin
textcolor(color and $f);
textbackground(color shr 4);
end
else if color=highcolor then
xwritess(esc,'[7m')
else
xwritess(esc,'[m');
end;
procedure xhighvideo;
begin
xsetcolor(highcolor);
end;
procedure xlowvideo;
begin
xsetcolor(lowcolor);
end;
procedure xwritehighlights;
var
i: integer;
begin
for i := 1 to length(s) do
if s[i]='{' then
xhighvideo
else if s[i]='}' then
xlowvideo
else
xwrites(s[i]);
end;
procedure hwritexy;
begin
xgotoxy(x,y);
xwritehighlights(s);
end;
end.