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