HAM Radio 1/HamRadio.cdr/misc/yappprot/yappxfer.pas

Pascal/Delphi Source File | 1986-12-06 | 11KB | 522 lines

{ BINXFER.INC

  (c) 1986  Jeffry B. Jacobsen

  This implements the YAPP(tm) binary transfer protocol (or at least
  a subset of the full protocol - this version does not include the
  server commands for automated transfer.)

  This is a modified version of the actual code used in YAPP for the
  IBM PC and compatibles.  Some lines have been deleted that handled
  functions such as displaying the status of the transfer, and checking
  for an abort from the keyboard.

}


type

  states = (S,S1,SH,SD,SE,ST,R,RH,RD,Abort,CW,C,Start);
  paktype = (UK,RR,RF,SI,HD,DT,EF,ET,NR,CN,CA,RI,TX,UU,TM,AF,AT);
  std    = array[states] of string[11];

const stdesc: std = ('SendInit  ',
                     'SendInit  ',
                     'SendHeader',
                     'SendData  ',
                     'SendEof   ',
                     'SendEOT   ',
                     'RcvWait   ',
                     'RcvHeader ',
                     'RcvData   ',
                     'SndABORT  ',
                     'WaitAbtAck',
                     'RcdABORT  ',
                     'Start     ');

var

  Sendinit_Count : integer;
  xferhdr   : line;
  xfercnt   : real;
  xferok    : boolean;

  state     : states;
  ptype     : paktype;

  pkbuff    : array [1..256] of char;
  pklen     : integer;
  pkfile    : file of byte;
  pkfname   : string[30];
  txtbuff   : line;


const

  NUL       = #0;
  SOH       = #1;
  STX       = #2;
  ETX       = #3;
  EOT       = #4;
  ENQ       = #5;
  ACK       = #6;
  DLE       = #16;
  NAK       = #21;
  CAN       = #24;




function waitready: boolean;
{wait 20 seconds or 120 seconds for a character}

begin
  waitready := false;
  if (state = S) or (state = S1) then
    set_timer(20)             { 20 seconds to timeout}
  else
    set_timer(120);           {120 seconds to timeout}
  repeat
    if timeout then begin     {timeout checks timer value which is}
      ptype := TM;            {decremented towards 0 every second }
      waitready := true;
      exit;
      end;
  until inready;              {inready checks for character ready at TNC}
end;


procedure getpkstr;

  var
    i : integer;
    ch : char;

  begin
    if waitready then exit;
    ch := recvchar;           {recvchar returns character from TNC}
    pklen := ord(ch);
    if (ptype = DT) and (pklen = 0) then pklen := 256;
    if (pklen = 0) then exit;
    for i := 1 to pklen do
      begin
      if waitready then exit;
      ch := recvchar;
      pkbuff[i] := ch;
      end;
   end;


procedure Getpack;

  var
    ch : char;

  begin
    ptype := UK;
    if waitready then exit;
    ch := recvchar;
    case ch of
      ACK:  begin
            if waitready then exit;
            ch := recvchar;
            case ord(ch) of
              1: ptype := RR;
              2: ptype := RF;
              3: ptype := AF;
              4: ptype := AT;
              5: ptype := CA;
              else;
              end;
            end;
      ENQ:  begin
            if waitready then exit;
            ch := recvchar;
            case ord(ch) of
              1: ptype := SI;
              2: ptype := RI;
              else ptype := UU; {unimplemented command}
              end;
            end;
      SOH:  begin
            ptype := HD;
            getpkstr;
            end;
      STX:  begin
            ptype := DT;
            getpkstr;
            end;
      ETX:  begin
            if waitready then exit;
            ch := recvchar;
            if (ord(ch) = 1) then ptype := EF;
            end;
      EOT:  begin
            if waitready then exit;
            ch := recvchar;
            if (ord(ch) = 1) then ptype := ET;
            end;
      NAK:  begin
            ptype := NR;
            getpkstr;
            end;
      CAN:  begin
            ptype := CN;
            getpkstr;
            end;
      DLE:  begin
            ptype := TX;
            getpkstr;
            end;
    else;
    end; {case}
  end;


procedure Sendinit;

  begin
    Sendinit_Count := 0;
    xmitstr(ENQ + #01);          {send string to TNC}
    getpack;
    case ptype of
      TM : state := S1;
      RI : state := S;
      RR : state := SH;
      RF : state := SD;
      CN : state := C;
      NR : state := Start;
      TX : disppacket;
      else begin
           state := Abort;
           showmsg(13);          {error message display}
           end;
      end;
    end;



procedure Sendinit_retry;

  begin
    Sendinit_Count := Sendinit_Count + 1;
    if (Sendinit_Count > 6) then begin
      state := Abort;
      showmsg(12);
      exit;
      end;
    xmitstr(ENQ + #01);
    getpack;
    case ptype of
      TM : state := S1;
      RI : state := S;
      RR : state := SH;
      RF : state := SD;
      CN : state := C;
      NR : state := Start;
      TX : disppacket;
      else begin
           state := Abort;
           showmsg(13);
           end;
      end;
    end;



procedure Sendhdr;

  var
    stlen : byte;

  begin
    temp := pkfname + NUL + filesize + NUL;
    xferhdr := temp;
    showheader;                          {display}
    stlen := length(temp);
    xmitstr(SOH + chr(stlen) + temp);
    getpack;
    case ptype of
      RF : state := SD;
      CN : state := C;
      NR : state := Start;
      TX : disppacket;
      else begin
           state := Abort;
           if (ptype = TM) then showmsg(12)
             else showmsg(13);
           end;
      end;
    end;



procedure Senddata;

  var
    i,cnt : integer;
    bte : byte;
    temp : array [1..256] of char;
    ch: char;
    scancode: integer;

  begin
    if inready then begin     {we shouldnt be getting a packet   }
      getpack;                {unless they sent a Cancel or Text }
      if (ptype = CN) then begin
        state := C;
        exit;
        end
      else if (ptype = TX) then
        disppacket
      else begin
        writeln('Unexpected packet type during Send!');
        state := Abort;
        exit;
        end;
      end;
    cnt := 0;
    while (not eof(pkfile)) and (cnt < 256) do
      begin
      cnt := cnt + 1;
      read(pkfile,bte);
      temp[cnt] := chr(bte);
      end;
    if cnt <> 0 then
      begin
      if cnt = 256 then bte := 0 else bte := cnt;
      xmitstr(STX + chr(bte));
      for i := 1 to cnt do
        xmitchar(temp[i]);
      end;
    if cnt < 256 then state := SE;
    xfercnt := xfercnt + cnt;
  end;


procedure SendEOF;

  begin
    xmitstr(ETX + #01);
    getpack;
    case ptype of
      AF : state := ST;
      TX : disppacket;
      else begin
           state := Abort;
           if (ptype = TM) then showmsg(12)
             else showmsg(13);
           end;
      end;
    end;


procedure SendEOT;

  begin
    xmitstr(EOT + #01);
    getpack;
    case ptype of
      AT : state := Start;  {Ack ok}
      TX : disppacket;
      else state := Start;  {They sent AF - so dont worry about it}
    end;
  end;


procedure Receive;

  begin
    getpack;
    case ptype of
      SI : begin
           showmsg(1);
           xmitstr(ACK + #01);
           state := RH;
           end;
      CN : state := C;
      TX : disppacket;
      else begin
           state := Abort;
           if (ptype = TM) then showmsg(12)
             else showmsg(13);
           end;
      end;
end;


procedure RcvHdr;

var
  i : integer;
  temp : line;

  begin
    temp := '';
    getpack;
    case ptype of
      HD : begin
           for i := 1 to pklen
             do temp := temp + pkbuff[i];
           xferhdr := temp;
           showheader;
           xmitstr(ACK + #02);
           state := RD;
           end;
      SI : state := RH;
      CN : state := C;
      ET : begin
           xmitstr(ACK + #04);
           state := Start;
           end;
      TX : disppacket;
      else begin
           state := Abort;
           if (ptype = TM) then showmsg(12)
             else showmsg(13);
           end;
      end;
    end;


procedure RcvData;

var
  i : integer;
  bte : byte;

  begin
    getpack;
    case ptype of
      DT : begin
           for i := 1 to pklen do
             begin
             bte := ord(pkbuff[i]);
             write(pkfile,bte);
             end;
           xfercnt := xfercnt + pklen;
           showbytes;
           state := RD;
           end;
      EF : begin
           close(pkfile);
           xferok := TRUE;
           showmsg(8);
           xmitstr(ACK + #03);
           state := RH;
           end;
      CN : state := C;
      TX : disppacket;
      else begin
           state := Abort;
           if (ptype = TM) then showmsg(12)
             else showmsg(13);
           end;
      end;
    end;



procedure Cancel;

  begin
    xmitstr(CAN + #00);
    state := CW;
  end;


procedure CanWait;

  begin
    escmsg(10);
    getpack;
    case ptype of
      CA : state := Start;
      CN : xmitstr(ACK + #05);
      TM : state := Start;
      UK : state := Start;
      TX : disppacket;
      else;
    end;
  end;



procedure CanRecd;

var
  i : integer;
  bte : byte;

  begin
    showmsg(11);
    xmitstr(ACK + #05);
    delay(3000);   {see if this helps the stupid TNC-2s problem!}
    state := Start;
  end;



procedure xfer;

begin
  xferhdr := '';
  xfercnt := 0;
  xmitline('t');   {put TNC into transparent mode}
  delay(50);
  txtbuff := '';
  repeat
    showstate;     {display state}
    case state of
      S: Sendinit;
     S1: Sendinit_retry;
     SH: Sendhdr;
     SD: Senddata;
     SE: SendEOF;
     ST: SendEOT;
      R: Receive;
     RH: Rcvhdr;
     RD: Rcvdata;
  Abort: Cancel;
     CW: CanWait;
      C: CanRecd;
    else;
    end; {case}
  until (state = Start);

  write(#07);     {bell}
  delay(1000);    {give TNC some time}
  cmdmode;        {get into command mode}
  flush;
  xmitline('conv');  {back to converse mode}
end;


procedure upload;

  begin
    pkfname := getfilname('Upload Filename: ');
    Assign(pkfile,pkfname);
    reset(pkfile);
    state := S;
    xfer;
    close(pkfile);
  end;


procedure download;

  begin
    pkfname := getfilname('Enter Filename: ');
    assign(pkfile,pkfname);
    rewrite(pkfile);
    state := R;
    xferok := FALSE;
    xfer;
    if not xferok then begin
      close(pkfile);
      erase(pkfile);
      end;
  end;