home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
intelmdsa.tar.gz
/
intelmdsa.tar
/
md2sen.plm
< prev
Wrap
Text File
|
1988-08-16
|
29KB
|
986 lines
/* SEND MODULE: this module handles all sending of data between the */
/* host and development system */
send$module:
do;
/* here are some global declarations for the communication module */
declare true literally '0FFH';
declare false literally '00H';
declare oldtry byte;
declare port1cmd literally '0F5H';
declare port2cmd literally '0F7H';
declare port1dat literally '0F4H';
declare port2dat literally '0F6H';
declare tx$rdy literally '01H';
declare rx$rdy literally '02H';
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 soh literally '1';
declare eofl literally '0';
declare delete literally '07FH';
declare myquote literally '023H';
declare mynumpads literally '0';
declare mypadchr literally '0';
declare myeol literally 'cr';
declare mytime literally '5';
declare readonly literally '1';
declare writeonly literally '2';
declare rdwr literally '3';
declare noedit literally '0';
declare pksize literally '94';
declare packet(pksize) byte public; /* buffer for packets */
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 port byte external; /* the port to use */
declare filename address external; /* the address of the filename */
declare lfilename address external; /* the address of the filename */
declare (jfn, status, pklen) address;
declare ljfn address;
declare cmdptr address external;
declare debug byte external;
/* here are the subroutines */
exit: procedure external;
end exit;
co: procedure(char) external;
declare char byte;
end co;
print: procedure(string) external;
declare string address;
end print;
nout: procedure(n) external;
declare n address;
end nout;
getrecv: procedure byte external;
end getrecv;
ci: procedure byte external;
end ci;
open: procedure(jfn, filenm, access, mode, status) external;
declare (jfn, filenm, access, mode, status) address;
end open;
read: procedure(jfn, buffer, count, actual, status) external;
declare (jfn, buffer, count, actual, status) address;
end read;
close: procedure(jfn, status) external;
declare (jfn, status) address;
end close;
newline: procedure external; end newline;
token: procedure address external; end token;
/* GNXTFN: this routine returns a pointer to the next file in a file */
/* list, or false if there are none. */
gnxtfn: procedure address;
filename = token;
return (filename > 0);
end gnxtfn;
/* PUTC: takes a character and a port, waits for transmit ready from */
/* port and then sends the character to it. Doesn't return a result */
putc: procedure (c, port) public;
declare (c, status, port) byte;
status = 0;
do case port;
do;
call co(c);
end;
do;
do while (status := input(port1cmd) and tx$rdy) = 0; end;
output(port1dat) = c;
end;
do;
do while (status := input(port2cmd) and tx$rdy) = 0; end;
output(port2dat) = c;
end;
end;
end putc;
/* GETC: this routine waits for something from the receive port then */
/* brings in the character and returns as a result. */
getc: procedure (port) byte public;
declare (c, status, port) byte;
status = 0;
do case port;
do;
c = ci;
end;
do;
do while status = 0;
status = (input(port1cmd) and rx$rdy);
end;
c = input(port1dat);
end;
do;
do while status = 0;
status = (input(port2cmd) and rx$rdy);
end;
c = input(port2dat);
end;
end;
return c;
end getc;
/* 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;
spar: procedure (a) public;
declare a address;
declare b based a byte;
b = tochar(pksize); /* set up header */
a = a + 1;
b = tochar(mytime);
a = a + 1;
b = tochar(mynumpads);
a = a + 1;
b = ctl(mypadchr);
a = a + 1;
b = tochar(myeol);
a = a + 1;
b = myquote;
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 (i, c, done) byte;
declare chr based pp byte;
declare count address;
done = false;
pp = packet;
maxpp = pp + spsize - 8;
do while not done;
call read(jfn, .c, 1, .count, .status);
if status > 0 then
do;
call print(.('Error reading file',crlf));
call exit;
end;
if count = 0 then
done = true;
else do;
if ((c and chrmsk) < space) or
((c and chrmsk) = delete) then
do;
chr = quote;
pp = pp + 1;
chr = ctl(c);
end;
else
if (c and chrmsk) = quote then
do;
chr = quote;
pp = pp + 1;
chr = c;
end;
else
chr = c;
pp = pp + 1;
if pp >= maxpp then done = true;
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, port);
if debug then call co('p');
i = i + 1;
end;
chksum = 0;
/* send the packet header */
call putc(soh, port); /* send packet marker (soh) */
if debug then call co('s');
i = tochar(length + 3);
chksum = i;
call putc(i, port); /* send character count */
if debug then call co('c');
i = tochar(pknum);
chksum = chksum + i; /* add in packet number */
call putc(i, port); /* send packet number */
if debug then call co('n');
chksum = chksum + type; /* add in packet type */
call putc(type, port); /* 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, port);
if debug then call co('.');
packet = packet + 1;
end;
/* check sum generation */
chksum = ((chksum + (chksum and 192) / 64) and 63);
chksum = tochar(chksum);
call putc(chksum, port); /* send the chksum */
if debug then call co('c');
call putc(eol, port); /* terminate the packet */
if debug then do;
call print(.('e',crlf));
call co('.');
end;
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 */
do while inchar <> soh; inchar = getc(port); end;
index = 0;
inchar = getc(port);
do while (inchar <> myeol);
buffer(index) = inchar;
index = index + 1;
inchar = getc(port);
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 */
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('.');
return type;
end;
call print(.('Bad checksum received', crlf));
return false;
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, .packet);
retc = rpack(.length, .num, .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(.packet);
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 (char,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;
length = 0; /* count characters in filename */
fnptr = filename;
char = fnindex;
do while fnindex > space;
length = length + 1;
fnptr = fnptr + 1;
end;
if debug then call print(.(cr,lf,'Filename is: ',null));
call print(filename);
if debug then do;
call print(.(cr,lf,'length is: ',null));
call nout(length);
call newline;
end; /* debug */
if ( char = ':' ) then do;
filename = filename + 4;
length = length - 4;
end; /* if */
call spack('F', msgnum, length, filename);
retc = rpack(.length, .num, .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(.packet);
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, .packet);
retc = rpack(.length, .num, .packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* here on valid acknowledgement */
tries = 0;
call close(jfn, .status);
if status > 0 then call print(.('Unable to close file',crlf));
if gnxtfn = false then
do;
msgnum = (msgnum + 1) mod 64;
return 'B';
end;
else return 'S';
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 debug then call print(.('sinit...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
if filename = 0 then return 'A';
call spar(.packet);
call spack('S', msgnum, 6, .packet); /* send start packet */
retc = rpack(.len, .num, .packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* here on valid acknowledgement */
call rpar(.packet);
if eol = 0 then eol = myeol;
if quote = 0 then quote = myquote;
tries = 0;
msgnum = (msgnum + 1) mod 64;
call open(.jfn, filename, readonly, noedit, .status);
if (status > 0) then return 'A';
else return 'F';
end sinit;
/* this routine sends a command to the VAX to shut down
the SERVER mode
*/
sfini: procedure byte;
declare (len, num, retc) byte;
if debug then call print(.('sinit...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
call spar(.packet);
call spack('G', msgnum, 1, .('F')); /* send start packet */
retc = rpack(.len, .num, .packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* here on valid acknowledgement */
call rpar(.packet);
if eol = 0 then eol = myeol;
if quote = 0 then quote = myquote;
tries = 0;
msgnum = (msgnum + 1) mod 64;
return 'W';
end sfini;
/* this routine sends a command to the VAX to log out
the VAX itself
*/
sbye: procedure byte;
declare (len, num, retc) byte;
if debug then call print(.('sinit...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
call spar(.packet);
call spack('G', msgnum, 1, .('L')); /* send start packet */
retc = rpack(.len, .num, .packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* here on valid acknowledgement */
call rpar(.packet);
if eol = 0 then eol = myeol;
if quote = 0 then quote = myquote;
tries = 0;
msgnum = (msgnum + 1) mod 64;
return 'W';
end sbye;
sget: procedure byte;
declare (len, num, retc) byte,
pp address,
cch based pp byte;
if debug then call print(.('sinit...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
if filename = 0 then return 'A';
else do;
pp = filename;
/* check the length of filename */
if cch = '[' then do;
do while cch <> ']';
pp = pp + 1;
end;
end;
do while cch <> '.';
pp = pp + 1;
end;
end;
len = pp - filename + 4;
call spack('R', msgnum, len, filename); /* send start packet */
retc = rpack(.len, .num, .packet);
if (retc <> 'S') then return state;
/* here on send init received */
call rpar(.packet);
call spar(.packet);
call spack('Y', msgnum, 6, .packet);
oldtry = tries;
tries = 0;
msgnum = (msgnum + 1) mod 64;
return 'F';
end sget;
scwd: procedure byte;
declare (len, num, retc) byte,
i byte,
dir (20) byte,
pp address,
cch based pp byte;
if debug then call print(.('sinit...',crlf));
if tries > maxtry then return 'A';
else tries = tries + 1;
pp = filename;
dir(0) = 'C';
i = 2;
if filename > 0 then
do;
do while cch <> 0;
dir(i) = cch;
pp = pp + 1;
i = i + 1;
end;
end;
dir(i) = 0;
len = pp - filename + 2;
dir(1) = len + 32;
filename = .dir;
call spack('G', msgnum, len, filename); /* send start packet */
retc = rpack(.len, .num, .packet);
if (retc = 'N') then return state;
if (retc <> 'Y') then return 'A';
/* here on valid acknowledgement */
call rpar(.packet);
if eol = 0 then eol = myeol;
if quote = 0 then quote = myquote;
tries = 0;
msgnum = (msgnum + 1) mod 64;
return 'W';
end scwd;
/* 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;
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, .packet);
retc = rpack(.length, .num, .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;
/* 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;
declare filename address;
state = 'S'; /* start in Send-Init state */
msgnum = 0;
tries = 0;
spsize = pksize;
timeint = mytime;
numpads = mynumpads;
padchar = mypadchr;
eol = myeol;
quote = myquote;
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 return false;
end;
end send;
/* this routine will get a file from VAX when VAX-KERMIT is in
SERVER mode .
*/
get: procedure byte public;
state = 'R'; /* start in Get-Init state */
msgnum = 0;
tries = 0;
spsize = pksize;
timeint = mytime;
numpads = mynumpads;
padchar = mypadchr;
eol = myeol;
quote = myquote;
do while true;
if debug then
do;
call print(.('state : ',null));
call co(state);
call newline;
end;
if state = 'F' then state = getrecv;
else
if state = 'R' then state = sget;
else
if state = 'W' then return true;
else
if state = 'A' then return false;
else return false;
end;
end get;
/* this routine is used to change working directory of
VAX when VAX-KERMIT is in SERVER mode .
*/
cwd: procedure byte public;
state = 'C';
msgnum = 0;
tries = 0;
spsize = pksize;
timeint = mytime;
numpads = mynumpads;
padchar = mypadchr;
eol = myeol;
quote = myquote;
do while true;
if debug then
do;
call print(.('state : ',null));
call co(state);
call newline;
end;
if state = 'C' then state = scwd;
else
if state = 'W' then
do;
call print(.(' DIRECTORY SYSUSERS:$'));
filename = filename + 2;
call print(filename);
return true;
end;
else
if state = 'A' then return false;
else return false;
end;
end cwd;
/* This routine is used to exit from VAX-KERMIT
When VAX-KERMIT is in SERVER mode
*/
finish: procedure byte public;
state = 'F';
msgnum = 0;
tries = 0;
spsize = pksize;
timeint = mytime;
numpads = mynumpads;
padchar = mypadchr;
eol = myeol;
quote = myquote;
do while true;
if debug then
do;
call print(.('state : ',null));
call co(state);
call newline;
end;
if state = 'F' then state = sfini;
else
if state = 'W' then return true;
else
if state = 'A' then return false;
else return false;
end;
end finish;
/* This routine is used to logout from VAX
When VAX-KERMIT is in SERVER mode
*/
bye: procedure byte public;
state = 'L';
msgnum = 0;
tries = 0;
spsize = pksize;
timeint = mytime;
numpads = mynumpads;
padchar = mypadchr;
eol = myeol;
quote = myquote;
do while true;
if debug then
do;
call print(.('state : ',null));
call co(state);
call newline;
end;
if state = 'L' then state = sbye;
else
if state = 'W' then return true;
else
if state = 'A' then return false;
else return false;
end;
end bye;
/* this routine is used to send files from MDS to VAX
when there are a lot of transmitted files involved.
The argument of LSEND command is the name of a file
which contains names of files to be sent to VAX .
In this file , filenames are seperated by at least
one space or a carage return .
*/
lsend: procedure byte public;
declare
(lcount,index,ltlength) address,
(ch,lstatus,lstate,flag) byte,
pp address,
buff (2000) byte;
lstate = 'L'; /* start in Send-Init state */
if debug then
do;
call print(.('lstate : ',null));
call co(lstate);
call newline;
end;
call open(.ljfn,lfilename,readonly,noedit,.lstatus);
if (lstatus > 0 ) then do;
call print(.('unable to open list file',crlf));
return false;
end;
ltlength = 0;
flag = true ;
do while flag; /* read filename into buffer */
call read(ljfn, .buff(ltlength), 100, .lcount, .lstatus);
if lstatus > 0 then do ;
call print(.('unable to read list file',crlf));
call exit;
end;
ltlength = ltlength + lcount;
if lcount = 0 then /* stop reading */
flag = false;
end; /* while */
index = 0;
/* replace carage return , line feed by space */
do while (index <= ltlength );
ch = buff(index);
if ((ch = cr) or (ch = lf)) then
buff(index) = space;
index = index + 1;
end;/* while*/
buff(ltlength) = 0;
call close(ljfn,.lstatus);
if lstatus > 0 then do;
call print(.('unable to close list file',crlf));
call exit;
end;
cmdptr = .buff;
filename = token;
flag = true;
do while flag ;
if send then
call print(.('file sent : OK ',crlf));
else do;
call print(.('send failed : '));
call print(filename);
if gnxtfn = false
then
do;
flag = false;
return true;
end;/* if*/
end ;/* else */
end;/* while */
end lsend;
end send$module;