home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ucsdappleii.tar.gz
/
ucsdappleii.tar
/
kermpack.text
< prev
next >
Wrap
Text File
|
1986-04-08
|
12KB
|
358 lines
(* >>>> 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 }