home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / PROT100.ZIP / SEALINK.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-13  |  27KB  |  682 lines
  1. PROGRAM TTRAN;
  2. (*
  3. SEALINK in Pascal.  (STAND-ALONE)
  4. Copyright (c)1990,1991 Eric J. Givler, All Rights Reserved.
  5. -1st attempt at converting this.
  6.  
  7. SEAlink - Sliding window file transfer protocol
  8. Version 1.20, created on 08/05/87 at 17:51:40
  9. (C) COPYRIGHT 1986,87 by System Enhancement Associates; ALL RIGHTS RESERVED
  10. *)
  11. USES crt,
  12.      dos,
  13.      fos,         { fos Send uses char, FOSSIL uses byte }
  14.      CRCS;
  15.  
  16. VAR filename : string;
  17.     transfer : boolean;
  18.  
  19. {
  20. CONVENTIONS:
  21.   com_putc(c) = send(CHAR);    ( FOSSIL   )
  22.   com_getc(t) = com_getc(t);   ( INTERNAL )
  23.   com_dump()  = purgeoutput;   ( FOSSIL   )
  24. }
  25.  
  26. FUNCTION leap( yr : integer) : BOOLEAN;
  27. BEGIN
  28.    if (((yr mod 4 = 0) and (yr mod 100 <> 0))
  29.       or (yr mod 400 = 0)) then leap := TRUE else leap := FALSE;
  30. END;
  31.  
  32. FUNCTION Since79(dt : DateTime) : longint;
  33. VAR i, leapyrs : integer;
  34.     secs, thisyear : longint;
  35.     month : array[1..12] of integer;
  36. BEGIN
  37.    month[1] := 31; month[2] := 28; month[3] := 31; month[4] := 30;
  38.    month[5] := 31; month[6] := 30; month[7] := 31; month[8] := 31;
  39.    month[9] := 30; month[10] := 31; month[11] := 30; month[12] := 31;
  40.    leapyrs := 0;
  41.    for i := 1970 to (dt.year - 1) do if leap(i) then inc(leapyrs);
  42.    secs := (dt.year - 1979)*86400*365 + leapyrs*86400;
  43.    thisyear := (longint(dt.hour) * 60 * 60) + (dt.min * 60) + (dt.sec) +
  44.                ((dt.day - 1) * 86400);
  45.    for i := 1 to (dt.month-1) do thisyear := thisyear + (month[i]*86400);
  46.    if leap(dt.year) and (dt.month > 2) then thisyear := thisyear + 86400;
  47.    Since79 := secs + thisyear;
  48. END;
  49.  
  50.  
  51.  
  52. FUNCTION SEALink(fname:string; upload:boolean):boolean;
  53.  
  54. CONST WINDOW = 6;                       (* maximum size of window  *)
  55.       ACK    = #$06;
  56.       NAK    = #$15;
  57.       SOH    = #$01;
  58.       EOT    = #$04;
  59.       CPMEOF = ^Z;
  60.  
  61. TYPE block0 = RECORD                    (* block zero data structure *)
  62.        flen   : longint;                (* file length               *)
  63.        fstamp : longint;                (* file date/time stamp      *)
  64.        fnam   : array[1..17] of char;   (* original file name        *)
  65.        prog   : array[1..15] of char;   (* sending program name      *)
  66.        noacks : char;                   (* true if ACKing not req.   *)
  67.        fill   : array[1..87] of char;   (* reserved for future use   *)
  68.      END;
  69.      blocktype = array[0..127] of byte; (* A typical xmodem block    *)
  70.  
  71. { STATICS in C }
  72. VAR  outblk : integer;                 (* number of next block to send  *)
  73.      ackblk : integer;                 (* number of last block ACKed    *)
  74.      blksnt : integer;                 (* number of last block sent     *)
  75.      slide  : integer;                 (* true if sliding window        *)
  76.      ackst  : integer;                 (* ACK/NAK state                 *)
  77.      numnak : integer;                 (* number of sequential NAKs     *)
  78.      chktec : integer;                 (* check type, 1=CRC, 0=checksum *)
  79.      toterr : integer;                 (* total number of errors        *)
  80.      ackrep : integer;                 (* true when ACK or NAK reported *)
  81.      ackseen: integer;                 (* count of sliding ACKs seen    *)
  82.  
  83.      progname: string;                 (* sending program               *)
  84.      ackless : integer;                (* true if ACKs not req. Ovrdrv  *)
  85.      t1      : longint;                (* timer, timerset               *)
  86.      rawblk  : integer;                (* raw block number              *)
  87.  
  88.      results : boolean;
  89.      sector  : blocktype;              (* A packet of data 128 bytes    *)
  90.  
  91.  
  92.      FUNCTION TimerSet(tenths:word) : longint;
  93.      { Returns a timer value which will expire in T tenths of a second }
  94.      var
  95.         Hour, Min, Sec, HSec : word;
  96.         Year, Mon, Day, DoW : word;
  97.      begin
  98.        GetDate(Year, Mon, Day, DoW);
  99.        GetTime(Hour, Min, Sec, HSec);
  100.        timerset := tenths+Hsec+100*(Sec+60*(Min+60*(Hour+24*DoW)));
  101.      end; {  timerset }
  102.  
  103.      FUNCTION TimeUp(Marker : longint) : boolean;
  104.      { Returns true if timer z has expired yet, or false otherwise }
  105.      var Marker2 : longint;
  106.      begin
  107.        Marker2 := TimerSet(0);
  108.        if (Marker-Marker2) > (8640000) then          { 24*60*60*100 }
  109.           Marker2 := Marker2+(60480000);             {7*24*60*60*100}
  110.        TimeUp := Marker2 >= Marker;
  111.      end; { TimeUp }
  112.  
  113.  
  114.      FUNCTION com_getc( t : longint):integer;
  115.      {Get char from port in t tenths of a sec.Return CPMEOF if time expired.}
  116.      Var Expires : longint;
  117.      BEGIN
  118.        Expires := TimerSet(t);
  119.        repeat
  120.        until serialchar or (TimeUp(Expires));
  121.        if serialchar then com_getc := ord(receive)
  122.           else com_getc := ord(CPMEOF);
  123.      END; { com_getc }
  124.  
  125.  
  126. (*   The various ACK/NAK states are:
  127.         0:   Ground state, ACK or NAK expected.
  128.         1:   ACK received
  129.         2:   NAK received
  130.         3:   ACK, block# received
  131.         4:   NAK, block# received
  132.         5:   Returning to ground state
  133. *)
  134.     PROCEDURE ackchk; (* check for ACK or NAK *)
  135.     VAR c   : integer;                      (* one byte of data     *)
  136.     BEGIN
  137.       ackrep := 0;                          (* nothing reported yet *)
  138.       c := com_getc(0);
  139.       while (c <> ord(CPMEOF)) do begin
  140.         if (ackst = 3) OR (ackst = 4) then begin
  141.           slide := 0;                      (* assume this will fail        *)
  142.           if (rawblk = (c OR $FF)) then    (* see if we believe the number *)
  143.           begin
  144.              rawblk := outblk - ((outblk-rawblk) AND $FF);
  145.              if (rawblk >= 0) AND (rawblk<=outblk) AND (rawblk>outblk-128)
  146.              then begin
  147.                 if (ackst = 3) then begin     (* advance for an ACK     *)
  148.                     if ackblk > rawblk then ackblk := ackblk
  149.                        else ackblk := rawblk;
  150.                     slide := 1;               (* we have sliding window! *)
  151.                     inc(ackseen);
  152.                     if ((ackless AND ackseen) > 10) then begin
  153.                        ackless := 0;          (* receiver not ACKless    *)
  154.                        writeln('- Overdrive disengaged    ');
  155.                     end;
  156.                     write(#13,'  ACK ',rawblk,' ==');
  157.                 end
  158.                 else begin        (* else retransmit for a NAK *)
  159.                     if rawblk < 0 then outblk := 0 else outblk := rawblk;
  160.                     slide := integer(numnak < 4); {boolean}
  161.                     write(#13,'  NAK ',rawblk,' ==');
  162.                 end;
  163.                 ackrep := 1;     (* we reported something  *)
  164.              end;
  165.           end;
  166.           ackst := 5;            (* return to ground state *)
  167.         end;
  168.  
  169.         if (ackst=1) OR (ackst=2) then begin
  170.            rawblk := c;
  171.            inc(ackst,2);
  172.         end;
  173.  
  174.         if (slide = 0) OR (ackst = 0) then begin
  175.            if (c = ord(ACK)) then begin
  176.               if (slide = 0) then begin
  177.                  inc(ackblk);
  178.                  write(#13,'  ACK ',ackblk,' --');
  179.                  ackrep := 1;     (* we reported an ACK *)
  180.               end;
  181.               ackst := 1;
  182.               numnak := 0;
  183.            end
  184.  
  185.            else if (c = ord('C')) OR (c = ord(NAK)) then begin
  186.                if (chktec > 1) then begin (* if method not determined yet *)
  187.                   if (c = ORD('C')) then chktec := 1
  188.                   else chktec := 0;     (* then do what receiver wants *)
  189.                end;
  190.                purgeoutput;      (* purge pending output *)
  191.                delay(6);         (* resynch              *)
  192.  
  193.                if (slide = 0) then begin
  194.                   outblk := ackblk+1;
  195.                   write(#13,'  NAK ',ackblk+1,' --');
  196.                   ackrep := 1;    (* we reported a negative ACK *)
  197.                end;
  198.                ackst := 2;
  199.                inc(numnak);
  200.                if (blksnt <> 0) then inc(toterr);
  201.            end; (* else *)
  202.         end; (* slide = 0 or ackst = 0 *)
  203.  
  204.         if (ackst = 5) then ackst := 0;
  205.         c := com_getc(0);
  206.       END; { while }
  207.     END; { ackblk }
  208.  
  209.  
  210.     PROCEDURE shipblk(blk : blocktype; blknum : integer);
  211.     {PHYSICALLY SHIP A BLOCK,blk=data to be shipped, blknum=number of block}
  212.     VAR n,                             (* index                    *)
  213.         crc : integer;                 (* CRC check value          *)
  214.     BEGIN
  215.       send(SOH);                      (* block header             *)
  216.       send(chr(blknum));              (* block number             *)
  217.       send(chr(blknum XOR 255));      (* -blknum-1                *)
  218.       sendblk(seg(blk[0]),ofs(blk[0]),128); (* from Fossil unit   *)
  219.       crc := 0;
  220.       if chktec = 1 then begin
  221.          crca(blk,sizeof(blk),crc);
  222.          send(chr(hi(crc)));
  223.          send(chr(lo(crc)));
  224.       end else begin
  225.          for n := 0 to 127 do crc := (crc + blk[n]) mod 256;
  226.          send(chr(crc));
  227.       end;
  228.       purgeline;
  229.     END; { shipblk }
  230.  
  231.  
  232.      PROCEDURE sendblock(var f : file; blknum: integer); (* send one block *)
  233.      { f=file to read from, blknum=block to send }
  234.      var blkloc : longint;                  (* address of start of block *)
  235.          buf    : blocktype;                (* one block of data         *)
  236.          result : word;
  237.      BEGIN
  238.         if (blknum <> blksnt+1 ) then begin       (* if jumping    *)
  239.             blkloc := longint(blknum-1) * longint(128);
  240.             seek(f,blkloc);                       (* move where to *)
  241.         end;
  242.         blksnt := blknum;
  243.         fillchar(buf,sizeof(buf),CPMEOF);    (* fill buffer with ^Zs      *)
  244.         blockread(f,buf,1,result);           (* read in some data         *)
  245.         shipblk(buf,blknum);                 (* pump it out the comm port *)
  246.      END; { sendblock }
  247.  
  248. {=======================================================================}
  249.  
  250. FUNCTION xmtfile(fname: string) : boolean;
  251. (*
  252.     This routine is used to send a file.  One file is sent at a time.
  253.     If the name is blank (name is null or *name points to a null),
  254.     then only an end of transmission marker is sent. This routine
  255.     returns a one if the file is successfully transmitted, or a zero
  256.     if a fatal error occurs.
  257. *)
  258. LABEL abort;
  259. var workfile : file;                       (* file to send           *)
  260.     endblk : integer;                      (* block number of EOT    *)
  261.     zero   : block0;                       (* block zero data        *)
  262.     toadd  : byte;
  263.     fsize  : longint;
  264.     dt     : DateTime;
  265. BEGIN
  266.    if fname <> '' then begin                 (* if sending a file  *)
  267.       assign(workfile,fname);
  268.       {$I-} reset(workfile,1); {$I+}         (* to get proper size *)
  269.       if ioresult <> 0 then begin
  270.          writeln('  Can''t read ',fname);
  271.          xmtfile := false;
  272.          exit;
  273.       end;
  274.  
  275.       fillchar(zero,sizeof(zero),chr(0));       (*clear out data block *)
  276.                                                 (* get file statistics *)
  277.       zero.flen := filesize(workfile);          (* size of file -bytes *)
  278.       endblk := ((zero.flen+127) DIV 128) + 1;
  279.       writeln('Ready to send ',endblk-1,' blocks of ',fname,' (',zero.flen,')');
  280.       reset(workfile);                          (* for 128 byte reads  *)
  281.       GetFTime(workfile,zero.fstamp);           (* time and date stamp *)
  282.       {
  283.       UnPackTime(zero.fstamp,dt);
  284.       zero.fstamp := Since79(dt);
  285.       }
  286.       move(fname[1],zero.fnam,ord(fname[0]));
  287.       move(progname[1],zero.prog,ORD(progname[0]));
  288.       zero.noacks := char(ackless);             (* OVERDRIVE engaged?  *)
  289.       move(zero,sector,sizeof(zero));           (* move into xmdm blk  *)
  290.    end
  291.    else endblk := 0;                    (* fake for no file   *)
  292.  
  293.    outblk :=  1;                        (* set starting state *)
  294.    ackblk := -1;
  295.    blksnt := 0;
  296.    slide  := 0;
  297.    ackst  := 0;
  298.    numnak := 0;
  299.    toterr := 0;
  300.    ackrep := 0;
  301.    ackseen:= 0;
  302.    chktec := 2;                        (* undetermined CRC or checksum? *)
  303.    toadd  := 0;
  304.  
  305.    t1 := timerset(300);                (* time limit for first block  *)
  306.    write('  Waiting...'+#13);
  307.  
  308.    while (ackblk < endblk) do begin     (* while not all there yet    *)
  309.      if not carrier then begin
  310.         writeln(#13+#10+'Lost carrier');
  311.         goto abort;
  312.      end;
  313.  
  314.      if keypressed then begin
  315.         if readkey = #27 then begin
  316.            writeln(#13+#10+'Aborted by operator');
  317.            goto abort;
  318.         end;
  319.      end;
  320.  
  321.      if ( timeup(t1) ) then begin
  322.         writeln(#13+#10+'Fatal timeout');
  323.         goto abort;
  324.      end;
  325.      
  326.      if slide = 1 then toadd := WINDOW
  327.         else toadd := 1;
  328.  
  329.      if (outblk <= ackblk + toadd) then begin
  330.         if (outblk < endblk) then begin
  331.            if (outblk > 0) then
  332.               sendblock(workfile,outblk)
  333.            else
  334.               shipblk(sector,0);
  335.  
  336.            if (ackrep <> 0) then
  337.               write(' Sending block #',outblk,#13);
  338.  
  339.            if (ackless AND slide) <> 0 then begin
  340.               if (outblk MOD 10 = 0) then
  341.                  write(#13,'  Passing block ',outblk);
  342.               ackblk := outblk;
  343.            end;
  344.         end
  345.         else if (outblk = endblk) then begin
  346.            send(EOT);
  347.            if (ackrep <> 0) then
  348.               write(' Sent EOT           '+#13);
  349.         end;
  350.         inc(outblk);             (* outblk++;                 *)
  351.         t1 := timerset(300);     (* time limit between blocks *)
  352.      end;
  353.  
  354.      ackchk;                     (* determine ACK status      *)
  355.  
  356.      if (numnak > 10) then begin
  357.         writeln(#13+#10,'  Too many errors');
  358.         goto abort;
  359.      end;
  360.    end; { while }
  361.  
  362.    writeln(' End of file         ');
  363.    if (endblk <> 0) then close(workfile);
  364.    if (toterr > 2) then
  365.          write(toterr,' errors detected and fixed in ',blksnt,' blocks.');
  366.    xmtFile := TRUE;                          (* exit with good status *)
  367.    exit;
  368.  
  369. ABORT:
  370.     if (endblk> 0) then close(workfile);
  371.     if (toterr > 0) then
  372.          writeln(toterr,' errors detected and fixed in ',blksnt,' blocks.');
  373.     xmtFile := FALSE;                         (* exit with bad status *)
  374. END; (* xmtfile *)
  375.  
  376. {=======================================================================}
  377.  
  378. FUNCTION rcvfile(fname:string) : string;
  379. { File receiver logic, fname = name of file }
  380. LABEL nakblock,                              (* we got a bad block *)
  381.       abort,                                 (* errors occurred    *)
  382.       ackblock,
  383.       nextblock,
  384.       blockstart,
  385.       endrcv;
  386. VAR c,                                 (* received character            *)
  387.     tries,                             (* retry counter                 *)
  388.     blknum,                            (* desired block number          *)
  389.     inblk,                             (* this block number             *)
  390.     endblk,                            (* block number of EOT, if known *)
  391.     n       : integer;                 (* index                         *)
  392.     workfile: file;                    (* file, opener                  *)
  393.     tmpname : string[100];             (* name of temporary file        *)
  394.     outname : string[100];             (* name of final file            *)
  395.     buf     : blocktype;               (* data buffer                   *)
  396.     zero    : block0;                  (* file header data storage      *)
  397.     left    : longint;                 (* bytes left to output          *)
  398.     stat : string[4];                  (* receive block status          *)
  399.     result : word;                     (* result of block write         *)
  400.     why : string;                      (* single block receiver status  *)
  401. {   char *getblock(), *why;            (* single block receiver, status *)}
  402.  
  403.  
  404.     PROCEDURE sendack(acknak,blknum:integer);  (* send an ACK or a NAK  *)
  405.     (* acknak: 1=ACK, 0=NAK *)
  406.     BEGIN
  407.        if(acknak = 1) then send(ACK)           (* send the right signal *)
  408.        else if (chktec = 1) then send('C')     (* CRC type ACK          *)
  409.        else send(NAK);                         (* send NAK              *)
  410.  
  411.        send(chr(blknum));                      (* block number          *)
  412.        send(chr(-blknum-1));                   (* block number check    *)
  413.     END; (* sendack*)
  414.  
  415.  
  416.     FUNCTION getblock(var buf : blocktype): string; (* read a block of data *)
  417.     (* buf = data buffer *)
  418.     VAR ourcrc : word;
  419.         hiscrc : integer;                  (* CRC check values    *)
  420.         c,                                 (* one byte of data    *)
  421.         n      : integer;                  (* index               *)
  422.         timeout: integer;                  (* short block timeout *)
  423.     BEGIN
  424.        ourcrc := 0; hiscrc := 0;
  425.        if ackless = 1 then timeout := 200 else timeout := 5;
  426.  
  427.        for n := 0 to 127 do begin
  428.           c := com_getc(timeout);
  429.           if (c = Ord(CPMEOF)) then getblock := 'Short';
  430.    
  431.           if (chktec = 1) then
  432.              updcrc(ourcrc,c)                    (* CRC table calculation *)
  433.           else ourcrc := (ourcrc + c) mod 256;   (* checksum              *)
  434.           buf[n] := c;
  435.        end;
  436.  
  437.        if (chktec = 1) then begin                (* CRC mode              *)
  438.           { ourcrc := crc_finish(ourcrc); }
  439.            hiscrc := (com_getc(timeout) SHL 8) OR com_getc(timeout);
  440.        end else begin
  441.            ourcrc := ourcrc AND $FF;
  442.            hiscrc := com_getc(timeout) AND $FF;
  443.        end;
  444.  
  445.        if (ourcrc = hiscrc) then begin
  446.           getblock := '';                       (* block is good  *)
  447.           exit;
  448.        end
  449.        else if (chktec = 1) then begin          (* else CRC error *)
  450.           getblock := 'CRC  ';
  451.           exit;
  452.        end
  453.        else getblock := 'Check';         (* or maybe checksum error *)
  454.     END; (* function GETBLOCK *)
  455.  
  456.  
  457. BEGIN (* rcvfile *)
  458.   writeln;
  459.   rcvfile := '';
  460.   stat := 'Init';                    (* receive block status     *)
  461.   if (fname <> '') then begin        (* figure out a name to use *)
  462.      {makefnam("X:\\",name,outname);}
  463.      {outname[2] = '-';}
  464.      {makefnam(outname+2,name,tmpname);}
  465.      {strcpy(outname,name);}
  466.      outname := fname;                     
  467.      delete(outname,1,1);
  468.      tmpname := '-'+outname;
  469.   end else begin
  470.      outname := '';
  471.      tmpname := '-TMPFILE.$$$';
  472.   end;
  473.  
  474.   assign(workfile,tmpname);          (* open output file *)
  475.   {$I-} reset(workfile); {$I+}
  476.   if ioresult = 0 then begin
  477.       writeln('  Cannot create ',tmpname);
  478.       close(workfile);
  479.       rcvfile := '';
  480.       exit;
  481.   end;
  482.   rewrite(workfile);                 (* rewrite this file *)  
  483.  
  484.   if outname <> '' then blknum := 1 
  485.      else blknum := 0;                (* first block we must get      *)
  486.   tries  := -10;                      (* kludge for first time around *)
  487.   chktec := 1;                        (* try for CRC error checking   *)
  488.   toterr := 0;                        (* no errors yet                *)
  489.   endblk := 0;                        (* we don't know the size yet   *)
  490.   ackless := 0;                       (* we don't know about this yet *)
  491.   fillchar(zero,sizeof(zero),0);      (* or much of anything else     *)
  492.  
  493.   if com_getc(0) = ord(SOH) then      (* kludge for adaptive modem7   *)
  494.      goto nextblock;
  495.  
  496. nakblock:                             (* we got a bad block           *)
  497.     if (blknum > 1) then inc(toterr);
  498.     inc(tries);
  499.     if (tries > 10) then begin
  500.        writeln(#13+#10'  Too many errors');
  501.        goto abort;
  502.     end;
  503.  
  504.     if (tries = 0)then chktec := 0;    (* if CRC isn't going       *)
  505.                                        (* then give checksum a try *)
  506.  
  507.     sendack(0,blknum);                 (* send the NAK             *)
  508.     write('  NAK block ',blknum,' ',stat,#13);
  509.  
  510.     if (ackless = 1) and (toterr > 20) then begin
  511.        ackless := 0;                       (* if ackless mode isn't working *)
  512.        writeln('- Overdrive disengaged'); (* then shut it off              *)
  513.     end;
  514.     goto nextblock;
  515.  
  516. ackblock:                              (* we got a good block *)
  517.     if (ackless = 0) then 
  518.        write('  ACK block ',blknum-1,' ',stat,#13)
  519.     else write('  Got block ',blknum,#13);
  520.  
  521. nextblock:                             (* start of "get a block" *)
  522.     stat := '';
  523.     if not carrier then begin
  524.        writeln(#13+#10+'  Lost carrier');
  525.        goto abort;
  526.     end;
  527.  
  528.     if keypressed then begin
  529.        if readkey = #27 then begin
  530.           writeln(#13+#10+'  Aborted by operator');
  531.           goto abort;
  532.        end;
  533.     end;
  534.  
  535.     t1 := timerset(30);                (* timer to start of block *)
  536.     while not timeup(t1) do begin
  537.         c := com_getc(0);
  538.         if (c = ord(EOT)) then begin
  539.            if ( endblk <> 0) or (endblk = blknum) then
  540.               goto endrcv;
  541.         end
  542.         else if (c = ord(SOH)) then begin
  543.            inblk := com_getc(5);
  544.            if (com_getc(5) = (inblk OR $FF)) then
  545.                goto blockstart;       (* we found a start *)
  546.         end;
  547.     end;
  548.     stat := 'Time ';
  549.     goto nakblock;
  550.  
  551. blockstart:                            (* start of block detected *)
  552.     c := blknum AND $FF;
  553.     if (inblk = 0) AND (blknum <= 1) then begin (* if this is the header *)
  554.        why := getblock(sector);
  555.        move(sector,zero,sizeof(sector));  (* put into our SEALink header *)
  556.        if why = '' then begin
  557.           sendack(1,inblk);               (* ack the header              *)
  558.           if fname = '' then begin        (* given name takes precedence *)
  559.              move(zero.fnam,outname[1],sizeof(zero.fnam));
  560.              outname[0] := chr(17);
  561.           end;
  562.           if (left = zero.flen) then   (* length to transfer    *)
  563.               endblk := (left+127) DIV 128 + 1;
  564.           if (ackless <> integer(zero.noacks)) then (* note variant *)
  565.           begin
  566.              if integer(zero.noacks) = 1 then writeln('+ Overdrive engaged')
  567.                 else writeln('+ Overdrive disengaged');
  568.           end;
  569.           ackless := integer(zero.noacks);
  570.  
  571.           write('  Receiving');
  572.           if (endblk <> 0) then write(' ',endblk-1,' blocks of');
  573.           write(outname);
  574.           move(zero.prog,progname[1],sizeof(zero.prog));
  575.           progname[0] := chr(15);
  576.           if (progname <> '') then write(' from ',progname);
  577.           writeln;
  578.           blknum := 1;              (* now we want first data block *)
  579.           goto ackblock;
  580.        end
  581.        else begin
  582.           stat := why;
  583.           goto nakblock;            (* bad header block *)
  584.        end;
  585.     end
  586.     else if (inblk = c) then begin        (* if this is the one we want *)
  587.        why := getblock(buf);
  588.        if why = '' then begin             (* else if we get it okay     *)
  589.           sendack(1,inblk);               (* ack the data               *)
  590.           for n :=0 to 127 do begin
  591.             if (endblk <> 0) then begin   (* limit file size if known   *)
  592.                if left = 0 then goto endrcv;
  593.                dec(left);
  594.             end;
  595.             {$I-} blockwrite(workfile,buf[n],1,result); {$I+}
  596.             if ioresult <> 0 then begin
  597.                  writeln(#13+#10,'  Write error (disk full?)');
  598.                  goto abort;
  599.             end;
  600.           end;
  601.           tries := 0;                    (* reset try count        *)
  602.           inc(blknum);                   (* we want the next block *)
  603.           goto ackblock;
  604.        end
  605.        else begin
  606.           stat := why;
  607.           goto nakblock;                 (* ask for a resend       *)
  608.        end;
  609.     end                                  (* else if resending what we have *)
  610.     else if (inblk < c) OR (inblk > c+100) then begin
  611.        why := getblock(buf);             (* ignore it              *)
  612.        sendack(1,inblk);                 (* but ack it             *)
  613.        stat := 'Dup';
  614.        goto ackblock;
  615.     end
  616.     else goto nextblock;                 (* else if running ahead  *)
  617.  
  618. endrcv:
  619.     sendack(0,blknum);
  620.     write('  NAK EOT         ',#13);
  621.     if (com_getc(20) <> ord(EOT)) then goto nakblock;
  622.     sendack(1,blknum);
  623.     write('  ACK EOT',#13);
  624.  
  625.     if ( blknum > 1 ) then begin         (* if we really got anything *)
  626.       if ( toterr > 2 ) then 
  627.          writeln(toterr,' errors detected and fixed in ',blknum-1,'blocks.');
  628.  
  629.          if (zero.fstamp <> 0) then      (* set stamp, if known *)
  630.             SetFtime(workfile,zero.fstamp);
  631.          close(workfile);
  632.          {unlink(outname);              (* erase this copy of file  * )}
  633.          rename(workfile,outname);
  634.          rcvfile := outname;            (* signal what file we got    *)
  635.          EXIT;
  636.     end
  637.     else begin                          (* else no real file          *)
  638.        close(workfile);
  639.        {unlink(tmpname);                (* discard empty file         *)}
  640.        rcvfile := '';                   (* signal end of transfer     *)
  641.     end;
  642.  
  643. abort:
  644.     if (toterr <> 0) then
  645.        writeln('  ',toterr,' errors detected and fixed in ',blknum-1,' blocks.');
  646.     close(workfile);
  647.     rcvfile := '';
  648. END; (* recvfile *)
  649.  
  650.  
  651. BEGIN (* SEALink *)
  652.    SEALink := FALSE;
  653.    progname:= 'NBBS';                (* name of sending program *)
  654.    slide   := 1;                     (* Sliding Windows please? *)
  655.    rawblk  := 1;
  656.    ackless := 0;                     (* acks ARE required       *)
  657.    if upload then SEALink := xmtfile(fname)
  658.       else SEALink := (rcvfile(fname) <> '');
  659. END; (* SEALink *)
  660.  
  661.  
  662. (* ==================================================================== 
  663.                             QUICK INTERFACE
  664.    ==================================================================== *)
  665. BEGIN { SEALink Sample Test Shell }
  666.   PortNum := 0;
  667.   If Not OpenFossil Then Exit;
  668.   writeln('SEAlink (Pascal) v1.20');
  669.   write('enter filename:');
  670.   readln(filename);
  671.   write('press <S>end or <R>eceive');
  672.   writeln;
  673.   repeat until keypressed;
  674.   if upcase(readkey) = 'S' then begin
  675.      transfer := SEALink(filename,TRUE); (* upload SEND it *)
  676.      filename := '';
  677.      transfer := SEALink(filename,TRUE); (* terminate it   *)
  678.   end else
  679.      writeln(filename,' was received as: ',SEALink(filename,FALSE));
  680.   CloseFossil;
  681. END. { SEALink Sample Test Shell }
  682.