kermit.columbia.edu/kermit.columbia.edu.tar/kermit.columbia.edu/ucsdpecan/kermutil.text

Text File | 1990-08-04 | 17KB | 597 lines

$D OS_ERHDL+}    { indicates to compile to use Pecan's errorhandler unit
$D OS_TIMER+}    { indicates to compile to use TIME() for timeouts

unit kermutil;

{ Change log:
13 May 89, V1.1: Eliminated "int_bool_rec" & misc cleanups   RTC
30 Apr 89, V1.1: Moved set/show & connect from kermit to here   RTC
26 Apr 89, V1.1: Added support for TIMEr controlled timeouts   RTC
16 Apr 89, V1.1: Added procedure flush_comm to Flush REMOTE:    RTC
13 Apr 89, V1.1: Added Version message          RTC
17 Aug 88: Fixed missing EOLN's problem in debf    RTC
14 Aug 88: Fixed the debug messages to all go to debf      RTC
31 Jul 88: Modified setup_comm to funct., updated io_error.    RTC
10 Jul 88: Converted to using screenops unit     RTC
02 Jul 88: Misc cleanup, eliminated char_int_rec, etc.   RTC
26 Jun 88 Patched Unitwrite problem in Echo   RTC
26 Jun 88 Modified read_ch to use cr_getkb    RTC

        13 May 84: Use KERNEL's syscom record for screen control -sp-
}

$I intfutil.text

uses {$U *system.library} screenops, {RTC, 10 Jul 88}
     {$U kermenus.code} kermenus,
     {$U kermpack.code} kermpack (pak_version),
     {$U helper.code} helper (hlp_version),
     {$U parser.code} parser (par_version),
     {$U sender.code} sender (sen_version),
     {$U receiver.code} receiver (rec_version),
     {$U client.code} client (cli_version),
     {$U remunit.code} remunit,  {SP, 1/14/84}
     {$U syslibr:kernel.code} kernel (syscom,version) {$B OS_ERHDL+},
     {$U syslibr:errorhandl.code} error_handling {$E OS_ERHDL+};

const
  my_version = '   Kermutil Unit V1.1, 13 May 89';

type
  time_value = integer[10];

var
  old_flush, old_stop: char;
  time_limit : time_value;

$I setshow.text

procedure connect;

(* connect to remote host and transceive *)

var ch: char;
    close: boolean;

  procedure read_esc;

  (* read character after esc char and interpret it *)

    begin
      repeat
      until read_ch(keyport,ch);       (* wait until they've typed something in *)
      if (ch in ['a'..'z']) then  (* uppercase it *)
          ch := chr(ord(ch) - ord('a') + ord('A'));
      if ch in ['B','C','S','?'] then
          case ch of
              'B': sendbrk;       (* B: send a break to the IBM *)
              'C': close := true; (* C: end connection *)
              'S': begin          (* S: show status *)
                      noun := allsym;
                      showparms
                   end; (* S *)
              '?': begin          (* ?: show options *)
                  writeln
('B    Send a BREAK signal.');
                  writeln
('C    Close Connection, return to KERMIT-UCSD command level.');
                  writeln
('S    Show Status of connection');
                  writeln
('?    Print this list');
                  writeln
('^',ctl(esc_char),'   send the escape character itself to the remote host.')
                end; (* ? *)
            end (* case *)
      else if ch = esc_char then  (* ESC-char: send it out *)
        begin
          if half_duplex then
              write(ch); { changed from echo() by SP }
          write_ch(oport,ch)
        end (* else if *)
      else                        (* anything else: ignore *)
          write(chr(bell))
    end; (* read_esc *)

  begin (* connect *)
    clear_buf(keyport);                    (* empty keyboard buffer *)
    clear_buf(inport);                    (* empty remote input buffer *)
    writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit');
    close := false;
    repeat
        if read_ch(inport,ch) then        (* if char from host then *)
            echo(ch);                   (* echo it *)

        if read_ch(keyport,ch) then        (* if char from keyboard then *)
            if ch <> esc_char then      (* if not ESC-char then *)
              begin
                if half_duplex then       (* echo it if half-duplex *)
                    write(ch); { changed from echo() by sp }
                write_ch(oport,ch)     (* send it out the port *)
              end (* if *)
            else (* ch = esc_char *)    (* else is ESC-char so *)
              read_esc;                   (* interpret next char *)
    until close;                      (* if still connected, get more *)
    writeln('Disconnected')
  end; (* connect *)

procedure uppercase(*var s: string255*);

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 read_ch(*unitno:integer; var ch: char): boolean*);

(* read a character from an input queue *)
var
   ready: boolean;

  begin
    if unitno=keyport then
       ready := cr_kbstat
    else if unitno=inport then
       ready := cr_remstat
    else
       ready := false;
    if ready then            (* if a char there *)
       if unitno=keyport then
          ch := cr_getkb
       else
          ch := cr_getrem;
    read_ch := ready
  end; (* read_ch *)

procedure write_ch(*unitno: integer; ch: char*);
begin
   if unitno=oport then
      cr_putrem( ch )
end;


procedure read_str(*unitno:integer; var s: string255*);

(* acts like readln(s) but takes input from input queue *)

var i: integer;

  begin
    i := 0;
    s := copy('',0,0);
    repeat
      repeat                              (* get a character *)
      until read_ch(unitno,ch);
      if (ord(ch) = backspace) then       (* if it's a backspace then *)
        begin
          if (i > 0) then                   (* if not at beginning of line *)
            begin
              write(ch);                      (* go back a space on screen *)
              write(' ');                     (* erase char on screen *)
              write(ch);                      (* go back a space again *)
              i := i - 1;                     (* adjust string counter *)
              s := copy(s,1,i)                (* adjust string *)
            end (* if *)
        end (* if *)
      else if (ord(ch) <> eoln_sym) then  (* otherwise if not at eoln  then *)
        begin
          write(ch);                        (* echo char on screen *)
          i := i + 1;                       (* inc string counter *)
          s := concat(s,' ');
          s[i] := ch;                       (* put char in string *)
        end; (* if *)
    until (ord(ch) = eoln_sym);           (* if not eoln, get another char *)
    s := copy(s,1,i);                     (* correct string length *)
    writeln                               (* write a line on the screen *)
  end; (* read_str *)


procedure clear_buf(*unitno:integer*);
 modified by SP
begin
   if unitno=keyport then
      unitclear( unitno )
end;


procedure send_brk;
begin
   cr_break
end;


function setup_comm{ : boolean};
 SP, 14 Jan 84
var
   result: cr_baud_result;
begin
   setup_comm := false;
   cr_setcommunications(false,
                        false,
                        baud,
                        8,
                        1,
                        cr_orig,
                        system_id,
                        result );
   case result of
     CR_bad_parameter :
         writeln('Bad Parameter, # Bits or Parity wrong');
     CR_bad_rate :
         writeln('Bad Baud Rate selection');
     CR_set_OK :
         setup_comm := true;
     CR_select_not_supported :
         writeln('Hardware does not support Baud selection')
   end {case}
end;

procedure flush_comm;                {added 16 Apr 89, RTC}

  var
    ch : char;

  begin {flush_comm}
    while CR_remstat do
      ch := CR_getrem   {flush all characters in REMOTE port}
  end {flush_comm};

function aand(*x,y: integer): integer*);

(* arithmetic and--takes 2 integers and ands them, yeilding an integer *)

  begin
    aand := ord(odd(x) and odd(y));  (* use as booleans to 'and' them *)
  end; (* aand *)


function aor(*x,y: integer): integer*);

(* arithmetic or *)

  begin
    aor := ord(odd(x) or odd(y));   (* use as booleans to 'or' them *)
  end; (* aor *)

function xor(*x,y: integer): integer*);

(* exclusive or *)

  begin
    xor := ord( (odd(x) or odd(y)) and not(odd(x) and odd(y)) );
  end; (* xor *)

procedure error(*p: packettype; len: integer*);

(* writes error message sent by remote host *)

var i: integer;

  begin
    gotoxy(0,errorline);
    for i := 0 to len-1 do
        write(p[i]);
    gotoxy(0,promptline);
  end; (* error *)

procedure io_error(*i: integer*);

  var
    message : string;

  begin
    SC_erase_to_EOL( 0, errorline );
    {$B OS_ERHDL+}
    IOR_to_message(i,message);
    {$E OS_ERHDL+} {$B OS_ERHDL-}
    case i of
        0: message := 'No error';
        1: message := 'Bad Block, Parity error (CRC)';
        2: message := 'Bad Unit Number';
        3: message := 'Bad I/O request, Illegal operation';
        4: message := 'Undefined hardware error';
        5: message := 'Lost unit, Volume is no longer on-line';
        6: message := 'Lost file, File is no longer in directory';
        7: message := 'Bad Title, Illegal file name';
        8: message := 'No room, insufficient space';
        9: message := 'No unit, No such volume on line';
        10: message := 'No file, No such file on volume';
        11: message := 'Duplicate file';
        12: message := 'Not closed, attempt to open an open file';
        13: message := 'Not open, attempt to access a closed file';
        14: message := 'Bad format, error in reading real or integer';
        15: message := 'Queue overflow';
        16: message := 'Write Protected volume';
        17: message := 'Illegal Block';
        18: message := 'Illegal Buffer for low-level I/O';
        19: message := 'Illegal Size or Range of File Attribute';
        20: message := 'Attempted read past End of File';
      end; (* case *)
      if i >= 128 then
        begin
          i := i - 128; message := '0';
          while i > 0 do
            begin
              message[1] := chr(ord('0') + i mod 10);
              message := concat(' ',message);
              i := i div 10
            end;
          message := concat('Host Operating System Error #',message)
        end;
    {$E OS_ERHDL-}
    writeln(message);
    gotoxy(0,promptline)
  end; (* io_error *)

procedure debugwrite(*s: string255*);

(* writes a debugging message *)
var i: integer;

  begin
    if debug then
      begin
        SC_erase_to_EOL(0,debugline);
        gotoxy(0,pred(debugline)); writeln(debf);
        write(debf,s);
        for i := 1 to 2000 do ;                (* write debugging message *)
      end (* if debug *)
  end; (* debugwrite *)

procedure debugint(*s: string255; i: integer*);

(* write a debugging message and an integer *)

  begin
    if debug then
      begin
        debugwrite(s);
        write(debf,i)
      end (* if debug *)
  end; (* debugint *)

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 *)

function ctl(*ch: char): char*);

(* ctl toggles control bit: ^A becomes A, A becomes ^A *)

  begin
    ctl := chr(xor(ord(ch),64))
  end; (* ctl *)

procedure echo(*ch: char*);

(* echos a character on the screen *)

var cursorx, cursory:integer;
    ch_buf : packed array [0..1] of char;

 The DataMedia emulation is by John Socha.
begin
   ch := chr(aand(ord(ch),127)); (* mask off parity bit *)
   ch_buf[0] := ch;     {for unitwrite portability      RTC}

   if emulating and (ord(ch) in [30,25,28,31,29,11]) then
      case ord(ch) of
         { Datamedia 1520 emulation }
         { rs }30: begin
                      { allow timeout while waiting for coordinates
                        so computer doesn't freeze }
                      set_timer(2);
                      repeat
                      until read_ch( inport, ch ) or timeout;
                      if not timeout then begin
                         cursorx:=ord(ch)-32;
                         repeat
                         until read_ch( inport, ch ) or timeout;
                         if not timeout then begin
                            cursory:=ord(ch)-32;
                            gotoxy(cursorx,cursory)
                         end
                      end
                   end;
         { em }25: SC_home;
         { fs }28: SC_right;
         { us }31: SC_up;
         { gs }29: SC_erase_to_EOL(SC_find_X,SC_find_Y);
         { vt }11: SC_eras_eos(SC_find_X,SC_find_Y)
      end
    else
       unitwrite(1,ch_buf[0],1,,12)  { the 12 eliminates DLE & CR expansion }
  end; (* echo *)


function getch(*var r: char): boolean*);

(* gets a character, strips parity, returns true if it got a char which *)
(* isn't Kermit SOH, false if it gets SOH or nothing after timeout *)

  begin
    getch := false;
    repeat
    until (read_ch(inport,r)) or timeout;       (* wait for a character *)
    if timeout then                             (* if wait too long then *)
        exit(getch);                            (* get out of here *)
    if parity <> nopar
      then r := chr(aand(ord(r),127));          (* strip parity from char *)
    getch := (r <> chr(soh));                   (* return true if not SOH *)
  end; (* getch *)


function getsoh(*: boolean*);

(* reads characters until it finds an SOH; returns false if has timed out *)

var ch: char;

  begin
    getsoh := true;
    repeat
      repeat
      until (read_ch(inport,ch)) or timeout; (* wait for a character *)
      if timeout then
        begin
            getsoh := false;
            exit(getsoh)
          end; (* if *)
        ch := chr(aand(ord(ch),127));            (* strip parity of char *)
    until (ch = chr(SOH))                        (* if not SOH, get more *)
  end; (* getsoh *)


function getfil(*filename: string255): boolean*);

(* opens a file for writing *)

  begin
    (*$I-*) (* turn i/o checking off *)
    if f_is_binary
      then
        begin
          rewrite(b_file,filename);
          bufpos := 1           {new file... nothing in buffer}
        end
      else rewrite(t_file,filename);
    (*$I-*) (* turn i/o checking on *)
    getfil := (ioresult = 0)
  end; (* getfil *)


procedure writescreen(*s: string255*);

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

begin
   page(output);
   gotoxy(0,titleline);
   write('            Kermit UCSD p-System, Version ', version );
   gotoxy(statuspos,statusline);
   write(s);
   gotoxy(0,packetline);
   write('Number of Packets: ');
   gotoxy(0,retryline);
   write('Number of Tries: ');
   gotoxy(0,fileline);
   write('File Name: ');
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 *)

$B OS_TIMER+
procedure long_time(var t : time_value);

  {this procedure converts the "dual integer" values returned by time()
   to a single "long integer" value, which it returns to the caller}

  var
    i : 0..1;
    hl : array [0..1] of integer;

  begin {long_time}
    t := 0; time(hl[0],hl[1]);
    for i := 0 to 1 do
      begin
        if hl[i] < 0 then t := t + 1;
        t := 65536*t + hl[i]
      end
  end {long_time};
$E OS_TIMER+

procedure set_timer{t : integer};    {added 26 Apr 89, RTC}

  {$B OS_TIMER-}
  const counts_per_second = 1000;        {WARNING!! implementation dependant}
  {$E OS_TIMER-}

  var long_t : time_value;

  begin {set_timer}
    long_t := t; {convert to long format}
    {$B OS_TIMER+}
    long_time(time_limit); time_limit := time_limit + 60*long_t
    {$E OS_TIMER+} {$B OS_TIMER-}
    time_limit := counts_per_second*long_t
    {$E OS_TIMER-}
  end {set_timer};

function timeout {: boolean};        {added 26 Apr 89, RTC}

  {$B OS_TIMER+}
  var this_time : time_value;
  {$E OS_TIMER+}

  begin {timeout}
    {$B OS_TIMER+}
    long_time(this_time);
    timeout := this_time > time_limit
    {$E OS_TIMER+} {$B OS_TIMER-}
    time_limit := time_limit - 1;
    timeout := time_limit <= 0
    {$E OS_TIMER-}
  end {timeout};

procedure utl_version;

begin
   write(my_version);
  {$B OS_TIMER+}
  write(' (with TIMER)');
  {$E OS_TIMER+}
  writeln
end {utl_version};


begin { body of unit kermutil }
   { initialization code }
   old_flush := syscom^.crtinfo.flush;
   old_stop := syscom^.crtinfo.stop;
   syscom^.crtinfo.flush := chr(255);  { effectively turning flush off }
   syscom^.crtinfo.stop := chr(254);   { effectively turning stop off }

   ***;

   { termination code }
   syscom^.crtinfo.flush := old_flush;  { turn flush back on }
   syscom^.crtinfo.stop := old_stop     { turn stop back on }
end. { kermutil }