{ ROSXFR.INC - Remote Operating System File Transfer Routines }

overlay procedure transfer(XfrMode: char);
{ Transfer file to/from calling system }
  var
    OK, CRCmode, timeout, EndOfFile: boolean;
    ch, blocknum, notblknum: byte;
    i, vv, sector, errcnt: integer;
    this: FilePtr;
    FileType: String[3];
    XfrName: FileName;
    Buffer: array[1..BufSize] of byte;
    XfrFile: untype_file;

  procedure TypeFile(var XfrFile: untype_file; remaining: integer);
  { Type an ASCII file with XON/XOFF handshaking.  The UnSqueeze segments were
    adapted from USQ.PAS by Scott Loftesness, Ernie LeMay, and Steve Freeman }
    const
      recognize = $FF76;
      DLE       = $90;
    var
      squeezed: boolean;
      x, BufferPtr, bpos, curin, repct, lastc, NoOfRecs: integer;
      DestName: FileName;
      ErrMsg: StrPr;
      dnode: array [0..255, 0..1] of integer;

    function getc: integer;
    { Get an 8 bit value from the input buffer - read block if necessary }
      begin
        if BufferPtr > BufSize
          then
            begin
              if BufBlocks < remaining
                then NoOfRecs := BufBlocks
                else NoOfRecs := remaining;
              if NoOfRecs > 0
                then BlockRead(XfrFile, Buffer, NoOfRecs)
                else EndOfFile := TRUE;
              remaining := remaining - NoOfRecs;
              BufferPtr := 1
            end;
        getc := Buffer[BufferPtr];
        BufferPtr := succ(BufferPtr)
      end;

    function getw: integer;
    { Get a 16 bit value from the input buffer }
      begin
        getw := getc + Swap(getc)
      end;

    procedure BuildTree;
    { Build decode tree }
      var
        i, CheckSum, numnodes: integer;
      begin
        ErrMsg := '';
        i := getw;                          { Is it really a squeezed file? }
        if i = recognize
          then
            begin
              CheckSum := getw;             { Get checksum }
              DestName := '';
              i := getc;                    { Build original file name }
              while i <> 0 do
                begin
                  DestName := DestName + UpCase(chr(i));
                  i := getc
                end;
              numnodes := getw;             { Get the number of nodes in tree }
              if (numnodes <= 256) and (numnodes > 0)
                then for i := 0 to pred(numnodes) do
                  begin
                    dnode[i, 0] := getw;
                    dnode[i, 1] := getw;
                  end
                else ErrMsg := 'Invalid decode tree size.'
            end
          else ErrMsg := 'Not a squeezed file.'
      end;

    function gethuff: integer;
    { Get character coding }
      var
        i: integer;
      begin
        i := 0;
        repeat
          bpos := succ(bpos);
          if bpos > 7
            then
              begin
                curin := getc;
                bpos := 0
              end
            else curin := curin shr 1;
          i := dnode[i, curin and $0001];
        until (i < 0);
        i := -succ(i);
        if i = 0
          then gethuff := 26
          else gethuff := i
      end;

    function getcr: integer;
      var
        c: integer;
      begin
        if repct > 0
          then
            begin
              repct := pred(repct);
              getcr := lastc
            end
          else
            begin
              c := gethuff;
              if c = DLE
                then
                  begin
                    repct := gethuff;
                    if repct = 0
                      then getcr := DLE
                      else
                        begin
                          repct := repct - 2;
                          getcr := lastc
                        end
                  end
                else
                  begin
                    getcr := c;
                    lastc := c
                  end
            end
      end;

    begin { TypeFile }
      i := pos('.', XfrName);
      if i = 0
        then FileType := ''
        else FileType := copy(XfrName, succ(i), length(XfrName));
      squeezed := ('Q' = FileType[2]);
      repct := 0;
      bpos := 8;
      ErrMsg := '';
      BufferPtr := MaxInt;                  { Force a read the first time }
      EndOfFile := FALSE;
      if remaining > 0
        then
          begin
            if squeezed
              then BuildTree
              else DestName := XfrName;
            i := pos('.', DestName);
            if i = 0
              then FileType := ''
              else FileType := copy(DestName, succ(i), length(DestName));
            if (FileType = 'COM') or (FileType = 'BB#') or (FileType = 'LBR') or
               (FileType = 'OBJ') or (FileType = 'EXE') or (FileType = 'CMD')
              then ErrMsg := 'Xmodem protocol required for ".' + FileType + '" files.';
            if ErrMsg = ''
              then
                begin
                  if squeezed
                    then
                      begin
                        writeln(USR, '       --> ', DestName);
                        x := getcr
                      end
                    else x := getc;
                  while (not brk) and (not EndOfFile) and (x <> 26) do
                    begin
                      write(USR, chr(x));
                      if squeezed
                        then x := getcr
                        else x := getc
                    end
                end
          end
        else ErrMsg := 'Missing or empty input file.';
      if ErrMsg <> ''
        then writeln(USR, ErrMsg)
    end;

  procedure updcrc(var crc: integer; acc: integer);
  { Update CRC with passed byte.  Derived from the following:
  ****************************************************************
  *                                                              *
  *   CRCSUBS (Cyclic Redundancy Code Subroutines) version 1.20  *
  *                                                              *
  *     These subroutines will compute and check a true 16-bit   *
  *   Cyclic Redundancy Code for a message of arbitrary length.  *
  *                                                              *
  *     The use of this scheme will guarantee detection of all   *
  *   single and double bit errors, all  errors  with  an  odd   *
  *   number  of  error bits, all burst errors of length 16 or   *
  *   less, 99.9969% of all 17-bit error bursts, and  99.9984%   *
  *   of  all  possible  longer  error bursts.  (Ref: Computer   *
  *   Networks, Andrew S.  Tanenbaum, Prentiss-Hall, 1981)       *
  *                                                              *
  *   CCITT:  X^16 + X^12 + X^5 + 1                              *
  *   CRC-16: X^16 + X^15 + X^2 + 1                              *
  *                                                              *
  *   The CRC generator may be either CCITT (preferred) or       *
  *   CRC-16.                                                    *
  *                                                              *
  *   Designed & coded by Paul Hansknecht, June 13, 1981         *
  *                                                              *
  *   Copyright (c) 1981, Carpenter Associates                   *
  *                  Box 451                                     *
  *                  Bloomfield Hills, MI 48013                  *
  *                  313/855-3074                                *
  *                                                              *
  *   This program may be freely reproduced for non-profit use.  *
  *                                                              *
  *   Converted to Turbo Pascal by Steven Fox                    *
  **************************************************************** }

    var
      carry, carnxt: boolean;
      i: integer;
    begin { updcrc }
      for i := 1 to 8 do
        begin
          carry := (0 <> ($0080 and acc));
          acc := acc shl 1;
          carnxt := (0 <> ($8000 and crc));
          crc := crc shl 1;
          if carry
            then crc := succ(crc);
          if carnxt
            then crc := $1021 xor crc       { Use $8005 for CRC-16 }
        end
    end;

  function GetByte(sec: integer; var timeout: boolean): byte;
  { Get byte from modem with 'sec' seconds timeout }
    var
      count: real;
    begin
      count := sec * lps * 1.48;            { This loop runs a little faster than GetChar }
      repeat
        count := count - 1.0
      until (not mdcarck) or (count < 0.0) or mdinprdy;
      timeout := (count < 0.0);
      if timeout or (not mdcarck)
        then GetByte := ord(NUL)
        else GetByte := mdinp
    end;

  procedure SendFile(var XfrFile: untype_file; remaining: integer);
  { Send a file using Xmodem protocol }
    var
      mm, ss: integer;
    begin
      writeln(USR, XfrName, ' contains ', remaining, ' blocks.');
      send_time(remaining, mm, ss);
      writeln(USR, 'Send time: ', mm, ' minutes ',ss, ' seconds.');
      writeln(USR, 'To cancel, type CTRL-X repeatedly.');
      writeln(USR, 'Ready to send...');
      errcnt := 0;
      repeat
        ch := GetByte(5, timeout);
        CRCmode := (ch = ord('C'));
        if CRCmode
          then
            begin
              writeln('CRC mode requested.');
              errcnt := 0
            end
        else if ch = ord(NAK)
          then
            begin
              writeln('Checksum mode requested.');
              errcnt := 0
            end
          else errcnt := succ(errcnt)
      until (errcnt = 0) or (errcnt >= maxerr);
      sector := 1;
      while (remaining > 0) and (errcnt < maxerr) do
        begin
          blockread(XfrFile, Buffer, 1);
          remaining := pred(remaining);
          repeat
            write(CR, 'Sending block: ', sector);     { Local display of what is happening }
            mdout(ord(SOH));
            mdout(lo(sector));
            mdout(not lo(sector));
            vv := 0;
            for i := 1 to 128 do
              begin
                mdout(Buffer[i]);
                if CRCmode
                  then updcrc(vv, Buffer[i])
                  else vv := vv + Buffer[i]
              end;
            if CRCmode
              then
                begin
                  updcrc(vv, 0);
                  updcrc(vv, 0);
                  mdout(hi(vv))
                end;
            mdout(lo(vv));
            ch := GetByte(10, timeout);
            if ch = ord(ACK)
              then
                begin
                  sector := succ(sector);
                  errcnt := 0
                end
              else
                begin
                  if ch = ord(NAK)
                    then write('  ++ NAK received')
                    else write('  ++ Timeout');
                  errcnt := succ(errcnt);
                  writeln('.  Error ', errcnt, '. ++')
                end
          until (errcnt = 0) or (errcnt >= maxerr)
        end;
      writeln;
      if errcnt = 0
        then
          begin
            repeat
              mdout(ord(EOT));
              if ord(ACK) = GetByte(10, timeout)
                then errcnt := 0
                else errcnt := succ(errcnt);
            until (errcnt = 0) or (errcnt >= maxerr);
            Delay(2000);
            if errcnt = 0
              then writeln(USR, 'Transfer complete.')
              else writeln(USR, 'End of file not acknowledged.')
          end
        else writeln(USR, 'Transfer aborted.');
    end;

  procedure RecvFile(XfrMode: char);
  { Receive a file with XMODEM protocol }

    procedure RecvBlock;
      begin
        if sector = 1
          then if CRCmode
                 then writeln('CRC mode selected.')
                 else writeln('Checksum mode selected.');
        blocknum := GetByte(1, timeout);
        notblknum := not GetByte(1, timeout);
        if (blocknum = lo(sector)) and (blocknum = notblknum)
          then
            begin
              write(CR, 'Receiving block: ', sector);
              vv := 0;
              for i := 1 to 128 do
                begin
                  Buffer[i] := GetByte(1, timeout);
                  if CRCmode
                    then updcrc(vv, Buffer[i])
                    else vv := vv + Buffer[i]
                end;
              i := GetByte(1, timeout);
              if CRCmode
                then
                  begin
                    i := swap(i) or GetByte(1, timeout);
                    updcrc(vv, 0);
                    updcrc(vv, 0)
                  end
                else vv := lo(vv);
              if i = vv
                then blockwrite(XfrFile, Buffer, 1)
                else
                  begin
                    OK := FALSE;
                    if CRCmode
                      then write('  ++ CRC failed')
                      else write('  ++ Checksum failed')
                  end
            end
          else
            begin
              OK := FALSE;
              write('  ++ Block number mismatch');
              repeat
                ch := GetByte(1, timeout)
              until timeout
            end
      end;

    begin { RecvFile }
      CRCmode := TRUE;
      sector := 1;
      errcnt := 0;
      EndOfFile := FALSE;
      writeln(USR, 'Ready to receive...');
      Delay(10000);                         { Wait before trying to start }
      repeat
        OK := TRUE;
        if sector = 1
          then
            begin
              if errcnt > 1                 { Try twice with CRC then toggle }
                then CRCmode := not CRCmode;{   mode each time through }
              if CRCmode
                then mdout(ord('C'))
                else mdout(ord(NAK))
            end;
        ch := GetByte(5, timeout);
        case chr(ch) of
          SOH: RecvBlock;
          EOT: EndOfFile := TRUE;
          else begin
                 if timeout
                   then write('  ++ Timeout')
                   else write('  ++ Received ', ch, ', not SOH');
                 OK := FALSE
               end
        end;
        if OK
          then
            begin
              mdout(ord(ACK));
              sector := succ(sector);
              errcnt := 0
            end
          else
            begin
              mdout(ord(NAK));
              errcnt := succ(errcnt);
              writeln('.  Error ', errcnt, '. ++')
            end
      until EndOfFile or (errcnt >= maxerr);
      writeln;
      OK := EndOfFile
    end;

  begin { transfer }
    XfrName := compress(prompt('File name: ', 12, 'ES'));
    writeln(USR);
    if XfrName <> ''
      then
        begin
          i := pos('.', XfrName);
          if i = 0
            then FileType := ''
            else FileType := copy(XfrName, succ(i), length(XfrName));
          if (XfrMode = 'S') or (XfrMode = 'T')
            then
              begin
                log(4, XfrName);
                BDOS(seldrive, SetDrv);     { 'Log in' drive/user }
                BDOS(getseluser, SetUsr);
                if in_library
                  then
                    begin
                      if 0 = pos('.', XfrName)
                        then XfrName := XfrName + '.';
                      this := LibBase;
                      while (this <> nil) and (XfrName <> compress(this^.fname)) do
                        this := this^.next;
                      if XfrName = compress(this^.fname)
                        then
                          begin
                            seek(LibFile, this^.index);
                            if XfrMode = 'S'
                              then SendFile(LibFile, this^.fsize)
                              else TypeFile(LibFile, this^.fsize)
                          end
                        else writeln(USR, XfrName, ' not found.')
                    end
                  else
                    begin
                      if ((FileType = 'BB#') or (FileType = 'COM'))
                        then writeln(USR, 'Cannot transfer "', FileType, '" files.')
                        else
                          begin
                            Assign(XfrFile, XfrName);
                            {$I-} Reset(XfrFile) {$I-}; { Make sure file exists }
                            if IOresult = 0
                              then
                                begin
                                  if XfrMode = 'S'
                                    then SendFile(XfrFile, FileSize(XfrFile))
                                    else TypeFile(XfrFile, FileSize(XfrFile));
                                  Close(XfrFile)
                                end
                              else writeln(USR, XfrName, ' not found.')
                          end
                    end
              end
            else
              begin
                log(5, XfrName);
                BDOS(seldrive, RcvDrv);          { 'Log in' upload drive/user }
                BDOS(getseluser, RcvUsr);
                Assign(XfrFile, XfrName);
                {$I-} Rewrite(XfrFile) {$I-};    { Try to open file }
                if IOresult = 0
                  then
                    begin
                      if FileType = 'COM'
                        then
                          begin
                            XfrName := copy(XfrName, 1, i) + 'OBJ';
                            writeln(USR, 'Renaming file to ', XfrName);
                          end;
                      writeln(USR, XfrName, ' will be received in a private area.');
                      RecvFile(XfrMode);
                      Close(XfrFile);
                      Delay(2000);
                      if OK
                        then writeln(USR, 'Transfer complete.')
                        else
                          begin
                            Erase(XfrFile);
                            writeln(USR, 'Transfer aborted.  Incomplete file deleted.')
                          end
                    end
                  else writeln(USR, 'Cannot create ', XfrName, '.')
              end;
          BDOS(seldrive, HomDrv);           { Restore default drive/user }
          BDOS(getseluser, HomUsr);
          writeln(USR);
          log(6, '')
        end
  end;