Columbia Kermit/kermit.zip/dtss/kermit.pl1

Text File | 2020-01-01 | 120KB | 3,505 lines

%title 'DCTS Kermit -- "Elementary" File Transfer Protocol';
%index;
%tables off;
%external;


/*

(C) Copyright 1986  Trustees of Dartmouth College.


Philip D.L. Koch


Use of this program without fee is permitted, provided that such use is not
made for commercial advantage, and that Dartmouth College is credited.
The Kermit protocol was designed at Columbia University and is copyrighted
by them.

Release Date: May 29, 1986.

Please indicate this release date in all correspondence concerning
this version of DCTS Kermit.

*/


Kermit: procedure() options(main);
%subtitle 'A Note About VPL1';

/* This program is designed to run in virtual mode; ie, using VPL1.  However,
since there are so few differences between virtual and non-virtual PL1, it
won't be too hard to switch back if, for example, you don't have a VPL1 system
installed.  The changes required to switch to non-virtual PL/I are:

1. Remove all "spawn" statements.  This means removing the timeout capability
   and the ability to do outbound connections, since both are done with tasks.

2. Replace any "global" options in "on" statements with a "call" of the
   on unit, possibly moving the "on" statement itself to the main procedure.

3. Write your own "wait" routine, to take the place of the one built into
   VPL1.  If you're lazy, you can simply remove the waits without major
   problem.

4. Use of the "block" and "unblock" functions must be removed.

The non-virtual PL1 compiler finds all of the places where the above must
be done, since they involve illegal syntax or undeclared names.

Even better, though, would be to install VPL1.

*/
%subtitle 'What This Program Does';

/* Kermit is an 'underground', volunteer protocol originally developed
at Columbia by Frank da Cruz, Bill Catchings et al.  It is used to transfer
files between different computers (typically a personal computer and a
timesharing computer).  Implementations of Kermit are available for nearly
every machine and OS you can think of.  Refer to Columbia's documentaion
for a definition of the protocol and the state machine which implements the
protocol; we use their model fairly literally.  In addition to the 'basic',
or rquired, functionality, this implementation includes (+) or does not
include (-) the following additional features refernced in Appendix II of
the Columbia Kermit Protocal Manual:

  + File groups can be sent and received, using pattern or list
    notation.  File types may be mixed.  Errors interrupt transfer
    of a single file rather than the whole group.  A log of the
    transactions can optionally be kept.

  + Filenames can be converted to and from 'normal' form, and overwriting
    an existing file of the same name can optionally be prevented.

  - Full 8-bit transission is allowed, but binary DTSS files (9-bits) cannot
    be transferred.

  + 8th bit prefixing is allowed in both directions.

  + Repeat-count prefixing is allowed in both directions.

  + Terminal Emulation is provided for (mostly for IBM).

  + Communications Options.  Duplex, parity, handshake, and line terminators
    can all be specified.

  - Only single and double character checksums are implemented.

  + Basic Server mode is implemented.

  + Many Advanced Server commands are implemented.

  + Commands can be sent to the other end, if it is a server.

  - Host commands are not implemented.

  + File transfers can be interrupted.

  + Local File Management Commands are allowed (as they are in server
    mode).

  - File Attribute Information is not implemented.

  + Debugging facilities are provided.
*/
%subtitle 'Globals';

%include 'params';
%subtitle 'Main Program';

/*

Control reaches this point when Kermit is initially run.  We initialize,
then call the interactive command processor.

*/

dcl init     entry; /* initialization of parameters etc */
dcl command  entry(file,file); /* command processor */


call init; /* initialize Kermit */
call command($screen,$screen); /* process commands from the terminal */

end kermit;
%subtitle 'Initialization';

/* Init --

Called once, at program startup, by the main procedure.

*/

init: procedure;

%list off;%include 'params';%list on;

dcl default  entry; /* set up default protocol parameters */
dcl ticktock entry; /* ticktock timer task */

call default; /* protocol defaults, kept in 'params' */

local    = ''b; /* not local until we connect out */
serving  = ''b; /* not serving until SERVER command */
logging  = ''b; /* not logging */
debuging = ''b; /* and not debugging */
break    = ''b; /* no breaks received yet */
$errmsg  = ''; /* no error message yet */
$timeout = 0; /* stop the timeout clock */
$bufp    = addr($qb); /* $buf overlays $qb */
$comffrn = 1; /* frn of comfile to other Kermit */

open file($comf)  frn(1) unformatted; /* comfile to other Kermit */
open file($screen)frn(1) stream; /* use same comfile for screen output */
open file($cat)   frn(2) unformatted; /* default catalog is current catalog */

spawn ticktock; /* fire up the ticktock timeout mechanism */

put file($screen) line('Type HELP for a command list.');

end init;
%subtitle 'Command Processor';

/* Command --

This is the user interface and command processor.

*/

command: procedure(input,output);

%list off;%include 'params';%list on;

dcl input    file; /* INPUT: input file (source of commands) */
dcl output   file; /* INPUT: output file (place to write prompts, errors, etc) *
/

dcl cmd      char var; /* the command line we read from 'input' */
dcl c3       char var; /* temp for keywords */
dcl b        bit(1) aligned; /* temp */

dcl open     entry(file,dstr,fixed,char var); /* to open files */
dcl protocol entry(fixed,char var,bit(1)aligned); /* protocol machine */
dcl filelist entry(dstr,char var,bit(1)aligned); /* to make lists of files match
ing template */
dcl unsave   entry(file); /* to unsave a file */
dcl logf     entry(char var); /* to write to logfile, if logging */
dcl split    entry(char var,char var); /* to split up filespec1 and filespec2 */
%page;

/* read next command and branch on it */

NEXTCMD: do while(more(input)); /* loop over all the input */
if input=$screen /* must we prompt? */
then put file(input) edit('DCTS Kermit>')(a); /* yes, do so */
get file(input) line(cmd); /* read the command */
call trim(cmd); /* trim off spaces etc */
c3 = substr(cmd,1,min(3,length(cmd))); /* pad or truncate to 3 chars */
call upper(c3); /* map to uppercase */
if      c3='BYE' then call bye;
else if c3='CON' then call connect;
else if c3='CWD' then call cwd;
else if c3='DEL' then call delete;
else if c3='DIR' then call directory;
else if c3='EXI' then call exit;
else if c3='FIN' then call finish;
else if c3='GEN' then call generic;
else if c3='GET' then call get;
else if c3='HEL' then call help;
else if c3='LOG' then call log;
else if c3='QUI' then call quit;
else if c3='REC' then call receive;
else if c3='REM' then call remote;
else if c3='SEN' then call send;
else if c3='SER' then call server;
else if c3='SET' then call set;
else if c3='SPA' then call space;
else if c3='TAK' then call take;
else if c3='TRA' then call transmit;
else if c3='TYP' then call type;
else call error('unrecognized command');
end;

return; /* return to caller when input exhausted */
%subtitle 'Command Processor -- Bye';

/* Bye command --

      BYE

Valid only for local systems.  Sends a GL (logout) command to the remote
system, and stops this program.

*/

bye: procedure();

call spell('BYE'); /* check spelling */
call ckeol; /* disallow arguments */
if ~local then call error('BYE valid only after CONNECT');
call protocol(3,'GL',b); /* send the command to remote server to shut down */
stop; /* ignore status and stop */

end bye;
%subtitle 'Command Processor -- Connect';

/* Connect command --

        CONNECT  [address]

Establishes a connection to another computer on the network, putting
this program in local mode.  We use NETFACE connection files to gain
outbound access to the network.

*/

connect: procedure();

dcl terminal entry; /* task to emulate terminal */
dcl termwait fixed ext init(0); /* Q to block on during terminal emulation */

call spell('CONNECT'); /* check spelling, trim spaces */
if serving then call error('cannot CONNECT after SERVER');

/* if address not supplied, we are to reestablish a prior connection */

if cmd='' then do; /* any arguments? */
if ~local then call error('must supply connection address');
end;

/* if address supplied, create new connection to it */

else do; /* if cmd~='' */
close file($comf); /* first, close old connection file */
on undf($comf) call error('connection failed (NETFACE not running)'); /* if mode
-3 open fails */
if entreg(6)<0 /* if run as an X-system */
then open file($comf) title('x$net:stream') stream update mode(3); /* then use X
NET */
else open file($comf) title('$net:stream')  stream update mode(3); /* else use o
fficial */
put file($comf) line('connect "'||cmd||'"'); /* initial line to NETFACE is conne
ct command */
get file($comf) line(cmd); /* reply from NETFACE is status of connection */
if length(cmd)<3 | substr(cmd,1,3)~='000' then do; /* good status? (ie, connecti
on established) */
local = ''b; /* not connected */
close file($comf); /* make sure residual NETFACE comfile gone */
open file($comf) frn(frn($screen)); /* No: back to default connection */
call error('could not connect ('||cmd||')'); /* report failures */
end;
$comffrn = frn($comf); /* save frn of comfile to Kermit for "timeout" */
end;

/* connection (re)established, so spawn terminal emulator */

local = '1'b; /* set the flag for local mode operation */
spawn terminal; /* spawn terminal emulator task */
call block(termwait); /* then block until terminal emulation is suspended */

end connect;
%subtitle 'Command Processor -- Cwd';

/* Cwd command --

       CWD  [directory]

Changes the current catalog, or directory.  If not specified, the directory
defaults to '*MYCAT';

*/

cwd: procedure();

dcl err char var; /* error message from 'open' */

call spell('CWD'); /* check spelling and trim spaces */
if cmd='' then cmd = '*MYCAT'; /* default catalog is user# */
close file($cat); /* close the current catalog */
call open($cat,(cmd),0,err); /* open new cat w CSRAO */
if err~='' then do; /* did open fail? */
open file($cat) unformatted frn(2); /* yes, back to user# */
call error('can''t open catalog ('||err||')');
end;

end cwd;
%subtitle 'Command Processor -- Delete';

/* Delete command --

       DELETE filespec

Deletes the file(s) specified.

*/

delete: procedure();

dcl (list,next,err) char var; /* filenames etc */
dcl tempf file constant internal; /* temporary for files to delete */
dcl i; /* temp */

call spell('DELETE'); /* check spelling, delete spaces */
if cmd='' then call error('must name file(s) to DELETE');
call filelist((cmd),list,''b); /* get list of files to delete */
if list='' then call error('no files match template');

do while(list~=''); /* loop over each file */
i = index(list,'|'); /* get end of next name */
next = substr(list,1,i-1); /* extract ext filename from list */
list = substr(list,i+1); /* truncate list */
call open(tempf,(next),3,err); /* try to open */
if err~='' then do; /* if open failed */
call  logf(next||' not deleted ('||err||')');
if ~local then call print(next||' not deleted ('||err||')');
end;
else do; /* we got RWA on it, so delete it */
call unsave(tempf); /* do it */
call  logf(next||' deleted');
if ~local then call print(next||' deleted');
end;
end;

end delete;
%subtitle 'Command Processor -- Directory';

/* Directory command --

       DIRECTORY  [filespec]

Displays a directory listing of the specified file(s), or all files in the
current catalog if the filespec is null.

*/

directory: procedure();

dcl list char var; /* file names */
dcl line char var; /* line being built */
dcl n; /* count of files per line */
dcl i; /* temp */

call spell('DIRECTORY'); /* check spelling and trim spaces */
if cmd='' then cmd = '*'; /* ask for all filenames if filespec is null */
call filelist((cmd),list,'1'b); /* get list of formatted filenames//lengths */
cmd = 'SPACE'; /* we'll use the SPACE command to print header */
call print(''); /* blank line */
call space; /* print catalog name, length, and remaining */
call print(''); /* blank line */
line = ''; /* initialize line */
n = 0; /* and #files on line */
do while(list~=''); /* loop over each filename */
   i = index(list,'|'); /* delimit next filename */
   line = line || '   ' || substr(list,1,i-1); /* add to line */
   n = n + 1; /* bump count */
   if mod(n,3)=0 then do; /* 3 on this line? */
      call print(line); /* yes, output */
      line = ''; /* and start again */
   end;
   list = substr(list,i+1); /* drop name from list */
end;
call print(line); /* end last line */

end directory;
%subtitle 'Command Processor -- Exit';

/* Exit command --

       EXIT

stops the program, just like QUIT.

*/

exit: procedure();

call spell('EXIT'); /* check the spelling */
call ckeol; /* disallow arguments */
stop; /* then stop */

end exit;
%subtitle 'Command Processor -- Finish';

/* Finish command --

         FINISH

Valid only on local systems.  Like BYE, it shuts down the remote server,
but asks it not to close the connection, and we don't stop either.  After
a FINISH, the user may re-connect to the same or another remote system.

*/

finish: procedure();

call spell('FINISH'); /* check spelling */
call ckeol; /* disallow arguments */
if ~local then call error('FINISH valid only after CONNECT');
call protocol(3,'GF',b); /* send Generic Finish command to remote server */
if ~b then call errorp; /* handle protocol error */
local = ''b; /* this undoes the CONNECT */
logging = ''b; /* and turns off logging */
close file($log); /* so close the logfile (if open) */

end finish;
%subtitle 'Command Processor -- Generic';

/* Generic command --

      GENERIC command [parameter]

Valid only if this is a server, this command is 'created' by the protocol
machine for G packets, which contain Generic commands.  Refer to the REMOTE
command, which is the "other side" which sends these commands.  The command
is exactly one character long, and the parameter (if any) is preceeded by a
coded length.  We don't allow users to type these.

*/

generic: procedure();

dcl stop entry; /* task to stop this program after a short pause */
dcl c1   char(1); /* the command */
dcl i    fixed; /* temp */

call spell('GENERIC'); /* check spelling, trim spaces */
if ~serving | cmd='' then call error('illegal command');

c1 = substr(cmd,1,1); /* extract command */
if length(cmd)<3 /* if too short for any parameters... */
then cmd = ''; /* then set parameter null */
else do; /* handle coded parameter length */
  i = byte(cmd,2) - 32; /* get coded length */
  i = min(i,length(cmd)-2); /* clamp down if packet too short for parameter */
  cmd = ' ' || substr(cmd,3,i); /* extract command parameter */
end;

if      c1='C' then call cwd; /* CWD */
else if c1='E' then call delete; /* DELETE */
else if c1='D' then call directory; /* DIRECTORY */
else if c1='U' then call space; /* SPACE */
else if c1='H' then call help; /* HELP */
else if c1='T' then call type; /* TYPE */
else if c1='L' then spawn stop; /* BYE */
else if c1='F' then spawn stop; /* FINISH */

else call error('DCTS does not implement this REMOTE command type');

end generic;
%subtitle 'Command Processor -- Get';

/* Get command --

      GET filespec [newname]

Receive the file(s) from a remote server. The optional "newname" argument
overrides the name the first file received will be saved as.

*/

get: procedure();

call spell('GET'); /* check spelling, trim leading spaces */
if ~local then call error('must CONNECT before GET');
if cmd='' then call error('must name file(s) to GET');
call protocol(4,'R'||cmd,b); /* send server the 'R' command */
if ~b then call errorp; /* handle protocol error */

end get;
%subtitle 'Command Processor -- Help';

/* Help command --

       HELP  [topic]

This is a weak implementation.  Feel free to use the EXPLAIN/HELP module
if you wish.

*/

help: procedure();

dcl (c,d) char var; /* for calling 'extract' */
dcl i;

call spell('HELP'); /* check spelling, trim spaces */
if cmd='' /* if no topic... */
then c = ''; /* then set it null */
else call extract(c,d,i); /* else map to uppercase */
c = substr(c,1,min(length(c),3)); /* truncate topic to 3 chars */

if c='SET' then do; /* the SET parameters */
call print('SET CHECKSUM [1,2]sets the block checksum type (2 is "safer")');
call print('SET DEBUG [ON,OFF]prints info helpful when debugging Kermit');
call print('SET MAPNAME       maps filenames sent to and received from other sys
tem');
call print('                  to uppercase, discarding non-alphanumerics except
"." and "*"');
call print('SET SAMENAME      sends files w same name they are saved with (the d
efault)');
call print('SET REPLACE       will overwrite an existing file with one received'
);

return; /* don't print the boilerplate about "files" args etc */
end;

if~serving then do; /* the non-server commands */
call print('The DCTS Kermit commands are:');
call print('BYE               shuts down remote server and stops Kermit');
call print('CONNECT [addr]    to connect to another computer on network');
call print('CWD [catalog]     to change current catalog');
call print('DELETE files      to unsave, or delete, files');
call print('DIRECTORY [files] to list files and their lengths');
call print('EXIT              stops Kermit (use BYE if server also running)');
call print('FINISH            shuts down remote server but not Kermit');
call print('GET files [newname] requests other computer to send us the file(s)')
;
call print('LOG [file]        logs a record of each file xfered (or not)');
call print('QUIT              same as EXIT');
call print('RECEIVE [newname] waits for file being sent by other computer');
call print('                  (use GET if remote end is a server, RECEIVE if not
)');
call print('REMOTE command    sends a command to a remote server');
call print('SEND files [newname] sends the file(s) to other computer');
call print('SERVER            puts this program in remote server mode');
call print('SET parameter     sets nonstandard parameters (HELP SET for a list)'
);
call print('SPACE             prints size and max of current catalog');
call print('TAKE file         inputs Kermit commands from file');
call print('TRANSMIT files    sends file(s) "naked" to other computer');
call print('TYPE files        lists file(s) on other computer''s screen');
end;

else if serving then do; /* relevent commands for remote service */
call print('The commands you may send to a DCTS Kermit Server are:');
call print('SEND files [newname]     to send files to the DCTS server');
call print('GET  files [newname]     to receive files from the DCTS server');
call print('BYE                      terminates both Kermits, closes connection'
);
call print('FINISH                   to stop the DCTS server only (cf BYE)');
call print('REMOTE CWD catalog       to change DCTS''s current catalog');
call print('REMOTE DELETE files      to delete file(s) on DCTS');
call print('REMOTE DIRECTORY [files] for DCTS catalog contents');
call print('REMOTE SPACE             for size and max of DCTS catalog');
call print('REMOTE KERMIT command    to send DCTS Kermit any command');
call print('                         (ie, REMOTE KERMIT SET REPLACE)');
call print('REMOTE TYPE files        to have DCTS files listed on your screen');
end;

call print('Optional arguments are bracketed, as in "[addr]".');
call print('The "files" arguments may contain wildcards (*) like "*.L".');
call print('The "newname" argument, if present, is the name the file will be sav
ed as.');
call print('Please refer to "Kermit User''s Guide" for details.');

end help;
%subtitle 'Command Processor -- Log';

/* Log command --

       LOG  [filename]

Log transactions (and debugging information, if enabled) to the named file.
If the filename is null, logging is turned off if already on.

*/

log: procedure();

dcl err char var; /* error message */

call spell('LOG'); /* check spelling, trim spaces, leave filename in 'cmd' */

if cmd='' then do; /* turning Logging off */
close file($log); /* so close file */
logging = ''b; /* set flag off */
end;
else do; /* wants to Log */
call open($log,(cmd),4,err); /* first, try to open existing file */
if err~='' /* if not found... */
then call open($log,(cmd),2,err); /* then try to create */
if err~='' then call error('can''t open LOG file ('||err||')');
reset file($log) to(lof($log)+1); /* append to end of file */
logging = '1'b; /* turn flag on */
end;

end log;
%subtitle 'Command Processor -- Quit';

/* Quit command --

      QUIT

stops the program, just like EXIT.

*/

quit: procedure();

call spell('QUIT'); /* check the spelling */
call ckeol; /* disallow arguments */
stop; /* then stop */

end quit;
%subtitle 'Command Processor -- Receive';

/* Receive command --

      RECEIVE [filespec]

Passively wait for a file; valid on either the local or remote end, as long
as neither is in server mode.  The optional filename overrides the name the
first file received will be saved as.

*/

receive: procedure();

call spell('RECEIVE'); /* check spelling */
if serving then call error('RECEIVE illegal while serving');
if ~local then call wait(5); /* wait for user to escape back to local kermit */
call protocol(2,cmd,b); /* receive the files (using optional filespec) */
if ~b then do;/* handle protocol error */
call print('Receive failed; if other end is a server, you should use GET, not RE
CEIVE.');
call errorp; /* handle protocol error message, if any */
end;

end receive;
%subtitle 'Command Processor -- Remote';

/* Remote command --

     REMOTE command [parameter]

Send a command to the remote server.  Valid only at the local end.  Most
of these turn into 'G' packets, which take a single letter command in the
data field, possibly followed by the parameter.  A 'G' packet parameter is
preceeded by a char encoding it's length; refer to the protocol manual.

*/

remote: procedure();

dcl rcmd    char var;/* remote command */
dcl rpar    char var; /* parameter field */
dcl i; /* temp */

call spell('REMOTE'); /* check spelling, trim spaces */
if ~local then call error('REMOTE must follow CONNECT');
call extract(rcmd,rpar,i); /* extract command, parameter, value */
rcmd = substr(rcmd,1,min(length(rcmd),3)); /* truncate to 3 chars */
rpar = substr(rpar,1,min(length(rpar),50)); /* truncate parameter too */

if      rcmd='CWD' then rcmd = 'GC'; /* Change Working Directory */
else if rcmd='DEL' then rcmd = 'GE'; /* Delete */
else if rcmd='DIR' then rcmd = 'GD'; /* Directory */
else if rcmd='SPA' then rcmd = 'GU'; /* Space */
else if rcmd='HEL' then rcmd = 'GH'; /* Help */
else if rcmd='HOS' then rcmd = 'C';  /* Host command */
else if rcmd='KER' then rcmd = 'K';  /* Kermit command */
else if rcmd='TYP' then rcmd = 'GT'; /* Type */

else call error('unsupported REMOTE command (try REMOTE KERMIT <cmd>)');

if substr(rcmd,1,1)='G' & rpar~='' /* if a Generic command with a parameter */
then rcmd = rcmd || chr(length(rpar)+32) || rpar; /* then add in length */
else rcmd = rcmd || rpar; /* else just add parameter to command wo length */

call protocol(4,rcmd,b); /* send the command to remote server */
if ~b then call errorp; /* handle protocol error */

end remote;
%subtitle 'Command Processor -- Send';

/* Send command --

     SEND filespec1 [filespec2]

Sends one or more files to other end, which may or may not be a server.
If filespec2 is present, it determines the name with which the only file
shipped will be saved.

*/

send: Procedure();

dcl (spec1,spec2) char var; /* the two filespecs */
dcl i fixed; /* temp */

call spell('SEND'); /* check spelling */
if serving then call error('SEND illegal while serving');
spec1 = cmd; /* initialize filespec1 */
if spec1='' then call error('must name file(s) to SEND');
call split(spec1,spec2); /* separate filespec1 and filespec2 */
call filelist((spec1),spec1,''b); /* get list of files matching filespec1 */
if spec1='' then call error('no files match template');
if spec2~='' then do; /* if filespec2 supplied... */
   if index(spec2,'?')~=0 /* make sure we can add to filelist */
   then call error('destination name cannot contain "?"');
   spec1 = substr(spec1,1,length(spec1)-1); /* truncate trailing '|' */
   if index(spec1,'|')~=0 /* filespec2 valid only when sending single file */
   then call error('cannot use destination name with wildcards');
   spec1 = spec1 || '?' || spec2 || '|'; /* add destination name */
end;
if ~local then call wait(5); /* wait for user to escape back to local Kermit */
call protocol(1,spec1,b); /* send the file(s) */
if ~b then call errorp; /* handle protocol error */

end send;
%subtitle 'Command Processor -- Server';

/* Server command --

      SERVER

invokes server mode.  We call the protocol machine, which never returns.

*/

server: procedure();

call spell('SERVER'); /* check spelling */
call ckeol; /* disallow arguments */
if local | serving /* appropriate? */
then call error('SERVE illegal after SERVE or CONNECT');
call print('Kermit Server running on DCTS host.  Please type your escape');
call print('sequence to return to your local machine.  Shut down the server');
call print('by typing the Kermit BYE command on your local machine.');
call flush(output); /* flush above message to screen */
call wait(5); /* OK: wait 5 sec for user to return to local system */
call protocol(0,'',b); /* then enter server mode */
signal error; /* die if we ever return from it */

end server;
%subtitle 'Command Processor -- Set';

/* Set command --

      SET parameter [option] [value]

Establish or modify various parameters for file transfer or terminal connection.
This is a catch-all set of implementation oddities.

*/

set: procedure();

dcl param   char var; /* set parameter */
dcl option  char var; /* set options/value */
dcl i; /* temp */

call spell('SET'); /* check spelling etc */
call extract(param,option,i); /* extract the parameter and value from command li
ne */
call upper(option); /* map option to uppercase */

if      param='CHECKSUM'then do; /* SET CHECKSUM */
  if (i=1) | (i=2) /* if type 1 or 2 (only ones supported) */
  then params.iwant = i; /* then set my preference */
  else call error('CHECKSUM must be set to 1 or 2');
end;

else if param='DEBUG'   then do; /* SET DEBUG */
  if option='OFF' /* SET DEBUG OFF */
  then debuging = '0'b; /* set global flag */
  else debuging = '1'b; /* SET DEBUG ON */
end;

else if param='MAPNAME'  then do; /* SET MAPNAME */
  params.fncnv = '1'b; /* turn on filename normalization (default is off) */
end;

else if param='SAMENAME' then do; /* SET SAMENAME */
  params.fncnv = ''b; /* then turn off filename normalization */
end;

else if param='REPLACE' then do; /* SET REPLACE */
  params.overwrit = '1'b; /* overwrite files of same name */
end;

else call error('illegal SET parameter');

end set;
%subtitle 'Command Processor -- Space';

/* Space command --

      SPACE

Displays space remaining in current catalog.

*/

space: procedure;

dcl 1 cathdr, /* catalog header */
    2 max    fixed, /* max */
    2 aloc   fixed, /* aloc */
    2 xx(2)  fixed, /* (unused) */
    2 accw   fixed, /* access word */
    2 ents   fixed, /* #entries */
    2 capac  fixed, /* capacity */
    2 pop    fixed, /* population */
    2 pad    fixed(20); /* padding for use with provide treename */
dcl cnam     char var; /* temp for catalog name */
dcl c        char(80) based; /* overlays 'cathdr' */
dcl (m1,m2,m3) fixed static; /* MME parameters */
dcl regs(0:11) fixed; /* MME parameters */

call spell('SPACE'); /* check spelling */
call ckeol; /* disallow arguments */
m1 = waddr(cathdr); /* point to catalog entry buffer */
m2 = wlen(cathdr); /* length of buffer */
unspec(regs(*)) = ''b; /* clear register block to 0s */
regs(0) = frn($cat); /* X0: frn */
regs(3) = waddr(m1); /* X3: ptr to ptr to buffer */
regs(5) = 3; /* X5: request type (provide treename, char string) */
regs(7) = waddr(m2); /* X7: ptr to length to read */
call mme(500246b3,regs(*)); /* Request Status: provide treename */
if regs(10)>1000000b3 then signal error; /* die if this fails */

cnam = substr(addr(cathdr)->c,1,(wlen(cathdr)+regs(11))*4); /* get name */

regs(1) = waddr(m3); /* X1: ptr to entry# */
m3 = 0; /* we want entry#0 */
call mme(500214b3,regs(*)); /* Read Catalog, entry #0 (catalog header) */
if regs(10)>1000000b3 then signal error; /* die if this fails */

call print(cnam||'  max:'||max(cathdr.max)||'  aloc:'||max(cathdr.aloc)||'  capa
city:'||max(cathdr.capac));

/* handle cat maxes: convert -1 to 'infinite' */

max: procedure(n) returns(char var);

dcl n fixed; /* INPUT: the number */

if n<0 /* infinite? */
then return('infinite'); /* yes, say so */
else return(n); /* else just convert number directly */

end max;

end space;
%subtitle 'Command Processor -- Take';

/* Take command --

      TAKE filespec

reads commands from the specified file.

*/

take: procedure();

dcl takef file int; /* the file we read commands from */
dcl err   char var; /* error message from open */

call spell('TAKE'); /* check spelling */
if per(takef)~=0 /* recursive? */
then call error('TAKE command may not be in TAKE file');
call open(takef,(cmd),1,err); /* open the file */
if err~='' /* did open fail? */
then call error('can''t open TAKE file: '||err);
call command(takef,output); /* OK: recurse to handle the commands */
close file(takef); /* done with the file */

end take;
%subtitle 'Command Processor -- Transmit';

/* Transmit command --

       TRANSMIT filespec

Sends the file, naked, to the remote connection.  Valid only if we're in
local mode, this can be used to ship a file to a system that doesn't have
a Kermit.  Put remote system in "accept file" mode in an editor, escape
back to this program, TRANSMIT, re-connect and quit the editor.  Good luck!

*/

transmit: procedure();

dcl (list,next) char var; /* filenames */
dcl i        fixed; /* temp */
dcl buf(512) fixed; /* buffer for file-to-output copies */
dcl tempf    file int; /* temp for files being listed */

call spell('TRANSMIT'); /* ckeck spelling, trim spaces */
if ~local then call error('must CONNECT to remote system before TRANSMIT');
if cmd='' then call error('must name file to TRANSMIT');
call filelist((cmd),list,''b); /* construct list of files to be sent */
if list='' then call error('no files matched template');

do while(list~=''); /* loop over each file to be transmitted */
i = index(list,'|'); /* find delimiter */
next = substr(list,1,i-1); /* extract next filename */
list = substr(list,i+1); /* truncate list */
call open(tempf,(next),1,next); /* open file */
if next~='' then call error('can''t open file ('||next||')');
i = 1; /* prime matread loop */
do while(i>0); /* loop while more in file */
   i = matread(tempf,buf,wlen(buf)); /* read from file */
   if i>0 then i = matwrite($comf,buf,i); /* and write to connection */
end;
close file(tempf); /* done with file */
end;

end transmit;
%subtitle 'Command Processor -- Type';

/* Type command --

       TYPE filespec

Send the indicated file(s), but to the local screen.  Ie, "type" them
on the local screen.  This is often called when we are a server, via the
GT generic command.

*/

type: procedure();

dcl (list,next) char var; /* filenames */
dcl i        fixed; /* temp */
dcl buf(512) fixed; /* buffer for file-to-output copies */
dcl tempf    file int; /* temp for files being listed */

call spell('TYPE'); /* ckeck spelling, trim spaces */
if cmd='' then call error('must name file to TYPE');
call filelist((cmd),list,''b); /* construct list of files to be sent */
if list='' then call error('no files matched template');

do while(list~=''); /* loop over each file to be typed */
i = index(list,'|'); /* find delimiter */
next = substr(list,1,i-1); /* extract next filename */
list = substr(list,i+1); /* truncate list */
call open(tempf,(next),1,next); /* open file */
if next~='' then call error('can''t open file ('||next||')');
i = 1; /* prime matread loop */
do while(i>0); /* loop while more in file */
   i = matread(tempf,buf,wlen(buf)); /* read from file */
   if i>0 then i = matwrite(output,buf,i); /* and write to default output */
end;
close file(tempf); /* done with file */
end;

end type;
%subtitle 'Command Processor -- Subroutines';


/* extract first word from command line */

extract: procedure(first,rest,nval);

dcl first char var; /* OUTPUT: first word in 'cmd', mapped to uppercase */
dcl rest  char var; /* OUTPUT: rest of 'cmd', not mapped but trimmed */
dcl nval  fixed; /* OUTPUT: if rest is numeric, numeric value, else -1 */
dcl (a,b) char var; /* temps */
dcl i; /* temp */

i = index(cmd,' '); /* space delimits first word from rest */
if i=0 then i = length(cmd) + 1; /* if no space, its all the first word */
a = substr(cmd,1,i-1); /* extract first word */
b = substr(cmd,i); /* and rest */
call upper(a); /* map first word to uppercase */
call trim(b); /* trim spaces from rest */

if b~='' & verify(b,'0123456789')=0 /* if b is entirely numeric */
then nval = fixedbin(b); /* then return its numeric value */
else nval = -1; /* else flag as non-numeric */

first = a; /* assign value of first word (mapped and trimmed) */
rest  = b; /* and rest (trimmed but not mapped) */

end extract;


/* trim leading and trailing spaces */

trim: procedure(arg);

dcl arg char var; /* UPDATE: argument to trim */
dcl i; /* temp */

i = verify(arg,' '); /* find first non-space */
if i=0 /* only spaces in string? */
then arg = ''; /* yes, set null */
else do; /* at least one non-space */
     arg = substr(arg,i); /* trim leading spaces */
     do i = length(arg) /* search arg */
            to 2 by -1 /* right to left */
            while(substr(arg,i,1)=''); /* looking for first non-blank */
     end;
     arg = substr(arg,1,i); /* then trim trailing spaces */
end;

end trim;


/* check spelling of first word in 'cmd' and trim leading spaces */

spell: procedure(word);

dcl word char var; /* INPUT: the word to spell, in uppercase */
dcl txt  char var; /* the first word stripped from the command line */
dcl i; /* temp */

i = index(cmd,' '); /* find delimiter to first word in command line */
if i=0 then i = length(cmd)+1; /* if no space, entire line is first word */
txt = substr(cmd,1,i-1); /* extract first word (note: word null if first char is
 space!) */
cmd = substr(cmd,i); /* then strip off command line */
call upper(txt); /* map first word to uppercase */
call trim(cmd); /* trim spaces from remaining portion of command line */

if txt~='' & index(word,txt)~=1 /* if typed word not subset of full spelling */
then call error(txt||' is not a command'); /* then error */

end spell;


/* map to uppercase */

upper: procedure(arg);

dcl arg char var; /* UPDATE: argument to be mapped */

arg = translate(arg,'QWERTYUIOPASDFGHJKLZXCVBNM','qwertyuiopasdfghjklzxcvbnm');

end upper;


/* give error message if unprocessed arguments in command */

ckeol: procedure();

if cmd~='' then call error('arguments not allowed: '||cmd);

end ckeol;


/* print line to output file */

print: procedure(line);

dcl line char var; /* INPUT: line to print */

put file(output) line(line); /* do it */

end print;


/* print error message and abort this command */

error: procedure(msg);

dcl msg char var; /* the text of the error message */

call print('Error, '||msg); /* print the message */
goto NEXTCMD; /* then abort this command, try next */

end error;


/* protocol error (called when 'protocol' returns w bad status) */

errorp: procedure();

if $errmsg='' /* if no clue as to why protocol error occured... */
then call error('communication with remote Kermit failed');
else call error(($errmsg)); /* use specific message if there is one */

end errorp;

end command;
%subtitle 'Command Processor -- Split';

/* Split --

Split up a string into two component words, separated by the first space.
The words may be quoted, and if only one word is present, the 2nd is set null.
This is used by the GET and SEND commands.  It is assumed that leading spaces
have already been trimmed.

*/

split: procedure(s1,s2);

dcl s1    char var; /* UPDATE: string to split, first word on exit */
dcl s2    char var; /* OUTPUT: second word */
dcl (i,j) fixed; /* temps */

j = index(s1,' '); /* by default, delimiter is space */
if j=0 then j = length(s1) + 1; /* first word is entire string if no space */

if index(s1,'"')=1 then do; /* 1st word quoted? */
   i = index(s1,'"',2); /* look for delimiter */
   if i>0 then do; /* if delimiter found */
      s1 = substr(s1,2); /* strip off leading '"' */
      j = i - 1; /* trailing '"' splits string */
   end;
end;

s2 = substr(s1,min(j+1,length(s1)+1)); /* extract 2nd word */
s1 = substr(s1,1,j-1); /* extract 1st word */

i = verify(s2,' ');/* look for leading spaces in word 2 */
if i=0 /* all spaces? */
then s2 = ''; /* yup */
else do; /* at least one non-space */
     s2 = substr(s2,i); /* trim leading spaces */
     do while(substr(s2,length(s2),1)=' '); /* loop while last char is a space *
/
        s2 = substr(s2,1,length(s2)-1); /* trim it */
     end;
end;

if index(s2,'"')=1 then do; /* 2nd word quoted too? */
   i = index(s2,'"',2); /* find delimiting quote */
   if i>0 then do; /* if found */
      s2 = substr(s2,2,i-2); /* extract quoted 2nd word */
   end;
end;

end split;
%subtitle 'Command Processor -- Stop Task';

/* Stop --

This is a task spawned by the BYE and FINISH generic commands, which are
valid only if we're in server mode.  We wait 5 seconds and stop the program.
The wait allows the protocol machine a little time to ACK the 'G' packet,
which is a courtesy to the other end.  Clearly this won't always work, and
it might have been better to figure out another way to do this, but at least
this scheme avoids a pathologic connection between command processing and
the protocol machine.

*/

stop: procedure();  /* Spawned by Generic BYE and FINISH */

call wait(5); /* wait awhile */
stop; /* and stop */

end stop;
%subtitle 'Files -- Drive';

/* Drive --

Issue a drive MME.  Used to set modes etc on $screen and $comf.

*/

drive: procedure(file,mode);

dcl file     file; /* INPUT: the file */
dcl mode     fixed; /* INPUT: the mode (type/function) */
dcl regs(0:11) fixed; /* mme parameters */

unspec(regs) = ''b; /* clear the regs */
regs(0) = frn(file); /* X0: frn */
regs(8) = mode; /* RA: mode */
call mme(500232b3,regs); /* issue Drive MME, ignore status */

end drive;
%subtitle 'Files -- Filelist';

/* Filelist --

This routine makes a list of files in a catalog, using the wildcard notation
'*'.  The list consists of a set of simple names, each terminated with an '|'.
The list may be null.  Two types of lists are made, formatted and not.

   1. Formatted lists include catalogs and lengths, and each entry is fixed leng
th:
         "FRED       123499|JOSEPH        756|"

   2. Unformatted lists do not include catalogs or lengths, and have spaces
      compressed out:
         "FRED|JOSEPH|"

The template is treated as the explicit name (perhaps a treename) of a single
file if it either contains an ':' or does not contain an '*', or contains '***'.

*/

filelist: procedure(template,list,formatted);

%list off;%include 'params';%list on;

dcl template dstr; /* UPDATE: the template */
dcl list     char var; /* OUTPUT: the list of names */
dcl formatted bit(1) aligned; /* INPUT: true iff formatted list wanted */
dcl ss(0:10) char var; /* the search strings */
dcl nss      fixed; /* the number of search string in the template */
dcl (m1,m2,m3) fixed static; /* MME parameters */
dcl regs(0:11) fixed; /* MME parameters */
dcl 1 rcbuf(100), /* read catalog entry buffer */
    2 name   char(8), /* filename */
    2 pwd    char(8), /* password */
    2 accw   fixed, /* access word */
    2 dp     fixed, /* days uses// pref */
    2 dates  fixed, /* DLU//DLM */
    2 len    fixed; /* length */
dcl (i,j,k,e,n) fixed; /* temps */
dcl c        char var; /* temp */

template = translate(template,'QWERTYUIOPASDFGHJKLZXCVBNM','qwertyuiopasdfghjklz
xcvbnm');
list = ''; /* initialize list to null */

/* distinguish between templates and explicit fileames */

if ( index(template,':')~=0 /* if it appears to be a treeame... */
   | index(template,'***')~=0 /* or if its in DLIBRARY... */
   | index(template,'*')=0) /* or if there are no wildcards... */
  & ~formatted /* and formatted list not wanted... */
then do; /* then it is not a template */
if template~='' /* unless null (in which case we don't add the '|') */
then list = template || '|'; /* then return single filename in list */
return; /* and done */
end;

/* parse the template into a set of search strings (mapping * to '') */

ss(0) = 'xx'; /* assume 0th search string is NOT a wildcard */
nss = 0; /* no search strings so far */
do while(template~='' & nss<hbound(ss,1)); /* loop stripping off search strings
*/
nss = nss + 1; /* next string */
if substr(template,1,1)='*' then do; /* a wildcard? */
ss(nss) = ''; /* yes, set flag */
template = substr(template,2); /* strip off the * */
end;
else do; /* not a wildcard */
i = index(template,'*'); /* search for next * */
if i=0 then i = length(template) + 1; /* use rest of string if no * */
ss(nss) = substr(template,1,i-1); /* get string */
template = substr(template,i); /* strip it off */
end;
end;

/* set up parameters for Read Catalog MME */

m1 = 1; /* first entry to read is #1 */
m2 = waddr(rcbuf); /* ptr to catalog entry buffer */
m3 = wlen(rcbuf); /* length of entry buffer in words */
regs(0) = frn($cat); /* X0: frn of catalog */
regs(1) = waddr(m1); /* X1: ptr to m1 */
regs(3) = waddr(m2); /* X3: ptr to m2 */
regs(6) = 0; /* X6: trap (unused?) */
regs(7) = waddr(m3); /* X7: ptr to m3 */
regs(10)= 0; /* initialize to enter loop first time */

/* loop over each file in the catalog */

do while(regs(10)=0); /* loop until we get bad status from Read Catalog */
   call mme(500214b3,regs(*)); /* read next 100 entries */
   regs(1) = 0; /* use implicit ptr into catalog hereafter */
   do j = 1 to (regs(11)+m3)/wlen(rcbuf(1)); /* for each entry read */
      if rcbuf(j).accw>0 | formatted then do; /* if not a catalog, or formatted
list */
         c = rcbuf(j).name; /* get name */
         e = 0; /* no mismatch yet */
         do k = 1 to nss while(e=0); /* for each search string */
            if ss(k)~='' then do; /* if not a wildcard */
               n = index(c,ss(k)); /* does string occur in filename? */
               if n=0 /* if not... */
               then e = 1; /* then no match */
               else if n~=1 & ss(k-1)~='' /* if matched in middle but no wildcar
d... */
               then e = 1; /* then no match */
               else c = substr(c,n+length(ss(k))); /* strip off match */
            end;
         end;
         if  e=0 /* if no mismatches */
          & (c='' | ss(nss)='') /* and either all matched or trailing wildcard *
/
         then do; /* then add to list */
            if ~formatted /* if tight packed filenames wanted... */
            then list = list || trim(rcbuf(j).name) || '|';
            else list = list || rcbuf(j).name || fmt(rcbuf(j).len) || '|';
         end;
      end;
   end;
end;

return; /* done: all catalog entries read */


/* trim trailing spaces off a filename */

trim: proc(name) returns(char var);

dcl name char(8); /* INPUT: space filled filename */
dcl i;

if name='' then return(''); /* handle name of 8 spaces */
do i = 1 to 8 while(substr(name,1,i)~=name); end;
return (substr(name,1,i)); /* return name without space fill */

end trim;

/* format number in fixed length character field */

fmt: procedure(n) returns(char(12));

dcl n fixed; /* INPUT: number to format */
dcl p pic'zzzzzzzzzzz9'; /* temp */

if n<0 then return('    infinite');/* handle negative lengths */
p = n; /* if positive, format */
return(string(p)); /* and return */

end fmt;

end filelist;
%subtitle 'Files -- Logf';

/* Logf --

Write lines to the logfile, if enabled, and to the screen, if local.

*/

logf: procedure(line);

%list off;%include 'params';%list on;

dcl line     char var; /* INPUT: the line to log */
dcl (date,time) builtin;

if logging /* if logging enabled... */
then put file($log) line(date(),' ',time(),' ',line); /* prefix with date/time s
tamp */

if local then do; /* ie, if we have a screen... */
   put file($screen) line(line); /* tell user whats going on */
   call flush($screen); /* immediately */
end;

end logf;
%subtitle 'Files -- Normaliz';

/* Normaliz --

Normalize a filename, by stripping it of any chars except uppercase letters,
digits, and the period and * (for wildcards), then truncating to at most 8 chars
.

*/

normaliz: procedure(name);

%list off;%include 'params';%list on;

dcl name dstr; /* UPDATE: the filename */
dcl i    fixed; /* temp */

name = translate(name,'QWERTYUIOPASDFGHJKLZXCVBNM','qwertyuiopasdfghjklzxcvbnm')
;
i = 1; /* enter loop at least once */
do while(i~=0); /* loop removing non-approved characters */
i = verify(name,'QWERTYUIOPASDFGHJKLZXCVBNM1234567890.*'); /* any offenders? */
if i~=0 /* yes! remove it!! */
then name = substr(name,1,i-1) || substr(name,i+1);
end;
if length(name)>8 then name = substr(name,1,8); /* truncate if necessary */
if length(name)=0 then name = 'NONAME'; /* try to be helpful */

end normaliz;
%subtitle 'Files -- Open';

/* Open --

This is the open file subroutine; it creates and saves output files if
necessary, scratches them if already saved (and overwriting is enabled),
and maps bad statuses into strings.

*/

open: procedure(file,name,type,err);

%list off;%include 'params';%list on;

dcl file     file; /* INPUT: the file to open */
dcl name     dstr; /* INPUT: the filename */
dcl type     fixed; /* INPUT: 0:catalog  1:input  2:output  3:delete  4:log */
dcl err      char var; /* OUTPUT: status: null if good, else error message */

dcl tw       fixed static; /* mme parameter: tallyword */
dcl acc(2)   fixed static; /* mme parameter: access control words */
dcl snam     char(80) static; /* mme parameter: name to catalog with */
dcl regs(0:11)fixed; /* mme parameter: register block */
dcl i;  /* temp */

on undf(file) begin;/* catch open errors */
i = shr(stw1(file),18)&777b3; /* get major status */
goto ERROR; /* handle */
end;

close file(file); /* make sure the file is closed */
err = ''; /* initialize error message to 'good' */

/* open of catalog: must try for OSRA */

if type=0 then do; /* if open of catalog (probably CWD command) */
open file(file) title(name) unformatted access(455000b3); /* note cannot use $ca
t!! */
if (per(file)&400000b3)=0 then do; /* if not a catalog... */
   close file(file); /* then close it */
   err = 'not a catalog'; /* say what is wrong */
end;
return; /* return if opened successfully */
end;

/* input file: always an error if can't open */

if type=1 then do; /* handle input files, the easy case */
open file(file) catfrn(frn($cat)) title(name) stream input;
return; /* got it, done */
end;

/* file to be deleted: always an error if can't open */

if type=3 then do; /* DELETE command opens files mode 3 */
open file(file) catfrn(frn($cat)) title(name) unformatted update;
return; /* return if opened */
end;

/* output file (types 2 and 4): try to open, to see if its there */

begin; /* we'll handle bad statuses ourselves */
  on undf(file) goto NOT_THERE; /* we hope open will fail */
  open file(file) catfrn(frn($cat)) title(name) stream update;
  if type=4 then return; /* if opening a logfile, don't worry about overwriting
*/
  if params.overwrit then do; /* we got it: ok? */
     scratch file(file); /* yes, scratch it */
     return; /* and done */
  end;
  err = 'it already exists but REPLACE option not SET'; /* explain what went wro
ng */
  close file(file); /* close the file */
  return; /* done: don't overwrite a file without permission */
end;

NOT_THERE: i = shr(stw1(file),18)&777b3; /* lets take a look at the status */
if i~=3 then goto ERROR; /* make sure open failed because 'file not found' */

/* create and catalog an output file */

open file(file) scratch pref(6) stream; /* first, make a scratch file */
snam = name; /* move parameter into static storage for MME */
tw = shl(waddr(snam),18) + shl(length(name),6) + 40b3; /* make tallyword to name
 */
acc(1) = 0; /* no trap mask necessary */
acc(2) = 007400007400b3; /* save w RWAL,RWAL */
regs(0) = frn($cat); /* X0: frn of initial cat */
regs(1) = waddr(tw); /* X1: ptr to tallyword */
regs(2) = frn(file); /* X2: frn of file to be cataloged */
regs(3) = 0; /* X3: mfd frn */
regs(4) = waddr(acc); /* X4: ptr to access info */
regs(5) = 0; /* X5: don't tell us filename */
regs(6) = 0; /* X6: (unused) */
regs(7) = 0; /* X7: no load/dump info */
call mme(500241b3,regs(*)); /* issue Tally Catalog */

i = shr(regs(10),18)&777b3; /* get major status from MME */

if i=0 then return; /* done if file cataloged successfully */

/* handle errors: we assume the major status is in 'i' */

ERROR: close file(file); /* make sure file closed */
if i<=12b3 then do case(i); /* handle low statuses */
err = 'access error'; /* 1: partial status */
err = 'in use'; /* 2: lockout */
err = 'not found'; /* 3: not found */
err = 'incorrect password'; /* 4: protection violation */
err = 'access error'; /* 5: fail */
err = 'illegal filename'; /* 6: bad treename */
err = 'access error'; /* 7: fetch */
err = 'migrated'; /* 10: migrated */
signal error; /* 11: (not a status) */
err = 'illegal filename'; /* 12: format error */
end;
else if i=40b3  then err = 'quotas error';
else if i=60b3  then err = 'out of storage';
else if i=100b3 then err = 'access error';
else signal error; /* other statuses are our fault */

return; /* return bad status */

end open;
%subtitle 'Files -- Reset';

/* Reset --

Issue Reset Status MME on a file.  We are passed the frn, rather than the
file declaration, since the fcb is probably busy and thus can't be used.

*/

reset: procedure(frn);

dcl frn        fixed; /* INPUT: frn of file to reset */
dcl regs(0:11) fixed; /* mme parameters */

unspec(regs(*)) = ''b; /* clear the registers */

regs(0) = frn; /* X0: frn */
call mme(500235b3,regs(*)); /* issue Reset Status, ignore status */

end reset;
%subtitle 'Files -- Unsave';

/* Unsave --

Uncatalog and close a file.  Called when reading a file is interrupted.

*/

unsave: procedure(file);

dcl file     file; /* INPUT: the file to unsave */
dcl regs(0:11) fixed; /* register block for MMEs */

unspec(regs(*)) = ''b; /* clear out the registers */

regs(0) = frn(file); /* X0: frn */
call mme(500204b3,regs(*)); /* Uncatalog MME, ignore status */

close file(file); /* close the scratch file, destroying it */

end unsave;
%subtitle 'Protocol Machine';

/* Protocol --

This is the finite state automaton that implements the Kermit file
server protocol.  When called, we expect the global parameters to
be set up, and file "$comf" to be the comfile to the remote Kermit.

We return '1'b iff the transaction was successful; if not, $errmsg MAY
contain an explanatory message.

*/

protocol: procedure(istate,text,ok);

%list off;%include 'params';%list on;

dcl istate   fixed; /* INPUT: initial state  */
dcl text     char var; /* UPDATE: filename list (send), command (send command) *
/
dcl ok       bit(1) aligned; /* OUTPUT: true iff transaction successful */

dcl typ      char(1) static; /* type of most recently read packet */
dcl seq      fixed static; /* sequence# of most recently read packet */
dcl data     dstr static; /* data field of most recently read packet */
dcl nil      dstr static init(''); /* canonic null data field (saves space) */
dcl err      char var; /* for use with "open" */

dcl command  entry(file,file); /* to parse commands */
dcl getp     entry(char(1),fixed,dstr); /* to read next packet */
dcl putp     entry(char(1),fixed,dstr); /* to send next packet */
dcl normaliz entry(dstr); /* apply 'normalizing' filename convetions */
dcl open     entry(file,dstr,fixed,char var); /* to open a file */
dcl unsave   entry(file); /* uncatalog and close */
dcl filelist entry(dstr,char var,bit(1)aligned); /* process wildcard file lists
*/
dcl default  entry; /* to set up protocol defaults */
dcl logf     entry(char var); /* to write lines to logfile, if logging */
dcl drive    entry(file,fixed); /* to issue Drive MMEs */
dcl split    entry(char var,char var); /* to split up 'filespec1' and 'filespec2
' */
%page;


on condition(abort) begin; /* catch aborted transactions */
close file($dataf); /* done with this file */
call odometer(0); /* disable the odometer if necessary */
ok = '0'b; /* set bad status */
goto EXIT; /* the exit from the transaction */
end;

ok = '1'b; /* assume transaction completes successfully */
$errmsg = ''; /* clear out the error message text */
params.chkt = 1; /* checksums revert to the default */
call flush($screen); /* flush pending screen output */

/* Drive network comfile, for two reasons: (1) to clear out pending input,
   and (2) to put real terminal-like systems (ie, things coming in on RS232
   lines) into Short-Timeout mode, so we can read parity bits.  We
   can't drive STO on just anything, since VAX/VMS can't handle drives.  So if
   we are in local mode (ie, if the remote end is almost certainly a host,
   NOT a terminal), then we simply flush pending input.  It is important to
   flush out the NAKs that have been accumulating while user thinks in local mod
e.
   In theory, Short Timeout can cause us to receive incomplete packets (ie,
   before the CR), but in practice it seems to be OK.  LBL modes are unattractiv
e
   since they discard parity coming in.  */


if local /* if we're confident remote end is a host server... */
then call drive($comf,400000b3); /* then just flush pending input */
else call drive($comf,000011b3); /* else use Short-Timeout drive (also flushes)
*/

do while(oninterrupt()~=''b);end; /* discard stacked specials */

do case(istate+1); /* branch on initial state */
call server; /* 0: server mode */
call send(text); /* 1: send file(s) */
call receive(text); /* 2: receive file(s) */
call sendcmd(text); /* 3: send command to remote server (short response expected
) */
call sendlong(text); /* 4: send command to remote server (long response expected
) */
end;

EXIT: if ~local then call drive($comf,000000b3); /* set LBL back for command mod
e */
return; /* return status in 'ok' */
%subtitle 'Protocol Machine -- Receive';

/* Receive --

This is the basic driver for non-server receive file operations. */

receive: procedure(name);

dcl name char var; /* UPDATE: if not null, overrides F packet filename */

$n = 0; /* set seq# 0 */
$r = 0; /* no retries yet */

do while(1); /* loop until we get an S */
call getp(typ,seq,data); /* read the next packet */

if typ='S' & seq=0 then do; /* Good, he sent a Send_initiate */
call rparms(data,'0'b); /* process the S-parameters */
call gparms(data); /* set up our parameters */
call putp('Y',$n,data); /* ACK him with our parameters */
call next; /* bump $n */
call readhdr(name); /* OK, read file(s) */
return; /* and done */
end;

else if typ='T' then do; /* timeouts are retried */
call putp('N',$n,nil); /* NAK first */
call retry; /* then bump retry count */
end;

else signal cond(abort); /* abort on other packet type */
end;

end receive;
%subtitle 'Protocol Machine -- Readhdr';

/* Readhdr --

This loops looking for a file header or EOT message, and reads in the file.
It returns only after the B (end of transaction) or an error.  We are passed
an optional name to save the file with, which (if present) overrides that
enclosed in the F packet.

*/

readhdr: procedure(name);

dcl name char var; /* UPDATE: optional name to save file with */

do while(1); /* loop over each file in this transaction */

call choose(); /* choose which checksum type to expect */
break = ''b; /* clear don't-send-file flag */
call getp(typ,seq,$buf); /* read the next packet */

if typ='F' & seq=$n then do; /* File header */
call unquote; /* unquote '$buf' */
if params.fncnv /* should we convert filenames? */
then call normaliz($buf); /* yes, do so */
if name~='' /* but wait, do we have an override on filename? */
then $buf = name; /* yes, use this name instead of one coming from remote system
 */
else name = $buf; /* else remember name to save it with */
call open($dataf,$buf,2,err); /* try to open/create the file */
call putp('Y',$n,nil); /* ACK the F packet whether open worked or not */
call next; /* bump $n, zero $r */
if err~='' then do; /* if open fails... */
   call logf(name||' received but not saved ('||err||')');
   break = '1'b; /* set not-xfered flag */
   open file($dataf) scratch; /* continue transaction, in case more files coming
 */
   call readdata; /* NOTE: we do not abort just because file can't be opened! */
end;
else do; /* open succeeeded */
   call logf(name||' receive initiate'); /* log start of xfer */
   call odometer(2); /* start the odometer */
   call readdata; /* now read in the D packets */
   call odometer(1); /* stop the odometer */
   if ~break /* if file received properly */
   then call logf(name||' received successfully'); /* log end of xfer */
   else call logf(name||' not received (transmit error)');
end;
name = ''; /* clear override name in case multiple files arrive */
end;

else if typ='X' & seq=$n then do; /* Text to be typed on user screen? */
if ~local then call error('X illegal to remote Kermit');
open file($dataf) frn(frn($screen)); /* refer to screen from I/O file */
call putp('Y',$n,nil); /* ACK the X packet */
call next; /* bump $n, zero $r */
call readdata; /* now read in the D packets */
end;

else if typ='B' & seq=$n then do; /* EOT ? (ie, no more files to be sent) */
call putp('Y',$n,nil); /* ACK the B packet */
return; /* and done reading this group of files */
end;

else if typ='S' & ((seq+1)&63)=$n then do; /* retransmission of the S ? */
call retry; /* bump $r */
call gparms(data); /* get our S-parameters */
call putp('Y',seq,data); /* re-ACK his S, in case our ACK was lost */
end;

else if typ='Z' & ((seq+1)&63)=$n then do; /* retransmission of the Z ? */
call retry; /* bump $r */
call putp('Y',seq,nil); /* re-ACK the Z, in case first ACk was lost */
end;

else if typ='T' then do; /* timeout? */
call retry; /* bump $r */
call putp('N',$n,nil); /* NAK the unreceived packet */
end; /* and keep trying */

else signal cond(abort); /* abort transaction for other packets */

end;

end readhdr;
%subtitle 'Protocol Machine -- Readdata';

/* Readdata --

Receive data up to the end of the file.  We loop over D packets until the
Z which ends the file.

*/

readdata: procedure();

do while(1); /* loop until Z or error */

call getp(typ,seq,$buf); /* read the next packet */

if typ='D' then do; /* D packet? */
if seq~=$n then do; /* wrong seq# ? */
call retry; /* yes, bump $r */
if ((seq+1)&63)~=$N /* if not retransmission of last... */
then signal cond(abort); /* then simply abort */
call putp('Y',seq,nil); /* re-ACK it, perhaps the first ACK was lost */
end;
else do; /* D with correct seq# */
call putb; /* unquote '$buf' and write to file '$dataf' */
call odometer(3); /* count these bytes xferred */
if break /* iterruption wanted? */
then call putp('Y',$n,'X'); /* yes, ACK but ask for a 'Z' next */
else call putp('Y',$n,nil); /* just ACK if no interruption wanted */
call next; /* bump $n, zero $r */
end;
end;

else if typ='Z' & seq=$n then do; /* Z (eof) packet? */
if $buf~='D' /* if not a 'discard' request, but a normal 'Z' */
then close file($dataf); /* then simply close file */
else do; /* if data field of Z packet not null, its a break request */
call unsave($dataf); /* so discard file and close */
break = '1'b; /* set flag that file not xfered */
end;
call putp('Y',$n,nil); /* ACK the Z */
call next; /* bump $n, zero $r */
return; /* done with reading this file */
end;

else if ((seq+1)&63)=$n & (typ='F' | typ='X') then do; /* retransmission? */
call retry; /* bump $r */
call putp('Y',seq,nil); /* re-ACK it, our first ACK probably lost */
end;

else if typ='T' then do; /* Timeout ? */
call retry; /* bump $r */
call putp('N',$n,nil); /* NAK the unreceived packet */
end;

else signal cond(abort); /* abort on bad packets */

end;

end readdata;
%subtitle 'Protocol Machine -- Server';

/* Server --

This is the main loop for server-mode operation.  We loop over messages,
until a BYE or EXIT command stops the program from on high.  Abort signals
are trapped here, lest they terminate server-mode.  Thus, we never leave
this loop except when the program stop.

*/

server: procedure();

dcl exchngd  bit(1) init(''b); /* true when we've seen his I parameters */
dcl cmdf     file internal; /* temp file for command output */
dcl list     char var; /* file list */
dcl i        fixed; /* temp */

serving = '1'b; /* set "server mode" flag */

on condition(abort) begin; /* catch errors */
close file ($dataf); /* close I/O file */
goto LOOP; /* loop for next command */
end;

LOOP: do while(1); /* loop over commands */

$n = 0; /* start transaction with packet #0 */
$r = 0; /* and no retries */
i  = params.time; /* save normal timeout period */
params.time = 60; /* wait up to 60 seconds for server commands, per protocol */
params.chkt = 1; /* checksums revert to the default */
call getp(typ,seq,$buf); /* read next packet */
params.time = i; /* once we recieve command, timeout normally */

if seq~=0 then call error('expected packet 0'); /* only seq=0 is acceptable */

if typ='I' then do; /* I: exchange parameters wo file xfer */
call rparms($buf,'0'b); /* read his parameters */
call gparms(data); /* then get ours */
call putp('Y',$n,data); /* ACK with our parameters */
exchngd = '1'b; /* remember we've seen his parameters */
end;

else if typ='S' then do; /* S: start to receive a file */
call rparms($buf,'0'b); /* read his parameters */
call gparms(data); /* then give him ours */
call putp('Y',$n,data); /* ACK the S with our parameters */
call next; /* bump $n */
call readhdr(''); /* read in the file (no override name) */
end;

else if typ='R' then do; /* R: send him our file(s) */
call unquote; /* unquote filename in $buf */
if params.fncnv /* should we convert filenames? */
then call normaliz($buf); /* yes, do so */
call filelist($buf,list,''b); /* process wildcards and make a list of files */
if list='' then call error('no files specified'); /* empty list? */
call send(list); /* OK: send him the files */
end;

/* Handle Server Commands, either interactive syntax (K) or special
   coded sytax (G).  We unquote these and write to a scratch file,
   then call the command processor to read from the scratch file and
   output to the $dataf file.  Then, the output is examined, and
   either put in an ACK if possible, else sent as text with X and D
   packets.  */

else if typ='K' | typ='G' then do;
open file(cmdf) scratch; /* open a command file */
open file($dataf) scratch; /* open a scratch file for command output */
if typ='G' /* Generic commad? */
then put file(cmdf) edit('generic ')(a); /* then prefix command */
call unquote; /* unquote '$buf' */
put file(cmdf) line($buf); /* write to command file */
reset file(cmdf); /* then reset */
call command(cmdf,$dataf); /* process the commands */
close file(cmdf); /* done with command file */
reset file($dataf); /* reset the output */
call quote; /* get first packet's worth of output in '$buf' */
data = $buf; /* save, in case output is short */
call quote; /* see if there is another packet's worth */
if length($buf)~=0 then do; /* if response will not fit in the 'Y'... */
reset file($dataf); /* reset again */
if ~exchngd | params.iwant>1 /* if haven't seen his I parameters or nonstandard
chkt */
then call send('*TTY|'); /* then must send S, the X, the Ds */
else do; /* if we've seen his I, no need for the S */
call next; /* so bump $n */
call sendhdr('*TTY'); /* then send the X and Ds */
call sendbreak; /* then send the 'B' */
end;
end;
else do; /* it fits in a single ACK */
call putp('Y',$n,data); /* so reply to the command */
close file($dataf); /* done with command output file */
end;
end;

else if typ='C' then call error('DTSS does not implement HOST commands');

else if typ='T' then call putp('N',$n,nil); /* NAK timeouts */

else call error('unexpected packet'); /* random packets result in E's */

end;

end server;
%subtitle 'Protocol Machine -- Send';

/* Send --

This is the entry point to send file(s); it is called both from the server
and from interactive mode.  We are passed a list of files to send.  If the
name is '*TTY|', then we assume that we are to send file $dataf (already open)
to the other end's screen with the 'X' packet protocol.  Otherwise, the file
name list is assumed to be in the format compiled by "filelist", which consists
of one or more treenames terminated with '|' characters.  If a file is to be
sent with a different destination name (SEND FRED XFRED), then the two names
are delimited with an '?' character, ie 'FRED?XFRED|'.

*/

send: procedure(names);

dcl names    char var; /* UPDATE: the filename list (described above) */
dcl dname    char var; /* destination filename */
dcl err      char var; /* error message from 'open' */
dcl i        fixed; /* temp */

/* first, send the S packet (exchanging parameters) */

$n, $r = 0; /* start with packet #0, no retries */
do while($n=0); /* loop until we get a good ACK */
call gparms(data); /* get our S-parameters */
call putp('S',$n,data); /* send the Send_initiate */
call getp(typ,seq,data); /* read the reply */
if typ='Y' & seq=0 /* the expected reply? */
then call next; /* yes, bump $n (exiting loop), zero $r */
else call retry; /* bad response, bump $r */
end;
call rparms(data,'1'b); /* handle other side's parameters */
call choose(); /* choose checksum type */

/* loop over each file */

do while(names~=''); /* loop over each file specified */
i = index(names,'|'); /* find next name */
$buf = substr(names,1,i-1); /* extract filename */
names = substr(names,i+1); /* truncate list */
i = index($buf,'?'); /* distinct destination name? */
if i=0 /* if not... */
then dname = $buf; /* then send with same name */
else do; /* destination name supplied */
dname = substr($buf,i+1); /* extract destination name */
$buf  = substr($buf,1,i-1); /* and local name */
end;
if params.fncnv then do; /* should we normalize the filenames we send? */
   data = dname; /* yes, move into 'dstr' so normaliz can operate on it */
   call normaliz(data); /* then normalize */
   dname = data; /* put back where it belongs */
end;
if $buf='*TTY' /* if special name for "send $dataf to screen" */
then err = ''; /* then we've already got $dataf open as frn 1 */
else call open($dataf,$buf,1,err); /* open the file to be sent */
if err='' /* error? */
then call sendhdr(dname); /* no, send file */
else do; /* open failed */
call logf($buf||' not sent ('||err||')'); /* log failed xfer */
if names='' /* if no more names... */
then call error('can''t open '||$buf||' ('||err||')');
else; /* if more to send, DO NOT tell other end or stop */
end;
end;

call sendbreak; /* send the B to delimit entire list of files */

end send;
%subtitle 'Protocol Machine -- Sendhdr';

/* Sendhdr --

Send the file or text header, then call senddata to pump out the data.
The file sent is $dataf, which should already be open and ready to go.
We are passed the name of the file, which is sent to the other end in the
F packet.  The special name '*TTY' stands for the destination's screen;
we send an X instead of an F in this case.  When we return, the end-of-file
Z packet has already been sent; our caller is responsible for the B.

*/

sendhdr: procedure(destn);

dcl destn    char var; /* UPDATE: destination name (*TTY for screen) */

if destn~='*TTY' then call logf(destn||' send initiate'); /* log start of xfer *
/
break = ''b; /* clear xmit failure flag */
data  = destn; /* move destination name into 'dstr' for 'putp' */

do while(1); /* loop over retries */

if destn='*TTY' /* if the special name... */
then call putp('X',$n,nil); /* then send to the screen */
else call putp('F',$n,data); /* send F for file xfer */
call getp(typ,seq,$buf); /* read the response */

if (typ='Y' & seq=$n) /* if the expected ACK... */
 | (typ='N' & ((seq-1)&63)=$n) /* or if a NAK for next packet (ie, we missed ACK
) */
then do; /* then proceed to send data */
call next; /* bump $n, zero $r */
call odometer(2); /* start the odometer running */
call senddata; /* then send the D packets, finish with Z */
call odometer(1); /* stop the odometer */
if destn~='*TTY' then do; /* don't log xmit of 'screen' files */
   if break /* if xmit failed for some reason */
   then call logf(destn||' not sent (transmit failure)');
   else call logf(destn||' sent successfully');
end;
return; /* and done */
end;

else if typ='N' | typ='T' then call retry; /* retry NAKs and Timeouts */

else signal cond(abort); /* abort on other packet types */

end;
end sendhdr;
%subtitle 'Protocol Machine -- Senddata';

/* Senddata --

Send the contents of a file or textual information.  We loop repeatedly
sending D packets until the end of the file is reached, at which point
we send a Z, close the file, and return.

*/

senddata: procedure();

dcl ok       bit(1); /* flag for loop control */

do while(1); /* loop over each D packet successfully sent */

call quote; /* read '$dataf' and quote into '$buf' */
if length($buf)=0 | break then do; /* if end-of-file or interrupted... */
call sendeof; /* send the Z packet */
return; /* and done */
end;
ok = '1'b; /* prime to enter loop */

do while(ok); /* loop until packet successfully written */

call putp('D',$n,$buf); /* send a data packet */
call getp(typ,seq,data); /* then read the response */

if (typ='Y' & seq=$n) /* if the expected ACK... */
 | (typ='N' & ((seq-1)&63)=$n) /* or if a NAK for next packet... */
then do; /* then other side got our data */
call next; /* bump $n, zero $r */
call odometer(3); /* count these bytes xfered */
if data='X' | data='Z' then do; /* does he want us to interrupt xfer? */
break = '1'b; /* yes, set flag */
call sendeof; /* stop */
return; /* and done */
end;
ok = ''b; /* get next bufferload */
end;

else if typ='N' | typ='T' | typ='Y' then call retry; /* retry NAKs, ACKs, and Ti
meouts */

else signal cond(abort); /* else abort on other packets */

end;
end;
end senddata;
%subtitle 'Protocol Machine -- Sendeof';

/* Sendeof --

Send the Z packet and close the file.  Higher levels are responsible for
sending the next file (if any), or sending the B (if there are no more
files) to end this transaction.

*/

sendeof: procedure();

close file($dataf); /* first, close the file */

do while(1); /* loop until packet successfully sent */
if break /* if interrupting... */
then data = 'D'; /* then tell other side to discard the file */
else data = ''; /* else tell him to keep it */
call putp('Z',$n,data); /* send the EOF */
call getp(typ,seq,data); /* read the response */

if (typ='Y' & seq=$n) /* if the expected ACK... */
 | (typ='N' & ((seq-1)&63)=$n) /* or if a NAK for next packet... */
then do; /* then he got our Z packet */
call next; /* bump $n, zero $r */
return; /* done */
end;

else if typ='N' | typ='T' then call retry; /* retry other NAKs and timeouts */

else signal cond(abort); /* else abort transaction on other packets */

end;

end sendeof;
%subtitle 'Protocol Machine -- Sendbreak';

/* Sendbreak --

Send the B packet, to delimit a list of files being sent.

*/

sendbreak: procedure();

do while(1); /* loop until proper reply recieved */

call putp('B',$n,nil); /* send the B */
call getp(typ,seq,data); /* read the reply */

if      typ='Y' & seq=$n then return; /* done if ACK received */
else if typ='N' & seq=0  then return; /* also ok if we missed his ACK */
else if typ='N' & seq=$n then call retry; /* retry if he missed the B */
else if typ='T'          then call retry; /* retry timeouts etc */
else signal cond(abort); /* reject others */

end;

end sendbreak;
%subtitle 'Protocol Machine -- Sendlong';

/* Sendlong --

This is the main entry for sending commands to a remote server that
expect a long response.  We just ship off an I packet and then join
the short response entry 'sendcmd'.

*/

sendlong: procedure(text);

dcl text char var; /* UPDATE: command type and text */

$n, $r = 0; /* initialize packet# and retry# */

do while(1); /* loop until packet received properly */
call gparms(data); /* set up our S-parameters */
call putp('I',$n,data); /* ship it */
call getp(typ,seq,data); /* read response to our I */

if typ='Y' & seq=$n then do; /* if we got a good response */
call rparms(data,'1'b); /* process his parameters */
call sendcmd(text); /* send the command */
return; /* and done */
end;

else if typ='E' then do; /* he'll send an E if he doesn't like our parameters */
call default; /* so set up default parameters */
call sendcmd(text); /* send the command */
return; /* and done */
end;

else if typ='N' | typ='T' then call retry; /* retry NAKs and timeouts */

else signal cond(abort); /* else abort transaction on other packets */
end;

end sendlong;
%subtitle 'Protocol Machine -- Sendcmd';

/* Sendcmd --

This is the entry used by the command interpreter to send commands
to the remote server Kermit at the other end.  In practice, this is
probably VM/CMS since they can't connect to us.  The command type
and text is sent in the parameter 'text'.  The type is taken from the
first char of 'text', and should be R for Receive, G for Generic, K for
remote, or C for Host.  The reply to our command (X,Y,S, or F) determines
whether to send the reply to the screen or to a file.

*/

sendcmd: procedure(text);

dcl text  char var; /* UPDATE: command type and text */
dcl gctyp char(1); /* the command type */
dcl gctxt char var; /* the command text */
dcl nname char var; /* override name, if any */
dcl i     fixed; /* temp */

/* go through a few shenanigans in order to quote the silly command */

nname = ''; /* clear override name */
gctyp = substr(text,1,1); /* extract command (G,R,K, or C) */
gctxt = substr(text,2); /* and text */
if gctyp='R' then do; /* called for GET command? */
   call split(gctxt,nname); /* split up "files" and "newname" args */
   if params.fncnv then do; /* should we normalize the filename? */
      data = gctxt; /* yes, move into a 'dstr' for normalization */
      call normaliz(data); /* normalize the file */
      gctxt = data; /* then put back */
   end;
end;
open file($dataf) scratch linesize(0); /* must write command here, to quote it *
/
put edit(gctxt)(a) file($dataf); /* write command to file */
reset file($dataf); /* reset it */
call quote; /* read '$dataf' and quote into '$buf' */
close file($dataf); /* done with temp file */

$n, $r = 0; /* initialize seq# and retry# */

do while(1); /* loop retrying command */

call putp(gctyp,$n,$buf); /* send the G, R, K, or C packet */
call getp(typ,seq,data); /* then read the response */

if typ='Y' & seq=0 then do; /* ACK: short response in data field */
$buf = data; /* move response to buffer used by 'unquote' */
call unquote; /* unquote the response */
put file($screen) line($buf); /* print response */
return; /* thats all */
end;

else if typ='X' & seq<=1 then do; /* X: long response to be printed */
open file($dataf) frn(frn($screen)); /* output to screen */
call flush($screen); /* keep output in sync */
$n = seq; /* NOTE: some Kermits send X with seq=0, and some with seq=1 */
call putp('Y',$n,nil); /* ACK the X */
call next; /* bump $n, zero $r */
break = ''b; /* clear flag, so readdata won't abort xmit */
call readdata; /* read the data packets */
close file($dataf); /* done with command response */
call readhdr(''); /* look for B, F, or X */
return; /* then done */
end;

else if typ='S' & seq=0 then do; /* S: file about to come */
call rparms(data,'0'b); /* read his parameters */
call gparms(data); /* assemble our parameters */
call putp('Y',$n,data); /* send our parameters in the ACK */
call next; /* Bump $n, zero $r */
call readhdr(nname); /* look for B, F, or X */
return; /* and done */
end;

else if typ='N' | typ='T' then call retry; /* retry NAKs and Timeouts */

else signal cond(abort); /* else abort on wierd packets */

end;

end sendcmd;
%Subtitle 'Protocol Machine -- Quote';

/* Quote--

Read input from $dataf and quote into $qbuf.  This is the only routine
that quotes data.  It handles control, 8th bit, and repeat prefixing,
as well as breaking up data into appropriate sized blocks.

We keep an explicit buffer of input chars, for efficiency and to be able
to back up easily.  Before trying to understand either this routine or its
sister "unquote", it is helpful to take a look (in the global dcls) at how
$buf overlays $qbuf.  We do this for several reasons:
   1. It lets $but be longer than normal 'dstr' strings, which is helpful
      when unquoting, which can make the data get very much larger due to
      repeat sequences.
   2. It is more efficient to refer to $qbuf than to $buf, in some cases,
      because the PL/I compiler has trouble dealing with varying length
      strings.  $Qbuf is declared nonvarying.

Note that the use of "ovy.c4" requires subscriptrange to be turned off.

*/

(nosubscriptrange, nostringrange):

quote: procedure();

dcl nc       fixed static; /* next char in input buffer */
dcl tc       fixed static; /* total #chars in input buffer */
dcl buf(2048)char(1) static; /* input buffer */
dcl uctl(0:255) fixed static; /* used to "uncontrol" chars */
dcl 1 ovy, /* used for mapping char(1)//fixed */
    2 c4(0)  char(1), /* character representation */
    2 c      fixed; /* fixed representation */
dcl (i,j,k)  fixed; /* temps */

/* if file has not been read, our static data is uninitialized */

if loc($dataf)=1 then do; /* is our buffer initialized? */
nc = 1; /* no, initialize next char pos */
tc = 0; /* and set buffer empty */
ovy.c = 0; /* clear next-char buffer */
do i = 0 to 127; /* loop initializing "uctl" */
uctl(i)     = 0; /* assume not necessary to prefix */
uctl(i+128) = 0; /* handle 8-th bit too */
if i=params.qctl /* if a prefix... */
 | i=params.qbin
 | i=params.rept
then do; /* these must be prefixed, but not modified */
  uctl(i)     = i; /* ie, send '#' as '##' */
  uctl(i+128) = i + 128; /* must escape '#' with 8-th bit set too! */
end;
if i<32 then do; /* true control char? */
  uctl(i)     = i + 64; /* map 0-37b3 ==> 100-137b3 */
  uctl(i+128) = i + 64 + 128; /* map 200-237b3 ==> 300-337b3 */
end;
if i=127 then do; /* ASCII DEL? */
  uctl(i)     = 77b3; /* map 177b3 ==> 77b3 */
  uctl(i+128) = 77b3 + 128; /* map 377b3 ==> 277b3 */
end;
end;
end;

i = 0; /* #chars packed into $qbuf */

/* loop getting a char from buffer, quoting, and packing into $qbuf */
/* we keep i=(length of quoted text), across this loop              */

do while(1); /* loop until $qbuf filled or $dataf exhausted */

/* test for buffer empty */

if nc>tc then do; /* buffer empty? */
j = matread($dataf,buf,wlen(buf)); /* read next bufferload */
if j=-1 then signal transmit($dataf); /* error? */
tc = j * 4; /* get #chars read */
if tc=0 then do; /* none? */
$qlen = i; /* yes, set length of $qbuf */
return; /* and exit */
end;
nc = 1; /* reset next char# to read */
if (lof($dataf)+1)=loc($dataf) then do; /* did we read last word in file? */
do j = tc to tc-2 by -1 while(buf(j)=chr(0)); /* skip trailing nulls */
tc = tc - 1; /* skip up to 3 nulls in last word */
end;
end;
end;

ovy.c4(4) = buf(nc); /* get next input char */
nc = nc + 1; /* bump next char# */

/* handle repeated occurances, if enabled */

if params.rept~=0 then do; /* repeats allowed? */
j = min(tc-nc+1,93); /* how many chars left in buffer? */
do k = 1 to j while(buf(nc+k-1)=ovy.c4(4)); /* count dups */
end;
if k>3 then do; /* enough for use of repeat prefix? */
substr($qbuf,i+1,1) = chr(params.rept); /* yes! pack prefix */
substr($qbuf,i+2,1) = chr(k+32); /* pack in count */
i = i + 2; /* adjust length of $qbuf */
nc = nc + k - 1; /* adjust cur char in buffer */
end;
end;

/* test for parity bits, and handle if set */

if (ovy.c&600b3)~=0 then do; /* parity bits set? */
if (ovy.c&400b3)~=0 then do; /* yes, test 9th bit */
   break = '1'b; /* set, so abort transmission */
   $qlen = 0 ; /* by faking EOF and setting not-sent flag */
   call logf('binary files (9th bits set) cannot be transferred');
   return; /* and done (data path only 8 bits wide) */
end;
if params.qbin~=0 then do; /* 8th bit prefix needed? */
ovy.c = ovy.c & 177b3; /* yes, strip off 8th bit */
substr($qbuf,i+1,1) = chr(params.qbin); /* then pack in the prefix */
i = i + 1; /* bump len of $qbuf */
end;
end;

/* does this char need to be escaped w the control prefix? */

if uctl(ovy.c)~=0 then do; /* control prefix required? */
ovy.c = uctl(ovy.c); /* yes, uncontrollify */
substr($qbuf,i+1,1) = '#'; /* pack in control prefix */
i = i + 1; /* bump len of $qbuf */
end;

/* pack char into $qbuf and test for possible overflow */

substr($qbuf,i+1,1) = ovy.c4(4); /* pack char into $qbuf */
i = i + 1; /* bump len of $qbuf */
if i>(params.maxl-5-6) then do; /* might next char sequence overflow packet len?
 */
$qlen = i; /* yes, set length of $qbuf */
return; /* and done */
end;
end;

end quote;
%subtitle 'Protocol Machine -- Unquote';

/* Unquote --

Unquote '$qbuf' in place.  Due to repeats, the unquoted text can be much
larger then the original, so the declaration of $qbuf is kludged up by
padding it with lots of extra space so it will never overflow.  Refer to "quote"
.

This is the only routine that unquotes data.  The approach is to process
text from left to right, packing data between prefixes down against the
bottom of $qbuf, and handling prefixes as they occur.  We use the INDEX bif
to search for the next prefix.  If expanding a repeat would overwrite
still-quoted text, we move the remaining quoted text to the end of $qbuf.
At all times, the variables 'a', 'b', and 'c' delimit the processed and
unprocessed text as follows:

 1                         a        b                 b+c    (end of $qbuf)
+---------------------------+------+------------------+---------+
| processed (unquoted) text |      | unprocessed text |         |
+---------------------------+------+------------------+---------+

*/

(nostringrange):

unquote: procedure();

dcl a        fixed; /* length, or last char pos, of processed text */
dcl b        fixed; /* start of unprocessed text (first char pos) */
dcl c        fixed; /* length of unprocessed text remaining */
dcl (x,y,z)  fixed; /* pos of next #, &, and ~ prefix ((b+c+1) if none) */
dcl (i,j,k)  fixed; /* temps */

a = 0; /* no processed text yet */
b = 1; /* first unprocessed char */
c = $qlen; /* length of unprocessed text */

substr($qbuf,c+1,1) = chr(params.qctl); /* delimit text w control prefix */
x = index($qbuf,chr(params.qctl)); /* find leftmost '#' */
if params.qbin=0 /* if no 8th bit prefixing... */
then y = 777777b3; /* then say leftmost is very far right indeed */
else do; /* we are 8th bit prefixing */
     substr($qbuf,c+2,1) = chr(params.qbin); /* delimit text with prefix */
     y = index($qbuf,chr(params.qbin)); /* find leftmost */
end;
if params.rept=0 /* if no repeat prefixing... */
then z = 777777b3; /* then say leftmost '~' is very far right indeed */
else do; /* we are repeat prefixing */
     substr($qbuf,c+3,1) = chr(params.rept); /* delimit text w prefix */
     z = index($qbuf,chr(params.rept)); /* find leftmost */
end;

LOOP: do while(c>0); /* loop until all text processed */

i = min(x,y,z); /* get leftmost prefix */
j = min(i-b,c); /* get unprocessed chars before prefix */

if j<0 then do; /* leftmost prefix to left of unprocessed chars?? */
   if x<b then x = index($qbuf,chr(params.qctl),b); /* find next '#' */
   if y<b then y = index($qbuf,chr(params.qbin),b); /* find next '&' */
   if z<b then z = index($qbuf,chr(params.rept),b); /* find next '~' */
   goto LOOP; /* this can happen when a prefix is used literally... */
end; /* for instance, '#~' or '~#&#A' */

if j~=0 & b~=1 /* if any plain-text, and it needs to be moved... */
then substr($qbuf,a+1,j) = substr($qbuf,b,j); /* pack down plain-text */

a = a + j; /* adjust length of processed text */
b = b + (j + 1); /* and start of unprocessed (skipping the prefix) */
c = c - (j + 1); /* and length of remaining unprocessed text */

if c>0 then do; /* if the prefix was not a delimiter past end of input... */

if i=x then do; /* handle control char at b */
call control; /* move down to processed text */
x = index($qbuf,chr(params.qctl),b); /* find next '#' */
end;

else if i=y then do; /* handle 8th bit prefix */
     if b=x then do; /* but wait, is it a '&#' sequence? */
        b = b + 1; /* yes, skip the # too */
        c = c - 1; /* adjust length of unprocessed text */
        call control; /* handle control character at b */
        x = index($qbuf,chr(params.qctl),b); /* find next '#' */
     end;
     else call move1; /* else just move down char at b */
     byte($qbuf,a) = byte($qbuf,a) | 200b3; /* add the 8th bit */
     y = index($qbuf,chr(params.qbin),b); /* find next '&' */
end;

else do; /* handle repeat prefix */
     i = byte($qbuf,b) - 32 - 1; /* get repeat count (one too low) */
     b = b + 1; /* point to repeated character */
     c = c - 1; /* adjust length */
     j = 0; /* assume no 8th bit prefix involved */
     if b>=y & substr($qbuf,b,1)=chr(params.qbin) then do; /* 8-bit prefix? */
        j = 200b3; /* yes, remember to add this bit in */
        b = b + 1; /* then advance past the '&' */
        c = c - 1; /* adjust len */
     end;
     if b>=x & substr($qbuf,b,1)=chr(params.qctl) then do; /* repeated control c
har? */
        b = b + 1; /* yes, advance past the '#' */
        c = c - 1; /* adjust len */
        call control; /* handle control character at b */
     end;
     else call move1; /* else just move down character at b */
     if j~=0 then byte($qbuf,a) = byte($qbuf,a) | 200b3; /* or in 8th bit if nee
ded */
     z = index($qbuf,chr(params.rept),b); /* find next '~' */
     if (a+i)>=b & c>0 then do; /* must we move up unprocessed text? */
        k = length($qbuf) - 3 - c; /* will move text here (save room for xtra pr
efixes) */
        substr($qbuf,k,c+3) = substr($qbuf,b,c+3); /* move way up */
        x = x + (k-b); /* adjust positions of next prefixes */
        y = y + (k-b);
        z = z + (k-b);
        b = k; /* new start of unprocessed text */
     end;
     k = a + i; /* new end of processed text */
     do while(a<k); /* loop duplicating repeated character */
        a = a + 1; /* bump length of processed text */
        substr($qbuf,a,1) = substr($qbuf,a-1,1); /* copy another char */
     end;
end;
end;

end; /* of 'do while(c>0);' */

$qlen = a; /* set length of processed, unquoted, text */
return; /* and done */

/* move one char from unprocessed to processed block */

move1: procedure();

substr($qbuf,a+1,1) = substr($qbuf,b,1); /* move the char */
a = a + 1; /* adjust length of processed text */
b = b + 1; /* and start of unprocessed text */
c = c - 1; /* and length of unprocessed text */

end move1;

/* make char at 'b' a control char, and move down */

control: procedure();

k = byte($qbuf,b); /* get the char */
if ((k&177b3)>=100b3) & ((k&177b3)<=137b3)
then k = k - 100b3; /* map 100-137 ==> 000-037 */
else if (k&177b3)=77b3
then k = k + 100b3; /* map 077 ==> 177 */
byte($qbuf,a+1) = k; /* move down */
a = a + 1; /* adjust length of processed text */
b = b + 1; /* adjust start of unprocessed test */
c = c - 1; /* and length of unprocessed text */

end control;

end unquote;
%subtitle 'Protocol Machine -- Gparms';

/* Gparms --

Assemble our preferred protocol parameters into S-format.

*/

gparms: procedure(d);

dcl d dstr; /* OUTPUT: the S-format parameters */

d = (9)' '; /* we send a 9-character string */
byte(d,1) = 94+32; /* allow 94-character packets */
byte(d,2) =  7+32; /* timeout after 7 seconds */
byte(d,3) =  0+32; /* no padding characters needed */
byte(d,5) = ascii('cr')+32; /* please put a CR at the end of every packet */
substr(d,6,1) = '#'; /* the control character quote */
substr(d,7,1) = 'Y'; /* we can quote 8th bit if other end needs to */

if params.iwant~=0 /* if we have a preferred checksum type... */
then byte(d,8) = params.iwant + ascii('0'); /* then state it */
else if params.uwant~=0 /* else if you have a preferred checksum... */
then byte(d,8) = params.uwant + ascii('0'); /* then that's OK with us */
else substr(d,8,1) = '1'; /* else, lets use one character checksums */

if params.rept~=0 /* if other end has already suggested a repeat character... */
then byte(d,9) = params.rept; /* then use it */
else byte(d,9) = ascii('~'); /* else suggest we repeat with '~' */

end gparms;
%subtitle 'Protocol Machine -- Rparms';

/* Rparms --

Process S-format parameters received from other end.  Note that, for most fields
,
a space means use the default value; we assume 'default' has already been called
.

*/

rparms: procedure(d,sent);

dcl d    dstr; /* INPUT: data field of packet */
dcl sent bit(1) aligned; /* INPUT: true if we've already sent our suggestions */
dcl d9   char(9); /* we only interpret the first 9 bytes */
dcl i; /* temp */

(nostrz): d9 = d; /* truncate or space fill, as necessary */

if substr(d9,1,1)~='' then params.maxl = byte(d9,1) - 32; /* max packet len */
if substr(d9,2,1)~='' then params.time = byte(d9,2) - 32; /* timeout */
if substr(d9,3,1)~='' then params.npad = byte(d9,3) - 32; /* #padding chars */
if substr(d9,4,1)~='' then do; /* handle padding char, if specified */
   i = byte(d9,4); /* get it so we can 'uncontrol' it */
   if (i&64)~=0 /* if was 0-37b3 */
   then params.padc = i - 64; /* then set up */
   else params.padc = i + 64; /* probably padding with DELs (177b3) */
end;
if substr(d9,5,1)~='' then params.eol  = byte(d9,5) - 32; /* packet delimiter */
if substr(d9,6,1)~='' then params.qctl = byte(d9,6); /* control char quote */
if substr(d9,7,1)~='' then do; /* handle 8th bit quoting, if requested */
   i = byte(d9,7); /* get requested quote character */
   if (i>=33 & i<=62) /* if in allowed range... */
    | (i>=96 & i<=126) /* (this handles values of 'N' and 'Y' properly) */
   then params.qbin = i; /* then use this char to quote 8th bit */
   else params.qbin = 0; /* else no quoting */
end;
if substr(d9,8,1)~='' then do; /* handle checksum type */
   i = byte(d9,8) - ascii('0'); /* map to 1-3 */
   if (i=1 | i=2) /* if an implemented checksum type... */
   then params.uwant = i; /* then remember your preference */
   else params.uwant = 0; /* treat unimplemented requests like no requests */
   if ~sent & params.iwant=0 /* if I haven't sent mine, and I have no preference
 */
   then params.iwant = params.uwant; /* then I'll do whatever you want */
end;
if substr(d9,9,1)~='' then do; /* handle repeating, if requested */
   i = byte(d9,9); /* get his suggestion */
   if ~sent /* if we haven't yet sent our parameters... */
    | (i=ascii('~')) /* or if we've sent our suggestion, and he agrees */
   then params.rept = i; /* then we'll be repeat prefixig */
   else params.rept = 0; /* else no repeating */
end;
end rparms;
%subtitle 'Protocol Machine -- Odometer';

/* Odometer --

This routine keeps track of the #bytes transferred, when we are running
locally.  We must be called at the beginning of each xfer, whenever bytes
are successfully transferred, and at the end.  In addition, there is a
special entrance called when a transaction is aborted, to disable the odometer.

*/

odometer: procedure(n);

dcl n  fixed; /* INPUT: action  0:disable  1:stop  2:start  3:advance */
dcl m  fixed static init(-1); /* the 'odometer', initially off */

do case(n+1); /* branch on action */
if m>=0 then do; /* 0: DISABLE ODOMETER (called via 'signal(abort)') */
   m = -1; /* stop it */
   put file($screen) skip; /* advance to next line */
end;
if m>=0 then do; /* 1: TURN OFF ODOMETER (xfer complete) */
   put file($screen) skip(0) edit(m,' bytes transferred')(f(7),a); /* final #byt
es */
   put file($screen) skip(1); /* advance to next line */
   m = -1; /* turn off the odometer */
end;
do; /* 2: TURN ON ODOMETER (start of xfer) */
   if local & ~debuging /* must be local, but if debugging plenty of output anyw
ay... */
   then m = 0; /* start counter by setting nonnegative */
end;
if m>=0 then do; /* 3: ADVANCE ODOMETER (bytes xferred) */
   m = m + length($buf); /* bump counter ($buf always contains the bytes xferred
) */
   if ($n&3)=0 then do; /* update screen every 4 packets... */
      put file($screen) skip(0) edit(m,' bytes transferred')(f(7),a);
      call flush($screen); /* update display immediately */
   end;
end;
end;

end odometer;
%subtitle 'Protocol Machine -- Subroutines';


/* bump $n (modulo 64) and zero $r */

next: procedure();

$n = ($n + 1) & 63; /* bump mod 64 */
$r = 0; /* zero retry count */

end next;


/* bump $r, checking for retry threshold */

retry: procedure();

$r = $r + 1; /* bump retry count */
if $r>params.maxretry /* if too many retries... */
then signal cond(abort); /* then abort the transaction */

end retry;


/* handle protocol error */

error: procedure(msg);

dcl msg char var; /* the error message */

if local /* if a local Kermit... */
then $errmsg = msg; /* then put in canonic spot */
else call putp('E',$n,(msg)); /* else send an Error packet */

signal cond(abort); /* then abort the transaction */

end error;


/* Unquote '$buf' and write to '$dataf'  */

putb: procedure();

linesize($dataf) = 0; /* turn off linewrap */
call unquote; /* unquote '$buf' */
put file($dataf) edit($buf)(a); /* write data to output file */

end putb;


/* choose checksum type: called after an S-parameter exchange */

choose: procedure();

if params.iwant~=0 /* if I've expressed a preference... */
 & params.iwant=params.uwant /* ...and if you've agreed... */
then params.chkt = params.iwant; /* then lets use it */
else params.chkt = 1; /* else use default (1-char) checksums */

end choose;

end protocol;
%subtitle 'Protocol Machine -- Default Parameters';

/* Default --

Sets up the default values of the protocol parameters, which are defined
by the protocol.

*/

default: procedure();

%list off;%include 'params';%list on;

params.maxl = 80; /* max packet length */
params.time = 5; /* 5 timeout in seconds */
params.npad = 0; /* #padding characters */
params.padc = 0; /* pad with NULLs */
params.eol  = ascii('cr'); /* terminate packets with an CR */
params.qctl = ascii('#'); /* quote control chars with '#' */
params.qbin = 0; /* don't quote 8th bits */
params.chkt = 1; /* single character checksums */
params.rept = 0; /* don't use repeat counts */
params.A    = '0'b; /* don't use A(ttribute) packets */
params.fncnv= '0'b; /* don't map filenames */
params.overwrit = ''b; /* don't overwrite existing output files by default */
params.maxretry = 5; /* max retry count */
params.iwant    = 0; /* this Kermit has not expressed a checksum preference */
params.uwant    = 0; /* nor has other end */

end default;
%subtitle 'Transmission -- Putp';

/* Putp --

Write a packet.  We assemble the padding characters, headers, checksum,
trailing character, and ship it off.  The data is assumed to be already
quoted, if necessary.

If the write operation fails, we signal the 'abort' condition, which causes
the protocol machine to abort the current transaction.  Otherwise, if we
return, the packet has left DCTS successfully.

*/

(nosubscriptrange, nostringrange):

putp: procedure(type,seqn,data);

%list off;%include 'params';%list on;

dcl type     char(1); /* INPUT: packet type */
dcl seqn     fixed; /* INPUT: sequence# */
dcl data     dstr; /* INPUT: data field */

dcl iobuf    char(150); /* I/O buffer */
dcl ld       fixed; /* length(data) */
dcl cks      fixed; /* checksum */
dcl (i,j)    fixed; /* temps */
dcl (m1,m2)  fixed static; /* MME parameters */
dcl regs(0:11) fixed; /* MME parameters */

dcl checksum entry(char(150),fixed,fixed); /* to compute checksums */
dcl debugp   entry(char(150),char var); /* to log debugging information */
dcl lostconn entry(fixed); /* called when connection lost */

ld = length(data); /* get length of packet data field */

/* assemble the characters to be written */

do j = 1 to params.npad; /* first, the padding chars */
   substr(iobuf,j,1) = chr(params.padc); /* pack in a padding char */
end;
substr(iobuf,j+0,1)  = chr(01); /* the mark */
substr(iobuf,j+1,1)  = chr(ld+2+params.chkt+32); /* length of packet */
substr(iobuf,j+2,1)  = chr(seqn+32); /* sequence# */
substr(iobuf,j+3,1)  = type; /* packet type */
substr(iobuf,j+4,ld) = data; /* then the data */
j = j + (ld + 3); /* #chars packed into iobuf so far */

/* append checksum to packet */

call checksum(iobuf,j,cks); /* compute checksum */
cks = cks - params.npad*params.padc; /* don't checksum padding characters! */
do case(params.chkt); /* branch on checksum type */
do; /* type 1: single character */
  substr(iobuf,j+1,1) = chr(((cks+shr(cks&192,6))&63)+32); /* compute per protoc
ol */
end;
do; /* type 2: double character */
  substr(iobuf,j+1,1) = chr((shr(cks,6)&63)+32); /* bits 007700b3 of checksum */
  substr(iobuf,j+2,1) = chr((cks&63)+32); /* bits 000077b3 of checksum */
end;
end;
j = j + params.chkt; /* adjust running sum of length */

/* log packet if debugging */

if debuging then call debugp(iobuf,'sent');

/* append terminating EOL */

substr(iobuf,j+1,1) = chr(params.eol); /* the terminator */
j = j + 1; /* count the terminator */

/* write the packet using a MME, so we can indicate its exact character length *
/

m1 = waddr(iobuf); /* point to the I/O buffer */
m2 = shr(j+3,2); /* get word length of packet */
unspec(regs) = ''b; /* clear the registers */
regs(1) = waddr(m1); /* X1: ptr to ptr to buffer */
regs(2) = frn($comf); /* X2: frn of destination */
regs(4) = (-j)&3; /* X4: #padding characters, in destination field */
regs(7) = waddr(m2); /* X7: ptr to #words to write */
do i = 1 to params.maxretry; /* loop retrying bad statuses */
   $timeout = - params.time; /* set the timer running */
   call mme(500234b3,regs); /* Write the buffer */
   $timeout = 0; /* stop the timer */
   if regs(10)=0 then return; /* exit if good status */
end;

call lostconn(regs(10)); /* lost connection if cannot write after several retrie
s */

end putp;
%subtitle 'Transmission -- Getp';

/* Getp --

Input a packet.  We verify the checksum and unpack it into the component
fields of interest to higher levels.  Most errors detectible at this level,
such as timeouts, short packets, bad checksums, etc result in the return of
a fake 'T' packet, with sequence#=$n.  If we get an error ("E") packet, all
we do is save the error message; the caller is responsible for signalling
abort, if he wants to.  True I/O errors (that seem fatal) cause "abort" to
be signalled, at least.  The data is NOT unquoted.

*/

(nostringrange, nosubscriptrange):

getp: procedure(type,seqn,data);

%list off;%include 'params';%list on;

dcl type     char(1); /* OUTPUT: packet type */
dcl seqn     fixed; /* OUTPUT: sequence# */
dcl data     dstr; /* OUTPUT: quoted data field */

dcl iobuf    char(150); /* I/O buffer */
dcl cks      fixed; /* checksum */
dcl pl       fixed; /* packet length in chars */
dcl (i,j)    fixed; /* temps */

dcl checksum entry(char(150),fixed,fixed); /* to compute checksums */
dcl debugp   entry(char(150),char var); /* debugging output */
dcl lostconn entry(fixed); /* called if connection lost */

/* loop issueing the read, retrying until we get solid data, error, or timeout *
/

i, j = 0; /* initialize position of mark (001) and retry count */
do while(j=0); /* loop until we get valid data */
   $timeout = - params.time; /* set clock ticking */
   pl = matread($comf,iobuf,wlen(iobuf)) * 4; /* read the packet, set pl:=#bytes
 */
   $timeout = 0; /* stop the clock */
   j = index(substr(iobuf,1,max(pl,0)),chr(1)); /* look for start of packet */
   if j=0 then do; /* if no mark character (001) in data read... */
      if pl<0 then do; /* I/O error: trouble! */
         if stw1($comf)=20000000b3 /* if reset status... */
         then call T('timeout'); /* then say we got a timeout */
         else call lostconn(stw1($comf)); /* signal abort on other bad statuses
*/
      end;
      i = i + 1; /* bump retry count */
      if i>params.maxretry then call T('too many retries');
   end;
end;

/* trim off leading and trailing junk */

if j>1 then do; /* if junk preceeds packet in data read... */
   pl = pl - j + 1; /* adjust length of packet by #bytes preceeding 001 */
   if pl<5 then call T('too short'); /* minimum packet size in 5 chars */
   substr(iobuf,1,pl) = substr(iobuf,j,pl); /* move down in buffer */
end;
j = byte(iobuf,2) - 32 + 2; /* get logical packet length */
if j<5 | j>96 then call T('bogus packet len'); /* valid length field? */
if j>pl then call T('truncated'); /* return error if entire packet not read */
pl = j; /* forget trailing junk (the CR, NULLs, etc) */

/* Heuristic: infer checksum method from packet received (suggested by protocol)
 */

if      substr(iobuf,4,1)='S' then params.chkt = 1; /* S packets always type 1 *
/
else if substr(iobuf,4,1)='N' then do; /* N packets are 'universal synchronizers
' */
     if (pl-4)>0 & (pl-4)<3 /* data field of N packets always null... */
     then params.chkt = pl - 4; /* so infer checksum length from packet length..
. */
end; /* (as long as latter is reasonable!) */

/* log packet if debugging is enabled */

if debuging then call debugp(iobuf,'rcvd');

/* Checksum data */

do case(params.chkt); /* branch on checksum type */
cks = byte(iobuf,pl)-32; /* type 1: get single byte checksum */
cks = (byte(iobuf,pl-1)-32)*64 + byte(iobuf,pl)-32; /* type 2: double byte */
end;
pl = pl - params.chkt; /* strip checksum off input string */
if pl<4 then call T('malformed'); /* too short? */
call checksum(iobuf,pl,i); /* compute checksum */
do case(params.chkt); /* branch on checksum type once again */
  if cks~=((i+shr(i&192,6))&63) then call T('chks err 1'); /* type 1 */
  if cks~=(i&7777b3) then call T('chks err 2'); /* type 2 */
end;

/* extract fields, save message if 'E', and return */

seqn = byte(iobuf,3) - 32; /* get sequence# */
data = substr(iobuf,5,pl-4); /* get data */
type = substr(iobuf,4,1); /* get packet type */

if type='E' then $errmsg = data; /* save message if error packet */

ERR: return; /* done */


/* return T packet on error */

T: proc(msg);

dcl msg char var; /* INPUT: error message */

if debuging /* log reception errors if debugging */
then call debugp(iobuf,'rcvd in error ('||msg||') stw1:'||octal(stw1($comf)));

type = 'T'; /* set type to generic error */
seqn = $n; /* set seq# to what is expected (this is required) */
data = ''; /* nullify data field */
goto ERR; /* return to getp's caller */

end T;

end getp;
%subtitle 'Transmission -- Lostconn';

/* Lostconn --

Called from GETP and PUTP, when we get a bad status on the MME, other than
commfile busy (6) and reset status (20), which are usually retried.  The connect
ion
appears to be dead.  If in server mode, all communication has been lost with
the world, so we can only terminate.  If local, we print an error message and
signal "abort", which will cause us to return to command level and report the
problem.

*/

lostconn: procedure(stw1);

%list off;%include 'params';%list on;

dcl stw1 fixed; /* INPUT: stw1 from mme */
dcl logf entry(char var); /* to log messages */

call logf('Connection closed due to communication error ('||octal(stw1)||')');

if serving /* if in server mode... */
then stop; /* then there's no recovery possible */
else signal cond(abort); /* else abort protocol, back to command processing */

end lostconn;
%subtitle 'Transmission -- Debugp';

/* Debugp --

Print debugging information regarding packet transmission.  Called from
the lowest level, ie 'getp' and 'putp'.  The packet we are passed may
contain leading and trailing padding, but has otherwise been checked for
gross format consistenncy (except for error msgs).  Debugging mode should be ON.

*/

debugp: procedure(packet,leader);

%list off;%include 'params';%list on;

dcl packet   char(150); /* INPUT: the packet buffer */
dcl leader   char var; /* message header ('rcvd', 'sent', or error msg) */
dcl f        file variable; /* temp */
dcl (i,j)    fixed; /* temps */

if      local   then f = $screen; /* output to screen if local */
else if logging then f = $log; /* else output to logfile if enabled */
else return; /* else nowhere to write our message! */

if length(leader)>5 /* if (long) error message... */
then put file(f) line('*pkt ',leader); /* then just log */
else do; /* normal xmit, log packet contents */
   i = index(packet,chr(1)); /* find start of packet in buffer */
   j = byte(packet,i+1)-32-2-params.chkt; /* length of data field */
   linesize(f) = 0; /* make sure lines don't wrap */
   put file(f) edit('*pkt ',leader,substr(packet,i+3,1),byte(packet,i+2)-32,
                substr(packet,i+4+j,params.chkt),'"',substr(packet,i+4,j),'"')
       (a,a(5),a,f(3),x(1),a(2),x(1),a,a,a);
   put file(f) skip;
end;

call flush(f); /* write it out now */

end debugp;
%subtitle 'Transmission -- Checksum';

/* Checksum --

Compute the packet checksum, which is defined to be the sum of its
bytes.  We KNOW that no 400b3 bit is set in any byte, since when sending
one of our files the quoting mechanism strips them off, and the front
ends guarantee these bits to be 0 when receiving someone else's file.
This lets us be slightly tricky, and compute the checksums in semi-
parallel, because we know that we can add any two bytes of data without
carrying out of a 9-bit byte.

We assume we are passed the MARK character (001), which is not added into
the checksum, and that we are not passed the checksum itself.

The checksum returned will have garbage in its upper half.

*/

(nosubscriptrange, nostringrange):

checksum: procedure(data,len,cks);

dcl data     char(150); /* INPUT: the packet buffer */
dcl len      fixed; /* INPUT: the packet length, minus the checksum field */
dcl cks      fixed; /* OUTPUT: the sum of each byte, minus 1 (for the mark) */

dcl word(0)  fixed based; /* used to access data by the word */
dcl p        ptr; /* addr(data), for use w 'word' */
dcl nulls    char(3) static init(chr(0)||chr(0)||chr(0)); /* for null padding */
dcl (i,j)    fixed; /* temps */

substr(data,len+1,3) = nulls; /* null pad last word */
i = shr(len+3,2); /* get word length of packet */
p = addr(data); /* get address of data */

j = -1; /* initialize checksum to account for mark character */
do while(i>0); /* loop over each word of packet */
   j = j + ((p->word(i)+shr(p->word(i),9))&000777000777b3); /* sum both halves *
/
   i = i - 1; /* next word, if any */
end;

cks = shr(j,18) + j; /* checksum is sum of upper and lower sums */

end checksum;
%subtitle 'Transmission -- Ticktock';

/* Ticktock --

This is a task, spawned during initialization, that wakes up every 5 seconds
and bumps the $timeout timer, if it is running (ie, if it is negative.)  If
it goes zero, a Reset Status is done on file $comf.  This is the way we
timeout reads and writes of packets.

*/

ticktock: procedure;

%list off;%include 'params';%list on;

%dcl N lit '5'; /* ticktock period, in seconds */

dcl reset    entry(fixed); /* to issue reset status */

do while(1); /* loop forever */
call wait(N); /* wait for N seconds */
if $timeout<0 then do; /* if the clock is running... */
   $timeout = $timeout + N; /* then bump by N seconds */
   if $timeout>=0 then do; /* did it run out? */
      if $timeout~=(N-1) /* give any timer longer than 1 sec at least 2 ticks */
      then $timeout = -1; /* (otherwise it might go off almost instantly) */
      else call reset($comffrn); /* reset comfile, timing out the read */
   end;
end;
end;

end ticktock;
%subtitle 'Transmission -- Terminal Emulation';

/* Terminal Emulation --

This is the external procedure spawned by the CONNECT command, to
do terminal emulation.  All that's required to "emulate" a terminal,
at least in our simplistic view, is to read the outbound connection and
write what we get to the screen, and visa versa.  We do this by setting
ourselves up as a global on unit for the Interrupt condition, and responding
to interrupts.  We look for unrequested input specials; when one comes in,
we read the data and write it to the other end.

The "real" terminal is file $screen, usually controlled by TCFACE.  The
outbound connection to the remote system is file $comf, always controlled
by NETFACE.

There are two complications.  First, TCFACE will discard pending input when
it receives output.  If we write to $screen after getting an URI special,
but before reading it, then the read will hang when finally issued.  We handle
this by clearing pending URIs when we write (it is IMPOSSIBLE to tell if a
TCFACE read will hang-- believe me, I implemented comfiles in the Exec!).
In effect, TCFACE is throwing away typeahead.  This makes it very difficult
to simulate terminals in full duplex (ie, with the system echoing the chars
typed), since inevitably the chars sent by the system to echo what is being
types will pass characters being sent to the system as they are typed, in
which case the chars typed will be discarded by TCFACE as typeahead!  We handle
this by NEVER DRIVING THE SCREEN INTO CHARACTER-BY-CHARACTER MODE, since doing
so will almost certainly result in typed chars being lost.  UNIX, and many
other systems, drive c-b-c mode, but we just keep the screen in l-b-l mode.
This works OK in most cases; UNIX won't get any input until the CR is typed,
but for most simple applications on UNIX this is (barely) adequate.

The other complication occurs when we get a zero status reading a TCFACE
terminal in build mode (for instance); we can't tell whether there is more
input pending, and therefore whether we should reissue the read.  We handle
this by not rereading.  Note that NETFACE does not discard pending input
the way TCFACE does, and it always sends URIs if input arrives wo a read
outstanding, so it is easier to deal with than TCFACE.

Terminal emulation continues until the user types "@@<ret>" on the real
terminal, at which point we drive both ends back to line-by-line mode and
unblock the main program.

What we don't do correctly is return to the state the emulation was in
if this is not the first communication with the network connection.
For example, say we connect to a UNIX.  They will drive the connection
into char-by-char, no-echo, no-append-LF mode.  When the user escapes
from the emulation, to transfer a file or something, we drive the files
back to line-by-line mode, and drive $screen even further (turning on
echo and LF-echo.)  Now, if the user does not put UNIX in server mode,
when he re-connects we'll leave the files in line-by-line mode etc.
Wrong!  The fix is to keep track of the current state, ad re-drive it
when re-emulating.  The trouble is, this is hard to do, but should be
done.

This is, by far, the most system-dependent and obscure part of Kermit.
Mostly because of TCFACE's typeahead throwaway, it CANNOT work entirely
satisfactorily.  We try to get it to work adequately for all systems.

*/

terminal: procedure(); /* first a task, then a global On Unit */

%list off;%include 'params';%list on;

dcl drive     entry(file,fixed); /* to issue a drive MME */
dcl nothing   entry; /* do-nothing On Unit for Interrupt */

dcl emulating bit(1) static init(''b); /* true when terminal emulating */
dcl termwait  fixed  ext; /* Q main task uses to wait for us to finish */
dcl f(2)      file   static; /* used to switch between $screen and $comf */
dcl (m1,m2)   fixed  static; /* MME parameters */

dcl (i,j)     fixed; /* temps */
dcl regs(0:11)fixed; /* MME registers */
dcl buf       char(2048); /* I/O buffer */
dcl n         fixed; /* file# 1:$screen  2:$comf  */
dcl ws        bit(1); /* true if this task has written screen */
dcl 1 spec, /* special interrupt template */
    2 bits    bit(9), /* slave end's bits */
    2 type    unsigned(9), /* special type */
    2 frn     unsigned(18), /* frn */
    2 data    fixed; /* length, etc. */


/* if not emulating, this is the original (spawned) task, so initialize */

if ~emulating then do; /* if just spawned by CONNECT command... */
   f(1) = $screen; /* initialize file index */
   f(2) = $comf; /* used for I/O switch */
   put file($screen) line('[Connecting to remote host, type "@@<cr>" to return.'
);
   put file($screen) line(' Remember, typeahead is not possible, so wait for out
put');
   put file($screen) line(' to complete before typing (and do not type a BREAK).
]');
   call flush($screen); /* flush the above message */
   emulating = '1'b; /* ok, we're set to go... */
   call drive($screen,000006b3); /* drive TCFACE into Line-by-Line wo LF echo */
   on interrupt global(terminal); /* set ourselves up as an on unit */
   signal interrupt; /* then handle the stacked specials (if any) */
   return; /* thats all until next special comes in */
end;


/* loop on each special */

ws = ''b; /* haven't written screen yet */

do while(emulating); /* return when out of specials or escaped */
unspec(spec) = oninterrupt(); /* get next special, if any */
if unspec(spec)=''b then return; /* if no more, wait for next */
if spec.type=1 /* if an unrequested input special... */
then call read; /* then handle */
else; /* else ignore others */
end;

EXIT: return; /* terminate task if escaped out of terminal emulation */


/* handle unrequested input */

read: procedure();

dcl n   fixed; /* file#  1:$screen   2:$comf  */
dcl frn builtin;

if spec.frn=frn($screen) /* $screen? */
then n = 1; /* yes, remember file index */
else if spec.frn=frn($comf) /* remote system? */
then n = 2; /* yes */
else return; /* ignore others (huh?) */

if debuging then call debug('URI spec  f:'||n||'  ms:'||ws||'  wds:'||octal(spec
.data));

if n=1 & ws then return; /* don't read TCFACE after writing to it! */

/* Must read via Read MME, in order to set the substatus and metatext
   enable bits in X4, so we are enabled for reading "metatext", or
   incoming drive information from the network.  The 100 bit in the upper
   byte of stw1 on the trap will be set if we get metatext. */

m1 = waddr(buf); /* ptr to I/O buffer */
m2 = wlen(buf); /* #words to read */
unspec(regs) = ''b; /* zero the registers */
regs(0) = spec.frn; /* X0: frn */
regs(3) = waddr(m1); /* X3: ptr to buffer ptr */
regs(4) = 140000b3; /* set substatus-request and metatext-enable bits */
regs(7) = waddr(m2); /* X7: ptr to #words to read */
call issue(500233b3); /* issue Read and handle comfile busy etc */
if debuging then call debug('read  stw1:'||octal(regs(10))||' '||octal(regs(11))
);
if (shr(regs(10),18)&776b3)~=0 then return; /* ignore bad statuses */
i = m2 + regs(11); /* get #words transferred */

if i<0 then return; /* ignore bad reads (BUT echo 0-len reads!) */
j = shr(regs(10),27); /* get substatus bits from read */

if (j&100b3)~=0 then do; /* if metatext bit set... */
   call metatext(n,i); /* process the information */
   return; /* don't write to other end! */
end;

if (n=1) & (i>0) & (substr(buf,1,3)='@@'||chr(ascii('cr'))) then do; /* escape s
equence? */
   call escape; /* turn off terminal emulation */
   return; /* done */
end;

if debuging then call debug('f:'||n||'  data:'||substr(buf,1,min((i*4)-(j&3),60)
));

/* must write via Write MME in order to set character residue, since some
   systems (rightfully) object to getting spurious trailing nulls */

j = 0; /* initialize count of trailing nulls */
do while(i>0 & j<3 & substr(buf,i*4-j,1)=chr(0)); /* loop discarding null fill o
f last word */
   j = j + 1; /* up to 3 trailing nulls */
end;
m2 = i; /* #words read */
regs(1) = waddr(m1); /* X1: ptr to ptr to buffer */
regs(2) = frn(f(3-n)); /* X2: frn of destination */
regs(4) = j; /* X4: set character-residue in destination field */
call issue(500234b3); /* issue Write, ignore status (except retry 6s) */

if n=2 then do; /* if reading $comf and writing $screen... */
   ws = '1'b; /* then remember not to try to read $screen */
   if logging & ~debuging /* if logging... (data already written if debugging) *
/
   then j = matwrite($log,buf,i); /* then log output to screen */
end;

end read;


/* escape sequence typed on screen, so shut down terminal emulation */

escape: procedure();

on interrupt global(nothing); /* don't react to further interrupts (but keep the
m stacked) */

call drive($screen,000000b3); /* set line-by-line mode */
call drive($screen,000020b3); /* turn on echo */
call drive($screen,003030b3); /* echo LF after CR, output messages and warnings
*/

put file($screen) line('[Connection suspended, back at DCTS]');

emulating = ''b; /* no longer emulating */
call unblock(termwait); /* unblock main task */

end escape;


/* handle incoming metatext (ie, drives): echo to the other side */

metatext: procedure(file,words);

dcl file     fixed; /* INPUT: the file# sending metatext */
dcl words    fixed; /* INPUT: #words of data read */
dcl (i,j,n)  fixed; /* temps */

i = 1; /* first byte to examine in input */

do while(i<=words*4); /* loop until input exhausted */
   j = byte(buf,i); /* get length of next 'record' in KSP metatext */
   if j=0 then return; /* done when we reach last-record-flag */
   n = byte(buf,i+1) - 'A0'b4; /* get drive type and normalize */
   i = i + j; /* advance pointer into input buffer */
   if n>=0 & n<37b3 & n~=12b3 then do;/* if drive looks ok... (do NOT drive char
-by-char!) */
      call drive(f(3-file),n); /* then do it to the other side */
      if debuging then call debug('drive  f:'||file||'  mod:'||substr(octal(n),7
));
   end;
   else do; /* we'll ignore this drive */
      if debuging then call debug('drive  f:'||file||'  mod:'||substr(octal(n),7
)||' NOT echoed');
   end;
end;

end metatext;


/* debugging mode output */

debug: procedure(txt);

dcl txt char var; /* UPDATE: line of output */
dcl prt char var; /* the printable chars */
dcl i,j;

if logging then do;/* make sure we're logging (bad idea to write to $screen) */
prt = substr(collate(),32,95); /* get the printable chars */
i = verify(txt,prt); /* any control chars, DELs, or chars w 8th bits set? */
do while(i~=0); /* loop over each ctl char */
j = byte(txt,i) & 177b3; /* yes, get it and mask off parity bits */
if j=177b3 /* delete? */
then j = 77b3; /* we'll print DEL as '^?' */
else j = j + 64; /* else, print NULL as '^@', etc */
txt = substr(txt,1,i-1)||'^'||chr(j)||substr(txt,i+1);
i = verify(txt,prt); /* another control char in string? */
end;
put file($log) line('### ',txt);
end;

end debug;


/* issue MME and handle commfile-busy statuses */

issue: procedure(n);

dcl n fixed; /* INPUT: mme# */
dcl i fixed; /* loop index */

do i = 1 to params.maxretry; /* loop retrying 6s */
   call mme(n,regs); /* issue the mme */
   if (shr(regs(10),18)&777b3)>=200b3 then do; /* XR0 or XR2 errors mean comfile
 closed */
      call escape; /* "escape" out of terminal emulation */
      put file($screen) line('Connection closed.');
      goto EXIT; /* abort emulation */
   end;
   if regs(10)~=6000000b3 /* if not the dreaded commfile-busy... */
   then return; /* then done */
end;

end issue;

end terminal;
%subtitle 'Transmission -- Nothing';

/* Nothing --

When we escape from terminal emulation, this procedure is set up as the
global On Unit for Interrupt.  We do nothing, but allow specials to accumulate
in case we re-"connect" to the terminal emulation session, in which case the
pending specials will still be there (NETFACE does not discard typeahead.)

*/

nothing: procedure();

end nothing;