home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
vmskermit32.zip
/
vmstrm.bli
< prev
next >
Wrap
Text File
|
1991-02-20
|
102KB
|
3,794 lines
MODULE KERTRM (IDENT = '3.3.120',
ADDRESSING_MODE(EXTERNAL = GENERAL, NONEXTERNAL = GENERAL)
) =
BEGIN
!<BLF/WIDTH:100>
!++
! FACILITY:
!
! KERMIT-32 terminal processing.
!
! ABSTRACT:
!
! This module will do all of the terminal processing for KERMIT-32.
! It contains the output routines for the terminal to send and
! receive messages as well as the routines to output text for debugging.
!
! ENVIRONMENT:
!
! VAX/VMS user mode.
!
! AUTHOR: Robert C. McQueen, CREATION DATE: 25-March-1983
!--
%SBTTL 'Table of Contents'
!
! TABLE OF CONTENTS:
!
%SBTTL 'Revision History'
!++
!
! Start of version 1. 25-March-1983
!
! 1.0.000 By: Robert C. McQueen On: 25-March-1983
! Create this module.
!
! 1.1.001 By: W. Hom On: 6-July-83
! Implement CONNECT command.
!
! 1.1.002 By: Nick Bush On: 7-July-83
! Fix RECEIVE QIO to time out correctly.
!
! 1.2.003 By: Robert C. McQueen On: 16-Aug-83
! Get the status correctly for the SS$_TIMEOUT checks.
!
! 1.2.004 By: Robert C. McQueen On: 9-Sept-1983
! Flag if we just opened the terminal, so that we can
! clear the input that is coming into the terminal. This
! will clear up some of the junk that we get on start up.
!
! 2.0.005 Release VAX/VMS Kermit-32 version 2.0
!
! 2.0.006 By: Nick Bush On: 10-Nov-1983
! Fix local echo and IBM mode.
!
! 2.0.013 By: Nick Bush On: 11-Nov-1983
! Make it possible to redirect debugging output to DBG$OUTPUT.
!
! 2.0.015 By: Nick Bush On: 17-Nov-1983
! Always purge typeahead when posting the receive QIO.
! Also eat any received data just before sending a packet.
!
! 2.0.020 By: Nick Bush On: 9-Dec-1983
! Only abort (when remote) if we seen two control-Y's in
! succession. This way a single glitch does not kill us.
!
! 2.0.021 By: Nick Bush On: 12-Dec-1983
! Add status type-out character (^A), debug toggle
! character (^D), and force timeout character (^M)
! to those accepted during a transfer when we are remote.
!
! 2.0.023 By: Nick Bush On: 16-Dec-1983
! Add a default terminal name for the communications line.
! If KER$COMM is defined, that will be the default.
!
! 2.0.027 By: Nick Bush On: 20-Jan-1983
! Fix reset of parity to use the correct field in the
! IO status block from the IO$_SENSEMODE. It was using
! the LF fill count instead.
!
! 2.0.031 By: Nick Bush On: 4-Feb-1983
! Change connect code to improve response (hopefully
! without worsening throughput or runtime requirements).
! When either terminal is idle we will be waiting for
! a single character with a larger buffered read queued
! up immediately after it.
!
! 2.0.033 By: Nick Bush On: 6-March-1984
! Change command input and terminal processing so that
! we will always have SYS$OUTPUT and SYS$COMMAND open
! when they are terminals, and will also always have
! the transfer terminal line open. This makes it
! unnecessary for the user to allocate a dialup line
! in order to go between CONNECT and a transfer command,
! and keep anyone else from grabbing the line between
! commands.
! Also add the command parsing for the rest of the LOCAL/REMOTE
! commands. This makes use of the fact that we have
! SYS$COMMAND open to allow us to read passwords without echo.
! Commands which should only be done when Kermit is local
! (GET, BYE, etc.) will now give an error if the transfer
! line is the same as the controlling terminal.
! SEND will now check for the files existance before calling
! KERMSG to send it.
!
! 2.0.034 By: Nick Bush On: 7-March-1984
! Default the parity type to be that of the default transfer
! line. This should make things simpler for systems which use
! parity by default.
!
! 2.0.035 By: Nick Bush On: 8-March-1984
! Add LOG SESSION command to set a log file for CONNECT.
! While we are doing so, clean up the command parsing a little
! so that we don't have as many COPY_xxx routines.
!
! 2.0.036 By: Robert C. McQueen On: 20-March-1984
! Fix call to LOG_OPEN to make the debug log file work.
! Module: KERTRM
!
! 2.0.037 By: Robert C. McQueen On: 20-March-1984
! Fix call to LOG_OPEN for debug log file.
! Module: KERTRM.
!
! 2.0.042 By: Nick Bush On: 26-March-1984
! Fix connect processing to make it easy to type messages
! on the user's terminal while connected. Use this
! to type messages when log file stopped and started.
! Include the node name in the messages to keep
! users who are running through multiple Kermit's from
! getting confused.
!
! 2.0.043 By: Nick Bush On: 28-March-1984
! Fix SET PARITY ODD to work. Somehow, the table entry
! had PR_NONE instead of PR_ODD. Also add status type
! out and help message to connect command.
!
! 3.0.045 Start of version 3.
!
! 3.0.046 By: Nick Bush On: 29-March-1984
! Fix debugging log file to correctly set/clear file open
! flag. Also make log files default to .LOG.
!
! 3.1.054 By: Nick Bush On: 13-July-1984
! Change TERM_OPEN to take an argument which determines
! whether it should post any QIO's. This makes it unnecessary
! for TERM_CONNECT to cancel the QIO's, and avoids problems
! with DECnet remote terminals.
!
! 3.1.060 By: Nick Bush On: 16-March-1985
! Increase size of terminal name buffers to account for large
! unit numbers (most likely seen with VTA's).
!
! 3.1.061 By: Nick Bush On: 16-March-1985
! Only attempt to set parity back when closing terminal.
!
! 3.1.065 By: Nick Bush On: 10-April-1985
! Split IBM handshaking from parity and local echo. Allow
! link time setting of IBM_MODE defaults by defining symbols:
!
! IBM_MODE_CHARACTER = character value of handshake character
! IBM_MODE_ECHO = 1 for local echo, 2 for no local echo
! IBM_MODE_PARITY = (0 = none), (1 = mark), (2 = even),
! (3 = odd), (4 = space).
!
! If not specified, Kermit will continue to use DC1, local echo
! and odd parity for IBM_MODE.
!
!
! Start of version 3.2 on 8-May-1985
!
! 3.2.073 By: Robert McQueen On: 11-March-1985
! Fix a problem restoring the terminal characteristics under
! VMS 4.x
!
! 3.2.100 By: Gregory P. Welsh On: 1-June-1986
! Added code for Transmit function (COMND_TRANSMIT).
!
! Start of version 3.3
!
! 3.3.101 By: Robert McQueen On: 2-July-1986
! Change $TRNLOG system service to be LIB$SYS_TRNLOG and
! handle the errors better. (LIB$ shouldn't change even if the
! system service does).
!
! 3.3.102 By: Robert McQueen On: 5-July-1986
! Add changes/fixes suggested by Art Guion and David Deley.
! - Turn off FALLBACK terminal characteristics for eightbit
! operations.
! - Decrease IBM timeouts when waiting for a handshake.
!
! 3.3.105 By: Robert McQueen On: 8-July-1986
! Attempt to fix the truncation errors that we now get from
! LINK with BLISS-32 v4.2. Also do code clean up in VMSTRM and
! VMSFIL.
!
! 3.3.115 JHW004 Jonathan H. Welch, 9-May-1988 14:35
! Added the ability to send a break character to
! the outgoing terminal session using the sequence
! esc-chr B. The break will be sent after the next
! character arrives. This is because there must be
! no outstanding I/O on a channel in order to modify
! terminal characteristics (necessary to send a break).
!
! 3.3.116 JHW008 Jonathan H. Welch, 12-Apr-1990 12:20
! Added and modified routines in to notify the user if
! SS$_HANGUP occurs on the outgoing terminal line.
!
! 3.3.117 JHW012 Jonathan H. Welch, 18-May-1990 7:56
! Modified asn_wth_mbx to obtain the master PID in the
! process tree before asking for JPI$_TERMINAL. $GETJPI
! was returning a null string for this item when called
! from a subprocess resulting in a "No default terminal
! line for transfers" message.
!
! 3.3.118 JHW013 Jonathan H. Welch, 18-May-1990 13:00
! Extended the buffer size for terminal names from 20
! characters to 255 to make sure any terminal name can
! be accomodated.
!
! 3.3.119 JHW014 Jonathan H. Welch, 5-Jun-1990 12:38
! Modified asn_wth_mbx to add a ':' to the end of the
! terminal name is one is not returned by VMS.
! This will keep LIB$GETDVI from failing with an
! "invalid device name" which results in the kermit
! error "no default terminal line for transfers."
!
! 3.3.120 JHW016 Jonathan H. Welch, 17-Oct-1990 9:42
! Modified asn_wth_mbx to work properly in non-interactive mode.
!--
%SBTTL 'Library files'
!
! INCLUDE FILES:
!
!
! System definitions
!
LIBRARY 'SYS$LIBRARY:STARLET';
!
! KERMIT common definitions
!
REQUIRE 'KERCOM';
REQUIRE 'KERERR';
%SBTTL 'Structure definitions -- $GETDVI arguments'
!
! $GETDVI interface fields and structure definition
!
LITERAL
ITEM_SIZE = 3; ! Length of a DVI item list entry
!
! Fields for accessing the items in a DVI item list
!
FIELD
ITEM_FIELDS =
SET
ITEM_BFR_LENGTH = [0, 0, 16, 0],
ITEM_ITEM_CODE = [0, 16, 16, 0],
ITEM_BFR_ADDRESS = [1, 0, 32, 0],
ITEM_RTN_LENGTH = [2, 0, 32, 0]
TES;
!
! Structure definition for item list
STRUCTURE
ITEM_LIST [I, O, P, S, E; N] =
[(N + 1)*ITEM_SIZE*4]
(ITEM_LIST + ((I*ITEM_SIZE) + O)*4)<P, S, E>;
%SBTTL 'Structures definitions -- Terminal characteristics'
!
! Terminal characteristics words
!
LITERAL
TC$_CHAR_LENGTH = 12;
!
! Fields for accessing the items in a characteristic block
!
FIELD
TC$_FIELDS =
SET
TC$_CLASS = [0, 0, 8, 0],
TC$_TYPE = [0, 8, 8, 0],
TC$_BFR_SIZE = [0, 16, 16, 0],
TC$_PAGE_LEN = [1, 24, 8, 0],
TC$_CHAR = [1, 0, 24, 0],
TC$_CHAR_2 = [2, 0, 32, 0]
TES;
!
! Structure definition for item list
!
STRUCTURE
TC$_CHAR_STR [O, P, S, E; N] =
[TC$_CHAR_LENGTH]
(TC$_CHAR_STR + O*4)<P, S, E>;
%SBTTL 'Literals'
!
! Literal definitions
!
LITERAL
MAX_NODE_NAME = 255, ! Size of a node name
TERM_NAME_SIZE = 255, ! Size of a terminal name - be generous
RECV_BUFF_SIZE = MAX_MSG + 20, ! Size of receive buffer
GET_DEV_EFN = 7, ! For GET_DEV_CHAR
CONS_O_EFN = 6, ! Event flag for console output
CONS_EFN = 5, ! Event flag for console input
TERM_O_EFN = 4, ! Event flag for terminal output
TIME_EFN = 3, ! Event flag number for receive timer
TERM_EFN = 2; ! Event flag number to use for Terminal input
%SBTTL 'Storage'
!
! OWN STORAGE:
!
!
! Communications routines storage
!
OWN
FORCE_ABORT, ! Force abort next receive
FORCE_TIMEOUT, ! Force time out on next receive
TERM_FIRST_TIME, ! First time QIO to read done
TERM_CHAN, ! Channel the terminal is opened on
mbx_chan : INITIAL(0), ! Mailbox channel associated with TERM_CHAN device.
new_mbx_chan : INITIAL(0), ! Mailbox channel associated with new (temporary) TERM_CHAN device.
CONS_CHAN, ! Channel the console terminal is opened on
SYS_OUTPUT_CHAN, ! Channel to SYS$OUTPUT (if it is a terminal)
SYS_OUTPUT_OPEN, ! SYS$OUTPUT open
SYS_OUTPUT_NAME : VECTOR [TERM_NAME_SIZE, BYTE], ! Text of physical name for SYS$OUTPUT
SYS_OUTPUT_DESC : BLOCK [8, BYTE], ! Descriptor for physical name
SYS_COMMAND_CHAN, ! Channel to SYS$COMMAND if a terminal
SYS_COMMAND_OPEN, ! SYS$COMMAND open
SYS_COMMAND_NAME : VECTOR [TERM_NAME_SIZE, BYTE], ! Text of physical name for SYS$COMMAND
SYS_COMMAND_DESC : BLOCK [8, BYTE], ! Descriptor for physical name
TERM_NAME : VECTOR [TERM_NAME_SIZE, BYTE], ! Text of current transfer terminal name
JOB_TERM_NAME : VECTOR [TERM_NAME_SIZE, BYTE], ! Text of jobs controlling terminal name
TERM_OPEN_FLAG, ! The transfer terminal is open
SESSION_FAB : $FAB_DECL, ! FAB for session logging
SESSION_RAB : $RAB_DECL, ! RAB for session logging
SESSION_NAME : VECTOR [MAX_FILE_NAME, BYTE], ! Actual name of session log file
SESSION_OPEN, ! Session log file open
SESSION_LOGGING, ! Session logging enabled
DEBUG_FAB : $FAB_DECL, ! FAB for debugging
DEBUG_RAB : $RAB_DECL, ! RAB for debugging
DEBUG_NAME : VECTOR [MAX_FILE_NAME, BYTE], ! Name of debugging log file
DEBUG_REDIRECTED, ! Debugging output redirected
NODE_NAME : VECTOR [MAX_NODE_NAME, BYTE], ! Node name text
IO_STATUS : VECTOR [4, WORD], ! IOSB for receive QIO
RECV_BUFFER : VECTOR [CH$ALLOCATION (RECV_BUFF_SIZE, CHR_SIZE)], ! Input buffer
OLD_PARITY : BLOCK [8, BYTE], ! Old IOSB information
OLD_TERM_CHAR : TC$_CHAR_STR FIELD (TC$_FIELDS), ! Old terminal chars
NEW_TERM_CHAR : TC$_CHAR_STR FIELD (TC$_FIELDS); ! New terminal chars
GLOBAL
NODE_DESC : BLOCK [8, BYTE] PRESET ! Descriptor for node name
([DSC$B_CLASS ] = DSC$K_CLASS_S, ! String class
[DSC$B_DTYPE ] = DSC$K_DTYPE_T, ! Text descriptor
[DSC$W_LENGTH ] = MAX_NODE_NAME, ! Maximum length
[DSC$A_POINTER ] = NODE_NAME), ! Address of the item
DEBUG_DESC : BLOCK [8, BYTE] PRESET ! Debugging log file
([DSC$B_CLASS ] = DSC$K_CLASS_S, ! descriptor
[DSC$B_DTYPE ] = DSC$K_DTYPE_T, ! Standard string descriptor
[DSC$W_LENGTH ] = 0, ! initialially zero length
[DSC$A_POINTER ] = DEBUG_NAME), ! pointing to DEBUG_NAME
SESSION_DESC : BLOCK [8, BYTE], ! Descriptor for session log file name
TERM_DESC : BLOCK [8, BYTE], ! Descriptor for current transfer terminal
JOB_TERM_DESC : BLOCK [8, BYTE], ! Descriptor for controlling terminal (if any)
TRANS_DELAY, ! The transmit delay
TRANS_ECHO_FLAG, ! The transmit echo flag
TERM_FLAG, ! Terminal setup for transfer
Send_Break_TTY_Flag; ! Flag to indicate if a break should be sent.
%SBTTL 'External routines'
!
! EXTERNAL REFERENCES:
!
!
! System library routines
!
EXTERNAL ROUTINE
LIB$ASN_WTH_MBX : ADDRESSING_MODE (GENERAL),
LIB$GETJPI : ADDRESSING_MODE (GENERAL),
LIB$GETDVI : ADDRESSING_MODE (GENERAL),
LIB$PUT_SCREEN : ADDRESSING_MODE (GENERAL),
LIB$PUT_OUTPUT : ADDRESSING_MODE (GENERAL),
LIB$EMUL : ADDRESSING_MODE (GENERAL),
LIB$ADDX : ADDRESSING_MODE (GENERAL),
LIB$SIGNAL : ADDRESSING_MODE (GENERAL),
LIB$WAIT : ADDRESSING_MODE (GENERAL);
!
! Forward routines:
!
FORWARD ROUTINE
TERM_DUMP : NOVALUE, ! Routine to type on terminal
GET_DEV_CHAR, ! Get device characteristics
Term_Hangup : NOVALUE,
Mbx_Ast_Rtn : NOVALUE,
asn_wth_mbx,
Send_Break_TTY,
DO_RECEIVE_QIO,
DO_CONS_QIO;
%SBTTL 'External storage'
!++
! The following is the various external storage locations that are
! referenced from this module.
!--
!
! KERMSG storage
!
EXTERNAL
PARITY_TYPE, ! Type of parity being used
ECHO_FLAG, ! Local echo
IBM_CHAR, ! IBM mode turn-around character
RCV_EOL, ! Receive EOL character
SEND_TIMEOUT, ! Receive time out counter
CONNECT_FLAG; ! Flag if communications line is TT:
!
! KERMIT storage
!
EXTERNAL
ESCAPE_CHR; ! Escape char. for CONNECT.
%SBTTL 'Terminal routines -- TERM_INIT - Initialize this module'
GLOBAL ROUTINE TERM_INIT : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will initialize the terminal processing module. It will
! initialize the various data locations in this module.
!
! CALLING SEQUENCE:
!
! TERM_INIT();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
LOCAL
COUNTER, ! Counter for logical name translation
STATUS, ! System call status
DEV_TYPE, ! Device type result
RSL_LENGTH : VOLATILE, ! Resulting length of translation
RSL_NAME : BLOCK [TERM_NAME_SIZE, BYTE], ! Translated name
RSL_DESC : BLOCK [8, BYTE], ! Descriptor for translated name
NODE_ITEM_LIST : FIELD(ITEM_FIELDS) ITEM_LIST [2] PRESET ! Node name
([0, ITEM_BFR_LENGTH ] = MAX_NODE_NAME, ! Translation
[0, ITEM_ITEM_CODE ] = LNM$_STRING, ! Item list
[0, ITEM_BFR_ADDRESS ] = NODE_NAME, ! to xlate
[0, ITEM_RTN_LENGTH ] = NODE_DESC[DSC$W_LENGTH]), ! SYS$NODE
ITMLST : ITEM_LIST [1] FIELD (ITEM_FIELDS) PRESET
([0, ITEM_ITEM_CODE ] = JPI$_TERMINAL, ! Get terminal name
[0, ITEM_BFR_LENGTH ] = TERM_NAME_SIZE - 1, ! Max name size
[0, ITEM_BFR_ADDRESS ] = JOB_TERM_NAME + 1, ! Place to store it
[0, ITEM_RTN_LENGTH ] = RSL_LENGTH); ! Resulting length
!
! Initialize session log file descriptor
!
SESSION_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
SESSION_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
SESSION_DESC [DSC$W_LENGTH] = 0;
SESSION_DESC [DSC$A_POINTER] = SESSION_NAME;
!
! Get system node name (if any)
!
NODE_DESC [DSC$W_LENGTH] = MAX_NODE_NAME;
STATUS = $TRNLNM(ATTR = %REF(LNM$M_CASE_BLIND),
TABNAM = %ASCID 'LNM$SYSTEM', LOGNAM = %ASCID 'SYS$NODE',
ITMLST = NODE_ITEM_LIST);
COUNTER = 64; ! Max number of translations
WHILE .STATUS ! Translation fails
AND .COUNTER GTR 0 ! or we do too many translations
DO
BEGIN
STATUS = $TRNLNM(ATTR = %REF(LNM$M_CASE_BLIND),
TABNAM = %ASCID 'LNM$SYSTEM', LOGNAM = NODE_DESC,
ITMLST = NODE_ITEM_LIST);
COUNTER = .COUNTER - 1;
END;
!
! If call failed, we don't really know the node name
!
IF (NOT .STATUS) OR (NODE_NAME[0] EQL 0)
THEN
NODE_DESC[DSC$W_LENGTH] = 0;
!
! Get controlling terminal
!
JOB_TERM_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
JOB_TERM_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
JOB_TERM_DESC [DSC$W_LENGTH] = TERM_NAME_SIZE;
JOB_TERM_DESC [DSC$A_POINTER] = JOB_TERM_NAME;
JOB_TERM_NAME [0] = %C'_';
STATUS = $GETJPIW (ITMLST = ITMLST);
JOB_TERM_DESC [DSC$W_LENGTH] = .RSL_LENGTH + 1;
IF NOT .STATUS OR .RSL_LENGTH EQL 0 THEN JOB_TERM_DESC [DSC$W_LENGTH] = 0;
!
! Open the output device and command device (if they are terminals)
!
SYS_OUTPUT_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
SYS_OUTPUT_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
SYS_OUTPUT_DESC [DSC$W_LENGTH] = TERM_NAME_SIZE;
SYS_OUTPUT_DESC [DSC$A_POINTER] = SYS_OUTPUT_NAME;
STATUS = GET_DEV_CHAR (%ASCID'SYS$OUTPUT', SYS_OUTPUT_DESC, DEV_TYPE);
IF .STATUS AND .DEV_TYPE EQL DC$_TERM
THEN
BEGIN
STATUS = $ASSIGN (CHAN = SYS_OUTPUT_CHAN, DEVNAM = SYS_OUTPUT_DESC);
IF .STATUS THEN SYS_OUTPUT_OPEN = TRUE;
END;
SYS_COMMAND_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
SYS_COMMAND_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
SYS_COMMAND_DESC [DSC$W_LENGTH] = TERM_NAME_SIZE;
SYS_COMMAND_DESC [DSC$A_POINTER] = SYS_COMMAND_NAME;
STATUS = GET_DEV_CHAR (%ASCID'SYS$COMMAND', SYS_COMMAND_DESC, DEV_TYPE);
IF .STATUS AND .DEV_TYPE EQL DC$_TERM
THEN
BEGIN
STATUS = $ASSIGN (CHAN = SYS_COMMAND_CHAN, DEVNAM = SYS_COMMAND_DESC);
IF .STATUS THEN SYS_COMMAND_OPEN = TRUE;
END;
!
! Set up the terminal name descriptor
!
TERM_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
TERM_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
TERM_DESC [DSC$A_POINTER] = TERM_NAME;
TERM_DESC [DSC$W_LENGTH] = TERM_NAME_SIZE;
!
! If KER$COMM is a terminal, then use it as the default.
!
STATUS = GET_DEV_CHAR (%ASCID'KER$COMM', TERM_DESC, DEV_TYPE);
IF NOT .STATUS OR .DEV_TYPE NEQ DC$_TERM
THEN
BEGIN
!
! If KER$COMM is not a terminal (or is not anything), try SYS$INPUT.
!
TERM_DESC [DSC$W_LENGTH] = TERM_NAME_SIZE;
STATUS = GET_DEV_CHAR (%ASCID'SYS$INPUT', TERM_DESC, DEV_TYPE);
IF NOT .STATUS OR .DEV_TYPE NEQ DC$_TERM
THEN
BEGIN
!
! If SYS$INPUT is not a terminal, check out SYS$OUTPUT. We will already have
! it open if it is a terminal.
!
IF .SYS_OUTPUT_OPEN
THEN
BEGIN
CH$COPY (.SYS_OUTPUT_DESC [DSC$W_LENGTH],
CH$PTR (.SYS_OUTPUT_DESC [DSC$A_POINTER]), CHR_NUL, TERM_NAME_SIZE,
CH$PTR (TERM_NAME));
TERM_DESC [DSC$W_LENGTH] = .SYS_OUTPUT_DESC [DSC$W_LENGTH];
END
ELSE
BEGIN
!
! SYS$OUTPUT is not a terminal. Next we try SYS$COMMAND. It should already
! be open if it is a valid terminal.
!
IF .SYS_COMMAND_OPEN
THEN
BEGIN
CH$COPY (.SYS_COMMAND_DESC [DSC$W_LENGTH],
CH$PTR (.SYS_COMMAND_DESC [DSC$A_POINTER]), CHR_NUL, TERM_NAME_SIZE,
CH$PTR (TERM_NAME));
TERM_DESC [DSC$W_LENGTH] = .SYS_OUTPUT_DESC [DSC$W_LENGTH];
END
ELSE
BEGIN
!
! Here we start to get desparate. Nothing we have tried so far was a terminal.
! Try the terminal which is controlling the job which owns this process.
!
TERM_DESC [DSC$W_LENGTH] = .JOB_TERM_DESC [DSC$W_LENGTH];
CH$COPY (.JOB_TERM_DESC [DSC$W_LENGTH],
CH$PTR (.JOB_TERM_DESC [DSC$A_POINTER]), CHR_NUL, TERM_NAME_SIZE,
CH$PTR (TERM_NAME));
END;
END;
END;
END;
!
! At this point TERM_DESC should be set up with something resembling
! the phyiscal name of a terminal (unless this is a detached process).
! We can now assign a channel to the terminal and tell the user what the
! default device is.
!
CH$WCHAR (CHR_NUL, CH$PTR (TERM_NAME, .TERM_DESC [DSC$W_LENGTH]));
status = asn_wth_mbx(term_desc, %REF(100), %REF(100), term_chan, mbx_chan);
TERM_DUMP (UPLIT BYTE(CHR_CRT, CHR_LFD), 2);
IF .STATUS
THEN
BEGIN
BIND
DEFTRM_TEXT = %ASCID'Default terminal for transfers is: ';
MAP
DEFTRM_TEXT : BLOCK [8, BYTE];
TERM_OPEN_FLAG = TRUE;
TERM_DUMP (.DEFTRM_TEXT [DSC$A_POINTER], .DEFTRM_TEXT [DSC$W_LENGTH]);
TERM_DUMP (TERM_NAME, .TERM_DESC [DSC$W_LENGTH]);
IF .mbx_chan NEQ 0 THEN Term_Hangup();
END
ELSE
BEGIN
BIND
NODEFTRM_TEXT = %ASCID'No default terminal line for transfers';
MAP
NODEFTRM_TEXT : BLOCK [8, BYTE];
TERM_OPEN_FLAG = FALSE;
TERM_DESC [DSC$W_LENGTH] = 0;
TERM_DUMP (.NODEFTRM_TEXT [DSC$A_POINTER], .NODEFTRM_TEXT [DSC$W_LENGTH])
END;
TERM_DUMP (UPLIT BYTE(CHR_CRT, CHR_LFD), 2);
!
! Initialize the flags
!
TERM_FLAG = FALSE;
TRANS_DELAY = '0'; ! init transmit delay to .0 seconds
!
! If we really did get the terminal open, then determine what type of
! parity it uses, and default to using that parity.
!
IF .TERM_OPEN_FLAG
THEN
BEGIN
STATUS = $QIOW (CHAN = .TERM_CHAN, FUNC = IO$_SENSEMODE, P1 = OLD_TERM_CHAR,
P2 = TC$_CHAR_LENGTH, IOSB = OLD_PARITY);
IF .STATUS
THEN
IF (.OLD_PARITY [6, 0, 8, 0] AND TT$M_PARITY) NEQ 0
THEN
IF (.OLD_PARITY [6, 0, 8, 0] AND TT$M_ODD) NEQ 0
THEN
PARITY_TYPE = PR_ODD
ELSE
PARITY_TYPE = PR_EVEN
ELSE
PARITY_TYPE = PR_NONE;
END;
END; ! End of TERM_INIT
%SBTTL 'ASN_WTH_MBX - Assign channel to device and mailbox.'
global ROUTINE ASN_WTH_MBX(p_device_name, p_message_size, p_buffer_quota,
p_device_channel, p_mailbox_channel) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will assign a channel to TERM_DESC and if TERM_DESC is not
! the users' terminal create and assign a mailbox to receive messages
! about the outgoing session's state (in particular we're watching for
! SS$_HANGUP).
!
! CALLING SEQUENCE:
!
! STATUS = ASN_WTH_MBX();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! TERM_DESC
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! TERM_CHAN, MBX_CHAN
!
! COMPLETION CODES:
!
! Status of LIB$GETJPI, $ASN_WTH_MBX, and/or $ASSIGN
!
! SIDE EFFECTS:
!
! A channel is assigned to TERM_CHAN and conditionally a mailbox
! is created and a channel assigned to it.
!
BEGIN
BIND
buffer_quota = .p_buffer_quota,
device_channel = .p_device_channel,
device_name = .p_device_name,
message_size = .p_message_size,
mailbox_channel = .p_mailbox_channel;
LOCAL
master_pid,
mode,
sts,
terminal_name : BLOCK [term_name_size, BYTE],
terminal_desc : BLOCK [8, BYTE] PRESET
([DSC$B_CLASS] = DSC$K_CLASS_S,
[DSC$B_DTYPE] = DSC$K_DTYPE_T,
[DSC$W_LENGTH] = term_name_size,
[DSC$A_POINTER] = terminal_name),
temp_name : BLOCK [term_name_size, BYTE],
temp_desc : BLOCK [8, BYTE] PRESET
([DSC$B_CLASS] = DSC$K_CLASS_S,
[DSC$B_DTYPE] = DSC$K_DTYPE_T,
[DSC$W_LENGTH] = term_name_size,
[DSC$A_POINTER] = temp_name);
MAP
device_name : BLOCK [term_name_size, BYTE];
sts = LIB$GETJPI(%REF(JPI$_MODE),0,0,mode);
if .mode NEQ JPI$K_INTERACTIVE
THEN
$ASSIGN(CHAN = device_channel, DEVNAM = device_name)
ELSE
BEGIN
sts = LIB$GETJPI(%REF(JPI$_MASTER_PID),0,0,master_pid,0,0);
IF NOT .sts THEN RETURN .sts;
sts = LIB$GETJPI(%REF(JPI$_TERMINAL),
master_pid,
0,
0,
temp_desc,
temp_desc);
IF NOT .sts THEN RETURN .sts;
IF .(.temp_desc[dsc$a_pointer] - 1 +
.temp_desc[dsc$w_length])<0,8> NEQ %C ':'
THEN
BEGIN
(.temp_desc[dsc$a_pointer] + .temp_desc[dsc$w_length])<0,8> = %C ':';
temp_desc[dsc$w_length] = .temp_desc[dsc$w_length] + 1;
END;
sts = LIB$GETDVI(%REF(DVI$_DEVNAM),
0,
temp_desc,
0,
terminal_desc,
terminal_desc);
IF NOT .sts THEN RETURN .sts;
IF CH$EQL(.terminal_desc[DSC$W_LENGTH], .terminal_desc[DSC$A_POINTER],
.device_name[DSC$W_LENGTH], .device_name[DSC$A_POINTER],
%C' ')
THEN
BEGIN
IF .mailbox_channel NEQ 0 THEN $DASSGN(CHAN = .mailbox_channel);
mailbox_channel = 0;
$ASSIGN(CHAN = device_channel, DEVNAM = device_name)
END
ELSE
LIB$ASN_WTH_MBX(device_name, message_size, buffer_quota,
device_channel, mailbox_channel)
END
END;
%SBTTL 'SET_TRANS_TERM - Set new transfer terminal line'
GLOBAL ROUTINE SET_TRANS_TERM (NEW_NAME) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will validate the terminal name that a user wishes to set
! as the transfer line. If the name is valid, it will store the physical
! name in TERM_DESC, and open the new terminal line.
!
! CALLING SEQUENCE:
!
! STATUS = SET_TRANS_TERM (NEW_NAME);
!
! INPUT PARAMETERS:
!
! NEW_NAME - Descriptor for new terminal name.
!
! IMPLICIT INPUTS:
!
! TERM_OPEN_FLAG, TERM_CHAN
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! True/false status value - error code
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
MAP
NEW_NAME : REF BLOCK [8, BYTE]; ! Descriptor for new name
LOCAL
NEW_CHAN, ! Temp for channel to new terminal
RSL_DESC : BLOCK [8, BYTE], ! Descriptor for physical name
RSL_NAME : VECTOR [TERM_NAME_SIZE, BYTE], ! String of resulting name
DEV_TYPE, ! Device type
STATUS; ! Random status values
!
! Set up descriptor
!
RSL_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
RSL_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
RSL_DESC [DSC$W_LENGTH] = TERM_NAME_SIZE; ! Maximum length
RSL_DESC [DSC$A_POINTER] = RSL_NAME; ! Where to store name
STATUS = GET_DEV_CHAR (.NEW_NAME, RSL_DESC, DEV_TYPE);
IF NOT .STATUS THEN RETURN .STATUS;
IF .DEV_TYPE NEQ DC$_TERM THEN RETURN KER_LINTERM;
!
! The device is a terminal, now make sure we can get it.
!
! If we are CONNECTing to the same device and this device is a LAT
! device then we must deassign our channel to it (in order for things
! to reset properly). There is a chance the reassignment will fail.
! If this happens then we are in a bad state - no valid output device.
!
! Otherwise keep a channel to either the old or new device at all times.
!
IF CH$EQL(.rsl_desc[DSC$W_LENGTH], .rsl_desc[DSC$A_POINTER],
.term_desc[DSC$W_LENGTH], .term_desc[DSC$A_POINTER],
%C' ') AND
CH$EQL(4, .rsl_desc[DSC$A_POINTER], 4, UPLIT('_LTA'))
! (..rsl_desc[DSC$A_POINTER] EQL '_LTA')
THEN
BEGIN
IF .mbx_chan NEQ 0
THEN
BEGIN
$DASSGN (CHAN = .mbx_chan);
mbx_chan = 0;
END;
$DASSGN (CHAN = .TERM_CHAN);
status = asn_wth_mbx(rsl_desc, %REF(100), %REF(100),
new_chan, new_mbx_chan);
IF NOT .STATUS THEN RETURN .STATUS;
END
ELSE
BEGIN
status = asn_wth_mbx(rsl_desc, %REF(100), %REF(100),
new_chan, new_mbx_chan);
IF NOT .STATUS THEN RETURN .STATUS;
!
! We have the new terminal. Deassign the old one and copy the new data
!
$DASSGN (CHAN = .TERM_CHAN);
IF .mbx_chan NEQ 0
THEN
BEGIN
$DASSGN (CHAN = .mbx_chan);
mbx_chan = 0;
END;
CH$COPY (.RSL_DESC [DSC$W_LENGTH], CH$PTR (RSL_NAME), CHR_NUL,
TERM_NAME_SIZE, CH$PTR (TERM_NAME));
TERM_DESC [DSC$W_LENGTH] = .RSL_DESC [DSC$W_LENGTH];
END;
TERM_CHAN = .NEW_CHAN;
IF .new_mbx_chan NEQ 0 THEN mbx_chan = .new_mbx_chan;
IF .mbx_chan NEQ 0 THEN Term_Hangup();
RETURN KER_NORMAL;
END; ! End of SET_TRANS_TERM
%SBTTL 'TERM_DUMP - This routine will dump text on the terminal'
GLOBAL ROUTINE TERM_DUMP (BUFFER_ADDRESS, BUFFER_COUNT) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will dump the text specified on the user's terminal.
! It will then return to the caller.
!
! CALLING SEQUENCE:
!
! TERM_DUMP( TEXT-BUFFER-ADDRESS, COUNT)
!
! INPUT PARAMETERS:
!
! TEXT-BUFFER-ADDRESS - Address of the buffer containing the characters.
!
! COUNT - Count of the characters in the buffer.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
LOCAL
TEXT_DESC : BLOCK [8, BYTE];
IF NOT .CONNECT_FLAG
THEN
BEGIN
IF .SYS_OUTPUT_OPEN
THEN
$QIOW (CHAN = .SYS_OUTPUT_CHAN, EFN = CONS_O_EFN,
FUNC = IO$_WRITEVBLK, P1 = .BUFFER_ADDRESS, P2 = .BUFFER_COUNT, P4 = 0)
ELSE
BEGIN
TEXT_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
TEXT_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
TEXT_DESC [DSC$W_LENGTH] = .BUFFER_COUNT;
TEXT_DESC [DSC$A_POINTER] = .BUFFER_ADDRESS;
LIB$PUT_OUTPUT (TEXT_DESC);
END;
END;
END; ! End of TERM_DUMP
%SBTTL 'DBG_DUMP - This routine will dump text on the terminal'
GLOBAL ROUTINE DBG_DUMP (BUFFER_ADDRESS, BUFFER_COUNT) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will dump the text specified on the user's terminal.
! It will then return to the caller.
!
! CALLING SEQUENCE:
!
! DBG_DUMP( TEXT-BUFFER-ADDRESS, COUNT)
!
! INPUT PARAMETERS:
!
! TEXT-BUFFER-ADDRESS - Address of the buffer containing the characters.
!
! COUNT - Count of the characters in the buffer.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
LOCAL
STATUS, ! Status from $PUT
TEXT_DESC : BLOCK [8, BYTE];
IF NOT .CONNECT_FLAG AND NOT .DEBUG_REDIRECTED ! Check where debugging should go
THEN
BEGIN
IF .SYS_OUTPUT_OPEN
THEN
$QIOW (CHAN = .SYS_OUTPUT_CHAN, EFN = CONS_O_EFN,
FUNC = IO$_WRITEVBLK OR IO$M_NOFORMAT, P1 = .BUFFER_ADDRESS, P2 = .BUFFER_COUNT)
ELSE
BEGIN
TEXT_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
TEXT_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
TEXT_DESC [DSC$W_LENGTH] = .BUFFER_COUNT;
TEXT_DESC [DSC$A_POINTER] = .BUFFER_ADDRESS;
LIB$PUT_OUTPUT (TEXT_DESC);
END;
END
ELSE
IF .DEBUG_REDIRECTED
THEN
BEGIN
EXTERNAL ROUTINE
LOG_CHAR, ! Routine to write a character to log file
LOG_CLOSE; ! Routine to close log file
LOCAL
POINTER;
POINTER = CH$PTR (.BUFFER_ADDRESS);
DECR I FROM .BUFFER_COUNT TO 1 DO
IF NOT LOG_CHAR (CH$RCHAR_A (POINTER), DEBUG_RAB)
THEN
BEGIN
LOG_CLOSE (DEBUG_FAB, DEBUG_RAB);
DEBUG_REDIRECTED = FALSE;
END;
END;
END; ! End of DBG_DUMP
%SBTTL 'GET_COMMAND - Get a command line'
GLOBAL ROUTINE GET_COMMAND (CMD_DESC, PROMPT_DESC, CMD_LENGTH, ECHO_FLAG) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will get a command line from SYS$COMMAND:. If
! SYS$COMMAND is a terminal, it will do input using a QIO, which will
! allow input without echo if desired. If SYS$COMMAND is not a terminal,
! it will use LIB$GET_COMMAND.
!
! CALLING SEQUENCE:
!
! STATUS = GET_COMMAND (CMD_DESC, PROMPT_DESC, CMD_LENGTH, ECHO_FLAG);
!
! INPUT PARAMETERS:
!
! CMD_DESC - String descriptor for command being input
! PROMPT_DESC - String descriptor for prompt
! ECHO_FLAG - True if input should be echoed, false if not
!
! IMPLICIT INPUTS:
!
! SYS_COMMAND_OPEN - Flag whether SYS$COMMAND is open
! SYS_COMMAND_CHAN - Channel SYS$COMMAND is open on, if open
!
! OUPTUT PARAMETERS:
!
! CMD_LENGTH - Actual length of command input
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! Returns status value, true unless error has occured.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
MAP
CMD_DESC : REF BLOCK [8, BYTE], ! Where to put input
PROMPT_DESC : REF BLOCK [8, BYTE]; ! Prompt string
EXTERNAL ROUTINE
TT_CRLF : NOVALUE, ! Type a CRLF
STR$UPCASE : ADDRESSING_MODE (GENERAL), ! Upcase a string
LIB$GET_COMMAND : ADDRESSING_MODE (GENERAL); ! Get string from SYS$COMMAND
LOCAL
QIO_FUNC, ! Function for QIO
IOSB : VECTOR [4, WORD], ! IOSB for QIO
STATUS; ! Random status values
IF .SYS_COMMAND_OPEN
THEN
BEGIN
QIO_FUNC = IO$_READPROMPT; ! Assume just read with prompt
IF NOT .ECHO_FLAG THEN QIO_FUNC = IO$_READPROMPT OR IO$M_NOECHO; ! Don't echo input
STATUS = $QIOW (CHAN = .SYS_COMMAND_CHAN, FUNC = .QIO_FUNC, IOSB = IOSB,
P1 = .CMD_DESC [DSC$A_POINTER], P2 = .CMD_DESC [DSC$W_LENGTH],
P5 = .PROMPT_DESC [DSC$A_POINTER], P6 = .PROMPT_DESC [DSC$W_LENGTH]);
IF NOT .STATUS THEN RETURN .STATUS;
!
! If we didn't echo, then dump a CRLF so we look nice
!
IF NOT .ECHO_FLAG THEN TT_CRLF ();
IF .IOSB [0]
THEN
BEGIN
.CMD_LENGTH = .IOSB [1]; ! Get actual length input
IF .IOSB [3] EQL 1 AND .IOSB [2] EQL CHR_CTL_Z THEN RETURN RMS$_EOF;
END;
!
! Upcase the resulting string
!
STATUS = STR$UPCASE (.CMD_DESC, .CMD_DESC);
IF NOT .STATUS THEN RETURN .STATUS;
RETURN .IOSB [0]; ! Return resulting status
END;
!
! Here if SYS$COMMAND is not open. Get the command via LIB$GET_COMMAND.
!
RETURN LIB$GET_COMMAND (.CMD_DESC, .PROMPT_DESC, .CMD_LENGTH);
END; ! End of GET_COMMAND
%SBTTL 'Communcations line -- TERM_OPEN'
GLOBAL ROUTINE TERM_OPEN (POST_QIOS) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will assign a channel that is used in the CONNECT
! processing and to send/receive a file from.
!
! CALLING SEQUENCE:
!
! TERM_OPEN(POST_QIOS);
!
! INPUT PARAMETERS:
!
! POST_QIOS - True if initial read QIO's should be posted.
!
! IMPLICIT INPUTS:
!
! TERM_DESC - Descriptor of a vector of ASCII characters that represent
! the name of the terminal to use.
!
! TERM_CHAN - Channel open to terminal if TERM_OPEN_FLAG is true.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! TERM_CHAN - Channel number of the terminal line we are using.
!
! COMPLETION CODES:
!
! SS$_NORMAL or error condition.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
EXTERNAL ROUTINE
LOG_FAOL, ! Write FAOL style text
LOG_OPEN; ! Open a log file
EXTERNAL
TRANSACTION_OPEN,
TRANSACTION_DESC : BLOCK [8, BYTE],
TRANSACTION_FAB : $FAB_DECL,
TRANSACTION_RAB : $RAB_DECL;
LOCAL
STATUS;
!
! If the terminal is not open, we must open it first.
!
IF NOT .TERM_OPEN_FLAG
THEN
IF .TERM_DESC [DSC$W_LENGTH] GTR 0
THEN
BEGIN
STATUS = SET_TRANS_TERM (TERM_DESC);
IF NOT .STATUS THEN RETURN .STATUS;
END
ELSE
RETURN KER_LINTERM;
!
! Set up connect flag properly
!
IF CH$NEQ (.SYS_OUTPUT_DESC [DSC$W_LENGTH], CH$PTR (.SYS_OUTPUT_DESC [DSC$A_POINTER]),
.TERM_DESC [DSC$W_LENGTH], CH$PTR (TERM_NAME), CHR_NUL) OR NOT .SYS_OUTPUT_OPEN
THEN
CONNECT_FLAG = FALSE
ELSE
CONNECT_FLAG = TRUE;
!
! If we aren't connected, remember the channel to use for the console I/O
!
IF NOT .CONNECT_FLAG AND .SYS_OUTPUT_OPEN THEN CONS_CHAN = .SYS_OUTPUT_CHAN;
!
! Get current settings for transfer terminal
!
STATUS = $QIOW (CHAN = .TERM_CHAN, FUNC = IO$_SENSEMODE, P1 = OLD_TERM_CHAR,
P2 = TC$_CHAR_LENGTH, IOSB = OLD_PARITY);
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
NEW_TERM_CHAR [TC$_BFR_SIZE] = .OLD_TERM_CHAR [TC$_BFR_SIZE];
NEW_TERM_CHAR [TC$_TYPE] = .OLD_TERM_CHAR [TC$_TYPE];
NEW_TERM_CHAR [TC$_CLASS] = .OLD_TERM_CHAR [TC$_CLASS];
NEW_TERM_CHAR [TC$_PAGE_LEN] = .OLD_TERM_CHAR [TC$_PAGE_LEN];
NEW_TERM_CHAR [TC$_CHAR] = (.OLD_TERM_CHAR [TC$_CHAR] OR TT$M_NOBRDCST) AND NOT (TT$M_CRFILL OR
TT$M_LFFILL OR TT$M_WRAP OR TT$M_NOTYPEAHD);
! We do not want to use eightbit if using parity
IF .PARITY_TYPE EQL PR_NONE
THEN
NEW_TERM_CHAR [TC$_CHAR] = .NEW_TERM_CHAR [TC$_CHAR] OR TT$M_EIGHTBIT
ELSE
NEW_TERM_CHAR [TC$_CHAR] = .NEW_TERM_CHAR [TC$_CHAR] AND NOT TT$M_EIGHTBIT;
NEW_TERM_CHAR [TC$_CHAR_2] = TT2$M_XON OR TT2$M_PASTHRU OR
(.OLD_TERM_CHAR [TC$_CHAR_2] AND NOT TT2$M_FALLBACK);
STATUS = $QIOW (CHAN = .TERM_CHAN, FUNC = IO$_SETMODE, P1 = NEW_TERM_CHAR,
P2 = TC$_CHAR_LENGTH, P5 = TT$M_ALTRPAR);
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
TERM_FLAG = TRUE; ! Terminal now open
TERM_FIRST_TIME = TRUE; ! Flag first time QIO should clear input
FORCE_TIMEOUT = FALSE; ! Don't timeout for no reason
FORCE_ABORT = FALSE; ! Don't abort yet
!
! Now post the initial receive QIO
!
IF .POST_QIOS ! Need the QIO's?
THEN
BEGIN
STATUS = DO_RECEIVE_QIO ();
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN KER_RECERR;
END;
!
! Also post the QIO for the console
!
IF NOT .CONNECT_FLAG AND .SYS_OUTPUT_OPEN
THEN
BEGIN
STATUS = DO_CONS_QIO ();
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
$CANCEL (CHAN = .TERM_CHAN);
$DASSGN (CHAN = .TERM_CHAN);
RETURN KER_RECERR;
END;
END;
END;
!
! Open any debugging log file
!
IF .DEBUG_DESC [DSC$W_LENGTH] GTR 0
THEN
IF LOG_OPEN (DEBUG_DESC, DEBUG_FAB, DEBUG_RAB)
THEN
DEBUG_REDIRECTED = TRUE
ELSE
DEBUG_REDIRECTED = FALSE
ELSE
DEBUG_REDIRECTED = FALSE;
IF .TRANSACTION_DESC [DSC$W_LENGTH] GTR 0
THEN
IF LOG_OPEN (TRANSACTION_DESC, TRANSACTION_FAB, TRANSACTION_RAB)
THEN
BEGIN
TRANSACTION_OPEN = TRUE;
LOG_FAOL (%ASCID'!-!-!11%D!/!-!%T!_Starting transaction log in file !AS!/',
UPLIT (0, TRANSACTION_DESC), TRANSACTION_RAB);
END
ELSE
TRANSACTION_OPEN = FALSE
ELSE
TRANSACTION_OPEN = FALSE;
RETURN KER_NORMAL;
END; ! End of TERM_OPEN
%SBTTL 'Communications line -- TERM_CLOSE'
GLOBAL ROUTINE TERM_CLOSE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will deassign the channel that was assigned by
! TERM_OPEN.
!
! CALLING SEQUENCE:
!
! TERM_CLOSE();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! TERM_CHAN - Channel number to deassign.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! SS$_NORMAL or error condition.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
EXTERNAL ROUTINE
LOG_FAOL, ! Routine to dump FAOL string
LOG_CLOSE; ! Routine to close log file
EXTERNAL
TRANSACTION_OPEN,
TRANSACTION_DESC : BLOCK [8, BYTE],
TRANSACTION_FAB,
TRANSACTION_RAB;
LOCAL
PAR, ! Parity being set
STATUS; ! Status returned by system service
STATUS = $CANCEL (CHAN = .TERM_CHAN); ! Kill pending QIO
IF .SYS_OUTPUT_OPEN THEN $CANCEL (CHAN = .CONS_CHAN);
CONNECT_FLAG = FALSE;
PAR = (.OLD_PARITY [6, 0, 8, 0] AND (TT$M_ODD OR TT$M_PARITY)) OR TT$M_ALTRPAR;
! Only set parity
STATUS = $QIOW (CHAN = .TERM_CHAN, FUNC = IO$_SETMODE, P1 = OLD_TERM_CHAR,
P2 = TC$_CHAR_LENGTH, P4 = .OLD_PARITY [4, 0, 16, 0], P5 = .PAR);
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
!
! Flag terminal parameters are reset
!
TERM_FLAG = FALSE;
!
! Close the debugging log file
!
IF .DEBUG_REDIRECTED
THEN
BEGIN
LOG_CLOSE (DEBUG_FAB, DEBUG_RAB);
DEBUG_REDIRECTED = FALSE;
END;
!
! Close the transaction log
!
IF .TRANSACTION_OPEN
THEN
BEGIN
LOG_FAOL (%ASCID'!-!-!11%D!/!-!%T!_Closing transaction log file !AS!/',
UPLIT (0, TRANSACTION_DESC), TRANSACTION_RAB);
LOG_CLOSE (TRANSACTION_FAB, TRANSACTION_RAB);
TRANSACTION_OPEN = FALSE;
END;
!
! If all worked, say so
!
RETURN KER_NORMAL
END; ! End of TERM_CLOSE
%SBTTL 'Communications line -- SEND'
GLOBAL ROUTINE SEND (ADDRESS, LENGTH) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will send a stream of 8-bit bytes over the terminal
! line to the remote KERMIT. This routine is called from KERMSG.
!
! CALLING SEQUENCE:
!
! SEND(Address-of-msg, Length-of-msg);
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! TERM_CHAN - Channel number to deassign.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! SS$_NORMAL or error condition.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
LOCAL
CUR_EFN, ! Current EFN settings
STATUS; ! Status returned by $QIOW
!
! If we already got a complete buffer of input we should ignore it.
! This is because we are probably retransmitting something and the
! incoming data is the response to the previous copy of this message.
! If we don't ignore it, we could get into a situation where every message
! gets transmitted twice.
!
STATUS = $READEF (EFN = TERM_EFN, STATE = CUR_EFN);
IF (.CUR_EFN AND 1^TERM_EFN) EQL 1 THEN DO_RECEIVE_QIO ();
STATUS = $QIOW (CHAN = .TERM_CHAN, EFN = TERM_O_EFN, FUNC = IO$_WRITEVBLK + IO$M_NOFORMAT,
P1 = .ADDRESS, P2 = .LENGTH);
IF .STATUS EQL SS$_NORMAL
THEN
RETURN KER_NORMAL
ELSE
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
END; ! End of SEND
%SBTTL 'Communications line -- RECEIVE'
GLOBAL ROUTINE RECEIVE (ADDRESS, LENGTH) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will receive a stream of 8-bit bytes over the terminal
! line to the remote KERMIT. This routine is called from KERMSG.
! The text that is stored will always contain the control-A as the
! first character.
!
! CALLING SEQUENCE:
!
! RECEIVE(Address-of-msg);
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! TERM_CHAN - Channel number to deassign.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! SS$_NORMAL or error condition.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
EXTERNAL
RCV_SOH; ! Character to use for start of packet
LOCAL
QWORD_TIMEOUT : VECTOR [2, LONG], ! Quad word TIMEOUT value
TIMER_VALUE : VECTOR [2, LONG], ! Quad word TIME value
OLD_POINTER, ! Pointer into the message
NEW_POINTER, ! Other pointer for finding SOH
CUR_LENGTH, ! Running length while finding SOH
CUR_EFN, ! Current EFN value
STATUS; ! Status returned by $QIO
OWN
INT_CHR_SEEN; ! Interrupt character seen last
!
! Flag we haven't seen a ^Y yet. We must get two control-Y's in fairly
! quick succession (no timeouts in between) in order to give up.
!
INT_CHR_SEEN = FALSE;
!
! Set up the timer if we have a time out parameter
!
IF NOT .FORCE_TIMEOUT THEN STATUS = $CLREF (EFN = TIME_EFN);
IF .SEND_TIMEOUT GTR 0
THEN
BEGIN
STATUS = $CANTIM (REQIDT = TIME_EFN);
STATUS = $GETTIM (TIMADR = TIMER_VALUE);
STATUS = LIB$EMUL (SEND_TIMEOUT, UPLIT (10000000), UPLIT (0), QWORD_TIMEOUT);
STATUS = LIB$ADDX (TIMER_VALUE, QWORD_TIMEOUT, QWORD_TIMEOUT);
STATUS = $SETIMR (DAYTIM = QWORD_TIMEOUT, EFN = TIME_EFN, REQIDT = TIME_EFN);
END;
!
! Loop until we get something that is acceptable
!
WHILE TRUE DO
BEGIN
!
! Wait for something to happen. Either the terminal EFN will come up
! indicating we have some data, or the timer EFN will indicate that
! the time has run out.
!
STATUS = $WFLOR (EFN = TERM_EFN, MASK = (1^TERM_EFN OR 1^TIME_EFN));
STATUS = $READEF (EFN = TERM_EFN, STATE = CUR_EFN);
FORCE_TIMEOUT = FALSE; ! Timeout had it chance to happen
!
! If the terminal EFN is not set, the time must have expired. Therefore,
! we have timed out, and need to return that fact.
!
IF (.CUR_EFN AND 1^TERM_EFN) EQL 0 THEN RETURN KER_TIMEOUT;
!
! If we have a request to abort, start it up the chain.
!
IF .FORCE_ABORT
THEN
BEGIN
STATUS = $CANTIM (REQIDT = TIME_EFN);
RETURN KER_ABORTED;
END;
!
! Check if the QIO completed successfully. If not, we will return
! an error.
!
IF NOT .IO_STATUS [0]
THEN
BEGIN
LIB$SIGNAL (.IO_STATUS [0]);
RETURN KER_RECERR;
END;
!
! First check for a control-Y as the terminator. If it was, then
! just abort now, since the user probably typed it.
!
IF .CONNECT_FLAG
THEN
IF (.IO_STATUS [2] EQL CHR_CTL_Y) AND (.RCV_EOL NEQ CHR_CTL_Y)
THEN
BEGIN
IF .INT_CHR_SEEN AND .IO_STATUS [1] EQL 0
THEN
BEGIN
STATUS = $CANTIM (REQIDT = TIME_EFN);
RETURN KER_ABORTED
END
ELSE
BEGIN
INT_CHR_SEEN = TRUE;
IO_STATUS [1] = 0; ! Force no input seen
END
END
ELSE
INT_CHR_SEEN = FALSE; ! Last character not ^Y
!
! Now find the final start of header character in the buffer. We
! will only return the text from that point on. If there is no SOH,
! then just get another buffer. It was probably noise on the line.
!
OLD_POINTER = CH$PTR (RECV_BUFFER, 0, CHR_SIZE);
CUR_LENGTH = .IO_STATUS [1]; ! Length without terminating character
NEW_POINTER = CH$FIND_CH (.CUR_LENGTH, .OLD_POINTER, .RCV_SOH);
!
! If we found a start of header character, then we probably have something
! to return. However, first we must find the last start of header, in case
! something is garbled.
!
IF NOT CH$FAIL (.NEW_POINTER)
THEN
BEGIN
!
! Search until we can't find any more start of headers, or until we run
! out of string to search (last character before EOL is an SOH).
!
WHILE (.CUR_LENGTH GTR 0) AND ( NOT CH$FAIL (.NEW_POINTER)) DO
BEGIN
CUR_LENGTH = .CUR_LENGTH - CH$DIFF (.NEW_POINTER, .OLD_POINTER);
! Adjust the length for the characters we are skipping
OLD_POINTER = .NEW_POINTER; ! Remember where we start
NEW_POINTER = CH$FIND_CH (.CUR_LENGTH - 1, CH$PLUS (.OLD_POINTER, 1), .RCV_SOH);
! Find the next SOH (if any)
END;
!
! If we have something left of the buffer, move from the SOH until the end
! into the callers buffer.
!
IF (.CUR_LENGTH GTR 0)
THEN
BEGIN
.LENGTH = .CUR_LENGTH + 1;
IF .PARITY_TYPE EQL PR_NONE ! Have eight-bit?
THEN
CH$MOVE (.CUR_LENGTH + 1, .OLD_POINTER, CH$PTR (.ADDRESS, 0, CHR_SIZE))
ELSE
BEGIN
NEW_POINTER = CH$PTR (.ADDRESS, 0, CHR_SIZE);
DECR CUR_LENGTH FROM .CUR_LENGTH TO 0 DO
CH$WCHAR_A ((CH$RCHAR_A (OLD_POINTER) AND %O'177'), NEW_POINTER);
END;
EXITLOOP
END
END; ! End of IF NOT CH$FAIL(.POINTER)
!
! If we have gotten here, we have input a buffer without a valid message.
! Make sure we post the QIO again
!
STATUS = DO_RECEIVE_QIO ();
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN KER_RECERR
END;
END; ! End of WHILE TRUE DO
!
! If we have gotten here, we have a valid message to return.
! Post the QIO so the buffer is available for the next message.
!
STATUS = DO_RECEIVE_QIO ();
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN KER_RECERR
END;
RETURN KER_NORMAL; ! Return happy
END; ! End of RECEIVE
%SBTTL 'Communications line -- IBM_WAIT'
GLOBAL ROUTINE IBM_WAIT =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will wait until the IBM turnaround character
! is seen on the communications line, or until the timeout
! parameter is exceeded.
!
! CALLING SEQUENCE:
!
! STATUS = IBM_WAIT ();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! TERM_CHAN - Channel number for terminal
!
! OUTPUT PARAMETERS:
!
! Status value is returned as routine value.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! SS$_NORMAL or error condition.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
LOCAL
QWORD_TIMEOUT : VECTOR [2, LONG], ! Quad word TIMEOUT value
TIMER_VALUE : VECTOR [2, LONG], ! Quad word TIME value
CUR_EFN, ! Current EFN value
STATUS; ! Status returned by $QIO
!
! Set up the timer if we have a time out parameter
!
STATUS = $CLREF (EFN = TIME_EFN);
IF .SEND_TIMEOUT GTR 0
THEN
BEGIN
STATUS = $CANTIM (REQIDT = TIME_EFN);
STATUS = $GETTIM (TIMADR = TIMER_VALUE);
STATUS = LIB$EMUL (SEND_TIMEOUT, UPLIT (1000000), UPLIT (0), QWORD_TIMEOUT);
STATUS = LIB$ADDX (TIMER_VALUE, QWORD_TIMEOUT, QWORD_TIMEOUT);
STATUS = $SETIMR (DAYTIM = QWORD_TIMEOUT, EFN = TIME_EFN, REQIDT = TIME_EFN);
END;
!
! Loop until we get something that is acceptable
!
WHILE TRUE DO
BEGIN
!
! Wait for something to happen. Either the terminal EFN will come up
! indicating we have some data, or the timer EFN will indicate that
! the time has run out.
!
STATUS = $WFLOR (EFN = TERM_EFN, MASK = (1^TERM_EFN OR 1^TIME_EFN));
STATUS = $READEF (EFN = TERM_EFN, STATE = CUR_EFN);
!
! If the terminal EFN is not set, the time must have expired. Therefore,
! pretend we got the character.
!
IF (.CUR_EFN AND 1^TERM_EFN) EQL 0 THEN RETURN KER_NORMAL;
!
! Check if the QIO completed successfully. If not, we will return
! an error.
!
IF NOT .IO_STATUS [0]
THEN
BEGIN
LIB$SIGNAL (.IO_STATUS [0]);
RETURN KER_RECERR;
END;
!
! First check for a control-Y as the terminator. If it was, then
! just abort now, since the user probably typed it.
!
IF .CONNECT_FLAG
THEN
IF (.IO_STATUS [2] EQL CHR_CTL_Y) AND (.RCV_EOL NEQ CHR_CTL_Y)
THEN
BEGIN
STATUS = $CANTIM (REQIDT = TIME_EFN);
RETURN KER_ABORTED
END;
! Check if terminator was the turnaround character
IF (.IO_STATUS [2] EQL .IBM_CHAR) THEN EXITLOOP;
!
! Make sure we post the QIO again
!
STATUS = DO_RECEIVE_QIO ();
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN KER_RECERR
END;
END; ! End of WHILE TRUE DO
!
! If we have gotten here, we have a valid message to return.
! Post the QIO so the buffer is available for the next message.
!
STATUS = DO_RECEIVE_QIO ();
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN KER_RECERR
END;
RETURN KER_NORMAL; ! Return happy
END; ! End of RECEIVE
%SBTTL 'GET_DEV_CHAR - Determine device characteristics'
ROUTINE GET_DEV_CHAR (LOG_NAME_DESC, PHYS_NAME_DESC, DEV_CLASS) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will get the device characteristics from VMS. It returns
! both the physical name of the device and the device class.
!
! CALLING SEQUENCE:
!
! STATUS = GET_DEV_CHAR (LOG_NAME_DESC, PHYS_NAME_DESC, DEV_CLASS);
!
! INPUT PARAMETERS:
!
! LOG_NAME_DESC - Descriptor for logical device for which the device
! class is desired.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! PHYS_NAME_DESC - Descriptor for physical device name
! DEV_CLASS - Device class for device
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES/RETURN VALUE:
!
! Status value returned from $GETDVI if it fails,
! KER_NORMAL otherwise.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
MAP
PHYS_NAME_DESC : REF BLOCK [8, BYTE]; ! Physical name descriptor
LOCAL
ITMLST : ITEM_LIST [2] FIELD (ITEM_FIELDS),
PHYS_NAME_LENGTH : VOLATILE,
STATUS;
!
! Set up item list for device class
!
ITMLST [0, ITEM_ITEM_CODE] = DVI$_DEVCLASS;
ITMLST [0, ITEM_BFR_LENGTH] = 4; ! 4 byte result
ITMLST [0, ITEM_BFR_ADDRESS] = .DEV_CLASS; ! Where to return result
ITMLST [0, ITEM_RTN_LENGTH] = 0; ! We know how long it is
!
! Item list entry for device name
!
ITMLST [1, ITEM_ITEM_CODE] = DVI$_DEVNAM; ! Want the name of the device
ITMLST [1, ITEM_BFR_LENGTH] = .PHYS_NAME_DESC [DSC$W_LENGTH]; ! Max length to return
ITMLST [1, ITEM_BFR_ADDRESS] = .PHYS_NAME_DESC [DSC$A_POINTER]; ! Where to return name
ITMLST [1, ITEM_RTN_LENGTH] = PHYS_NAME_LENGTH; ! Where to return length
!
! End the list of items
!
ITMLST [2, ITEM_ITEM_CODE] = 0;
ITMLST [2, ITEM_BFR_LENGTH] = 0;
!
! Request the information
!
STATUS = $GETDVIW (EFN = GET_DEV_EFN, DEVNAM = .LOG_NAME_DESC, ITMLST = ITMLST);
IF NOT .STATUS THEN RETURN .STATUS;
!
! Assign the length and return happy
!
PHYS_NAME_DESC [DSC$W_LENGTH] = .PHYS_NAME_LENGTH;
RETURN KER_NORMAL;
END; ! End of GET_DEV_CHAR
%SBTTL 'Term_Hangup'
global ROUTINE Term_Hangup : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine puts a read-attention AST on the mailbox associated with
! TERM_DESC - the port being used for external communications. The
! mailbox will receive 3 types of messages: Unsolicited data, Terminal
! hangup, and Broadcast messages. Only Terminal hangup messages are of
! interest here.
!
!
! CALLING SEQUENCE:
!
! TERM_HANGUP();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! MBX_CHAN - The channel to the mailbox associated with TERM_DESC.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! Return status from $QIOW
!
! SIDE EFFECTS:
!
! A write-attention AST is queued to the mailbox. The ast routine
! MBX_AST_RTN will be called if a message is written to the mailbox.
!
!--
BEGIN
LOCAL
Function,
Iosb : VECTOR [4, WORD], ! I/O status block.
Sts;
Function = IO$_SETMODE + IO$M_WRTATTN;
Sts = $QIOW(CHAN = .Mbx_Chan,
FUNC = .Function,
IOSB = Iosb,
P1 = Mbx_Ast_Rtn);
IF .sts THEN sts = .Iosb[0];
IF NOT .sts THEN LIB$SIGNAL(.Sts);
END;
%SBTTL 'Mbx_Ast_Rtn'
ROUTINE Mbx_Ast_Rtn : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called at AST level whenever a mailbox message
! arrives in the mailbox associated with TERM_DESC. If the message
! is a hangup notification the user will be 1) notified his outgoing
! connection is no longer present (technically there is no longer
! a channel to the device represented in TERM_DESC) and 2)
!
! CALLING SEQUENCE:
!
! MBX_AST_RTN();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! TERM_DESC
! MBX_CHAN - The channel to the mailbox associated with TERM_DESC.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! MBX_CHAN
!
! COMPLETION CODES:
!
! SS$_NORMAL or error condition.
!
! SIDE EFFECTS:
!
! A message may be output to the user if his outgoing session is
! no longer valid.
!
!--
BEGIN
LOCAL
Function,
Iosb : VECTOR [4, WORD],
Mbx_Msg : VECTOR [124, BYTE],
Sts;
Function = IO$_READVBLK;
Sts = $QIOW(CHAN = .Mbx_Chan,
FUNC = .Function,
IOSB = Iosb,
P1 = Mbx_Msg,
P2 = 100);
IF .Sts THEN Sts = .Iosb[0];
IF NOT .sts THEN LIB$SIGNAL(.Sts);
IF .Mbx_Msg<0,16> EQL MSG$_TRMHANGUP
THEN
BEGIN
! asn_wth_mbx(term_desc, %REF(100), %REF(100), term_chan, mbx_chan);
$DASSGN(CHAN = .mbx_chan);
mbx_chan = 0;
LIB$SIGNAL(SS$_HANGUP)
END
ELSE
Term_Hangup();
END;
%SBTTL 'Send_Break_TTY'
GLOBAL ROUTINE Send_Break_TTY =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine sends a break to the user's current terminal line.
!
!
! CALLING SEQUENCE:
!
! STATUS = Send_Break_TTY ();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! Term_Desc - The current outgoing terminal line.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! Return status from $QIOW
!
! SIDE EFFECTS:
!
! A break is sent to the user's outgoing terminal line.
!
!--
BEGIN
LOCAL
Char : VECTOR [2], ! Terminal characteristics.
Iosb : VECTOR [4, WORD], ! I/O status block.
Parity_Flags,
Sts;
Sts = $QIOW(CHAN = .Term_Chan,
FUNC = IO$_SENSEMODE,
IOSB = Iosb,
P1 = Char);
IF .Sts THEN Sts = .Iosb [0];
IF NOT .Sts THEN RETURN .Sts;
Parity_Flags<4,16> = .Iosb [3];
Sts = $QIOW(CHAN = .Term_Chan,
FUNC = IO$_SETMODE,
IOSB = Iosb,
P1 = Char,
P5 = (.Parity_Flags OR TT$M_BREAK));
IF .Sts THEN Sts = .Iosb [0];
IF NOT .Sts THEN RETURN .Sts;
LIB$WAIT(%REF(%E'0.25'));
Sts = $QIOW(CHAN = .Term_Chan,
FUNC = IO$_SETMODE,
IOSB = Iosb,
P1 = Char,
P5 = .Parity_Flags);
IF (.Sts) THEN Sts = .Iosb [0];
Send_Break_TTY_Flag = 0;
RETURN .Sts;
END;
%SBTTL 'DO_RECEIVE_QIO'
ROUTINE DO_RECEIVE_QIO =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called to perform a QIO input from the terminal. This
! ensures that there is usually a receive buffer pending.
!
! CALLING SEQUENCE:
!
! STATUS = DO_RECEIVE_QIO ();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! RCV_EOL - Receive end-of-line character
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! IO_STATUS - IOSB for the QIO
! RCV_BUFFER - Data input from terminal
!
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! TERM_EFN is set when I/O completes
!
!--
BEGIN
LOCAL
QIO_FUNC,
TERMINATOR : VECTOR [2, LONG],
STATUS; ! For status of QIO call
!
! Initialize the terminating characters for the QIO. Only terminate
! on the end-of-line character and a control-Y
!
TERMINATOR [0] = 0;
TERMINATOR [1] = 1^.RCV_EOL OR 1^CHR_CTL_Y;
IF .IBM_CHAR GEQ 0 THEN TERMINATOR [1] = .TERMINATOR [1] OR 1^.IBM_CHAR;
! Need IBM turnaround?
!
! Initialize the QIO function
! Always purge typeahead
!
QIO_FUNC = IO$_TTYREADALL OR IO$M_NOECHO OR IO$M_PURGE;
RETURN $QIO (CHAN = .TERM_CHAN, EFN = TERM_EFN, FUNC = .QIO_FUNC, IOSB = IO_STATUS,
P1 = RECV_BUFFER, P2 = RECV_BUFF_SIZE, P4 = TERMINATOR);
END; ! End of DO_RECEIVE_QIO
%SBTTL 'DO_CONS_QIO'
ROUTINE DO_CONS_QIO =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called to perform a QIO input from the terminal. This
! ensures that there is usually a receive buffer pending.
!
! CALLING SEQUENCE:
!
! STATUS = DO_CONS_QIO ();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! RCV_EOL - Receive end-of-line character
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! IO_STATUS - IOSB for the QIO
! RCV_BUFFER - Data input from terminal
!
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! TERM_EFN is set when I/O completes
!
!--
BEGIN
EXTERNAL
ABT_CUR_FILE,
ABT_ALL_FILE,
DEBUG_FLAG,
TYP_STS_FLAG;
LOCAL
I, ! Random index variable
TERMINATOR : VECTOR [2, LONG], ! Pointer at terminator mask
TERM_MASK : VECTOR [8, LONG], ! Terminator mask
STATUS; ! For status of QIO call
LITERAL
CONS_BUFF_SIZE = 1;
OWN
CONS_STATUS : VECTOR [4, WORD],
CONS_BUFFER : VECTOR [CONS_BUFF_SIZE, BYTE];
!
! AST routine for console
!
ROUTINE CONS_AST (DUMMY) =
BEGIN
IF .CONS_STATUS [0]
THEN
SELECT .CONS_STATUS [2] OF
SET
[CHR_CTL_Z] :
ABT_ALL_FILE = TRUE;
[CHR_CTL_X] :
ABT_CUR_FILE = TRUE;
[CHR_CTL_Y] :
RETURN SS$_NORMAL;
[CHR_CTL_C] :
BEGIN
FORCE_TIMEOUT = TRUE;
FORCE_ABORT = TRUE;
END;
[CHR_CTL_D] :
DEBUG_FLAG = NOT .DEBUG_FLAG;
[CHR_CTL_A] :
TYP_STS_FLAG = TRUE;
[CHR_CTL_M] :
FORCE_TIMEOUT = TRUE;
[CHR_CTL_Z, CHR_CTL_X, CHR_CTL_A, CHR_CTL_M, CHR_CTL_C] :
! Make sure what we did gets noticed, even if we are currently waiting
! forever for input.
IF .FORCE_TIMEOUT OR .SEND_TIMEOUT EQL 0 THEN $SETEF (EFN = TIME_EFN);
TES;
IF .CONS_STATUS [0] NEQ SS$_CANCEL AND .CONS_STATUS [0] NEQ SS$_ABORT
THEN
RETURN DO_CONS_QIO ()
ELSE
RETURN SS$_NORMAL;
END;
!
! Start of main portion of DO_CONS_QIO
!
TERMINATOR [0] = 32; ! Length of terminator mask in bytes
TERMINATOR [1] = TERM_MASK; ! Address of mask
INCR I FROM 0 TO 7 DO
TERM_MASK [.I] = -1; ! All characters are terminators
RETURN $QIO (CHAN = .CONS_CHAN, EFN = CONS_EFN, FUNC = IO$_TTYREADALL OR IO$M_NOECHO,
IOSB = CONS_STATUS, ASTADR = CONS_AST, P1 = CONS_BUFFER, P2 = CONS_BUFF_SIZE,
P4 = TERMINATOR);
END; ! End of DO_CONS_QIO
%SBTTL 'TERM_CONNECT'
GLOBAL ROUTINE TERM_CONNECT =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine TERM_CONNECT will enable two terminal-like devices,
! MY_TERM and TERM_NAME, to communicate with each other. Anything
! that the user types on his terminal, MYTERM, will be sent to the
! other device, TERM_NAME, over the terminal line TERM_CHAN.
! Anything that TERM_NAME cares to output will be sent to MYTERM.
! The main routine TERM_CONNECT performs the initialization. It
! opens the input and output files and connects streams.
!
! CALLING SEQUENCE:
!
! TERM_CONNECT();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! TERM_DESC - Descriptor of a vector of ASCII characters that represent
! the name of the terminal to use.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! TERM_CHAN - Channel number used by the terminal line to TERM_DESC.
!
! COMPLETION CODES:
!
! SS$_NORMAL or error condition.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
EXTERNAL ROUTINE
LOG_OPEN, ! Open log file
LOG_CLOSE; ! Close log file
LITERAL
OUT_BUFLEN = 80, ! Max # of char. in output buffer
INP_BUFSIZ = 80, ! Max # of char. in input buffer
NUM_OUT_BUF = 2, ! # of output buffers per device
NUM_IN_BUF = 2, ! # of input buffers per device
MYT = 0, ! Device MY_TERM
TRM = 1, ! Device TERM_NAME
OFFSET = 1, ! IOSB : offset to terminator
EOFSIZ = 3, ! IOSB : terminator size
T_EFN_DISP = NUM_OUT_BUF,
XITEFN = 2*NUM_OUT_BUF + 1, ! Exit event flag number
EFN_MASK = (1^XITEFN - 1) AND ( NOT 1); ! Mask of flags set by CONNECT
STRUCTURE
IOSB_VECTOR [D, BUFNUM, INFO; NUMBUF] =
[NUMBUF*16]
(IOSB_VECTOR + (D*NUMBUF + BUFNUM)*8 + 2*INFO)<0, 16, 0>,
BUFFER_VECTOR [D, BUFNUM; NUMBUF, BUFSIZ] =
[NUMBUF*BUFSIZ*2 + NUMBUF]
(BUFFER_VECTOR + (D*NUMBUF + BUFNUM)*BUFSIZ + D);
OWN
BTIMUP : VECTOR [4, WORD], ! Time limit in binary format
CHANNEL : VECTOR [2, LONG], ! Contains channel #s
CHR_COUNT : VECTOR [2, WORD] INITIAL (0), ! # of char. in out buffer
ESC_FLG : INITIAL (FALSE), ! Was last char. the ESCAPE_CHR
IN_IOSB : IOSB_VECTOR [NUM_IN_BUF], ! IOSB status block
INP_BUF : BUFFER_VECTOR [NUM_IN_BUF, INP_BUFSIZ], ! Input buffers
MSG : VECTOR [80, BYTE], ! Combined escape message
MSG_DES : BLOCK [8, BYTE], ! Descriptor for message
OUT_BUF : BUFFER_VECTOR [NUM_OUT_BUF, OUT_BUFLEN], ! Output buffers
OUT_BUFNUM : VECTOR [2, BYTE], ! Present output buffer
OUT_EFN : VECTOR [2, BYTE], ! Present event flag #
OUT_PTR : VECTOR [2, LONG], ! CS-pointer for output buffer
MYT_QIO_FUNC, ! Function for QIO input for my terminal
ESC_CHR_LEN, ! Length of escape character message
ESC_CHR_MSG : VECTOR [30, BYTE], ! Escape character message
STATE; ! Used by $READEF to store state of EFs
BIND
CON_MSG_1 = %ASCID'Connecting to ',
CON_MSG_2 = %ASCID'. Type ',
CON_MSG_3 = %ASCID'C to return to VAX/VMS Kermit-32]',
CON_MSG_4 = %ASCID'Returning to VAX/VMS Kermit-32]';
MAP
CON_MSG_1 : BLOCK [8, BYTE],
CON_MSG_2 : BLOCK [8, BYTE],
CON_MSG_3 : BLOCK [8, BYTE],
CON_MSG_4 : BLOCK [8, BYTE];
BIND
ATIMUP = %ASCID'0 00:00:00.050', ! Time to wait for more output
MYT_CHAN = CHANNEL [1],
MY_TERM = %ASCID'SYS$INPUT:';
LABEL
CONN_STREAMS;
LOCAL
CON_MSG : VECTOR [80, BYTE],
CON_MSG_DESC : BLOCK [8, BYTE],
STATUS;
%SBTTL 'TERM_CONNECT -- TYPE_OUT_BUF'
ROUTINE TYPE_OUT_BUF (DEV) =
!++
! This routine send the contents of the output buffer to the other
! device. It also resets the OUT_PTR and the CHR_COUNT and it
! increments OUT_EFN and OUT_BUFNUM.
!--
BEGIN
LOCAL
STATUS;
! Check to make sure exit flag not set before $QIO
IF (STATUS = $READEF (EFN = XITEFN, STATE = STATE)) NEQ SS$_WASCLR
THEN
BEGIN
$SETEF (EFN = .OUT_EFN [.DEV]);
RETURN .STATUS;
END;
$WAITFR (EFN = .OUT_EFN [.DEV]);
$CLREF (EFN = .OUT_EFN [.DEV]);
IF $READEF (EFN = XITEFN, STATE = STATE) EQL SS$_WASCLR
THEN
STATUS = $QIO (CHAN = .CHANNEL [.DEV], EFN = .OUT_EFN [.DEV],
FUNC = IO$_WRITEVBLK OR IO$M_NOFORMAT, P1 = OUT_BUF [.DEV, .OUT_BUFNUM [.DEV]],
P2 = .CHR_COUNT [.DEV])
ELSE
BEGIN
$SETEF (EFN = .OUT_EFN [.DEV]);
RETURN .STATUS;
END;
CHR_COUNT [.DEV] = 0;
OUT_EFN [.DEV] = .OUT_EFN [.DEV] + 1;
IF (OUT_BUFNUM [.DEV] = .OUT_BUFNUM [.DEV] + 1) GEQ NUM_OUT_BUF
THEN
BEGIN
OUT_BUFNUM [.DEV] = 0;
OUT_EFN [.DEV] = .DEV*T_EFN_DISP + 1;
END;
OUT_PTR [.DEV] = CH$PTR (OUT_BUF [.DEV, .OUT_BUFNUM [.DEV]]);
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
$SETEF (EFN = XITEFN);
END;
RETURN .STATUS;
END;
%SBTTL 'TERM_CONNECT -- TIME_UP'
ROUTINE TIME_UP (OUTEFN) : NOVALUE =
!++
! AST routine called 0.1 second after first character is input. It calls
! TYPE_OUT_BUF to transmit output buffer.
!--
BEGIN
LOCAL
DEV;
IF (.OUTEFN - T_EFN_DISP) LEQ 0
THEN
DEV = 0 ! Device was MY_TERM
ELSE
DEV = 1; ! Device was TERM_NAME
TYPE_OUT_BUF (.DEV);
END; ! End of TIME_UP
%SBTTL 'TERM_CONNECT -- STORE_INPUT'
ROUTINE STORE_INPUT (DEV, INP_POINTER, NUM_CHR_IN) : NOVALUE =
!++
! This routine stores the input buffer in the output buffer and keeps
! track of the number of characters in the output buffer. It also
! calls TYPE_OUT_BUF when the output buffer is full and it sets up
! the timer routine TIME_UP.
!--
BEGIN
EXTERNAL ROUTINE
LOG_CHAR, ! Routine to log characters
GEN_PARITY; ! Routine to generate parity
LOCAL
STATUS;
IF (STATUS = $READEF (EFN = XITEFN, STATE = STATE)) NEQ SS$_WASCLR THEN RETURN;
IF .NUM_CHR_IN EQL 0 THEN RETURN .STATUS;
IF .NUM_CHR_IN + .CHR_COUNT [.DEV] GTR OUT_BUFLEN
THEN
BEGIN
!
! If we don't have enough room in the buffer for all of the characters, call
! ourself to dump what will fit, then proceed with what remains.
!
LOCAL
SAVED_CHR_CNT; ! Saved character count
SAVED_CHR_CNT = OUT_BUFLEN - .CHR_COUNT [.DEV];
NUM_CHR_IN = .NUM_CHR_IN - .SAVED_CHR_CNT;
STORE_INPUT (.DEV, .INP_POINTER, .SAVED_CHR_CNT);
INP_POINTER = CH$PLUS (.INP_POINTER, .SAVED_CHR_CNT);
END;
IF .CHR_COUNT [.DEV] EQL 0
THEN
BEGIN
STATUS = $SETIMR (DAYTIM = BTIMUP, ASTADR = TIME_UP, REQIDT = .OUT_EFN [.DEV]);
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
$SETEF (EFN = XITEFN);
RETURN .STATUS;
END;
END;
! We must generate parity for the communications terminal
IF .DEV EQL 0
THEN
BEGIN
LOCAL
POINTER;
POINTER = .INP_POINTER;
DECR I FROM .NUM_CHR_IN TO 1 DO
CH$WCHAR_A (GEN_PARITY (CH$RCHAR_A (POINTER)), OUT_PTR [.DEV]);
END
ELSE
OUT_PTR [.DEV] = CH$MOVE (.NUM_CHR_IN, .INP_POINTER, .OUT_PTR [.DEV]);
!
! If we want logging, do it now
!
IF (.DEV EQL 1 OR .ECHO_FLAG) AND .SESSION_OPEN AND .SESSION_LOGGING
THEN
BEGIN
LOCAL
STATUS,
POINTER;
POINTER = .INP_POINTER;
DECR I FROM .NUM_CHR_IN TO 1 DO
IF NOT LOG_CHAR (CH$RCHAR_A (POINTER), SESSION_RAB)
THEN
BEGIN
SESSION_LOGGING = FALSE;
EXITLOOP;
END;
END;
IF (CHR_COUNT [.DEV] = .CHR_COUNT [.DEV] + .NUM_CHR_IN) GEQ OUT_BUFLEN - INP_BUFSIZ
THEN
BEGIN
$CANTIM (REQIDT = .OUT_EFN [.DEV]);
TYPE_OUT_BUF (.DEV);
END;
RETURN .STATUS;
END; ! End of STORE_INPUT
%SBTTL 'TERM_CONNECT -- MYTINP'
ROUTINE MYTINP (INP_BUFNUM) =
!++
! This AST routine gets characters from the channel MYT_CHAN and outputs
! them on the channel TERM_CHAN. It also checks to see if the exit
! characters have been typed. If they have been typed, MYTINP sets the
! event flag XITEFN. INP_BUFNUM contains the # of the input buffer.
!--
BEGIN
OWN
STATUS,
NUM_CHR_IN;
%SBTTL 'TERM_CONNECT -- MYTINP -- CHK_FOR_EXIT'
ROUTINE CHK_FOR_EXIT (INP_BUFNUM) =
!++
! This routine checks to see if the exit characters have been typed. It
! returns TRUE if found and FALSE if not. If only 1 ESCAPE_CHR found
! then ESC_FLG is set to TRUE.
!--
BEGIN
ROUTINE TYPE_MSG (MSG_DESC, OPEN_FLAG, CLOSE_FLAG, CRLF_FLAG) : NOVALUE =
BEGIN
MAP
MSG_DESC : REF BLOCK [8, BYTE];
IF .OPEN_FLAG
THEN
BEGIN
STORE_INPUT (TRM, CH$PTR (UPLIT BYTE(%C'[')), 1);
IF .NODE_DESC [DSC$W_LENGTH] GTR 0
THEN
STORE_INPUT (TRM,
CH$PTR (.NODE_DESC [DSC$A_POINTER]), .NODE_DESC [DSC$W_LENGTH]);
END;
STORE_INPUT (TRM, CH$PTR (.MSG_DESC [DSC$A_POINTER]), .MSG_DESC [DSC$W_LENGTH]);
IF .CLOSE_FLAG THEN STORE_INPUT (TRM, CH$PTR (UPLIT BYTE(%C']')), 1);
IF .CRLF_FLAG THEN STORE_INPUT (TRM, CH$PTR (UPLIT BYTE(CHR_CRT, CHR_LFD)), 2);
END;
LOCAL
EAT_CHR, ! Number of input characters to eat
ESC_PTR,
INDEX : INITIAL (0), ! Displacement of ESC from beginning of buffer
PTR0; ! Points to beginning of input buffer
PTR0 = CH$PTR (INP_BUF [MYT, .INP_BUFNUM]);
IF .ESC_FLG EQL TRUE ! ESCAPE_CHR was previously typed.
THEN
BEGIN
INDEX = 0;
ESC_PTR = .PTR0;
ESC_FLG = FALSE;
END
ELSE
IF (ESC_PTR = CH$FIND_CH (.NUM_CHR_IN, .PTR0, .ESCAPE_CHR)) EQL 0
THEN
RETURN FALSE
ELSE
BEGIN
INDEX = CH$DIFF (.PTR0, .ESC_PTR);
IF .INDEX NEQ (NUM_CHR_IN = .NUM_CHR_IN - 1)
THEN
BEGIN
CH$COPY (.NUM_CHR_IN - .INDEX, CH$PLUS (.ESC_PTR, 1), 0,
.NUM_CHR_IN - .INDEX, .ESC_PTR);
END
ELSE ! ESCAPE_CHR was last character.
BEGIN
ESC_FLG = TRUE;
RETURN FALSE;
END;
END;
EAT_CHR = 0; ! No characters to eat
SELECTONE CH$RCHAR (.ESC_PTR) OF
SET
['?'] :
BEGIN
TYPE_MSG (%ASCID'Escape commands are:', TRUE, FALSE, TRUE);
Type_Msg (%ASCID' B - Sends a break', FALSE, FALSE, TRUE);
TYPE_MSG (%ASCID' C - Return to VAX/VMS Kermit-32', FALSE, FALSE, TRUE);
TYPE_MSG (%ASCID' Q - Suspend logging to session log file (if any)', FALSE,
FALSE, TRUE);
TYPE_MSG (%ASCID' R - Resume logging to session log file (if any)', FALSE,
FALSE, TRUE);
TYPE_MSG (%ASCID' S - Show status', FALSE, FALSE, TRUE);
TYPE_MSG (%ASCID' 0 - Send a null', FALSE, FALSE, TRUE);
TYPE_MSG (%ASCID' ? - Type this text', FALSE, FALSE, TRUE);
TYPE_MSG (%ASCID' ', FALSE, FALSE, FALSE);
STORE_INPUT (TRM, ESC_CHR_MSG, .ESC_CHR_LEN);
TYPE_MSG (%ASCID' - Send escape character', FALSE, TRUE, TRUE);
EAT_CHR = 1;
END;
['B', 'b'] :
BEGIN
Send_Break_TTY_Flag = 1;
EAT_CHR = 1;
END;
['C', 'c'] :
BEGIN
NUM_CHR_IN = .INDEX;
RETURN TRUE;
END;
['Q', 'q'] :
BEGIN
BIND
NO_LOG_TEXT = %ASCID'logging already disabled',
STOP_LOG_TEXT = %ASCID'logging disabled';
IF .SESSION_LOGGING
THEN
TYPE_MSG (STOP_LOG_TEXT, TRUE, TRUE, TRUE)
ELSE
TYPE_MSG (NO_LOG_TEXT, TRUE, TRUE, TRUE);
SESSION_LOGGING = FALSE;
EAT_CHR = 1;
END;
['R', 'r'] :
BEGIN ! Resume logging
BIND
NO_LOG_TEXT = %ASCID'no log file to enable',
START_LOG_TEXT = %ASCID'logging enabled';
SESSION_LOGGING = .SESSION_OPEN;
IF .SESSION_LOGGING
THEN
TYPE_MSG (START_LOG_TEXT, TRUE, TRUE, TRUE)
ELSE
TYPE_MSG (NO_LOG_TEXT, TRUE, TRUE, TRUE);
EAT_CHR = 1;
END;
['S', 's'] :
BEGIN
TYPE_MSG (%ASCID'Connected to ', TRUE, FALSE, FALSE);
TYPE_MSG (TERM_DESC, FALSE, FALSE, TRUE);
TYPE_MSG (%ASCID' Escape character: "', FALSE, FALSE, FALSE);
STORE_INPUT (TRM, ESC_CHR_MSG, .ESC_CHR_LEN);
TYPE_MSG (%ASCID'"', FALSE, FALSE, TRUE);
TYPE_MSG (%ASCID' Local echo: ', FALSE, FALSE, FALSE);
IF .ECHO_FLAG
THEN
TYPE_MSG (%ASCID'On', FALSE, FALSE, TRUE)
ELSE
TYPE_MSG (%ASCID'Off', FALSE, FALSE, TRUE);
TYPE_MSG (%ASCID' Parity: ', FALSE, FALSE, FALSE);
CASE .PARITY_TYPE FROM PR_MIN TO PR_MAX OF
SET
[PR_NONE] :
TYPE_MSG (%ASCID'None', FALSE, FALSE, TRUE);
[PR_ODD] :
TYPE_MSG (%ASCID'Odd', FALSE, FALSE, TRUE);
[PR_EVEN] :
TYPE_MSG (%ASCID'Even', FALSE, FALSE, TRUE);
[PR_MARK] :
TYPE_MSG (%ASCID'Mark', FALSE, FALSE, TRUE);
[PR_SPACE] :
TYPE_MSG (%ASCID'Space', FALSE, FALSE, TRUE);
TES;
TYPE_MSG (%ASCID' Logging: ', FALSE, FALSE, FALSE);
IF .SESSION_OPEN GTR 0
THEN
BEGIN
TYPE_MSG (SESSION_DESC, FALSE, FALSE, FALSE);
IF .SESSION_LOGGING
THEN
TYPE_MSG (%ASCID' Enabled', FALSE, TRUE, TRUE)
ELSE
TYPE_MSG (%ASCID' Disabled', FALSE, TRUE, TRUE);
END
ELSE
TYPE_MSG (%ASCID' None specifed', FALSE, TRUE, TRUE);
EAT_CHR = 1; ! Eat the "S"
END;
[.ESCAPE_CHR] :
CH$WCHAR (.ESCAPE_CHR, .ESC_PTR); ! Write the escape character
['0'] :
CH$WCHAR (CHR_NUL, .ESC_PTR); ! Write a null
[OTHERWISE] :
BEGIN ! Send a bell char. to MY_TERM
STORE_INPUT (TRM, CH$PTR (UPLIT BYTE(CHR_BEL)), 1);
EAT_CHR = 1; ! Eat the character
END;
TES;
IF .EAT_CHR GTR 0
THEN
IF (NUM_CHR_IN = .NUM_CHR_IN - .EAT_CHR) NEQ .INDEX
THEN
CH$COPY (.NUM_CHR_IN - .INDEX, CH$PLUS (.ESC_PTR, .EAT_CHR), CHR_NUL,
.NUM_CHR_IN - .INDEX, .ESC_PTR);
RETURN FALSE;
END; ! End of CHK_FOR_EXIT
%SBTTL 'TERM_CONNECT -- MYTINP'
! Main portion of MYTINP
IF (STATUS = $READEF (EFN = XITEFN, STATE = STATE)) NEQ SS$_WASCLR THEN RETURN .STATUS;
NUM_CHR_IN = .IN_IOSB [MYT, .INP_BUFNUM, OFFSET] + .IN_IOSB [MYT, .INP_BUFNUM, EOFSIZ];
IF .NUM_CHR_IN NEQ 0
THEN
IF CHK_FOR_EXIT (.INP_BUFNUM)
THEN
BEGIN
$CANTIM ();
$SETEF (EFN = XITEFN); ! Exit characters typed. Set flag.
RETURN 1;
END
ELSE
STORE_INPUT (MYT, CH$PTR (INP_BUF [MYT, .INP_BUFNUM]), .NUM_CHR_IN);
! Store char.
IF (STATUS = $READEF (EFN = XITEFN, STATE = STATE)) EQL SS$_WASCLR
THEN
! If we got some characters, then queue up the next read for lots of
! characters with a 0 timeout (get what we can). Otherwise queue up
! a read for one character waiting forever.
IF .NUM_CHR_IN GTR 0 OR .INP_BUFNUM NEQ 0
THEN
! Queue up a read for the console terminal
STATUS = $QIO (CHAN = .MYT_CHAN, FUNC = .MYT_QIO_FUNC OR IO$M_TIMED,
ASTADR = MYTINP, P1 = INP_BUF [MYT, .INP_BUFNUM], P2 = INP_BUFSIZ, P3 = 0,
ASTPRM = .INP_BUFNUM, IOSB = IN_IOSB [MYT, .INP_BUFNUM, 0])
ELSE
STATUS = $QIO (CHAN = .MYT_CHAN, FUNC = .MYT_QIO_FUNC, ASTADR = MYTINP,
P1 = INP_BUF [MYT, .INP_BUFNUM], P2 = 1, ASTPRM = .INP_BUFNUM,
IOSB = IN_IOSB [MYT, .INP_BUFNUM, 0]);
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
$SETEF (EFN = XITEFN);
END;
RETURN .STATUS;
END; ! End of MYTINP
%SBTTL 'TERM_CONNECT -- TRMINP'
ROUTINE TRMINP (INP_BUFNUM) =
!++
! This AST routine receives characters from the channel TERM_CHAN and
! outputs the characters to the channel MYT_CHAN. INP_BUFNUM contains
! the number of the input buffer.
!--
BEGIN
LOCAL
NUM_CHR_IN,
STATUS;
IF (STATUS = $READEF (EFN = XITEFN, STATE = STATE)) NEQ SS$_WASCLR THEN RETURN .STATUS;
NUM_CHR_IN = .IN_IOSB [TRM, .INP_BUFNUM, OFFSET] + .IN_IOSB [TRM, .INP_BUFNUM, EOFSIZ];
IF .NUM_CHR_IN NEQ 0
THEN
STORE_INPUT (TRM, CH$PTR (INP_BUF [TRM, .INP_BUFNUM]),
.NUM_CHR_IN);
IF (STATUS = $READEF (EFN = XITEFN, STATE = STATE)) EQL SS$_WASCLR
THEN
BEGIN
! Now that there are no pending I/Os we can call the routine to send
! a break signal to the outgoing terminal line if necessary.
! Pending I/Os would block the QIO SETMODE instruction from taking
! place, effectively hanging kermit until the current I/O read
! completes (if ever).
IF .Send_Break_TTY_Flag EQL 1
THEN Send_Break_TTY ();
!
! If we actually got something input, then queue up a read with a 0
! timeout for the whole buffer. Otherwise, queue up a single character
! read, if this is the first buffer.
!
IF .NUM_CHR_IN GTR 0 OR .INP_BUFNUM NEQ 0
THEN
STATUS = $QIO (CHAN = .TERM_CHAN,
FUNC = IO$_TTYREADALL OR IO$M_NOECHO OR IO$M_TIMED, ASTADR = TRMINP,
P1 = INP_BUF [TRM, .INP_BUFNUM], P2 = INP_BUFSIZ, P3 = 0,
IOSB = IN_IOSB [TRM,
.INP_BUFNUM, 0], ASTPRM = .INP_BUFNUM)
ELSE
STATUS = $QIO (CHAN = .TERM_CHAN, FUNC = IO$_TTYREADALL OR IO$M_NOECHO,
ASTADR = TRMINP, P1 = INP_BUF [TRM, .INP_BUFNUM], P2 = 1,
IOSB = IN_IOSB [TRM,
.INP_BUFNUM, 0], ASTPRM = .INP_BUFNUM);
END;
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
$SETEF (EFN = XITEFN);
END;
RETURN .STATUS;
END; ! End of TRMINP
%SBTTL 'TERM_CONNECT -- ESC_MSG'
ROUTINE ESC_MSG (ESC_TEXT) =
BEGIN
MAP
ESC_TEXT : REF VECTOR [, BYTE];
SELECTONE .ESCAPE_CHR OF
SET
[CHR_NUL, 0] :
BEGIN
BIND
NUL_TXT = %ASCID'^@ or control-space on VT-100';
MAP
NUL_TXT : BLOCK [8, BYTE];
CH$MOVE (.NUL_TXT [DSC$W_LENGTH], CH$PTR (.NUL_TXT [DSC$A_POINTER]),
CH$PTR (.ESC_TEXT));
RETURN .NUL_TXT [DSC$W_LENGTH];
END;
[CHR_RS, %O'36'] :
BEGIN
BIND
RS_TXT = %ASCID'^^ or ^~ on VT-100';
MAP
RS_TXT : BLOCK [8, BYTE];
CH$MOVE (.RS_TXT [DSC$W_LENGTH], CH$PTR (.RS_TXT [DSC$A_POINTER]),
CH$PTR (.ESC_TEXT));
RETURN .RS_TXT [DSC$W_LENGTH];
END;
[CHR_US, %O'37'] :
BEGIN
BIND
US_TXT = %ASCID'^_ or ^? on VT-100';
MAP
US_TXT : BLOCK [8, BYTE];
CH$MOVE (.US_TXT [DSC$W_LENGTH], CH$PTR (.US_TXT [DSC$A_POINTER]),
CH$PTR (.ESC_TEXT));
RETURN .US_TXT [DSC$W_LENGTH];
END;
[1 TO %O'37'] :
BEGIN
ESC_TEXT [0] = %C'^';
ESC_TEXT [1] = .ESCAPE_CHR + %O'100';
RETURN 2;
END;
[CHR_DEL, %O'177'] :
BEGIN
ESC_TEXT = 'DEL';
RETURN 3;
END;
TES;
RETURN 0; ! No escape character?
END; ! End of ESC_MSG
%SBTTL 'TERM_CONNECT -- COMND_TRANSMIT'
GLOBAL ROUTINE COMND_TRANSMIT : NOVALUE = ! and below
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine transmits a file (or files) to the remote side one character
! at a time. It can display the numbers of the lines as they are transfered,
! or echo back to the controling terminal from the remote so that progress of
! the transmit can be monitored. It can also delay between 0 and .9 secs
! after each carriage return for machines that cannot keep up with the
! transfer. The file is transmitted blindly (except line feeds are removed)
! with no error correction or packets. This is useful for sending files to
! systems where KERMIT is unavailable.
!
! CALLING SEQUENCE:
!
! COMND_TRANSMIT ();
!
! IMPLICIT INPUTS:
!
! TRANS_DELAY - time (0.0 - 0.9 seconds) to delay after carriage return is transmitted.
! TRANS_ECHO_FLAG - flags whether data from remote side is echoed to the console terminal (ON);
! or line numbers are printed during transmit.
!
! IMPLICIT OUTPUTS:
!
! None
!
! COMPLETION_CODES:
!
! Standard status values.
!
! SIDE EFFECTS:
!
! Line feed characters are not transmitted.
!--
BEGIN
EXTERNAL
FILE_SIZE,
FILE_NAME : VECTOR [CH$ALLOCATION (MAX_FILE_NAME)],
TY_FIL;
EXTERNAL ROUTINE
FILE_OPEN;
LOCAL
STATUS, ! KERMIT status values
TRANSMIT_DELAY : VECTOR [CH$ALLOCATION(8)], ! String for transmit delay
TR_DESC : BLOCK [8,BYTE]; ! Descriptor for transmit delay
OWN
SAVE_FILE_NAME : VECTOR [CH$ALLOCATION (MAX_FILE_NAME)], ! File name
SAVE_FILE_SIZE, ! File size
SAVE_TY_FIL, ! File type out flag
DELAY : VECTOR [2,LONG,SIGNED]; ! Time after transmitting carriage return
BIND
D_TIME = PLIT('0 ::00.'); ! First part of delta time used to find delay
%SBTTL 'TERM_CONNECT -- TRANSMIT_FILE'
ROUTINE TRANSMIT_FILE = ! and below
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine transmits the current file (that has already been opened) and
! then opens the next file (if there is one).
!
!--
BEGIN ! TRANSMIT_FILE
EXTERNAL
ABT_ALL_FILE,
ABT_CUR_FILE,
SMG$_PASALREXI, ! Pasteboard exits for device msg
FLAG_FILE_OPEN;
EXTERNAL ROUTINE
NEXT_FILE,
FILE_OPEN,
FILE_CLOSE,
TT_TEXT,
TT_CRLF : NOVALUE,
SY_DISMISS : NOVALUE,
SMG$CREATE_PASTEBOARD : ADDRESSING_MODE (GENERAL),
SMG$DELETE_PASTEBOARD : ADDRESSING_MODE (GENERAL);
LOCAL
STATUS, ! KERMIT status values
ISTAT, ! qiow status values
PASTE_STAT, ! SMG status values
NEW_ID : VECTOR [1, LONG, UNSIGNED]; ! Dummy new pasteboard id
OWN
LINE_NUM; ! Line number counter
%SBTTL 'TERM_CONNECT -- TRANSMIT_CHARACTERS'
ROUTINE TRANSMIT_CHARACTERS : NOVALUE = ! and below
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is a loop that transmits all of the characters in a file,
! one character per pass.
!
!--
BEGIN ! TRANSMIT_CHARACTERS
LITERAL
WAIT_EFN = 22,
CHARACTER_LEN = 1;
EXTERNAL ROUTINE
GET_FILE,
TT_NUMBER,
TT_OUTPUT : NOVALUE;
LOCAL
STATUS, ! KERMIT status values
TSTAT, ! timer status values
ISTAT, ! qiow status values
CHARACTER, ! Character from get-a-char routine
TERM_IOSB : VECTOR [4, WORD, UNSIGNED]; ! IO status block for term chan
!
! Begin TRANSMIT_CHARACTERS:
!
DO
BEGIN ! Transmit a character
! Get next character
STATUS = GET_FILE (CHARACTER);
IF .STATUS AND NOT .STATUS EQL KER_EOF AND NOT .CHARACTER EQL CHR_LFD ! Did we get one?
THEN
BEGIN ! Have a character
! Write character out transfer terminal:
ISTAT = $QIOW (CHAN = .TERM_CHAN, EFN = TERM_O_EFN,
FUNC = IO$_WRITEVBLK + IO$M_NOFORMAT,
IOSB = TERM_IOSB,
P1 = CHARACTER, P2 = CHARACTER_LEN);
IF NOT .ISTAT THEN LIB$SIGNAL (.ISTAT);
IF NOT .TERM_IOSB THEN LIB$SIGNAL (.TERM_IOSB);
IF .CHARACTER EQL CHR_CRT
THEN
BEGIN ! Just transmitted a carriage return
IF NOT .DELAY EQL 0
THEN
! Delay desired time:
BEGIN
TSTAT = $SETIMR (EFN = WAIT_EFN, DAYTIM = DELAY);
IF NOT .STATUS THEN LIB$SIGNAL (.TSTAT);
TSTAT = $WAITFR (EFN = WAIT_EFN);
IF NOT .STATUS THEN LIB$SIGNAL (.TSTAT);
END;
IF NOT .TRANS_ECHO_FLAG
THEN
! Purge term_chan typeahead buffer to get rid of the echoed data and type packet number to console:
BEGIN
TSTAT = $QIOW (CHAN = .TERM_CHAN, FUNC = IO$_READVBLK OR IO$M_PURGE,
P1 = INP_BUF [TRM, 0], P2 = 0, IOSB = IN_IOSB [TRM, 0, 0]);
IF NOT .TSTAT THEN LIB$SIGNAL (.TSTAT);
TT_NUMBER (.LINE_NUM);
TT_TEXT (UPLIT (%ASCIZ' '));
TT_OUTPUT ();
LINE_NUM = .LINE_NUM + 1;
END;
END; ! Just transmitted a cariage return
END; ! Have a character
END ! Transmit a character
UNTIL NOT .STATUS OR .STATUS EQL KER_EOF OR NOT .ISTAT OR NOT .TERM_IOSB
OR .FORCE_ABORT OR .ABT_CUR_FILE OR .ABT_ALL_FILE;
END; ! End TRANSMIT_CHARACTERS
!
! Begin TRANSMIT_FILE:
!
FLAG_FILE_OPEN = TRUE;
TT_TEXT (UPLIT (%ASCIZ' File: '));
TT_TEXT (FILE_NAME); ! Type out file name
TT_CRLF ();
FILE_SIZE = .SAVE_FILE_SIZE; ! Reset the file name size
INCR I FROM 0 TO .FILE_SIZE - 1 DO
FILE_NAME [.I] = .SAVE_FILE_NAME [.I];
TY_FIL = .SAVE_TY_FIL; ! Reset type out flag
LINE_NUM = 1; ! Initialize line number counter
IF (STATUS = TERM_OPEN (TRUE)) ! Open the terminal
THEN
BEGIN ! Term open
! Cancel qio's to term_chan to start from scratch:
STATUS = $CANCEL (CHAN = .TERM_CHAN);
IF NOT .STATUS THEN LIB$SIGNAL (.STATUS);
! Test to see if we are supposed to echo from the term_chan to the cons_chan:
IF .TRANS_ECHO_FLAG
THEN
BEGIN ! Echo data
! Clear screen (by creating a default pasteboard using SMG utility):
SY_DISMISS (3); ! Wait a bit so user can see file name
PASTE_STAT = SMG$CREATE_PASTEBOARD (NEW_ID);
IF NOT .PASTE_STAT THEN LIB$SIGNAL (.PASTE_STAT);
! Prepare event flags
$CLREF (EFN = XITEFN);
INCR FLAG FROM 1 TO XITEFN - 1 DO
$SETEF (EFN = .FLAG);
$SETAST (ENBFLG = 0); ! Disable AST until after all QIOs
! Set up read qio's to echo characters to controling terminal
ISTAT = $QIO (CHAN = .TERM_CHAN, FUNC = IO$_TTYREADALL OR IO$M_NOECHO,
ASTADR = TRMINP, P1 = INP_BUF [TRM, 0], P2 = INP_BUFSIZ, P3 = 0,
IOSB = IN_IOSB [TRM, 0, 0], ASTPRM = 0);
IF NOT .ISTAT THEN LIB$SIGNAL (.ISTAT);
INCR INP_BUFNUM FROM 1 TO NUM_IN_BUF - 1 DO
BEGIN
ISTAT = $QIO (CHAN = .TERM_CHAN, FUNC = IO$_TTYREADALL OR
IO$M_NOECHO OR IO$M_TIMED, ASTADR=TRMINP,
P1=INP_BUF[TRM,.INP_BUFNUM], P2=INP_BUFSIZ, P3=0,
IOSB = IN_IOSB [TRM, .INP_BUFNUM, 0], ASTPRM = .INP_BUFNUM);
IF NOT .ISTAT THEN LIB$SIGNAL (.ISTAT);
END;
$SETAST (ENBFLG = 1); ! Enable AST
END ! End echo data
ELSE ! No echo; output line number title to console:
TT_TEXT (UPLIT (%ASCIZ' Transmitting line number... '));
! Start a loop that handles one character per pass:
TRANSMIT_CHARACTERS ();
! Finished transmitting file - close it:
FILE_CLOSE ();
ABT_CUR_FILE = FALSE;
IF .TRANS_ECHO_FLAG THEN SY_DISMISS (1); ! Wait a bit so user can see the end of the file
! Cancel read qio's:
$SETAST (ENBFLG = 0); ! Disable AST's
STATUS = $CANCEL (CHAN = .TERM_CHAN);
IF NOT .STATUS THEN LIB$SIGNAL (.STATUS);
STATUS = $CANCEL (CHAN = .CONS_CHAN);
IF NOT .STATUS THEN LIB$SIGNAL (.STATUS);
! Clear screen again if we did it before - ie delete pasteboard if we created one:
IF .TRANS_ECHO_FLAG AND NOT .PASTE_STAT EQL SMG$_PASALREXI
THEN
BEGIN
PASTE_STAT = SMG$DELETE_PASTEBOARD (NEW_ID);
IF NOT .PASTE_STAT THEN LIB$SIGNAL (.PASTE_STAT);
END
ELSE
BEGIN
TT_CRLF ();
TT_CRLF ();
END;
! Post normal qio's that were canceled:
STATUS = DO_CONS_QIO();
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN KER_RECERR
END;
STATUS = DO_RECEIVE_QIO();
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN KER_RECERR
END;
! Close the console terminal to clean up:
STATUS = TERM_CLOSE ();
IF NOT .STATUS THEN LIB$SIGNAL (.STATUS);
$SETAST (ENBFLG = 1); ! Enable AST's
END; ! Term open
! Determine if there is another file to send.
SAVE_TY_FIL = .TY_FIL; ! Save current type out flag
TY_FIL = FALSE; ! Supress the type out of names
IF NOT .ABT_ALL_FILE AND NOT .FORCE_ABORT THEN STATUS=NEXT_FILE () ELSE STATUS=KER_NOMORFILES;
TY_FIL = .SAVE_TY_FIL; ! Reset the type out flag
ABT_ALL_FILE = FALSE;
FORCE_ABORT = FALSE;
FORCE_TIMEOUT = FALSE;
RETURN .STATUS;
END; ! End TRANSMIT_FILE
!
! Begin COMND_TRANSMIT:
!
! Initialize variables
CHR_COUNT [0] = 0;
CHR_COUNT [1] = 0;
OUT_BUFNUM [0] = 0;
OUT_BUFNUM [1] = 0;
OUT_EFN [0] = 1;
OUT_EFN [1] = T_EFN_DISP + 1;
OUT_PTR [0] = CH$PTR (OUT_BUF [0, .OUT_BUFNUM [0]]);
OUT_PTR [1] = CH$PTR (OUT_BUF [1, .OUT_BUFNUM [1]]);
! Assign channels to devices TERM_NAME and MY_TERM.
STATUS = TERM_OPEN (FALSE); ! Open terminal, no QIO's
IF .CONNECT_FLAG ! Check if TERM_NAME is TT:
THEN
BEGIN
TERM_CLOSE ();
LIB$SIGNAL (KER_CON_SAME);
RETURN KER_CON_SAME;
END;
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
IF NOT .SYS_OUTPUT_OPEN ! Make sure we have terminals
THEN
BEGIN
TERM_CLOSE ();
LIB$SIGNAL (KER_LINTERM); ! Must both be terminals
RETURN KER_LINTERM; ! So give up if not
END;
CHANNEL [0] = .TERM_CHAN;
CHANNEL [1] = .CONS_CHAN;
IF NOT .STATUS
THEN
BEGIN
TERM_CLOSE ();
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
! Have two terminals - Set up delay:
CH$COPY (7,CH$PTR(D_TIME), 1,CH$PTR(TRANS_DELAY), %C ' ', 8,CH$PTR(TRANSMIT_DELAY));
TR_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
TR_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
TR_DESC [DSC$W_LENGTH] = 8;
TR_DESC [DSC$A_POINTER] = TRANSMIT_DELAY;
STATUS = $BINTIM (TIMBUF=TR_DESC, TIMADR=DELAY); ! Calculate delta time
IF NOT .STATUS THEN LIB$SIGNAL (.STATUS);
! Get the first file and try to open it:
SAVE_TY_FIL = .TY_FIL; ! Save current type out flag
TY_FIL = FALSE; ! Supress the type out of names
SAVE_FILE_SIZE = .FILE_SIZE; ! Save the file name size
INCR I FROM 0 TO .FILE_SIZE - 1 DO
SAVE_FILE_NAME [.I] = .FILE_NAME [.I];
! If we can open the file, then transmit it:
IF FILE_OPEN (FNC_READ)
THEN ! Loop to handle one file at a time:
DO
STATUS = TRANSMIT_FILE ()
UNTIL ( NOT .STATUS) OR (.STATUS EQL KER_NOMORFILES)
ELSE
TY_FIL = .SAVE_TY_FIL; ! Reset type out flag
END; ! End COMND_TRANSMIT routine
%SBTTL 'TERM_CONNECT -- INITIALIZATION'
! Initialize variables
CHR_COUNT [0] = 0;
CHR_COUNT [1] = 0;
ESC_FLG = FALSE;
OUT_BUFNUM [0] = 0;
OUT_BUFNUM [1] = 0;
OUT_EFN [0] = 1;
OUT_EFN [1] = T_EFN_DISP + 1;
OUT_PTR [0] = CH$PTR (OUT_BUF [0, .OUT_BUFNUM [0]]);
OUT_PTR [1] = CH$PTR (OUT_BUF [1, .OUT_BUFNUM [1]]);
$BINTIM (TIMBUF = ATIMUP, TIMADR = BTIMUP);
!
! Initialize Connect message
!
ESC_CHR_LEN = ESC_MSG (ESC_CHR_MSG);
CON_MSG_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
CON_MSG_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
CON_MSG_DESC [DSC$A_POINTER] = CON_MSG;
CON_MSG_DESC [DSC$W_LENGTH] = 1 + .NODE_DESC [DSC$W_LENGTH] + .CON_MSG_1 [DSC$W_LENGTH] +
.TERM_DESC [DSC$W_LENGTH] + .CON_MSG_2 [DSC$W_LENGTH] + .ESC_CHR_LEN + .CON_MSG_3 [DSC$W_LENGTH]
;
CH$COPY (1, CH$PTR (UPLIT BYTE(%C'[')), .NODE_DESC [DSC$W_LENGTH],
CH$PTR (.NODE_DESC [DSC$A_POINTER]), .CON_MSG_1 [DSC$W_LENGTH],
CH$PTR (.CON_MSG_1 [DSC$A_POINTER]), .TERM_DESC [DSC$W_LENGTH],
CH$PTR (.TERM_DESC [DSC$A_POINTER]), .CON_MSG_2 [DSC$W_LENGTH],
CH$PTR (.CON_MSG_2 [DSC$A_POINTER]), .ESC_CHR_LEN, CH$PTR (ESC_CHR_MSG),
.CON_MSG_3 [DSC$W_LENGTH], CH$PTR (.CON_MSG_3 [DSC$A_POINTER]), CHR_NUL,
.CON_MSG_DESC [DSC$W_LENGTH], CH$PTR (CON_MSG));
!
! Assign channels to devices TERM_NAME and MY_TERM.
!
STATUS = TERM_OPEN (FALSE); ![054] Open terminal, no QIO's
IF .CONNECT_FLAG ! Check if TERM_NAME is TT:
THEN
BEGIN
TERM_CLOSE ();
LIB$SIGNAL (KER_CON_SAME);
RETURN KER_CON_SAME;
END;
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
IF NOT .SYS_OUTPUT_OPEN ![013] Make sure we have terminals
THEN
BEGIN
TERM_CLOSE ();
LIB$SIGNAL (KER_LINTERM); ![013] Must both be terminals
RETURN KER_LINTERM; ![013] So give up if not
END;
![054] STATUS = $CANCEL (CHAN = .TERM_CHAN); ! Kill all pending QIOs for terminal
CHANNEL [0] = .TERM_CHAN;
CHANNEL [1] = .CONS_CHAN;
![054] STATUS = $CANCEL (CHAN = .CONS_CHAN); ! Kill pending QIOs for console as well
! STATUS = $ASSIGN (DEVNAM = MY_TERM, CHAN = MYT_CHAN);
IF NOT .STATUS
THEN
BEGIN
TERM_CLOSE ();
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
!
! Open any session logging file
!
SESSION_OPEN = FALSE; ! Assume not logging
SESSION_LOGGING = FALSE; ! . . .
IF .SESSION_DESC [DSC$W_LENGTH] GTR 0
THEN
BEGIN
STATUS = LOG_OPEN (SESSION_DESC, SESSION_FAB, SESSION_RAB);
IF .STATUS
THEN
BEGIN
SESSION_OPEN = TRUE;
SESSION_LOGGING = TRUE;
END;
END;
! Prepare event flags
$CLREF (EFN = XITEFN);
INCR FLAG FROM 1 TO XITEFN - 1 DO
$SETEF (EFN = .FLAG);
!
! Set up proper function for reading from console terminal. This is done
! so that the NOECHO flag only gets used if LOCAL_ECHO is OFF.
!
MYT_QIO_FUNC = IO$_TTYREADALL;
IF NOT .ECHO_FLAG THEN MYT_QIO_FUNC = IO$M_NOECHO OR IO$_TTYREADALL;
! Connect streams
CONN_STREAMS :
BEGIN
! Send connect message
LIB$PUT_OUTPUT (%ASCID'');
LIB$PUT_OUTPUT (CON_MSG_DESC);
LIB$PUT_OUTPUT (%ASCID'');
$SETAST (ENBFLG = 0); ! Disable AST until after all QIOs
!
! The first input for each terminal will be for one character.
! This read will wait forever for a character. The subsequent
! reads will have a timeout of 0 (immediate return). This
! gets us good response without using large amounts of run time.
!
STATUS = $QIO (CHAN = .MYT_CHAN, FUNC = .MYT_QIO_FUNC, ASTADR = MYTINP, P1 = INP_BUF [MYT, 0],
P2 = 1, IOSB = IN_IOSB [MYT, 0, 0], ASTPRM = 0);
IF NOT .STATUS THEN LEAVE CONN_STREAMS;
STATUS = $QIO (CHAN = .TERM_CHAN, FUNC = IO$_TTYREADALL OR IO$M_NOECHO, ASTADR = TRMINP,
P1 = INP_BUF [TRM, 0], P2 = INP_BUFSIZ, P3 = 0, IOSB = IN_IOSB [TRM, 0, 0], ASTPRM = 0);
IF NOT .STATUS THEN LEAVE CONN_STREAMS;
INCR INP_BUFNUM FROM 1 TO NUM_IN_BUF - 1 DO
BEGIN
! Queue up an input for console terminal
STATUS = $QIO (CHAN = .MYT_CHAN, FUNC = .MYT_QIO_FUNC OR IO$M_TIMED, ASTADR = MYTINP,
P1 = INP_BUF [MYT, .INP_BUFNUM], P2 = INP_BUFSIZ, P3 = 0,
IOSB = IN_IOSB [MYT,
.INP_BUFNUM, 0], ASTPRM = .INP_BUFNUM);
IF NOT .STATUS THEN LEAVE CONN_STREAMS;
STATUS = $QIO (CHAN = .TERM_CHAN, FUNC = IO$_TTYREADALL OR IO$M_NOECHO OR IO$M_TIMED,
ASTADR = TRMINP, P1 = INP_BUF [TRM, .INP_BUFNUM], P2 = INP_BUFSIZ, P3 = 0,
IOSB = IN_IOSB [TRM, .INP_BUFNUM, 0], ASTPRM = .INP_BUFNUM);
IF NOT .STATUS THEN LEAVE CONN_STREAMS;
END;
$SETAST (ENBFLG = 1); ! Enable AST
$WAITFR (EFN = XITEFN); ! Wait for exit flag
$WFLAND (EFN = 0, MASK = EFN_MASK); ! Go when outputs completed
CON_MSG_DESC [DSC$W_LENGTH] = 1 + .NODE_DESC [DSC$W_LENGTH] + .CON_MSG_4 [DSC$W_LENGTH];
CH$COPY (1, CH$PTR (UPLIT BYTE(%C'[')), .NODE_DESC [DSC$W_LENGTH],
CH$PTR (.NODE_DESC [DSC$A_POINTER]), .CON_MSG_4 [DSC$W_LENGTH],
CH$PTR (.CON_MSG_4 [DSC$A_POINTER]), CHR_NUL, .CON_MSG_DESC [DSC$W_LENGTH],
CH$PTR (.CON_MSG_DESC [DSC$A_POINTER]));
LIB$PUT_OUTPUT (CON_MSG_DESC);
LIB$PUT_OUTPUT (%ASCID'');
END;
!
! Program end -- Close both channels and return with STATUS
!
$CANTIM ();
!
! Close any log file
!
IF .SESSION_OPEN THEN LOG_CLOSE (SESSION_FAB, SESSION_RAB);
SESSION_OPEN = FALSE;
!
! Call TERM_CLOSE to clean up
!
STATUS = TERM_CLOSE ();
IF NOT .STATUS THEN LIB$SIGNAL (.STATUS);
$SETAST (ENBFLG = 1);
RETURN .STATUS;
END; ! End of TERM_CONNECT
%SBTTL 'End of KERTRM'
END ! End of module
ELUDOM