home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
pub
/
ucsdwdme
/
utils.text
< prev
next >
Wrap
Text File
|
2020-01-01
|
8KB
|
265 lines
function ready(p:port):boolean;
begin
ready:= ((p=terminal) and istarr) or ((p=modem) and istbrr);
end;
function pget(p:port):char;
begin
if p=terminal then pget:=rcvabt
else pget:=rcvbbt;
end;
procedure read_str(*var p: port; var s: string*);
(* acts like readln(s) but takes input from specified port *)
var i: integer;
begin
i := 0;
s := copy('',0,0);
repeat
repeat (* get a character *)
until ready(p);
ch:=pget(p);
if (ord(ch) = backspace) then (* if it's a backspace then *)
begin
if (i > 0) then (* if not at beginning of line *)
begin
write(ch); (* go back a space on screen *)
write(' '); (* erase char on screen *)
write(ch); (* go back a space again *)
i := i - 1; (* adjust string counter *)
s := copy(s,1,i) (* adjust string *)
end (* if *)
end (* if *)
else if (ord(ch) <> eoln_sym) then (* otherwise if not at eoln then *)
begin
write(ch); (* echo char on screen *)
i := i + 1; (* inc string counter *)
s := concat(s,' ');
s[i] := ch; (* put char in string *)
end; (* if *)
until (ord(ch) = eoln_sym); (* if not eoln, get another char *)
s := copy(s,1,i); (* correct string length *)
writeln (* write a line on the screen *)
end; (* read_str *)
function read_ch(*p: port; var ch: char): boolean*);
(* read a character from an input port *)
begin
if ready(p) then (* if a char there *)
begin
ch := pget(p); (* get the char *)
read_ch := true; (* and return true *)
end (* if *)
else (* otherwise *)
read_ch := false; (* return false *)
end; (* read_ch *)
function getch(*var r: char; p: port): boolean*);
(* gets a character, strips parity, returns true if it got a char which *)
(* isn't Kermit SOH, false if it gets SOH or nothing after maxtry *)
const maxtry = 10000;
var count: integer;
begin
count := 0;
getch := false;
repeat
count := count + 1;
until ready(p) or (count > maxtry); (* wait for a character *)
if (count > maxtry) then (* if wait too long then *)
exit(getch); (* get out of here *)
r:=pget(p); (* get the character *)
r := chr(aand(ord(r),127)); (* strip parity from char *)
getch := (r <> chr(soh)); (* return true if not SOH *)
end; (* getch *)
function aand(*x,y: integer): integer*);
(* arithmetic and--takes 2 integers and ands them, yeilding an integer *)
var xrec, yrec, temp: int_bool_rec;
begin
xrec.i := x; (* put the two numbers in variant record *)
yrec.i := y;
temp.b := xrec.b * yrec.b; (* use as sets to 'and' them *)
aand := temp.i (* return integer result *)
end; (* aand *)
function aor(*x,y: integer): integer*);
(* arithmetic or *)
var xrec, yrec, temp: int_bool_rec;
begin
xrec.i := x; (* put two numbers in variant record *)
yrec.i := y;
temp.b := xrec.b + yrec.b; (* use as sets to 'or' them *)
aor := temp.i (* return integer result *)
end; (* aor *)
function xor(*x,y: integer): integer*);
(* exclisive or *)
var xrec, yrec, temp: int_bool_rec;
begin
xrec.i := x; (* put two numbers in variant record *)
yrec.i := y;
(* use as sets to 'xor' them *)
temp.b := (xrec.b - yrec.b) + (yrec.b - xrec.b);
xor := temp.i (* return integer result *)
end; (* xor *)
procedure error(*p: packettype; len: integer*);
(* writes error message sent by remote host *)
var i: integer;
begin
gotoxy(0,errorline);
for i := 0 to len-1 do
write(p[i]);
gotoxy(0,promptline);
end; (* error *)
procedure io_error(*i: integer*);
begin
gotoxy(0,errorline);
write(chr(27),'K'); (* erase to end of line *)
case i of
0: writeln('No error');
1: writeln('Bad Block, Parity error (CRC)');
2: writeln('Bad Unit Number');
3: writeln('Bad Mode, Illegal operation');
4: writeln('Undefined hardware error');
5: writeln('Lost unit, Unit is no longer on-line');
6: writeln('Lost file, File is no longer in directory');
7: writeln('Bad Title, Illegal file name');
8: writeln('No room, insufficient space');
9: writeln('No unit, No such volume on line');
10: writeln('No file, No such file on volume');
11: writeln('Duplicate file');
12: writeln('Not closed, attempt to open an open file');
13: writeln('Not open, attempt to close a closed file');
14: writeln('Bad format, error in reading real or integer');
15: writeln('Ring buffer overflow')
end; (* case *)
gotoxy(0,promptline)
end; (* io_error *)
procedure debugwrite(*s: string*);
(* writes a debugging message *)
var i: integer;
begin
if debug then
begin
gotoxy(0,debugline+debnext);
debnext:=(debnext+1) mod debug_max;
write(chr(27),'K'); (* erase to end of line *)
write(s); (* write debugging message *)
end (* if debug *)
end; (* debugwrite *)
procedure debugint(*s: string; i: integer*);
(* write a debugging message and an integer *)
begin
if debug then
begin
debugwrite(s);
write(i)
end (* if debug *)
end; (* debugint *)
procedure writescreen(*s: string*);
(* sets up the screen for receiving or sending files *)
begin
write(chr(esc),'E'{clearscreen});
gotoxy(0,titleline);
write(' Kermit UCSD p-system');
gotoxy(statuspos,statusline);
write(s);
gotoxy(0,packetline);
write('Number of Packets: ');
gotoxy(0,retryline);
write('Number of Tries: ');
gotoxy(0,fileline);
write('File Name: ');
end; (* writescreen *)
procedure refresh_screen(*numtry, num: integer*);
(* keeps track of packet count on screen *)
begin
gotoxy(retrypos,retryline);
write(numtry: 5);
gotoxy(packetpos,packetline);
write(num: 5)
end; (* refresh_screen *)
function min(*x,y: integer): integer*);
(* returns smaller of two integers *)
begin
if x < y then
min := x
else
min := y
end; (* min *)
function tochar(*ch: char): char*);
(* tochar converts a control character to a printable one by adding space *)
begin
tochar := chr(ord(ch) + ord(' '))
end; (* tochar *)
function unchar(*ch: char): char*);
(* unchar undoes tochar *)
begin
unchar := chr(ord(ch) - ord(' '))
end; (* unchar *)
function ctl(*ch: char): char*);
(* ctl toggles control bit: ^A becomes A, A becomes ^A *)
begin
ctl := chr(xor(ord(ch),64))
end; (* ctl *)
procedure echo(ch: char);
(* echos a character on the screen *)
begin
ch := chr(aand(ord(ch),127)); (* mask off parity bit *)
repeat until istatr;
sndabt(ch)
end; (* echo *)