home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ucsdpecan.tar.gz
/
ucsdpecan.tar
/
kermpack.text
< prev
next >
Wrap
Text File
|
1990-08-05
|
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 }