Columbia Kermit/kermit.zip/pub/ucsdpecan/kermpack.text

Text File | 2020-01-01 | 14KB | 430 lines

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 }