Columbia Kermit/kermit.zip/archives/ucsdibmpc.zip/kermutil.text

Text File | 1984-05-23 | 13KB | 493 lines

unit kermutil;

{ Change log:

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

interface

   uses {$U kermglob.code} kermglob;


   function read_ch(unitno: integer; var ch: char): boolean;

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

   procedure echo(ch: char);

   procedure clear_buf(unitno:integer);

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

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

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

   procedure uppercase(var s: string255);

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

   procedure io_error(i: integer);

   procedure debugwrite(s: string255);

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

   function min(x,y: integer): integer;

   function tochar(ch: char): char;

   function unchar(ch: char): char;

   function ctl(ch: char): char;

   function getch(var r: char_int_rec): boolean;

   function getsoh: boolean;

   function getfil(filename: string255): boolean;

   procedure send_brk;

   procedure setup_comm;

   procedure write_ch(unitno: integer; ch: char );

   procedure screen( scrcmd: scrcommands );

   procedure writescreen(s: string255);

   procedure refresh_screen(numtry, num: integer);


implementation

uses {$U remunit.code} remunit,  {SP, 1/14/84}
     {$U kernel.code} kernel;


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


 screen -- perform screen operations
procedure screen{( scrcmd: scrcommands )};
begin
   { for portability, peek in at syscom vector to get control chars }
   with syscom^ do begin
      if crtctrl.prefixed[ord(scrcmd)] then
         write( crtinfo.prefix );

      with crtctrl do
         case scrcmd of
            sc_up:       write( rlf );
            sc_right:    write( ndfs );
            sc_clreol:   write( eraseeol );
            sc_clreos:   write( eraseeos );
            sc_home:     write( home );
            sc_escape:   write( escape );
            sc_left:     write( backspace );
            sc_clrall:   write( clearscreen );
            scr_clrline: write( clearline )
         end
   end
end; { screen }


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 begin
          ch := ' ';
          unitread( keyport, ch, 1,, 12 )
       end
       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;


procedure setup_comm;
 SP, 14 Jan 84
var
   result: cr_baud_result;
begin
   cr_setcommunications(false,
                        false,
                        baud,
                        8,
                        1,
                        cr_orig,
                        'IBM PC',
                        result );
end;


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

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

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put the two numbers in variant record *)
    yrec.i := y;
    temp.b := xrec.b and yrec.b;  (* use as booleans to 'and' them *)
    aand := temp.i                (* return integer result *)
  end; (* aand *)


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

(* arithmetic or *)

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put two numbers in variant record *)
    yrec.i := y;
    temp.b := xrec.b or yrec.b;   (* use as booleans to 'or' them *)
    aor := temp.i                 (* return integer result *)
  end; (* aor *)

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

(* exclusive or *)

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put two numbers in variant record *)
    yrec.i := y;
                                  (* use as booleans to 'xor' them *)
    temp.b := (xrec.b or yrec.b) and (not(xrec.b and yrec.b));
    xor := temp.i                 (* return integer result *)
  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*);

  begin
    gotoxy( 0, errorline );
    screen( sc_clreol );
    case i of
        0: writeln('No error');
        1: writeln('Bad Block, Parity error (CRC)');
        2: writeln('Bad Unit Number');
        3: writeln('Bad Mode, Illegal operation');
        4: writeln('Undefined hardware error');
        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')
      end; (* case *)
    gotoxy(0,promptline)
  end; (* io_error *)

procedure debugwrite(*s: string255*);

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

  begin
    if debug then
      begin
        gotoxy(0,debugline);
        screen( sc_clreol );
        write(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(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 *)
const
   maxtry = 30000;

var count, cursorx, cursory:integer;
 The DataMedia emulation is by John Socha.
begin
   ch := chr(aand(ord(ch),127)); (* mask off parity bit *)

   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 }
                      count := 0;
                      repeat
                         count := count + 1
                      until read_ch( inport, ch ) or (count>maxtry);
                      if count<=maxtry then begin
                         cursorx:=ord(ch)-32;
                         count := 0;
                         repeat
                            count := count + 1
                         until read_ch( inport, ch ) or (count>maxtry);
                         if count<=maxtry then begin
                            cursory:=ord(ch)-32;
                            gotoxy(cursorx,cursory)
                         end
                      end
                   end;
         { em }25: screen( sc_home );
         { fs }28: screen( sc_right );
         { us }31: screen( sc_up );
         { gs }29: screen( sc_clreol );
         { vt }11: screen( sc_clreos )
      end
    else
       unitwrite(1,ch,1,,12)  { the 12 eliminates DLE & CR expansion }
  end; (* echo *)


function getch(*var r: char_int_rec): 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 maxtry *)

const maxtry = 10000;

var count: integer;

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


function getsoh(*: boolean*);

(* reads characters until it finds an SOH; returns false if has to read more *)
(* than maxtry chars *)
 modified by SP

const maxtry = 10000;

var ch: char;
    count: integer;

  begin
    count := 0;
    getsoh := true;
    repeat
      repeat
        count := count + 1
      until (read_ch(inport,ch)) or (count > maxtry); (* wait for a character *)
      if (count > maxtry) 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 *)
    rewrite(f,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 *)


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

   ***;  { <-- would you believe that this is Pascal? }

   { termination code }
   syscom^.crtinfo.flush := chr(6);  { turn flush back on }
   syscom^.crtinfo.stop := chr(19)   { effectively turning stop off }

end. { kermutil }