ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/TURBOPAS/TKERMIT.LBR/KSEND.PQS/KSEND.PAS

Pascal/Delphi Source File | 2000-06-30 | 17KB | 502 lines

    procedure check_init(var check_ok : boolean); (* check send init packet *)

      (* This procedure looks at the send init packet or the ack for one
         and matches the data to see if we can communicate.  IT sets up
         what it can if I can live with what the other guy wants.  I don't
         want to be picky if I can help it.  If he doesn't tell me everything
         I make some assumptions that should allow communications.
      *)

      var
        packet_length : integer;

      begin  (* we've got a packet we can work with *)
        if rec_packet_num = packet_num mod 64 then
          check_ok := true;
        packet_length := length(rec_packet);
        if packet_length >= 1 then
          begin
            if unchar(rec_packet[1]) in [4..94] then
              packet_size := unchar(rec_packet[1])
            else
              check_ok := false; (* packets < 4 and > 94 make no sense *)
          end;
        if check_ok then (* let's find out what he wants *)
          begin
            if packet_length >= 3 then (* skip timeout, I can't *)
              my_pad_num := unchar(rec_packet[3]); (* number of pad chars *)
            if packet_length >= 4 then
              my_pad_char := ctl(rec_packet[4]);
            if packet_length >= 5 then
              send_eol := unchar(rec_packet[5]);
            if packet_length >= 6 then
              begin
                if rec_packet[6] = ' ' then
                  his_ctl_quote := quote_char
                else
                  his_ctl_quote := rec_packet[6];
              end
            else
              his_ctl_quote := quote_char;
            if packet_length >= 7 then
              case rec_packet[7] of
                'N' : if quoting then (* we're deadlocked *)
                        check_ok := false;
                'Y' : ; (* we don't care, quoting is all set up *)
                '!'..'>','`'..'~' : begin (* we'll use his quote char *)
                                      quoting := true;
                                      quote_8 := rec_packet[7];
                                    end;
                else
                  check_ok := false; (* he didn't send me a valid char *)
              end (* case *)
            else
              if quoting then
                check_ok := false; (* I'm trying to quote and he won't
                                    acknowledge it *)
          end;
      end; (* check_init *)

  procedure check_ack; (* check ack states for most packets *)

    begin
      ack_ok := false; (* we'll assume a bad packet and prove otherwise *)
      receive_packet;
      if packet_ok and (not abort) then
        begin
          case packet_type of
            ack_pack : if rec_packet_num = packet_num mod 64 then
                         ack_ok := true; (* we better be exact on this one *)
            nak_pack : begin
                         if rec_packet_num = 0 then
                           rec_packet_num := 63
                         else rec_packet_num := rec_packet_num - 1;
                         if rec_packet_num = (packet_num mod 64) then
                           ack_ok := true; (* nak for next is ack for current *)
                       end;
            error_pack : begin (* he must be upset at me *)
                           gotoxy(1,9);
                           write(rec_packet);
                           abort := true;
                         end;
            else
              ack_ok := false; (* if it's another type try to keep sending
                                  I don't know if this is right, but it
                                  sounds logical. *)
          end; (* case *)
        end
      else
        ack_ok := false;
      if debug then
        begin
          gotoxy(1,16);
          write('ack_ok: ', ack_ok,'  packet_num: ',packet_num,
            '  rec_packet_num: ',rec_packet_num);
        end;
      if ack_ok = false then
        packets_bad := packets_bad + 1;
    end;

  procedure send_packet;

    (* This will send a packet that has been prepared by build packet, which
       does most of the work.
    *)

    var
      temp_char : char;

    begin (* send_packet *)
      iobyte := (iobyte and $fc) or port; (* set port *)
      while bios(1) <> 0 do
        bios(2); (* clear input buffer as Columbia recommends *)
      iobyte := (iobyte and $fc) or 1; (* set port to con: *)
      update(packets_sent, packets_bad); (* update the display with new info *)
      if debug then
        begin
          gotoxy(1,17);
          write('Packet length: ', length(packet_buffer));
          gotoxy(1,13);
          write('spack: ');
          for count := 1 to length(packet_buffer) do
            begin
              temp_char := packet_buffer[count]; (* make dummy var *)
              if ord(temp_char) > 127 then       (* 8th bit set *)
                begin
                  temp_char := chr(ord(temp_char) and $7f); (* strip 8th bit *)
                  write('''');  (* show ' for 8th bit and fall through *)
                end;
              if temp_char < ' ' then
                write('^' + ctl(temp_char))
              else write(temp_char);
            end;
        end;
      for count := 1 to length(packet_buffer) do
        send_char(ord(packet_buffer[count]));
    end; (* send_packet *)

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

  procedure build_packet;

      (* This procedure tacks on the things we need for a packet such as
         parity, checksum, padding, and the ^A.
      *)

      var
        checksum, count, index, bit_count : integer;
        temp_pack : string[150];

      begin (* build_packet *)
        checksum := 0;
        packet_buffer := ^A + char40(length(packet_buffer_data) + 2) +
                                char40(packet_num mod 64) + packet_buffer_data;
        for count := 2 to length(packet_buffer) do
          begin
            checksum := checksum + ord(packet_buffer[count]);
          end;
        checksum := ((checksum + ((checksum and 192) div 64)) and 63);
        packet_buffer := packet_buffer + char40(checksum) + chr(send_eol);
        if my_pad_num > 0 then (* add in the padding requested *)
          for count := 1 to my_pad_num do
            packet_buffer := my_pad_char + packet_buffer;
        case parity_type_var of
          mark_parity : for count := 1 to length(packet_buffer) do
                   packet_buffer[count] := chr(ord(packet_buffer[count]) or $80);
          space_parity : for count := 1 to length(packet_buffer) do
                   packet_buffer[count] := chr(ord(packet_buffer[count]) and $7f);
          even_parity, odd_parity : begin
                        for count := 1 to length(packet_buffer) do
                          begin
                            bit_count := 0;
                            temp_pack := packet_buffer;
                            for index := 1 to 7 do
                              begin
                                temp_pack[count] := chr(ord(temp_pack[count])
                                   shr 1);
                                if (ord(temp_pack[count]) and $01 = 1) then
                                  bit_count := bit_count + 1;
                              end;
                            if odd(bit_count) and (parity_type_var =
                              even_parity) then
                              packet_buffer[count] :=
                                chr(ord(packet_buffer[count]) or $80);
                            if (not odd(bit_count)) and (parity_type_var =
                              odd_parity) then
                              packet_buffer[count] :=
                                chr(ord(packet_buffer[count]) or $80);
                          end;
                      end;
        end; (* case *)
      end; (* build_packet *)

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

  procedure quit; (* return to CP/M. *)

    begin (* quit *)
      gotoxy(1,23); (* get cursor back below display *)
      halt;
    end; (* quit *)

  procedure finish; (* finish with server - bye, finish, logout, commands *)

    var
      try : integer;

    begin (* finish *)
      case line_command[1] of
        'F','f' : packet_buffer_data := 'GF';
        'B','b','L','l' : packet_buffer_data := 'GL';
      end; (* case *)
      packet_num := 0;
      try := 0;
      build_packet;
      repeat
        try := try + 1;
        send_packet;
        check_ack;
      until (abort) or (ack_ok) or (try > maxtry);
      if (try > maxtry) or abort then
        begin
          gotoxy(1,9);
          writeln('Unable to logout server.');
        end
        else
          case line_command[1] of   (* we only halt if 'bye' and we logged out *)
            'B','b' : halt;
          end; (* case *)
      gotoxy(1,23); (* get cursor back below display *)
    end; (* finish *)

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

  procedure send; (* send a file to remote host *)

    const
      eof_packet = 'Z';
      break_packet = 'B';

    var
      try : integer;
      send_done : boolean;

    procedure get_file_data; (* read in the file data *)

      var
        char_count : integer;
        temp : char;
        temp_data : string[120];
        end_of_file : boolean;

      begin
        packet_buffer_data := 'D';
        char_count := 1;
        end_of_file := false;
        while not (((filepointer > buffersize) and eof(outfile)) or
          (char_count >= (packet_size - 4)) or end_of_file) do
          begin
           if (filepointer > buffersize) then
             begin
               blockread(outfile, filebuffer, 1);
               filepointer := 1;
               buffer_num := buffer_num + 1;
             end;
           temp := filebuffer[filepointer];
           filepointer := filepointer + 1;
           if (ord(temp) > $7f) and quoting then
             begin
               packet_buffer_data := packet_buffer_data + quote_8;  (* add 8 bit quote char *)
               char_count := char_count + 1;
               temp := chr(ord(temp) and $7f);  (* strip high bit *)
             end;                               (* and fall through *)
           if (ord(temp) and $7f) < ord(' ') then
             begin
               packet_buffer_data :=
                 packet_buffer_data + quote_char + ctl(temp);
               char_count := char_count + 2;
             end
           else
             begin
               if (ord(temp) and $7f) = ord(quote_char) then
                 begin
                   packet_buffer_data := packet_buffer_data + quote_char;
                   char_count := char_count + 1;
                 end;
               packet_buffer_data := packet_buffer_data + temp;
               char_count := char_count + 1;
             end;
           if (file_type_var = ascii) then
             if temp = ^Z then
               begin
                 end_of_file := true;
                 delete(packet_buffer_data,length(packet_buffer_data) - 1, 2);
                  (* delete ^Z at end of packet *)
               end;
        end; (* while *)
        if (end_of_file or ((filepointer > buffersize) and eof(outfile))) then
          begin
            file_done := true;
            close(outfile);
          end
        else
          file_done := false;
      end;

    procedure sinit; (* do send init packet *)

      begin
        packet_num := 0;
        try := 0;
        if (parity_type_var <> no_parity) and (file_type_var = binary) then
            quote_8 := '&'  (* let's try to quote chars with 8'th bit set *)
                            (* We have to if we're to transmit binary *)
        else
          quote_8 := 'Y'; (* I'm willing to quote *)
        if repeating then
          repeat_char := '~'
        else
          repeat_char := ' ';
        packet_buffer_data :=  'S' + char40(packet_size) + char40(timeout)
                               + char40(npad) + ctl(pad) + char40(end_of_line)
                               + quote_char + quote_8 + chk_type
                               + repeat_char;
        build_packet;
        repeat
          ack_ok := false; (* assume its bad until proved otherwise *)
          packets_sent := packets_sent + 1;
          send_packet;
          receive_packet;
          if debug then
            begin
              gotoxy(1,22);
              write('got incoming packet');
            end;
          if (packet_ok and (packet_type = ack_pack) and (not abort)) then
            check_init(ack_ok);
          try := try + 1;
        until ack_ok or abort or (try = maxtry);
        if ack_ok then
          state := send_file_header
        else abort := true;
      end; (* sinit *)

    procedure sheader; (* send file header *)

      begin
        packet_num := packet_num + 1; (* next packet *)
        packet_buffer_data := 'F' + arg1;
        build_packet;
        try := 0;
        repeat
          send_packet;
          check_ack;
          try := try + 1;
        until ack_ok or abort or (try = maxtry);
        if ack_ok then
          state := send_file
        else
          abort := true;
      end; (* sinit *)


    procedure sfile; (* send the file data *)

      begin
        gotoxy(40,2);
        write('Sending...');
        repeat
          packet_num := packet_num + 1;
          get_file_data;
          if length(packet_buffer_data) > 1 then (* packet has data in it *)
            begin
              build_packet;
              try := 0;
              repeat
                send_packet;
                check_ack;
                try := try + 1;
              until ack_ok or abort or (try = maxtry);
            end;
        until file_done or abort or (try = maxtry);
        if file_done then
          state := send_eof
        else
          abort := true;
      end;

    procedure seof; (* send EOF packet *)

      begin
        packet_num := (packet_num + 1) mod 64;
        packet_buffer_data := eof_packet;
        build_packet;
        try := 0;
        repeat
          send_packet;
          check_ack;
          try := try + 1;
        until ack_ok or abort or (try = maxtry);
        if ack_ok then
          state := send_break
        else
          abort := true;
      end;

    procedure sbreak;

      begin
        state := send_break;
        packet_num := (packet_num + 1) mod 64;
        packet_buffer_data := break_packet;
        build_packet;
        try := 0;
        repeat
          send_packet;
          check_ack;
          try := try + 1;
        until ack_ok or abort or ( try = maxtry);
        if ack_ok then
          send_done := true
        else
          abort := true;
        end; (* sbreak *)

    begin (* send *)
      clrscr;
      packets_sent := 0;
      packets_bad := 0;
      send_done := false;
      displayt;
      open_file(read_open, arg1);
      if open_ok then
        begin
          filepointer := buffersize + 1; (* postion pointer beyond end of
                                            buffer so we get a record on entry
                                         *)
          state := send_init;
          repeat
            case state of
              send_init : sinit;
              send_file_header : sheader;
              send_file : sfile;
              send_eof : seof;
              send_break : sbreak;
            end; (* case *)
          until abort or send_done;
          if send_done then
            begin
              gotoxy(40,2);
              write('Completed.     ', bell);
            end
          else
            begin
              gotoxy(40,2);
              write('Aborted        ', bell);
            end;
          if abort and debug then
            begin
              gotoxy(1,18);
              writeln('Abort conditions were:');
              writeln('State during abort was: ', state_str[state]);
              writeln('Quoting was: ',quoting);
            end;
        end;
        gotoxy(1,23);
    end; (* send *)

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

  procedure send_ack;

    var
      q_var : char;

    begin (* send_ack *)
      if (state = receive_init) or (state = get_file) then
        begin
          if quoting then
            q_var := quote_8
          else
            q_var := 'N';
          packet_buffer_data :=  'Y' + char40(packet_size) + char40(timeout)
                               + char40(npad) + ctl(pad) + char40(end_of_line)
                               + quote_char + q_var + chk_type;

        end
      else
        packet_buffer_data := 'Y';
      build_packet;
      send_packet;
    end; (* send_ack *)

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

  procedure send_nak;

    begin
      packet_buffer_data := 'N';
      build_packet;
      send_packet;
    end;