home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
c
/
ucibmpc.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2020-01-01
|
82KB
|
2,639 lines
>>>> HELPER.TEXT
unit helper;
interface
procedure help;
implementation
uses {$U kermglob.code} kermglob;
procedure keypress;
var ch: char;
begin
writeln('---------------Press any key to continue---------------');
read( keyboard, ch );
page(output); {SP}
end; (* keypress *)
procedure help1;
var ch: char;
begin { help1 }
if (noun = nullsym) then begin
writeln('KERMIT is a family of programs that do reliable file transfer');
writeln('between computers over TTY lines.',
' KERMIT can also be used to make the ');
writeln('microcomputer behave as a terminal',
' for a mainframe. These are the ');
writeln('commands for the UCSD p-system version, KERMIT-UCSD:');
writeln
end; (* if *)
if (noun = nullsym) or (noun = consym) then begin
writeln(' CONNECT To make a "virutual terminal" connection to a remote');
writeln(' ':14, 'system.');
writeln;
writeln(' ':14, 'To break the connection and "escape" back to the micro,');
writeln(' ':14, 'type the escape sequence (CTRL-] C, that is Control ');
writeln(' ':14, 'rightbracket followed immediately by the letter C.)');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = exitsym) then begin
writeln(' EXIT To return back to main command level of the p-system.');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = helpsym) then begin
writeln(' HELP To get a list of KERMIT commands.');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = quitsym) then begin
writeln(' QUIT Same as EXIT.');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = recsym) then begin
writeln(' RECEIVE To accept a file from the remote system.');
writeln;
end; (* if *)
end; (* help1 *)
procedure help2;
var ch: char;
begin { help2 }
if (noun = nullsym) or (noun = sendsym) then begin
writeln(' SEND To send a file or group of files to the remote system.');
writeln;
end; (* if *)
if (noun = nullsym) then
keypress;
if (noun = nullsym) or (noun = setsym) then begin
writeln(' SET To establish system-dependent parameters. The ');
writeln(' SET options are as follows: ');
writeln;
if (adj = nullsym) or (adj = debugsym) then begin
writeln(' DEBUG To set debug mode ON or OFF ');
writeln(' ':31, '(default is OFF).');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = escsym) then begin
writeln(' ':14, 'ESCAPE To change the escape sequence that ');
writeln(' ':31, 'lets you return to the PC Kermit from');
writeln(' ':31, 'the remote host. The default is CTRL-] c.');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = filewarnsym) then begin
writeln(' ':14, 'FILE-WARNING ON/OFF, default is OFF. If ON, ');
writeln(' ':31, 'Kermit will warn you and rename an ');
writeln(' ':31, 'incoming file so as not to write over');
writeln(' ':31, 'a file that currently exists with the');
writeln(' ':31, 'same name');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = baudsym) then begin
writeln(' ':14, 'BAUD To set the serial baud rate.' );
writeln(' ':31, 'Choices are: 110/300/1200/2400/4800/9600.' );
writeln(' ':31, 'The default is 1200.');
writeln
end; (* if *)
if (adj = nullsym) then
keypress;
end; (* if *)
end; (* help2 *)
procedure help3;
begin
if (noun = nullsym) or (noun = setsym) then begin
if (adj = nullsym) or (adj = ibmsym) then begin
writeln(' ':14, 'IBM ON/OFF, default is OFF. This flag ');
writeln(' ':31, 'should be ON only when transfering files');
writeln(' ':31, 'between the micro and an IBM VM/CMS');
writeln(' ':31, 'system. It also causes the parity to');
writeln(' ':31, 'be set appropriately (mark) and activates');
writeln(' ':31, 'local echoing');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = localsym) then begin
writeln(' ':14, 'LOCAL-ECHO ON/OFF, default is OFF. This sets the');
writeln(' ':31, 'duplex. It should be ON when using ');
writeln(' ':31, 'the IBM and OFF for the DEC-20.');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = emulatesym) then begin
writeln(' ':14, 'EMULATE ON/OFF, default is OFF. This sets the');
writeln(' ':31, 'DataMedia 1520A terminal emulation on or off.');
writeln;
end; (* if *)
end; (* if *)
end; (* help3 *)
procedure help4;
begin
if (noun = setsym) or (noun = nullsym) then begin
if (adj = nullsym) or (adj = paritysym) then begin
writeln(' ':14, 'PARITY EVEN, ODD, MARK, SPACE, or NONE.');
writeln(' ':31, 'NONE is the default but if the IBM ');
writeln(' ':31, 'flag is set, parity is set to MARK. ');
writeln(' ':31, 'This flag selects the parity for ');
writeln(' ':31, 'outgoing and incoming characters during');
writeln(' ':31, 'CONNECT and file transfer to match the');
writeln(' ':31, 'requirements of the host.');
writeln;
end; (* if *)
end; (* if *)
if (noun = nullsym) or (noun = showsym) then begin
writeln(' SHOW To see the values of parameters that can be modified');
writeln(' via the SET command.');
end; (* if *)
end; (* help4 *)
procedure help;
begin
help1;
help2;
help3;
help4
end; (* help *)
end. { unit helper }
>>>> KERMGLOB.TEXT
unit kermglob;
interface
const blksize = 512;
oport = 8; (* output port # *)
inport = 7;
keyport = 2;
bell = 7; (* ASCII bell *)
maxpack = 93; (* maximum packet size minus 1 *)
soh = 1; (* start of header *)
sp = 32; (* ASCII space *)
cr = 13; (* ASCII CR *)
lf = 10; (* ASCII line feed *)
xdle = 16; (* ASCII DLE (space compression prefix for psystem) *)
del = 127; (* delete *)
my_esc = 29; (* default esc char for connect (^]) *)
maxtry = 5; (* number of times to retry sending packet *)
my_quote = '#'; (* quote character I'll use *)
my_pad = 0; (* number of padding chars I need *)
my_pchar = 0; (* padding character I need *)
my_eol = 13; (* end of line character i need *)
my_time = 5; (* seconds after which I should be timed out *)
maxtim = 20; (* maximum timeout interval *)
mintim = 2; (* minimum time out interval *)
at_eof = -1; (* value to return if at eof *)
rqsize = 5000; (* input queue size *)
qsize1 = 5001; (* qsize + 1 *)
eoln_sym = 13; (* pascal eoln sym *)
back_space = 8; (* pascal backspace sym *)
defaultbaud = 1200; (* default baud rate *)
(* screen control information *)
(* console line on which to put specified info *)
title_line = 1;
statusline = 2;
packet_line = 3;
retry_line = 4;
file_line = 5;
error_line = 6;
debug_line = 7;
prompt_line = 8;
(* position on line to put info *)
statuspos = 70;
packet_pos = 19;
retry_pos = 17;
file_pos = 11;
type packettype = packed array[0..maxpack] of char;
parity_type = (evenpar, oddpar, markpar, spacepar, nopar);
char_int_rec = record (* allows character to be treated as integer... *)
(* is system dependent *)
case boolean of
true: (i: integer);
false: (ch: char)
end; (* record *)
int_bool_rec = record (* allows integer to be treated as boolean... *)
(* used for numeric and, or, xor...system dependent *)
case boolean of
true: (i: integer);
false: (b: boolean)
end; (* record *)
string255 = string[255];
statustype = (null, at_eol, unconfirmed, parm_expected, ambiguous,
unrec, fn_expected, ch_expected, num_expected);
vocab = (nullsym, allsym, baudsym, consym, debugsym, emulatesym,
escsym, evensym, exitsym, filewarnsym,helpsym, ibmsym,
localsym, marksym, nonesym, oddsym, offsym, onsym, paritysym,
quitsym, recsym, sendsym, setsym, showsym, spacesym);
scrcommands = (sc_up, sc_right, sc_clreol, sc_clreos, sc_home,
sc_escape, sc_left, sc_clrall, scr_clrline);
var noun, verb, adj: vocab;
status: statustype;
vocablist: array[vocab] of string255;
xfilename, line: string255;
newescchar: char;
expected: set of vocab;
newbaud: integer;
currstate: char; (* current state *)
f: file of char; (* file to be received *)
oldf: file; (* file to be sent *)
s: string255;
xeol, quote, esc_char: char;
fwarn, ibm, half_duplex, debug: boolean;
i, size, rpsiz, spsiz, pad, n, num_try, oldtry, timint: integer;
recpkt, packet: packettype;
padchar, ch: char;
debf: text; (* file for debug output *)
parity: parity_type;
xon: char;
filebuf: packed array[1..1024] of char;
bufpos, bufend: integer;
parity_array: packed array[char] of char;
ctlset: set of char;
rec_ok, send_ok: boolean;
baud: integer;
emulating: boolean;
implementation
end. { kermglob }
>>>> KERMIT.TEXT
program kermit;
(* $R-*) (* turn range checking off *)
(* $L+*)
USES {$u kermglob.code} kermglob,
{$U kermutil.code} kermutil,
(* {$U kermpack.code} kermpack, *)
{$U parser.code} parser,
{$U helper.code} helper,
{$U sender.code} sender,
{$U receiver.code} receiver;
{
Modifications by SP, 25 Oct 1983: adapt to IBM Version IV.1
Delete keyboard and serial buffering: provided by system already.
Additional mods by SP, 18 Mar 1984: make all strings 255 chars long
13 May 84: Incorporate screen control through syscom record entries
for portability
}
procedure showparms;
forward;
procedure connect;
(* connect to remote host and transceive *)
var ch: char;
close: boolean;
procedure read_esc;
(* read character after esc char and interpret it *)
begin
repeat
until read_ch(keyport,ch); (* wait until they've typed something in *)
if (ch in ['a'..'z']) then (* uppercase it *)
ch := chr(ord(ch) - ord('a') + ord('A'));
if ch in ['B','C','S','?'] then
case ch of
'B': sendbrk; (* B: send a break to the IBM *)
'C': close := true; (* C: end connection *)
'S': begin (* S: show status *)
noun := allsym;
showparms
end; (* S *)
'?': begin (* ?: show options *)
writeln('B Send a BREAK signal.');
writeln('C Close Connection, return to KERMIT-UCSD command level.');
writeln('Q Query Status of connection');
writeln('F Send Control-F character to remote host.' );
writeln('S Send Control-S character to remote host.' );
writeln('? Print this list');
writeln('^',esc_char,' send the escape character itself to the');
writeln(' remote host.')
end; (* ? *)
end (* case *)
else if ch = esc_char then (* ESC-char: send it out *)
begin
if half_duplex then
begin
write(ch); { changed from echo() by SP }
write_ch(oport,ch)
end (* if *)
end (* else if *)
else (* anything else: ignore *)
write(chr(bell))
end; (* read_esc *)
begin (* connect *)
clear_buf(keyport); (* empty keyboard buffer *)
clear_buf(inport); (* empty remote input buffer *)
writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit');
close := false;
repeat
if read_ch(inport,ch) then (* if char from host then *)
echo(ch); (* echo it *)
if read_ch(keyport,ch) then (* if char from keyboard then *)
if ch <> esc_char then (* if not ESC-char then *)
begin
if half_duplex then (* echo it if half-duplex *)
write(ch); { changed from echo() by sp }
write_ch(oport,ch) (* send it out the port *)
end (* if *)
else (* ch = esc_char *) (* else is ESC-char so *)
read_esc; (* interpret next char *)
until close; (* if still connected, get more *)
writeln('Disconnected')
end; (* connect *)
procedure fill_parity_array;
(* parity value table for even parity...not(entry) = odd parity *)
const min = 0;
max = 126;
var i, shifter, counter: integer;
minch, maxch, ch: char;
r: char_int_rec;
begin
minch := chr(min);
maxch := chr(max);
case parity of
evenpar: for ch := minch to maxch do begin
r.ch := ch; (* put char into variant record *)
shifter := aand(r.i,255); (* mask off parity bit *)
counter := 0;
for i := 1 to 7 do begin (* count the 1's *)
if odd(shifter) then
counter := counter + 1;
shifter := shifter div 2
end; (* for i *)
if odd(counter) then (* stick a 1 on if necessary *)
parity_array[ch] := chr(aor(ord(ch),128))
else
parity_array[ch] := chr(aand(ord(ch),127))
end; (* for ch *) (* case even *)
oddpar: for ch := minch to maxch do begin
r.ch := ch; (* put char into variant record *)
shifter := aand(r.i,255); (* mask off parity bit *)
counter := 0;
for i := 1 to 7 do begin (* count the 1's *)
if odd(shifter) then
counter := counter + 1;
shifter := shifter div 2
end; (* for i *)
if odd(counter) then (* stick a 1 on if necessary *)
parity_array[ch] := chr(aand(ord(ch),127))
else
parity_array[ch] := chr(aor(ord(ch),128))
end; (* for ch *) (* case odd *)
markpar:
for ch := minch to maxch do (* stick a 1 on all chars *)
parity_array[ch] := chr(aor(ord(ch),128));
spacepar:
for ch := minch to maxch do (* mask off parity on all chars *)
parity_array[ch] := chr(aand(ord(ch),127));
nopar:
for ch := minch to maxch do (* don't mess with parity bit at all *)
parity_array[ch] := ch;
end; (* case *)
end; (* fill_parity_array *)
{$I setshow.text}
procedure initialize;
var ch: char;
begin
pad := mypad;
padchar := chr(mypchar);
xeol := chr(my_eol);
esc_char := chr(my_esc);
quote := my_quote;
ctlset := [chr(1)..chr(31),chr(del),quote];
half_duplex := false;
debug := false;
emulating := false;
fwarn := false;
spsiz := max_pack;
rpsiz := max_pack;
n := 0;
parity := nopar;
initvocab;
fill_parity_array;
ibm := false;
xon := chr(17);
bufpos := 1;
bufend := 0;
baud := defaultbaud;
setup_comm
end; (* initialize *)
procedure closeup;
begin
page( output )
end; (* closeup *)
begin (* main kermit program *)
initialize;
repeat
write('Kermit-UCSD> ');
readstr(keyport,line);
case parse of
unconfirmed: writeln('Unconfirmed');
parm_expected: writeln('Parameter expected');
ambiguous: writeln('Ambiguous');
unrec: writeln('Unrecognized command');
fn_expected: writeln('File name expected');
ch_expected: writeln('Single character expected');
null: case verb of
consym: connect;
helpsym: help;
recsym: begin
recsw(rec_ok);
gotoxy(0,debugline);
write(chr(bell));
if rec_ok then
writeln('successful receive')
else
writeln('unsuccessful receive');
(*$I-*) (* set i/o checking off *)
close(oldf); { why??? }
if not rec_ok then
close(f); { added by SP }
(*$I+*) (* set i/o checking back on *)
gotoxy(0,promptline);
end; (* recsym *)
sendsym: begin
uppercase(xfilename);
sendsw(send_ok);
gotoxy(0,debugline);
write(chr(bell));
if send_ok then
writeln('successful send')
else
writeln('unsuccessful send');
(*$I-*) (* set i/o checking off *)
close(oldf);
(*$I+*) (* set i/o checking back on *)
gotoxy(0,promptline);
end; (* sendsym *)
setsym: set_parms;
show_sym: show_parms;
end; (* case verb *)
end; (* case parse *)
until (verb = exitsym) or (verb = quitsym);
closeup
end. (* kermit *)
>>>> KERMPACK.TEXT
unit kermpack;
interface
uses {$U kermglob.code} kermglob;
procedure spar(var packet: packettype);
procedure rpar(var packet: packettype);
procedure spack(ptype: char; num:integer; len: integer; data: packettype);
function rpack(var len, num: integer; var data: packettype): char;
procedure bufemp(buffer: packettype; var f: text; len: integer);
function bufill(var buffer: packettype): integer;
implementation
uses {$U kermutil.code} kermutil;
procedure bufemp(*buffer: packettype; var f: text; len: integer*);
(* empties a packet into a file *)
{ Note: this strips out ALL linefeed characters! }
var i,ls: integer;
r: char_int_rec;
s: string255;
begin
s := copy('',0,0);
ls := 0;
i := 0;
while i < len do begin
r.ch := buffer[i]; (* get a character *)
if (r.ch = myquote) then begin (* if character is control quote *)
i := i + 1; (* skip over quote and *)
r.ch := buffer[i]; (* get quoted character *)
if (aand(r.i,127) <> ord(myquote)) then
r.ch := ctl(r.ch); (* controllify it *)
end; (* if *)
if (r.i = lf) then { skip linefeeds SP }
i := i + 1
else if (r.i = cr) then begin (* else if a carriage return then *)
i := i + 1;
{ i := i + 3; } (* skip over that and line feed *)
(*$I-*) (* turn i/o checking off *)
writeln(f,s); (* and write out line to file *)
s := copy('',0,0); (* empty the string var *)
ls := 0;
if (io_result <> 0) then begin (* if io_error *)
io_error(ioresult); (* tell them and *)
currstate := 'a'; (* abort *)
end (* if *)
end
(*$I+*) (* turn i/o checking back on *)
else begin (* else, is a regular char, so *)
r.i := aand(r.i,127); (* mask off parity bit *)
s := concat(s,' '); (* and add character to out string *)
ls := ls + 1;
s[ls] := r.ch;
i := i + 1 (* increase buffer pointer *)
end; (* else *)
end; (* while *) (* and get another char *)
(*$I-*) (* turn i/o checking off *)
write(f,s); (* and write out line to file *)
if (io_result <> 0) then begin (* if io_error *)
io_error(ioresult); (* tell them and *)
currstate := 'a'; (* abort *)
end (* if *)
(*$I+*) (* turn i/o checking back on *)
end; (* bufemp *)
function bufill(*var buffer: packettype): integer*);
(* fill a packet with data from a file...manages a 2 block buffer *)
var i, j, k, t7, count: integer;
r: char_int_rec;
begin
i := 0;
(* while file has some data & packet has some room we'll keep going *)
while ((bufpos <= bufend) or (not eof(oldf))) and (i < spsiz-12) do
begin
(* if we need more data from disk then *)
if (bufpos > bufend) and (not eof(oldf)) then
begin
(* read a couple of blocks *)
bufend := blockread(oldf,filebuf[1],2) * blksize;
(* and adjust buffer pointer *)
bufpos := 1
end; (* if *)
if (bufpos <= bufend) then (* if we're within buffer bounds *)
begin
r.ch := filebuf[bufpos]; (* get a character *)
bufpos := bufpos + 1; (* increase buffer pointer *)
if (r.i = xdle) then (* if it's space compression char, *)
begin
count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
bufpos := bufpos + 1; (* read past # *)
r.ch := ' '; (* and make current char a space *)
end (* else if *)
else (* otherwise, it's just a char *)
count := 1; (* so only 1 copy of it *)
if (r.ch in ctlset) then (* if a control char *)
begin
if (r.i = cr) then (* if a carriage return *)
begin
buffer[i] := quote; (* put (quoted) CR in buffer *)
i := i + 1;
buffer[i] := ctl(chr(cr));
i := i + 1;
r.i := lf; (* and we'll stick a LF after *)
end; (* if *)
if r.i <> 0 then (* if not a NUL then *)
begin
buffer[i] := quote; (* put the quote in buffer *)
i := i + 1;
if r.ch <> quote then
r.ch := ctl(r.ch); (* and un-controllify char *)
end (* if *)
end; (* if *)
end; (* if *)
j := 1;
while (j <= count) and (i <= spsiz - 8) do
begin (* put all the chars in buffer *)
if (r.i <> 0) then (* so long as not a NUL *)
begin
buffer[i] := r.ch;
i := i + 1;
end (* if *)
else (* if is a NUL so *)
if (bufpos > blksize) then (* skip to end of block *)
bufpos := bufend + 1 (* since rest will be NULs *)
else
bufpos := blksize + 1;
j := j + 1
end; (* while *)
end; (* while *)
if (i = 0) then (* if we're at end of file, *)
bufill := (at_eof) (* indicate it *)
else (* else *)
begin
if (j <= count) then (* if didn't all fit in packet *)
begin
bufpos := bufpos - 2; (* put buf pointer at DLE *)
(* and update compress count *)
filebuf[bufpos + 1] := tochar(chr(count-j+1));
end; (* if *)
bufill := i (* return # of chars in packet *)
end; (* else *)
end; (* bufill *)
procedure spar(*var packet: packettype*);
(* fills data array with my send-init parameters *)
begin
packet[0] := tochar(chr(maxpack)); (* biggest packet i can receive *)
packet[1] := tochar(chr(mytime)); (* when i want to be timed out *)
packet[2] := tochar(chr(mypad)); (* how much padding i need *)
packet[3] := ctl(chr(mypchar)); (* padding char i want *)
packet[4] := tochar(chr(myeol)); (* end of line character i want *)
packet[5] := myquote; (* control-quote char i want *)
packet[6] := 'N'; (* I won't do 8-bit quoting *)
end; (* spar *)
procedure rpar(*var packet: packettype*);
(* gets their init params *)
begin
spsiz := ord(unchar(packet[0])); (* max send packet size *)
timint := ord(unchar(packet[1])); (* when i should time out *)
pad := ord(unchar(packet[2])); (* number of pads to send *)
padchar := ctl(packet[3]); (* padding char to send *)
xeol := unchar(packet[4]); (* eol char i must send *)
quote := packet[5]; (* incoming data quote char *)
end; (* rpar *)
procedure packetwrite(p: packettype; len: integer);
(* writes out all of a packet for debugging purposes *)
var i: integer;
begin
gotoxy(0,debugline);
for i := 0 to len+3 do
write(p[i])
end; (* packetwrite *)
procedure spack(*ptype: char; num: integer; len: integer; data: packettype*);
(* send a packet *)
const maxtry = 10000;
var bufp, i, count: integer;
chksum: char;
buffer: packettype;
ch: char;
begin
if ibm and (currstate <> 's') then (* if ibm and not SINIT then *)
begin
count := 0;
repeat (* wait for an xon *)
repeat
count := count + 1
until (readch(inport, ch)) or (count > maxtry );
until (ch = xon) or (count > maxtry);
if count > maxtry then (* if wait too long then *)
begin
exit(spack) (* get out *)
end; (* if *)
end; (* if *)
bufp := 0;
for i := 1 to pad do
write_ch(oport,padchar); (* write out any padding chars *)
buffer[bufp] := chr(soh); (* packet sync character *)
bufp := bufp + 1;
chksum := tochar(chr(len + 3)); (* init chksum *)
buffer[bufp] := tochar(chr(len + 3)); (* character count *)
bufp := bufp + 1;
chksum := chr(ord(chksum) + ord(tochar(chr(num))));
buffer[bufp] := tochar(chr(num));
bufp := bufp + 1;
chksum := chr(ord(chksum) + ord(ptype));
buffer[bufp] := ptype; (* packet type *)
bufp := bufp + 1;
for i := 0 to len - 1 do (* loop through data chars *)
begin
buffer[bufp] := data[i]; (* store char *)
bufp := bufp + 1;
chksum := chr(ord(chksum) + ord(data[i]))
end; (* for i *)
(* compute final chksum *)
chksum := chr(aand(ord(chksum) + (aand(ord(chksum),192) div 64), 63));
buffer[bufp] := tochar(chksum);
bufp := bufp + 1;
buffer[bufp] := xeol;
if (parity <> nopar) then
for i := 0 to bufp do (* set correct parity on buffer *)
buffer[i] := parity_array[buffer[i]];
{unitwrite(oport,buffer[0],bufp+1,,12);} (* send the packet out *)
for i := 0 to bufp do
write_ch(oport, buffer[i]);
if debug then
packetwrite(buffer,len);
end; (* spack *)
(*$G+*) (* turn on goto option...need it for next routine *)
function rpack(*var len, num: integer; var data: packettype): char*);
(* read a packet *)
label 1; (* used to emulate C's CONTINUE statement *)
const maxtry = 10000;
var count, i, ichksum: integer;
chksum, ptype: char;
r: char_int_rec;
begin
count := 0;
if not getsoh and (currstate<>'r') then (*if don't get synch char then *)
begin
rpack := 'N'; (* treat as a NAK *)
num := n mod 64;
exit(rpack) (* and get out of here *)
end;
1: count := count + 1;
if (count>maxtry)and(currstate<>'r') then (* if we've tried too many times *)
begin (* and aren't waiting for init *)
rpack := 'N'; (* treat as NAK *)
exit(rpack) (* and get out of here *)
end; (* if *)
if not getch(r) then (* get a char and *)
goto 1; (* resynch if soh *)
ichksum := r.i; (* start checksum *)
len := ord(unchar(r.ch)) - 3; (* character count *)
if not getch(r) then (* get a char and *)
goto 1; (* resynch if soh *)
ichksum := ichksum + r.i;
num := ord(unchar(r.ch)); (* packet number *)
if not getch(r) then (* get a char and *)
goto 1; (* resynch if soh *)
ichksum := ichksum + r.i;
ptype := r.ch; (* packet type *)
for i := 0 to len-1 do (* get any data *)
begin
if not getch(r) then (* get a char and *)
goto 1; (* resynch if soh *)
ichksum := ichksum + r.i;
data[i] := r.ch;
end; (* for i *)
data[len] := chr(0); (* mark end of data *)
if not getch(r) then (* get a char and *)
goto 1; (* resynch if soh *)
(* compute final checksum *)
chksum := chr(aand(ichksum + (aand(ichksum,192) div 64), 63));
if (chksum <> unchar(r.ch)) then (* if checksum bad *)
rpack := chr(0) (* return 'false' indicator *)
else (* else *)
rpack := ptype; (* return packet type *)
if debug then
begin
gotoxy(0,debugline);
write(len,num,ptype);
for i := 1 to 1000 do
;
end; (* if *)
end; (* rpack *)
(*$G-*) (* turn off goto option...don't need it anymore *)
end. { kermpack }
>>>> KERMUTIL.TEXT
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 }
>>>> PARSER.TEXT
(*$S+*)
unit parser;
INTERFACE
uses {$U kermglob.code} kermglob;
function parse: statustype;
procedure initvocab;
IMPLEMENTATION
uses
{$U kermutil.code} kermutil;
procedure eatspaces(var s: string255);
var done: boolean;
i: integer;
begin
done := (length(s) = 0);
while not done do
begin
if s[1] = ' ' then
begin
i := length(s) - 1;
s := copy(s,2,i);
done := length(s) = 0
end (* if *)
else
done := true
end (* while *)
end; (* eatspaces *)
procedure isolate_word(var line, s: string255);
var i: integer;
done: boolean;
begin
done := false;
i := 1;
s := copy(' ',0,0);
while (i <= length(line)) and not done do
begin
if line[i] = ' ' then
done := true
else
s := concat(s,copy(line,i,1));
i := i + 1;
end; (* while *)
line := copy(line,i,length(line)-i+1);
end; (* isolate_word *)
function get_fn(var line, fn: string255): boolean;
var i, l: integer;
begin
get_fn := true;
isolate_word(line, fn);
l := length(fn);
(* Watch out, the set below had an ASCII null (0) in quotes as its 5th *)
(* member, between '_' and '/'. The null character has been deleted to *)
(* allow tape and network distribution of this program. *)
if (l > 15) or (l < 1) then
get_fn := false
else
for i := 1 to l do
if not (fn[i] in ['0'..'9','A'..'Z', '-', '_', '', '/', '.']) then
get_fn := false
end; (* get_fn *)
function get_num( var line: string255; var n: integer ): boolean;
var
numstr: string255;
i, l: integer;
begin
get_num := true;
isolate_word( line, numstr );
l := length(numstr);
if (l>5) or (l<1) then begin
n := 0;
get_num := false
end
else begin
n := 0; i := 1;
numstr := concat( numstr, ' ' );
while (numstr[i] in ['0'..'9']) do begin
if n<(maxint div 10) then
n := n*10 + ord( numstr[i] ) - ord( '0' );
i := i + 1
end
end
end; { get_num }
function nextch(var ch: char): boolean;
var s: string255;
begin
isolate_word(line,s);
if length(s) <> 1 then
nextch := false
else
begin
ch := s[1];
nextch := true
end (* else *)
end; (* nextch *)
function parse(*: statustype*);
type states = (start, fin, get_filename, get_set_parm, get_parity, get_on_off,
get_char, get_show_parm, get_help_show, get_help_parm,
exitstate, get_baud);
var status: statustype;
word: vocab;
state: states;
function get_sym(var word: vocab): statustype;
var i: vocab;
s: string255;
stat: statustype;
done: boolean;
matches: integer;
begin
eat_spaces(line);
if length(line) = 0 then
getsym := ateol
else
begin
stat := null;
done := false;
isolate_word(line,s);
i := allsym;
matches := 0;
repeat
if (pos(s,vocablist[i]) = 1) and (i in expected) then
begin
matches := matches + 1;
word := i
end
else if (s[1] < vocablist[i,1]) then
done := true;
if (i = spacesym) then
done := true
else
i := succ(i)
until (matches > 1) or done;
if matches > 1 then
stat := ambiguous
else if (matches = 0) then
stat := unrec;
getsym := stat
end (* else *)
end; (* getsym *)
begin
state := start;
parse := null;
noun := nullsym;
verb := nullsym;
adj := nullsym;
uppercase(line);
repeat
case state of
start:
begin
expected := [consym, exitsym, helpsym, quitsym, recsym, sendsym,
setsym, showsym];
status := getsym(verb);
if status = ateol then
begin
parse := null;
exit(parse)
end (* if *)
else if (status <> unrec) and (status <> ambiguous) then
case verb of
consym: state := fin;
exitsym, quitsym: state := fin;
helpsym: state := get_help_parm;
recsym: state := fin;
sendsym: state := getfilename;
setsym: state := get_set_parm;
showsym: state := get_show_parm;
end (* case *)
end; (* case start *)
fin:
begin
expected := [];
status := getsym(verb);
if status = ateol then
begin
parse := null;
exit(parse)
end (* if status *)
else
status := unconfirmed
end; (* case fin *)
getfilename:
begin
expected := [];
if getfn(line,xfilename) then
begin
status := null;
state := fin
end (* if *)
else
status := fnexpected
end; (* case get file name *)
get_set_parm:
begin
expected := [paritysym, localsym, ibmsym, emulatesym, escsym,
debugsym, filewarnsym, baudsym];
status := getsym(noun);
if status = ateol then
status := parm_expected
else if (status <> unrec) and (status <> ambiguous) then
case noun of
paritysym: state := get_parity;
localsym: state := get_on_off;
ibmsym: state := get_on_off;
emulatesym: state := get_on_off;
escsym: state := getchar;
debugsym: state := get_on_off;
filewarnsym: state := get_on_off;
baudsym: state := get_baud
end (* case *)
end; (* case get_set_parm *)
get_parity:
begin
expected := [marksym, spacesym, nonesym, evensym, oddsym];
status := getsym(adj);
if status = ateol then
status := parm_expected
else if (status <> unrec) and (status <> ambiguous) then
state := fin
end; (* case get_parity *)
get_baud:
begin
expected := [];
if get_num( line, newbaud ) then begin
status := null; state := fin
end
else begin
newbaud := 0;
status := parm_expected
end
end; (* case get_baud *)
get_on_off:
begin
expected := [onsym, offsym];
status := getsym(adj);
if status = ateol then
status := parm_expected
else if (status <> unrec) and (status <> ambiguous) then
state := fin
end; (* get_on_off *)
get_char:
if nextch(newescchar) then
state := fin
else
status := ch_expected;
get_show_parm:
begin
expected := [allsym, paritysym, localsym, ibmsym, escsym,
debugsym, filewarnsym, baudsym];
status := getsym(noun);
if status = ateol then
status := parm_expected
else if (status <> unrec) and (status <> ambiguous) then
state := fin
end; (* case get_show_parm *)
get_help_show:
begin
expected := [paritysym, localsym, ibmsym, escsym,
debugsym, filewarnsym, baudsym, emulatesym];
status := getsym(adj);
if (status = at_eol) then
begin
status := null;
state := fin
end
else if (status <> unrec) and (status <> ambiguous) then
state := fin
end; (* case get_help_show *)
get_help_parm:
begin
expected := [consym, exitsym, helpsym, quitsym, recsym,
sendsym, setsym, showsym];
status := getsym(noun);
if status = ateol then
begin
parse := null;
exit(parse)
end;
if (status <> unrec) and (status <> ambiguous) then
case noun of
consym: state := fin;
sendsym: state := fin;
recsym: state := fin;
setsym: state := get_help_show;
showsym: state := fin;
helpsym: state := fin;
exitsym, quitsym: state := fin;
end (* case *)
end; (* case get_help_show *)
end (* case *)
until (status <> null);
parse := status
end; (* parse *)
procedure initvocab;
var i: integer;
begin
vocablist[allsym] := 'ALL';
vocablist[baudsym] := 'BAUD';
vocablist[consym] := 'CONNECT';
vocablist[debugsym] := 'DEBUG';
vocablist[emulatesym] := 'EMULATE';
vocablist[escsym] := 'ESCAPE';
vocablist[evensym] := 'EVEN';
vocablist[exitsym] := 'EXIT';
vocablist[filewarnsym] := 'FILE-WARNING';
vocablist[helpsym] := 'HELP';
vocablist[ibmsym] := 'IBM';
vocablist[localsym] := 'LOCAL-ECHO';
vocablist[marksym] := 'MARK';
vocablist[nonesym] := 'NONE';
vocablist[oddsym] := 'ODD';
vocablist[offsym] := 'OFF';
vocablist[onsym] := 'ON';
vocablist[paritysym] := 'PARITY';
vocablist[quitsym] := 'QUIT';
vocablist[recsym] := 'RECEIVE';
vocablist[sendsym] := 'SEND';
vocablist[setsym] := 'SET';
vocablist[showsym] := 'SHOW';
vocablist[spacesym] := 'SPACE';
end; (* initvocab *)
end. (* end of unit *)
>>>> RECEIVER.TEXT
unit receiver;
interface
procedure recsw(var rec_ok: boolean);
implementation
uses
{$U kermglob.code} kermglob,
{$U kermutil.code} kermutil,
{$U kermpack.code} kermpack;
procedure recsw{(var rec_ok: boolean)};
function rdata: char;
(* send file data *)
var num, len: integer;
ch: char;
i: integer;
begin
repeat
if numtry > maxtry then
begin
currstate := 'a';
exit(rdata)
end;
num_try := num_try + 1;
ch := rpack(len,num,recpkt); (* receive a packet *)
refresh_screen(numtry,n);
if (ch = 'D') then (* got data packet *)
begin
if (num <> (n mod 64)) then (* wrong packet *)
begin
if (oldtry > maxtry) then
begin
rdata := 'a'; (* too many tries, abort *)
exit(rdata)
end; (* if *)
n := n - 1;
if (num = (n mod 64)) then (* previous packet again *)
begin (* so re-ACK it *)
spack('Y',num,6,packet);
numtry := 0; (* reset try counter *)
(* stay in same state *)
end (* if *)
else (* wrong number *)
currstate := 'a' (* so abort *)
end (* if *)
else (* right packet *)
begin
bufemp(recpkt,f,len); (* write data to file *)
spack('Y',(n mod 64),0,packet); (* ACK packet *)
oldtry := numtry; (* reset try counters *)
numtry := 0;
n := n + 1 (* bump packet number *)
(* stay in data send state *)
end (* else *)
end (* if 'D' *)
else if (ch = 'F') then (* file header *)
begin
if (oldtry > maxtry) then
begin
rdata := 'a'; (* too many tries, abort *)
exit(rdata)
end; (* if *)
n := n - 1;
if (num = (n mod 64)) then (* previous packet again *)
begin (* so re-ACK it *)
spack('Y',num,0,packet);
numtry := 0; (* reset try counter *)
currstate := currstate; (* stay in same state *)
end (* if *)
else
currstate := 'a' (* not previous packet, abort *)
end (* if 'F' *)
else if (ch = 'Z') then (* end of file *)
begin
if (num <> (n mod 64)) then(* wrong packet, abort *)
begin
rdata := 'a';
exit(rdata)
end; (* if *)
spack('Y',n mod 64,0,packet); (* ok, ACK it *)
close(f,lock); (* close up the file *)
n := n + 1; (* bump packet counter *)
currstate := 'f'; (* go to complete state *)
end (* else if 'Z' *)
else if (ch = 'E') then (* error packet *)
begin
error(recpkt,len); (* display error *)
currstate := 'a' (* and abort *)
end (* if 'E' *)
else if (ch <> chr(0)) then (* some other packet type, *)
currstate := 'a' (* abort *)
until (currstate <> 'd');
rdata := currstate
end; (* rdata *)
function rfile: char;
(* receive file header *)
var num, len: integer;
ch: char;
oldfn: string255;
i: integer;
procedure makename(recpkt: packettype; var fn: string255; l: integer);
function exist(fn: string255): boolean;
(* returns true if file named fn exists *)
var f: file;
isthere: boolean;
begin
(*$I-*) (* turn off i/o checking *)
reset(f,fn);
isthere := (ioresult = 0);
if isthere then { added by SP }
close( f );
(*$I+*)
exist := isthere
end; (* exist *)
procedure checkname(var fn: string255);
(* if file fn exists, makes a new name which doesn't *)
(* does this by changing letters in file name until it *)
(* finds some combination which doesn't exitst *)
var ch: char;
i: integer;
begin
i := 1;
while (i <= length(fn)) and exist(fn) do
begin
ch := 'A';
while (ch in ['A'..'Z']) and exist(fn) do
begin
fn[i] := ch;
ch := succ(ch);
end; (* while *)
i := i + 1
end; (* while *)
end; (* checkname *)
begin (* makename *)
fn := copy(' ',1,15); (* stretch length *)
moveleft(recpkt[0],fn[1],l); (* get filename from packet *)
oldfn := copy(fn, 1,l); (* save fn sent to show user *)
fn := copy(fn,1,min(15,l)); (* set length of filename *)
(* and make sure <= 15 *)
uppercase(fn);
if pos('.TEXT',fn) <> length(fn)-4 then
begin
if length(fn) > 10 then
fn := copy(fn,1,10); (* can only be 15 long in all *)
fn := concat(fn,'.TEXT'); (* and we'll add .TEXT *)
end; (* if *)
if fwarn then (* if file warning is on *)
checkname(fn); (* must check that name unique *)
end; (* makename *)
begin (* rfile *)
if debug then
debugwrite('rfile');
if (numtry > maxtry) then (* if too many tries, give up *)
begin
rfile := 'a';
exit(rfile)
end;
numtry := numtry + 1;
ch := rpack(len,num,recpkt); (* receive a packet *)
refresh_screen(numtry,n);
if ch = 'S' then (* send init, maybe our ACK lost *)
begin
if (oldtry > maxtry) then (* too many tries, abort *)
begin
rfile := 'a';
exit(rfile)
end; (* if *)
n := n - 1;
if num = (n mod 64) then (* previous packet mod 64? *)
begin (* yes, ACK it again *)
spar(packet); (* with our send init params *)
spack('Y',num,6,packet);
numtry := 0; (* reset try counter *)
rfile := currstate; (* stay in same state *)
end (* if *)
else (* not previous packet, abort *)
currstate := 'a'
end (* if 'S' *)
else if (ch = 'Z') then (* end of file *)
begin
if (oldtry > maxtry) then (* too many tries, abort *)
begin
rfile := 'a';
exit(rfile)
end; (* if *)
n := n - 1;
if num = (n mod 64) then (* previous packet mod 64? *)
begin (* yes, ACK it again *)
spack('Y',num,0,packet);
numtry := 0;
rfile := currstate (* stay in same state *)
end (* if *)
else
rfile := 'a' (* no, abort *)
end (* else if *)
else if (ch = 'F') then (* file header *)
begin (* which is what we really want *)
if (num <> (n mod 64)) then (* if wrong packet, abort *)
begin
rfile := 'a';
exit(rfile)
end;
makename(recpkt,xfilename,len); (* get filename, make unique if filew *)
gotoxy(filepos,fileline);
write(oldfn,' ==> ',xfilename);
if not getfil(xfilename) then (* try to open new file *)
begin
ioerror(ioresult); (* if unsuccessful, tell them *)
rfile := 'a'; (* and abort *)
exit(rfile)
end; (* if *)
spack('Y',n mod 64,0,packet); (* ACK file header *)
oldtry := numtry; (* reset try counters *)
numtry := 0;
n := n + 1; (* bump packet number *)
rfile := 'd'; (* switch to data state *)
end (* else if *)
else if ch = 'B' then (* break transmission *)
begin
if (num <> (n mod 64)) then (* wrong packet, abort *)
begin
rfile := 'a';
exit(rfile)
end;
spack('Y',n mod 64,0,packet); (* say ok *)
rfile := 'c' (* go to complete state *)
end (* else if *)
else if (ch = 'E') then
begin
error(recpkt,len);
rfile := 'a'
end
else if (ch = chr(0)) then (* returned false *)
rfile := currstate (* so stay in same state *)
else (* some weird state, so abort *)
rfile := 'a'
end; (* rfile *)
function rinit: char;
(* receive initialization *)
var num, len: integer; (* packet number and length *)
ch: char;
begin
if debug then
debugwrite('rinit');
numtry := numtry + 1;
ch := rpack(len,num,recpkt); (* receive a packet *)
refresh_screen(num_try,n);
if (ch = 'S') then (* send init packet *)
begin
rpar(recpkt); (* get other side's init data *)
spar(packet); (* fill packet with my init data *)
ctl_set := [chr(1)..chr(31),chr(del),quote];
spack('Y',n mod 64,6,packet); (* ACK with my params *)
oldtry := numtry; (* save old try count *)
numtry := 0; (* start a new counter *)
n := n + 1; (* bump packet number *)
rinit := 'f'; (* enter file send state *)
end (* if 'S' *)
else if (ch = 'E') then
begin
rinit := 'a';
error(recpkt,len)
end (* if 'E' *)
else if (ch = chr(0)) then
rinit := 'r' (* stay in same state *)
else
rinit := 'a' (* abort *)
end; (* rinit *)
(* state table switcher for receiving packets *)
begin (* recswok *)
writescreen('Receiving');
currstate := 'r'; (* initial state is send *)
n := 0; (* set packet # *)
numtry := 0; (* no tries yet *)
while true do
if currstate in ['d', 'f', 'r', 'c', 'a'] then
case currstate of
'd': currstate := rdata;
'f': currstate := rfile;
'r': currstate := rinit;
'c': begin
rec_ok := true;
exit(recsw)
end; (* case c *)
'a': begin
rec_ok := false;
exit(recsw)
end (* case a *)
end (* case *)
else (* state not in legal states *)
begin
rec_ok := false;
exit(recsw)
end (* else *)
end; (* recsw *)
end. { receiver }
>>>> SENDER.TEXT
unit sender;
interface
procedure sendsw(var send_ok: boolean);
implementation
uses
{$U kermglob.code} kermglob,
{$U kermutil.code} kermutil,
{$U kermpack.code} kermpack;
procedure sendsw{(var send_ok: boolean)};
var io_status: integer;
procedure openfile;
(* resets file & gets past first 2 blocks *)
begin
(*$I-*) (* turn off compiler i/o checking temporarily *)
reset(oldf,xfilename);
(*$I+*) (* turn compiler i/o checking back on *)
io_status := io_result;
if (iostatus = 0) then
if (pos('.TEXT',xfilename) = length(xfilename) - 4) then
begin (* is a text file, so *)
i := blockread(oldf,filebuf,1); (* skip past 2 block header *)
i := blockread(oldf,filebuf,1);
end; (* if *)
end; (* openfile *)
function sinit: char;
(* send init packet & receive other side's *)
var num, len, i: integer; (* packet number and length *)
ch: char;
begin
if debug then
debugwrite('sinit');
if numtry > maxtry then
begin
sinit := 'a';
exit(sinit)
end;
num_try := num_try + 1;
spar(packet);
clear_buf(inport);
refresh_screen(numtry,n);
spack('S',n mod 64,6,packet);
ch := rpack(len,num,recpkt);
if (ch = 'N') then
begin
sinit := 's';
exit(sinit)
end (* if 'N' *)
else if (ch = 'Y') then
begin
if ((n mod 64) <> num) then (* not the right ack *)
begin
sinit := currstate;
exit(sinit)
end;
rpar(recpkt);
if (xeol = chr(0)) then (* if they didn't spec eol *)
xeol := chr(my_eol); (* use mine *)
if (quote = chr(0)) then (* if they didn't spec quote *)
quote := my_quote; (* use mine *)
ctl_set := [chr(1)..chr(31),chr(del),quote];
numtry := 0;
n := n + 1; (* increase packet number *)
sinit := 'f';
exit(sinit)
end (* else if 'Y' *)
else if (ch = 'E') then
begin
error(recpkt,len);
sinit := 'a'
end (* if 'E' *)
else if (ch = chr(0)) then
sinit := currstate
else if (ch <> 'N') then
sinit := 'a'
end; (* sinit *)
function sdata: char;
(* send file data *)
var num, len: integer;
ch: char;
packarray: array[false..true] of packettype;
sizearray: array[false..true] of integer;
current: boolean;
b: boolean;
function other(b: boolean): boolean;
(* complements a boolean which is used as array index *)
begin
if b then
other := false
else
other := true
end; (* other *)
begin
current := true;
packarray[current] := packet;
sizearray[current] := size;
while (currstate = 'd') do
begin
if (numtry > maxtry) then (* if too many tries, give up *)
currstate := 'a';
b := other(current);
numtry := numtry + 1;
(* send a data packet *)
spack('D',n mod 64,sizearray[current],packarray[current]);
refresh_screen(numtry,n);
(* set up next packet *)
sizearray[b] := bufill(packarray[b]);
ch := rpack(len,num,recpkt); (* receive a packet *)
if ch = 'N' then (* NAK, so just stay in this state *)
if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
sdata := currstate
else (* is just like ACK for this packet *)
begin
if num > 0 then
num := (num - 1) (* in which case, decrement num *)
else
num := 63;
ch := 'Y'; (* and indicate an ACK *)
end; (* else *)
if (ch = 'Y') then
begin
if ((n mod 64) <> num) then (* if wrong ACK *)
begin
sdata := currstate; (* stay in same state *)
exit(sdata); (* get out of here *)
end; (* if *)
numtry := 0;
n := n + 1;
current := b;
if sizearray[current] = ateof then
currstate := 'z' (* set state to eof *)
else
currstate := 'd' (* else stay in data state *)
end (* if *)
else if (ch = 'E') then
begin
error(recpkt,len);
currstate := 'a'
end (* if 'E' *)
else if (ch = chr(0)) then (* receive failure, so stay in d *)
begin
end
else if (ch <> 'N') then
currstate := 'a' (* on anything else goto abort state *)
end; (* while *)
size := sizearray[current];
packet := packarray[current];
sdata := currstate
end; (* sdata *)
function sfile: char;
(* send file header *)
var num, len, i: integer;
ch: char;
fn: packettype;
oldfn: string255;
procedure legalize(var fn: string255);
(* make sure we send only 1 '.' in filename *)
var count, i, j, l: integer;
begin
count := 0;
l := length(fn);
for i := 1 to l do (* count '.'s in fn *)
if fn[i] = '.' then
count := count + 1;
for i := 1 to count-1 do (* remove all but 1 *)
begin
j := 1;
while (j < l) and (fn[j] <> '.') do
j := j + 1; (* by finding it *)
fn := concat(copy(fn,1,j-1),copy(fn,j+1,l-j)); (* and copying around it *)
l := l - 1
end (* for i *)
end; (* legalize *)
begin
if debug then
debugwrite('sfile');
if (numtry > maxtry) then (* if too many tries, give up *)
begin
sfile := 'a';
exit(sfile)
end;
numtry := numtry + 1;
oldfn := xfilename;
legalize(xfilename); (* make filename acceptable to remote *)
len := length(xfilename);
moveleft(xfilename[1],fn[0],len); (* move filename into a packettype *)
gotoxy(filepos,fileline);
write(oldfn,' ==> ',xfilename);
refresh_screen(numtry,n);
spack('F',n mod 64,len,fn); (* send file header packet *)
size := bufill(packet); (* get first data from file *)
(* while waiting for response *)
ch := rpack(len,num,recpkt);
if ch = 'N' then (* NAK, so just stay in this state *)
if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
exit(sfile) (* is just like ACK for this packet *)
else
begin
if (num > 0) then
num := (num - 1) (* in which case, decrement num *)
else
num := 63;
ch := 'Y'; (* and indicate an ACK *)
end; (* else *)
if (ch = 'Y') then
begin
if ((n mod 64) <> num) then (* if wrong ACK, stay in F state *)
exit(sfile);
numtry := 0;
n := n + 1;
sfile := 'd';
end (* if *)
else if (ch = 'E') then
begin
error(recpkt,len);
sfile := 'a'
end (* if 'E' *)
else if (ch <> chr(0)) and (ch <> 'N') then (* don't recognize it *)
sfile := 'a'
end; (* sfile *)
function seof: char;
(* send end of file *)
var num, len: integer;
ch: char;
begin
if debug then
debugwrite('seof');
if (numtry > maxtry) then (* if too many tries, give up *)
begin
seof := 'a';
exit(seof)
end;
numtry := numtry + 1;
refresh_screen(numtry,n);
spack('Z',(n mod 64),0,packet); (* send end of file packet *)
if debug then
debugwrite('seof1');
ch := rpack(len,num,recpkt);
if ch = 'N' then (* NAK, so just stay in this state *)
if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
exit(seof) (* is just like ACK for this packet *)
else
begin
if num > 0 then
num := (num - 1) (* in which case, decrement num *)
else
num := 63;
ch := 'Y'; (* and indicate an ACK *)
end; (* else *)
if (ch = 'Y') then
begin
if debug then
debugwrite('seof2');
if ((n mod 64) <> num) then (* if wrong ACK, stay in F state *)
exit(seof);
numtry := 0;
n := n + 1;
if debug then
debugwrite(concat('closing ',s));
close(oldf);
seof := 'b'
end (* if *)
else if (ch = 'E') then
begin
error(recpkt,len);
seof := 'a'
end (* if 'E' *)
else if (ch = chr(0)) then (* receive failed, so stay in z state *)
begin
end
else if (ch <> 'N') then (* other error, just abort *)
seof := 'a'
end; (* seof *)
function sbreak: char;
var num, len: integer;
ch: char;
(* send break (end of transmission) *)
begin
if debug then
debugwrite('sbreak');
if (numtry > maxtry) then (* if too many tries, give up *)
begin
sbreak := 'a';
exit(sbreak)
end;
numtry := numtry + 1;
refresh_screen(numtry,n);
spack('B',(n mod 64),0,packet); (* send end of file packet *)
ch := rpack(len,num,recpkt);
if ch = 'N' then (* NAK, so just stay in this state *)
if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
exit(sbreak) (* is just like ACK for this packet *)
else
begin
if num > 0 then
num := (num - 1) (* in which case, decrement num *)
else
num := 63;
ch := 'Y'; (* and indicate an ACK *)
end; (* else *)
if (ch = 'Y') then
begin
if ((n mod 64) <> num) then (* if wrong ACK, stay in B state *)
exit(sbreak);
numtry := 0;
n := n + 1;
sbreak := 'c' (* else, switch state to complete *)
end (* if *)
else if (ch = 'E') then
begin
error(recpkt,len);
sbreak := 'a'
end (* if 'E' *)
else if (ch = chr(0)) then (* receive failed, so stay in z state *)
begin
end
else if (ch <> 'N') then (* other error, just abort *)
sbreak := 'a'
end; (* sbreak *)
(* state table switcher for sending *)
begin (* sendsw *)
if debug then
debugwrite(concat('Opening ',xfilename));
openfile;
if io_status <> 0 then
begin
io_error(io_status);
send_ok := false;
exit(sendsw)
end;
write_screen('Sending');
currstate := 's';
n := 0; (* set packet # *)
numtry := 0;
while true do
if currstate in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then
case currstate of
'd': currstate := sdata;
'f': currstate := sfile;
'z': currstate := seof;
's': currstate := sinit;
'b': currstate := sbreak;
'c': begin
send_ok := true;
exit(sendsw)
end; (* case c *)
'a': begin
send_ok := false;
exit(sendsw)
end (* case a *)
end (* case *)
else (* state not in legal states *)
begin
send_ok := false;
exit(sendsw)
end (* else *)
end; (* sendsw *)
end. { sender }
>>>> SETSHOW.TEXT
procedure write_bool(s: string255; b: boolean);
(* writes message & 'on' if b, 'off' if not b *)
begin
write(s);
case b of
true: writeln('on');
false: writeln('off');
end; (* case *)
end; (* write_bool *)
procedure show_parms;
(* shows the various settable parameters *)
begin
case noun of
allsym: begin
write_bool('Debugging is ',debug);
writeln('Escape character is ^',ctl(esc_char));
write_bool('File warning is ',fwarn);
write_bool('IBM is ',ibm);
write_bool('Local echo is ',halfduplex);
write_bool('Emulate DataMedia is ', emulating );
case parity of
evenpar: write('Even');
markpar: write('Mark');
nopar: write('No');
oddpar: write('Odd');
spacepar: write('Space');
end; (* case *)
writeln(' parity');
writeln( 'Baud rate is ', baud:5 );
end; (* allsym *)
debugsym: write_bool('Debugging is ',debug);
escsym: writeln('Escape character is ^',ctl(esc_char));
filewarnsym: write_bool('File warning is ',fwarn);
ibmsym: write_bool('IBM is ',ibm);
localsym: write_bool('Local echo is ',halfduplex);
emulatesym: write_bool('Emulate DataMedia is ', emulating );
baudsym: writeln( 'Baud rate is ', baud:5 );
paritysym: begin
case parity of
evenpar: write('Even');
markpar: write('Mark');
nopar: write('No');
oddpar: write('Odd');
spacepar: write('Space');
end; (* case *)
writeln(' parity');
end; (* paritysym *)
end; (* case *)
end; (* show_sym *)
procedure set_parms;
(* sets the parameters *)
begin
case noun of
debugsym: case adj of
onsym: begin
debug := true;
(*$I-*)
rewrite(debf,'CONSOLE:')
(*I+*)
end; (* onsym *)
offsym: debug := false
end; (* case adj *)
escsym: escchar := newescchar;
filewarnsym: fwarn := (adj = onsym);
ibmsym: case adj of
onsym: begin
ibm := true;
parity := markpar;
half_duplex := true;
fillparityarray
end; (* onsym *)
offsym: begin
ibm := false;
parity := nopar;
half_duplex := false;
fillparityarray
end; (* onsym *)
end; (* case adj *)
localsym: halfduplex := (adj = onsym);
emulatesym: emulating := (adj = onsym);
paritysym: begin
case adj of
evensym: parity := evenpar;
marksym: parity := markpar;
nonesym: parity := nopar;
oddsym: parity := oddpar;
spacesym: parity := spacepar;
end; (* case *)
fill_parity_array;
end; (* paritysym *)
baudsym: begin
if newbaud=110 then
baud := 110
else if newbaud=300 then
baud := 300
else if newbaud=1200 then
baud := 1200
else if newbaud=2400 then
baud := 2400
else if newbaud=4800 then
baud := 4800
else if newbaud=9600 then
baud := 9600;
setup_comm
end { baudsym }
end; (* case *)
end; (* set_parms *)