home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ucsdwdme.tar.gz
/
ucsdwdme.tar
/
rsutils.text
< prev
next >
Wrap
Text File
|
1984-12-03
|
15KB
|
403 lines
function getfil(*filename: string): boolean*);
(* opens a file for writing *)
begin
(*$I-*) (* turn i/o checking off *)
rewrite(f,filename);
(*$I-*) (* turn i/o checking on *)
getfil := (ioresult = 0)
end; (* getfil *)
procedure bufemp(*buffer: packettype; var f: text; len: integer*);
(* empties a packet into a file *)
var i,ls: integer;
r: char;
s: string;
begin
s := copy('',0,0);
ls := 0;
i := 0;
while i < len do
begin
r := buffer[i]; (* get a character *)
if (r = myquote) then (* if character is control quote *)
begin
i := i + 1; (* skip over quote and *)
r := buffer[i]; (* get quoted character *)
if (aand(ord(r),127) <> ord(myquote)) then
r := ctl(r); (* controllify it *)
end; (* if *)
if (ord(r) = cr) then (* else if a carriage return then *)
begin
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 (* if io_error *)
begin
io_error(ioresult); (* tell them and *)
state := 'a'; (* abort *)
end (* if *)
end
(*$I+*) (* turn i/o checking back on *)
else (* else, is a regular char, so *)
begin
r:= chr(aand(ord(r),127)); (* mask off parity bit *)
s := concat(s,' '); (* and add character to out string *)
ls := ls + 1;
s[ls] := r;
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 (* if io_error *)
begin
io_error(ioresult); (* tell them and *)
state := '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;
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-9) 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 := filebuf[bufpos]; (* get a character *)
bufpos := bufpos + 1; (* increase buffer pointer *)
if (ord(r) = dle) then (* if it's space compression char, *)
begin
count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
bufpos := bufpos + 1; (* read past # *)
r := ' '; (* 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 in ctlset) then (* if a control char *)
begin
if (ord(r) = 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 := chr(lf); (* and we'll stick a LF after *)
end; (* if *)
if r <> chr(0) then (* if not a NUL then *)
begin
buffer[i] := quote; (* put the quote in buffer *)
i := i + 1;
if r <> quote then
r := ctl(r); (* and un-controllify char *)
end (* if *)
end; (* if *)
end; (* if *)
j := 1;
while (j <= count) and (i <= spsiz - 5) do
begin (* put all the chars in buffer *)
if (ord(r) <> 0) then (* so long as not a NUL *)
begin
buffer[i] := r;
i := i + 1;
end (* if *)
else (* 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 *)
var s:string;
begin
s:='rpar:spsize:## timint:## pad:## padchar:### eol:### quote:###';
spsiz := ord(unchar(packet[0])); (* max send packet size *)
s[13]:=chr(ord('0')+(spsiz div 10));
s[14]:=chr(ord('0')+(spsiz mod 10));
timint := ord(unchar(packet[1])); (* when i should time out *)
s[23]:=chr(ord('0')+(timint div 10));
s[24]:=chr(ord('0')+(timint mod 10));
pad := ord(unchar(packet[2])); (* number of pads to send *)
s[30]:=chr(ord('0')+(pad div 10));
s[31]:=chr(ord('0')+(pad mod 10));
padchar := ctl(packet[3]); (* padding char to send *)
s[41]:=chr(ord('0')+(ord(padchar) div 100));
s[42]:=chr(ord('0')+((ord(padchar) mod 100) div 10));
s[43]:=chr(ord('0')+(ord(padchar) mod 10));
eol := unchar(packet[4]); (* eol char i must send *)
s[49]:=chr(ord('0')+(ord(eol) div 100));
s[50]:=chr(ord('0')+((ord(eol) mod 100) div 10));
s[51]:=chr(ord('0')+(ord(eol) mod 10));
quote := packet[5]; (* incoming data quote char *)
s[59]:=chr(ord('0')+(ord(quote) div 100));
s[60]:=chr(ord('0')+((ord(quote) mod 100) div 10));
s[61]:=chr(ord('0')+(ord(quote) mod 10));
debugwrite(s);
end; (* rpar *)
procedure packetwrite(*p: packettype; len: integer*);
(* writes out all of a packet for debugging purposes *)
var i: integer;
s: string;
begin
s:='length:## Sequence:## Type: #';
if p[0]=chr(soh) then s:=concat('SOH ',s);
s[8]:=chr(ord('0')+(ord(p[1]) div 10));
s[9]:=chr(ord('0')+(ord(p[1]) mod 10));
s[20]:=chr(ord('0')+(ord(p[2]) div 10));
s[21]:=chr(ord('0')+(ord(p[2]) mod 10));
s[length(s)]:=p[3];
debugwrite(s);
gotoxy(0,debugline+debnext);
debnext:=(debnext+1) mod debug_max;
for i := 4 to len+3 do
begin
if i = 84 then
begin
gotoxy(0,debugline+debnext);
debnext:=(debnext+1) mod debug_max;
write(chr(27),'K');
end; (* if *)
write(p[i])
end; (* for *)
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 (state <> 's') then (* if ibm and not SINIT then *)
begin
count := 0;
repeat (* wait for an xon *)
repeat
count := count + 1
until (readch(modem,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 begin
while not istbtr do ;
sndbbt(padchar); (* write out any padding chars *)
end;
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] := eol;
if (parity <> nopar) then
for i := 0 to bufp do (* set correct parity on buffer *)
buffer[i] := parity_array[buffer[i]];
for i:=0 to bufp do begin
while not istbtr do;
sndbbt(buffer[i]); (* send the packet out *)
end;
debugwrite('sending');
if debug then
packetwrite(buffer,len);
end; (* spack *)
function getsoh(*p: port): boolean*);
(* reads characters until it finds an SOH; returns false if has to read more *)
(* than maxtry chars *)
const maxtry = 10000; (* allows about 1 second of trying *)
var ch: char;
seconds,count: integer;
begin
count := 0;
seconds:=0;
get_soh := true;
repeat
repeat
count := count + 1;
if count>maxtry then begin
seconds:=seconds+1;
count:=0;
end;
until ready(p) or (seconds > timint); (* wait for a character *)
if (seconds > timint) then
begin
get_soh := false;
exit(get_soh);
end;
ch := pget(p); (* get the character *)
ch := chr(aand(ord(ch),127)); (* strip parity of char *)
until (ch = chr(SOH)) (* if not SOH, get more *)
end; (* getsoh *)
(*$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; (* allows for about 1 second of checking *)
var seconds, count, i, ichksum: integer;
chksum, ptype: char;
r: char;
begin
count := 0;
seconds := 0;
if not getsoh(modem) and (state<>'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(state<>'r') then (* end of one second *)
if seconds<timint then begin (* and aren't waiting for init *)
count:=0;
seconds:=seconds+1;
end
else begin (* if we've tried too many times *)
rpack := 'N'; (* treat as NAK *)
exit(rpack) (* and get out of here *)
end; (* if *)
if not getch(r,modem) 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,modem) then (* get a char and *)
goto 1; (* resynch if soh *)
ichksum := ichksum + ord(r);
num := ord(unchar(r)); (* packet number *)
if not getch(r,modem) 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,modem) 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,modem) 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
gotoxy(0,debugline+debnext);
debnext:= (debnext+1) mod debug_max;
write('rpack: len:',len,' num:',num,' ptype:',ptype);
end; (* if *)
end; (* rpack *)
(*$G-*) (* turn off goto option...don't need it anymore *)