kermit.columbia.edu/kermit.columbia.edu.tar/kermit.columbia.edu/ucsdibmpc/kermpack.text

Text File | 1984-05-22 | 13KB | 349 lines

unit kermpack;

interface

   uses {$U kermglob.code} kermglob;


   procedure spar(var packet: packettype);

   procedure rpar(var packet: packettype);

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

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

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

   function bufill(var buffer: packettype): integer;


implementation

uses {$U kermutil.code} kermutil;


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_int_rec;
    s: string255;

begin
   s := copy('',0,0);
   ls := 0;
   i := 0;
   while i < len do begin
      r.ch := buffer[i];          (* get a character *)
      if (r.ch = myquote) then begin   (* if character is control quote *)
         i := i + 1;               (* skip over quote and *)
         r.ch := buffer[i];        (* get quoted character *)
         if (aand(r.i,127) <> ord(myquote)) then
            r.ch := ctl(r.ch);    (* controllify it *)
      end; (* if *)
      if (r.i = lf) then { skip linefeeds SP }
         i := i + 1
      else if (r.i = cr) then begin     (* else if a carriage return then *)
         i := i + 1;
         {  i := i + 3;  }         (* skip over that and line feed *)
         (*$I-*)                   (* turn i/o checking off *)
         writeln(f,s);             (* and write out line to file *)
         s := copy('',0,0);        (* empty the string var *)
         ls := 0;
         if (io_result <> 0) then begin (* if io_error *)
            io_error(ioresult);     (* tell them and *)
            currstate := 'a';           (* abort *)
         end (* if *)
      end
      (*$I+*)                      (* turn i/o checking back on *)
      else begin                   (* else, is a regular char, so *)
         r.i := aand(r.i,127);     (* mask off parity bit *)
         s := concat(s,' ');       (* and add character to out string *)
         ls := ls + 1;
         s[ls] := r.ch;
         i := i + 1                (* increase buffer pointer *)
      end; (* else *)
   end; (* while *)              (* and get another char *)
   (*$I-*)                     (* turn i/o checking off *)
   write(f,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; (* bufemp *)


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

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

var i, j, k, t7, count: integer;
    r: char_int_rec;

  begin
    i := 0;
    (* while file has some data & packet has some room we'll keep going *)
    while ((bufpos <= bufend) or (not eof(oldf))) and (i < spsiz-12) do
      begin
        (* if we need more data from disk then *)
        if (bufpos > bufend) and (not eof(oldf)) then
          begin
            (* read a couple of blocks *)
            bufend := blockread(oldf,filebuf[1],2) * blksize;
            (* and adjust buffer pointer *)
            bufpos := 1
          end; (* if *)
        if (bufpos <= bufend) then     (* if we're within buffer bounds *)
          begin
            r.ch := filebuf[bufpos];      (* get a character *)
            bufpos := bufpos + 1;         (* increase buffer pointer *)
            if (r.i = xdle) then           (* if it's space compression char, *)
              begin
                count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
                bufpos := bufpos + 1;       (* read past # *)
                r.ch := ' ';                (* and make current char a space *)
              end (* else if *)
            else                           (* otherwise, it's just a char *)
                count := 1;                (* so only 1 copy of it *)
            if (r.ch in ctlset) then     (* if a control char *)
              begin
                if (r.i = cr) then         (* if a carriage return *)
                  begin
                    buffer[i] := quote;      (* put (quoted) CR in buffer *)
                    i := i + 1;
                    buffer[i] := ctl(chr(cr));
                    i := i + 1;
                    r.i := lf;                (* and we'll stick a LF after *)
                  end; (* if *)
                if r.i <> 0 then           (* if not a NUL then *)
                  begin
                    buffer[i] := quote;      (* put the quote in buffer *)
                    i := i + 1;
                    if r.ch <> quote then
                        r.ch := ctl(r.ch);   (* and un-controllify char *)
                  end (* if *)
              end; (* if *)
          end; (* if *)
        j := 1;
        while (j <= count) and (i <= spsiz - 8) do
          begin                           (* put all the chars in buffer *)
            if (r.i <> 0) then            (* so long as not a NUL *)
              begin
                buffer[i] := r.ch;
                i := i + 1;
              end (* if *)
            else                          (* if is a NUL so *)
                if (bufpos > blksize) then  (* skip to end of block *)
                    bufpos := bufend + 1    (* since rest will be NULs *)
                else
                    bufpos := blksize + 1;
            j := j + 1
          end; (* while *)
      end; (* while *)
    if (i = 0) then                         (* if we're at end of file, *)
        bufill := (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 := i                           (* return # of chars in packet *)
      end; (* else *)
  end; (* bufill *)


procedure spar(*var packet: packettype*);

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

  begin
    packet[0] := tochar(chr(maxpack));   (* 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 *)
    packet[6] := 'N';                    (* I won't do 8-bit quoting *)
  end; (* spar *)

procedure rpar(*var packet: packettype*);

(* gets their init params *)

  begin
    spsiz := ord(unchar(packet[0]));     (* max send packet size *)
    timint := ord(unchar(packet[1]));    (* when i should time out *)
    pad := ord(unchar(packet[2]));       (* number of pads to send *)
    padchar := ctl(packet[3]);           (* padding char to send *)
    xeol := unchar(packet[4]);            (* eol char i must send *)
    quote := packet[5];                  (* incoming data quote char *)
  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+3 do
        write(p[i])
  end; (* packetwrite *)

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

(* send a packet *)

const maxtry = 10000;

var bufp, i, count: integer;
    chksum: char;
    buffer: packettype;
    ch: char;

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

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

    for i := 0 to len - 1 do                 (* loop through data chars *)
      begin
        buffer[bufp] := data[i];             (* store char *)
        bufp := bufp + 1;
        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));
    buffer[bufp] := tochar(chksum);
    bufp := bufp + 1;
    buffer[bufp] := xeol;

    if (parity <> nopar) then
        for i := 0 to bufp do                 (* set correct parity on buffer *)
            buffer[i] := parity_array[buffer[i]];

    {unitwrite(oport,buffer[0],bufp+1,,12);}       (* send the packet out *)

    for i := 0 to bufp do
       write_ch(oport, buffer[i]);

    if debug then
        packetwrite(buffer,len);
  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 *)

const maxtry = 10000;

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

  begin
    count := 0;

    if not getsoh and (currstate<>'r') 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: count := count + 1;
     if (count>maxtry)and(currstate<>'r') 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 := r.i;                        (* start checksum *)
    len := ord(unchar(r.ch)) - 3;          (* character count *)

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

    if not getch(r) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)
    ichksum := ichksum + r.i;
    ptype := r.ch;                         (* 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 + r.i;
        data[i] := r.ch;
      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.ch)) then       (* if checksum bad *)
        rpack := chr(0)                      (* return 'false' indicator *)
    else                                   (* else *)
        rpack := ptype;                      (* return packet type *)

    if debug then
      begin
        gotoxy(0,debugline);
        write(len,num,ptype);
        for i := 1 to 1000 do
            ;
      end; (* if *)
  end; (* rpack *)

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


end. { kermpack }