home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ucsdibmpc.tar.gz
/
ucsdibmpc.tar
/
kermutil.text
< prev
next >
Wrap
Text File
|
1984-05-23
|
13KB
|
493 lines
unit kermutil;
{ Change log:
13 May 84: Use KERNEL's syscom record for screen control -sp-
}
interface
uses {$U kermglob.code} kermglob;
function read_ch(unitno: integer; var ch: char): boolean;
procedure read_str(unitno:integer; var s: string255);
procedure echo(ch: char);
procedure clear_buf(unitno:integer);
function aand(x,y: integer): integer;
function aor(x,y: integer): integer;
function xor(x,y: integer): integer;
procedure uppercase(var s: string255);
procedure error(p: packettype; len: integer);
procedure io_error(i: integer);
procedure debugwrite(s: string255);
procedure debugint(s: string255; i: integer);
function min(x,y: integer): integer;
function tochar(ch: char): char;
function unchar(ch: char): char;
function ctl(ch: char): char;
function getch(var r: char_int_rec): boolean;
function getsoh: boolean;
function getfil(filename: string255): boolean;
procedure send_brk;
procedure setup_comm;
procedure write_ch(unitno: integer; ch: char );
procedure screen( scrcmd: scrcommands );
procedure writescreen(s: string255);
procedure refresh_screen(numtry, num: integer);
implementation
uses {$U remunit.code} remunit, {SP, 1/14/84}
{$U kernel.code} kernel;
procedure uppercase(*var s: string255*);
var i: integer;
begin
for i := 1 to length(s) do
if s[i] in ['a'..'z'] then
s[i] := chr(ord(s[i]) - ord('a') + ord('A'))
end; (* uppercase *)
screen -- perform screen operations
procedure screen{( scrcmd: scrcommands )};
begin
{ for portability, peek in at syscom vector to get control chars }
with syscom^ do begin
if crtctrl.prefixed[ord(scrcmd)] then
write( crtinfo.prefix );
with crtctrl do
case scrcmd of
sc_up: write( rlf );
sc_right: write( ndfs );
sc_clreol: write( eraseeol );
sc_clreos: write( eraseeos );
sc_home: write( home );
sc_escape: write( escape );
sc_left: write( backspace );
sc_clrall: write( clearscreen );
scr_clrline: write( clearline )
end
end
end; { screen }
function read_ch(*unitno:integer; var ch: char): boolean*);
(* read a character from an input queue *)
var
ready: boolean;
begin
if unitno=keyport then
ready := cr_kbstat
else if unitno=inport then
ready := cr_remstat
else
ready := false;
if ready then (* if a char there *)
if unitno=keyport then begin
ch := ' ';
unitread( keyport, ch, 1,, 12 )
end
else
ch := cr_getrem;
read_ch := ready
end; (* read_ch *)
procedure write_ch(*unitno: integer; ch: char*);
begin
if unitno=oport then
cr_putrem( ch )
end;
procedure read_str(*unitno:integer; var s: string255*);
(* acts like readln(s) but takes input from input queue *)
var i: integer;
begin
i := 0;
s := copy('',0,0);
repeat
repeat (* get a character *)
until read_ch(unitno,ch);
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 *)
procedure clear_buf(*unitno:integer*);
modified by SP
begin
if unitno=keyport then
unitclear( unitno )
end;
procedure send_brk;
begin
cr_break
end;
procedure setup_comm;
SP, 14 Jan 84
var
result: cr_baud_result;
begin
cr_setcommunications(false,
false,
baud,
8,
1,
cr_orig,
'IBM PC',
result );
end;
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 and yrec.b; (* use as booleans 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 or yrec.b; (* use as booleans to 'or' them *)
aor := temp.i (* return integer result *)
end; (* aor *)
function xor(*x,y: integer): integer*);
(* exclusive or *)
var xrec, yrec, temp: int_bool_rec;
begin
xrec.i := x; (* put two numbers in variant record *)
yrec.i := y;
(* use as booleans to 'xor' them *)
temp.b := (xrec.b or yrec.b) and (not(xrec.b and yrec.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 );
screen( sc_clreol );
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: string255*);
(* writes a debugging message *)
var i: integer;
begin
if debug then
begin
gotoxy(0,debugline);
screen( sc_clreol );
write(s);
for i := 1 to 2000 do ; (* write debugging message *)
end (* if debug *)
end; (* debugwrite *)
procedure debugint(*s: string255; i: integer*);
(* write a debugging message and an integer *)
begin
if debug then
begin
debugwrite(s);
write(i)
end (* if debug *)
end; (* debugint *)
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 *)
const
maxtry = 30000;
var count, cursorx, cursory:integer;
The DataMedia emulation is by John Socha.
begin
ch := chr(aand(ord(ch),127)); (* mask off parity bit *)
if emulating and (ord(ch) in [30,25,28,31,29,11]) then
case ord(ch) of
{ Datamedia 1520 emulation }
{ rs }30: begin
{ allow timeout while waiting for coordinates
so computer doesn't freeze }
count := 0;
repeat
count := count + 1
until read_ch( inport, ch ) or (count>maxtry);
if count<=maxtry then begin
cursorx:=ord(ch)-32;
count := 0;
repeat
count := count + 1
until read_ch( inport, ch ) or (count>maxtry);
if count<=maxtry then begin
cursory:=ord(ch)-32;
gotoxy(cursorx,cursory)
end
end
end;
{ em }25: screen( sc_home );
{ fs }28: screen( sc_right );
{ us }31: screen( sc_up );
{ gs }29: screen( sc_clreol );
{ vt }11: screen( sc_clreos )
end
else
unitwrite(1,ch,1,,12) { the 12 eliminates DLE & CR expansion }
end; (* echo *)
function getch(*var r: char_int_rec): 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 (read_ch(inport,r.ch)) or (count>maxtry); (* wait for a character *)
if (count > maxtry) then (* if wait too long then *)
exit(getch); (* get out of here *)
r.i := aand(r.i,127); (* strip parity from char *)
getch := (r.ch <> chr(soh)); (* return true if not SOH *)
end; (* getch *)
function getsoh(*: boolean*);
(* reads characters until it finds an SOH; returns false if has to read more *)
(* than maxtry chars *)
modified by SP
const maxtry = 10000;
var ch: char;
count: integer;
begin
count := 0;
getsoh := true;
repeat
repeat
count := count + 1
until (read_ch(inport,ch)) or (count > maxtry); (* wait for a character *)
if (count > maxtry) then
begin
getsoh := false;
exit(getsoh)
end; (* if *)
ch := chr(aand(ord(ch),127)); (* strip parity of char *)
until (ch = chr(SOH)) (* if not SOH, get more *)
end; (* getsoh *)
function getfil(*filename: string255): boolean*);
(* opens a file for writing *)
begin
(*$I-*) (* turn i/o checking off *)
rewrite(f,filename);
(*$I-*) (* turn i/o checking on *)
getfil := (ioresult = 0)
end; (* getfil *)
procedure writescreen(*s: string255*);
(* sets up the screen for receiving or sending files *)
begin
page(output);
gotoxy(0,titleline);
write(' Kermit UCSD p-system, Version ', version );
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 *)
begin { body of unit kermutil }
{ initialization code }
syscom^.crtinfo.flush := chr(255); { effectively turning flush off }
syscom^.crtinfo.stop := chr(254); { effectively turning stop off }
***; { <-- would you believe that this is Pascal? }
{ termination code }
syscom^.crtinfo.flush := chr(6); { turn flush back on }
syscom^.crtinfo.stop := chr(19) { effectively turning stop off }
end. { kermutil }