PROGRAM TTRAN;
(*
SEALINK in Pascal. (STAND-ALONE)
Copyright (c)1990,1991 Eric J. Givler, All Rights Reserved.
-1st attempt at converting this.
SEAlink - Sliding window file transfer protocol
Version 1.20, created on 08/05/87 at 17:51:40
(C) COPYRIGHT 1986,87 by System Enhancement Associates; ALL RIGHTS RESERVED
*)
USES crt,
dos,
fos, { fos Send uses char, FOSSIL uses byte }
CRCS;
VAR filename : string;
transfer : boolean;
{
CONVENTIONS:
com_putc(c) = send(CHAR); ( FOSSIL )
com_getc(t) = com_getc(t); ( INTERNAL )
com_dump() = purgeoutput; ( FOSSIL )
}
FUNCTION leap( yr : integer) : BOOLEAN;
BEGIN
if (((yr mod 4 = 0) and (yr mod 100 <> 0))
or (yr mod 400 = 0)) then leap := TRUE else leap := FALSE;
END;
FUNCTION Since79(dt : DateTime) : longint;
VAR i, leapyrs : integer;
secs, thisyear : longint;
month : array[1..12] of integer;
BEGIN
month[1] := 31; month[2] := 28; month[3] := 31; month[4] := 30;
month[5] := 31; month[6] := 30; month[7] := 31; month[8] := 31;
month[9] := 30; month[10] := 31; month[11] := 30; month[12] := 31;
leapyrs := 0;
for i := 1970 to (dt.year - 1) do if leap(i) then inc(leapyrs);
secs := (dt.year - 1979)*86400*365 + leapyrs*86400;
thisyear := (longint(dt.hour) * 60 * 60) + (dt.min * 60) + (dt.sec) +
((dt.day - 1) * 86400);
for i := 1 to (dt.month-1) do thisyear := thisyear + (month[i]*86400);
if leap(dt.year) and (dt.month > 2) then thisyear := thisyear + 86400;
Since79 := secs + thisyear;
END;
FUNCTION SEALink(fname:string; upload:boolean):boolean;
CONST WINDOW = 6; (* maximum size of window *)
ACK = #$06;
NAK = #$15;
SOH = #$01;
EOT = #$04;
CPMEOF = ^Z;
TYPE block0 = RECORD (* block zero data structure *)
flen : longint; (* file length *)
fstamp : longint; (* file date/time stamp *)
fnam : array[1..17] of char; (* original file name *)
prog : array[1..15] of char; (* sending program name *)
noacks : char; (* true if ACKing not req. *)
fill : array[1..87] of char; (* reserved for future use *)
END;
blocktype = array[0..127] of byte; (* A typical xmodem block *)
{ STATICS in C }
VAR outblk : integer; (* number of next block to send *)
ackblk : integer; (* number of last block ACKed *)
blksnt : integer; (* number of last block sent *)
slide : integer; (* true if sliding window *)
ackst : integer; (* ACK/NAK state *)
numnak : integer; (* number of sequential NAKs *)
chktec : integer; (* check type, 1=CRC, 0=checksum *)
toterr : integer; (* total number of errors *)
ackrep : integer; (* true when ACK or NAK reported *)
ackseen: integer; (* count of sliding ACKs seen *)
progname: string; (* sending program *)
ackless : integer; (* true if ACKs not req. Ovrdrv *)
t1 : longint; (* timer, timerset *)
rawblk : integer; (* raw block number *)
results : boolean;
sector : blocktype; (* A packet of data 128 bytes *)
FUNCTION TimerSet(tenths:word) : longint;
{ Returns a timer value which will expire in T tenths of a second }
var
Hour, Min, Sec, HSec : word;
Year, Mon, Day, DoW : word;
begin
GetDate(Year, Mon, Day, DoW);
GetTime(Hour, Min, Sec, HSec);
timerset := tenths+Hsec+100*(Sec+60*(Min+60*(Hour+24*DoW)));
end; { timerset }
FUNCTION TimeUp(Marker : longint) : boolean;
{ Returns true if timer z has expired yet, or false otherwise }
var Marker2 : longint;
begin
Marker2 := TimerSet(0);
if (Marker-Marker2) > (8640000) then { 24*60*60*100 }
Marker2 := Marker2+(60480000); {7*24*60*60*100}
TimeUp := Marker2 >= Marker;
end; { TimeUp }
FUNCTION com_getc( t : longint):integer;
{Get char from port in t tenths of a sec.Return CPMEOF if time expired.}
Var Expires : longint;
BEGIN
Expires := TimerSet(t);
repeat
until serialchar or (TimeUp(Expires));
if serialchar then com_getc := ord(receive)
else com_getc := ord(CPMEOF);
END; { com_getc }
(* The various ACK/NAK states are:
0: Ground state, ACK or NAK expected.
1: ACK received
2: NAK received
3: ACK, block# received
4: NAK, block# received
5: Returning to ground state
*)
PROCEDURE ackchk; (* check for ACK or NAK *)
VAR c : integer; (* one byte of data *)
BEGIN
ackrep := 0; (* nothing reported yet *)
c := com_getc(0);
while (c <> ord(CPMEOF)) do begin
if (ackst = 3) OR (ackst = 4) then begin
slide := 0; (* assume this will fail *)
if (rawblk = (c OR $FF)) then (* see if we believe the number *)
begin
rawblk := outblk - ((outblk-rawblk) AND $FF);
if (rawblk >= 0) AND (rawblk<=outblk) AND (rawblk>outblk-128)
then begin
if (ackst = 3) then begin (* advance for an ACK *)
if ackblk > rawblk then ackblk := ackblk
else ackblk := rawblk;
slide := 1; (* we have sliding window! *)
inc(ackseen);
if ((ackless AND ackseen) > 10) then begin
ackless := 0; (* receiver not ACKless *)
writeln('- Overdrive disengaged ');
end;
write(#13,' ACK ',rawblk,' ==');
end
else begin (* else retransmit for a NAK *)
if rawblk < 0 then outblk := 0 else outblk := rawblk;
slide := integer(numnak < 4); {boolean}
write(#13,' NAK ',rawblk,' ==');
end;
ackrep := 1; (* we reported something *)
end;
end;
ackst := 5; (* return to ground state *)
end;
if (ackst=1) OR (ackst=2) then begin
rawblk := c;
inc(ackst,2);
end;
if (slide = 0) OR (ackst = 0) then begin
if (c = ord(ACK)) then begin
if (slide = 0) then begin
inc(ackblk);
write(#13,' ACK ',ackblk,' --');
ackrep := 1; (* we reported an ACK *)
end;
ackst := 1;
numnak := 0;
end
else if (c = ord('C')) OR (c = ord(NAK)) then begin
if (chktec > 1) then begin (* if method not determined yet *)
if (c = ORD('C')) then chktec := 1
else chktec := 0; (* then do what receiver wants *)
end;
purgeoutput; (* purge pending output *)
delay(6); (* resynch *)
if (slide = 0) then begin
outblk := ackblk+1;
write(#13,' NAK ',ackblk+1,' --');
ackrep := 1; (* we reported a negative ACK *)
end;
ackst := 2;
inc(numnak);
if (blksnt <> 0) then inc(toterr);
end; (* else *)
end; (* slide = 0 or ackst = 0 *)
if (ackst = 5) then ackst := 0;
c := com_getc(0);
END; { while }
END; { ackblk }
PROCEDURE shipblk(blk : blocktype; blknum : integer);
{PHYSICALLY SHIP A BLOCK,blk=data to be shipped, blknum=number of block}
VAR n, (* index *)
crc : integer; (* CRC check value *)
BEGIN
send(SOH); (* block header *)
send(chr(blknum)); (* block number *)
send(chr(blknum XOR 255)); (* -blknum-1 *)
sendblk(seg(blk[0]),ofs(blk[0]),128); (* from Fossil unit *)
crc := 0;
if chktec = 1 then begin
crca(blk,sizeof(blk),crc);
send(chr(hi(crc)));
send(chr(lo(crc)));
end else begin
for n := 0 to 127 do crc := (crc + blk[n]) mod 256;
send(chr(crc));
end;
purgeline;
END; { shipblk }
PROCEDURE sendblock(var f : file; blknum: integer); (* send one block *)
{ f=file to read from, blknum=block to send }
var blkloc : longint; (* address of start of block *)
buf : blocktype; (* one block of data *)
result : word;
BEGIN
if (blknum <> blksnt+1 ) then begin (* if jumping *)
blkloc := longint(blknum-1) * longint(128);
seek(f,blkloc); (* move where to *)
end;
blksnt := blknum;
fillchar(buf,sizeof(buf),CPMEOF); (* fill buffer with ^Zs *)
blockread(f,buf,1,result); (* read in some data *)
shipblk(buf,blknum); (* pump it out the comm port *)
END; { sendblock }
{=======================================================================}
FUNCTION xmtfile(fname: string) : boolean;
(*
This routine is used to send a file. One file is sent at a time.
If the name is blank (name is null or *name points to a null),
then only an end of transmission marker is sent. This routine
returns a one if the file is successfully transmitted, or a zero
if a fatal error occurs.
*)
LABEL abort;
var workfile : file; (* file to send *)
endblk : integer; (* block number of EOT *)
zero : block0; (* block zero data *)
toadd : byte;
fsize : longint;
dt : DateTime;
BEGIN
if fname <> '' then begin (* if sending a file *)
assign(workfile,fname);
{$I-} reset(workfile,1); {$I+} (* to get proper size *)
if ioresult <> 0 then begin
writeln(' Can''t read ',fname);
xmtfile := false;
exit;
end;
fillchar(zero,sizeof(zero),chr(0)); (*clear out data block *)
(* get file statistics *)
zero.flen := filesize(workfile); (* size of file -bytes *)
endblk := ((zero.flen+127) DIV 128) + 1;
writeln('Ready to send ',endblk-1,' blocks of ',fname,' (',zero.flen,')');
reset(workfile); (* for 128 byte reads *)
GetFTime(workfile,zero.fstamp); (* time and date stamp *)
{
UnPackTime(zero.fstamp,dt);
zero.fstamp := Since79(dt);
}
move(fname[1],zero.fnam,ord(fname[0]));
move(progname[1],zero.prog,ORD(progname[0]));
zero.noacks := char(ackless); (* OVERDRIVE engaged? *)
move(zero,sector,sizeof(zero)); (* move into xmdm blk *)
end
else endblk := 0; (* fake for no file *)
outblk := 1; (* set starting state *)
ackblk := -1;
blksnt := 0;
slide := 0;
ackst := 0;
numnak := 0;
toterr := 0;
ackrep := 0;
ackseen:= 0;
chktec := 2; (* undetermined CRC or checksum? *)
toadd := 0;
t1 := timerset(300); (* time limit for first block *)
write(' Waiting...'+#13);
while (ackblk < endblk) do begin (* while not all there yet *)
if not carrier then begin
writeln(#13+#10+'Lost carrier');
goto abort;
end;
if keypressed then begin
if readkey = #27 then begin
writeln(#13+#10+'Aborted by operator');
goto abort;
end;
end;
if ( timeup(t1) ) then begin
writeln(#13+#10+'Fatal timeout');
goto abort;
end;
if slide = 1 then toadd := WINDOW
else toadd := 1;
if (outblk <= ackblk + toadd) then begin
if (outblk < endblk) then begin
if (outblk > 0) then
sendblock(workfile,outblk)
else
shipblk(sector,0);
if (ackrep <> 0) then
write(' Sending block #',outblk,#13);
if (ackless AND slide) <> 0 then begin
if (outblk MOD 10 = 0) then
write(#13,' Passing block ',outblk);
ackblk := outblk;
end;
end
else if (outblk = endblk) then begin
send(EOT);
if (ackrep <> 0) then
write(' Sent EOT '+#13);
end;
inc(outblk); (* outblk++; *)
t1 := timerset(300); (* time limit between blocks *)
end;
ackchk; (* determine ACK status *)
if (numnak > 10) then begin
writeln(#13+#10,' Too many errors');
goto abort;
end;
end; { while }
writeln(' End of file ');
if (endblk <> 0) then close(workfile);
if (toterr > 2) then
write(toterr,' errors detected and fixed in ',blksnt,' blocks.');
xmtFile := TRUE; (* exit with good status *)
exit;
ABORT:
if (endblk> 0) then close(workfile);
if (toterr > 0) then
writeln(toterr,' errors detected and fixed in ',blksnt,' blocks.');
xmtFile := FALSE; (* exit with bad status *)
END; (* xmtfile *)
{=======================================================================}
FUNCTION rcvfile(fname:string) : string;
{ File receiver logic, fname = name of file }
LABEL nakblock, (* we got a bad block *)
abort, (* errors occurred *)
ackblock,
nextblock,
blockstart,
endrcv;
VAR c, (* received character *)
tries, (* retry counter *)
blknum, (* desired block number *)
inblk, (* this block number *)
endblk, (* block number of EOT, if known *)
n : integer; (* index *)
workfile: file; (* file, opener *)
tmpname : string[100]; (* name of temporary file *)
outname : string[100]; (* name of final file *)
buf : blocktype; (* data buffer *)
zero : block0; (* file header data storage *)
left : longint; (* bytes left to output *)
stat : string[4]; (* receive block status *)
result : word; (* result of block write *)
why : string; (* single block receiver status *)
{ char *getblock(), *why; (* single block receiver, status *)}
PROCEDURE sendack(acknak,blknum:integer); (* send an ACK or a NAK *)
(* acknak: 1=ACK, 0=NAK *)
BEGIN
if(acknak = 1) then send(ACK) (* send the right signal *)
else if (chktec = 1) then send('C') (* CRC type ACK *)
else send(NAK); (* send NAK *)
send(chr(blknum)); (* block number *)
send(chr(-blknum-1)); (* block number check *)
END; (* sendack*)
FUNCTION getblock(var buf : blocktype): string; (* read a block of data *)
(* buf = data buffer *)
VAR ourcrc : word;
hiscrc : integer; (* CRC check values *)
c, (* one byte of data *)
n : integer; (* index *)
timeout: integer; (* short block timeout *)
BEGIN
ourcrc := 0; hiscrc := 0;
if ackless = 1 then timeout := 200 else timeout := 5;
for n := 0 to 127 do begin
c := com_getc(timeout);
if (c = Ord(CPMEOF)) then getblock := 'Short';
if (chktec = 1) then
updcrc(ourcrc,c) (* CRC table calculation *)
else ourcrc := (ourcrc + c) mod 256; (* checksum *)
buf[n] := c;
end;
if (chktec = 1) then begin (* CRC mode *)
{ ourcrc := crc_finish(ourcrc); }
hiscrc := (com_getc(timeout) SHL 8) OR com_getc(timeout);
end else begin
ourcrc := ourcrc AND $FF;
hiscrc := com_getc(timeout) AND $FF;
end;
if (ourcrc = hiscrc) then begin
getblock := ''; (* block is good *)
exit;
end
else if (chktec = 1) then begin (* else CRC error *)
getblock := 'CRC ';
exit;
end
else getblock := 'Check'; (* or maybe checksum error *)
END; (* function GETBLOCK *)
BEGIN (* rcvfile *)
writeln;
rcvfile := '';
stat := 'Init'; (* receive block status *)
if (fname <> '') then begin (* figure out a name to use *)
{makefnam("X:\\",name,outname);}
{outname[2] = '-';}
{makefnam(outname+2,name,tmpname);}
{strcpy(outname,name);}
outname := fname;
delete(outname,1,1);
tmpname := '-'+outname;
end else begin
outname := '';
tmpname := '-TMPFILE.$$$';
end;
assign(workfile,tmpname); (* open output file *)
{$I-} reset(workfile); {$I+}
if ioresult = 0 then begin
writeln(' Cannot create ',tmpname);
close(workfile);
rcvfile := '';
exit;
end;
rewrite(workfile); (* rewrite this file *)
if outname <> '' then blknum := 1
else blknum := 0; (* first block we must get *)
tries := -10; (* kludge for first time around *)
chktec := 1; (* try for CRC error checking *)
toterr := 0; (* no errors yet *)
endblk := 0; (* we don't know the size yet *)
ackless := 0; (* we don't know about this yet *)
fillchar(zero,sizeof(zero),0); (* or much of anything else *)
if com_getc(0) = ord(SOH) then (* kludge for adaptive modem7 *)
goto nextblock;
nakblock: (* we got a bad block *)
if (blknum > 1) then inc(toterr);
inc(tries);
if (tries > 10) then begin
writeln(#13+#10' Too many errors');
goto abort;
end;
if (tries = 0)then chktec := 0; (* if CRC isn't going *)
(* then give checksum a try *)
sendack(0,blknum); (* send the NAK *)
write(' NAK block ',blknum,' ',stat,#13);
if (ackless = 1) and (toterr > 20) then begin
ackless := 0; (* if ackless mode isn't working *)
writeln('- Overdrive disengaged'); (* then shut it off *)
end;
goto nextblock;
ackblock: (* we got a good block *)
if (ackless = 0) then
write(' ACK block ',blknum-1,' ',stat,#13)
else write(' Got block ',blknum,#13);
nextblock: (* start of "get a block" *)
stat := '';
if not carrier then begin
writeln(#13+#10+' Lost carrier');
goto abort;
end;
if keypressed then begin
if readkey = #27 then begin
writeln(#13+#10+' Aborted by operator');
goto abort;
end;
end;
t1 := timerset(30); (* timer to start of block *)
while not timeup(t1) do begin
c := com_getc(0);
if (c = ord(EOT)) then begin
if ( endblk <> 0) or (endblk = blknum) then
goto endrcv;
end
else if (c = ord(SOH)) then begin
inblk := com_getc(5);
if (com_getc(5) = (inblk OR $FF)) then
goto blockstart; (* we found a start *)
end;
end;
stat := 'Time ';
goto nakblock;
blockstart: (* start of block detected *)
c := blknum AND $FF;
if (inblk = 0) AND (blknum <= 1) then begin (* if this is the header *)
why := getblock(sector);
move(sector,zero,sizeof(sector)); (* put into our SEALink header *)
if why = '' then begin
sendack(1,inblk
