home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ucsdappleii.tar.gz
/
ucsdappleii.tar
/
kermutil.text
< prev
next >
Wrap
Text File
|
1986-04-08
|
9KB
|
374 lines
(*>>>>>>>>>>>>>>KERMUTIL>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*)
$S+
$I-
$R-
$V-
UNIT kermutil; INTRINSIC CODE 20;
INTERFACE
USES kermglob;
PROCEDURE upper_case( VAR s : STRING );
FUNCTION interrupt( int_key : CHAR ) : BOOLEAN;
PROCEDURE error(VAR p: packettype; len: INTEGER);
PROCEDURE io_error(i: INTEGER);
PROCEDURE debugwrite( s: STRING);
PROCEDURE packet_write( VAR p : packettype; len : INTEGER );
PROCEDURE ack_write( ptype: CHAR; len,num: INTEGER; VAR data: packettype);
PROCEDURE write_bool( s: STRING; b: BOOLEAN);
PROCEDURE read_str( VAR s : STRING);
PROCEDURE write_ctl( ch : CHAR);
FUNCTION test_printer : BOOLEAN;
FUNCTION min(x,y: INTEGER): INTEGER;
FUNCTION tochar(ch: CHAR): CHAR;
FUNCTION unchar(ch: CHAR): CHAR;
PROCEDURE screen( scrcmd: scrcommands );
PROCEDURE writescreen( s: STRING);
PROCEDURE refresh_screen(numtry, num: INTEGER);
PROCEDURE check_apple_char( check: rem_stat_rec);
FUNCTION ctl( ch : CHAR ) : CHAR;
FUNCTION calc_checksum( VAR packet: packettype; len : INTEGER ) : CHAR;
IMPLEMENTATION
PROCEDURE uppercase {var s: string};
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 *)
FUNCTION interrupt{ (int_key : char) : boolean };
var buflen : packed array[0..7] of 0..255;
ch : char;
begin
interrupt := false; ch := ' ';
unitstatus( keyport, buflen[0], control_word );
if buflen[0] > 0
then begin
unitread( keyport, ch, 1,, 12 );
if ch = int_key then interrupt := true;
end;
end; { interrupt }
PROCEDURE screen{ scrcmd: scr_commands };
begin
if prefixed[ scrcmd ] then unitwrite( consol, prefix, 1,,12 );
case scrcmd of
sc_up : unitwrite( consol, rlf , 1,,12 );
sc_right : unitwrite( consol, ndfs , 1,,12 );
sc_clreol : unitwrite( consol, eraseol , 1,,12 );
sc_clreos : unitwrite( consol, eraseos , 1,,12 );
sc_home : unitwrite( consol, home , 1,,12 );
sc_delchar : unitwrite( consol, delchar , 1,,12 );
sc_clrall : unitwrite( consol, clrscreen, 1,,12 );
sc_clrline : unitwrite( consol, clrline , 1,,12 );
sc_left : unitwrite( consol, backsp , 1,,12 );
sc_down : unitwrite( consol, lf , 1,,12 );
end; { case }
end; { procedure screen }
PROCEDURE error{ var p: packettype; len: integer };
(* writes error message sent by remote host *)
begin
gotoxy(0,errorline);
screen( sc_clreol );
write('Host error : ');
unitwrite( consol, p[0], len,, 12 );
gotoxy(0,promptline);
end; (* error *)
PROCEDURE io_error{ i: integer };
begin
gotoxy( 0, errorline );
screen( sc_clreol );
write('IO_ERROR : ');
case i of
0: writeln('No error');
1: writeln('Bad Block, Parity error (CRC)'); {not used for Apple}
2: writeln('Bad Unit Number');
3: writeln('Bad Mode, Illegal operation');
4: writeln('Undefined hardware error'); {not used for Apple}
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');
16: writeln('Diskette is write protected');
end; (* case *)
if i = 64 then writeln('Bad block on diskette');
gotoxy(0,promptline)
end; (* io_error *)
PROCEDURE debugwrite{ s: string };
(* writes a debugging message *)
var j: integer;
begin
gotoxy( 0, debug_line );
screen( sc_clreol );
write('Debug state is ', s );
end; (* debugwrite *)
PROCEDURE packet_write{ var p:packettype; len: integer };
(* writes a packet to the screen for debugging purposes *)
var i : integer;
begin
gotoxy( 0, pack_line + 2 ); screen( sc_clreol ); gotoxy( 0, pack_line + 1 );
screen( sc_clreol );
unitwrite( consol, p[1], ( len-2 ), , 12 );
end; { packet_write }
PROCEDURE ack_write{ ptype: char; len,num: integer; var data: packettype};
(* writes a ack/nack package to the screen for debugging purposes *)
var i : integer;
begin
gotoxy( 0, ack_line + 1 );
screen( sc_clreos );
writeln('type= ',ptype);
writeln('num = ',num);
writeln('len = ',len);
unitwrite(consol, data[0], len,, 12 );
end; { ack_write }
PROCEDURE write_bool{ s: string; b: boolean};
(* writes message & 'on' if b, 'off' if not b *)
begin
write(p, s);
case b of
true: writeln(p,'ON');
false: writeln(p,'OFF');
end; (* case *)
end; (* write_bool *)
PROCEDURE write_ctl{ ch : char };
begin
if ord(ch) < 32
then begin
if ord(ch) = 27 then write(p,'<ESC>')
else write(p,'<^',chr(ord(ch)+64),'> ');
end
else begin
if ord(ch) = 127 then write(p,'<DEL>')
else write(p,'<',ch,'> ');
end;
end; { write_ctl }
PROCEDURE read_str{ var s : string };
var i, j, k : integer;
ch : char;
begin
i := 0; s := ''; ch := ' ';
repeat
unitread( keyport, ch, 1 );
if ch = backsp
then begin
if i > 0
then begin
if s[i] in ctl_set then j := 5 else j := 1;
for k := 1 to j do write( ch, ' ', ch );
delete( s, i, 1 );
i := i - 1;
end;
end
else begin
if ch <> cr
then begin
if i < 80
then begin
if ch in ctl_set then write_ctl( ch )
else write( ch );
i := i + 1;
s := concat( s, ' ' );
s[i] := ch;
end
else write( chr(bell) );
end;
end;
until ch = cr;
writeln;
end; { read_str }
FUNCTION test_printer;
this function only tests for the presence of a printerinterface card
begin
close( pr );
reset( pr, pr_file );
test_printer := ( ioresult = 0 );
end;
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 *)
PROCEDURE writescreen{ s: string };
(* sets up the screen for receiving or sending files *)
begin
page(output);
gotoxy( 11, titleline); write('Kermit UCSD p-System : ', s );
gotoxy( 50, statusline - 1 );
write('( type '); write_ctl( int_key );
write(' to break off )');
gotoxy(0,packetline);
write('Number of Packets: ');
gotoxy(0,retryline);
write('Number of Tries: ');
gotoxy(0,fileline);
write('File Name: ');
if debug then
begin
gotoxy(0,packline);
write('Outgoing Packet:');
gotoxy(0,ackline);
write('Incoming Packet:');
end;
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 *)
PROCEDURE check_apple_char { check : rem_stat_rec };
this procedure only works with a special implementation of unitstatus
in the attached remin driver. special character checking can be turned
off or on depending on the value of 'check'. also the remin driver can
be instructed to pass 7 or 8 bit characters to pascal.
var control_word : cntrl_word_rec;
begin
with control_word do
begin
channel := inp; purpose := control; special_req := none;
reserved := 0; filler := 0;
end;
unitstatus( inport, check, control_word );
end; { check_apple_char }
FUNCTION ctl{ ( ch : char ) : char }; EXTERNAL;
toggles bit 7 of a character: ' controllifies or decontrollifies '
FUNCTION calc_checksum{ (var packet:packettype; len:integer):char }; EXTERNAL;
calculates one character checksum of a packet
begin
end. { kermutil }