home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
intel86b.zip
/
kersys.p86
< prev
next >
Wrap
Text File
|
2011-08-10
|
37KB
|
1,000 lines
$large ram optimize(3)
Kermit$sys: do;
/*
* K e r m i t File Transfer Utility
*
* iRMX-86 Kermit, Version 2.41
* by Albert J. Goodman, Grinnell College
*
* System-dependent interface and utility procedures module.
* Edit date: 22-August-1985
*/
/* Define the iRMX-86 operating system interface */
/* Define the exception codes we use */
declare
E$OK literally '0000h',
E$FNEXIST literally '0021h', /* non-existent file */
E$FACCESS literally '0026h', /* file access not granted */
E$FTYPE literally '0027h', /* bad file type */
E$LOG$NAME$NEXIST literally '0045h', /* non-existent logical name */
E$CONTINUED literally '0083h'; /* continued command line */
/* Define the system type TOKEN */
$include(:I:LTKSEL.LIT)
/* Include external definitions for the iRMX-86 system calls we use */
$include(:I:HSNCOR.EXT)
$include(:I:HFMTEX.EXT)
$include(:I:HGTICN.EXT)
$include(:I:HCRCCN.EXT)
$include(:I:HSNCMD.EXT)
$include(:I:HGTCMD.EXT)
$include(:I:IEXIOJ.EXT)
$include(:I:ISATFL.EXT)
$include(:I:ISCRFL.EXT)
$include(:I:ISOPEN.EXT)
$include(:I:ISSPEC.EXT)
$include(:I:ISRDMV.EXT)
$include(:I:ISWRMV.EXT)
$include(:I:ISCLOS.EXT)
$include(:I:ISDLCN.EXT)
$include(:I:ISDLFL.EXT)
$include(:I:IGTTIM.EXT)
$include(:I:NSTEXH.EXT)
$include(:I:NRCUNI.EXT)
$include(:I:NCRSEM.EXT)
declare
/* CONSTANTS */
/* Useful text substitutions */
boolean literally 'byte', /* define a new type */
TRUE literally '0FFh', /* and constants */
FALSE literally '000h', /* of that type */
/* ASCII control character constants */
CTRL$C literally '03h', /* CTRL/C */
HT literally '09h', /* horizontal tab */
LF literally '0Ah', /* line-feed */
CR literally '0Dh', /* carriage-return */
/* String constants */
remote$name(*) byte data( 12, ':KERMITPORT:' ),
console$name(*) byte data( 4, ':CO:' ),
file$list$name(*) byte data( 20, ':WORK:KERMITFLST.TMP' ),
/* GET$CONSOLE$CHAR and GET$REMOTE$CHAR return codes */
TIMEOUT literally '0FFFFh', /* Time limit expired */
CTRL$C$CODE literally '08003h', /* CTRL/C abort */
/* READ$CHAR return code */
EOF$CODE literally '0FF00h', /* end-of-file */
/* GLOBAL VARIABLES */
/* Tokens (what the system uses to identify objects) */
cur$file token public, /* Connection to the current file */
comm$conn token, /* token for our command connection */
file$list token, /* Connection to the file containg a filename list */
console$tok token, /* Connection to the console */
remote$tok token, /* Connection to the remote port */
cc$sema4 token, /* Semaphore to signal when CTRL/C pressed */
/* Buffers */
in$buff structure( /* Buffer for input from remote */
next byte, /* next char to be read from buffer */
len byte, /* number of chars in the buffer */
ch(256) byte) initial( 0, 0 ),
com$line structure( /* The buffer for the command line */
len byte,
ch(80) byte) public;
/* External procedures defined in KERMIT$UTIL */
get$filespec: procedure( keyword$num, info$ptr ) external;
declare
keyword$num byte,
info$ptr pointer;
end get$filespec;
upcase: procedure( x ) byte external;
declare
x byte;
end upcase;
/*
*
* System-dependent utility procedures used by Kermit.
*
*/
print: procedure( string$ptr ) public;
/*
* Print the string pointed to by STRING$PTR on the console.
* A string consists of a length byte followed by the specified
* number of characters (bytes).
*/
declare
string$ptr pointer,
status word;
call rq$c$send$co$response( 0, 0, string$ptr, @status );
end print;
new$line: procedure public;
/*
* Get the cursor to a new line on the console (i.e. print CR/LF).
*/
call print( @( 2,CR,LF ) );
end new$line;
print$char: procedure( char ) public;
/*
* Print the character CHAR on the console.
*/
declare
char byte,
string structure(
len byte,
ch byte);
/* Form a one-character string and then print it */
string.ch = char;
string.len = 1;
call print( @string );
end print$char;
exit$program: procedure public;
/*
* Exit from the program, i.e. return to the operating system.
* This procedure does not return to the calling routine.
*/
declare
status word;
call new$line; /* make sure the cursor's on a new line */
call rq$exit$io$job( 0, 0, @status );
end exit$program;
disp$excep: procedure( excep$code );
/*
* Display the exception code and associated mnemonic (error
* message) on the console. (Does not include any CRLFs.)
*/
declare
( excep$code, status ) word,
string$buffer structure(
len byte,
ch(40) byte);
string$buffer.len = 0; /* Init to null string */
/* Get the exception code and mnemonic */
call rq$c$format$exception( @string$buffer, size(string$buffer),
excep$code, 1, @status );
call print( @string$buffer ); /* Display the exception message */
end disp$excep;
check$status: procedure( status );
/*
* Check the exception code returned by a system call to the
* variable STATUS. If it is not E$OK, display the exception code
* and mnemonic at the console and abort the program.
*/
declare
status word;
if ( status <> E$OK ) then
do; /* Handle an exceptional condition */
call new$line; /* Make sure we're at the start of a line */
call disp$excep( status ); /* Display the error message */
call print( @( 18,', program aborted.' ) ); /* And what we're doing */
call new$line;
/* And abort the program. */
call exit$program;
end; /* if ( status <> E$OK ) */
end check$status;
disable$exception$handler: procedure;
/*
* Disable the default exception handler, to prevent it from gaining
* control and aborting the program as soon as any exception occurs.
*/
declare
status word,
exception$handler$info structure(
offset word,
base word,
mode byte);
exception$handler$info.offset = 0;
exception$handler$info.base = 0;
exception$handler$info.mode = 0; /* Never pass control to EH */
call rq$set$exception$handler( @exception$handler$info, @status );
call check$status( status );
end disable$exception$handler;
setup$terminals: procedure;
/*
* Set up both terminal lines used by the program--the line to
* the remote computer and our local console--by getting
* connections to them, opening them in read/write mode,
* and setting their terminal characteristics to no echo and
* transparent/polling (no line editing) modes.
* Initializes the globals REMOTE$TOK and CONSOLE$TOK.
*/
declare
status word,
terminal$data structure(
number$param word,
number$used word,
connection$flags word,
terminal$flags word,
in$baud$rate word,
out$baud$rate word,
scroll$lines word);
/* Get both connections */
remote$tok = rq$s$attach$file( @remote$name, @status );
if ( status = E$LOG$NAME$NEXIST ) then
do; /* Give a more helpful error message */
call print( @( 32,'Terminal line to remote computer' ) );
call print( @( 21,' must be attached as ' ) );
call print( @remote$name );
call new$line;
/* And abort the program */
call exit$program;
end; /* if ( status = E$LOG$NAME$NEXIST ) */
else
call check$status( status );
console$tok = rq$s$attach$file( @console$name, @status );
call check$status( status );
/* Open both for both reading and writing */
/* Specify zero buffers for interactive use */
call rq$s$open( remote$tok, 3, 0, @status );
call check$status( status );
call rq$s$open( console$tok, 3, 0, @status );
call check$status( status );
/* Get current remote terminal characteristics */
terminal$data.number$param = 5;
terminal$data.number$used = 1;
call rq$s$special( remote$tok, 4, @terminal$data, 0, @status );
call check$status( status );
/* Set to transparent/polling mode and no echo */
terminal$data.connection$flags =
( terminal$data.connection$flags OR 0007h );
terminal$data.number$param = 5;
terminal$data.number$used = 1;
call rq$s$special( remote$tok, 5, @terminal$data, 0, @status );
call check$status( status );
/* Get current console characteristics */
terminal$data.number$param = 5;
terminal$data.number$used = 1;
call rq$s$special( console$tok, 4, @terminal$data, 0, @status );
call check$status( status );
/* Set to transparent/polling mode and no echo */
terminal$data.connection$flags =
( terminal$data.connection$flags OR 0007h );
terminal$data.number$param = 5;
terminal$data.number$used = 1;
call rq$s$special( console$tok, 5, @terminal$data, 0, @status );
call check$status( status );
end setup$terminals;
retrap$control$c: procedure;
/*
* Prevent a CTRL/C typed on the console from interrupting
* the program, after TRAP$CONTROL$C has been called once.
* This is needed because each call to C$SEND$COMMAND re-enables
* the system's CTRL/C trap, so this must be called to re-enable
* ours.
*/
declare
status word,
signal$pair structure(
semaphore token,
character byte);
/* Associate CTRL/C from the console with our semaphore */
signal$pair.semaphore = cc$sema4;
signal$pair.character = CTRL$C;
call rq$s$special( console$tok, 6, @signal$pair, 0, @status );
call check$status( status );
end retrap$control$c;
trap$control$c: procedure;
/*
* Prevent a CTRL/C typed on the console from interrupting
* the program, and instead allow us to test for whether CTRL/C
* has been pressed by calling the function CONTROL$C$FLAG (defined
* below). Initializes the global CC$SEMA4. (SETUP$TERMINALS must
* have previously been called to get a connection to the console
* into the global CONSOLE$TOK.)
*/
declare
status word;
/* Create a semaphore to receive a unit when a CTRL/C is pressed */
cc$sema4 = rq$create$semaphore( 0, 1, 0, @status );
call check$status( status );
/* And assign CTRL/C to our semaphore */
call retrap$control$c;
end trap$control$c;
control$c$flag: procedure boolean;
/*
* Return TRUE if CTRL/C has been pressed on the console,
* FALSE otherwise. (TRAP$CONTROL$C must previously have been
* called.) If it returns TRUE, it will return FALSE on succeeding
* calls unless CTRL/C was pressed again.
*/
declare
( units$left, status ) word;
/* Check for a unit at the semaphore (don't wait for one) */
units$left = rq$receive$units( cc$sema4, 0, 0, @status );
call check$status( status );
if ( units$left = 0 ) then /* there wasn't one */
return( FALSE ); /* so signal no CTRL/C */
else /* there was one */
do;
/* Take that unit from the semaphore (so it won't be seen again) */
units$left = rq$receive$units( cc$sema4, 1, 0, @status );
call check$status( status );
return( TRUE ); /* And signal that we got a CTRL/C */
end; /* else */
end control$c$flag;
setup: procedure public;
/*
* This procedure does the system-dependent setup
* which must be done when the Kermit program
* is first started.
*/
declare
status word;
call disable$exception$handler;
call setup$terminals;
call trap$control$c;
/* Create a command connection, using the console for :CI: and :CO: */
comm$conn = rq$c$create$command$connection( console$tok, console$tok,
0, @status );
call check$status( status );
end setup;
read$char: procedure( source ) word public;
/*
* Return the next character from the file (or device) specified
* by SOURCE (which must be a connection open for reading).
* Returns the constant EOF$CODE (which cannot be a character
* because it is larger than 0FFh) if the file pointer is
* at end-of-file.
*/
declare
source token,
( bytes$read, status ) word,
ch byte;
if ( source = remote$tok) then
do; /* do buffered input from remote */
if ( in$buff.next >= in$buff.len ) then
do; /* re-fill the buffer */
bytes$read = rq$s$read$move( source, @in$buff.ch, 256, @status );
call check$status( status );
in$buff.next = 0; /* reset the pointers */
in$buff.len = bytes$read;
if ( in$buff.len = 0 ) then /* there's no more to be read */
return( EOF$CODE ); /* so signal end-of-file */
end; /* if ... */
ch = in$buff.ch( in$buff.next ); /* get next char from the buffer */
in$buff.next = in$buff.next + 1; /* update the pointer */
return( ch ); /* and return the character */
end; /* if ... */
else
do; /* Read the next byte from the file */
bytes$read = rq$s$read$move( source, @ch, 1, @status );
call check$status( status );
if ( bytes$read = 0 ) then /* we ran into end-of-file */
return( EOF$CODE ); /* so signal that */
else /* we got a character */
return( ch ); /* so return it */
end; /* else */
end read$char;
get$next$file$name: procedure( info$ptr ) public;
/*
* Place the name of the next file to be sent into the buffer
* pointed to by INFO$PTR. This assumes that GET$FIRST$FILE$NAME
* has previously been called. When there are no more filenames,
* the buffer receives a null string (length zero).
*/
declare
info$ptr pointer,
ch word,
info based info$ptr structure(
len byte,
ch(1) byte);
info.len = 0; /* init to null string */
ch = read$char( file$list ); /* read the first character */
/* Read characters from the file-list file up to return or EOF */
do while ( ( ch <> CR ) and ( ch <> EOF$CODE ) );
info.ch( info.len ) = ch; /* store previous char */
info.len = ( info.len + 1 ); /* update length */
ch = read$char( file$list ); /* get next char */
end; /* do while ( ( ch <> CR ) and ( ch <> EOF$CODE ) ) */
if ( ch = CR ) then /* we got a return */
ch = read$char( file$list ); /* discard the line-feed too */
end get$next$file$name;
get$first$file$name: procedure( keyword$num, info$ptr ) public;
/*
* Get the first filename matching the filespec in keyword number
* KEYWORD$NUM into the buffer pointed to by INFO$PTR. This routine
* also does the setup necessary for handling wild-card file names so
* that GET$NEXT$FILE$NAME can return the subsequent matching file
* names. Returns a null string to the buffer if the name cannot
* be parsed (e.g. contains wildcards which don't match any files).
*/
declare
keyword$num byte,
info$ptr pointer,
( status, com$status ) word,
info based info$ptr structure(
len byte,
ch(1) byte);
/* Get the filespec (possibly with wildcards) into the INFO buffer */
call get$filespec( keyword$num, info$ptr );
/* Send the ITEMIZE command to list the matching filenames */
call rq$c$send$command( comm$conn, @( 9,'ITEMIZE &' ), @com$status,
@status );
if ( status <> E$CONTINUED ) then /* should be continued */
call check$status( status );
/* Append an ampersand to the filespec */
info.ch( info.len ) = '&';
info.len = ( info.len + 1 );
/* And concatenate it to the ITEMIZE command */
call rq$c$send$command( comm$conn, @info, @com$status, @status );
if ( status <> E$CONTINUED ) then /* should still be continued */
call check$status( status );
/* Form the rest of the command in the INFO buffer */
call movb( @( ' OVER ' ), @info.ch( 0 ), 6 ); /* the preposition */
/* and the output filename */
call movb( @file$list$name( 1 ), @info.ch( 6 ), file$list$name( 0 ) );
info.len = ( file$list$name( 0 ) + 8 ); /* store length */
info.ch( info.len - 2 ) = CR;
info.ch( info.len - 1 ) = LF;
/* Send the rest of the command and exectue it */
call rq$c$send$command( comm$conn, @info, @com$status, @status );
call check$status( status );
call retrap$control$c;
if ( com$status = E$OK ) then /* it executed O.K. */
do;
/* Get a connection to the file produced */
file$list = rq$c$get$input$connection( @file$list$name, @status );
call check$status( status );
call get$next$file$name( @info ); /* and get the first filename */
end; /* if ( com$status = E$OK ) */
else /* A problem with the ITEMIZE command */
info.len = 0; /* Return null-string as the file-name */
end get$first$file$name;
finish$send: procedure public;
/*
* Clean up after the ITEMIZE command.
*/
declare
status word;
/* Delete the file connection, if possible */
call rq$s$delete$connection( file$list, @status );
/* And delete the temporary file itself, if possible */
call rq$s$delete$file( @file$list$name, @status );
/* STATUS is ignored because the file may not */
/* have been successfully created */
end finish$send;
prepare$file$name: procedure( info$ptr ) public;
/*
* Prepare the filename in the buffer pointed to by INFO$PTR for
* sending to the other Kermit--i.e. remove directory and/or device
* names, leaving only the filename itself in the buffer.
*/
declare
info$ptr pointer,
( i, ch ) byte,
info based info$ptr structure(
len byte,
ch(1) byte);
i = info.len; /* Start at the end of the pathname */
ch = info.ch( i - 1 ); /* Get last character */
do while ( ( ch <> '/' ) and ( ch <> '^' ) and ( ch <> ':' )
and ( i > 0 ) ); /* while we're still in the filename */
i = ( i - 1 ); /* scan backwards to the start of actual filename */
ch = info.ch( i - 1 ); /* get current character */
end; /* do while ... */
if ( i > 0 ) then /* there's a logical or directory name to be trimmed */
do;
/* move the actual filename to the beginning of the buffer */
call movb( @info.ch( i ), @info.ch( 0 ), ( info.len - i ) );
info.len = ( info.len - i ); /* and update length */
end; /* if ( i > 0 ) */
end prepare$file$name;
open$file: procedure( name$ptr ) boolean public;
/*
* Open the file specified in the string (length byte followed
* by the characters of the name) pointed to by NAME$PTR, which is
* assumed to already exist, for reading. Sets the global CUR$FILE.
* Returns TRUE if the open was successful, otherwise it prints
* an error message on the console describing the problem
* encountered and returns FALSE.
*/
declare
status word,
name$ptr pointer;
/* Get a connection to the file */
cur$file = rq$s$attach$file( name$ptr, @status );
if ( status = E$OK ) then /* we got a connection */
/* so open it, for reading only, with two buffers */
call rq$s$open( cur$file, 1, 2, @status );
if ( status = E$OK ) then /* we successfully opened the file */
return( TRUE ); /* indicate success */
else /* we encountered a problem */
do; /* Display an error message */
call print( @( 17,'Can''t open file "' ) );
call print( name$ptr );
call print( @( 3,'"; ' ) );
if ( status = E$FACCESS ) then
call print( @( 20,'read access required' ) );
else if ( status = E$FNEXIST ) then
call print( @( 19,'file does not exist' ) );
else if ( status = E$FTYPE ) then
call print( @( 32,'can''t use data file as directory' ) );
else
call disp$excep( status );
return( FALSE ); /* and indicate failure */
end;
end open$file;
create$file: procedure( name$ptr ) boolean public;
/*
* Create the file specified in the string (length byte followed
* by the characters of the name pointed to by NAME$PTR and open
* it for writing. If it already exists the user will be asked
* whether to overwrite it. If the operation is successful the
* global CUR$FILE is set and TRUE is returned, otherwise an
* error message is displayed at the console and FALSE is returned.
*/
declare
status word,
answer byte,
name$ptr pointer;
/* First, check whether the file already exists */
cur$file = rq$s$attach$file( name$ptr, @status );
if ( status = E$OK ) then /* the file does already exist */
do;
/* First, delete the connection we didn't really want */
call rq$s$delete$connection( cur$file, @status );
call check$status( status );
/* Now, ask the user whether to overwrite the file */
call print( @( 6,'File "' ) );
call print( name$ptr );
call print( @( 37,'" already exists; overwrite it <no>? ' ) );
answer = get$console$char( 0FFFFh ); /* wait for an answer */
call print$char( answer ); /* show them what they typed */
call new$line; /* and that the question is finished */
if ( upcase( answer ) = 'Y' ) then
status = E$FNEXIST; /* act as if the file didn't exist */
else /* they don't want to overwrite it */
return( FALSE ); /* indicate failure, with no error message */
end;
if ( status = E$FNEXIST ) then /* it's O.K. to go ahead and create it */
do;
cur$file = rq$s$create$file( name$ptr, @status );
if ( status = E$OK ) then /* we created the file O.K. */
/* so open it, for writing only, with two buffers */
call rq$s$open( cur$file, 2, 2, @status );
end;
if ( status = E$OK ) then /* we successfully created the file */
return( TRUE ); /* indicate success */
else /* we encountered a problem */
do; /* Display an error message */
call print( @( 19,'Can''t create file "' ) );
call print( name$ptr );
call print( @( 3,'"; ' ) );
if ( status = E$FACCESS ) then
call print( @( 21,'write access required' ) );
else if ( status = E$FNEXIST ) then
call print( @( 19,'file does not exist' ) );
else if ( status = E$FTYPE ) then
call print( @( 32,'can''t use data file as directory' ) );
else
call disp$excep( status );
return( FALSE ); /* and indicate failure */
end;
end create$file;
close$file: procedure public;
/*
* Close the file specified by the connection in the global
* token CUR$FILE.
*/
declare
status word;
call rq$s$close( cur$file, @status ); /* close the file */
call check$status( status );
/* and delete the connection */
call rq$s$delete$connection( cur$file, @status );
call check$status( status );
end close$file;
get$char: procedure( source, time$limit ) word;
/*
* Return the next character from the terminal line (connection)
* indicated by SOURCE, waiting until a character arrives or
* TIME$LIMIT seconds have elapsed; if the time limit expires
* with no character having been received, return the constant
* TIMEOUT (which cannot be a character because it is larger than
* 0FFh). If CTRL/C is pressed on the console, it will immediately
* return the constant CTRL$C$CODE (which also cannot be a character).
* If TIME$LIMIT is zero, will return immediately, with a character
* if one was waiting (or CTRL$C$CODE), otherwise with TIMEOUT. If
* TIME$LIMIT = 0FFFFh it is taken to be infinite, i.e. it will
* never time out.
*/
declare
source token,
( time$limit, ch, status ) word,
( start$time, time$now ) dword,
timed$out boolean;
/* Store the time at which we started waiting */
start$time = rq$get$time( @status );
call check$status( status );
ch = EOF$CODE; /* we haven't gotten anything yet */
timed$out = FALSE; /* Ensure that we go through the loop at least once */
/* Loop until we time out or get a character */
do while ( ( not timed$out ) and ( ch = EOF$CODE ) );
/* Check for a control-C interrupt from the console */
if ( control$c$flag ) then /* We got one */
ch = CTRL$C$CODE; /* so return the "character" CTRL$C$CODE */
else /* no control-C */
ch = read$char( source ); /* look for a normal character */
if ( ch = EOF$CODE ) then /* if we didn't get anything */
do; /* check on the time limit */
if ( time$limit = 0 ) then /* if they don't want to wait */
timed$out = TRUE; /* time out immediately */
/* if they gave a finite time limit */
else if ( time$limit < 0FFFFh ) then
do; /* check whether we've run out of time yet */
/* Get the time now */
time$now = rq$get$time( @status );
call check$status( status );
/* If the elapsed time is greater than the limit */
if ( ( time$now - start$time ) > time$limit ) then
timed$out = TRUE; /* we ran out of time, stop waiting */
end; /* if ( time$limit < 0FFFFh ) */
/* If TIME$LIMIT is infinite (0FFFFh), TIMED$OUT stays FALSE */
end; /* if ( ch = EOF$CODE ) */
end; /* do while ( ( not timed$out ) and ( ch = EOF$CODE ) ) */
if ( timed$out ) then /* we ran out of time */
return( TIMEOUT ); /* so return that information */
else /* we got a character (or control-C) */
return( ch ); /* so return that */
end get$char;
get$console$char: procedure( time$limit ) word public;
declare
time$limit word;
return( get$char( console$tok, time$limit ) );
end get$console$char;
get$remote$char: procedure( time$limit ) word public;
declare
time$limit word;
return( get$char( remote$tok, time$limit ) );
end get$remote$char;
put$char: procedure( destination, ch ) public;
/*
* Put the character CH out to the file or terminal line
* specified by DESTINATION (which must be a connection
* open for writing).
*/
declare
destination token,
ch byte,
( bytes$written, status ) word;
bytes$written = rq$s$write$move( destination, @ch, 1, @status );
call check$status( status );
end put$char;
xmit$console$char: procedure( ch ) public;
/*
* Send character CH to the console.
*/
declare
ch byte;
call put$char( console$tok, ch );
end xmit$console$char;
xmit$remote$char: procedure( ch ) public;
/*
* Send character CH out to the remote port.
*/
declare
ch byte;
call put$char( remote$tok, ch );
end xmit$remote$char;
xmit$packet: procedure( packet$ptr, len ) public;
/*
* Send a whole packet, pointed to by PACKET$PTR and
* containing LEN characters, out to the remote port.
*/
declare
packet$ptr pointer,
( len, bytes$written, status ) word;
bytes$written = rq$s$write$move( remote$tok, packet$ptr, len, @status );
call check$status( status );
end xmit$packet;
flush$input$buffer: procedure public;
/*
* Flush (empty) the input ("type-ahead") buffer for the
* line on which we are connected to the other Kermit.
* Also clears any stored-up CTRL/C's from the console.
*/
do while ( read$char( remote$tok ) <> EOF$CODE );
/* Keep reading (and discarding) characters */
/* until there aren't any more */
end; /* do while ( read$char( remote$tok ) <> EOF$CODE ) */
do while ( control$c$flag = TRUE );
/* And the same with control-C's */
end; /* do while ( control$c$flag = TRUE ) */
end flush$input$buffer;
get$command$line: procedure( prompt$ptr ) public;
/*
* Display the string pointed to by PROMPT$PTR and get a command
* line from the console into the global buffer COM$LINE. This
* procedure also does some preliminary processing of the command line:
* All letters are converted to upper-case, tabs are converted to
* spaces, spaces which are redundant or at the beginning of the
* command line are removed, and line terminators are removed.
* Thus upon return the COM$LINE buffer should contain simply the
* keyword(s), separated by only one space each.
*/
declare
prompt$ptr pointer,
space$flag boolean, /* TRUE if a space here is significant */
( i, j ) byte, /* Indicies into the command line buffer */
status word;
/* Issue the prompt and get the command line into the buffer */
call rq$c$send$co$response( @com$line, size( com$line ),
prompt$ptr, @status );
call check$status( status );
if ( com$line.len = 0 ) then /* We got EOF (end-of-file, or ^Z) */
do; /* Treat the EOF like an EXIT command */
call print( @( 2,'^Z' ) ); /* Echo the ^Z */
call new$line; /* And echo a CRLF */
/* Put the EXIT command in the buffer */
call movb( @( 4,'EXIT' ), @com$line, 5 );
end; /* if ( com$line.len = 0 ) */
else /* We got a command line */
do; /* do the preliminary processing of the command line */
/* If the last character wasn't a line-feed */
if ( com$line.ch( com$line.len - 1 ) <> LF ) then
call new$line; /* Get the cursor onto a new line */
/* Add a CR at the end in case there isn't one */
com$line.ch( com$line.len ) = CR;
i, j = 0; /* init the pointers to the start of the buffer */
space$flag = FALSE; /* Initial spaces are meaningless */
/* Process the line until the CR */
do while ( com$line.ch( i ) <> CR );
if ( com$line.ch( i ) = HT ) then
com$line.ch( i ) = ' '; /* convert tabs to spaces */
/* If this is a significant character */
if ( space$flag or ( com$line.ch( i ) <> ' ' ) ) then
do; /* Process this character */
/* Store it (capitalized) in the resulting command line */
com$line.ch( j ) = upcase( com$line.ch( i ) );
j = j + 1; /* Increment the pointer to the result */
if ( com$line.ch( i ) = ' ' ) then /* if it's a space */
space$flag = FALSE; /* further spaces are redundant */
else /* it's not a space */
space$flag = TRUE; /* so a space after it is meaningful */
end; /* if ( space$flag or ( com$line.ch( i ) <> ' ' ) ) */
i = i + 1; /* Move to the next character of input */
end; /* do while ( com$line.ch( i ) <> CR ) */
com$line.len = j; /* Store the length of the result */
end; /* else -- we got a command line */
end get$command$line;
do$help: procedure( num$params ) public;
/*
* Perform the HELP command. This procedure passes the name
* of our help library and the number of parameters specified
* by NUM$PARAMS to the HELP program.
*/
declare
( num$params, i ) byte,
( com$status, status ) word,
buffer structure(
len byte,
ch(50) byte);
/* Get the name of the file containing this program */
call rq$c$get$command$name( @buffer, size( buffer ), @status );
call check$status( status );
/* Append the .HLP suffix to it, forming the name of the help library */
call movb( @( '.HLP &' ), @buffer.ch( buffer.len ), 6 );
buffer.len = ( buffer.len + 6 );
/* Send the HELP command, with @ to signal library name comes next */
call rq$c$send$command( comm$conn, @( 7,'HELP @&' ), @com$status,
@status );
if ( status <> E$CONTINUED ) then /* should be continued */
call check$status( status );
/* Add our help library name to it */
call rq$c$send$command( comm$conn, @buffer, @com$status, @status );
if ( status <> E$CONTINUED ) then /* should still be continued */
call check$status( status );
/* For each parameter which we have */
do i = 1 to num$params;
call get$filespec( i, @buffer ); /* get the parameter */
buffer.ch( buffer.len ) = ' ';
buffer.ch( buffer.len + 1 ) = '&'; /* add space and ampersand */
buffer.len = ( buffer.len + 2 );
/* Append the parameter to the HELP command line */
call rq$c$send$command( comm$conn, @buffer, @com$status, @status );
if ( status <> E$CONTINUED ) then /* should still be continued */
call check$status( status );
end; /* do i = 1 to num$params */
/* And finally execute the command */
call rq$c$send$command( comm$conn, @( 2,CR,LF ), @com$status, @status );
call check$status( status );
call retrap$control$c;
end do$help;
end kermit$sys;