{$A+}{$B-}{$D+}{$G+}{$R-}{$S-}{$V-}
(*
  $A+: Align on word boundaries (for 80x86 processors
  $B-: short circuit boolean evaluation
  $G+: enable 80286 code optimization
  $L : local symbols switch
  $R+- only adds time when an index is used in array or a string
  $S+- checks stack whenever a procedure is called or a dynamic variable
       is created.
  $V+: Controls type-checking on strings passed as variable parameters
 
*)
(*
   PROTOCOL.PAS - protocol unit for NBBS BBS v1.00a
   (c)1989,1990,1993 Eric J. Givler, All Rights Reserved.

   History:

   Internal Functions and Procedures in this unit include:
   function eltime      - elapsed time calculations of transfers.
   function leap        - return true if year is a leap year
   function octal       - return octal string of a longint
   function since70     - Calculate seconds since 01/01/70
   function sendxmodem  - send xmodem/checksum
   function sendxmodemCRC guess?
   function send1kxmodem- send Xmodem-1K
   function sendymodem  - send true Ymodem (has header info)
   function sendascii   - not done
   function recvascii   - not done
   function recvxmodem  - Receive Xmodem/Checksum

   Dispatcher functions (CALLABLE)
   FUNCTION UpLoad(fname: string; using:protocols): boolean;
   FUNCTION DownLoad(fname: string; using:protocols): boolean;


   FOR A USER WHO DOESN'T HAVE MNP:
   var valid_protocol_set : set of protocol;

   valid_protocol_set := protocol_set - MNP_set;

   YOU CAN THEN STEP THROUGH THE SET, PRESENT THE USER WITH WHAT PROTOCOLS
   ARE AVAILABLE, AND THEN USE THE UNIT TO INITIATE THE TRANSFER.  LIKE:

   var p: protocol;
   p := integer(0);
   repeat
     writeln('How about using ', protocol_name[p]);
     p := succ(p);
   until (p = External);
*)
UNIT PROTOCOL;

INTERFACE

type protocols = (ASCII, XmodemChkSum, XmodemCRC, Xmodem1K, Ymodem,
                 MegaLink,YmodemG);

const protocol_name: array[protocols] of string[12] =
                ('ASCII','XmodemChkSum','XmodemCRC','Xmodem1K',
                 'Ymodem','MegaLink','YmodemG');

      protocol_set : set of protocols = [ASCII..YmodemG];
      batch_set    : set of protocols = [Ymodem,YmodemG,MegaLink];
      MNP_set      : set of protocols = [YmodemG];

var errorcode : byte;
{
  0 = No Error, Success
  1 = User/Remote Aborted Transfer
  2 = Local Abort
  3 = Carrier Loss
  4 = Bad CRC
  5 = No ACK on EOT
  6 = File already exists?
  7 = File NOT found
}
   cps : real;  { result of last transfer - Characters Per Second }


(* protocol dispatchers *)
function Upload(fname: string; using : protocols): boolean;
function Download(fname: string; using : protocols): boolean;

(* ------------------------- IMPLEMENTATION ---------------------------- *)
IMPLEMENTATION

USES DOS,
     crt,     { Turbo Pascal CRT routines    }
     crcs,    { CRC calculation routines     }
     fos;     { Fossil communication library }

CONST NUL  = 00;
      SOH  = #$01;            { Start Of Header (128)   }
      STX  = #$02;            { Start Of Header (1024)  }
      EOT  = #$04;            { End of Transmission     }
      ACK  = #$06;            { Acknowledge (positive)  }
      DLE  = #$10;            { Data Link Escape        }
      NAK  = #$15;            { Negative Acknowledge    }
      SYN  = #$16;            { Synchronous idle        }
      XON  = #$11;            { Transmit On (DC1)       }
      XOFF = #$13;            { Transmit Off (DC3)      }
      CAN  = #$18;            { Cancel                  }
      CPMEOF = #$1A;          { End Of File (padding)^Z }

      C   = #$43;
      TAB = 09;
      LF  = #$0A;
      CR  = #$0D;
      Space = ' ';

      lastbyte = 127;
      errormax = 5;
      retrymax = 10;             { 10 retries }

type  blocktype = array[0..127] of byte;

VAR   sector : blocktype;        { array[0..lastbyte] of byte; }
      systicks  : longint absolute $40:$6c;
      tickstart : real;


function eltime(lesser,greater:real):real;
begin
   if lesser <= greater then
        eltime := greater - lesser
   else eltime := (86400.0 - lesser) + greater;
end; (* eltime (elapsed time) for reals *)


FUNCTION SENDXMODEM(var f : file): boolean;
{ currently no abort local or remote allowed here!! }
var j,                            { for local loops }
    result,
    checksum,
    blocknum,
    ch       : integer;
    lc       : char;              { possible local abort }
    counter  : byte;
    temp     : string[5];
begin
  sendxmodem := false;
  blocknum := 1;
  str((filesize(f) div 128):5,temp);
  writeln('File open:' + temp + ' records.');
  repeat
     counter := 0;
     fillchar(sector,sizeof(sector),CPMEOF);
     blockread(f,sector,sizeof(sector),result);
     repeat
       write(cr,'Sending block: ',blocknum);
       FOS.Send(SOH);                             { Start of Header  }
       FOS.Send(CHR(blocknum));                   { Packet Number    }
       FOS.Send(CHR(-blocknum-1));                { One's complement }
       CHECKSUM := 0;
       FOS.Sendblk(seg(sector[0]),ofs(sector[0]),128);
       for j:= 0 to lastbyte do CHECKSUM:=(CHECKSUM+sector[j]) mod 256;
       send(chr(CHECKSUM));
       purgeline;
       inc(counter);
       ch := readline(10);
       if keypressed then lc := readkey;
     until (ch in [Ord(ACK),Ord(CAN)]) or (counter = retrymax) or (NOT carrier);
     if (ch = Ord(CAN)) or (lc = #27) then
     begin
        errorcode := 1;
        exit;
     end;       
     inc(blocknum);
  until eof(f) or (counter = retrymax) or (not FOS.carrier);
  if counter = retrymax then
  begin
     Writeln(cr,lf,'No ACK on sector');
     errorcode := 1;
  end
  else
  begin
     counter := 0;
     repeat
        send(EOT);
        inc(counter);
     until (readline(10)=ord(ACK)) or (counter=retrymax) or (not carrier);
     if counter = retrymax then
     begin
        WriteLn(cr,lf,'No ACK on EOT');
        errorcode := 1;
     end
     else
     begin
        WriteLn(cr,lf,'Transfer complete');
        errorcode := 0;
        sendxmodem := TRUE;
     end;
  end;
end;


FUNCTION SendXmodemCRC( var f : file ) : boolean;
VAR  temp    : string[5];
     counter,
     result  : word;
     j,k,blocknum: integer;
BEGIN
   blocknum := 1;
   str((filesize(f) div 128):5,temp);
   writeln('File open:' + temp + ' records.');
   REPEAT
      counter := 0;
      FillChar(sector,SizeOF(sector),CPMEOF);
      {$I-} Blockread(f,sector,sizeof(sector),result); {$I+}
      if IOResult <> 0 THEN
      begin
          WriteLn('Error Reading File: CANCELLED');
          Send(CAN);
          Send(CAN);
          Exit;
      end;
      REPEAT
         Write(cr,'Sending block# ',blocknum);
         Send(SOH);
         Send(CHR(blocknum));
         Send(CHR(-blocknum-1));
         SendBlk( seg(sector[0]), ofs(sector[0]), 128);
         crc := 0;
         Crca(sector,SizeOf(sector),crc);
         Send(CHR(Hi(crc)));
         Send(CHR(Lo(crc)));           
         PurgeLine;
         inc(counter);
      UNTIL (readline(10) = Ord(ACK)) OR (counter = retrymax);
      Inc(blocknum);
   UNTIL EOF(f) OR (counter = retrymax) OR (NOT Carrier);
   if counter = retrymax THEN
       writeln(cr,lf,'No ACK on sector')
   else
   begin
      counter := 0;
      repeat
         Send(EOT);
         Inc(counter);
      until (readline(10)=Ord(ACK)) or (counter=retrymax);
      if counter = retrymax then
          writeln(cr,lf,'No ACK on EOT')
      else WriteLn(cr,lf,'Transfer complete');
   end;
END;


FUNCTION SendAscii(fname:string):boolean;
{ establish any flow control before calling this function }
var thefile : TEXT;
    inch,ch,lc : char;
begin
   SendAscii := FALSE;
   ch := ' '; lc := ' ';
   assign(thefile,fname);
   {$I-} Reset(thefile); {$I+}
   if ioresult <> 0 then begin
      errorcode := 7; { file not found }
      exit;
   end;
   repeat
     read(thefile, inch);
     send(inch);
     if serialchar then ch := receive;
     if keypressed then lc := readkey;
     {
     if ch = chr(ord(xoff))) then
        repeat
           if serialchar then ch := receive;
        until ch = chr(ord(xon));
     }
   until eof(thefile) OR (not carrier) or (ch = ^X) or (lc = #27);
   send(^Z);
   close(thefile);
   SendAscii := TRUE;
   errorcode := 0;
   if not carrier then begin
      errorcode := 3;  SendAscii := FALSE;
   end else if ch = ^X then begin
      errorcode := 1;  SendAscii := FALSE;
   end else if lc = #27 then begin
      errorcode := 2;  SendAscii := FALSE;
   end;
end;


function octal( t : LongInt) : String;
{ FUNCTION  octal   - Returns OCTAL string of a LongInt (seconds) }
var quotient, remainder : longint;
    code : integer;
    os : string;
    ch : string[1];
begin
    os := '';
    ch := ' ';
    quotient := t;
    while (quotient <> 0) do begin
       quotient := quotient DIV 8;
       remainder := t MOD 8;
       t := quotient;
       str(remainder,ch);
       os := ch + os;
   end;
   octal := os;
end;


function leap( yr : integer) : BOOLEAN;
{ FUNCTION  leap    - Returns TRUE if yr is a leapyear. }
begin
   if (((yr mod 4 = 0) and (yr mod 100 <> 0)) or (yr mod 400 = 0)) then
      leap := TRUE
   else leap := FALSE;
end;


function since70(dt : datetime) : longint;
{ FUNCTION  since70 - Calculates seconds since 01/01/70 for LAST UPDATE }
const month : array[1..12] of integer = (31,28,31,30,31,30,31,31,30,31,30,31);
var i, leapyrs : integer;
    secs, thisyear : longint;
begin
   leapyrs := 0;
   for i := 1970 to (dt.year - 1) do if leap(i) then inc(leapyrs);
   secs := (dt.year - 1970)*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;
   since70 := secs + thisyear;
end;


{============================== SendYmodem =============================}
FUNCTION  SENDYMODEM( filename : string; var f : file ) : boolean;
CONST NULL = $0;
VAR block : array[0..1023] of byte; (* byte *)
     temp : string[5];
     j,i  : integer;
    str1  : string;
   ftime  : longint;
   tcrc   : word;
   dt : datetime;
   blocknum,
   counter,
   result : integer;
BEGIN

     (* Build Ymodem header block - block 0 *)
     FillChar(sector,SizeOf(sector),NULL); { chr(0) }
     for j := 0 to length(filename)-1 DO sector[j] := Ord(filename[j+1]);
     inc(j);
     str(FileSize(f),str1);
     for i := 1 to length(str1) DO sector[j+i] := Ord(str1[i]);
     j := j + i + 1;
     sector[j] := $20;
     GetFTime(f,ftime);
     UnPackTime(ftime,dt);
     str1 := Octal(Since70(dt));
     For i := 1 to length(str1) do sector[j+i] := Ord(str1[i]);
     sector[j+i+1] := $20;

     (* Send header packet *)
     REPEAT
        Send(SOH);
        Send(#0);
        Send(#$FF);
        SendBlk(seg(sector[0]),ofs(sector[0]),128);
        crc := 0;
        crca(Sector,SizeOf(sector),crc);
        Send(CHR(Hi(crc)));
        Send(CHR(Lo(crc)));
        PurgeLine;
     UNTIL (readline(10) = Ord(ACK));

     blocknum := 1;
     str((filesize(f) DIV 1024):5,temp);
     WriteLn('File open:' + temp + ' records.');
     REPEAT
        counter := 0;
        FillChar(block,SizeOf(block),CPMEOF);
        {$I-} blockread(f,block,SizeOf(block),result); {$I+}
        if IOResult <> 0 then
        begin
           WriteLn('Error Reading File: CANCELLED');
           FOS.Send(CAN);
           FOS.Send(CAN);
           Exit;
        end;
        REPEAT
           Write(cr,'Sending block: ',blocknum);
           Send(STX);
           Send(CHR(blocknum));
           Send(CHR(-blocknum-1));
           SendBlk(seg(block[0]),ofs(block[0]),1024);
           crc := 0;
           Crca(block,sizeof(block),crc);
           Send(CHR(Hi(crc)));
           Send(CHR(Lo(crc)));
           PurgeLine;
           Inc(counter);
        UNTIL (readline(10) = Ord(ACK)) OR (counter = retrymax);
        inc(blocknum);
     UNTIL EOF(f) OR (counter = retrymax) OR (NOT Carrier);

     IF counter = retrymax THEN
         Writeln(CR,LF,'No ACK on sector')
     ELSE
     BEGIN
         counter := 0;
         REPEAT
           Send(EOT);
           Inc(counter);
         UNTIL (readline(10) = Ord(ACK)) or (counter=retrymax);
         IF counter = retrymax THEN
            WriteLn(CR,LF,'No ACK on EOT')
         ELSE WriteLn(CR,LF,'Transfer complete');
     END;

     (*  Send a null header block to signify end of transfer! *)
     counter := 0;
     REPEAT
        FillChar(sector,SizeOf(sector),CHR(0));  { NULL := CHR(0) }
        Send(SOH);
        Send(#$00);
        Send(#$FF);
        SendBlk(seg(sector[0]),ofs(sector[0]),128);
        crc := 0;
        crca(Sector, SizeOf(sector), crc);
        Send(CHR(Hi(crc)));
        Send(CHR(Lo(crc)));
        inc(counter);
     UNTIL (Readline(10) = Ord(ACK)) or (counter = retrymax);
END;


(* 
    PROCEDURE PackDateAndTime(var pd : date; dt : DateTime);
    { Returns the number of seconds since 00:00:00 01/01/1970 }
    CONST TDays : array[boolean,0..12] of word =
           ((0,31,59,90,120,151,181,212,243,273,304,334,365),
           (0,31,60,91,121,152,182,213,244,274,305,335,366));
          diff  = 347155200;
    VAR total,
        temp   : date;
        lyr    : boolean;
    BEGIN
       lyr := (((dt.year mod 4 = 0) and (dt.year mod 100 <>0))
              or (dt.year mod 400 = 0));
       dec(dt.year,1981);
       total := date(dt.sec) + (dt.min * 60) + (date(dt.hour) * 3600);
       temp := date(dt.year) * word(365) + (dt.year div 4);
       inc(temp,TDays[lyr][dt.month-1]);
       inc(temp,dt.day-1);
       pd := total + (temp * 86400) + diff;
    END;  {PackDateAndTime}

    crc := 0;
    crca(block, SizeOf(block), crc);
    Send(CHR(Hi(crc)));
    Send(CHR(Lo(crc)));
    BlockCRC(Seg(block),Ofs(block),1023);
    Send(CHR(Hi(crc_reg_hi)));
    Send(CHR(Lo(crc_reg_hi)));

    BlockCRC(Seg(sector[0]),ofs(sector[0]),127);
    Send(CHR(Hi(crc_reg_hi)));
    Send(CHR(Lo(crc_reg_hi)));

           {FOR j := 0 TO 1023 do begin
               Send(block[j]);
               updcrc(tcrc,block[j]);
           end;
           }
*)

FUNCTION SEND1KXMODEM( var f : file ) : boolean;
VAR block  : array[0..1023] of byte;
    temp   : string[5];
    result : word;
    counter,
    blocknum,
    j     : integer;
BEGIN
   blocknum := 1;
   str((filesize(f) DIV 1024):5,temp);
   WriteLn(#13+#10'File open:' + temp + ' records.');
   repeat
     counter := 0;
     FillChar(block,SizeOf(block),CPMEOF);
     {$I-} blockread(f,block,SizeOf(block),result); {$I+}
     if IOResult <> 0 then
     begin
        WriteLn('Error Reading File: CANCELLED');
        Send(CAN);
        Send(CAN);
        Exit;
     end;
     repeat
        Write(cr,'Sending block: ',blocknum);
        Send(STX);                              {  Send(SOH);     }
        Send(CHR(blocknum));
        Send(CHR(-blocknum-1));                 { (-blocknum-1)); }
        For j := 0 to 1023 do Send(CHR(block[j]));
        crc := 0;
        crca(block,1024,crc);
        Send(CHR(Hi(crc)));
        Send(CHR(Lo(crc)));
        PurgeLine;
        Inc(counter);
        { ch := readline(10);  write('ch:',ch,#7); }
     until (readline(10) =Ord(ACK)) OR (counter = retrymax);
     WRITE(COUNTER);
     inc(blocknum);
   until EOF(f) OR (counter = retrymax) OR (NOT FOS.Carrier);
   IF counter = retrymax THEN
      Writeln(cr,lf,'No ACK on sector')
   else
   begin
      counter := 0;
      repeat
         Send(EOT);
         Inc(counter);
      until (readline(10)=Ord(ACK)) or (counter=retrymax);
      IF counter = retrymax THEN
         WriteLn(cr,lf,'No ACK on EOT')
      ELSE WriteLn(cr,lf,'Transfer complete');
   end;
end;


{====================================================================
 UPLOAD DISPATCHER
 ====================================================================}
FUNCTION UPLOAD(fname: string; using:protocols): boolean;
VAR result   : boolean;
    workfile : file;
    sizeoffile : longint;
    elapsed  : word;
BEGIN
    result := FALSE;
    assign(workfile,fname);
    {$I-} reset(workfile,1); {$I+}
    if ioresult <> 0 then
        errorcode := 7
    else
    begin
        tickstart := systicks / 18.23;
        sizeoffile:= filesize(workfile);
        case using of
           {Ascii       : result := SendAscii(fname);}
           XmodemChkSum : result := SendXmodem( workfile );
           XmodemCRC    : result := SendXmodemCRC( workfile );
           Xmodem1K     : result := Send1KXmodem( workfile );
           Ymodem       : result := SendYmodem(fname, workfile );
        else
           write('Protocol currently unavailable!',#7);
        end;
        close(workfile);
        Upload  := result;
        elapsed := trunc(Eltime( tickstart, (systicks/18.23) ));
        writeln('Elapsed Seconds: ', elapsed );
        cps     := sizeoffile / elapsed;
        writeln('Cps: ', cps:7:2)
    end;
END;


{==========================================================================
  Receive protocols and dispatcher follow
===========================================================================}
FUNCTION recvascii(fname:string) : boolean;
var  lc,rc:char;
     textfile : TEXT;
begin
  recvascii := FALSE;
  lc := ' ';
  rc := ' ';
  assign(textfile,fname);
  {$I-} Reset(textfile); {$I+}
  if (IOResult = 0) then begin
     close(textfile);
     errorcode := 6;
     exit;
  end;
  rewrite(textfile);
  SendText('Ends on Ctrl-Z, Abort with Ctrl-X');
  Writeln('Type ^X to exit ASCII receive');
  repeat
    If SerialChar THEN rc := Receive;
    If Keypressed THEN lc := ReadKey;
    Write(textfile,rc);
  until (rc = ^Z) OR (rc = ^X) OR (lc = #27) OR (NOT Carrier);
  close(textfile);
  if rc = ^Z then begin
     errorcode := 0;
     recvascii := TRUE;
     exit;
  end;
  if rc = ^X then errorcode := 1
  else if lc = #27 then errorcode := 2
  else if NOT carrier then errorcode := 3;
  erase(textfile);
end;


FUNCTION RecvXmodem(fname:string) : boolean;
VAR j,
    firstchar,
    sectornum,
    sectorcurrent,
    sectorcomp,
    errors,
    checksum  : integer;
    errorflag : boolean;
    c         : char;
    workfile  : file;

begin
   RecvXmodem := FALSE;
   assign(workfile,fname);
   rewrite(workfile);
   if Ioresult <> 0 then begin
      errorcode := 6;
      exit;
   end;
   sectornum := 0;
   errors := 0;
   send(NAK);
   send(NAK);                       (* send ready characters *)
   repeat
     errorflag := false;
     repeat
       firstchar := readline(20);
     until ((firstchar IN [Ord(SOH),Ord(EOT)]) OR
           (firstchar = timeout)) OR (Not Carrier);
     if NOT Carrier THEN begin
        errorcode := 3;
        exit;
     end;
     IF firstchar = timeout THEN Writeln(cr,lf,'Error - No starting SOH');
     IF firstchar = Ord(SOH) THEN BEGIN
        sectorcurrent := Readline(1);      {real sector number}
        sectorcomp    := Readline(1);      {+ inverse of above}
        IF (sectorcurrent+sectorcomp) = 255 THEN BEGIN {< becomes this #}
           IF (sectorcurrent=sectornum+1) THEN BEGIN
              checksum := 0;
              ReadBlk(seg(sector[0]),ofs(sector[0]),128);
              for j:= 0 to lastbyte do
                  checksum := (checksum+sector[j]) mod 256;
              IF checksum = Readline(1) THEN BEGIN
                 blockwrite(WorkFile,sector,1);
                 errors := 0;
                 sectornum := sectorcurrent;
                 write(cr,'Received sector ',sectorcurrent);
                 send(ACK)
              END ELSE BEGIN
                 writeln(cr,lf,'Checksum error');
                 errorflag := true
              END
           END ELSE IF (sectorcurrent=sectornum) THEN BEGIN
              REPEAT
              UNTIL Readline(1) = timeout;
              Writeln(cr,lf,'Received duplicate sector ', sectorcurrent);
              Send(ack)
           END ELSE BEGIN
              Writeln(cr,lf,'Synchronization error');
              errorflag := true
           END
        END else BEGIN
           Writeln(cr,lf,'Sector number error');
           errorflag := true
        END
     END;
     IF errorflag THEN BEGIN
        inc(errors);
        REPEAT UNTIL Readline(1) = timeout;
        send(nak)
     END;
   UNTIL ((firstchar = Ord(EOT)) OR (firstchar = timeout)) OR
         (errors = errormax) OR (NOT Carrier);

   IF (firstchar = Ord(EOT)) AND (errors < errormax) THEN BEGIN
      send(ack);
      Writeln(cr,lf,'Transfer complete');
      errorcode := 0; recvxmodem := TRUE;
   end else