home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
intelrmx86.tar.gz
/
intelrmx86.tar
/
send.p86
< prev
next >
Wrap
Text File
|
1985-10-28
|
18KB
|
704 lines
/* SEND MODULE: this module handles all sending of data between the */
/* host and RMX system */
$compact
$optimize(3)
send$module:
do;
$INCLUDE(:INC:LTKSEL.LIT)
$INCLUDE(:INC:UREAD.EXT)
$INCLUDE(:INC:UWRITE.EXT)
$INCLUDE(:INC:UDCTIM.EXT)
$INCLUDE(:INC:NSLEEP.EXT)
/* here are some global declarations for the communication module */
declare true literally '0FFH';
declare false literally '00H';
declare chrmsk literally '07FH';
declare maxtry literally '05';
declare space literally '020H';
declare cr literally '0DH';
declare lf literally '0AH';
declare null literally '00H';
declare crlf literally 'cr,lf,null';
declare eofl literally '0';
declare delete literally '07FH';
declare send$delay byte external;
declare send$eol byte external;
declare send$paclen byte external;
declare send$padchar byte external;
declare send$padding byte external;
declare send$pause byte external;
declare send$quote byte external;
declare send$start byte external;
declare send$time byte external;
declare readonly literally '1';
declare writeonly literally '2';
declare rdwr literally '3';
declare noedit literally '0';
declare pksize literally '94';
declare send$packet(pksize) byte public; /* buffer for packets */
declare recv$packet(pksize) byte public; /* buffer for packets */
declare send_delay word;
declare state byte; /* FSM last state */
declare msgnum byte; /* message number */
declare tries byte; /* max number of retries */
declare numpads byte; /* how many pads to send */
declare padchar byte; /* the present pad character */
declare eol byte; /* the present eol character */
declare quote byte; /* the present quote character */
declare timeint byte; /* the present time out */
declare spsize byte; /* the present packet size */
declare pklen word;
declare (j,count) word initial (0,0);
declare (k,cnt) word initial (0,0);
declare buflen literally '128';
declare inbuf (buflen) byte;
declare outbuf(buflen) byte;
declare outlen word initial (0);
declare (in$conn,out$conn) token external;
declare (ci$conn,co$conn) token external;
declare status word external;
declare debug byte external;
declare file$conn token external;
declare iobuff(1024) byte external;
declare file$len (2) word external;
declare byte$out dword;
declare byte$tot dword at (@file$len);
declare frac$tot word;
declare filename structure
(len byte,
name(80) byte) external;
declare wait$time byte public;
declare system$end$time dword public;
declare time$buffer structure
(system$time dword,
date(8) byte,
time(8) byte);
/* here are the subroutines */
check$error: procedure (fatal) byte external;
declare fatal byte;
end check$error;
co: procedure(char) external;
declare char byte;
end co;
prints: procedure(msg) external;
declare msg pointer;
end prints;
print: procedure(string) external;
declare string pointer;
end print;
nout: procedure(n) external;
declare n word;
end nout;
noutd: procedure(n) external;
declare n dword;
end noutd;
file$open: procedure (mode) external;
declare mode byte;
end file$open;
newline: procedure external; end newline;
/* TOCHAR: takes a character and converts it to a printable character */
/* by adding a space */
tochar: procedure(char) byte public;
declare char byte;
return (char + space);
end tochar;
/* UNCHAR: undoes 'tochar' */
unchar: procedure(char) byte public;
declare char byte;
return (char - space);
end unchar;
/* CTL: this routine takes a character and toggles the control bit */
/* (ie. ^A becomes A and A becomes ^A). */
ctl: procedure(char) byte public;
declare char byte;
declare cntrlbit literally '040H';
return (char xor cntrlbit);
end ctl;
getc: procedure (conn) byte public;
declare conn token;
if debug then call print(@('Entering getc...',crlf));
k=k+1;
loop:
if k>=cnt then do;
cnt=DQ$READ(conn,@inbuf,buflen,@status);
if check$error(0) then wait$time = 0;
k=0;
if debug then call print(@('back from reading...',crlf));
if cnt=0 then call chk$time;
if wait$time=0 then return 0;
if debug then call print(@('looping back to read again',crlf));
goto loop;
end;
return inbuf(k);
end getc;
putc: procedure (c, conn) public;
declare c byte;
declare conn token;
outbuf(outlen)=c;
outlen=outlen+1;
if outlen>=buflen then call do$put(conn);
end putc;
do$put: procedure (conn) public;
declare conn token;
if outlen>0 then do;
call DQ$WRITE(conn,@outbuf,outlen,@status);
if check$error(0) then return;
outlen=0;
end;
end do$put;
set$end$time: procedure (wait) public;
declare wait byte;
time$buffer.system$time=0;
call DQ$DECODE$TIME(@time$buffer,@status);
if check$error(1) then return;
wait$time=wait;
system$end$time=time$buffer.system$time +
double(double(wait));
if debug then do;
call print(@('wait_time=',null));
call nout(wait$time);
call print(@(' from end_time=',null));
call noutd(system$end$time);
call print(@(' and now_time=',null));
call noutd(time$buffer.system$time);
call newline;
end;
end set$end$time;
chk$time: procedure public;
if debug then call print(@(' enter chk_time...',crlf));
call RQ$SLEEP(10,@status); /* add wait a little? */
if check$error(1) then return;
time$buffer.system$time=0;
call DQ$DECODE$TIME(@time$buffer,@status);
if check$error(1) then return;
if time$buffer.system$time>system$end$time then wait$time=0;
else wait$time=system$end$time-time$buffer.system$time;
if debug then do;
call print(@('wait_time=',null));
call nout(wait$time);
call print(@(' from end_time=',null));
call noutd(system$end$time);
call print(@(' and now_time=',null));
call noutd(time$buffer.system$time);
call newline;
end;
return;
end chk$time;
spar: procedure (a) public;
declare a address;
declare b based a byte;
b = tochar(send$paclen); /* set up header */
a = a + 1;
b = tochar(send$time);
a = a + 1;
b = tochar(send$padding);
a = a + 1;
b = ctl(send$padchar);
a = a + 1;
b = tochar(send$eol);
a = a + 1;
b = send$quote;
end spar;
rpar: procedure (addr) public;
declare addr address;
declare item based addr byte;
spsize = unchar(item); /* isn't plm wonderful? */
addr = addr + 1;
timeint = unchar(item);
addr = addr + 1;
numpads = unchar(item);
addr = addr + 1;
padchar = ctl(item);
addr = addr + 1;
eol = unchar(item);
addr = addr + 1;
quote = item;
end rpar;
bufill: procedure (packet) byte;
declare packet address;
declare (pp, maxpp) address;
declare done byte;
declare chr based pp byte;
declare i word;
done = false;
pp = packet;
maxpp = pp + spsize - 8;
do while not done;
if j>=count then do;
count = DQ$READ(file$conn,@iobuff,512,@status);
if status > 0 then do;
call print(@('Error reading file',crlf));
if check$error(0) then return 0;
end;
if count = 0 then done = true;
j=0;
end;
else do;
do i=j to count-1;
if ((iobuff(i) and chrmsk) < space) or
((iobuff(i) and chrmsk) = delete) then
do;
chr = quote;
pp = pp + 1;
chr = ctl(iobuff(i));
end;
else
if (iobuff(i) and chrmsk) = quote then
do;
chr = quote;
pp = pp + 1;
chr = iobuff(i);
end;
else
chr = iobuff(i);
pp = pp + 1;
byte$out=byte$out+1;
if pp >= maxpp then do;
j = i+1;
return (pp-packet);
end;
end;
j=count+1;
end;
end;
return (pp - packet);
end bufill;
/* SPACK: this routine sends a packet of data to the host, it takes */
/* four parameters, the type of packet, message number, packet length */
/* and a pointer to a buffer containing what is to be output. It does */
/* not return a value. */
spack: procedure(type, pknum, length, packet) public;
declare (type, pknum, length) byte;
declare packet address;
declare char based packet byte;
declare (i, chksum) byte;
if debug then do;
call print(@('Sending packet ',null));
call nout(pknum);
call newline;
end;
i = 1; /* do padding */
do while (i <= numpads);
call putc(padchar, out$conn);
i = i + 1;
end;
chksum = 0;
/* send the packet header */
call putc(send$start, out$conn); /* send packet marker (soh) */
if debug then call co('s');
i = tochar(length + 3);
chksum = i;
call putc(i, out$conn); /* send character count */
if debug then call co('c');
i = tochar(pknum);
chksum = chksum + i; /* add in packet number */
call putc(i, out$conn); /* send packet number */
if debug then call co('n');
chksum = chksum + type; /* add in packet type */
call putc(type, out$conn); /* send the packet type */
if debug then call co(type);
/* now send the data */
do i = 1 to length;
chksum = chksum + char;
call putc(char, out$conn);
if debug then call co(char);
packet = packet + 1;
end;
/* check sum generation */
chksum = ((chksum + (chksum and 192) / 64) and 63);
chksum = tochar(chksum);
call putc(chksum, out$conn); /* send the chksum */
if debug then call co('c');
call putc(eol, out$conn); /* terminate the packet */
if debug then do;
call co('e');
call newline;
end;
call do$put(out$conn);
end spack;
/* RPACK: this routine receives a packet from the host. It takes three */
/* parameters: the address of where to put the length of the packet, */
/* the address of where to put the packet number and the address of the */
/* buffer to recieve the data. It returns true for a positive reply or */
/* false for a NEGative reply. */
rpack: procedure(length, pknum, packet) byte public;
declare (length, pknum, packet, pkptr) address;
declare len based length byte;
declare num based pknum byte;
declare pk based pkptr byte;
declare (i, index, chksum, hischksum, type, inchar, msglen) byte;
declare buffer(128) byte;
if debug then call print(@('rpack | ',null));
inchar = 0; /* wait for a header */
call set$end$time(send$time);
do while inchar <> send$start;
inchar = getc(in$conn);
if wait$time=0 then return 'N';
end;
index = 0;
call set$end$time(send$time);
inchar = getc(in$conn);
if wait$time=0 then return 'N';
do while (inchar <> send$eol);
buffer(index) = inchar;
index = index + 1;
inchar = getc(in$conn);
if wait$time=0 then return 'N';
end;
buffer(index) = null;
if debug then do;
call print(@('Received packet: [',null));
call print(@buffer);
call print(@(']',cr,lf,'Length of message: ',null));
end;
msglen = index - 1;
if debug then do;
call nout(msglen);
call newline;
call print(@('Length field: ',null));
call nout(buffer(0));
call co('_');
end;
len = unchar(buffer(0)-3);
if debug then do;
call nout(len);
call print(@(cr,lf,'Message number: ',null));
call nout(buffer(1));
call co('_');
end;
num = unchar(buffer(1));
if debug then do;
call nout(num);
call print(@(cr,lf,'Type: ',null));
end;
type = buffer(2);
if debug then do;
call co(type);
call newline;
end; /* debug */
pkptr = packet;
chksum = buffer(0) + buffer(1) + buffer(2);
i = 3; /* index of first data character */
do while (i < msglen);
chksum = (pk := buffer(i)) + chksum;
pkptr = pkptr+1;
i = i + 1;
end;
pk = null; /* terminate with null for printing */
pkptr = packet;
chksum = (chksum + ((chksum and 192) / 64)) and 63;
if debug then do;
call print(@('His checksum: ',null));
call nout(buffer(msglen));
call co('_');
end; /* debug */
hischksum = unchar(buffer(msglen));
if debug then do;
call nout(hischksum);
call print(@(cr,lf,'Our checksum: ',null));
call nout(chksum);
call newline;
end; /* debug */
if chksum = hischksum then do;
if debug then call co('.');
if type='E' then do;
if len>0 then call print(@pk);
end;
return type;
end;
call print(@('Bad checksum received', crlf));
len=0;
return 'E';
end rpack;
/* SDATA: this routine sends the data from the buffer area to the host. */
/* It takes no parameters but returns the next state depending on the */
/* type of acknowledgement. */
sdata: procedure byte;
declare (num, length, retc) byte;
if debug then call print(@('sdata...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
call spack('D', msgnum, pklen, .send$packet);
retc = rpack(.length, .num, .recv$packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* here when good acknowledgement */
tries = 0;
msgnum = (msgnum + 1) mod 64;
pklen = bufill(.send$packet);
frac$tot=(byte$out*100)/byte$tot;
call print(@('output ',null));
call noutd(byte$out);
call print(@(' bytes = ',null));
call nout(frac$tot);
call print(@('%',cr,null));
if pklen > 0 then return 'D';
else return 'Z';
end sdata;
/* SFILE: this routine sends a packet to the host which contains the */
/* filename of the file being sent so that the file can be created at */
/* the host end. It returns a new state depending on the nature of the */
/* the hosts acknowledgement. */
sfile: procedure byte;
declare (num, length, retc) byte;
declare fnptr address;
declare fnindex based fnptr byte;
if debug then call print(@('sfile...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
if debug then call print(@(cr,lf,'Filename is: ',null));
call prints(@filename);
call newline;
if debug then do;
call print(@(cr,lf,'length is: ',null));
call nout(length);
call newline;
end; /* debug */
call spack('F', msgnum, filename.len,.filename.name);
retc = rpack(.length, .num, .recv$packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* here on valid acknowledgement */
tries = 0;
msgnum = (msgnum + 1) mod 64;
pklen = bufill(.send$packet);
if debug then call nout(pklen);
if debug then call newline;
if pklen > 0 then return 'D';
else return 'Z';
end sfile;
/* SEOF: this routine is used when eof is detected, it closes up and */
/* returns the new state as usual. */
seof: procedure byte;
declare (num, length, retc) byte;
if debug then call print(@('seof...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
call spack('Z', msgnum, 0, .send$packet);
retc = rpack(.length, .num, .recv$packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* here on valid acknowledgement */
byte$out=0;
tries = 0;
/* here is where you open next file if wildcard spec. */
filename.len=0;
msgnum = (msgnum + 1) mod 64;
if filename.len=0 then
return 'B';
else do;
call file$open(1);
return 'S';
end;
end seof;
/* SINIT: this routine does initialisations and opens the file to be */
/* send, it returns a new state depending on the outcome of trying to */
/* open the file. */
sinit: procedure byte;
declare (len, num, retc) byte;
call print(@(cr,lf,'Sending ',null));
if tries > maxtry then return 'A';
else tries = tries + 1;
call spar(.send$packet);
call spack('S', msgnum, 6, .send$packet); /* send start packet */
retc = rpack(.len, .num, .recv$packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* here on valid acknowledgement */
call rpar(.recv$packet);
if eol = 0 then eol = send$eol;
if quote = 0 then quote = send$quote;
byte$out=0;
tries = 0;
msgnum = (msgnum + 1) mod 64;
return 'F';
end sinit;
/* SBREAK: this module breaks the flow of control at the end of a */
/* transmission and allows the send routine to terminate by returning */
/* either a successful or failure condition to the main kermit routine. */
sbreak: procedure byte public;
declare (num, length, retc) byte;
if debug then call print(@('sbreak...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
call spack('B', msgnum, 0, .send$packet);
retc = rpack(.length, .num, .recv$packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* we only get here if we received a valid acknowledgement */
tries = 0;
msgnum = (msgnum + 1) mod 64;
return 'C';
end sbreak;
/* serror: this module sends an error packet to abort the transmittion */
serror: procedure byte;
declare (num, length, retc) byte;
if debug then call print(@('serror...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
call spack('B', msgnum, 0, .send$packet);
retc = rpack(.length, .num, .recv$packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* we only get here if we received a valid acknowledgement */
tries = 0;
msgnum = (msgnum + 1) mod 64;
return 'A';
end serror;
send$setup: procedure public;
msgnum = 0;
tries = 0;
spsize = send$paclen;
timeint = send$time;
numpads = send$padding;
padchar = send$padchar;
eol = send$eol;
quote = send$quote;
end send$setup;
/* SEND: here's the main code for the send command, it's a FSM for */
/* sending files. The main loop calles various routines until it */
/* finishes or an error occurs; this is signified by a true or false */
/* result being returned to the main 'kermit' routine. */
send: procedure byte public;
state = 'S'; /* start in Send-Init state */
call send$setup;
send_delay=double(send$delay)*100;
if co$conn=out$conn then call RQ$SLEEP(send_delay,@status);
do while true;
if debug then
do;
call print(@('state : ',null));
call co(state);
call newline;
end;
if state = 'D' then state = sdata;
else
if state = 'F' then state = sfile;
else
if state = 'Z' then state = seof;
else
if state = 'S' then state = sinit;
else
if state = 'B' then state = sbreak;
else
if state = 'C' then return true;
else
if state = 'A' then return false;
else
if state = 'E' then return false;
else return false;
end;
end send;
end send$module;