Columbia Kermit/kermit.zip/c/ucpeca.pas

Pascal/Delphi Source File | 2020-01-01 | 141KB | 4,441 lines

|x|*|f6|*|f5|*|f4|*|f3|*|f2|*|f1|{bootstrap the function keys}|.
jff/Change log:/|nsm$log|nqan|{locate & mark the Change log}|.
cfucpecan.p[begin,end]|n|f6ucpecan.p|n|{get specified part}|.
bsmbegin|n2fsbsmend|nqa,|{mark beginning and ending lines of this part}|.
jmend|nf/>>>>/ d|g}|!|*c|f1|f4ramdisk:|f1|n|f5|{save next part to ramdisk:}|.
|f3|f3|f3|f3|f3|f3|f3|f3|f3|f3|f3|f3|f37|n|*|f6|f3|{main extraction sequence}|.
|xsmend|njfk/|d|e|f2|{extraction initialization, replaced by filename}|.
jfd|n|eqa|{remove unwanted filename line}|.
{>>>> KERMIT.TEXT}
program kermit;

(* $R-*) (* turn range checking off *)
(* $L+*)

USES {$u kermglob.code} kermglob,
     {$U kermutil.code} kermutil,
     {$U parser.code}   parser,
     {$U helper.code}   helper,
     {$U sender.code}   sender,
     {$U receiver.code} receiver,
     {$U client.code}   client;

const
  my_version = 'Kermit-UCSD V1.1, 13 May 89';

{Change log:
  13 May 89, V1.1: Fixed "lost debug file" bug   RTC
  30 Apr 89, V1.1: Moved set/show & connect procedures to kermutil   RTC
  30 Apr 89, V1.1: Added KERMENUS unit   RTC
  26 Apr 89, V1.1: Fixed "chained TAKE commands" bug     RTC
  19 Apr 89, V1.1: minor cleanups   RTC
  16 Apr 89, V1.1: Added BYE & FINISH commands       RTC
  15 Apr 89, V1.1: Added GET and PUT commands       RTC
  13 Apr 89, V1.1: Began work on new Version   RTC
  17 Aug 88: Misc. cleanup and bug fixes in LOG command      RTC
  14 Aug 88: Added LOG and CLOSE commands         RTC
  31 Jul 88: Modified for variable system_id       RTC
  02 Jul 88: Added Binary transfers & TAKE command     RTC
  29 Jun 88: Fixed Assorted Bugs in "connect" escape functions  RTC
  Modifications by SP, 25 Oct 1983: adapt to IBM Version IV.1
  Delete keyboard and serial buffering: provided by system already.

  Additional mods by SP, 18 Mar 1984: make all strings 255 chars long

  13 May 84: Incorporate screen control through syscom record entries
             for portability
}

var
  taking_commands : boolean;

procedure initialize;

var ch: char;

  begin
    ker_version := my_version;
    writeln(ker_version);
    writeln(
'   This program uses Library Units (c) 1986 Pecan Software Systems, Inc.');
    writeln(
'   This program may be freely distributed for non-commercial purposes.');
    writeln;
    timint := mytime;
    pad := mypad;
    padchar := chr(mypchar);
    xeol := chr(my_eol);
    esc_char := chr(my_esc);
    quote := my_quote;
    ctlset := [chr(0)..chr(31),chr(del),quote];
    half_duplex := false;
    debug := false;
    {$I-}
    rewrite(debf,'CONSOLE:');
    {$I+}
    emulating := false;
    f_is_binary := false;
    lit_names := false;
    fwarn := false;
    spsiz := max_pack;
    rpsiz := max_pack;
    n := 0;
    parity := nopar;
    initvocab;
    fill_parity_array;
    ibm := false;
    xon := chr(17);
    bufpos := 1;
    bufend := 0;
    baud := defaultbaud;
    system_id := 'UNKNOWN';
    if setup_comm then {baud was ok};
    {$I-}
    reset(cmd_file,'*kermitinfo.text');
    taking_commands := io_result = 0;
    if ioresult <> 0 then close(cmd_file)
    {$I+}
  end; (* initialize *)


procedure closeup;

  begin
    close(debf,lock);
    page( output )
  end; (* closeup *)


  begin (* main kermit program *)
    initialize;
    repeat
        write('Kermit-UCSD> ');
        if taking_commands
          then
            begin
              readln(cmd_file,line);
              writeln(line);
              if eof(cmd_file) then
                begin
                  close(cmd_file);
                  taking_commands := false
                end
            end
          else readstr(keyport,line);
        case parse of
            unconfirmed: writeln('Unconfirmed');
            parm_expected: writeln('Parameter expected');
            ambiguous: writeln('Ambiguous');
            unrec: writeln('Unrecognized command');
            fn_expected: writeln('File name expected');
            ch_expected: writeln('Single character expected');
            null: case verb of
                      consym: connect;
                      helpsym: help;
                      logsym:   begin
                                  {$I-}
                                  case adj of
                                    debugsym:
                                      begin
                                        close(debf,lock);
                                        rewrite(debf,xfilename)
                                      end;
                                  end {case adj};
                                  if ioresult <> 0 then
                                    begin
                                      writeln('Unable to open ',xfilename);
                                      case adj of
                                        debugsym:
                                          begin
                                            close(debf);
                                            rewrite(debf,'CONSOLE:')
                                          end;
                                      end {case adj};
                                    end
                                  else {$I+}
                                    case adj of
                                      debugsym: write(debf,
                                          ker_version,' -- Debug log...');
                                    end
                                end;
                      closesym: begin
                                  {$I-}
                                  case adj of
                                    debugsym: close(debf,lock);
                                  end {case adj};
                                  if ioresult <> 0 then
                                    begin
                                      writeln('Unable to close file');
                                    end;
                                  case adj of
                                    debugsym: rewrite(debf,'CONSOLE:');
                                  end {case adj};
                                  {$I+}
                                end;
                      takesym : begin
                                  {$I-}
                                  if taking_commands
                                    then close(cmd_file);
                                  reset(cmd_file,xfilename);
                                  taking_commands := io_result = 0;
                                  if ioresult <> 0 then close(cmd_file)
                                  {$I+}
                                end;
                      getsym, recsym: begin
                          recsw(rec_ok,verb = getsym);
                          gotoxy(0,debugline);
                          write(chr(bell));
                          if rec_ok then
                              writeln('successful receive')
                          else
                              writeln('unsuccessful receive');
                          (*$I-*) (* set i/o checking off *)
                          if f_is_binary
                            then close(b_file)
                            else close(t_file);
                          (*$I+*) (* set i/o checking back on *)
                          gotoxy(0,promptline);
                        end; (* recsym *)
                      putsym, sendsym: begin
                          uppercase(xfilename);
                          sendsw(send_ok);
                          gotoxy(0,debugline);
                          write(chr(bell));
                          if send_ok then
                              writeln('successful send')
                          else
                              writeln('unsuccessful send');
                          (*$I-*) (* set i/o checking off *)
                          if f_is_binary
                            then close(b_file)
                            else close(t_file);
                          (*$I+*) (* set i/o checking back on *)
                          gotoxy(0,promptline);
                        end; (* sendsym *)
                      finsym,byesym: begin
                          case verb of
                            finsym: line := 'F';
                            byesym: line := 'L';
                          end {case};
                          clientsw(send_ok,'G',line);
                          gotoxy(0,debugline);
                          write(chr(bell));
                          if send_ok then
                              writeln('successful transaction')
                          else
                              writeln('unsuccessful transaction');
                          (*$I-*) (* set i/o checking off *)
                          close(t_file);
                          (*$I+*) (* set i/o checking back on *)
                          gotoxy(0,promptline);
                        end; {generic server command}
                      setsym: set_parms;
                      show_sym: show_parms;
                  end; (* case verb *)
        end; (* case parse *)
     until (verb = exitsym) or (verb = quitsym);
     closeup
   end. (* kermit *)
{>>>> SENDER.TEXT}
{$D AFS-}  { indicates to compile to run without Adv. File Sys.}

unit sender;

interface

{Change log:
13 May 89, V1.1: Misc. cleanups to debug messages   RTC
26 Apr 89, V1.1: minor cleanups   RTC
16 Apr 89, V1.1: Fixed "garbage in buffer" bug         RTC
13 Apr 89, V1.1: Added Version message          RTC
14 Aug 88: Fixed timeout state bug       RTC
07 Aug 88: Added conditional compilation for AFS/SFS difference    RTC
31 Jul 88: Added Attributes Packets & cancel xfr request from receiver  RTC
10 Jul 88: Converted to use screenops unit     RTC
10 Jul 88: Fixed cleareol problem on filenames      RTC
02 Jul 88: Fixed sinit 8th-bit prefix negotiation bug     RTC
30 Jun 88: Added Binary and multiple file transfers    RTC

}

   procedure sendsw(var send_ok: boolean);

   procedure sen_version;


implementation

uses
   screenops,   {RTC, 10 Jul 88}
   {$U kermglob.code} kermglob,
   {$U kermutil.code} kermutil,
   {$U kermpack.code} kermpack,
   {$B AFS+} {$U syslibr:attribute.code} attributes, {$E AFS+}
   {$U syslibr:wild.code} wild,
   {$U syslibr:dir.info.code} dirinfo;

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


procedure sendsw{(var send_ok: boolean)};

var
  do_attr, still_sending, discard, next_is_empty : boolean;
  files_to_send : D_listp;
  io_status: integer;
  heap: ^integer;
  {$B AFS-}
  this_file : D_listp;
  {$E AFS-}

procedure openfile;

(* resets file of appropriate type *)

  var
    dummy : boolean;

  begin
    if debug then
        debugwrite(concat('Opening ',xfilename));
    (*$I-*) (* turn off compiler i/o checking temporarily *)
    if f_is_binary
      then
        begin
          reset(b_file,xfilename);
          if io_result = 0 then
            {$B AFS+}
            dummy := get_attribute(b_file,FA_lastvalidbyte,last_blksize);
            {$E AFS+} {$B AFS-}
            last_blksize := 512;        {default as we can't determine it}
            {$E AFS-}
          bufend := 0                   {mark the buffer as empty!}
        end
      else reset(t_file,xfilename);
    (*$I+*) (* turn compiler i/o checking back on *)
    io_status := io_result;
    {$B AFS-}
    this_file := files_to_send;
    {$E AFS-}
  end; (* openfile *)

function sinit: char;

(* send init packet & receive other side's *)

var num, len, i: integer;  (* packet number and length *)
    ch: char;

  begin
    if debug then
        debugwrite('sinit');

    if numtry > maxtry then
      begin
        sinit := 'a';
        exit(sinit)
      end;

    num_try := num_try + 1;
    spar(packet);

    clear_buf(inport);

    refresh_screen(numtry,n);

    spack('S',n mod 64,10,packet);

    ch := rpack(len,num,recpkt);

    if (ch = 'N') then
      begin
        sinit := 's';
        exit(sinit)
      end (* if 'N' *)
    else if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then       (* not the right ack *)
          begin
            sinit := currstate;
            exit(sinit)
          end;
        rpar(recpkt,len);
        if (xeol = chr(0)) then   (* if they didn't spec eol *)
            xeol := chr(my_eol);    (* use mine *)
        if (quote = chr(0)) then (* if they didn't spec quote *)
            quote := my_quote;     (* use mine *)
        ctl_set := [chr(0)..chr(31),chr(del),quote];
        if en_qbin then ctl_set := ctl_set + [qbin];
        numtry := 0;
        n := n + 1;              (* increase packet number *)
        sinit := 'f';
        exit(sinit)
      end (* else if 'Y' *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sinit := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then
        sinit := currstate
    else if (ch <> 'N') then
        sinit := 'a'
  end; (* sinit *)

function sattr: char;

(* send attributes packet *)

var num, len: integer;
    ch: char;
    got_attr : boolean;
    {$B AFS+}
    file_date : FA_chron;
    {$E AFS+}
    packet : packettype;

  begin
    if debug then
        debugwrite('sattr');

    if numtry > maxtry then
      begin
        sattr := 'a';
        exit(sattr)
      end;

    num_try := num_try + 1;

    refresh_screen(numtry,n);

    packet[0] := '#';                   { creation date attribute }
    {$B AFS+}
    packet[1] := tochar(chr(12));       { length }
    if f_is_binary
      then got_attr := get_attribute(b_file,FA_revision_date,file_date)
      else got_attr := get_attribute(t_file,FA_revision_date,file_date);
    with file_date,date,time do
    {$E AFS+} {$B AFS-}
    packet[1] := tochar(chr(6));        { length }
    with this_file^.D_date do
    {$E AFS-}
      begin
        packet[2] := chr(year div 10 + ord('0'));
        packet[3] := chr(year mod 10 + ord('0'));
        packet[4] := chr(month div 10 + ord('0'));
        packet[5] := chr(month mod 10 + ord('0'));
        packet[6] := chr(day div 10 + ord('0'));
        packet[7] := chr(day mod 10 + ord('0'));
        {$B AFS+}
        packet[8] := ' ';
        packet[9] := chr(hour div 10 + ord('0'));
        packet[10] := chr(hour mod 10 + ord('0'));
        packet[11] := ':';
        packet[12] := chr(min div 10 + ord('0'));
        packet[13] := chr(min mod 10 + ord('0'))
        {$E AFS+}
      end;

    spack('A',n mod 64,{$B AFS+}14{$E AFS+} {$B AFS-}8{$E AFS-},packet);

    ch := rpack(len,num,recpkt);

    if (ch = 'N') then
      begin
        sattr := 'd';
        exit(sattr)
      end (* if 'N' *)
    else if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then       (* not the right ack *)
          begin
            sattr := currstate;
            exit(sattr)
          end;
        numtry := 0;
        n := n + 1;              (* increase packet number *)
        do_attr := false;
        discard := (len > 0) and (recpkt[0] = 'N');
        if discard
          then sattr := 'z'
          else sattr := 'd';
        exit(sattr)
      end (* else if 'Y' *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sattr := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then
        sattr := currstate
    else if (ch <> 'N') then
        sattr := 'a'
  end; (* sattr *)

function sdata: char;

(* send file data *)

var num, len: integer;
    ch: char;
    packarray: array[boolean] of packettype;
    sizearray: array[boolean] of integer;
    current: boolean;
    b: boolean;

function other(b: boolean): boolean;

(* complements a boolean which is used as array index *)

  begin
    if b then
        other := false
    else
        other := true
  end; (* other *)

  begin
    discard := false;
    current := true;
    packarray[current] := packet;
    sizearray[current] := size;
    next_is_empty := true;
    while (currstate = 'd') do
      begin
        if (numtry > maxtry) then             (* if too many tries, give up *)
            currstate := 'a';

        b := other(current);
        numtry := numtry + 1;

                                          (* send a data packet *)
        spack('D',n mod 64,sizearray[current],packarray[current]);

        refresh_screen(numtry,n);

        if next_is_empty then             (* set up next packet *)
          begin
            sizearray[b] := bufill(packarray[b]);
            next_is_empty := false
          end;

        ch := rpack(len,num,recpkt);      (* receive a packet *)
        if ch = 'N' then                  (* NAK, so just stay in this state *)
            if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
                sdata := currstate
            else                          (* is just like ACK for this packet *)
              begin
                if num > 0 then
                    num := (num - 1)      (* in which case, decrement num *)
                else
                    num := 63;
                ch := 'Y';                (* and indicate an ACK *)
              end; (* else *)

        if (ch = 'Y') then
           begin
             if ((n mod 64) <> num) then (* if wrong ACK *)
               (* stay in same state *)
             else
               begin
                 numtry := 0;
                 n := n + 1;
                 current := b;
                 next_is_empty := true;
                 discard := sizearray[current] = at_badblk;
                 if read_ch(keyport, ch) then {check for user canceling send}
                   begin
                     if ord(ch) in [can_cur,can_all]
                       then discard := true;
                     if ord(ch) = can_all
                       then files_to_send := nil
                   end;
                 if len = 1 then {check for receiver canceling send}
                   begin
                     if recpkt[0] in ['X','Z']
                       then discard := true;
                     if recpkt[0] = 'Z'
                       then files_to_send := nil
                   end;
                 if (sizearray[current] = at_eof) or discard then
                     currstate := 'z'            (* set state to eof *)
                 else
                     currstate := 'd'            (* else stay in data state *)
               end {else}
           end (* if *)
          else if (ch = 'E') then
            begin
              error(recpkt,len);
              currstate := 'a'
            end (* if 'E' *)
          else if (ch = chr(0)) then      (* receive failure, so stay in d *)
          else if (ch <> 'N') then
            currstate := 'a'                  (* on anything else goto abort state *)
      end; (* while *)
    size := sizearray[current];
    packet := packarray[current];
    sdata := currstate
  end; (* sdata *)

function sfile: char;

(* send file header *)

var num, len, i: integer;
    ch: char;
    fn: packettype;
    oldfn: string255;

procedure legalize(var fn: string255);

(* make sure we send only 1 '.' in filename *)

var count, i, j, l: integer;

  begin
    if not lit_names then
      begin
        count := 0;
        l := length(fn);
        for i := 1 to l do                                  (* count '.'s in fn *)
            if fn[i] = '.' then
                count := count + 1;
        for i := 1 to count-1 do                            (* remove all but 1 *)
          begin
            j := 1;
            while (j < l) and (fn[j] <> '.') do
                j := j + 1;                                 (* by finding it *)
            fn := concat(copy(fn,1,j-1),copy(fn,j+1,l-j));  (* and copying around it *)
            l := l - 1
          end (* for i *)
      end;
    i := pos(':',fn);
    if i <> 0 then
      fn := copy(fn,i+1,length(fn)-i)         {remove Vol. name}
  end; (* legalize *)

  begin
    if debug then
        debugwrite('sfile');

    if (numtry > maxtry) then          (* if too many tries, give up *)
      begin
        sfile := 'a';
        exit(sfile)
      end;
    numtry := numtry + 1;

    oldfn := xfilename;
    legalize(xfilename);                (* make filename acceptable to remote *)
    len := length(xfilename);

    moveleft(xfilename[1],fn[0],len);   (* move filename into a packettype *)

    SC_erase_to_EOL(filepos,fileline);
    write(oldfn,' ==> ',xfilename);

    refresh_screen(numtry,n);

    spack('F',n mod 64,len,fn);               (* send file header packet *)

    if next_is_empty then
      begin
        size := bufill(packet);            (* get first data from file *)
        next_is_empty := false
      end;                             (* while waiting for response *)

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
          begin
            sfile := 'f';
            exit(sfile)                (* is just like ACK for this packet *)
          end
        else
          begin
            if (num > 0) then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then  (* if wrong ACK, stay in F state *)
          begin
            sfile := 'f';
            exit(sfile)
          end;
        numtry := 0;
        n := n + 1;
        do_attr := en_attr;
        sfile := 'd';
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sfile := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then  {stay in f state}
        sfile := 'f'
    else if (ch <> 'N') then (* don't recognize it *)
        sfile := 'a'
  end; (* sfile *)

function seof: char;

(* send end of file *)

var num, len: integer;
    ch: char;

  begin
    if debug then
        debugwrite('seof');

    if (numtry > maxtry) then          (* if too many tries, give up *)
      begin
        seof := 'a';
        exit(seof)
      end;
    numtry := numtry + 1;

    refresh_screen(numtry,n);

    packet[0] := 'D';           {set up in case of discard}

    spack('Z',(n mod 64),ord(discard),packet);    (* send end of file packet *)

    if debug then
        debugwrite('seof1');

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
          begin
            seof := 'z';
            exit(seof)                 (* is just like ACK for this packet *)
          end
        else
          begin
            if num > 0 then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if debug then
            debugwrite('seof2');
        if ((n mod 64) <> num) then     (* if wrong ACK, stay in Z state *)
          begin
            seof := 'z';
            exit(seof)
          end;
        numtry := 0;
        n := n + 1;
        if debug then
            debugwrite(concat('Closing ',xfilename));
        if f_is_binary
          then close(b_file)
          else close(t_file);
        while files_to_send <> nil do with files_to_send^ do
          begin
            xfilename := concat(D_volume,':',D_title);
            seof := 'f';
            next_is_empty := true;

            openfile;
            files_to_send := D_next_entry;
            if io_status <> 0
              then io_error(io_status)
              else exit(seof)
          end {while};
        seof := 'b'
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        seof := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then         (* receive failed, so stay in z state *)
        seof := 'z'
    else if (ch <> 'N') then           (* other error, just abort *)
        seof := 'a'
  end; (* seof *)

function sbreak: char;

var num, len: integer;
    ch: char;

(* send break (end of transmission) *)

  begin
    if debug then
        debugwrite('sbreak');

    if (numtry > maxtry) then          (* if too many tries, give up *)
      begin
        sbreak := 'a';
        exit(sbreak)
      end;
    numtry := numtry + 1;

    refresh_screen(numtry,n);

    spack('B',(n mod 64),0,packet);    (* send Break Transfer packet *)

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
          begin
            sbreak := 'b';
            exit(sbreak)               (* is just like ACK for this packet *)
          end
        else
          begin
            if num > 0 then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then    (* if wrong ACK, stay in B state *)
          begin
            sbreak := 'b';
            exit(sbreak)
          end;
        numtry := 0;
        n := n + 1;
        sbreak := 'c'                  (* else, switch state to complete *)
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sbreak := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then         (* receive failed, so stay in b state *)
        sbreak := 'b'
    else if (ch <> 'N') then           (* other error, just abort *)
        sbreak := 'a'
  end; (* sbreak *)

(* state table switcher for sending *)

  begin (* sendsw *)
    mark(heap);
    send_ok := false;
    still_sending :=
        D_dirlist(xfilename,[D_code..D_svol],files_to_send,false) = D_okay;
    if files_to_send <> nil then with files_to_send^ do
      begin
        xfilename := concat(D_volume,':',D_title);
        next_is_empty := true;

        openfile;
        files_to_send := D_next_entry;
        if io_status <> 0 then
          begin
            io_error(io_status);
            still_sending := false
          end
      end;

    if still_sending then write_screen('Sending');
    currstate := 's';
    n := 0;       (* set packet # *)
    numtry := 0;
    flush_comm;         {flush any garbage in buffer}

    while still_sending do
        if currstate in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then
          case currstate of
              'd': if do_attr
                     then currstate := sattr
                     else currstate := sdata;
              'f': currstate := sfile;
              'z': currstate := seof;
              's': currstate := sinit;
              'b': currstate := sbreak;
              'c': begin
                     send_ok := true;
                     still_sending := false
                   end; (* case c *)
              'a': still_sending := false
            end (* case *)
        else (* state not in legal states *)
          begin
            debugwrite('Unknown State');
            still_sending := false
          end (* else *);
    release(heap)
  end; (* sendsw *)

procedure sen_version;

  begin
    writeln(my_version)
  end {sen_version};

end. { sender }
{>>>> RECEIVER.TEXT}
{$D AFS-}       {indicates for compile to run without Adv. File Sys.}

unit receiver;

interface

{Change log:
18 May 89, V1.1: Added debugdate to reread file dates (fixed date bug[??]) RTC
13 May 89, V1.1: Misc. cleanup to debug messages   RTC
30 Apr 89, V1.1: Fixed receiver won't stop on maxtry bug   RTC
26 Apr 89, V1.1: minor cleanups   RTC
16 Apr 89, V1.1: Fixed "garbage in buffer" bug       RTC
16 Apr 89, V1.1: Fixed "short text filename" bug.   RTC
15 Apr 89, V1.1: Added GET protocol & debug logging of date set result    RTC
13 Apr 89, V1.1: Added version message          RTC
17 Aug 88: Fixed garbage after partial last block of bin. file    RTC
07 Aug 88: Added conditional compilation for AFS/SFS differences   RTC
31 Jul 88: Added Attribute Packets & user discard requests to sender   RTC
10 Jul 88: Converted to use screenops unit     RTC
10 Jul 88: Fixed cleareol problem on filenames     RTC
02 Jul 88: Added binary file transfer & discard protocol   RTC

}

  procedure recsw(var rec_ok: boolean; get_from_server : boolean);

  procedure rec_version;


implementation

uses
   screenops,   {RTC, 10 Jul 88}
   {$U kermglob.code} kermglob,
   {$U kermutil.code} kermutil,
   {$U kermpack.code} kermpack,
   {$B AFS+}
   {$U syslibr:attribute.code} attributes;
   {$E AFS+} {$B AFS-}
   {$U syslibr:wild.code} wild,
   {$U syslibr:dir.info.code} dirinfo;
   {$E AFS-}

const
  my_version = '   Receiver Unit V1.1, 18 May 89';

{$B AFS-}
procedure debugdate;

  var
    heap : ^integer;
    list : D_listp;
    rslt : D_result;

  begin {debugdate}
    mark(heap);
    rslt := D_dirlist(xfilename,[Dvol..Ddir],list,false);
    if rslt <> D_okay then debugwrite('Can''t Access File Date');
    if debug then with list^,D_date do
      begin
        debugwrite('');
        write(debf,'File ',D_volume,':',D_title,' Current Date = ',
              month,'/',day,'/',year)
      end;
    release(heap)
  end {debugdate};
{$E AFS-}

procedure recsw{(var rec_ok: boolean; get_from_server : boolean)};

var
  date_attr : record
                valid : boolean;
                value : {$B AFS+} FA_chron {$E AFS+}
                        {$B AFS-} D_daterec {$E AFS-}
              end;

function bufattr(buffer : packettype; len : integer) : integer;

  var
    sp_pos,i,j,buffered : integer;
    tempattr : string;

  begin {bufattr}
    packet[0] := 'Y'; buffered := 1;    {agree to accept file}
    i := 0; while i < len do
      begin
        if buffer[i] in ['#'] then      {acceptable attribute}
          begin
            tempattr := '';
            for j := 1 to ord(unchar(buffer[succ(i)])) do
              begin
                tempattr := concat(tempattr,' ');
                tempattr[length(tempattr)] := buffer[succ(i) + j]
              end;
            case buffer[i] of
              '#' : with date_attr,value {$B AFS+},date,time{$E AFS+} do
                begin
                  sp_pos := pos(' ',tempattr);
                  if sp_pos = 0 then sp_pos := succ(length(tempattr));
                  year := (ord(tempattr[sp_pos-6]) - ord('0')) * 10
                        + (ord(tempattr[sp_pos-5]) - ord('0'));
                  month := (ord(tempattr[sp_pos-4]) - ord('0')) * 10
                         + (ord(tempattr[sp_pos-3]) - ord('0'));
                  day := (ord(tempattr[sp_pos-2]) - ord('0')) * 10
                       + (ord(tempattr[sp_pos-1]) - ord('0'));
                  {$B AFS+}
                  if length(tempattr) > sp_pos then
                    begin
                      hour := (ord(tempattr[sp_pos+1]) - ord('0')) * 10
                            + (ord(tempattr[sp_pos+2]) - ord('0'));
                      min := (ord(tempattr[sp_pos+4]) - ord('0')) * 10
                            + (ord(tempattr[sp_pos+5]) - ord('0'))
                    end
                  else          {no time provided}
                    begin
                      hour := 24 {non-valid time}; min := 0
                    end;
                  {$E AFS+}
                  valid := true
                end
            end {case}
          end
        else                            {reject attribute}
          begin
            packet[buffered] := buffer[i];
            buffered := succ(buffered)
          end;
        i := succ(succ(i) + ord(unchar(buffer[succ(i)])))
      end;
    bufattr := buffered
  end {bufattr};

function rdata: char;

(* receive file data *)

var dummy, num, len: integer;
    ch: char;
    {$B AFS+}
    did_attr : boolean;
    {$E AFS+}
    i: integer;

  begin

    repeat
        debugwrite('rdata');

        if numtry > maxtry then
          begin
            currstate := 'a';
            exit(rdata)
          end;
        num_try := num_try + 1;

        ch := rpack(len,num,recpkt);   (* receive a packet *)

        refresh_screen(numtry,n);

        if (ch = 'D') then             (* got data packet *)
          begin
            if (num <> (n mod 64)) then (* wrong packet *)
              begin
                if (oldtry > maxtry) then
                  begin
                    rdata := 'a';      (* too many tries, abort *)
                    exit(rdata)
                  end; (* if *)

                if (num = (pred(n) mod 64)) then (* previous packet again *)
                  begin                (* so re-ACK it *)
                    spack('Y',num,0,packet);
                    numtry := 0;       (* reset try counter *)
                                       (* stay in same state *)
                  end (* if *)
                else                   (* wrong number *)
                    currstate := 'a'       (* so abort *)
              end (* if *)
            else                       (* right packet *)
              begin
                bufemp(recpkt,len);  (* write data to file *)
                if read_ch(keyport, ch) then {check if user wants to can}
                  packet[0] := ctl(ch);
                spack('Y',(n mod 64),ord(ord(ch) in [can_cur,can_all]),
                      packet); (* ACK packet *)
                oldtry := numtry;      (* reset try counters *)
                numtry := 0;
                n := n + 1             (* bump packet number *)
                                       (* stay in data receive state *)
              end (* else *)
          end (* if 'D' *)
        else if ch = 'A' then           { Attributes }
          begin
            if (num <> (n mod 64)) then (* wrong packet *)
              begin
                if (oldtry > maxtry) then
                  begin
                    rdata := 'a';      (* too many tries, abort *)
                    exit(rdata)
                  end; (* if *)

                if (num = (pred(n) mod 64)) then (* previous packet again *)
                  begin                (* so re-ACK it *)
                    spack('Y',num,0,packet);
                    numtry := 0;       (* reset try counter *)
                                       (* stay in same state *)
                  end (* if *)
                else                   (* wrong number *)
                    currstate := 'a'       (* so abort *)
              end (* if *)
            else                       (* right packet *)
              begin
                spack('Y',(n mod 64),bufattr(recpkt,len),packet); (* ACK packet *)
                oldtry := numtry;      (* reset try counters *)
                numtry := 0;
                n := n + 1             (* bump packet number *)
                                       (* stay in data receive state *)
              end (* else *)
          end {if 'A'}
        else if (ch = 'F') then        (* file header *)
          begin
            if (oldtry > maxtry) then
              begin
                rdata := 'a';          (* too many tries, abort *)
                exit(rdata)
              end; (* if *)

            if (num = (pred(n) mod 64)) then (* previous packet again *)
              begin                    (* so re-ACK it *)
                spack('Y',num,0,packet);
                numtry := 0;           (* reset try counter *)
                                               (* stay in same state *)
              end (* if *)
            else
                currstate := 'a'           (* not previous packet, abort *)
          end (* if 'F' *)
        else if (ch = 'Z') then        (* end of file *)
          begin
            if (num <> (n mod 64)) then(* wrong packet, abort *)
              begin
                rdata := 'a';
                exit(rdata)
              end; (* if *)
            spack('Y',n mod 64,0,packet); (* ok, ACK it *)
            if (len = 1) and (recpkt[0] = 'D')
              then
                begin
                  debugwrite(concat('Discarding ',xfilename));
                  if f_is_binary               {discard the file}
                    then close(b_file)
                    else close(t_file)
                end
              else
                begin
                  debugwrite(concat('Closing ',xfilename));
                  if f_is_binary               (* close up the file *)
                    then
                      begin
                        if bufpos > 1               {data in last block}
                          then
                            begin
                              for dummy := bufpos to blksize do
                                filebuf[dummy] := chr(0);
                              dummy := blockwrite(b_file,filebuf,1);
                              dummy := pred(bufpos);
                              {$B AFS+}
                              did_attr :=
                                  put_attribute(b_file,FA_lastvalidbyte,dummy)
                              {$E AFS+}
                            end;
                        {$B AFS+}
                        with date_attr do if valid then {set date}
                          did_attr :=
                              put_attribute(b_file,FA_revisiondate,value);
                        {$E AFS+}
                        close(b_file,lock)
                      end
                    else
                      begin
                        {$B AFS+}
                        with date_attr do if valid then {set date}
                          did_attr :=
                              put_attribute(t_file,FA_creationdate,value);
                        {$E AFS+}
                        close(t_file,lock)
                      end;
                  {$B AFS-}
                  debugdate;
                  with date_attr do if valid then {set date}
                    case D_changedate(xfilename,value,
                         [D_code,D_text,D_data,D_svol]) of
                      D_okay :      debugwrite('Date set OK');
                      D_notfound :  debugwrite('No such File, Date not set');
                      D_nameerror : debugwrite('Name error, Date not set');
                      D_offline :   debugwrite('Volume offline, Date not set');
                      D_other :     debugwrite('Unknown error, Date not set');
                    end {case};
                  debugdate;
                  {$E AFS-}
                end;
            bufpos := 1;                {clean up binary file buffer}
            n :=  n + 1;               (* bump packet counter *)
            currstate := 'f';              (* go to complete state *)
          end (* else if 'Z' *)
        else if (ch = 'E') then        (* error packet *)
          begin
            error(recpkt,len);         (* display error *)
            currstate := 'a'               (* and abort *)
          end (* if 'E' *)
        else if (ch <> chr(0)) then    (* some other packet type, *)
            currstate := 'a'               (* abort *)
    until (currstate <> 'd');
    rdata := currstate
  end; (* rdata *)

function rfile: char;

(* receive file header *)

var num, len: integer;
    ch: char;
    oldfn: string255;
    i: integer;

procedure makename(recpkt: packettype; var fn: string255; l: integer);

function exist(fn: string255): boolean;

(* returns true if file named fn exists *)

var f: file;

  begin
    (*$I-*) (* turn off i/o checking *)
    reset(f,fn);
    exist := (ioresult = 0);
    (*$I+*)
  end; (* exist *)

procedure checkname(var fn: string255);

(* if file fn exists, makes a new name which doesn't *)
(* does this by changing letters in file name until it *)
(* finds some combination which doesn't exitst *)

var ch: char;
    i: integer;

  begin
    i := 1;
    while (i <= length(fn)) and exist(fn) do
      begin
        ch := succ(fn[i]);    {RTC, 13 May 89}
        if not (ch in ['A'..'Z']) then ch := 'A';
        while (ch in ['A'..'Z']) and exist(fn) do
          begin
            fn[i] := ch;
            ch := succ(ch);
          end; (* while *)
        i := i + 1
      end; (* while *)
    end; (* checkname *)

  begin (* makename *)
    fn := copy('               ',1,15);    (* stretch length *)
    moveleft(recpkt[0],fn[1],l);           (* get filename from packet *)
    oldfn := copy(fn, 1,l);                (* save fn sent to show user *)
    fn := copy(fn,1,min(15,l));            (* set length of filename *)
                                           (* and make sure <= 15 *)
    uppercase(fn);
    if not f_is_binary then
        if (pos('.TEXT',fn) <> length(fn)-4) or (length(fn) < 5) then
      begin
        if length(fn) > 10 then
            fn := copy(fn,1,10);           (* can only be 15 long in all *)
        fn := concat(fn,'.TEXT');          (* and we'll add .TEXT *)
      end; (* if *)
    if fwarn then                          (* if file warning is on *)
        checkname(fn);                     (* must check that name unique *)
  end; (* makename *)

  begin (* rfile *)
    debugwrite('rfile');

    if (numtry > maxtry) then         (* if too many tries, give up *)
      begin
        rfile := 'a';
        exit(rfile)
      end;
    numtry := numtry + 1;

    ch := rpack(len,num,recpkt);      (* receive a packet *)

    refresh_screen(numtry,n);

    if ch = 'S' then                  (* send init, maybe our ACK lost *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end; (* if *)

        if num = (pred(n) mod 64) then      (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            spar(packet);             (* with our send init params *)
            spack('Y',num,10,packet);
            numtry := 0;              (* reset try counter *)
            rfile := currstate;           (* stay in same state *)
          end (* if *)
        else                          (* not previous packet, abort *)
          rfile := 'a'
      end (* if 'S' *)
    else if (ch = 'Z') then           (* end of file *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end; (* if *)

        if num = (pred(n) mod 64) then       (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            spack('Y',num,0,packet);
            numtry := 0;
            rfile := currstate            (* stay in same state *)
          end (* if *)
        else
            rfile := 'a'              (* no, abort *)
      end (* else if *)
    else if (ch = 'F') then           (* file header *)
      begin                           (* which is what we really want *)
        if (num <> (n mod 64)) then   (* if wrong packet, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end;

        makename(recpkt,xfilename,len); (* get filename, make unique if filew *)
        SC_erase_to_EOL(filepos,fileline);
        write(oldfn,' ==> ',xfilename);

        if not getfil(xfilename) then  (* try to open new file *)
          begin
            ioerror(ioresult);        (* if unsuccessful, tell them *)
            rfile := 'a';             (* and abort *)
            exit(rfile)
          end; (* if *)

        spack('Y',n mod 64,0,packet); (* ACK file header *)

        {initializations for file attribute data}
        date_attr.valid := false;
        {end of initializations for file attribute data}

        oldtry := numtry;             (* reset try counters *)
        numtry := 0;
        n := n + 1;                   (* bump packet number *)
        rfile := 'd';                 (* switch to data state *)
      end (* else if *)
    else if ch = 'B' then             (* break transmission *)
      begin
        if (num <> (n mod 64)) then            (* wrong packet, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end;
        spack('Y',n mod 64,0,packet); (* say ok *)
        rfile := 'c'                  (* go to complete state *)
      end (* else if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        rfile := 'a'
      end
    else if (ch = chr(0)) then        (* returned false *)
        rfile := currstate                (* so stay in same state *)
    else                              (* some weird state, so abort *)
        rfile := 'a'
  end; (* rfile *)

function rinit: char;

(* receive initialization *)

var num, len: integer;  (* packet number and length *)
    ch: char;
    fn : packettype;

  begin
    debugwrite('rinit');

    if (numtry > maxtry) then         (* if too many tries, give up *)
      begin
        rinit := 'a';
        exit(rinit)
      end;
    numtry := numtry + 1;

    if get_from_server then {ask server for files}
      begin
        len := length(xfilename);
        moveleft(xfilename[1],fn[0],len);
        spack('R', n mod 64, len, fn)
      end;

    ch := rpack(len,num,recpkt); (* receive a packet *)
    refresh_screen(num_try,n);

    if (ch = 'S') then           (* send init packet *)
      begin
        rpar(recpkt,len);            (* get other side's init data *)
        spar(packet);            (* fill packet with my init data *)
        ctl_set := [chr(0)..chr(31),chr(del),quote];
        if en_qbin then ctl_set := ctl_set + [qbin];
        spack('Y',n mod 64,10,packet); (* ACK with my params *)
        get_from_server := false;
        oldtry := numtry;        (* save old try count *)
        numtry := 0;             (* start a new counter *)
        n := n + 1;              (* bump packet number *)
        rinit := 'f';            (* enter file receive state *)
      end (* if 'S' *)
    else if ch = 'Y' then
      begin
        rinit := 'r';
        if n mod 64 = num then {we have the right ACK}
          begin
            get_from_server := false;
            numtry := 0;
            n := n + 1
          end
      end {if 'Y'}
    else if (ch = 'E') then
      begin
        rinit := 'a';
        error(recpkt,len)
      end (* if 'E' *)
    else if (ch = chr(0)) or (ch = 'N')  then
        rinit := 'r'             (* stay in same state *)
    else
        rinit := 'a'             (* abort *)
  end; (* rinit *)

(* state table switcher for receiving packets *)

  begin (* recswok *)
    rec_ok := false;
    writescreen('Receiving');
    currstate := 'r';            (* initial state is receive *)
    n := 0;                  (* set packet # *)
    numtry := 0;             (* no tries yet *)
    flush_comm;         {flush any garbage in buffer}

    while true do
        if currstate in ['d', 'f', 'r', 'c', 'a'] then
          case currstate of
              'd': currstate := rdata;
              'f': currstate := rfile;
              'r': currstate := rinit;
              'c': begin
                     rec_ok := true;
                     exit(recsw)
                   end; (* case c *)
              'a': exit(recsw)
            end (* case *)
        else (* state not in legal states *)
          begin
            debugwrite('Unknown State');
            exit(recsw)
          end (* else *)
  end; (* recsw *)

procedure rec_version;

  begin
    writeln(my_version)
  end {rec_version};

end. { receiver }
{>>>> CLIENT.TEXT}

unit client;

interface

{Change log:
13 May 89, V1.1: Misc. cleanups to debug messages   RTC
30 Apr 89, V1.1: Fixed failure to terminate on maxtry bug   RTC
26 Apr 89, V1.1: minor cleanups   RTC
16 Apr 89, V1.1: Fixed "garbage in buffer" bug        RTC
16 Apr 89, V1.1: Adapted CLIENT Unit from RECEIVE Unit         RTC
}

  procedure clientsw(var cli_ok: boolean; ptype: char; data: string);

  procedure cli_version;


implementation

uses
   screenops,   {RTC, 10 Jul 88}
   {$U kermglob.code} kermglob,
   {$U kermutil.code} kermutil,
   {$U kermpack.code} kermpack;

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

var
  f_save : boolean;             { save area for f_is_binary }

procedure clientsw{(var cli_ok: boolean; ptype: char; data: string)};

function cdata: char;

(* client text data *)

var dummy, num, len: integer;
    ch: char;
    i: integer;

  begin

    repeat
        debugwrite('cdata');

        if numtry > maxtry then
          begin
            currstate := 'a';
            exit(cdata)
          end;
        num_try := num_try + 1;

        ch := rpack(len,num,recpkt);   (* receive a packet *)

        refresh_screen(numtry,n);

        if (ch = 'D') then             (* got data packet *)
          begin
            if (num <> (n mod 64)) then (* wrong packet *)
              begin
                if (oldtry > maxtry) then
                  begin
                    cdata := 'a';      (* too many tries, abort *)
                    exit(cdata)
                  end; (* if *)

                if (num = (pred(n) mod 64)) then (* previous packet again *)
                  begin                (* so re-ACK it *)
                    spack('Y',num,0,packet);
                    numtry := 0;       (* reset try counter *)
                                       (* stay in same state *)
                  end (* if *)
                else                   (* wrong number *)
                    currstate := 'a'       (* so abort *)
              end (* if *)
            else                       (* right packet *)
              begin
                bufemp(recpkt,len);  (* write data to file *)
                if read_ch(keyport, ch) then {check if user wants to can}
                  packet[0] := ctl(ch);
                spack('Y',(n mod 64),ord(ord(ch) in [can_cur,can_all]),
                      packet); (* ACK packet *)
                oldtry := numtry;      (* reset try counters *)
                numtry := 0;
                n := n + 1             (* bump packet number *)
                                       (* stay in data receive state *)
              end (* else *)
          end (* if 'D' *)
        else if (ch = 'X') then        (* text header *)
          begin
            if (oldtry > maxtry) then
              begin
                cdata := 'a';          (* too many tries, abort *)
                exit(cdata)
              end; (* if *)

            if (num = (pred(n) mod 64)) then (* previous packet again *)
              begin                    (* so re-ACK it *)
                spack('Y',num,0,packet);
                numtry := 0;           (* reset try counter *)
                                               (* stay in same state *)
              end (* if *)
            else
                currstate := 'a'           (* not previous packet, abort *)
          end (* if 'X' *)
        else if (ch = 'Z') then        (* end of file *)
          begin
            if (num <> (n mod 64)) then(* wrong packet, abort *)
              begin
                cdata := 'a';
                exit(cdata)
              end; (* if *)
            spack('Y',n mod 64,0,packet); (* ok, ACK it *)
            close(t_file);
            n :=  n + 1;               (* bump packet counter *)
            currstate := 'f';              (* go to complete state *)
          end (* else if 'Z' *)
        else if (ch = 'E') then        (* error packet *)
          begin
            error(recpkt,len);         (* display error *)
            currstate := 'a'               (* and abort *)
          end (* if 'E' *)
        else if (ch <> chr(0)) then    (* some other packet type, *)
            currstate := 'a'               (* abort *)
    until (currstate <> 'd');
    cdata := currstate
  end; (* cdata *)

function cfile: char;

(* client text header *)

var num, len: integer;
    ch: char;
    i: integer;

  begin (* cfile *)
    debugwrite('cfile');

    if (numtry > maxtry) then         (* if too many tries, give up *)
      begin
        cfile := 'a';
        exit(cfile)
      end;
    numtry := numtry + 1;

    ch := rpack(len,num,recpkt);      (* receive a packet *)

    refresh_screen(numtry,n);

    if ch = 'S' then                  (* send init, maybe our ACK lost *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            cfile := 'a';
            exit(cfile)
          end; (* if *)

        if num = (pred(n) mod 64) then      (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            spar(packet);             (* with our send init params *)
            spack('Y',num,10,packet);
            numtry := 0;              (* reset try counter *)
            cfile := currstate;           (* stay in same state *)
          end (* if *)
        else                          (* not previous packet, abort *)
          cfile := 'a'
      end (* if 'S' *)
    else if (ch = 'Z') then           (* end of file *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            cfile := 'a';
            exit(cfile)
          end; (* if *)

        if num = (pred(n) mod 64) then       (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            spack('Y',num,0,packet);
            numtry := 0;
            cfile := currstate            (* stay in same state *)
          end (* if *)
        else
            cfile := 'a'              (* no, abort *)
      end (* else if *)
    else if (ch = 'X') then           (* text header *)
      begin                           (* which is what we really want *)
        if (num <> (n mod 64)) then   (* if wrong packet, abort *)
          begin
            cfile := 'a';
            exit(cfile)
          end;

        if not getfil('console:') then  { try to open console output }
          begin
            ioerror(ioresult);          { if unsuccessful, tell them }
            cfile := 'a';               { and abort }
            exit(cfile)
          end;

        spack('Y',n mod 64,0,packet); (* ACK file header *)

        oldtry := numtry;             (* reset try counters *)
        numtry := 0;
        n := n + 1;                   (* bump packet number *)
        cfile := 'd';                 (* switch to data state *)
      end (* else if *)
    else if ch = 'B' then             (* break transmission *)
      begin
        if (num <> (n mod 64)) then            (* wrong packet, abort *)
          begin
            cfile := 'a';
            exit(cfile)
          end;
        spack('Y',n mod 64,0,packet); (* say ok *)
        cfile := 'c'                  (* go to complete state *)
      end (* else if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        cfile := 'a'
      end
    else if (ch = chr(0)) then        (* returned false *)
        cfile := currstate                (* so stay in same state *)
    else                              (* some weird state, so abort *)
        cfile := 'a'
  end; (* cfile *)

function cinit: char;

(* client initialization *)

var num, len: integer;  (* packet number and length *)
    ch: char;
    cmdpkt : packettype;

  begin
    debugwrite('cinit');

    if (numtry > maxtry) then         (* if too many tries, give up *)
      begin
        cinit := 'a';
        exit(cinit)
      end;
    numtry := numtry + 1;
    len := length(data);
    moveleft(data[1],cmdpkt[0],len);
    spack(ptype, n mod 64, len, cmdpkt);

    ch := rpack(len,num,recpkt); (* receive a packet *)
    refresh_screen(num_try,n);

    if (ch = 'S') then           (* send init packet *)
      begin
        rpar(recpkt,len);            (* get other side's init data *)
        spar(packet);            (* fill packet with my init data *)
        ctl_set := [chr(0)..chr(31),chr(del),quote];
        if en_qbin then ctl_set := ctl_set + [qbin];
        spack('Y',n mod 64,10,packet); (* ACK with my params *)
        oldtry := numtry;        (* save old try count *)
        numtry := 0;             (* start a new counter *)
        n := n + 1;              (* bump packet number *)
        cinit := 'f';            (* enter file receive state *)
      end (* if 'S' *)
    else if ch = 'Y' then
      begin
        cinit := 'c';
        if n mod 64 = num then {we have the right ACK}
          begin
            numtry := 0;
            n := n + 1
          end
      end {if 'Y'}
    else if (ch = 'N') then
      cinit := 'r'
    else if (ch = 'E') then
      begin
        cinit := 'a';
        error(recpkt,len)
      end (* if 'E' *)
    else if (ch = chr(0)) then
        cinit := 'r'             (* stay in same state *)
    else
        cinit := 'a'             (* abort *)
  end; (* cinit *)

(* state table switcher for receiving packets *)

  begin (* clientsw *)
    cli_ok := false;
    writescreen('Talking to Server');
    f_save := f_is_binary; {save for later restore}
    f_is_binary := false;  {client ONLY recieves text}
    currstate := 'r';            (* initial state is receive *)
    n := 0;                  (* set packet # *)
    numtry := 0;             (* no tries yet *)
    flush_comm;         {flush any garbage in buffer}

    while true do
        if currstate in ['d', 'f', 'r', 'c', 'a'] then
          case currstate of
              'd': currstate := cdata;
              'f': currstate := cfile;
              'r': currstate := cinit;
              'c': begin
                     f_is_binary := f_save;
                     cli_ok := true;
                     exit(clientsw)
                   end; (* case c *)
              'a': begin
                     f_is_binary := f_save;
                     exit(clientsw)
                   end (* case a *)
            end (* case *)
        else (* state not in legal states *)
          begin
            debugwrite('Unknown State');
            f_is_binary := f_save;
            exit(clientsw)
          end (* else *)
  end; (* clientsw *)

procedure cli_version;

  begin
    writeln(my_version)
  end {cli_version};

end. { client }
{>>>> HELPER.TEXT}
unit helper;

interface

{Change log:
13 May 89, V1.1: Added SET INTERFACE, COMMENT, and "client" helps   RTC
26 Apr 89, V1.1: minor cleanups   RTC
13 Apr 89, V1.1: Added Version message         RTC
14 Aug 88: Added command helps for SET SYSTEM command      RTC
14 Aug 88: Added LOG and CLOSE help commands         RTC
31 Jul 88: Minor cleanups of help messages      RTC
30 Jun 88: Added -NAMES, -TYPE, and TAKE command helps   RTC

}

   procedure help;

   procedure hlp_version;


implementation

uses {$U kermglob.code} kermglob;

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

procedure keypress;

var ch: char;

  begin
    write('---------------Press any key to continue---------------');
    read( keyboard, ch );
    page(output); {SP}
  end; (* keypress *)

procedure help1;

  var ch: char;

  begin { help1 }
    if (noun = nullsym) then begin
      writeln('KERMIT is a family of  programs that do reliable file transfer');
      writeln('between computers over TTY lines.',
              '  KERMIT can also be used to make the ');
      writeln('microcomputer behave as a terminal',
              ' for a mainframe.  These are the ');
      writeln('commands for the UCSD p-System version, KERMIT-UCSD:');
      writeln
    end; (* if *)

    if (noun = nullsym) or (noun = consym) then begin
      writeln('  CONNECT     To make a "virtual terminal" connection to a remote');
      writeln('':14, 'system.');
      writeln;
      writeln('':14, 'To break the connection and "escape" back to the micro,');
      writeln('':14, 'type the escape sequence (CTRL-] C, that is Control ');
      writeln('':14, 'rightbracket followed immediately by the letter C.)');
      writeln;
    end; (* if *)

    if (noun = nullsym) or (noun = exitsym) then begin
      writeln('  EXIT        To return back to main command level of the p-system.');
    end; (* if *)

    if (noun = nullsym) or (noun = quitsym) then begin
      writeln('  QUIT        Same as EXIT.');
      writeln;
    end; (* if *)

    if (noun = nullsym) or (noun = helpsym) then begin
      writeln('  HELP        To get a list of KERMIT commands.');
      writeln;
    end; (* if *)

    if (noun = nullsym) or (noun = recsym) then begin
      writeln('  RECEIVE     To accept a file from the remote system.');
    end; (* if *)

    if (noun = nullsym) or (noun = sendsym) then begin
      writeln('  SEND        To send a file or group of files to the remote system.');
    end; (* if *)

    if (noun = nullsym) or (noun = getsym) then begin
      writeln('  GET         To request a file from a remote Kermit in SERVER mode.');
    end; (* if *)

    if (noun = nullsym) or (noun = putsym) then begin
      writeln('  PUT         To send a file to a remote Kermit in SERVER mode.');
      writeln;
    end; (* if *)

    if (noun = nullsym) or (noun = byesym) then begin
      writeln('  BYE         Shutdown and logout a remote Kermit in SERVER mode.');
    end; (* if *)

    if (noun = nullsym) or (noun = finsym) then begin
      writeln('  FINISH      Shutdown a remote Kermit in SERVER mode.');
    end; (* if *)

    if (noun = nullsym) then
        keypress;
  end; (* help1 *)

procedure help2;

var ch: char;

  begin { help2 }
    if (noun = nullsym) or (noun = setsym) then begin
      writeln('  SET         To establish system-dependent parameters.  The ');
      writeln('':14, 'SET options are as follows: ');
      writeln;
      if (adj = nullsym) or (adj = debugsym) then begin
        writeln('':14, 'DEBUG            To set debug mode ON or OFF ');
        writeln('':31, '(default is OFF).');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = escsym) then begin
        writeln('':14, 'ESCAPE           To change the escape sequence that ');
        writeln('':31, 'lets you return to the PC Kermit from');
        writeln('':31, 'the remote host.  The default is CTRL-] c.');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = filenamsym) then begin
        writeln('':14, 'FILE-NAMES       LITERAL/CONVERTED, Default is CONVERTED, ');
        writeln('':31, 'In this Kermit LITERAL Names have');
        writeln('':31, 'Volume name Stripped, while CONVERTED');
        writeln('':31, 'Names also have all but the final');
        writeln('':31, '''.'' removed.');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = filetypesym) then begin
        writeln('':14, 'FILE-TYPE        BINARY/TEXT Default is TEXT.');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = filewarnsym) then begin
        writeln('':14, 'FILE-WARNING     ON/OFF, default is OFF.  If ON, ');
        writeln('':31, 'Kermit will warn you and rename an incoming ');
        writeln('':31, 'file so as not to write over a file that ');
        writeln('':31, 'currently exists with the same name');
        writeln;
      end; (* if *)
      if (adj = nullsym) then
        keypress;
    end; (* if *)
  end; (* help2 *)

procedure help3;

  begin
    if (noun = nullsym) or (noun = setsym) then begin
      if (adj = nullsym) or (adj = baudsym) then begin
        writeln('':14, 'BAUD             To set the serial baud rate.' );
        writeln('':31, 'Choices are dependant on your Hardware.' );
        writeln('':31, 'The default is 1200.');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = ibmsym) then begin
        writeln('':14, 'IBM              ON/OFF, default is OFF.  This flag ');
        writeln('':31, 'should be ON only when transfering files');
        writeln('':31, 'between the micro and an IBM VM/CMS');
        writeln('':31, 'system.  It also causes the parity to');
        writeln('':31, 'be set appropriately (mark) and activates');
        writeln('':31, 'local echoing');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = intsym) then begin
        writeln('':14, 'INTERFACE        KERMIT/UCSD, default is KERMIT.');
        writeln('':31, 'Permits selection of prefered User Interface:');
        writeln('':31, 'KERMIT command line or UCSD menus.');
        writeln;
      end; (* if *)

      if (adj = nullsym) or (adj = localsym) then begin
        writeln('':14, 'LOCAL-ECHO       ON/OFF, default is OFF.  This sets the');
        writeln('':31, 'duplex.  It should be ON when using ');
        writeln('':31, 'the IBM and OFF for the DEC-20.');
        writeln;
      end; (* if *)

      if (adj = nullsym) or (adj = emulatesym) then begin
        writeln('':14, 'EMULATE          ON/OFF, default is OFF.  This sets the');
        writeln('':31, 'DataMedia 1520A terminal emulation on or off.');
        writeln;
      end; (* if *)
      if (adj = nullsym) then
        keypress;
    end; (* if *)
  end; (* help3 *)

procedure help4;

  begin
    if (noun = setsym) or (noun = nullsym) then begin
      if (adj = nullsym) or (adj = systemsym) then begin
        writeln('':14, 'SYSTEM-ID        Specify the System-ID for your REMUNIT');
        writeln('':31, 'if your REMUNIT needs it specified.');
        writeln('':31, 'Called "model" in the REMUNIT specs.');
        writeln('':31, 'Default System-ID is UNKNOWN');
        writeln;
      end; (* if *)

      if (adj = nullsym) or (adj = paritysym) then begin
        writeln('':14, 'PARITY           EVEN, ODD, MARK, SPACE, or NONE.');
        writeln('':31, 'NONE is the default but if the IBM ');
        writeln('':31, 'flag is set, parity is set to MARK.  ');
        writeln('':31, 'This flag selects the parity for ');
        writeln('':31, 'outgoing and incoming characters during');
        writeln('':31, 'CONNECT and file transfer to match the');
        writeln('':31, 'requirements of the host.');
        writeln;
      end; (* if *)
    end; (* if *)
    if (noun = nullsym) or (noun = showsym) then begin
      writeln('  SHOW        To see the values of parameters that can be modified');
      write('':14, 'via the SET command. ');
      if (adj in [paritysym, localsym, ibmsym, escsym, debugsym,
                  filenamsym, filetypesym, filewarnsym, baudsym,
                  emulatesym, systemsym, nullsym]) then begin
        writeln('For an explanation of the parameter,');
        writeln('':14, 'see the help for the matching SET command.'); write('':14)
      end; (* if *)
      if (adj in [allsym, versionsym, nullsym]) then begin
        writeln('Additional SHOW options are as follows:');
      end; (* if *)
      writeln;
      if (adj = nullsym) or (adj = allsym) then begin
        writeln('':14, 'ALL              Show all parameters.');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = versionsym) then begin
        writeln('':14, 'VERSION          Show version information.');
        writeln;
      end; (* if *)
    end; (* if *)
    if (noun = nullsym) then
        keypress;

    if (noun = nullsym) or (noun = takesym) then begin
      writeln('  TAKE        This command instructs Kermit to take further');
      writeln('':14, 'commands from a specified file.');
    end; (* if *)
    if (noun = nullsym) or (noun = comsym) then begin
      writeln('  COMMENT     Comments a TAKE file. (ignored)');
      writeln;
    end; (* if *)
    if (noun = nullsym) or (noun = logsym) then begin
      writeln('  LOG         This command opens a selected log file.');
      writeln('':14, 'LOG options are as follows:');
      writeln;
      if (adj = nullsym) or (adj = debugsym) then begin
        writeln('':14, 'DEBUG            open specified file for debug output.');
        writeln;
      end; (* if *)
    end; (* if *)
    if (noun = nullsym) or (noun = closesym) then begin
      writeln('  CLOSE       This command closes a selected log file previously');
      writeln('':14, 'opened via the LOG command.');
    end; (* if *)
  end; (* help4 *)

procedure help;
begin
  help1;
  help2;
  help3;
  help4
end; (* help *)

procedure hlp_version;

  begin
    writeln(my_version)
  end {hlp_version};

end. { unit helper }
{>>>> PARSER.TEXT}
(*$S+*)
unit parser;

INTERFACE

uses {$U kermglob.code} kermglob;

{Change log:
13 May 89, V1.1: Fixed several bugs in parsing of HELP commands   RTC
13 May 89, V1.1: Added parsing for COMMENT command
30 Apr 89, V1.1: Added parsing for SET INTERFACE command   RTC
26 Apr 89, V1.1: minor cleanups   RTC
16 Apr 89, V1.1: Added BYE & FINISH command parsing       RTC
14 Apr 89, V1.1: Added parsing for GET, PUT & SHOW VERSION commands   RTC
13 Apr 89, V1.1: Added Version message       RTC
14 Aug 88: Added parsing for LOG, CLOSE, and SET SYSTEM commands   RTC
02 Jul 88: Added -NAMES, -TYPE, TAKE command parsing   RTC

}

   function parse: statustype;

   procedure initvocab;

   procedure par_version;


IMPLEMENTATION

uses
   {$U kermutil.code} kermutil;

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


procedure eatspaces(var s: string255);

var done: boolean;
    i: integer;

  begin
    done := (length(s) = 0);
    while not done do
      begin
        if s[1] = ' ' then
          begin
            i := length(s) - 1;
            s := copy(s,2,i);
            done := length(s) = 0
          end (* if *)
        else
            done := true
      end (* while *)
  end; (* eatspaces *)

procedure isolate_word(var line, s: string255);

var i: integer;
    done: boolean;

  begin
    done := false;
    i := 1;
    s := copy(' ',0,0);
    while (i <= length(line)) and not done do
      begin
        if line[i] = ' ' then
            done := true
        else
            s := concat(s,copy(line,i,1));
        i := i + 1;
      end; (* while *)
    line := copy(line,i,length(line)-i+1);
  end; (* isolate_word *)

function get_fn(var line, fn: string255): boolean;

var i, l: integer;

  begin
    get_fn := true;
    isolate_word(line, fn);
    l := length(fn);
    if (l < 1) then
        get_fn := false
  end; (* get_fn *)

function get_num( var line: string255; var n: integer ): boolean;

var
   numstr: string255;
   i, l: integer;
begin
   get_num := true;
   isolate_word( line, numstr );
   l := length(numstr);
   if (l>5) or (l<1) then begin
      n := 0;
      get_num := false
   end
   else begin
      n := 0; i := 1;
      numstr := concat( numstr, ' ' );
      while (numstr[i] in ['0'..'9']) do begin
         if n<(maxint div 10) then
            n := n*10 + ord( numstr[i] ) - ord( '0' );
         i := i + 1
      end
   end
end; { get_num }

function nextch(var ch: char): boolean;

var s: string255;

  begin
    isolate_word(line,s);
    if length(s) <> 1 then
        nextch := false
    else
      begin
        ch := s[1];
        nextch := true
      end (* else *)
  end; (* nextch *)

function parse(*: statustype*);

type states = (start, fin, get_filename, get_set_parm, get_parity,
               get_on_off, get_f_type, get_char, get_show_parm,
               get_help_show, get_int_type, get_naming, get_help_parm,
               exitstate, get_baud, get_line, get_log_parm, get_help_log);

var status: statustype;
    word: vocab;
    state: states;

function get_a_sym(var word: vocab): statustype;

var i: vocab;
    s: string255;
    stat: statustype;
    done: boolean;
    matches: integer;

  begin
    eat_spaces(line);
    if length(line) = 0 then
        get_a_sym := ateol
    else
      begin
        stat := null;
        done := false;
        isolate_word(line,s);
        i := allsym;
        matches := 0;
        repeat
            if (pos(s,vocablist[i]) = 1) and (i in expected) then
              begin
                matches := matches + 1;
                word := i
              end
            else if (s[1] < vocablist[i,1]) then
                done := true;
            if (i = versionsym) then
                done := true
            else
                i := succ(i)
        until (matches > 1) or done;
        if matches > 1 then
            stat := ambiguous
        else if (matches = 0) then
            stat := unrec;
        get_a_sym := stat
      end (* else *)
  end; (* get_a_sym *)

  begin
    state := start;
    parse := null;
    noun := nullsym;
    verb := nullsym;
    adj := nullsym;
    uppercase(line);
    repeat
        case state of
          start:
              begin
                expected := [comsym, consym, exitsym, helpsym, quitsym,
                             logsym, closesym, getsym, putsym, byesym, finsym,
                             recsym, sendsym, setsym, showsym, takesym];
                status := get_a_sym(verb);
                if status = ateol then
                  begin
                    parse := null;
                    exit(parse)
                  end (* if *)
                else if (status <> unrec) and (status <>  ambiguous) then
                    case verb of
                      comsym: state := get_line;
                      consym, exitsym, quitsym,
                      byesym, finsym, recsym: state := fin;
                      getsym, putsym,
                      sendsym, takesym: state := getfilename;
                      helpsym: state := get_help_parm;
                      logsym, closesym: state := get_log_param;
                      setsym: state := get_set_parm;
                      showsym: state := get_show_parm;
                    end (* case *)
              end; (* case start *)
          fin:
              begin
                expected := [];
                status := get_a_sym(verb);
                if status = ateol then
                  begin
                    parse := null;
                    exit(parse)
                  end (* if status *)
                else
                    status := unconfirmed
              end; (* case fin *)
          getfilename:
            begin
              expected := [];
              if getfn(line,xfilename) then
                begin
                  status := null;
                  state := fin
                end (* if *)
              else
                  status := fnexpected
            end; (* case get file name *)
          get_set_parm:
              begin
                expected := [paritysym, localsym, ibmsym, emulatesym,
                             escsym, debugsym, filenamsym, filetypesym,
                             intsym, filewarnsym, baudsym, systemsym];
                status := get_a_sym(noun);
                if status = ateol then
                    status := parm_expected
                else if (status <> unrec) and (status <>  ambiguous) then
                    case noun of
                      paritysym: state := get_parity;
                      localsym: state := get_on_off;
                      ibmsym: state := get_on_off;
                      emulatesym: state := get_on_off;
                      escsym: state := getchar;
                      debugsym: state := get_on_off;
                      filenamsym : state := get_naming;
                      filetypesym : state := get_f_type;
                      filewarnsym: state := get_on_off;
                      intsym: state := get_int_type;
                      baudsym: state := get_baud;
                      systemsym: state := get_line
                    end (* case *)
            end; (* case get_set_parm *)
          get_log_parm:
              begin
                expected := [debugsym];
                status := get_a_sym(adj);
                if status = ateol then
                    status := parm_expected
                else if (status <> unrec) and (status <> ambiguous) then
                    if verb = logsym
                      then state := getfilename
                      else state := fin
              end; (* case get_log_parm *)
          get_line:
              begin
                eat_spaces(line);
                parse := null;
                exit(parse)
              end; {case get_line}
          get_parity, get_naming, get_int_type, get_on_off, get_f_type:
              begin
                case state of
                  get_parity:   expected := [marksym, spacesym,
                                             nonesym, evensym, oddsym];
                  get_naming:   expected := [convsym, litsym];
                  get_int_type: expected := [kermitsym, ucsdsym];
                  get_on_off:   expected := [onsym, offsym];
                  get_f_type:   expected := [binsym, textsym];
                end {case state};
                status := get_a_sym(adj);
                if status = ateol then
                    status := parm_expected
                else if (status <> unrec) and (status <> ambiguous) then
                    state := fin
              end; (* case get_parity  *)
          get_baud:
             begin
               expected := [];
               if get_num( line, newbaud ) then begin
                  status := null; state := fin
               end
               else begin
                  newbaud := 0;
                  status := parm_expected
               end
             end; (* case get_baud *)
          get_char:
              if nextch(newescchar) then
                 state := fin
              else
                 status := ch_expected;
          get_show_parm:
              begin
                expected := [allsym, paritysym, localsym, ibmsym,
                             emulatesym, escsym, debugsym,
                             filenamsym, filetypesym, filewarnsym,
                             baudsym, systemsym, versionsym];
                status := get_a_sym(noun);
                if status = ateol then
                    status := parm_expected
                else if (status <> unrec) and (status <>  ambiguous) then
                    state := fin
              end; (* case get_show_parm *)
          get_help_show, get_help_log:
              begin
                case noun of
                  logsym, closesym:
                    expected := [debugsym];
                  setsym:
                    expected := [paritysym, localsym, ibmsym, escsym,
                                 intsym, debugsym, filenamsym, filetypesym,
                                 filewarnsym, baudsym, emulatesym, systemsym];
                  showsym:
                    expected := [paritysym, localsym, ibmsym, escsym,
                                 debugsym, filenamsym, filetypesym,
                                 filewarnsym, baudsym, emulatesym, systemsym,
                                 allsym, versionsym];
                end {case noun};
                status := get_a_sym(adj);
                if (status = at_eol) then
                  begin
                    status := null;
                    state := fin
                  end
                else if (status <> unrec) and (status <>  ambiguous) then
                    state := fin
              end; (* case get_help_show *)
          get_help_parm:
              begin
                expected := [consym, exitsym, helpsym, quitsym, recsym,
                             comsym, getsym, putsym, byesym, finsym, takesym,
                             logsym, closesym, sendsym, setsym, showsym];
                status := get_a_sym(noun);
                if status = ateol then
                  begin
                    parse := null;
                    exit(parse)
                  end;
                if (status <> unrec) and (status <>  ambiguous) then
                    case noun of
                      consym, comsym, getsym, putsym,
                      sendsym, finsym, byesym, takesym,
                      recsym: state := fin;
                      closesym, logsym: state := get_help_log;
                      showsym, setsym: state := get_help_show;
                      helpsym: state := fin;
                      exitsym, quitsym: state := fin;
                    end (* case *)
              end; (* case get_help_show *)
        end (* case *)
    until (status <> null);
    parse := status
  end; (* parse *)

procedure initvocab;

var i: integer;

  begin
    vocablist[allsym] :=        'ALL';
    vocablist[baudsym] :=       'BAUD';
    vocablist[binsym] :=        'BINARY';
    vocablist[byesym] :=        'BYE';
    vocablist[closesym] :=      'CLOSE';
    vocablist[comsym] :=        'COMMENT';
    vocablist[consym] :=        'CONNECT';
    vocablist[convsym] :=       'CONVERTED';
    vocablist[debugsym] :=      'DEBUG';
    vocablist[emulatesym] :=    'EMULATE';
    vocablist[escsym] :=        'ESCAPE';
    vocablist[evensym] :=       'EVEN';
    vocablist[exitsym] :=       'EXIT';
    vocablist[filenamsym] :=    'FILE-NAMES';
    vocablist[filetypesym] :=   'FILE-TYPE';
    vocablist[filewarnsym] :=   'FILE-WARNING';
    vocablist[finsym] :=        'FINISH';
    vocablist[getsym] :=        'GET';
    vocablist[helpsym] :=       'HELP';
    vocablist[ibmsym] :=        'IBM';
    vocablist[intsym] :=        'INTERFACE';
    vocablist[kermitsym] :=     'KERMIT';
    vocablist[litsym] :=        'LITERAL';
    vocablist[localsym] :=      'LOCAL-ECHO';
    vocablist[logsym] :=        'LOG';
    vocablist[marksym] :=       'MARK';
    vocablist[nonesym] :=       'NONE';
    vocablist[oddsym] :=        'ODD';
    vocablist[offsym] :=        'OFF';
    vocablist[onsym] :=         'ON';
    vocablist[paritysym] :=     'PARITY';
    vocablist[putsym] :=        'PUT';
    vocablist[quitsym] :=       'QUIT';
    vocablist[recsym] :=        'RECEIVE';
    vocablist[sendsym] :=       'SEND';
    vocablist[setsym] :=        'SET';
    vocablist[showsym] :=       'SHOW';
    vocablist[spacesym] :=      'SPACE';
    vocablist[systemsym] :=     'SYSTEM-ID';
    vocablist[takesym] :=       'TAKE';
    vocablist[textsym] :=       'TEXT';
    vocablist[ucsdsym] :=       'UCSD';
    vocablist[versionsym] :=    'VERSION';
  end; (* initvocab *)

procedure par_version;

  begin
    writeln(my_version)
  end {par_version};

end. (* end of unit *)

{>>>> INTFUTIL.TEXT}
interface

{Change log:
30 Apr 89, V1.1: Extracted from KERMUTIL   RTC
}

   uses
     {$U kermglob.code} kermglob;

   procedure fill_parity_array;

   procedure set_parms;

   procedure show_parms;

   procedure connect;

   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): boolean;

   function getsoh: boolean;

   function getfil(filename: string255): boolean;

   procedure send_brk;

   function setup_comm : boolean;        {changed 31 Jul 88, RTC}

   procedure flush_comm;                {added 16 Apr 89, RTC}

   procedure write_bool(s: string255; b: boolean);

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

   procedure writescreen(s: string255);

   procedure refresh_screen(numtry, num: integer);

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

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

   procedure utl_version;

implementation

{>>>> FAKEUTIL.TEXT}

unit kermutil;

{ Change log:
30 Apr 89, V1.1: Created Fake version of KERMUTIL   RTC
}

{$I intfutil.text}

procedure fill_parity_array;
  begin end; (* fill_parity_array *)

procedure write_bool{s: string255; b: boolean};
  begin end; (* write_bool *)

procedure show_parms;
  begin end; (* show_sym *)

procedure set_parms;
  begin end; (* set_parms *)

procedure connect;
  begin (* connect *) end; (* connect *)

procedure uppercase(*var s: string255*);
  begin end; (* uppercase *)

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

procedure write_ch(*unitno: integer; ch: char*);
  begin end;

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

procedure clear_buf(*unitno:integer*);
  begin end;

procedure send_brk;
  begin end;

function setup_comm{ : boolean};
  begin end;

procedure flush_comm;                {added 16 Apr 89, RTC}
  begin {flush_comm} end {flush_comm};

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

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

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

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

procedure io_error(*i: integer*);
  begin end; (* io_error *)

procedure debugwrite(*s: string255*);
  begin end; (* debugwrite *)

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

function min(*x,y: integer): integer*);
  begin end; (* min *)

function tochar(*ch: char): char*);
  begin end; (* tochar *)

function unchar(*ch: char): char*);
  begin end; (* unchar *)

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

procedure echo(*ch: char*);
  begin end; (* echo *)

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

function getsoh(*: boolean*);
  begin end; (* getsoh *)

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

procedure writescreen(*s: string255*);
  begin end; (* writescreen *)

procedure refresh_screen(*numtry, num: integer*);
  begin end; (* refresh_screen *)

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

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

procedure utl_version;
  begin end {utl_version};

begin { body of unit kermutil }
   { initialization code }
   ***;
   { termination code }
end. { fakeutil }
{>>>> KERMUTIL.TEXT}
{$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 }
{>>>> SETSHOW.TEXT}

{ Change log:
30 Apr 89, V1.1: moved into kermutil   RTC
30 Apr 89, V1.1: Added SET INTERFACE command    RTC
16 Apr 89, V1.1: Added Client Unit to SHOW VER command      RTC
14 Apr 89, V1.1: Added SHOW VERSION command   RTC
14 Aug 88: Added SYSTEM-ID and modified DEBUG      RTC
31 Jul 88: Modified to permit REMUNIT to accept/reject baud rate    RTC

}

procedure fill_parity_array;

(* parity value table for even parity...not(entry) = odd parity *)

const min = 0;
      max = 255;

var i, shifter, counter: integer;
    ch: char;

begin
   for ch := chr(min) to chr(max) do
     case parity of
        evenpar: begin
                    shifter := aand(ord(ch),255); (* mask off parity bit *)
                    counter := 0;
                    for i := 1 to 7 do begin       (* count the 1's *)
                       if odd(shifter) then
                          counter := counter + 1;
                       shifter := shifter div 2
                    end; (* for i *)
                    if odd(counter) then       (* stick a 1 on if necessary *)
                       parity_array[ch] := chr(aor(ord(ch),128))
                    else
                       parity_array[ch] := chr(aand(ord(ch),127))
                 end; (* for ch *) (* case even *)
        oddpar:  begin
                    shifter := aand(ord(ch),255);  (* mask off parity bit *)
                    counter := 0;
                    for i := 1 to 7 do begin        (* count the 1's *)
                       if odd(shifter) then
                           counter := counter + 1;
                       shifter := shifter div 2
                    end; (* for i *)
                    if odd(counter) then        (* stick a 1 on if necessary *)
                       parity_array[ch] := chr(aand(ord(ch),127))
                    else
                       parity_array[ch] := chr(aor(ord(ch),128))
                 end; (* for ch *) (* case odd *)
        markpar: parity_array[ch] := chr(aor(ord(ch),128));
        spacepar:parity_array[ch] := chr(aand(ord(ch),127));
        nopar:   parity_array[ch] := ch;
      end; (* case *)
  end; (* fill_parity_array *)

procedure write_bool{s: string255; b: boolean};

(* writes message & 'on' if b, 'off' if not b *)
  begin
    write(s);
    case b of
        true: writeln('on');
        false: writeln('off');
      end; (* case *)
  end; (* write_bool *)

procedure show_parms;

(* shows the various settable parameters *)
var
  i,first,last : vocab;

begin
   if noun = allsym then
     begin
       first := baudsym; last := systemsym
     end
   else
     begin
       first := noun; last := noun
     end;
   for i := first to last do
     case i of
       debugsym:    write_bool('Debugging is ',debug);

       escsym:      writeln('Escape character is ^',ctl(esc_char));

       filenamsym:  begin
                      write('File names are ');
                      if lit_names
                        then write('Literal')
                        else write('Converted');
                      writeln
                    end;

       filetypesym: begin
                      write('File type is ');
                      if f_is_binary
                        then write('Binary')
                        else write('Text');
                      writeln
                    end;

       filewarnsym: write_bool('File warning is ',fwarn);

       ibmsym:      write_bool('IBM is ',ibm);

       localsym:    write_bool('Local echo is ',halfduplex);

       emulatesym:  write_bool('Emulate DataMedia is ', emulating );

       baudsym:     writeln( 'Baud rate is ', baud:5 );

       paritysym:   begin
                       case parity of
                          evenpar: write('Even');
                          markpar: write('Mark');
                          nopar: write('No');
                          oddpar: write('Odd');
                          spacepar: write('Space');
                       end; (* case *)
                       writeln(' parity');
                    end; (* paritysym *)

       systemsym:   writeln('System ID is ',system_id);

     end; (* case *)
   if noun = versionsym then
     begin
       writeln(ker_version);
       rec_version; sen_version; cli_version;
       hlp_version; pak_version; utl_version; gbl_version;
       mnu_version; par_version;
     end
end; (* show_sym *)


procedure set_parms;

(* sets the parameters *)

  var
    oldbaud : integer;

  begin
    case noun of
        debugsym: debug := adj = onsym;
        escsym: escchar := newescchar;
        filenamsym : lit_names := adj = litsym;
        filetypesym : f_is_binary := adj = binsym;
        filewarnsym: fwarn := (adj = onsym);
        ibmsym: case adj of
                    onsym: begin
                        ibm := true;
                        parity := markpar;
                        half_duplex := true;
                        fillparityarray
                      end; (* onsym *)
                    offsym: begin
                        ibm := false;
                        parity := nopar;
                        half_duplex := false;
                        fillparityarray
                      end; (* onsym *)
                  end; (* case adj *)
        intsym: if adj = ucsdsym then menu_interface;
        localsym: halfduplex := (adj = onsym);
        emulatesym: emulating := (adj = onsym);
        paritysym: begin
              case adj of
                  evensym: parity := evenpar;
                  marksym: parity := markpar;
                  nonesym: parity := nopar;
                  oddsym: parity := oddpar;
                  spacesym: parity := spacepar;
                end; (* case *)
              fill_parity_array;
             end; (* paritysym *)
        baudsym: begin
            oldbaud := baud; baud := newbaud;
            if not setup_comm then baud := oldbaud
         end { baudsym };
        systemsym: system_id := line;
      end; (* case *)
  end; (* set_parms *)
{>>>> KERMENUS.TEXT}
unit kermenus;

interface

  {Change log:
  14 May 89, V1.1: Added Parameters menu   RTC
  02 May 89, V1.1: Added menu to control log files   RTC
  30 Apr 89, V1.1: Originally written   RTC
  }

  procedure menu_interface;

  procedure mnu_version;

implementation

  uses screenops,
       {$U kermglob.code} kermglob,
       {$U kermutil.code} kermutil,
       {$U sender.code}   sender,
       {$U receiver.code} receiver,
       {$U client.code}   client;

  const
    my_version = '   Kermenus Unit V1.1, 14 May 89';

  procedure transfer_files;

    var
      ch : char;

    begin {transfer_files}
      ch := SC_prompt(concat('Kermit-UCSD File Transfer: ',
                             'S(end, R(eceive, G(et, P(ut, A(bort'),
                      -1,-1,0,menu_line,
                      ['S','R','G','P','A',' '],
                      false,',');
      SC_clr_line(menu_line);
      case ch of
        'G', 'R' : begin
                if ch = 'G' then
                  begin
                    gotoxy(file_pos,file_line);
                    readln(xfilename); uppercase(xfilename)
                  end;
                recsw(rec_ok,ch = 'G');
                gotoxy(0,debugline);
                write(chr(bell));
                if rec_ok then
                    writeln('successful receive')
                else
                    writeln('unsuccessful receive');
                (*$I-*) (* set i/o checking off *)
                if f_is_binary
                  then close(b_file)
                  else close(t_file);
                (*$I+*) (* set i/o checking back on *)
              end; (* recsym *)
        'P', 'S' : begin
                gotoxy(file_pos,file_line);
                readln(xfilename); uppercase(xfilename);
                sendsw(send_ok);
                gotoxy(0,debugline);
                write(chr(bell));
                if send_ok then
                    writeln('successful send')
                else
                    writeln('unsuccessful send');
                (*$I-*) (* set i/o checking off *)
                if f_is_binary
                  then close(b_file)
                  else close(t_file);
                (*$I+*) (* set i/o checking back on *)
              end; (* sendsym *)
        'A', ' ' : begin
                gotoxy(0,debugline);
                write('file transfer aborted');
              end; {abort transfer}
      end {case ch}
    end {transfer_files};

  procedure logs;

    var
      ch_cmd,ch_log : char;
      log_message : string;

    begin {logs}
      ch_cmd := SC_prompt(concat('Kermit-UCSD Logs: ',
                             'O(pen, C(lose, A(bort'),
                      -1,-1,0,menu_line,
                      ['O','C','A',' '],
                      false,',');
      case ch_cmd of
        'O' : log_message := 'Open';
        'C' : log_message := 'Close';
        'A',' ' : exit(logs)
      end {case ch_cmd};
      ch_log := SC_prompt(concat('Kermit-UCSD ',log_message,' Log: ',
                             'D(ebug, A(bort'),
                      -1,-1,0,menu_line,
                      ['D','A',' '],
                      false,',');
      case ch_log of
        'D' : log_message := concat(log_message,' for Debug');
        'A',' ' : exit(logs)
      end {case ch_log};
      if ch_cmd = 'O' then {command was to open log}
        begin
          SC_clr_line(menu_line);
          write('File to ',log_message,' Logging>');
          readln(xfilename); uppercase(xfilename);
          {$I-}
          case ch_log of
            'D' :
              begin
                close(debf,lock);
                rewrite(debf,xfilename)
              end;
          end {case ch_log};
          if ioresult <> 0 then
            begin
              writeln('Unable to open ',xfilename);
              case ch_log of
                'D' :
                  begin
                    close(debf);
                    rewrite(debf,'CONSOLE:')
                  end;
              end {case ch_log};
            end
          else {$I+}
            case ch_log of
              'D' : write(debf,
                  ker_version,' -- Debug log...');
            end
        end
      else {command was to close log}
        begin
          {$I-}
          case ch_log of
            'D' : close(debf,lock);
          end {case ch_log};
          if ioresult <> 0 then
            begin
              writeln('Unable to close file');
            end;
          case ch_log of
            'D' : rewrite(debf,'CONSOLE:');
          end {case ch_log};
          {$I+}
        end;
    end {logs};

  procedure menu_interface;

    var
      done : boolean;
      ch : char;

    procedure write_bool(b: boolean);

      {writes 'True' or 'False'}

      begin {write_bool}
        if b
          then write('True ')
          else write('False')
      end {write_bool};

    procedure read_bool(var b: boolean);

      var ch : char;

      begin {read_bool}
        SC_getc_ch(ch,['T','F']);
        b := ch = 'T'
      end {read_bool};

    procedure parameters;

      const
        name_line = 9;
        type_line = 10;
        warn_line = 11;
        baud_line = 12;
        parity_line = 13;
        echo_line = 14;
        ibm_line = 15;
        em_line = 16;
        esc_line = 17;
        debug_line = 18;
        sys_line = 19;
        opt_pos = 4;
        val_pos = 25;

      begin {parameters}
        SC_eras_eos(0,pred(name_line));
        repeat
          gotoxy(opt_pos,name_line); write('File N(ames');
          gotoxy(val_pos,name_line);
          if lit_names
            then write('Literal  ')
            else write('Converted');
          gotoxy(opt_pos,type_line); write('File T(ype');
          gotoxy(val_pos,type_line);
          if f_is_binary
            then write('Binary')
            else write('Text  ');
          gotoxy(opt_pos,warn_line); write('File W(arning');
          gotoxy(val_pos,warn_line); write_bool(f_warn);
          gotoxy(opt_pos,baud_line); write('B(aud rate');
          gotoxy(val_pos,baud_line); write(baud);
          gotoxy(opt_pos,parity_line); write('P(arity');
          gotoxy(val_pos,parity_line);
          case parity of
            evenpar: write('Even');
            markpar: write('Mark');
            nopar: write('None');
            oddpar: write('Odd');
            spacepar: write('Space');
          end {case parity};
          gotoxy(opt_pos,echo_line); write('L(ocal echo');
          gotoxy(val_pos,echo_line); write_bool(half_duplex);
          gotoxy(opt_pos,ibm_line); write('I(BM mode');
          gotoxy(val_pos,ibm_line); write_bool(ibm);
          gotoxy(opt_pos,em_line); write('eM(ulate Datamedia');
          gotoxy(val_pos,em_line); write_bool(emulating);
          gotoxy(opt_pos,esc_line); write('E(scape Character');
          gotoxy(val_pos,esc_line); write('^',ctl(esc_char));
          gotoxy(opt_pos,debug_line); write('D(ebugging');
          gotoxy(val_pos,debug_line); write_bool(debug);
          gotoxy(opt_pos,sys_line); write('S(ystem ID');
          gotoxy(val_pos,sys_line); write(system_id);
          ch := SC_prompt(concat('Kermit Parameters: {options} ',
                               '<space> to leave, ',
                               'switch to K(ermit style interface, V(ersion'),
                          -1,-1,0,menu_line,
                ['D','E','N','T','W','I','L','M','B','P','S','K','V',' '],
                          false,',');
          case ch of
            'D' : begin
                    SC_erase_to_EOL(val_pos,debug_line); read_bool(debug)
                  end;
            'E' : repeat
                    SC_erase_to_EOL(val_pos,esc_line);
                    read(keyboard,esc_char)
                  until esc_char in [chr(0)..chr(31)];
            'N' : begin
                    SC_erase_to_EOL(val_pos,name_line);
                    SC_getc_ch(ch,['L','C']);
                    lit_names := ch = 'L'
                  end;
            'T' : begin
                    SC_erase_to_EOL(val_pos,type_line);
                    SC_getc_ch(ch,['B','T']);
                    f_is_binary := ch = 'B'
                  end;
            'W' : begin
                    SC_erase_to_EOL(val_pos,warn_line); read_bool(f_warn)
                  end;
            'I' : begin
                    SC_erase_to_EOL(val_pos,ibm_line); read_bool(ibm);
                    if ibm then
                      begin
                        parity := markpar;
                        half_duplex := true
                      end
                    else
                      begin
                        parity := nopar;
                        half_duplex := false
                      end;
                    fill_parity_array
                  end;
            'L' : begin
                    SC_erase_to_EOL(val_pos,echo_line); read_bool(halfduplex)
                  end;
            'M' : begin
                    SC_erase_to_EOL(val_pos,em_line); read_bool(emulating)
                  end;
            'B' : repeat
                    SC_erase_to_EOL(val_pos,baud_line); {$I-} read(baud); {$I+}
                    SC_erase_to_EOL(0,menu_line)
                  until setup_comm;
            'P' : begin
                    SC_erase_to_EOL(val_pos,parity_line);
                    SC_getc_ch(ch,['E','O','M','S','N']);
                    case ch of
                      'E' : parity := evenpar;
                      'M' : parity := markpar;
                      'N' : parity := nopar;
                      'O' : parity := oddpar;
                      'S' : parity := spacepar;
                    end {case ch};
                    fill_parity_array
                  end;
            'S' : begin
                    SC_erase_to_EOL(val_pos,sys_line); readln(system_id)
                  end;
            'K' : begin
                    done := true; {switch back to KERMIT style interface}
                    SC_clr_screen; exit(parameters)
                  end;
            'V' : begin
                    SC_eras_eos(0,name_line);
                    noun := versionsym; show_parms;
                    exit(parameters)
                  end;
            ' ' : exit(parameters);
          end {case ch}
        until false
      end {parameters};

    begin {menu_interface}
      done := false;
      writescreen('');
      repeat
        ch := SC_prompt(concat('Kermit-UCSD: ',
                               'C(onnect, T(ransfer Files, Q(uit, ',
                               'S(et Parameters, L(ogs, B(ye, F(inish'),
                        -1,-1,0,menu_line,
                        ['C','T','Q','S','L','B','F'],
                        false,',');
        SC_clr_line(status_line); SC_clr_line(debug_line);
        case ch of
          'C' : begin SC_clr_screen; connect; writescreen('') end;
          'T' : transfer_files;
          'L' : logs;
          'F', 'B' : begin
                  case ch of
                    'F' : line := 'F';
                    'B' : line := 'L';
                  end {case};
                  clientsw(send_ok,'G',line);
                  gotoxy(0,debugline);
                  write(chr(bell));
                  if send_ok then
                      writeln('successful transaction')
                  else
                      writeln('unsuccessful transaction');
                  (*$I-*) (* set i/o checking off *)
                  close(t_file);
                  (*$I+*) (* set i/o checking back on *)
                end; {generic server command}
          'S' : parameters;
          'Q' : begin done := true; verb := quitsym end;
        end {case ch}
      until done
    end {menu_interface};

  procedure mnu_version;

    begin {mnu_version}
      writeln(my_version)
    end {mnu_version};

end {kermenus}.
{>>>> KERMPACK.TEXT}
unit kermpack;

interface

   uses {$U kermglob.code} kermglob;

{Change log:
30 Apr 89, V1.1: Eliminated "no timeout on receive" checks   RTC
26 Apr 89, V1.1: Changed to "timer" controlled timeouts   RTC
19 Apr 89, V1.1: minor cleanups   RTC
13 Apr 89, V1.1: Added Version message        RTC
14 Aug 88: Fixed packetwrite to output to debf          RTC
31 Jul 88: Modified for exact size binary xfr, misc. cleanup    RTC
02 Jul 88: Added binary transfers        RTC

}

   procedure spar(var packet: packettype);

   procedure rpar(var packet: packettype; len : integer);

   procedure spack(ptype: char; num:integer; len: integer; data: packettype);

   function rpack(var len, num: integer; var data: packettype): char;

   procedure bufemp(buffer: packettype; len: integer);

   function bufill(var buffer: packettype): integer;

   procedure pak_version;


implementation

uses {$U kermutil.code} kermutil;

const
  my_version = '   Kermpack Unit V1.1, 30 Apr 89';


procedure bufemp(*buffer: packettype; var f: text; len: integer*);

(* empties a packet into a file *)
{ Note: this strips out ALL linefeed characters! }

var i,ls: integer;
    r: char;
    set_bit_8 : boolean;
    s: string255;

procedure write_bin;

  var
    dummy : integer;

  begin {write_bin}
    filebuf[bufpos] := r;
    i := succ(i); bufpos := succ(bufpos);
    if bufpos > blksize then
      begin
        {$I-}
        dummy := blockwrite(b_file,filebuf,1);
        if io_result <> 0 then
          begin
            io_error(ioresult);         {tell them and...}
            currstate := 'a'            {abort}
          end;
        {$I+}
        bufpos := 1
      end
  end {write_bin};

procedure write_text;

  var
    dummy : integer;

  begin {write_text}
      if ord(r) = lf then { skip linefeeds SP }
         i := i + 1
      else if (ord(r) = cr) then begin     (* else if a carriage return then *)
         i := i + 1;
         (*$I-*)                           (* turn i/o checking off *)
         writeln(t_file,s);                (* and write out line to file *)
         s := copy('',0,0);                (* empty the string var *)
         ls := 0;
         (*$I+*)                           (* turn i/o checking back on *)
      end
      else begin                           (* else, is a regular char, so Q5R      $H     s := concat(s,' ');               (* and add character to out string *)
        ls := ls + 1;
         s[ls] := r;
         if length(s) >= 255 then          {dump full string  RTC}
           begin
             {$I-}
             write(t_file,s);
             s := ''; ls := 0
             {$I+}
           end;
         i := i + 1                (* increase buffer pointer *)
      end; (* else *)
      if (io_result <> 0) then begin (* if io_error *)
         io_error(ioresult);     (* tell them and *)
         currstate := 'a';           (* abort *)
      end (* if *)
  end {write_text};

begin
   s := copy('',0,0);
   ls := 0;
   i := 0;
   while i < len do begin
      r := buffer[i];          (* get a character *)
      if en_qbin and (r = qbin) then
        begin
          i := succ(i);
          r := buffer[i];      {get 8 bit quoted char}
          set_bit_8 := true
        end
      else set_bit_8 := false;
      if (r = myquote) then begin   (* if character is control quote *)
         i := i + 1;                (* skip over quote and *)
         r := buffer[i];            (* get quoted character *)
         if not (chr(aand(ord(r),127)) in
                 ctl_set - [chr(0)..chr(31),chr(del)]) then
            r := ctl(r);    (* controllify it *)
      end; (* if *)
      if set_bit_8 then r := chr(aor(ord(r),128));
      if f_is_binary
        then write_bin
        else write_text
   end; (* while *)                     (* and get another char *)
   if not f_is_binary then
     begin
       (*$I-*)                          (* turn i/o checking off *)
       write(t_file,s);                 (* and write out line to file *)
       if (io_result <> 0) then begin   (* if io_error *)
          io_error(ioresult);           (* tell them and *)
          currstate := 'a';             (* abort *)
       end (* if *)
       (*$I+*)                          (* turn i/o checking back on *)
     end
end; (* bufemp *)


function bufill(*var buffer: packettype): integer*);

(* fill a packet with data from a file *)

var i : integer;
    r : char;

  function done : boolean;

    begin {done}
      if f_is_binary
        then done := (bufpos > last_blksize) and eof(b_file)
        else done := eof(t_file)
    end {done};

  begin
    i := 0;
    (* while file has some data & packet has some room we'll keep going *)
    while not done and (i < spsiz-9) do
      begin
        if f_is_binary then
          begin
            (* if we need more data from disk then *)
            if (bufpos > bufend) and (not eof(b_file)) then
              begin
                {$I-}
                bufend := blockread(b_file,filebuf[1],1) * blksize;
                if io_result <> 0 then
                  begin
                    bufill := at_badblk;
                    exit(bufill)
                  end;
                {$I+}
                (* and adjust buffer pointer *)
                bufpos := 1
              end; (* if *)
            r := filebuf[bufpos];      (* get a character *)
            bufpos := bufpos + 1;         (* increase buffer pointer *)
          end
        else
          begin
            r := t_file^;
            {$I-}
            if eoln(t_file) then
              begin
                buffer[i] := quote;      (* put (quoted) CR in buffer *)
                i := i + 1;
                buffer[i] := ctl(chr(cr));
                i := i + 1;
                r := chr(lf);            (* and we'll stick a LF after *)
              end;
            get(t_file);
            if io_result <> 0 then
              begin
                bufill := at_badblk;
                exit(bufill)
              end
            {$I+}
          end;
        if en_qbin and (ord(r) > 127) then
          begin
            r := chr(ord(r)-128);       {remove the 8th bit}
            buffer[i] := qbin;          {insert prefix}
            i := succ(i)
          end;
        if chr(aand(ord(r),127)) in ctl_set then     (* if a control char *)
          begin
            buffer[i] := quote;      (* put the quote in buffer *)
            i := i + 1;
            if not (chr(aand(ord(r),127)) in
                    ctl_set - [chr(0)..chr(31),chr(del)]) then
                r := ctl(r);   (* and un-controllify char *)
          end (* if *);
        buffer[i] := r;
        i := i + 1;
      end; (* while *)
    if (i = 0) then                         (* if we're at end of file, *)
        bufill := at_eof                    (* indicate it *)
    else                                    (* else *)
        bufill := i                         (* return # of chars in packet *)
  end; (* bufill *)


procedure spar(*var packet: packettype*);

(* fills data array with my send-init parameters *)

  begin
    packet[0] := tochar(chr(maxpack+1));   (* biggest packet i can receive *)
    packet[1] := tochar(chr(mytime));    (* when i want to be timed out *)
    packet[2] := tochar(chr(mypad));     (* how much padding i need *)
    packet[3] := ctl(chr(mypchar));      (* padding char i want *)
    packet[4] := tochar(chr(myeol));     (* end of line character i want *)
    packet[5] := myquote;                (* control-quote char i want *)
    if parity = nopar
      then packet[6] := 'Y'              (* I will do 8-bit quoting *)
      else packet[6] := my_qbin;         { I need to do 8-bit quoting }
    packet[7] := '1';                    { checksum type I want }
    packet[8] := 'N';                    { I will not do run len encoding }
    packet[9] := tochar(chr(8));         { I can do attributes packets }
    debugwrite('spar:')
  end; (* spar *)

procedure rpar(*var packet: packettype; len : integer*);

(* gets their init params *)

  begin
    if len > 0
      then spsiz := ord(unchar(packet[0]))     (* max send packet size *)
      else spsiz := 80;
    if len > 1
      then timint := ord(unchar(packet[1]))    (* when i should time out *)
      else timint := my_time;
    if len > 2
      then pad := ord(unchar(packet[2]))       (* number of pads to send *)
      else pad := 0;
    if len > 3
      then padchar := ctl(packet[3])           (* padding char to send *)
      else padchar := chr(my_pchar);
    if len > 4
      then xeol := unchar(packet[4])           (* eol char i must send *)
      else xeol := chr(my_eol);
    if len > 5
      then quote := packet[5]                  (* incoming data quote char *)
      else quote := my_quote;
    if len > 6
      then qbin := packet[6]                   { incoming 8th bit quote }
      else qbin := 'N';
    if parity = nopar
      then en_qbin := qbin in [chr(33)..chr(62),chr(96)..chr(126)]
      else
        begin
          if q_bin = 'Y' then qbin := my_qbin;
          en_qbin := qbin = my_qbin
        end;
    if len > 9
      then en_attr := aand(ord(unchar(packet[9])),8) = 8
      else en_attr := false;
    debugwrite('rpar:')
  end; (* rpar *)

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

(* writes out all of a packet for debugging purposes *)

var i: integer;

  begin
    gotoxy(0,debugline);
    for i := 0 to len-1 do
        write(debf,p[i])
  end; (* packetwrite *)

procedure spack(*ptype: char; num: integer; len: integer; data: packettype*);

(* send a packet *)

var i: integer;
    chksum: char;
    ch: char;

  begin
    debugwrite('spack:');
    if ibm and (currstate <> 's') then           (* if ibm and not SINIT then *)
      begin
        set_timer(timint);
        repeat                                 (* wait for an xon *)
            repeat
            until (readch(inport, ch)) or timeout;
        until (ch = xon) or timeout;
        if timeout then                 (* if wait too long then *)
          begin
            exit(spack)                          (* get out *)
          end; (* if *)
      end; (* if *)

    for i := 1 to pad do
        write_ch(oport,parity_array[padchar]);(* write out any padding chars *)
    write_ch(oport,parity_array[chr(soh)]);                (* packet sync character *)
    chksum := tochar(chr(len + 3));          (* init chksum *)
    write_ch(oport,parity_array[tochar(chr(len + 3))]);    (* character count *)
    chksum := chr(ord(chksum) + ord(tochar(chr(num))));
    write_ch(oport,parity_array[tochar(chr(num))]);
    chksum := chr(ord(chksum) + ord(ptype));
    write_ch(oport,parity_array[ptype]);                   (* packet type *)

    for i := 0 to len - 1 do                 (* loop through data chars *)
      begin
        write_ch(oport,parity_array[data[i]]);             (* store char *)
        chksum := chr(ord(chksum) + ord(data[i]))
      end; (* for i *)
                                             (* compute final chksum *)
    chksum := chr(aand(ord(chksum) + (aand(ord(chksum),192) div 64), 63));
    write_ch(oport,parity_array[tochar(chksum)]);
    write_ch(oport,parity_array[xeol]);

    if debug then
      begin
        write(debf,' len:',len,' num:',num,' ptype:',ptype);
        packetwrite(data,len); write(debf,' chksum:',tochar(chksum))
      end
  end; (* spack *)

(*$G+*) (* turn on goto option...need it for next routine *)

function rpack(*var len, num: integer; var data: packettype): char*);

(* read a packet *)

label 1; (* used to emulate C's CONTINUE statement *)

var i, ichksum: integer;
    chksum, ptype: char;
    r: char;

  begin
    debugwrite('rpack:');
    set_timer(timint);

    if not getsoh then                       (*if don't get synch char then *)
      begin
        rpack := 'N';                        (* treat as a NAK *)
        num := n mod 64;
        exit(rpack)                          (* and get out of here *)
      end;

  1: if timeout then                        (* if we've tried too many times *)
        begin                               (* and aren't waiting for init *)
          rpack := 'N';                      (* treat as NAK *)
          exit(rpack)                        (* and get out of here *)
        end; (* if *)

    if not getch(r) then                (* get a char and *)
            goto 1;                        (* resynch if soh *)

    ichksum := ord(r);                        (* start checksum *)
    len := ord(unchar(r)) - 3;          (* character count *)

    if not getch(r) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)
    ichksum := ichksum + ord(r);
    num := ord(unchar(r));              (* packet number *)

    if not getch(r) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)
    ichksum := ichksum + ord(r);
    ptype := r;                         (* packet type *)

    for i := 0 to len-1 do                 (* get any data *)
      begin
        if not getch(r) then            (* get a char and *)
            goto 1;                        (* resynch if soh *)
        ichksum := ichksum + ord(r);
        data[i] := r;
      end; (* for i *)
    data[len] := chr(0);                   (* mark end of data *)

    if not getch(r) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)

                                           (* compute final checksum *)
    chksum := chr(aand(ichksum + (aand(ichksum,192) div 64), 63));

    if (chksum <> unchar(r)) then       (* if checksum bad *)
        rpack := chr(0)                      (* return 'false' indicator *)
    else                                   (* else *)
        rpack := ptype;                      (* return packet type *)

    if debug then
      begin
        write(debf,' len:',len,' num:',num,' ptype:',ptype);
        packetwrite(data,len); write(debf,' chksum:',r)
      end; (* if *)
  end; (* rpack *)

(*$G-*) (* turn off goto option...don't need it anymore *)

procedure pak_version;

  begin
    writeln(my_version)
  end {pak_version};

end. { kermpack }
{>>>> KERMGLOB.TEXT}
unit kermglob;

interface

{Change log:
13 May 89, V1.1: Added COMMENT vocab. & Eliminated "int_bool_rec"   RTC
30 Apr 89, V1.1: Added vocabulary for SET INTERFACE command   RTC
26 Apr 89, V1.1: minor cleanups   RTC
16 Apr 89, V1.1: Added BYE & FINISH commands       RTC
13 Apr 89, V1.1: Added Version message      RTC
14 Aug 88: Added LOG, CLOSE, and SET SYSTEM commands    RTC
31 Jul 88: Added variable system_id string for REMUNIT    RTC
31 Jul 88: Added attributes packets & exact size bin. xfrs    RTC
10 Jul 88: Removed screen command definitions    RTC
30 Jun 88: Modified for binary files, "take", ^X & ^Z   RTC
}

   const
         blksize = 512;
         oport = 8;          (* output port # *)
         inport = 7;
         keyport = 2;
         bell = 7;           (* ASCII bell *)
         maxpack = 93;       (* maximum packet size minus 1 *)
         soh = 1;            (* start of header *)
         sp = 32;            (* ASCII space *)
         cr = 13;            (* ASCII CR *)
         lf = 10;            (* ASCII line feed *)
         del = 127;          (* delete *)
         can_cur = 24;       { cancel current file char ^X }
         can_all = 26;       { cancel all files char    ^Z }
         my_esc = 29;        (* default esc char for connect (^]) *)
         maxtry = 5;         (* number of times to retry sending packet *)
         my_quote = '#';     (* quote character I'll use *)
         my_qbin = '&';      { 8th bit quote character I want }
         my_pad = 0;         (* number of padding chars I need *)
         my_pchar = 0;       (* padding character I need *)
         my_eol = 13;        (* end of line character i need *)
         my_time = 5;        (* seconds after which I should be timed out *)
         maxtim = 20;        (* maximum timeout interval *)
         mintim = 2;         (* minimum time out interval *)
         at_eof = -1;        (* value to return if at eof *)
         at_badblk = -2;     { value to return if at bad block }
         {rqsize = 5000;      (* input queue size *)
         qsize1 = 5001;      (* qsize + 1 *)}
         eoln_sym = 13;      (* pascal eoln sym *)
         back_space = 8;     (* pascal backspace sym *)
         defaultbaud = 1200; (* default baud rate *)

   (* screen control information *)
     (* console line on which to put specified info *)
         menu_line = 0;
         title_line = 2;
         statusline = 3;
         packet_line = 4;
         retry_line = 5;
         file_line = 6;
         error_line = 7;
         debug_line = 8;
         prompt_line = 9;
     (* position on line to put info *)
         statuspos = 60;
         packet_pos = 19;
         retry_pos = 17;
         file_pos = 11;

   type packettype = packed array[0..maxpack] of char;
        parity_type = (evenpar, oddpar, markpar, spacepar, nopar);

        string255 = string[255];


        statustype = (null, at_eol, unconfirmed, parm_expected, ambiguous,
                      unrec, fn_expected, ch_expected, num_expected);
        vocab = (nullsym, allsym, baudsym, binsym, byesym, closesym, comsym,
                 consym, convsym, debugsym, emulatesym, escsym, evensym,
                 exitsym, filenamsym, filetypesym, filewarnsym, finsym,
                 getsym, helpsym, ibmsym, intsym, kermitsym, litsym,
                 localsym, logsym, marksym, nonesym, oddsym, offsym, onsym,
                 paritysym, putsym, quitsym, recsym, sendsym, setsym,
                 showsym, spacesym, systemsym, takesym, textsym, ucsdsym,
                 versionsym);

    var noun, verb, adj: vocab;
        status: statustype;
        vocablist: array[vocab] of string[13];
        xfilename, line: string255;
        newescchar: char;
        expected: set of vocab;
        newbaud: integer;

        currstate: char; (* current state *)
        xeol, quote, qbin, esc_char: char;
        lit_names, f_is_binary, fwarn, ibm, half_duplex,
        en_attr, en_qbin, debug: boolean;
        i, size, rpsiz, spsiz, pad, n, num_try, oldtry, timint: integer;
        recpkt, packet: packettype;
        padchar, ch: char;
        s: string255;
        debf: text; (* file for debug output *)
        parity: parity_type;
        xon: char;
        filebuf: packed array[1..blksize] of char;
        bufpos, bufend: integer;
        parity_array: packed array[char] of char;
        ctlset: set of char;
        rec_ok, send_ok: boolean;
        baud: integer;
        emulating: boolean;
        last_blksize : integer;  {size of last block of boolean file}
        t_file : text   {file for text file transfers};
        b_file : file   {file for binary file transfers};
        cmd_file : text {file of "take" commands};
        ker_version,            { version id for other units }
        system_id : string      {id string for REMUNIT};

   procedure gbl_version;

implementation

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

   procedure gbl_version;

     begin
       writeln(my_version)
     end {gbl_version};

end. { kermglob }
{>>>> UCPECAN.M.TEXT}
ckermglob


cfakeutil
kermutil

ckermpack


cparser


chelper


csender


creceiver


cclient


ckermenus


ckermutil


ckermit


{>>>>}