home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ucsdpecan.tar.gz
/
ucsdpecan.tar
/
receiver.text
< prev
next >
Wrap
Text File
|
1990-08-05
|
20KB
|
581 lines
$D AFS-} {indicates for compile to run without Adv. File Sys.
unit receiver;
interface
{Change log:
18 May 89, V1.1: Added debugdate to reread file dates (fixed date bug[??]) RTC
13 May 89, V1.1: Misc. cleanup to debug messages RTC
30 Apr 89, V1.1: Fixed receiver won't stop on maxtry bug RTC
26 Apr 89, V1.1: minor cleanups RTC
16 Apr 89, V1.1: Fixed "garbage in buffer" bug RTC
16 Apr 89, V1.1: Fixed "short text filename" bug. RTC
15 Apr 89, V1.1: Added GET protocol & debug logging of date set result RTC
13 Apr 89, V1.1: Added version message RTC
17 Aug 88: Fixed garbage after partial last block of bin. file RTC
07 Aug 88: Added conditional compilation for AFS/SFS differences RTC
31 Jul 88: Added Attribute Packets & user discard requests to sender RTC
10 Jul 88: Converted to use screenops unit RTC
10 Jul 88: Fixed cleareol problem on filenames RTC
02 Jul 88: Added binary file transfer & discard protocol RTC
}
procedure recsw(var rec_ok: boolean; get_from_server : boolean);
procedure rec_version;
implementation
uses
screenops, {RTC, 10 Jul 88}
{$U kermglob.code} kermglob,
{$U kermutil.code} kermutil,
{$U kermpack.code} kermpack,
{$B AFS+}
{$U syslibr:attribute.code} attributes;
{$E AFS+} {$B AFS-}
{$U syslibr:wild.code} wild,
{$U syslibr:dir.info.code} dirinfo;
{$E AFS-}
const
my_version = ' Receiver Unit V1.1, 18 May 89';
$B AFS-
procedure debugdate;
var
heap : ^integer;
list : D_listp;
rslt : D_result;
begin {debugdate}
mark(heap);
rslt := D_dirlist(xfilename,[Dvol..Ddir],list,false);
if rslt <> D_okay then debugwrite('Can''t Access File Date');
if debug then with list^,D_date do
begin
debugwrite('');
write(debf,'File ',D_volume,':',D_title,' Current Date = ',
month,'/',day,'/',year)
end;
release(heap)
end {debugdate};
$E AFS-
procedure recsw{(var rec_ok: boolean; get_from_server : boolean)};
var
date_attr : record
valid : boolean;
value : {$B AFS+} FA_chron {$E AFS+}
{$B AFS-} D_daterec {$E AFS-}
end;
function bufattr(buffer : packettype; len : integer) : integer;
var
sp_pos,i,j,buffered : integer;
tempattr : string;
begin {bufattr}
packet[0] := 'Y'; buffered := 1; {agree to accept file}
i := 0; while i < len do
begin
if buffer[i] in ['#'] then {acceptable attribute}
begin
tempattr := '';
for j := 1 to ord(unchar(buffer[succ(i)])) do
begin
tempattr := concat(tempattr,' ');
tempattr[length(tempattr)] := buffer[succ(i) + j]
end;
case buffer[i] of
'#' : with date_attr,value {$B AFS+},date,time{$E AFS+} do
begin
sp_pos := pos(' ',tempattr);
if sp_pos = 0 then sp_pos := succ(length(tempattr));
year := (ord(tempattr[sp_pos-6]) - ord('0')) * 10
+ (ord(tempattr[sp_pos-5]) - ord('0'));
month := (ord(tempattr[sp_pos-4]) - ord('0')) * 10
+ (ord(tempattr[sp_pos-3]) - ord('0'));
day := (ord(tempattr[sp_pos-2]) - ord('0')) * 10
+ (ord(tempattr[sp_pos-1]) - ord('0'));
{$B AFS+}
if length(tempattr) > sp_pos then
begin
hour := (ord(tempattr[sp_pos+1]) - ord('0')) * 10
+ (ord(tempattr[sp_pos+2]) - ord('0'));
min := (ord(tempattr[sp_pos+4]) - ord('0')) * 10
+ (ord(tempattr[sp_pos+5]) - ord('0'))
end
else {no time provided}
begin
hour := 24 {non-valid time}; min := 0
end;
{$E AFS+}
valid := true
end
end {case}
end
else {reject attribute}
begin
packet[buffered] := buffer[i];
buffered := succ(buffered)
end;
i := succ(succ(i) + ord(unchar(buffer[succ(i)])))
end;
bufattr := buffered
end {bufattr};
function rdata: char;
(* receive file data *)
var dummy, num, len: integer;
ch: char;
{$B AFS+}
did_attr : boolean;
{$E AFS+}
i: integer;
begin
repeat
debugwrite('rdata');
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 *)
if (num = (pred(n) mod 64)) then (* previous packet again *)
begin (* so re-ACK it *)
spack('Y',num,0,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,len); (* write data to file *)
if read_ch(keyport, ch) then {check if user wants to can}
packet[0] := ctl(ch);
spack('Y',(n mod 64),ord(ord(ch) in [can_cur,can_all]),
packet); (* ACK packet *)
oldtry := numtry; (* reset try counters *)
numtry := 0;
n := n + 1 (* bump packet number *)
(* stay in data receive state *)
end (* else *)
end (* if 'D' *)
else if ch = 'A' then { Attributes }
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 *)
if (num = (pred(n) mod 64)) then (* previous packet again *)
begin (* so re-ACK it *)
spack('Y',num,0,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
spack('Y',(n mod 64),bufattr(recpkt,len),packet); (* ACK packet *)
oldtry := numtry; (* reset try counters *)
numtry := 0;
n := n + 1 (* bump packet number *)
(* stay in data receive state *)
end (* else *)
end {if 'A'}
else if (ch = 'F') then (* file header *)
begin
if (oldtry > maxtry) then
begin
rdata := 'a'; (* too many tries, abort *)
exit(rdata)
end; (* if *)
if (num = (pred(n) mod 64)) then (* previous packet again *)
begin (* so re-ACK it *)
spack('Y',num,0,packet);
numtry := 0; (* reset try counter *)
(* 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 *)
if (len = 1) and (recpkt[0] = 'D')
then
begin
debugwrite(concat('Discarding ',xfilename));
if f_is_binary {discard the file}
then close(b_file)
else close(t_file)
end
else
begin
debugwrite(concat('Closing ',xfilename));
if f_is_binary (* close up the file *)
then
begin
if bufpos > 1 {data in last block}
then
begin
for dummy := bufpos to blksize do
filebuf[dummy] := chr(0);
dummy := blockwrite(b_file,filebuf,1);
dummy := pred(bufpos);
{$B AFS+}
did_attr :=
put_attribute(b_file,FA_lastvalidbyte,dummy)
{$E AFS+}
end;
{$B AFS+}
with date_attr do if valid then {set date}
did_attr :=
put_attribute(b_file,FA_revisiondate,value);
{$E AFS+}
close(b_file,lock)
end
else
begin
{$B AFS+}
with date_attr do if valid then {set date}
did_attr :=
put_attribute(t_file,FA_creationdate,value);
{$E AFS+}
close(t_file,lock)
end;
{$B AFS-}
debugdate;
with date_attr do if valid then {set date}
case D_changedate(xfilename,value,
[D_code,D_text,D_data,D_svol]) of
D_okay : debugwrite('Date set OK');
D_notfound : debugwrite('No such File, Date not set');
D_nameerror : debugwrite('Name error, Date not set');
D_offline : debugwrite('Volume offline, Date not set');
D_other : debugwrite('Unknown error, Date not set');
end {case};
debugdate;
{$E AFS-}
end;
bufpos := 1; {clean up binary file buffer}
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;
begin
(*$I-*) (* turn off i/o checking *)
reset(f,fn);
exist := (ioresult = 0);
(*$I+*)
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 := succ(fn[i]); {RTC, 13 May 89}
if not (ch in ['A'..'Z']) then 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 not f_is_binary then
if (pos('.TEXT',fn) <> length(fn)-4) or (length(fn) < 5) 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 *)
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 *)
if num = (pred(n) mod 64) then (* previous packet mod 64? *)
begin (* yes, ACK it again *)
spar(packet); (* with our send init params *)
spack('Y',num,10,packet);
numtry := 0; (* reset try counter *)
rfile := currstate; (* stay in same state *)
end (* if *)
else (* not previous packet, abort *)
rfile := '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 *)
if num = (pred(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 *)
SC_erase_to_EOL(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 *)
{initializations for file attribute data}
date_attr.valid := false;
{end of initializations for file attribute data}
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;
fn : packettype;
begin
debugwrite('rinit');
if (numtry > maxtry) then (* if too many tries, give up *)
begin
rinit := 'a';
exit(rinit)
end;
numtry := numtry + 1;
if get_from_server then {ask server for files}
begin
len := length(xfilename);
moveleft(xfilename[1],fn[0],len);
spack('R', n mod 64, len, fn)
end;
ch := rpack(len,num,recpkt); (* receive a packet *)
refresh_screen(num_try,n);
if (ch = 'S') then (* send init packet *)
begin
rpar(recpkt,len); (* get other side's init data *)
spar(packet); (* fill packet with my init data *)
ctl_set := [chr(0)..chr(31),chr(del),quote];
if en_qbin then ctl_set := ctl_set + [qbin];
spack('Y',n mod 64,10,packet); (* ACK with my params *)
get_from_server := false;
oldtry := numtry; (* save old try count *)
numtry := 0; (* start a new counter *)
n := n + 1; (* bump packet number *)
rinit := 'f'; (* enter file receive state *)
end (* if 'S' *)
else if ch = 'Y' then
begin
rinit := 'r';
if n mod 64 = num then {we have the right ACK}
begin
get_from_server := false;
numtry := 0;
n := n + 1
end
end {if 'Y'}
else if (ch = 'E') then
begin
rinit := 'a';
error(recpkt,len)
end (* if 'E' *)
else if (ch = chr(0)) or (ch = 'N') then
rinit := 'r' (* stay in same state *)
else
rinit := 'a' (* abort *)
end; (* rinit *)
(* state table switcher for receiving packets *)
begin (* recswok *)
rec_ok := false;
writescreen('Receiving');
currstate := 'r'; (* initial state is receive *)
n := 0; (* set packet # *)
numtry := 0; (* no tries yet *)
flush_comm; {flush any garbage in buffer}
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': exit(recsw)
end (* case *)
else (* state not in legal states *)
begin
debugwrite('Unknown State');
exit(recsw)
end (* else *)
end; (* recsw *)
procedure rec_version;
begin
writeln(my_version)
end {rec_version};
end. { receiver }