home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
intel86.tar.gz
/
intel86.tar
/
kerutil.p86
< prev
Wrap
Text File
|
1986-06-06
|
39KB
|
1,231 lines
$large
Kermit$util: do;
/*
* K e r m i t File Transfer Utility
*
* iRMX-86 Kermit, Version 2.3
* by Albert J. Goodman, Grinnell College
*
* General Kermit utilities module.
* Edit date: 2-June-1985
*/
/* Define the system type TOKEN */
$include(:I:LTKSEL.LIT)
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 */
NUL literally '00h', /* null */
SOH literally '01h', /* start-of-header */
CTRL$C literally '03h', /* CTRL/C */
BEL literally '07h', /* bell (beep) */
BS literally '08h', /* backspace */
HT literally '09h', /* horizontal tab */
LF literally '0Ah', /* line-feed */
CR literally '0Dh', /* carriage-return */
CTRL$R$BRAK literally '1Dh', /* CTRL/] */
DEL literally '7Fh', /* delete (rubout) */
/* Defaults for various Kermit parameters */
def$packet$len literally '80',
def$time$limit literally '10',
def$num$pad literally '0',
def$pad$char literally 'NUL',
def$eol literally 'CR',
def$quote literally '''#''',
/* GET$REMOTE$CHAR return codes (see KERMIT$SYS) */
TIMEOUT literally '0FFFFh', /* Time limit expired */
CTRL$C$CODE literally '08003h', /* CTRL/C abort */
/* READ$CHAR return code (see KERMIT$SYS) */
EOF$CODE literally '0FF00h', /* end-of-file */
/* Other constants */
MAX$PACKET$LEN literally '94',
MAX$KEYWORDS literally '5',
/* String constant (for PRINT$SPACES) */
spaces$string(*) byte data( 15, ' ' ),
/* GLOBAL VARIABLES */
/* Token (defined in KERMIT$SYS) */
cur$file token external, /* Connection to the current file */
/* Kermit parameters (defined in main module) */
debug boolean external, /* Whether we're debugging the program */
max$retry byte external, /* Maximum number of times to retry a packet */
packet$len byte external, /* The maximum length packet to send */
time$limit byte external, /* Seconds to time out if nothing received */
num$pad byte external, /* The number of padding characters to send */
pad$char byte external, /* The padding character to send */
eol byte external, /* The EOL (end-of-line) character to send */
quote byte external, /* The control-quote character to be used */
/* Other Kermit variables (defined in main module) */
state byte external, /* Current state */
seq byte external, /* The current sequence number (0 to 63) */
tries byte external, /* Number of times current packet retried */
/* Buffers */
com$line structure( /* The buffer for the command line */
len byte,
ch(80) byte) external, /* defined in KERMIT$SYS */
/* Comand parsing information */
num$keywords byte public, /* Number of keywords in KEYWORD array */
keyword(MAX$KEYWORDS) structure( /* the keywords in COM$LINE */
index byte, /* starting index */
len byte); /* length without spaces */
/* External procedures defined in KERMIT$SYS */
get$remote$char: procedure( time$limit ) word external;
declare
time$limit word;
end get$remote$char;
xmit$remote$char: procedure( ch ) external;
declare
ch byte;
end xmit$remote$char;
print: procedure( string$ptr ) external;
declare
string$ptr pointer;
end print;
new$line: procedure external;
end new$line;
print$char: procedure( ch ) external;
declare
ch byte;
end print$char;
read$char: procedure( file ) word external;
declare
file token;
end read$char;
write$char: procedure( file, ch ) external;
declare
file token,
ch byte;
end write$char;
/*
*
* General Kermit utility functions
*
*/
char: procedure( x ) byte;
/*
* Transform an integer in the range 0 to 94 (decimal)
* into a printable ASCII character.
*/
declare
x byte;
return( x + ' ' );
end char;
unchar: procedure( x ) byte;
/*
* Reverse the CHAR transformation.
*/
declare
x byte;
return( x - ' ' );
end unchar;
ctl: procedure( x ) byte;
/*
* Transform a control character into its printable representation,
* and vice-versa. I.e. CTRL/A becomes A, and A becomes CTRL/A.
*/
declare
x byte;
return( x XOR 40h );
end ctl;
upcase: procedure( x ) byte public;
/*
* Force an ASCII letter to upper-case;
* a non-letter is returned unchanged.
*/
declare
x byte;
if ( ( x >= 'a' ) and ( x <= 'z' ) ) then /* it was lower-case */
return( x - 'a' + 'A' ); /* return the upper-case equivalent */
else /* it was anything else */
return( x ); /* just return it unchanged */
end upcase;
low7: procedure( x ) byte;
/*
* Return the low-order seven bits of a character,
* i.e. set the eighth bit to zero, stripping the parity bit.
*/
declare
x byte;
return( x AND 07Fh );
end low7;
not$printable: procedure( x ) boolean;
/*
* Determine whether an ASCII character is a printable character
* or not; return TRUE if it is a control character, FALSE if it's
* printable. Assumes the high-order (parity) bit is not set.
*/
declare
x byte;
return( ( x < ' ' ) or ( x = DEL ) );
end not$printable;
special$char: procedure( x ) boolean;
/*
* Returns TRUE if X is a quoting or prefix
* character currently being used (i.e. if
* it needs to be quoted itself). Assumes
* the high-order (parity) bit is not set.
*/
declare
x byte;
/* Only the control-quote is implemented so far */
return( x = quote );
end special$char;
next$seq: procedure( seq$num ) byte public;
/*
* Return the next sequence number after SEQ$NUM; that is,
* SEQ$NUM + 1 modulo 64.
*/
declare
seq$num byte;
return( ( seq$num + 1 ) AND 03Fh );
end next$seq;
previous$seq: procedure( seq$num ) byte public;
/*
* Return the previous sequence number to SEQ$NUM.
*/
declare
seq$num byte;
if ( seq$num = 0 ) then
return( 63 );
else
return( seq$num - 1 );
end previous$seq;
/*
*
* Output display procedures
*
*/
show$char: procedure( ch ) public;
/*
* Display a character on the console in readable form,
* even if it is a control character. It is assumed
* that the high-order bit is not set.
*/
declare
ch byte;
if ( not$printable( ch ) ) then
do; /* Display the character in a readable form */
if ( ch = DEL ) then /* Display DEL specially */
call print( @( 5, '<DEL>' ) );
else
do; /* display an ordinary control character */
call print( @( 6,'<Ctrl-' ) );
call print$char( ctl( ch ) );
call print$char( '>' );
end; /* else */
end; /* if ( not$printable( ch ) ) */
else /* It's printable, so just display it */
call print$char( ch );
end show$char;
show$dec$num: procedure( num ) public;
/*
* Display the value of a number in decimal on the console.
*/
declare
( num, digit, i ) word,
string structure(
len byte,
ch(5) byte);
i = 5; /* Start at the last (least-significant) digit */
do while ( num > 0 ); /* As long as there are more digits */
digit = num mod 10; /* Get the current least-significant digit */
num = ( num - digit ) / 10; /* Remove it from the number */
i = i - 1; /* Back up one place */
string.ch(i) = digit + '0'; /* Convert the digit to ASCII */
end; /* do while */
string.len = 5 - i; /* Find the length of the number */
if ( string.len = 0 ) then
do; /* Display zero as 0, not a null string */
string.ch(0) = '0';
string.len = 1;
end; /* if ... */
else if ( i > 0 ) then /* If we didn't use all five spaces, */
/* Move the number down to the start of the buffer */
call movb( @string.ch(i), @string.ch(0), string.len );
call print( @string ); /* display the number */
end show$dec$num;
show$flag: procedure( flag ) public;
/*
* Display the value of a boolean flag on the console:
* If the flag is TRUE, display ON, if the flag is FALSE,
* display OFF.
*/
declare
flag boolean;
if ( flag ) then
call print( @( 2,'ON' ) );
else
call print( @( 3,'OFF' ) );
end show$flag;
print$spaces: procedure( num );
/*
* Print NUM spaces on the console.
*/
declare
num byte,
len byte at( @spaces$string );
len = num; /* set length to be printed this time--must not be > 15 */
call print( @spaces$string ); /* print them */
end print$spaces;
/*
*
* Kermit protocol communication routines
*
*/
send$char: procedure( ch );
/*
* Send the character CH to the other Kermit.
*/
declare
ch byte;
call xmit$remote$char( ch ); /* send it on the remote line */
end send$char;
send$packet: procedure( type, num, info$ptr ) public;
/*
* Send a packet to the remote Kermit. TYPE is the character
* for the packet type, NUM is the packet number to be used,
* and INFO$PTR points to a string (length byte followed by
* data bytes) containing the contents of the packet to be sent,
* with all control-quoting or other processing already done.
* INFO$PTR may be zero in which case an "emtpy" packet is sent.
* The length field is assumed to be at least five less than
* PACKET$LEN (the maximum length packet to send, i.e. the other
* Kermit's buffer size)--this is not checked here.
*/
declare
( type, num, i, checksum ) byte,
info$ptr pointer,
info based info$ptr structure(
len byte,
ch(1) byte);
send$packet$char: procedure( ch );
/*
* Send one character of a packet (other than the SOH or
* checksum) by adding it to the checksum and then actually
* sending it.
*/
declare
ch byte;
checksum = ( checksum + ch ); /* Accumulate checksum */
call send$char( ch ); /* send the char */
end send$packet$char;
/* begin SEND$PACKET */
if ( debug ) then
do;
call print( @( 20,'Send-packet: num = ' ) );
call show$dec$num( num );
call print( @( 9,'; type = ' ) );
call show$char( type );
call print( @( 10,'; data = "' ) );
if ( info$ptr <> 0 ) then
call print( info$ptr );
call print$char( '"' );
call new$line;
end;
do i = 1 to num$pad; /* Send any padding requested */
call send$char( pad$char );
end; /* do i = 1 to num$pad */
call send$char( SOH ); /* Send the synchronization character */
checksum = 0; /* Initialize the checksum */
if ( info$ptr = 0 ) then /* no info to be sent */
call send$packet$char( char( 3 ) ); /* so length is three */
else /* send packet length */
call send$packet$char( char( info.len + 3 ) );
call send$packet$char( char( num ) ); /* send packet number */
call send$packet$char( type ); /* send packet type */
if ( info$ptr <> 0 ) then /* they gave us an info string */
if ( info.len > 0 ) then /* there is some data to be sent */
do i = 0 to ( info.len - 1 ); /* for each character of data */
call send$packet$char( info.ch( i ) ); /* send it */
end; /* do i = 0 to ( info.len - 1 ) */
/* Now compute the final checksum by folding the high bits in */
checksum = ( ( checksum + shr( checksum, 6 ) ) AND 03Fh );
call send$char( char( checksum ) ); /* and send the checksum */
/* The packet itself has now been sent */
call send$char( eol ); /* now send the EOL character */
end send$packet;
receive$char: procedure( time$limit ) word;
/*
* Receive a character from the other Kermit, timing out
* after TIME$LIMIT seconds. Returns the same special
* codes as GET$REMOTE$CHAR.
*/
declare
( time$limit, ch ) word;
ch = get$remote$char( time$limit ); /* receive from remote port */
if ( ch < 0100h ) then /* we got a real character, not a special code */
ch = low7( ch ); /* so strip the 8th bit in case it's parity */
return( ch ); /* and return what we received */
end receive$char;
receive$packet: procedure( num$ptr, info$ptr ) byte public;
/*
* Receive a packet from the remote Kermit. NUM$PTR points
* to a byte which receives the sequence number of the incoming
* packet, INFO$PTR points to a string which receives the
* data field of the incoming packet, and the function returns
* the type character of the incoming packet. If no character
* is received for TIME$LIMIT seconds at any point in the process,
* the receive operation will be abandoned and zero will be returned.
* (TIME$LIMIT is a global used here.)
* Zero will also be returned if a packet with a bad checksum is
* received. If CTRL/C is pressed on the console the receive
* will be aborted and 0FFh will be returned. (Note that if a
* character with ASCII value 0 or 0FFh is received during a packet,
* that code will be returned; however this does not apply outside
* the packet, and if a NUL or character 0FFh is received during a
* packet that indicates an error anyway.)
*/
declare
( num$ptr, info$ptr ) pointer,
num based num$ptr byte,
( checksum, type, i ) byte,
ch word,
info based info$ptr structure(
len byte,
ch(1) byte);
get$packet$char: procedure byte;
/*
* Return the next character of a packet and add it to the
* checksum. Returns zero or 0FFh as described above for
* RECEVIE$PACKET.
*/
declare
ch word;
ch = receive$char( time$limit ); /* Get a char */
if ( ch = TIMEOUT ) then /* nothing received in time */
return( 0 );
else if ( ch = CTRL$C$CODE ) then /* CTRL/C abort */
return( 0FFh );
else /* got a character */
do;
checksum = ( checksum + ch ); /* accumulate checksum */
return( ch ); /* and return the character */
end;
end get$packet$char;
/* begin RECEIVE$PACKET */
ch = receive$char( time$limit ); /* Get first character */
/* As long as we got characters, but not the synchronization mark */
do while ( ( ch <> TIMEOUT ) and ( ch <> CTRL$C$CODE ) and ( ch <> SOH ) );
ch = receive$char( time$limit ); /* keep getting them */
end; /* do while ... */
/* convert error conditions to our return codes */
if ( ch = TIMEOUT ) then
ch = 0;
else if ( ch = CTRL$C$CODE ) then
ch = 0FFh;
do while ( ch = SOH ); /* if we got SOH, get the packet which follows */
checksum = 0; /* initialize the checksum */
ch = get$packet$char; /* get what should be the count */
/* If we got a character, not SOH */
if ( ( ch <> 0 ) and ( ch <> 0FFh ) and ( ch <> SOH ) ) then
do;
info.len = ( unchar( ch ) - 3 ); /* store data length */
ch = get$packet$char; /* now try for the sequence number */
if ( ( ch <> 0 ) and ( ch <> 0FFh ) and ( ch <> SOH ) ) then
do;
num = unchar( ch ); /* store packet number */
ch = get$packet$char; /* now the type */
if ( ( ch <> 0 ) and ( ch <> 0FFh ) and ( ch <> SOH ) ) then
do;
type = ch; /* store packet type for later */
i = 0; /* init data index */
/* while we're still getting the data field */
do while ( ( ch <> 0 ) and ( ch <> 0FFh ) and
( ch <> SOH ) and ( i < info.len ) );
ch = get$packet$char; /* get next data char */
info.ch( i ) = ch; /* store data character */
i = ( i + 1 ); /* and bump data index */
end; /* do while ... */
if ( ( ch <> 0 ) and ( ch <> 0FFh ) and
( ch <> SOH ) ) then /* got data O.K. */
do;
/* Get the incoming checksum */
ch = receive$char( time$limit );
if ( ch = TIMEOUT ) then
ch = 0; /* signal no packet received */
else if ( ch = CTRL$C$CODE ) then
ch = 0FFh; /* signal CTRL/C abort */
else if ( ch <> SOH ) then /* got checksum */
do;
/* finish computing our checksum */
checksum = ( ( checksum + shr( checksum, 6 ) )
AND 03Fh );
/* if incoming checksum and ours disagree */
if ( checksum <> unchar( ch ) ) then
ch = 0; /* signal bad packet received */
else /* finally got good, complete, packet */
ch = type; /* so return its type */
end; /* else if ( ch <> SOH ) */
end; /* if ... */
end; /* if ... */
end; /* if ... */
end; /* if ... */
end; /* do while ( ch = SOH ) */
/* Finished with that packet */
/* We would now flush the input buffer if we were using one */
if ( debug ) then
do;
call print( @( 17,'Receive-packet: ' ) );
if ( ch = 0 ) then
call print( @( 19,'<bad/absent packet>' ) );
else if ( ch = 0FFh ) then
call print( @( 14,'<CTRL/C abort>' ) );
else
do;
call print( @( 6,'num = ' ) );
call show$dec$num( num );
call print( @( 9,'; type = ' ) );
call show$char( ch );
call print( @( 10,'; data = "' ) );
call print( info$ptr );
call print$char( '"' );
end;
call new$line;
end;
return( ch ); /* return packet type or error code (0 or 0FFh) */
end receive$packet;
send$kermit$params: procedure( info$ptr ) public;
/*
* This procedure places our current parameters into the
* buffer pointed to by INFO$PTR in the format required for
* a Send-init packet or the acknowledgement to one.
*/
declare
info$ptr pointer,
info based info$ptr structure(
len byte,
ch(1) byte);
info.len = 6;
info.ch( 0 ) = char( packet$len ); /* longest packet to send */
info.ch( 1 ) = char( time$limit ); /* number of seconds to time-out */
info.ch( 2 ) = char( num$pad ); /* number of padding chars */
info.ch( 3 ) = ctl( pad$char ); /* padding character */
info.ch( 4 ) = char( eol ); /* end-of-line character */
info.ch( 5 ) = quote; /* control-quote character */
end send$kermit$params;
get$kermit$params: procedure( info$ptr ) public;
/*
* This procedure sets our parameters based on the contents of
* the buffer pointed to by INFO$PTR which should contain the
* data field from a Send-init packet or the acknowledgement to one.
*/
declare
i byte,
info$ptr pointer,
info based info$ptr structure(
len byte,
ch(1) byte);
do i = info.len to 5; /* for each field they omitted which we use */
info.ch( i ) = ' '; /* make it a space, i.e. default it */
end; /* do i = info.len to 5 */
/* Set buffer size. */
if ( info.ch( 0 ) = ' ' ) then
packet$len = def$packet$len; /* use default */
else
packet$len = unchar( info.ch( 0 ) ); /* use what they sent */
/* Set time-out limit. */
if ( info.ch( 1 ) = ' ' ) then
time$limit = def$time$limit; /* use default */
else
time$limit = unchar( info.ch( 1 ) ); /* use theirs */
/* Set number of padding chars. */
if ( info.ch( 2 ) = ' ' ) then
num$pad = def$num$pad; /* use default */
else
num$pad = unchar( info.ch( 2 ) ); /* use theirs */
/* Set the padding character. */
if ( info.ch( 3 ) = ' ' ) then
pad$char = def$pad$char; /* use default */
else
pad$char = ctl( info.ch( 3 ) ); /* use theirs */
/* Set the end-of-line character. */
if ( info.ch( 4 ) = ' ' ) then
eol = def$eol; /* use default */
else
eol = unchar( info.ch( 4 ) ); /* use theirs */
/* Set the control-quote character. */
if ( info.ch( 5 ) = ' ' ) then
quote = def$quote; /* use default */
else
quote = info.ch( 5 ); /* use theirs */
end get$kermit$params;
read$packet$from$file: procedure( info$ptr ) public;
/*
* Fill the buffer pointed to by INFO$PTR with the next packet
* of the current file. This routine does the quoting/prefixing.
* If zero bytes are loaded into the buffer, then we ran into
* end-of-file.
*/
declare
info$ptr pointer,
i byte,
ch word,
info based info$ptr structure(
len byte,
ch(1) byte);
i, ch = 0;
/* While we have more characters from the file and the packet */
/* has room for another char (possibly with control quote) */
do while ( ( ch <> EOF$CODE ) and ( i < ( packet$len - 6 ) ) );
ch = read$char( cur$file ); /* get a char from the file */
if ( ch <> EOF$CODE ) then /* we got one */
do;
ch = low7( ch ); /* strip the 8th bit, just in case... */
/* If this character needs to be quoted */
if ( not$printable( ch ) or special$char( ch ) ) then
do;
info.ch( i ) = quote; /* Put control-quote in buffer */
i = ( i + 1 ); /* and update index */
if ( not$printable( ch ) ) then
ch = ctl( ch ); /* make control characters printable */
end; /* if ... -- needs to be quoted */
info.ch( i ) = ch; /* put character in buffer */
i = ( i + 1 ); /* and update index */
end; /* if ( ch <> EOF$CODE ) */
end; /* do while ... */
info.len = i; /* store length of what we put in buffer */
end read$packet$from$file;
write$packet$to$file: procedure( info$ptr ) public;
/*
* Write the contents of a received packet (in the buffer pointed
* to by INFO$PTR) out to the current file. This routine deals
* with quoting characters in the incoming data.
*/
declare
info$ptr pointer,
( x, i ) byte,
info based info$ptr structure(
len byte,
ch(1) byte);
i = 0; /* start at the beginning */
do while ( i < info.len ); /* while we have any more data */
x = info.ch( i ); /* get the current character */
if ( x = quote ) then /* it's the control-quote character */
do;
i = ( i + 1 ); /* go to the next (quoted) character */
x = info.ch( i ); /* and get it */
/* If it's not a quoting or prefix character */
if ( not special$char( x ) ) then /* it's a control char */
x = ctl( x ); /* so restore the actual character */
end; /* if ( x = quote ) */
call write$char( cur$file, x ); /* write char to file */
i = ( i + 1 ); /* now go to next char */
end; /* do while ( i < info.len ) */
end write$packet$to$file;
/*
*
* Error handling routines
*
*/
error$msg: procedure( msg$ptr ) public;
/*
* Send an error packet to the remote Kermit
* and display the error message on the console too.
*/
declare
msg$ptr pointer;
/* Send Error packet to the other Kermit */
call send$packet( 'E', seq, msg$ptr ); /* send Error packet */
seq = next$seq( seq ); /* and bump sequence number */
call print( msg$ptr ); /* print it on the console too */
end error$msg;
unknown$packet$type: procedure( type, packet$ptr ) public;
/*
* Deal with a received packet of an unexpected type.
*/
declare
type byte, /* type of the packet received */
packet$ptr pointer; /* points to contents of the packet */
if ( type = 'E' ) then /* it is an error packet */
do;
/* Display the error message we received from the remote Kermit */
call print( @( 20,'Remote Kermit error:' ) );
call new$line;
call print( packet$ptr );
call new$line;
end;
else /* an unknown packet type */
do;
/* Display an appropriate error message */
call print( @( 24,'Unexpected packet type (' ) );
call show$char( type );
call print( @( 11,') received.' ) );
end;
state = 'A'; /* In any case, abort the current operation */
end unknown$packet$type;
too$many$retries: procedure public;
/*
* Deal with the retry count reaching its limit.
*/
/* Display an error message */
call print( @( 17,'Too many retries.' ) );
state = 'A'; /* and abort the operation */
end too$many$retries;
wrong$number: procedure public;
/*
* Deal with a received packet with wrong sequence number.
*/
/* Display an error message */
call print( @( 27,'Unexpected packet sequence.' ) );
state = 'A'; /* and abort the operation */
end wrong$number;
/*
*
* Command parsing and display procedures
*
*/
parse$command: procedure public;
/*
* Parse the command line in the global buffer COM$LINE into
* keywords, separated by spaces. The keywords are stored
* in the global KEYWORD array, the count in NUM$KEYWORDS.
*/
declare
( i, j ) word;
num$keywords = 0; /* Initially we don't have any keywords yet */
i = 0; /* Start at the beginning of the command line */
/* Go until we get to the end or have the maximum number of keywords */
do while ( ( i < com$line.len ) and ( num$keywords < MAX$KEYWORDS ) );
keyword( num$keywords ).index = i; /* store start of this keyword */
/* Find the next space (end of this keyword) */
j = findb( @com$line.ch( i ), ' ', ( com$line.len - i ) );
if ( j = 0FFFFh ) then /* there isn't another space */
j = ( com$line.len - i ); /* this keyword is rest of the line */
keyword( num$keywords ).len = j; /* store its length */
num$keywords = ( num$keywords + 1 ); /* bump the keyword count */
i = ( i + j + 1 ); /* next keyword starts after the space */
end; /* do while ( i < com$line.len ) */
end parse$command;
parse$dec$num: procedure( keyword$num, num$ptr ) boolean public;
/*
* Parse a decimal number out of keyword number KEYWORD$NUM;
* i.e. interpret the string of characters that make up that
* keyword as a decimal number, and place its value into
* the word pointed to by NUM$PTR. It returns a value of
* TRUE if this was successful, FALSE if the keyword does not
* represent a number (e.g. contains letters).
*/
declare
( keyword$num, i ) byte,
num$ptr pointer,
num based num$ptr word,
( first, last, ch ) byte,
valid boolean;
num = 0; /* Init the number to zero */
valid = TRUE; /* Assume it's valid until proven otherwise */
first = keyword( keyword$num ).index; /* Get starting position */
last = first + keyword( keyword$num ).len - 1; /* and ending one */
do i = first to last; /* Step through each character in turn */
ch = com$line.ch( i ); /* Get current character */
if ( ( ch >= '0' ) and ( ch <= '9' ) ) then /* valid digit */
num = ( num * 10 ) + ( ch - '0' ); /* Accumulate value */
else /* not a decimal digit */
valid = FALSE; /* Flag that it's invalid--NUM is meaningless */
end; /* do i = first to last */
return( valid );
end parse$dec$num;
show$keyword: procedure( keyword$num );
/*
* Display keyword number KEYWORD$NUM (as parsed into the
* global array KEYWORD) on the console.
*/
declare
( keyword$num, first, last, i ) byte;
/* Get the location of the first character of the keyword */
first = keyword( keyword$num ).index;
/* and the location of the last character of the keyword */
last = first + keyword( keyword$num ).len - 1;
/* Display each character in turn */
do i = first to last;
call print$char( com$line.ch( i ) );
end; /* do i = first to last */
end show$keyword;
show$command: procedure( kp1, kp2, kp3 ) public;
/*
* Display a command (one to three keywords) on the console.
* Used for error messages.
*/
declare
( kp1, kp2, kp3 ) pointer;
call print( kp1 );
if ( kp2 <> 0 ) then
do;
call print$char( ' ' );
call print( kp2 );
if ( kp3 <> 0 ) then
do;
call print$char( ' ' );
call print( kp3 );
end; /* if ( kp3 <> 0 ) */
end; /* if ( kp2 <> 0 ) */
end show$command;
hint$command: procedure( kp1, kp2, kp3 );
/*
* Give a hint on using the command (called if too few
* parameters or invalid parameter).
*/
declare
( kp1, kp2, kp3 ) pointer;
call print( @( 7,' (Type' ) );
if ( kp1 <> 0 ) then /* it's a subcommand */
do;
call print$char( ' ' );
call show$command( kp1, kp2, kp3 );
end; /* if ( kp1 <> 0 ) */
call print( @( 23,' ? to see the choices.)' ) );
end hint$command;
too$few$params: procedure( kp1, kp2, kp3 ) public;
/*
* Issue the error messages for commands which require
* parameters when they were not followed by any keywords.
*/
declare
( kp1, kp2, kp3 ) pointer;
call show$command( kp1, kp2, kp3 );
call print( @( 22,' requires a parameter.' ) );
call hint$command( kp1, kp2, kp3 );
end too$few$params;
too$many$params: procedure( kp1, kp2, kp3 ) public;
/*
* Issue the error messages for commands which don't take
* parameters when they are followed by extra keyword(s).
*/
declare
( kp1, kp2, kp3 ) pointer;
call show$command( kp1, kp2, kp3 );
call print( @( 26,' does not take parameters.' ) );
end too$many$params;
extra$params: procedure( kp1, kp2, kp3 ) public;
/*
* Issue the error messages for commands which take only
* one parameter when they are followed by more than one
* keyword.
*/
declare
( kp1, kp2, kp3 ) pointer;
call show$command( kp1, kp2, kp3 );
call print( @( 26,' takes only one parameter.' ) );
end extra$params;
invalid$param: procedure( k$num, kp1, kp2, kp3 ) public;
/*
* Issue the error messages for invalid parameters.
*/
declare
k$num byte,
( kp1, kp2, kp3 ) pointer;
call show$keyword( k$num );
call print( @( 16,' is not a valid ' ) );
if ( kp1 = 0 ) then
call print( @( 8,'command.' ) );
else
do;
call print( @( 13,'parameter to ' ) );
call show$command( kp1, kp2, kp3 );
call print$char( '.' );
end; /* else */
call hint$command( kp1, kp2, kp3 );
end invalid$param;
keyword$match: procedure( keyword$num, keyword$ptr, min$len ) boolean public;
/*
* Compare keyword number KEYWORD$NUM (as parsed into the KEYWORD
* array) with the keyword (string) pointed to by KEYWORD$PTR,
* and return TRUE if the keyword is an abbreviation of the string
* containing at least MIN$LEN characters, otherwise return FALSE.
*/
declare
( keyword$num, min$len ) byte,
keyword$ptr pointer,
string based keyword$ptr structure(
len byte,
ch(1) byte);
if ( keyword( keyword$num ).len < min$len ) then
return( FALSE ); /* the keyword is too short */
else if ( keyword( keyword$num ).len > string.len ) then
return( FALSE ); /* the keyword is too long */
else if ( cmpb( @com$line.ch( keyword( keyword$num ).index ),
@string.ch,
keyword( keyword$num ).len ) = 0FFFFh ) then
return( TRUE ); /* the keyword matches */
else
return( FALSE ); /* the keyword doesn't match */
end keyword$match;
list$choices: procedure( kp1, kp2, kp3, list$ptr, list$last ) public;
/*
* List the choices for commands or parameters to commands,
* in response to the ? "parameter."
*/
declare
( kp1, kp2, kp3, list$ptr ) pointer,
(list$element based list$ptr)(1) pointer,
element$ptr pointer,
element$len based element$ptr byte,
( list$last, i, j, k ) byte;
call print$spaces( 2 );
call print( @( 10,'Available ' ) );
if ( kp1 = 0 ) then
call print( @( 8,'commands' ) );
else
do;
call print( @( 14,'parameters to ' ) );
call show$command( kp1, kp2, kp3 );
end; /* else */
call print( @( 5,' are:' ) );
k = 5; /* Set to start a new line immediately */
do i = 0 to list$last; /* for each entry in the list */
if ( k > 4 ) then /* start a new line every 5 columns */
do;
call new$line;
call print$spaces( 4 ); /* indent */
k = 0; /* reset column counter */
end; /* if ( k > 4 ) */
element$ptr = list$element( i );
/* Compute number of spaces to next column */
j = ( 15 - ( element$len MOD 15 ) );
/* And update columns on this line so far */
k = ( k + ( element$len / 15 ) + 1 );
call print( element$ptr );
call print$spaces( j );
end; /* do i = 0 to list$last */
end list$choices;
/*
*
* Other utility procedures
*
*/
get$filespec: procedure( keyword$num, info$ptr ) public;
/*
* Get the filespec in keyword number KEYWORD$NUM into
* the buffer pointed to by INFO$PTR.
*/
declare
keyword$num byte,
info$ptr pointer,
info based info$ptr structure(
len byte,
ch(1) byte);
/* Copy the keyword into the INFO buffer */
info.len = keyword( keyword$num ).len;
call movb( @com$line.ch( keyword( keyword$num ).index ),
@info.ch, info.len );
end get$filespec;
send$generic$command: procedure( info$ptr, info2$ptr ) boolean public;
/*
* Send a Generic Kermit Command (the data field of which
* INFO$PTR must point to) to the other Kermit. This only
* deals with commands to which no reply other than ACK or NAK
* or possibly an Error message is expected. If an Error packet
* is received the error message is displayed and FALSE is returned;
* if a NAK is received the packet is retransmitted up to the
* global MAX$RETRY count, at which point an error message is
* displayed and FALSE is returned; if an ACK is received TRUE
* is returned. INFO2$PTR points to the buffer which receives
* the contents of the response packet.
*/
declare
( info$ptr, info2$ptr ) pointer,
( type, num ) byte; /* Incoming packet type, number */
seq = 0; /* Set packet sequence number */
tries = 0; /* Init try count */
do while ( tries < max$retry );
tries = ( tries + 1 ); /* count a try */
call send$packet( 'G', seq, info$ptr ); /* send generic command */
type = receive$packet( @num, info2$ptr ); /* get response */
if ( ( type = 'Y' ) and ( num = seq ) ) then /* got good ACK */
return( TRUE );
else if ( type = 0FFh ) then /* CTRL/C abort */
do;
call print( @( 26,'Command aborted by CTRL/C.' ) );
return( FALSE );
end;
else if ( ( type <> 'N' ) and ( type <> 'Y' ) and ( type <> 0 ) ) then
do;
call unknown$packet$type( type, info2$ptr );
return( FALSE );
end;
end; /* do while ( tries < max$retry ) */
call too$many$retries;
return( FALSE );
end send$generic$command;
end kermit$util;