Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PROT100.ZIP/SEALINK.PAS

Pascal/Delphi Source File | 1993-03-13 | 26.0 KB | 682 lines

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);               (* ack the header              *)
          if fname = '' then begin        (* given name takes precedence *)
             move(zero.fnam,outname[1],sizeof(zero.fnam));
             outname[0] := chr(17);
          end;
          if (left = zero.flen) then   (* length to transfer    *)
              endblk := (left+127) DIV 128 + 1;
          if (ackless <> integer(zero.noacks)) then (* note variant *)
          begin
             if integer(zero.noacks) = 1 then writeln('+ Overdrive engaged')
                else writeln('+ Overdrive disengaged');
          end;
          ackless := integer(zero.noacks);

          write('  Receiving');
          if (endblk <> 0) then write(' ',endblk-1,' blocks of');
          write(outname);
          move(zero.prog,progname[1],sizeof(zero.prog));
          progname[0] := chr(15);
          if (progname <> '') then write(' from ',progname);
          writeln;
          blknum := 1;              (* now we want first data block *)
          goto ackblock;
       end
       else begin
          stat := why;
          goto nakblock;            (* bad header block *)
       end;
    end
    else if (inblk = c) then begin        (* if this is the one we want *)
       why := getblock(buf);
       if why = '' then begin             (* else if we get it okay     *)
          sendack(1,inblk);               (* ack the data               *)
          for n :=0 to 127 do begin
            if (endblk <> 0) then begin   (* limit file size if known   *)
               if left = 0 then goto endrcv;
               dec(left);
            end;
            {$I-} blockwrite(workfile,buf[n],1,result); {$I+}
            if ioresult <> 0 then begin
                 writeln(#13+#10,'  Write error (disk full?)');
                 goto abort;
            end;
          end;
          tries := 0;                    (* reset try count        *)
          inc(blknum);                   (* we want the next block *)
          goto ackblock;
       end
       else begin
          stat := why;
          goto nakblock;                 (* ask for a resend       *)
       end;
    end                                  (* else if resending what we have *)
    else if (inblk < c) OR (inblk > c+100) then begin
       why := getblock(buf);             (* ignore it              *)
       sendack(1,inblk);                 (* but ack it             *)
       stat := 'Dup';
       goto ackblock;
    end
    else goto nextblock;                 (* else if running ahead  *)

endrcv:
    sendack(0,blknum);
    write('  NAK EOT         ',#13);
    if (com_getc(20) <> ord(EOT)) then goto nakblock;
    sendack(1,blknum);
    write('  ACK EOT',#13);

    if ( blknum > 1 ) then begin         (* if we really got anything *)
      if ( toterr > 2 ) then
         writeln(toterr,' errors detected and fixed in ',blknum-1,'blocks.');

         if (zero.fstamp <> 0) then      (* set stamp, if known *)
            SetFtime(workfile,zero.fstamp);
         close(workfile);
         {unlink(outname);              (* erase this copy of file  * )}
         rename(workfile,outname);
         rcvfile := outname;            (* signal what file we got    *)
         EXIT;
    end
    else begin                          (* else no real file          *)
       close(workfile);
       {unlink(tmpname);                (* discard empty file         *)}
       rcvfile := '';                   (* signal end of transfer     *)
    end;

abort:
    if (toterr <> 0) then
       writeln('  ',toterr,' errors detected and fixed in ',blknum-1,' blocks.');
    close(workfile);
    rcvfile := '';
END; (* recvfile *)


BEGIN (* SEALink *)
   SEALink := FALSE;
   progname:= 'NBBS';                (* name of sending program *)
   slide   := 1;                     (* Sliding Windows please? *)
   rawblk  := 1;
   ackless := 0;                     (* acks ARE required       *)
   if upload then SEALink := xmtfile(fname)
      else SEALink := (rcvfile(fname) <> '');
END; (* SEALink *)


(* ====================================================================
                            QUICK INTERFACE
   ==================================================================== *)
BEGIN { SEALink Sample Test Shell }
  PortNum := 0;
  If Not OpenFossil Then Exit;
  writeln('SEAlink (Pascal) v1.20');
  write('enter filename:');
  readln(filename);
  write('press <S>end or <R>eceive');
  writeln;
  repeat until keypressed;
  if upcase(readkey) = 'S' then begin
     transfer := SEALink(filename,TRUE); (* upload SEND it *)
     filename := '';
     transfer := SEALink(filename,TRUE); (* terminate it   *)
  end else
     writeln(filename,' was received as: ',SEALink(filename,FALSE));
  CloseFossil;
END. { SEALink Sample Test Shell }