(* >>>> KERMPACK.TEXT  *************************************************)

(*$I-*)
(*$R-*)
(*$S+*)
(*$V-*)

UNIT kermpack;  INTRINSIC CODE 21  ;


INTERFACE

USES  kermglob,
      kermutil;


PROCEDURE spar;

PROCEDURE rpar;

PROCEDURE spack( ptype: CHAR; num, len: INTEGER );

PROCEDURE send_errpack( num : INTEGER );

FUNCTION  rpack(spnum: INTEGER; VAR len, rpnum: INTEGER; VAR data: packettype;
                timeout: INTEGER; soh_char: CHAR ) : CHAR;

FUNCTION  bufill_t : INTEGER;

FUNCTION  bufill_i : INTEGER;

PROCEDURE bufemp_t( len : INTEGER );

PROCEDURE bufemp_i( len : INTEGER );


IMPLEMENTATION


FUNCTION bufill_t (* : integer*);

(* fill a packet with data from a textfile...manages a 2 block buffer *)

var i, j, count: integer;
    ch : char;

begin
  i := 4; (* start at packet[4] for data chars *)
  (* while file has some data & packet has some room we'll keep going *)
  while ((bufpos <= bufend) or (not eof(applefile))) and (i < max1_data) do
    begin
      (* if we need more data from disk then *)
      if (bufpos > bufend) and (not eof(applefile)) then
        begin
          (* read a textpage = 2 blocks *)
          bufend := blockread(applefile,filebuf[1],2) * blksize;
          io_status := ioresult;
          if io_status <> 0 then exit( bufill_t );
          (* and adjust buffer pointer *)
          bufpos := 1
        end; (* if *)
      if (bufpos <= bufend) then          (* if we're within buffer bounds *)
        begin
          ch := filebuf[bufpos];          (* get a character *)
          bufpos := bufpos + 1;           (* increase buffer pointer *)
          if (ch = xdle_char) then        (* if it's space compression char, *)
            begin
              count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
              bufpos := bufpos + 1;       (* read past # *)
              ch := ' ';                  (* and make current char a space *)
            end (* if *)
            else                          (* otherwise, it's just a char *)
              count := 1;                 (* so only 1 copy of it *)
          if (ch in ctlq_set) then        (* if a control char *)
            begin
              if (ch = cr) then           (* if a carriage return *)
                begin
                  packet[i] := quote;     (* put (quoted) CR in packet *)
                  i := i + 1;
                  packet[i] := ctl( cr );
                  i := i + 1;
                  ch := lf;               (* and we'll stick a LF after *)
                end; (* if *)
              packet[i] := quote;         (* put the quote in packet *)
              i := i + 1;
              if ch <> quote then
                      ch := ctl(ch);      (* and un-controllify char *)
            end (* if *)
        end; (* if *)
      j := 1;
      while (j <= count) and (i < max2_data) do
        begin                             (* put all the chars in packet *)
          if ch <> chr(0) then            (* so long as not a NUL *)
            begin
              packet[i] := ch;
              i := i + 1;
            end (* if *)
          else bufpos := bufend +1;       (* if is a NUL so *)
                                          (* skip to end of block *)
                                          (* since rest will be NULs *)
          j := j + 1
        end; (* while *)
    end; (* while *)
  if (i = 4) then                         (* if we're at end of file, *)
      bufill_t := (at_eof)                (* indicate it *)
  else                                    (* else *)
    begin
      if (j <= count) then                (* if didn't all fit in packet *)
        begin
          bufpos := bufpos - 2;           (* put buf pointer at DLE *)
                                          (* and update compress count *)
          filebuf[bufpos + 1] := tochar(chr(count-j+1));
        end; (* if *)
      bufill_t := i                       (* return # of data in packet + 4 *)
    end; (* else *)
end; (* bufill_t *)


FUNCTION bufill_i { : integer };

 fills packet with data form another type of file than a textfile.  
 This will only work if serial wordlength can be set to 8 databits, 
 no parity and if both sides plus the transport medium do not change
 in any way the most significant bit of the byte send.              

var i : integer;
    ch : char;
 
begin
  i := 4; ch := ' ';
  while ((bufpos <= bufend) or ( not eof(applefile))) and ( i < spsiz ) do
    begin
      if (bufpos > bufend) and ( not eof(applefile) ) then
        begin
          bufend := blockread( applefile, filebuf[1], 1) * blksize;
          io_status := ioresult;
          if io_status <> 0 then exit( bufill_i );
          bufpos := 1;
        end;
      if (bufpos <= bufend) then
        begin
          ch := filebuf[bufpos];
          bufpos := bufpos + 1;
          if ch in ctlq_set then begin
                                   packet[i] := quote;
                                   i := i + 1;
                                   if ch <> quote then ch := ctl( ch );
                                  end;
          packet[i] := ch;
          i := i + 1;
        end;
    end; { while }
  if i = 4 then bufill_i := at_eof
           else bufill_i := i;
end; { bufill_i }



PROCEDURE bufemp_t { len : integer };

var ch : char;
    i, j : integer;
 
begin
  i := 0;
  while i < len do
  begin
    if bufpos < ( page_size - 1 )
      then begin
             ch := rec_pkt[i];
             if ch = quote
               then begin
                      i := i + 1;
                      ch := rec_pkt[i];
                      if ch = quote
                        then begin
                               filebuf[bufpos] := ch;
                               bufpos := bufpos + 1;
                             end
                        else begin
                               ch := ctl( ch );
                               if ch in [ cr, ff ] then
                                 begin
                                   if ch = ff then if no_ffeed
                                                   then ch := cr;
                                   filebuf[bufpos]   := ch;
                                   filebuf[bufpos+1] := xdle_char;
                                   filebuf[bufpos+2] := ' ';
                                   crpos := bufpos;
                                   bufpos := bufpos + 3;
                                   dle_flag := true;
                                 end;
                             end;
                    end
               else begin
                      if ( ch = ' ' ) and dle_flag
                        then filebuf[bufpos-1] := succ( filebuf[bufpos-1] )
                        else begin
                               dle_flag := false;
                               filebuf[bufpos] := ch;
                               bufpos := bufpos + 1;
                             end;
                    end;
             i := i + 1;
           end
      else begin
             j := blockwrite( rec_file, filebuf[1], 1 );
             bufpos := bufpos - crpos;
             moveleft( filebuf[crpos], filebuf[1], bufpos );
             fillchar( filebuf[crpos], pagesize + 1 - crpos, chr(0) );
             j := blockwrite( rec_file, filebuf[blk_size + 1], 1 );
             io_status := ioresult;
             if j <> 1 then io_status := 8;
             if io_status <> 0 then exit( bufemp_t );
             bufpos := bufpos + 1;
             crpos := pagesize - 1;
           end;
  end;
end;  { bufemp_t }
 
 


PROCEDURE bufemp_i { len : integer };

var ch : char;
    i, j : integer;
 
begin
  i := 0;
  while i < len do
  begin
    if bufpos <= blk_size
      then begin
             ch := rec_pkt[i];
             if ch = quote
               then begin
                      i := i + 1;
                      ch := rec_pkt[i];
                      if ch <> quote then ch := ctl( ch );
                    end;
             filebuf[bufpos] := ch;
             bufpos := bufpos + 1;
             i := i + 1;
           end
      else begin
             j := blockwrite( rec_file, filebuf[1], 1 );
             bufpos := 1;
             io_status := ioresult;
             if j <> 1 then io_status := 8;
             if io_status <> 0 then exit( bufemp_i );
           end;
  end;
end;  { bufemp_i }
 

 


PROCEDURE spar;

(* fills packet with my send-init parameters *)

  begin
    packet[4] := tochar(chr(maxpack));   (* biggest packet i can receive *)
    packet[5] := tochar(chr(mytime));    (* when i want to be timed out *)
    packet[6] := tochar(chr(mypad));     (* how much padding i need *)
    packet[7] := ctl(mypchar);           (* padding char i want *)
    packet[8] := tochar(eoln_char);      (* end of line character i want *)
    packet[9] := myquote;                (* control-quote char i want *)
    packet[10]:= chr(0);                 (* I won't do 8-bit quoting *)
  end; (* spar *)



PROCEDURE rpar;

(* gets their init params *)

begin
  spsiz     := ord(unchar(rec_pkt[0]));         (* max send packet size     *)
  max1_data := spsiz - 2;                       (* calculate maximal        *)
  max2_data := spsiz + 1;                       (* data limits for bufill_t *)
  xtime     := ord(unchar(rec_pkt[1]));         (* when i should time out   *)
  pad       := ord(unchar(rec_pkt[2]));         (* number of pads to send   *)
  padchar   := ctl(rec_pkt[3]);                 (* padding char to send     *)
  xeol_char := unchar(rec_pkt[4]);              (* eol char i must send     *)
  quote     := rec_pkt[5];                      (* incoming data quote char *)
end; (* rpar *)


PROCEDURE spack(*ptype: char; num: integer; len: integer*);

(* send a packet *)

const mtry = 10000;

var j, i, count: integer;
    ch: char;

begin
  if ibm and (currstate <> 's') then           (* if ibm and not SINIT then *)
    begin
      count := 0; ch := ' ';
      repeat                                   (* wait for an xon *)
        repeat
            count := count + 1;
            unitstatus( inport, j, control_word );
        until ( j > 0 ) or ( count > mtry );
        unitread( inport, ch, 1,, 12 );
      until (ch = xon_char) or (count > mtry);
      if count > mtry then exit( spack ); (* if wait too long then get out *)
    end; (* if *)

  if pad > 0 then
    begin
      for i := 1 to pad do
      unitwrite( outport, padchar, 1,, 12 ); (* write out any padding chars *)
    end;
  packet[0] := soh_char;                     (* packet sync character *)
  packet[1] := tochar(chr(len - 1));         (* character count *)
  packet[2] := tochar(chr(num));             (* packet number *)
  packet[3] := ptype;                        (* packet type *)
   (* data chars have already been filled in by by the bufill procedure *)
                                             (* compute final chksum *)
                                             (* len=data chars + 4 *)
  packet[len]   := tochar( calc_checksum( packet, len ) );
  packet[len+1] := xeol_char;
  if debug then packet_write( packet, len+2 );
  unitwrite( outport, packet[0], len+2,, 12 );
end; (* spack *)


PROCEDURE  send_errpack { num : integer };

var len : integer;

begin
  len := length ( err_string );
  moveleft( err_string[1], packet[4], len );
  spack( 'E', num, len+4 );
end;  { send_errpack }


FUNCTION rpack{ (spnum:integer; var len,rpnum:integer; data:packettype;  }
              {  timeout:integer; soh_char:char) : char } ; EXTERNAL;
 
 this function listens to the serial input port, detects a kermit 
 package, decodes it and returns the data part of the packet.     
 its function value is the type of the received packet. If there  
 was a receive error or the timeout period (1..31 sec) was        
 exhausted without receiving a valid packet the function returns  
 with '@' as value, with rpnum=spnum and with len = 0.            


begin
end. { kermpack }