/* 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;