Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TMODEM.ZIP/TMODEM.IN1

Text File | 1987-06-16 | 27.8 KB | 862 lines

(****************************************************************************)
(*                      DETERMINE MEMORY AVAILABLE                          *)
(****************************************************************************)
   function
      memory   : integer;
   var
      memspace : real;
   begin
      memspace := maxavail;
      if memspace < 0 then
         memspace := 65536.0 + memspace;
      memory := round( (memspace * 16.0) / 1024.0 );
   end;

(****************************************************************************)
(*                         EN-QUE SERIAL PORT INPUT &                       *)
(*                         DE-QUE SERIAL PORT OUTPUT                        *)
(*                             INTERRUPT DRIVEN                             *)
(****************************************************************************)
   procedure
      async_intr_handler;
   begin
      inline ($FB/$50/$53/$51/$52/$57/$56/$06/$1E);
      inline ($2E/$A1/datasegment
             /$8E/$D8);
      int_ident := port[int_ident_reg];
      repeat
         if int_ident = 4 then begin
            line_status := port[line_status_reg] and $1C;
            sin_buffer[sin_store_ptr] := port[base_com_addr];
            if line_status = 0 then begin
               if ascii_mode then begin
                  case sin_buffer[sin_store_ptr] of
                     XOFF : port[int_enable_reg] := 1;
                     XON  : port[int_enable_reg] := 3;
                  end;
               end;
               if sin_store_ptr = sin_buf_size then
                  sin_store_ptr := 1
               else
                  sin_store_ptr := sin_store_ptr + 1;
            end;
         end
         else begin
            if sout_store_ptr = sout_read_ptr then begin
               port[int_enable_reg] := 1;
               sout_int_off := true;
            end
            else begin
               port[base_com_addr] := sout_buffer[sout_read_ptr];
               if sout_read_ptr = sout_buf_size then
                  sout_read_ptr := 1
               else
                  sout_read_ptr := sout_read_ptr + 1;
            end;
         end;
         int_ident := port[int_ident_reg];
      until int_ident = 1;
      port[$20] := $20;
      inline ($1F/$07/$5E/$5F/$5A/$59/$5B/$58/$5D/$5D/$CF);
   end;

(****************************************************************************)
(*                        DE-QUE SERIAL PORT INPUT                          *)
(****************************************************************************)
   function
      read_sin_buffer : char;
   begin
      read_sin_buffer := chr(sin_buffer[sin_read_ptr]);
      if sin_read_ptr = sin_buf_size then
         sin_read_ptr := 1
      else
         sin_read_ptr := sin_read_ptr + 1;
   end;

(****************************************************************************)
(*                       EN-QUE SERIAL PORT OUTPUT                          *)
(****************************************************************************)
   procedure
      store_sout_buffer(ch : char);
   var
      new_sout_store_ptr   : integer;
      cnt                  : integer;
   begin
      if sout_store_ptr = sout_buf_size then
         new_sout_store_ptr := 1
      else
         new_sout_store_ptr := sout_store_ptr + 1;
      cnt := 0;
      while new_sout_store_ptr = sout_read_ptr do begin  { Wait for room }
         cnt := cnt + 1;                                 { in the queue. }
         if cnt > 40 then begin
            sout_store_ptr := sout_read_ptr;
            continue_transfer := false;
            exit;
         end;
         delay(wait_increment);
      end;
      sout_buffer[sout_store_ptr] := ord(ch);
      sout_store_ptr := new_sout_store_ptr;
      if sout_int_off then begin
         sout_int_off := false;
         port[int_enable_reg] := 3;
      end;
   end;

(****************************************************************************)
(*                           SETUP SERIAL PORT                              *)
(****************************************************************************)
   procedure setserial(baudrate,stopbits,databits : integer;
                      parity : parityType);
   var
      parameter : integer;
      parn      : byte;
   begin
      case baudrate of
         300  : begin
                   baudrate:=2;
                   sync_time := wait_increment div 4;
                end;
         1200 : begin
                   baudrate:=4;
                   sync_time := wait_increment div 10;
                end;
         2400 : begin
                   baudrate:=5;
                   sync_time := wait_increment div 20;
                end;
      else
         baudrate:=4;                     { Default to 1200 baud }
         sync_time := wait_increment div 10;
      end;
      if stopbits=2 then
         stopbits:=1
      else
         stopbits:=0;                     { Default to 1 stop bit }
      case parity of
         even : parn:=1;
         odd  : parn:=2;
      else
         parn:=0;
      end;
      if databits=7 then
         databits:=2
      else begin
         databits:=3;                     { Default to 8 data bits }
         parn:=0;
      end;
      parameter:=(baudrate shl 5)+(stopbits shl 2)+databits;
      case parn of
         1 : parameter:=parameter+24;
         2 : parameter:=parameter+8;
      end;
      regs.DX := 0;                       { 0 = COM1;   1 = COM2 }
      regs.AX := parameter;
      regs.FLAGS := 0;
      intr($14,regs);
      port[int_enable_reg] := 1;
      port[modem_control_reg] := $0B;
      port[$21] := port[$21] and turn_IRQ_on;
      sout_int_off := true;
   end;

(****************************************************************************)
(*                         DISPLAY PROMPTS LINE                             *)
(****************************************************************************)
   procedure
      clear_pos( i,j : integer );
   begin
      escape_win;
      textcolor( BGcolor );
      textbackground( FGcolor );
      gotoxy(i,j);
      write(' ');
      textcolor( FGcolor );
      textbackground( BGcolor );
      reset_win;
   end;

   procedure
      display_prompts;
   begin
      escape_win;
      textcolor( BGcolor );
      textbackground( FGcolor );
      gotoxy(1,25);
      clreol;
      write('   Alt: X=Exit, PgDn=Receive, PgUp=Transmit, C=Capture, S=Chg Prms, F10=Help  ');
      textcolor( FGcolor );
      textbackground( BGcolor );
      reset_win;
   end;

(****************************************************************************)
(*                         SAVE CAPTURE BUFFERS                             *)
(****************************************************************************)
   procedure
      save_capture_buffers;
   var
      r        : real;
   begin
      writeln;
      write(' Enter Filename for Capture Buffer Save: ');
      readln(filename);
      if length(filename)=0 then exit;
      assign(recv_file,filename);
      rewrite(recv_file);
      capture_curr := capture_first;
      repeat
         if capture_curr^.capture_store_ptr <= 1024 then
            capture_curr^.capture_buffer[capture_curr^.capture_store_ptr] := ^Z
         else
            capture_curr^.capture_store_ptr := 1024;
         if capture_curr^.capture_store_ptr > 1 then begin
            r := (capture_curr^.capture_store_ptr / 128.0) + 0.999;
            blockwrite(recv_file,capture_curr^.capture_buffer,trunc(r));
         end;
         capture_curr := capture_curr^.capture_next;
      until capture_curr = nil;
      close(recv_file);
   end;

(****************************************************************************)
(*                      ENTER / LEAVE  CAPTURE MODE                         *)
(****************************************************************************)
   procedure
      toggle_capture_mode;
   var
      yes_no   : strtype;
   begin
      if capture_flag then begin
         capture_flag := false;
         mkwin(11,8,67,14,'Exit Capture Mode');
         writeln;
         write(' Do you wish to save capture buffer? ');
         readln(yes_no);
         if upcase(yes_no[1]) = 'Y' then
            save_capture_buffers;
         capture_curr := capture_first;
         repeat
            capture_first := capture_curr;
            capture_curr := capture_curr^.capture_next;
            dispose(capture_first);
         until capture_curr = nil;
         rmwin;
         clear_pos(1,25);
      end
      else begin
         capture_flag := true;
         capture_warning := false;
         escape_win;
         gotoxy(1,25);
         write('*');
         reset_win;
         new(capture_first);
         capture_curr := capture_first;
         capture_curr^.capture_store_ptr := 1;
         capture_curr^.capture_next := nil;
      end;
   end;

(****************************************************************************)
(*                          CAPTURE A CHARACTER                             *)
(****************************************************************************)
   procedure
      capture( c : char );
   begin
      capture_curr^.capture_buffer[capture_curr^.capture_store_ptr] := c;
      capture_curr^.capture_store_ptr := capture_curr^.capture_store_ptr + 1;
      if capture_curr^.capture_store_ptr > 1024 then begin
         if memory < 6 then
            toggle_capture_mode
         else begin
            new(capture_curr^.capture_next);
            capture_curr := capture_curr^.capture_next;
            capture_curr^.capture_store_ptr := 1;
            capture_curr^.capture_next := nil;
            if (not capture_warning and (memory < 10)) then begin
               capture_warning := true;
               escape_win;
               gotoxy(1,25);
               write('W');
               reset_win;
            end;
         end;
      end;
   end;

(****************************************************************************)
(*                             PROCESS ESCAPE                               *)
(****************************************************************************)
   procedure
      wrt( c : char );
   begin
      if c = FF then
         clrscr
      else
         write( c );
      if capture_flag then capture(c);
   end;

   procedure
      set_graphics;
   var
      i     : integer;
      FG,BG : integer;
   begin
      FG := FGcolor;
      BG := BGcolor;
      for i:=1 to escape_number do begin
         case escape_register[i] of
            0 : lowvideo;
            1 : normvideo;
            5 : FG := FG + blink;
            7 : begin
                   FG := BG;
                   BG := FG;
                end;
           30 : FG := black;
           31 : FG := red;
           32 : FG := green;
           33 : FG := yellow;
           34 : FG := blue;
           35 : FG := magenta;
           36 : FG := cyan;
           37 : FG := white;
           40 : BG := black;
           41 : BG := red;
           42 : BG := green;
           43 : BG := yellow;
           44 : BG := blue;
           45 : BG := magenta;
           46 : BG := cyan;
           47 : BG := white;
         else
            ;
         end;
      end;
      textcolor( FG );
      textbackground( BG );
      escape_mode := false;
   end;

   procedure
      addr_cursor;
   begin
      case escape_number of
         0 : begin
                escape_register[1]:=1;
                escape_register[2]:=1;
             end;
         1 : escape_register[2]:=1;
      else
         ;
      end;
      if escape_register[1]=25 then
         gotoxy(escape_register[2],24)
      else
         gotoxy(escape_register[2],escape_register[1]);
      escape_mode := false;
   end;

   procedure
      clear_scr;
   begin
      if ( escape_number = 1 )  and  ( escape_register[1] = 2 ) then
         clrscr;
      escape_mode := false;
   end;

   procedure
      clear_line;
   begin
      if ( escape_number = 1 )  and  ( escape_register[1] = 0 ) then
         clreol;
      escape_mode := false;
   end;

   procedure
      process_escape( c : char );
   var
      i    : integer;
      ch   : char;
   begin
      case c of
         ' ', '['
             : exit;
         'f','H'
             : begin
                  addr_cursor;
                  exit;
               end;
         'J' : begin
                  clear_scr;
                  exit;
               end;
         'k' : begin
                  clear_line;
                  exit;
               end;
         'm' : begin
                  set_graphics;
                  exit;
               end;
      end;
      ch := upcase( c );
      escape_str := escape_str + ch;
      if ch in [ 'A'..'G','L'..'P' ] then exit;
      if ch in [ '0'..'9' ] then begin
         escape_register[escape_number] := (escape_register[escape_number] * 10) + ord( ch ) - ord( '0' );
         exit;
      end;
      case ch of
         ';', ',' : begin
                       escape_number := escape_number + 1;
                       escape_register[escape_number] := 0;
                    end;
         'T', 'S', '#', '+', '-', '>', '<', '.'
                  : ;
      else
         escape_mode := false;
         for i:=1 to length( escape_str ) do
            wrt( escape_str[i] );
      end;
   end;

(****************************************************************************)
(*                             SCREEN HANDLER                               *)
(****************************************************************************)
   procedure
      scrwrite( c : char );
   var
      i  : integer;
   begin
      if c = ESC then begin
         if escape_mode then begin
            for i:=1 to length( escape_str ) do
               wrt( escape_str[i] );
         end;
         escape_str := '';
         escape_number := 1;
         escape_register[escape_number] := 0;
         escape_mode := true;
      end
      else
         if escape_mode then
            process_escape(c)
         else
            wrt( c );
   end;

(****************************************************************************)
(*                       COMMUNICATIONS PROBLEMS !!!                        *)
(****************************************************************************)
   procedure
      ask_operator(var ch : char);
   var
      yes_no   : string[4];
   begin
      mkwin(60,18,80,22,'');
      error_count := 0;
      writeln;
      write(' Continue? y/n ');
      readln(yes_no);
      if upcase(yes_no[1]) = 'Y' then
         ch := NAK
      else begin
         ch := CAN;
         continue_transfer := false;
      end;
      rmwin;
   end;

(****************************************************************************)
(*                              SEND BLOCK                                  *)
(****************************************************************************)
   procedure
      xmit_data(data_block : strtype);
   var
      i         : integer;
   begin
      i := 0;
      while ( i < length(data_block) ) and continue_transfer do begin
         i := i+1;
         store_sout_buffer(data_block[i]);
         if keypressed then begin
            read(kbd,kbd_char);
            ask_operator(kbd_char);
         end;
      end;
      sin_read_ptr := sin_store_ptr;         { Flush the buffer. }
   end;

(****************************************************************************)
(*                             RECEIVE BLOCK                                *)
(****************************************************************************)
   procedure
      recv_data(var data_block : strtype; char_cnt : integer);
   var
      cnt      : integer;
      time     : integer;
      max_loop : byte;
   begin
      data_block := '';
      cnt := 0;
      time := wait_increment;
      max_loop := 40;
      repeat
         if cnt > 0 then
            delay(time);
         if sin_store_ptr <> sin_read_ptr then begin
            data_block := data_block + read_sin_buffer;
            cnt := 0;
            time := sync_time;
            max_loop := 5;
         end
         else
            cnt := cnt + 1;
         if keypressed then begin
            read(kbd,kbd_char);
            ask_operator(kbd_char);
         end;
      until ( cnt > max_loop )
         or ( char_cnt = length(data_block) )
         or ( not continue_transfer );
   end;

(****************************************************************************)
(*                             SYNC WITH REMOTE                             *)
(****************************************************************************)
   procedure
      sync_with_remote;
   begin
      sout_read_ptr := sout_store_ptr;
      delay(sync_time);
      while sin_read_ptr <> sin_store_ptr do begin
         sin_read_ptr := sin_store_ptr;
         delay(sync_time);
         delay(sync_time);
      end;
   end;
   procedure
      sync_NAK;
   var
      i   : integer;
   begin
      for i:=1 to 20 do sync_with_remote;
   end;

(****************************************************************************)
(*                       PROCESS XMODEM INPUT BUFFER                        *)
(****************************************************************************)
   procedure
      process_xmodem_buffer(var xbuf : strtype; var resp : char);
   label
      SEND_NAK;
   var
      i      : integer;
      chk    : integer;
      xcnt   : integer;
   begin
      if length(xbuf) <> 132 then
         goto SEND_NAK;
      if xbuf[1] <> SOH then
         goto SEND_NAK;
      if (ord(xbuf[2]) <> ( ord(xbuf[3]) xor $FF) ) then
         goto SEND_NAK;
      if lo(block_count) = ord(xbuf[2]) then begin
         resp := ACK;
         exit;
      end;
      if lo(block_count + 1) <> ord(xbuf[2]) then
         goto SEND_NAK;
      chk := 0;
      xcnt := xmodem_buf_cnt + 1;
      for i:=4 to 131 do begin
         chk := chk + ord(xbuf[i]);
         xmodem_table[xcnt,i-3] := xbuf[i];
      end;
      if lo(chk) <> ord(xbuf[132]) then
         goto SEND_NAK;
      block_count := block_count + 1;
      xmodem_buf_cnt := xmodem_buf_cnt + 1;
      if xmodem_buf_cnt = max_xmodem_buffers then begin
         blockwrite(recv_file,xmodem_table,max_xmodem_buffers);
         xmodem_buf_cnt := 0;
      end;
      resp := ACK;
      exit;
   SEND_NAK:
      error_count := error_count + 1;
      if error_count > 30 then
         ask_operator(resp)
      else
         resp := NAK;
      sync_NAK;
   end;

(****************************************************************************)
(*                             RECEIVE FILE                                 *)
(****************************************************************************)
   procedure
      receive_file;
   var
      buf          : strtype;
      response     : char;
   begin
      xmodem_buf_cnt := 0;
      error_count := 0;
      block_count := 0;
      continue_transfer := true;
      mkwin(15,4,62,12,'Download XMODEM');
      write(' Enter Filename to Receive: ');
      readln(filename);
      if length(filename)=0 then begin
         rmwin;
         exit;
      end;
      setserial(baud,stopbits,8,paritytype(0));
      assign(recv_file,filename);
      rewrite(recv_file);
      writeln;
      writeln('        Block Count     Error Count');
      writeln('        -----------     -----------');
      writeln;
      sync_with_remote;
      store_sout_buffer( NAK );        { NAK the sender to start things off. }
      recv_data(buf,132);              { Get the 1st block from sender.      }
      while ( buf <> CAN )
        and ( buf <> EOT )
        and ( continue_transfer )
      do begin
         process_xmodem_buffer(buf,response);
         if continue_transfer then begin
            gotoxy(12,5);
            writeln(block_count:4,'              ',error_count:2);
            sync_with_remote;
            store_sout_buffer( response );
            recv_data(buf,132);
         end;
      end;
      sync_with_remote;
      if not continue_transfer then begin
         store_sout_buffer( CAN );
         buf := CAN;
      end;
      if xmodem_buf_cnt > 0 then
         blockwrite(recv_file,xmodem_table,xmodem_buf_cnt);
      close(recv_file);
      setserial(baud,stopbits,databits,paritytype(par));
      if buf = CAN then
         writeln(' File transfer canceled!')
      else begin
         store_sout_buffer( ACK );
         writeln(' File transfer complete.');
      end;
      wait_for_key;
      rmwin;
   end;

(****************************************************************************)
(*                            ALLOCATE BUFFERS                              *)
(****************************************************************************)
   procedure
      get_buffer( var final : boolean );
   begin
      if xmodem_buf_cnt = 0 then begin
         xmodem_rd := 1;
         while ( xmodem_buf_cnt < max_xmodem_buffers ) and ( xmodem_rd <> 0 )
         do begin
            xmodem_buf_cnt := xmodem_buf_cnt + 1;
            blockread(xmit_file,xmodem_table[xmodem_buf_cnt],1,xmodem_rd);
         end;
         xmodem_ptr := 0;
      end;
      xmodem_ptr := xmodem_ptr + 1;
      xmodem_buf_cnt := xmodem_buf_cnt - 1;
      if ( xmodem_buf_cnt = 0 ) and ( xmodem_rd = 0 ) then
         final := true
      else
         final := false;
   end;

(****************************************************************************)
(*                    FORMAT XMODEM OUTPUT BUFFER                           *)
(****************************************************************************)
   procedure
      build_xmodem_buffer(var xbuf : strtype; var last_block : boolean);
   var
      i       : integer;
      chk     : integer;
      ch      : char;
   begin
      get_buffer( last_block );
      xbuf := SOH + chr(lo(block_count)) + chr(lo(block_count) xor $FF);
      chk := 0;
      for i:=1 to 128 do begin
         ch := xmodem_table[xmodem_ptr,i];
         xbuf := xbuf + ch;
         chk := chk + ord( ch );
      end;
      xbuf := xbuf + chr(lo(chk));
   end;

(****************************************************************************)
(*                        GET REMOTE RESPONSE                               *)
(****************************************************************************)
   procedure
      get_response(var resp : char);
   var
      cnt          : integer;
      answer_back  : strtype;
   begin
      cnt := 0;
      repeat
         recv_data(answer_back,1);
         cnt := cnt + 1;
      until ( cnt = 3 ) or ( answer_back <> '' );
      if ( answer_back[1] = CAN ) or ( answer_back = '' ) then begin
         continue_transfer := false;
         resp := CAN;
      end
      else
         resp := answer_back[1];
   end;

(****************************************************************************)
(*                            TRANSMIT FILE                                 *)
(****************************************************************************)
   procedure
      transmit_file;
   var
      buf          : strtype;
      response     : char;
      cnt          : integer;
      last_block   : boolean;
   begin
      error_count := 0;
      mkwin(15,4,62,13,'Upload XMODEM');
      repeat
         write(' Enter Filename to Transmit: ');
         readln(filename);
         if length(filename)=0 then begin
            rmwin;
            exit;
         end;
         assign(xmit_file,filename);
         {$I-}
         reset(xmit_file);
         {$I+}
         ok := (ioresult = 0);
         if not ok then
            writeln(' Cannot find file: ',filename);
      until ok;
      setserial(baud,stopbits,8,paritytype(0));
      writeln(' Files Size is ',filesize(xmit_file)+1,' Blocks.');
      xmodem_buf_cnt := 0;
      block_count := 1;
      build_xmodem_buffer(buf,last_block);
      continue_transfer := true;
      xmit_data('Holding for start of transfer...'+CRLF);
      writeln(' Waiting for start... ');
      writeln;
      get_response(response);
      if response <> CAN then begin
         sync_with_remote;
         xmit_data(buf);
         get_response(response);
         gotoxy(1,3);
         writeln('                                   ');
         writeln('        Block Count     Error Count');
         writeln('        -----------     -----------');
         gotoxy(12,6);
         writeln(block_count:4,'              ',error_count:2);
      end;
      while ( response <> EOT )
        and ( response <> CAN )
        and ( continue_transfer )
      do begin
         sync_with_remote;
         case response of
            NAK : begin
                     error_count := error_count + 1;
                     if error_count > 30 then
                        ask_operator(response);
                     sync_NAK;
                     if continue_transfer then begin
                        xmit_data(buf);
                        get_response(response);
                     end;
                  end;
            ACK : begin
                     if last_block then
                        response := EOT
                     else begin
                        block_count := block_count + 1;
                        build_xmodem_buffer(buf,last_block);
                        xmit_data(buf);
                        get_response(response);
                     end;
                  end;
         else
            response := NAK;
            error_count := error_count + 1;
         end;
         gotoxy(12,6);
         writeln(block_count:4,'              ',error_count:2);
      end;
      sync_with_remote;
      if not continue_transfer then begin
         store_sout_buffer( CAN );
         response := CAN;
      end
      else begin
         cnt := 0;
         repeat
            store_sout_buffer( EOT );
            get_response(response);
            cnt := cnt + 1;
         until ( response = ACK ) or ( response = CAN ) or ( cnt = 5 );
      end;
      close(xmit_file);
      setserial(baud,stopbits,databits,paritytype(par));
      if response = CAN then
         writeln(' File transfer canceled!')
      else
         writeln(' File transmission complete.');
      wait_for_key;
      rmwin;
   end;

(****************************************************************************)
(*                                H E L P                                   *)
(****************************************************************************)
   procedure
      give_help;
   begin
      mkwin(28,1,72,24,'Command List');
      writeln(' Use with the ALT key:');
      writeln;
      writeln('    A = Transmit using ASCII XON/XOFF.');
      writeln('    L = Display the disk directory.');
      writeln('    N = New directory and/or drive.');
      writeln('    V = View a file.   K = Kill a file.');
      writeln('    M = Macro keys, define and modify.');
      writeln('    C = Toggle capture mode ON/OFF.');
      writeln('    S = Change communication parameters.');
      writeln('    D = Modem and dialing management.');
      writeln('    O = Order the dialing directory.');
      writeln('    G = Redial the last number.');
      writeln('    E = Toggle between FULL/HALF duplex.');
      writeln('    Q = Hang up, put modem "ON HOOK".');
      writeln('    W = Wipe the screen, clear it');
      writeln('    X = Terminate and Return to DOS');
      writeln('  F10 = Command List');
      writeln('Pg-Dn = Download a File in XMODEM');
      writeln('Pg-Up = Upload a File in XMODEM');
      writeln;
      wait_for_key;
      rmwin;
   end;