(*>>>>>>>>>>>>>>KERMUTIL>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*)

$S+
$I-
$R-
$V-

UNIT kermutil;  INTRINSIC CODE 20;

INTERFACE

   USES  kermglob;
 
   PROCEDURE upper_case( VAR s : STRING );
 
   FUNCTION  interrupt( int_key : CHAR ) : BOOLEAN;
 
   PROCEDURE error(VAR p: packettype; len: INTEGER);

   PROCEDURE io_error(i: INTEGER);

   PROCEDURE debugwrite( s: STRING);
 
   PROCEDURE packet_write( VAR p : packettype; len : INTEGER );
 
   PROCEDURE ack_write( ptype: CHAR; len,num: INTEGER; VAR data: packettype);
 
   PROCEDURE write_bool( s: STRING; b: BOOLEAN);
 
   PROCEDURE read_str( VAR s : STRING);
 
   PROCEDURE write_ctl( ch : CHAR);

   FUNCTION  test_printer : BOOLEAN;

   FUNCTION min(x,y: INTEGER): INTEGER;

   FUNCTION tochar(ch: CHAR): CHAR;

   FUNCTION unchar(ch: CHAR): CHAR;

   PROCEDURE screen( scrcmd: scrcommands );

   PROCEDURE writescreen( s: STRING);

   PROCEDURE refresh_screen(numtry, num: INTEGER);
 
   PROCEDURE check_apple_char( check: rem_stat_rec);
 
   FUNCTION ctl( ch : CHAR ) : CHAR;
 
   FUNCTION calc_checksum( VAR packet: packettype; len : INTEGER ) : CHAR;


IMPLEMENTATION

PROCEDURE uppercase {var s: string};

var i: integer;

begin
 for i := 1 to length(s) do
     if s[i] in ['a'..'z'] then
         s[i] := chr(ord(s[i]) - ord('a') + ord('A'))
end; (* uppercase *)



FUNCTION interrupt{ (int_key : char) : boolean };

var buflen : packed array[0..7] of 0..255;
    ch : char;

begin
  interrupt := false;  ch := ' ';
  unitstatus( keyport, buflen[0], control_word );
  if buflen[0] > 0
    then begin
           unitread( keyport, ch, 1,, 12 );
           if ch = int_key then interrupt := true;
         end;
end;   {  interrupt  }



PROCEDURE screen{ scrcmd: scr_commands };

begin
  if prefixed[ scrcmd ] then unitwrite( consol, prefix, 1,,12 );
  case scrcmd of
     sc_up      : unitwrite( consol, rlf      , 1,,12 );
     sc_right   : unitwrite( consol, ndfs     , 1,,12 );
     sc_clreol  : unitwrite( consol, eraseol  , 1,,12 );
     sc_clreos  : unitwrite( consol, eraseos  , 1,,12 );
     sc_home    : unitwrite( consol, home     , 1,,12 );
     sc_delchar : unitwrite( consol, delchar  , 1,,12 );
     sc_clrall  : unitwrite( consol, clrscreen, 1,,12 );
     sc_clrline : unitwrite( consol, clrline  , 1,,12 );
     sc_left    : unitwrite( consol, backsp   , 1,,12 );
     sc_down    : unitwrite( consol, lf       , 1,,12 );
  end; { case }
end; { procedure screen }



PROCEDURE error{ var p: packettype; len: integer };

(* writes error message sent by remote host *)

begin
  gotoxy(0,errorline);
  screen( sc_clreol );
  write('Host error : ');
  unitwrite( consol, p[0], len,, 12 );
  gotoxy(0,promptline);
end; (* error *)



PROCEDURE io_error{ i: integer };

begin
 gotoxy( 0, errorline );
 screen( sc_clreol );
 write('IO_ERROR : ');
 case i of
      0: writeln('No error');
      1: writeln('Bad Block, Parity error (CRC)'); {not used for Apple}
      2: writeln('Bad Unit Number');
      3: writeln('Bad Mode, Illegal operation');
      4: writeln('Undefined hardware error'); {not used for Apple}
      5: writeln('Lost unit, Unit is no longer on-line');
      6: writeln('Lost file, File is no longer in directory');
      7: writeln('Bad Title, Illegal file name');
      8: writeln('No room, insufficient space');
      9: writeln('No unit, No such volume on line');
     10: writeln('No file, No such file on volume');
     11: writeln('Duplicate file');
     12: writeln('Not closed, attempt to open an open file');
     13: writeln('Not open, attempt to close a closed file');
     14: writeln('Bad format, error in reading real or integer');
     15: writeln('Ring buffer overflow');
     16: writeln('Diskette is write protected');
   end; (* case *)
 if i = 64 then writeln('Bad block on diskette');
 gotoxy(0,promptline)
end; (* io_error *)



PROCEDURE debugwrite{  s: string };

(* writes a debugging message *)

var j: integer;

begin
  gotoxy( 0, debug_line );
  screen( sc_clreol );
  write('Debug state is ', s );
end; (* debugwrite *)


PROCEDURE packet_write{  var p:packettype; len: integer };

(* writes a packet to the screen for debugging purposes *)

var i : integer;

begin
  gotoxy( 0, pack_line + 2 ); screen( sc_clreol ); gotoxy( 0, pack_line + 1 );
  screen( sc_clreol );
  unitwrite( consol, p[1], ( len-2 ), , 12 );
end; { packet_write }



PROCEDURE ack_write{ ptype: char; len,num: integer; var data: packettype};

(* writes a ack/nack package to the screen for debugging purposes *)

var i : integer;

begin
  gotoxy( 0, ack_line + 1 );
  screen( sc_clreos );
  writeln('type= ',ptype);
  writeln('num = ',num);
  writeln('len = ',len);
  unitwrite(consol, data[0], len,, 12 );
end;  { ack_write }

PROCEDURE write_bool{ s: string; b: boolean};

(* writes message & 'on' if b, 'off' if not b *)

begin
  write(p, s);
  case b of
      true: writeln(p,'ON');
      false: writeln(p,'OFF');
    end; (* case *)
end; (* write_bool *)



PROCEDURE write_ctl{ ch : char };

begin
  if ord(ch) < 32
   then begin
          if ord(ch) = 27  then write(p,'<ESC>')
                           else write(p,'<^',chr(ord(ch)+64),'> ');
        end
   else begin
          if ord(ch) = 127 then write(p,'<DEL>')
                           else write(p,'<',ch,'>  ');
        end;
end;  { write_ctl }


PROCEDURE read_str{ var s : string };

var i, j, k : integer;
         ch : char;
 
begin
  i := 0; s := ''; ch := ' ';
  repeat
    unitread( keyport, ch, 1 );
    if ch = backsp
      then begin
             if i > 0
               then begin
                      if s[i] in ctl_set then j := 5 else j := 1;
                      for k := 1 to j do write( ch, ' ', ch );
                      delete( s, i, 1 );
                      i := i - 1;
                    end;
           end
      else begin
             if  ch  <>  cr
               then begin
                      if i < 80
                        then begin
                               if ch in ctl_set then write_ctl( ch )
                                                else write( ch );
                               i := i + 1;
                               s := concat( s, ' ' );
                               s[i] := ch;
                             end
                        else write( chr(bell) );
                    end;
           end;
  until ch = cr;
  writeln;
end;  { read_str }



FUNCTION  test_printer;

 this function only tests for the presence of a printerinterface card 

begin
  close( pr );
  reset( pr, pr_file );
  test_printer := ( ioresult = 0 );
end;



FUNCTION min{(x,y: integer): integer };

(* returns smaller of two integers *)

begin
 if x < y then min := x else min := y
end; (* min *)



FUNCTION tochar{ (ch: char): char };
 
(* tochar converts a control character to a printable one by adding space *)

begin
 tochar := chr(ord(ch) + ord(' '))
end; (* tochar *)



FUNCTION unchar{ (ch: char): char };

(* unchar undoes tochar *)

begin
  unchar := chr(ord(ch) - ord(' '))
end; (* unchar *)




PROCEDURE writescreen{  s: string };

(* sets up the screen for receiving or sending files *)

begin
   page(output);
   gotoxy( 11, titleline); write('Kermit UCSD p-System : ', s );
   gotoxy( 50, statusline - 1 );
   write('( type '); write_ctl( int_key );
   write(' to break off )');
   gotoxy(0,packetline);
   write('Number of Packets: ');
   gotoxy(0,retryline);
   write('Number of Tries: ');
   gotoxy(0,fileline);
   write('File Name: ');
   if debug then
     begin
       gotoxy(0,packline);
       write('Outgoing Packet:');
       gotoxy(0,ackline);
       write('Incoming Packet:');
     end;
end; (* writescreen *)



PROCEDURE refresh_screen{ numtry, num: integer };

(* keeps track of packet count on screen *)

begin
   gotoxy(retrypos,retryline);
   write(numtry: 5);
   gotoxy(packetpos,packetline);
   write(num: 5)
end; (* refresh_screen *)


PROCEDURE check_apple_char {  check : rem_stat_rec };

 this procedure only works with a special implementation of unitstatus 
 in the attached remin driver. special character checking can be turned
 off or on depending on the value of 'check'. also the remin driver can
 be instructed to pass 7 or 8 bit characters to pascal.                

var  control_word : cntrl_word_rec;

begin
  with control_word do
    begin
      channel := inp;  purpose := control;   special_req := none;
      reserved := 0; filler := 0;
    end;
  unitstatus( inport, check, control_word );
end;  { check_apple_char }


FUNCTION ctl{ ( ch : char ) : char }; EXTERNAL;

 toggles bit 7 of a character: ' controllifies or decontrollifies ' 

FUNCTION calc_checksum{ (var packet:packettype; len:integer):char }; EXTERNAL;

 calculates one character checksum of a packet 


begin
end. { kermutil }