From:	SMTP%"JONESD@kcgl1.eng.ohio-state.edu" 18-APR-1991 14:40:47.41
To:	GVROD@CCVAX.IASTATE.EDU, tihor@acf3.NYU.EDU, GAVRON@ALPHA.SUNQUEST.COM
CC:	
Subj:	Unix Program Front End (UPFE) source code.

Received: from acf3.NYU.EDU by ACF1.NYU.EDU with SMTP; 
          Thu, 18 Apr 1991 14:40:26 EDT
Received: from kcgl1.eng.ohio-state.edu by acf3.NYU.EDU (5.61/1.34)
	id AA00866; Thu, 18 Apr 91 14:40:13 -0400
Date: Thu, 18 Apr 91 14:39 EST
From: Dave Jones <JONESD@kcgl1.eng.ohio-state.edu>
Subject: Unix Program Front End (UPFE) source code.
To: GVROD@CCVAX.IASTATE.EDU, tihor@acf3.NYU.EDU, GAVRON@ALPHA.SUNQUEST.COM
Message-Id: <8AEC55F448DFC00160@kcgl1.eng.ohio-state.edu>
X-Envelope-To: tihor@acf3.NYU.EDU
X-Vms-To: @UPFE_DIST_LIST
X-Vms-Cc: JONESD

$!								18-APR-1991
$!
$! Invoke this file as a command procedure to upack the UPFE source files
$! and build the image.
$!
$!
$ ON WARNGING THEN GOTO CLEANUP
$ GOSUB UNLOAD_FILES
$ FORTRAN/NODEBUG UPFE_MAIN.FOR+UPFE_PTERM/OBJECT=UPFE_OBJ.OBJ
$ LINK/EXE=UPFE.EXE/NOTRACE UPFE_OBJ.OBJ
$!
$ TYPE SYS$INPUT
The executable file UPFE.EXE is now built.  Place this file in a directory
where the full file specification is less than 64 characters, then setup
a DCL symbol to invoke this executable as a foreign command 
(e.g. UPFE == "$USER$DISK:[UTILITIES]UPFE").

The argument to UPFE is either the command to execute or a '$image' string in
the manner of a foreign command.

Examples:

	UPFE RUN SIMPLE_IO
	UPFE $SYSGEN
	UPFE MCR DISKQUOTA

$ prog_template = f$parse("UPFE.EXE;",,,,"NO_CONCEAL")
$ IF f$length(prog_template) .GT. 63 THEN WRITE SYS$OUTPUT -
	"Warning!  Filename is more than 63 chars: ", prog_template
$!
$ CLEANUP:
$    DELETE = "DELETE"
$    IF F$SEARCH("UPFE_OBJ.OBJ;") .NE. "" THEN DELETE/LOG UPFE_OBJ.OBJ;*
$ EXIT
$ UNLOAD_FILES:
$ CREATE UPFE_MAIN.FOR
	PROGRAM UNIX_PROGRAM_FRONT_END
C+
C	This program provides a utility for 'rationalizing' standard terminal
C	I/O for	unix programs ported to VMS.  Since unix doesn't have a
C	read-with-prompt concept, prompts are simply writes to stdout followed
C	by a read from stdin.  As a result, the VMS user sees recalled lines
C	go to the next line without a prompt.
C
C	This program filters input/output and converts output characters
C	preceeding a read into a prompt for that read.  In addition, an SMG
C	virtual keyboard is used to supply up to 20 lines of command recall.
C
C	User invokes this utility as a foreign command and passes the
C	command used to invoke the unix program as it argument.
C
C	Internally, this utility creates a sub-process to handle the PTY
C	and drive a mailbox-based command procedure that this process
C	invokes.
C-
	IMPLICIT NONE
	INTEGER STATUS, LIB$GETJPI, LIB$GET_FOREIGN, LENGTH, IMAGE_COUNT
	INTEGER PID, MASTER_PID, MBX, SYS$CREMBX, SYS$SETPRN, IMLEN
	INTEGER SYS$ENQ, SYS$DEQ, SYS$SYNCH, LKSB(6), LOCK_AST, UPFE_SPAWN
	INTEGER UPFE_SEND_INFO, UPFE_GET_INFO
	CHARACTER MBX_NAME*13, PROC_NAME*15, IMAGE_NAME*64, LINE*300
	CHARACTER TERMINAL*64
	INCLUDE '($JPIDEF)'
	INCLUDE '($LCKDEF)'
	INCLUDE '($LNMDEF)'
	EXTERNAL UPFE_LOCK_AST
C
C	Determine whether we are running due to user command (master process)
C	or whether we are the sub-process created to control the
C	psuedo-terminal.  If we assume that the master process is using a
C	CLI (true if using upfe command), we can distinguish the cases by 
C	checking the image count.  The sub-process's will be zero and the
C	master process will be greater than 0 (LOGINOUT is always the first
C	image run).
C
	PID = 0
	STATUS = LIB$GETJPI ( JPI$_IMAGECOUNT, PID, , IMAGE_COUNT )
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
	IF ( IMAGE_COUNT .EQ. 0 ) THEN
C
C	    We are the pty process, get PID of guy who created us.
C
	    STATUS = LIB$GETJPI ( JPI$_OWNER, , , MASTER_PID )
	    IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
	    LOCK_AST = %LOC ( UPFE_LOCK_AST )
	ELSE
C
C	    We are the master process.  Set pid and prompt for command
C	    if not supplied (give user oportunity to abort before we
C	    expend additional energies).
C
	    MASTER_PID = PID
	    STATUS = LIB$GET_FOREIGN ( LINE, 'command: ', LENGTH )
	    IF ( .NOT. STATUS ) CALL EXIT
	    LOCK_AST = 0
	END IF
C
C	Create mailbox and queue exclusive mode lock using name based upon 
C	master PID.  
C
	CALL SYS$FAOL ( 'UPFE_!8XL', , MBX_NAME, MASTER_PID )
	STATUS = SYS$CREMBX ( , MBX, %VAL(300), %VAL(360),
	1	%VAL('FF00'X), , MBX_NAME )
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
C
	STATUS = SYS$ENQ ( %VAL(8), %VAL(LCK$K_NLMODE), LKSB, ,MBX_NAME, , 
	1	, , , , )
	IF ( STATUS ) CALL SYS$SYNCH ( %VAL(8), LKSB )
	STATUS = LKSB(1)
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
	STATUS = SYS$ENQ ( %VAL(8), %VAL(LCK$K_EXMODE), LKSB, 
	1	%VAL(LCK$M_CONVERT), , , %VAL(LOCK_AST), LKSB, , , )
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
C
	IF ( PID .EQ. MASTER_PID ) THEN
C
C	    Wait for the lock
C
	    CALL SYS$SYNCH ( %VAL(8), LKSB )
C
C	    Create the sub-process and pass it info.
C
	    STATUS = LIB$GETJPI ( JPI$_IMAGNAME, , , , IMAGE_NAME, IMLEN )
	    IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
	    STATUS = UPFE_SPAWN ( IMAGE_NAME(:IMLEN), PID )
	    IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
C
	    STATUS = UPFE_SEND_INFO ( MBX, LINE, LENGTH )
C
C	    IF spawn worked, exit with do_command to invoke mailbox.
C
	    IF ( STATUS ) CALL LIB$DO_COMMAND ( '@'//MBX_NAME )
	    CALL EXIT ( STATUS )
C
	ELSE
C
C	    Set the process name.
C
	    STATUS = SYS$SETPRN ( MBX_NAME )
C
C	    Branch to mainline code for sub-process.
C
	    CALL UPFE_CHILD ( MBX, LKSB(2) )
C
	END IF
	END
C-----------------------------------------------------------------------------
C
	SUBROUTINE UPFE_LOCK_AST ( LKSB )
C+
C	Completion AST for conversion of sub-process's lock conversion
C	request.  If the status is other that SS$_CANCEL, assume master
C	process exitted the image before anticipated and kill this process.
C-
	IMPLICIT NONE
	INTEGER LKSB(6)
	INCLUDE '($SSDEF)'
	IF ( LKSB(1) .NE. SS$_CANCEL ) CALL EXIT ( LKSB(1) )
	END
C-----------------------------------------------------------------------------
C
	INTEGER FUNCTION UPFE_SPAWN ( IMAGE, PID )
C+
C	Spawn the sub-process that controls the PTY.
C
C	Input:
C	    IMAGE
C	Output:
C	    PID		Pid of created process or zero.
C-
	IMPLICIT NONE
	INTEGER PID
	CHARACTER*(*) IMAGE
	INTEGER SYS$CREPRC, SYS$CREMBX, PRIVS(2), MBX_UNIT, SYS$TRNLNM
	INTEGER ITEM_LIST(4), START, TRN_LEN
	STRUCTURE /PROCESS_CONTROL/
	    INTEGER AST, PID, MBX, IOSB(2)
	    CHARACTER MESSAGE*128
	END STRUCTURE
	RECORD /PROCESS_CONTROL/ PCB
	CHARACTER TRANSLATION*256
	EXTERNAL UPFE_TERM_MBX_AST
	INCLUDE '($JPIDEF)'
	INCLUDE '($LNMDEF)'
	INCLUDE '($DVIDEF)'
C
C	Create mailbox to receive termination messages.
C
	PID = 0
	UPFE_SPAWN = SYS$CREMBX ( , PCB.MBX, %VAL(128),, %VAL(128),
	1	%VAL('FF00'X), , )
	IF ( .NOT. UPFE_SPAWN ) RETURN
	CALL LIB$GETDVI ( DVI$_UNIT, PCB.MBX, , MBX_UNIT )
C
C	Issue read on mailbox.
C
	PCB.AST = %LOC ( UPFE_TERM_MBX_AST )
	PCB.IOSB(1) = 0
	CALL SYS$DCLAST ( UPFE_TERM_MBX_AST, PCB, )
C
C	Translate SYS$COMMAND for use as the sub-processes INPUT/OUTPUT.
C
	ITEM_LIST(1) = LNM$_STRING * '10000'X + 255
	ITEM_LIST(2) = %LOC ( TRANSLATION )
	ITEM_LIST(3) = %LOC ( TRN_LEN )
	ITEM_LIST(4) = 0
C
	UPFE_SPAWN = SYS$TRNLNM 
	1	(  , 'LNM$FILE_DEV', 'SYS$COMMAND', , ITEM_LIST )
	IF ( .NOT. UPFE_SPAWN ) RETURN
	START = 1
	IF ( TRANSLATION(1:2) .EQ. CHAR(27)//CHAR(0) ) START = 5
C
C	Create the sub-process.
C
	CALL LIB$GETJPI ( JPI$_PROCPRIV, , , PRIVS )
	UPFE_SPAWN = SYS$CREPRC ( PCB.PID, IMAGE, 
	1	TRANSLATION(START:TRN_LEN), TRANSLATION(START:TRN_LEN), ,
	2	PRIVS, , , %VAL(4), , %VAL(MBX_UNIT), )
C
	IF ( UPFE_SPAWN ) PID = PCB.PID
C
	END	
C-----------------------------------------------------------------------------
C
	SUBROUTINE UPFE_TERM_MBX_AST ( PCB )
C+
C	AST thread to read termination mailboxes checking for termination
C	of the sub-process.  If detected, force exit of image.
C-
	IMPLICIT NONE
	STRUCTURE /PROCESS_CONTROL/
	    INTEGER AST, PID, MBX, IOSB(2)
	    CHARACTER MESSAGE*128
	END STRUCTURE
	RECORD /PROCESS_CONTROL/ PCB
	INTEGER STATUS, SYS$QIO
	INCLUDE '($IODEF)'
	INCLUDE '($MSGDEF)'
C
	IF ( PCB.IOSB(1) ) THEN
C
C	   See if message is DELPROC and send by the right process.
C
	    IF ( PCB.IOSB(2) .EQ. PCB.PID ) THEN
		CALL LIB$PUT_OUTPUT ( 'Child process died' )
		CALL EXIT
	    END IF
	END IF
C
C	Issue another read.
C
	STATUS = SYS$QIO ( , %VAL(PCB.MBX), %VAL(IO$_READVBLK), PCB.IOSB,
	1	%VAL(PCB.AST), PCB, %REF(PCB.MESSAGE), %VAL(128), , , , )
C
	END
C-----------------------------------------------------------------------------
C
	INTEGER FUNCTION UPFE_SEND_INFO ( MBX, LINE, LENGTH )
C+
C	Send control info to child process via mailbox.
C-
	IMPLICIT NONE
	INTEGER MBX, LENGTH
	CHARACTER LINE*(*)
	INTEGER SYS$QIOW, SYS$TRNLNM, ITEM_LIST(4), TRN_LEN, START
	INCLUDE '($IODEF)'
	INCLUDE '($LNMDEF)'
	INTEGER*2 IOSB(4)
	CHARACTER TRANSLATION*256
C
C	Translate sys$input and sys$output and send translations to
C	the sub-process.
C
	ITEM_LIST(1) = LNM$_STRING * '10000'X + 255
	ITEM_LIST(2) = %LOC ( TRANSLATION )
	ITEM_LIST(3) = %LOC ( TRN_LEN )
	ITEM_LIST(4) = 0
C
	UPFE_SEND_INFO = SYS$TRNLNM 
	1	( , 'LNM$FILE_DEV', 'SYS$INPUT', , ITEM_LIST )
	IF ( .NOT. UPFE_SEND_INFO ) RETURN
	START = 1
	IF ( TRANSLATION(1:2) .EQ. CHAR(27)//CHAR(0) ) START = 5
	UPFE_SEND_INFO = SYS$QIOW ( %VAL(8), %VAL(MBX), 
	1	%VAL(IO$_WRITEVBLK), IOSB, , ,
	2	%REF(TRANSLATION(START:)), %VAL(TRN_LEN-START+1), , , , )
C
	UPFE_SEND_INFO = SYS$TRNLNM 
	1	( , 'LNM$FILE_DEV', 'SYS$OUTPUT', , ITEM_LIST )
	IF ( .NOT. UPFE_SEND_INFO ) RETURN
	START = 1
	IF ( TRANSLATION(1:2) .EQ. CHAR(27)//CHAR(0) ) START = 5
	UPFE_SEND_INFO = SYS$QIOW ( %VAL(8), %VAL(MBX), 
	1	%VAL(IO$_WRITEVBLK), IOSB, , ,
	2	%REF(TRANSLATION(START:)), %VAL(TRN_LEN-START+1), , , , )
C
C	Send the orignal command line
C
	UPFE_SEND_INFO = SYS$QIOW ( %VAL(8), %VAL(MBX), 
	1	%VAL(IO$_WRITEVBLK), IOSB, , ,
	2	%REF(LINE), %VAL(LENGTH), , , , )
C
C	Read a status line back to synchronize lock dequeue.
C
	UPFE_SEND_INFO = SYS$QIOW ( %VAL(8), %VAL(MBX),
	1	%VAL(IO$_READVBLK), IOSB, , ,
	2	%REF(TRANSLATION), %VAL(LEN(TRANSLATION)), , , , )
C
	END
C===========================================================================
C
	INTEGER FUNCTION UPFE_CHILD ( MBX, LOCK )
C+
C	Top level routine for sub-process.
C	Input:
C	    MBX		Integer.  Channel assigned to mailbox.
C	    LOCK	Integer.  Lock ID of deadman lock.
C-
	IMPLICIT NONE
	INTEGER LOCK, MBX
	INTEGER SYS$QIOW, SYS$DEQ, IN_LEN, OUT_LEN, CMD_LEN, LENGTH
	INTEGER EXIT_BLOCK(-2:5), SYS$DCLEXH, BUFADR, UPFE_SEND_COMMAND
	INTEGER*2 IOSB(4)
	INCLUDE '($IODEF)'
	INCLUDE '($LCKDEF)'
	CHARACTER INPUT*300, OUTPUT*300, COMMAND*300
	CHARACTER TERMINAL*64
	EXTERNAL UPFE_CHILD_EXIT
C
C	Read the info passed by the master.
C
	UPFE_CHILD = SYS$QIOW ( , %VAL(MBX), %VAL(IO$_READVBLK), IOSB,
	1	, , %REF(INPUT), %VAL(LEN(INPUT)), , , , )
	IF ( UPFE_CHILD ) UPFE_CHILD = ZEXT ( IOSB(1) )
	IF ( .NOT. UPFE_CHILD ) RETURN
	IN_LEN = ZEXT(IOSB(2))
CC	TYPE*,'Input device: ', INPUT(:IN_LEN), IN_LEN
C
	UPFE_CHILD = SYS$QIOW ( , %VAL(MBX), %VAL(IO$_READVBLK), IOSB,
	1	, , %REF(OUTPUT), %VAL(LEN(OUTPUT)), , , , )
	IF ( UPFE_CHILD ) UPFE_CHILD = ZEXT ( IOSB(1) )
	IF ( .NOT. UPFE_CHILD ) RETURN
	OUT_LEN = ZEXT(IOSB(2))
C
	UPFE_CHILD = SYS$QIOW ( , %VAL(MBX), %VAL(IO$_READVBLK), IOSB,
	1	, , %REF(COMMAND), %VAL(LEN(COMMAND)), , , , )
	IF ( UPFE_CHILD ) UPFE_CHILD = ZEXT ( IOSB(1) )
	IF ( .NOT. UPFE_CHILD ) RETURN
	CMD_LEN = ZEXT(IOSB(2))
C
C	Cancel the pending lock request and write status.
C
	UPFE_CHILD = SYS$DEQ ( %VAL(LOCK), , , %VAL(LCK$M_CANCEL) )
	IF ( .NOT. UPFE_CHILD ) RETURN
C	  
	UPFE_CHILD = SYS$QIOW ( , %VAL(MBX), %VAL(IO$_WRITEVBLK), IOSB,
	1	, , 1, %VAL(4), , , , )
	IF ( UPFE_CHILD ) UPFE_CHILD = ZEXT ( IOSB(1) )
	IF ( .NOT. UPFE_CHILD ) RETURN
C
C	Setup an exit handler to send EOF to mailbox.
C
	EXIT_BLOCK(-1) = %LOC ( UPFE_CHILD_EXIT )
	EXIT_BLOCK(0) = 2
	EXIT_BLOCK(1) = %LOC ( EXIT_BLOCK(5) )
	EXIT_BLOCK(2) = %LOC ( MBX )
	UPFE_CHILD = SYS$DCLEXH ( EXIT_BLOCK )
C
C	Create a PTY.
C
	CALL UPFE_CREATE_PTY 
	1	( INPUT(:IN_LEN), OUTPUT(:OUT_LEN), TERMINAL, BUFADR )
C
C	Send commands to mailbox as a command procedure.  We need to
C	reset SYS$INPUT and SYS$INPUT to the PTY, then issue the command.
C
C	Commands sent:
C		$DEFINE/USER/TRANS=TERM SYS$OUTPUT FTAnnn
C		$DEFINE/USER/TRANS=TERM SYS$ERROR NL:
C		$DEFINE/USER/TRANS=TERM SYS$INPUT  FTAnnn
C		$OPEN/READ UPFE_PSEUDO_TERM FTAnnn 
C		$ON WARNING THEN CONTINUE
C		$ON CONTROL_Y THEN CONTINUE
C		${user command}
C		$CLOSE UPFE_PSEUDO_TERM
C
	UPFE_CHILD = UPFE_SEND_COMMAND ( MBX, .FALSE.,
	1	'$SAVE_VER = ''F$VERIFY(0)', 0 )
	IF ( .NOT. UPFE_CHILD ) RETURN
	UPFE_CHILD = UPFE_SEND_COMMAND ( MBX, .FALSE.,
	1	'$DEFINE/USER/TRANS=TERMINAL SYS$OUTPUT !AS', TERMINAL )
	IF ( .NOT. UPFE_CHILD ) RETURN
	UPFE_CHILD = UPFE_SEND_COMMAND ( MBX, .FALSE.,
	1	'$DEFINE/USER/TRANS=TERMINAL SYS$ERROR NL:', TERMINAL )
	IF ( .NOT. UPFE_CHILD ) RETURN
	UPFE_CHILD = UPFE_SEND_COMMAND ( MBX, .FALSE.,
	1	'$DEFINE/USER/TRANS=TERMINAL SYS$INPUT !AS', TERMINAL )
	IF ( .NOT. UPFE_CHILD ) RETURN
C
	UPFE_CHILD = UPFE_SEND_COMMAND ( MBX,  .FALSE., 
	1	'$OPEN/READ UPFE_PSEUDO_TERM !AS', TERMINAL )
	IF ( .NOT. UPFE_CHILD ) RETURN
	UPFE_CHILD = UPFE_SEND_COMMAND ( MBX, .FALSE.,
	1	'$ON WARNING THEN CONTINUE', 0 )
	IF ( .NOT. UPFE_CHILD ) RETURN
	UPFE_CHILD = UPFE_SEND_COMMAND ( MBX, .FALSE.,
	1	'$ON CONTROL_Y THEN CONTINUE', 0 )
	IF ( .NOT. UPFE_CHILD ) RETURN
C
C	IF user specified command begining with a dollar sign, make at
C	temporary symbol and modify command string.
C
	IF ( COMMAND(1:1) .EQ. '$' ) THEN
	    UPFE_CHILD = UPFE_SEND_COMMAND ( MBX, .FALSE.,
	1	'$ UPFE_CMD := !AS', COMMAND(:MAX(1,MIN(CMD_LEN,285))) )
	    IF ( .NOT. UPFE_CHILD ) RETURN
	    CALL STR$TRIM ( COMMAND, 'UPFE_CMD', CMD_LEN )
	END IF
	UPFE_CHILD = UPFE_SEND_COMMAND ( MBX, .FALSE.,
	1	'$!AS', COMMAND(:MAX(1,MIN(CMD_LEN,299))) )
	IF ( .NOT. UPFE_CHILD ) RETURN
C
C	The final command we do ansynchronously so that we don't have
C	to wait on it.
C
	UPFE_CHILD = UPFE_SEND_COMMAND ( MBX, .TRUE.,
	1	'$CLOSE UPFE_PSEUDO_TERM/ERR=L''F$VERIFY(SAVE_VER)', 0 )
	IF ( .NOT. UPFE_CHILD ) RETURN
C
C	process the I/O generated by the command to the psuedo-terminal.
C
	CALL UPFE_PTY_IO ( %VAL(BUFADR) )
C
	END
C------------------------------------------------------------------------
C
	INTEGER FUNCTION UPFE_SEND_COMMAND (MBX, NOWAIT, STRING, FAO_ARG)
C+
C	Format data line and write to mailbox.
C	process to exit.
C-
	IMPLICIT NONE
	INTEGER MBX, NOWAIT, FAO_ARG(100), CMD_LEN, SYS$FAO, SYS$QIOW, FUNC
	INTEGER*2 IOSB(4)
	CHARACTER STRING*(*), COMMAND*300
	INCLUDE '($IODEF)'
C
	UPFE_SEND_COMMAND = SYS$FAO (STRING, CMD_LEN, COMMAND, FAO_ARG)
	IF ( UPFE_SEND_COMMAND .AND. CMD_LEN .GT. 0 ) THEN
C
C	    Trim string and write it.
C
	    CALL STR$TRIM ( COMMAND, COMMAND(:MAX(1,CMD_LEN)), CMD_LEN )
	    CMD_LEN = MIN ( CMD_LEN, 255 )
	    FUNC = IO$_WRITEVBLK
	    IF ( NOWAIT ) FUNC = FUNC + IO$M_NOW
	    UPFE_SEND_COMMAND = SYS$QIOW ( %VAL(8), %VAL(MBX),
	1	%VAL(FUNC), IOSB, , ,
	2	%REF(COMMAND), %VAL(CMD_LEN), , , , )
C
	    IF ( UPFE_SEND_COMMAND ) UPFE_SEND_COMMAND = ZEXT(IOSB(1))
	END IF
	END
C
C------------------------------------------------------------------------
C
	INTEGER FUNCTION UPFE_CHILD_EXIT ( EXIT_STATUS, MBX )
C+
C	Perform cleanup operation on mailbox, send EOF to force
C	process to exit.
C-
	IMPLICIT NONE
	INTEGER EXIT_STATUS, MBX, SYS$QIOW, IOSB(2)
	INCLUDE '($IODEF)'
C
	UPFE_CHILD_EXIT = SYS$QIOW ( , %VAL(MBX), 
	1	%VAL(IO$_WRITEOF+IO$M_NOW), IOSB, , , , , , , , )
	CALL SYS$DASSGN ( %VAL(MBX) )
	END

$!
$ CREATE UPFE_PTERM.FOR
C
	SUBROUTINE UPFE_CREATE_PTY ( INPUT, OUTPUT, TERMINAL, BUFADR )
C+
C	Initialize psuedo terminal and its control structures.
C
C	Input;
C	    INPUT
C	Output:
C	    TERMINAL	Device name of created PTY.
C-
	IMPLICIT NONE
	CHARACTER*(*) INPUT, OUTPUT, TERMINAL
	INTEGER STATUS, SYS$ASSIGN, PTD$CREATE, UNIT, LENGTH, BUFADR
	INTEGER TT_CHAR(5), IO_BUFADR(2), ITEM_LIST(4), SYS$QIOW
	INTEGER SMG$CREATE_VIRTUAL_KEYBOARD, PTD$SET_EVENT_NOTIFICATION 
	INTEGER EXIT_BLOCK(-2:5)
	INTEGER*2 IOSB(4)
	INCLUDE '($DVIDEF)'
	INCLUDE '($IODEF)'
	INCLUDE '($PTDDEF)'
	EXTERNAL PTD$CANCEL, UPFE_QUEUE_EVENT, UPFE_PTY_RUNDOWN
	EXTERNAL UPFE_CONTROL_C_AST
C
	INTEGER PTY, TTY, KEYBOARD, KEYTABLE
	LOGICAL IS_TERMINAL
	COMMON /UPFE_PTY/ PTY, TTY, IS_TERMINAL, KEYBOARD, KEYTABLE
C
C	Assign channel to INPUT device and get characteristics.
C
C
	STATUS = SYS$ASSIGN ( INPUT, TTY, , )
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
	CALL LIB$GETDVI ( DVI$_TRM, TTY, , IS_TERMINAL )
	IF ( IS_TERMINAL ) THEN
C
C	    Perform sense mode to get current characteristics.
C
	    STATUS = SYS$QIOW ( , %VAL(TTY), %VAL(IO$_SENSEMODE), IOSB,
	1	, , TT_CHAR, %VAL(20), , , , )
C
C	    Setup control Y ast to force exit.  Set control to be ignored.
C
CC	    STATUS = SYS$QIOW ( , %VAL(TTY), 
CC	1	%VAL(IO$_SETMODE+IO$M_CTRLCAST), IOSB, , ,
CC	2	UPFE_CONTROL_C_AST, UPFE_CONTROL_C_AST, , , , )
C
CC	    STATUS = SYS$QIOW ( , %VAL(TTY), 
CC	1	%VAL(IO$_SETMODE+IO$M_CTRLYAST), IOSB, , ,
CC	2	UPFE_CONTROL_C_AST, , , , , )
	END IF
C
C	Create the PTY.
C
	CALL LIB$GET_VM_PAGE ( 6, IO_BUFADR )
	BUFADR = IO_BUFADR(1)
	IO_BUFADR(2) = IO_BUFADR(1) + 512*5
	STATUS = PTD$CREATE
	1	(PTY, , TT_CHAR, %VAL(20), UPFE_QUEUE_EVENT, 6, , IO_BUFADR)
	IF ( .NOT. STATUS ) TYPE*,'Status of PTY create:', STATUS
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
	CALL LIB$GETDVI ( DVI$_UNIT, PTY, , UNIT )
	TERMINAL = ' '
	CALL LIB$GETDVI ( DVI$_DEVNAM, PTY, , , TERMINAL )
C
C	Set up exit handler to cleanly run down the PTY (works around bug in
C	FTDRIVER).
C
	EXIT_BLOCK(-1) = %LOC ( UPFE_PTY_RUNDOWN )
	EXIT_BLOCK(0) = 2
	EXIT_BLOCK(1) = %LOC(EXIT_BLOCK(5))	! reason
	EXIT_BLOCK(2) = %LOC(PTY)
	CALL SYS$DCLEXH ( EXIT_BLOCK )
C
C	Set ASTs to go off when reads start.  Event codes;
C	    0	PTD$READ completed
C	    1	START_READ notification
C	    2	MIDDLE_READ notification
C	    3   END_READ notification
C	    4	Characteristics change notification
C	    5   XON notification
C	    6   PTY idle notification
C
	STATUS = PTD$SET_EVENT_NOTIFICATION ( %VAL(PTY),
	1	UPFE_QUEUE_EVENT, 1, , %VAL(PTD$C_START_READ) )
	STATUS = PTD$SET_EVENT_NOTIFICATION ( %VAL(PTY),
	1	UPFE_QUEUE_EVENT, 2, , %VAL(PTD$C_MIDDLE_READ) )
	STATUS = PTD$SET_EVENT_NOTIFICATION ( %VAL(PTY),
	1	UPFE_QUEUE_EVENT, 3, , %VAL(PTD$C_END_READ) )
	STATUS = PTD$SET_EVENT_NOTIFICATION ( %VAL(PTY),
	1	UPFE_QUEUE_EVENT, 4, , %VAL(PTD$C_CHAR_CHANGED) )
	STATUS = PTD$SET_EVENT_NOTIFICATION ( %VAL(PTY),
	1	UPFE_QUEUE_EVENT, 5, , %VAL(PTD$C_SEND_XON) )
	STATUS = PTD$SET_EVENT_NOTIFICATION ( %VAL(PTY),
	1	, , , %VAL(PTD$C_ENABLE_READ) )
C
C	Creat virtual keyboard and keytable.
C
	CALL SMG$CREATE_KEY_TABLE ( KEYTABLE )
	STATUS = SMG$CREATE_VIRTUAL_KEYBOARD ( KEYBOARD, INPUT )
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
C
C
	END
C---------------------------------------------------------------------------
C
	INTEGER FUNCTION UPFE_QUEUE_EVENT ( CODE )
C+
C	Queue/dequeue events signifying AST calls.  IF CODE >= 0, save the
C	code number in a FIFO.  If CODE < 0, return the next code in the list
C	or an error status (-1, queue empty).  If an error status is returned,
C	the next queue event will also call a setef for the event flag
C	-CODE to be set.
C
C	This routine must always be called as an AST or with ASTs disabled.
C
C	Input:
C	    CODE value.
C
C-
	IMPLICIT NONE
	INTEGER CODE
	PARAMETER QUEUE_SIZE = 63
	INTEGER PENDING(0:QUEUE_SIZE), HEAD/0/, TAIL/0/
	LOGICAL AWAITING_EVENT/.FALSE./
	SAVE PENDING, HEAD, TAIL, AWAITING_EVENT
C
	IF ( CODE .GE. 0 ) THEN
C
C	   Append code to tail.  Wake if awating_event and queue is empty
C
	    IF ( AWAITING_EVENT .AND. HEAD .EQ. TAIL ) THEN
		CALL SYS$WAKE ( , )
		AWAITING_EVENT = .FALSE.
	    END IF
	    PENDING(TAIL) = CODE
	    TAIL = IAND(QUEUE_SIZE,TAIL+1)
	    IF ( TAIL .EQ. HEAD ) HEAD = IAND(QUEUE_SIZE,HEAD+1)	! queue full
	    UPFE_QUEUE_EVENT = 1
	    RETURN
C
	ELSE IF ( HEAD .EQ. TAIL ) THEN
C
C	    User wanted an event returned but queue is empty.
C
	    AWAITING_EVENT = .TRUE.
	    UPFE_QUEUE_EVENT = -1
	ELSE
C
C	    Simplest case, remove from head of queue.
C
	    UPFE_QUEUE_EVENT = PENDING(HEAD)
	    HEAD = IAND(QUEUE_SIZE,HEAD+1)
	END IF
C
	END
C---------------------------------------------------------------------------
C
	SUBROUTINE UPFE_PTY_IO ( PTDBUF )
C+
C	Relay/filter I/O between the terminal and IO.
C-
	IMPLICIT NONE
	STRUCTURE /PTDBUF/
	    INTEGER*2 STATUS, LENGTH
	    CHARACTER*508 DATA
	END STRUCTURE
	RECORD /PTDBUF/ PTDBUF(6)
	INTEGER STATUS, EF, PTD$READ, PTD$WRITE, LINE_LEN, CR_PENDING, OCTET
	INTEGER I, EVENT, UPFE_QUEUE_EVENT, PTD$DELETE, PROMPT_LEN, J, GSTATE
	INTEGER SMG$READ_COMPOSED_LINE, LIB$GETDVI, UNIT, READ_STATE
	INTEGER TT_CHAR(5), NEW_CHAR(5), SYS$QIOW, NEW_STATE
	EXTERNAL UPFE_QUEUE_EVENT
	INTEGER*2 IOSB(4)
	CHARACTER LINE*1024, PROMPT*1024
C
	INTEGER PTY, TTY, KEYBOARD, KEYTABLE
	LOGICAL IS_TERMINAL
	COMMON /UPFE_PTY/ PTY, TTY, IS_TERMINAL, KEYBOARD, KEYTABLE
	INCLUDE '($DVIDEF)'
	INCLUDE '($IODEF)'
	INCLUDE '($PTDDEF)'
	INCLUDE '($SSDEF)'
	INCLUDE '($TTDEF)'
	INCLUDE '($TT2DEF)'
C
C	Initialize
C
	EF = 11
	READ_STATE = 0
	GSTATE = 0
	PTDBUF(1).STATUS = 44		! initialize buffer for read.
	PTDBUF(1).LENGTH = 0
	CALL SYS$DCLAST ( UPFE_QUEUE_EVENT, 0, )
	LINE_LEN = 0
	CR_PENDING = .FALSE.
	IF ( IS_TERMINAL ) THEN
	    STATUS = SYS$QIOW ( , %VAL(TTY), %VAL(IO$_SENSEMODE), IOSB,
	1	, , TT_CHAR, %VAL(20), , , , )
	    IF ( IAND(TT_CHAR(3), TT2$M_APP_KEYPAD) .EQ. 0 ) 
	1	CALL SMG$SET_KEYPAD_MODE ( KEYBOARD, 0 )
	END IF
C
C	Main loop, Get event.
C
	DO WHILE ( EF .EQ. 11 )
100	    CALL SYS$SETAST ( %VAL(0) )
	    EVENT = UPFE_QUEUE_EVENT ( -1 )
	    CALL SYS$SETAST ( %VAL(1) )
	    IF ( EVENT .LT. 0 ) THEN
C
C		Queue is empty, wait for something to happen
C
		CALL SYS$HIBER()
C
	    ELSE IF ( EVENT .EQ. 0 ) THEN
C
C		A call to PTD$READ completed, display what was read.
C
		IF ( PTDBUF(1).STATUS ) THEN
C
C		    Call graphics intercept routine to pick out the graphics
C		    commands.  The buffer will be fixed up if needed.
C
		    CALL UPFE_GRAPHICS_INTERCEPT ( GSTATE, PTDBUF(1) )
C
C		    Transfer buffer contents to output lines.  Break up char stream
C		    into records.
C
		    DO I = 1, PTDBUF(1).LENGTH
		        OCTET = ICHAR ( PTDBUF(1).DATA(I:I) )
		        IF ( OCTET .EQ. 13 ) THEN 	! ascii CR
			    CR_PENDING = .TRUE.
			    IF ( LINE_LEN .EQ. 0 ) CR_PENDING  = .FALSE.
C
		        ELSE IF ( CR_PENDING .AND. OCTET .EQ. 10 ) THEN
C
C			    Previous char was <CR> and this is <LF>, ignore it.
C
			    CR_PENDING = .FALSE.
C
		        ELSE
C
C			    Add character to output line.
C
		            LINE_LEN = LINE_LEN + 1
		            LINE(LINE_LEN:LINE_LEN) = CHAR(OCTET)
			    CR_PENDING = .FALSE.
			    IF ( LINE_LEN .GE. LEN(LINE) ) CR_PENDING = .TRUE.
		        END IF
C
C		        Flush output buffer if <CR> detected.
C
		        IF ( CR_PENDING ) THEN
			    CALL SYS$QIOW ( , %VAL(TTY), %VAL(IO$_WRITEVBLK),
	1			IOSB, , , %REF(LINE), %VAL(LINE_LEN),
	2			, %VAL('01000000'X), , )
			    LINE_LEN = 0
		        END IF
		    END DO
C
		ELSE IF ( PTDBUF(1).STATUS .EQ. 0 ) THEN
C
C		    Attribute changes seem to cause spurious ASTs, ignore it.
C
		    GOTO 100
	        ELSE IF ( PTDBUF(1).STATUS .NE. SS$_ABORT .AND.
	1		  PTDBUF(1).STATUS .NE. SS$_CANCEL ) THEN
C
C		    Error is not one of the 'expected' cases.
C
		    TYPE*,'Error in PTD$READ:',PTDBUF(1).STATUS,PTDBUF(1).LENGTH
	        END IF
C
C		Check read state and either start reading next buffer or
C		get input.
C
		IF ( READ_STATE .EQ. 0 ) THEN
C
C	            Initialize buffer for next read and queue it.
C
	            PTDBUF(1).STATUS = 0
	            PTDBUF(1).LENGTH = 0
		    STATUS = PTD$READ (%VAL(EF), %VAL(PTY), 
	1		UPFE_QUEUE_EVENT, 0, PTDBUF(1), %VAL(500) )
		    IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
		ELSE
C
C		    read input line.
C
150		    PROMPT_LEN = LINE_LEN
		    IF ( PROMPT_LEN .GT. 0 ) THEN
		        PROMPT = LINE(:PROMPT_LEN)
		        STATUS = SMG$READ_COMPOSED_LINE ( KEYBOARD, KEYTABLE,
	1		PTDBUF(2).DATA, PROMPT(:PROMPT_LEN), PTDBUF(2).LENGTH )
		    ELSE
		        STATUS = SMG$READ_COMPOSED_LINE ( KEYBOARD, KEYTABLE,
	1		    PTDBUF(2).DATA, 'upfe> ', PTDBUF(2).LENGTH )
		    END IF
C
C		    Append either <CR> or <EOF> to buffer
C
		    IF ( STATUS ) THEN
		        LINE_LEN = PTDBUF(2).LENGTH + 1
		        PTDBUF(2).DATA(LINE_LEN:LINE_LEN) = CHAR(13)
		    ELSE
			LINE_LEN = 1
		        PTDBUF(2).DATA(LINE_LEN:LINE_LEN) = CHAR(26)
		    END IF
C
C		    Send data line.
C
		    DO WHILE ( READ_STATE .EQ. 1 .AND. LINE_LEN .GT. 0 )
		        PTDBUF(2).STATUS = 0
		        PTDBUF(2).LENGTH = 0
		        PTDBUF(3).STATUS = 0
		        PTDBUF(3).LENGTH = 0
		        STATUS = PTD$WRITE ( %VAL(PTY), , , PTDBUF(2),
	1		    %VAL(LINE_LEN), PTDBUF(3), %VAL(500) )
C
			J = PTDBUF(2).LENGTH
			LINE_LEN = LINE_LEN - J
			DO I = 1, LINE_LEN
			    J = J + 1
			    PTDBUF(2).DATA(I:I) = PTDBUF(2).DATA(J:J)
			END DO
C
		        IF ( PTDBUF(2).STATUS .EQ. SS$_DATAOVERUN ) THEN
C
C			    Typeahead buffer is full, stall until driver is
C			    ready.
C
			    IF ( LINE_LEN .GT. 0 ) READ_STATE = 2
		        END IF
		    END DO
C
		END IF
	    ELSE IF ( EVENT .EQ. 1 ) THEN 
C
C		Read started, take what is left over in the line buffer
C		as a prompt.
C
		READ_STATE = 1
	        CALL PTD$CANCEL ( %VAL(PTY) )
C
	    ELSE IF ( EVENT .EQ. 2 ) THEN 
C
C		Read finished writing prompt.
C
		READ_STATE = 1
C
	    ELSE IF ( EVENT .EQ. 3 ) THEN 
C
C		Read finish, get more data from client.
C
		READ_STATE = 0
	        PTDBUF(1).STATUS = 0
	        PTDBUF(1).LENGTH = 0
		STATUS = PTD$READ (%VAL(EF), %VAL(PTY), 
	1		UPFE_QUEUE_EVENT, 0, PTDBUF(1), %VAL(500) )
		IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
C
	    ELSE IF ( EVENT .EQ. 4 ) THEN 
C
C		Change in terminal characteristics, flush line buffer.
C		Anything that goes changing things is probably trouble.
C
		CALL SYS$QIOW ( , %VAL(TTY), %VAL(IO$_WRITEVBLK),
	1			IOSB, , , %REF(LINE), %VAL(LINE_LEN),
	2			, , , )
		LINE_LEN = 0
	        STATUS = SYS$QIOW ( , %VAL(PTY), %VAL(IO$_SENSEMODE), IOSB,
	1		, , NEW_CHAR, %VAL(20), , , , )
		NEW_CHAR(2) = IEOR(TT_CHAR(2),NEW_CHAR(2))
		NEW_CHAR(3) = IEOR(TT_CHAR(3),NEW_CHAR(3))
		IF ( IAND(NEW_CHAR(3),TT2$M_APP_KEYPAD) .NE. 0 ) THEN
		    TT_CHAR(3) = IEOR ( TT_CHAR(3), TT2$M_APP_KEYPAD )
	    	    NEW_STATE = (IAND(TT_CHAR(3),TT2$M_APP_KEYPAD) .NE. 0)
		    CALL SMG$SET_KEYPAD_MODE ( KEYBOARD, NEW_STATE )
		    NEW_CHAR(3) = IEOR ( NEW_CHAR(3), TT2$M_APP_KEYPAD )
		END IF
		IF ( NEW_CHAR(2) .NE. 0 .OR. NEW_CHAR(3) .NE. 0 ) THEN
C
C		    Allow a selected set of characteristics to be modified.
C
		    IF ( IAND(NEW_CHAR(2),TT$M_NOBRDCST) .NE. 0 )
	1		TT_CHAR(2) = IEOR ( TT_CHAR(2), TT$M_NOBRDCST )
		    IF ( IAND(NEW_CHAR(2),TT$M_LOWER) .NE. 0 )
	1		TT_CHAR(2) = IEOR ( TT_CHAR(2), TT$M_LOWER )
		    IF ( IAND(NEW_CHAR(2),TT$M_NOECHO) .NE. 0 )
	1		TT_CHAR(2) = IEOR ( TT_CHAR(2), TT$M_NOECHO )
		    IF ( IAND(NEW_CHAR(2),TT$M_WRAP) .NE. 0 )
	1		TT_CHAR(2) = IEOR ( TT_CHAR(2), TT$M_WRAP )
C
		    STATUS = SYS$QIOW ( , %VAL(TTY), %VAL(IO$_SETMODE),
	1			IOSB, , , TT_CHAR, %VAL(12), , , , )
		END IF
C
	    ELSE IF ( EVENT .EQ. 5 ) THEN
C
C		The driver sent an XON, continue sending data.
C
		DO WHILE ( READ_STATE .EQ. 2 .AND. LINE_LEN .GT. 0 )
		    PTDBUF(2).STATUS = 0
		    PTDBUF(2).LENGTH = 0
		    PTDBUF(3).STATUS = 0
		    PTDBUF(3).LENGTH = 0
		    STATUS = PTD$WRITE ( %VAL(PTY), , , PTDBUF(2),
	1		    %VAL(LINE_LEN), PTDBUF(3), %VAL(500) )
C
		    J = PTDBUF(2).LENGTH
		    LINE_LEN = LINE_LEN - J
		    DO I = 1, LINE_LEN
			J = J + 1
			PTDBUF(2).DATA(I:I) = PTDBUF(2).DATA(J:J)
		    END DO
C
		    IF ( PTDBUF(2).STATUS .EQ. SS$_DATAOVERUN ) THEN
C
C			Typeahead buffer is full, stall until driver is
C			ready.
C
			READ_STATE = 3
		    END IF
		END DO
C
C		If we got another XOFF, go back to stalled state.
C
		IF ( READ_STATE .EQ. 3 ) READ_STATE = 2
C
	    ELSE IF ( EVENT .EQ. 6 ) THEN
C
C		User deassigned channel, cancel any reads  exit program.
C
		CALL PTD$CANCEL(%VAL(PTY))
		CALL SYS$SYNCH ( %VAL(EF), PTDBUF(1) )
		CALL EXIT ( STATUS )
	    END IF
	END DO
C
	END
C---------------------------------------------------------------------------
C
	INTEGER FUNCTION UPFE_PTY_RUNDOWN ( REASON, PTY )
C+
C	Exit handler for  PTY.
C	Rundown the psuedo terminal control connection.  There is currently
C	a bug in the driver that forces us to take extra action during the
C	rundown to prevent attrition of the process's BYTLM
C
C	Input:
C	    PTY		Controller channel for terminal assigned by PTD$CREATE.
C			We assume that there is no pending activity.
C
C-
	IMPLICIT NONE
	INTEGER REASON, PTY, LIB$GETDVI, STATUS, PTD$DELETE, UNIT
	INTEGER*2 IOSB(4)
	CHARACTER DEVICE*64
	INCLUDE '($DVIDEF)'
	INCLUDE '($IODEF)'
C
C	Get the device name
C
	UPFE_PTY_RUNDOWN = LIB$GETDVI ( DVI$_DEVNAM, PTY, , , DEVICE )
	IF ( .NOT. UPFE_PTY_RUNDOWN ) GOTO 400
C
C	Delete the PTY and wait for the driver to detect it and properly 
C	cleanup the resources.  If this process dies before the device UCB is 
C	deleted, the job doesn't get the byte limit back.  
C
	UPFE_PTY_RUNDOWN = PTD$DELETE ( %VAL(PTY) )
	IF ( .NOT. UPFE_PTY_RUNDOWN ) GOTO 400
C
	CALL LIB$WAIT ( 0.5 )
	DO WHILE ( LIB$GETDVI ( DVI$_UNIT, , DEVICE, UNIT ) )
	    CALL LIB$WAIT ( 0.5 )
	END DO
C
400	CONTINUE
	UPFE_PTY_RUNDOWN = 1
C
	END
C------------------------------------------------------------------------
C
	SUBROUTINE UPFE_CONTROL_C_AST ( AST )
C+
C	AST to handle control C's hit by use so that control-Y ast is
C	not fired.   IF AST argument is non-null, issue another ^C AST,
C	otherwise force an exit
C-
	IMPLICIT NONE
	EXTERNAL AST
	INTEGER STATUS, SYS$QIOW, IOSB(2), SYS$FORCEX
C
	INTEGER PTY, TTY, KEYBOARD, KEYTABLE, AST
	LOGICAL IS_TERMINAL 
	COMMON /UPFE_PTY/ PTY, TTY, IS_TERMINAL, KEYBOARD, KEYTABLE
	INCLUDE '($IODEF)'
	IF ( %LOC(AST) .EQ. 0 ) THEN
	    STATUS = SYS$FORCEX ( , , %VAL(1) )
	ELSE
	     STATUS = SYS$QIOW ( , %VAL(TTY), 
	1	%VAL(IO$_SETMODE+IO$M_CTRLCAST), IOSB, , ,
	2	AST, AST, , , , )
	END IF
	END
C
	SUBROUTINE SHOW_QUO ( TEXT )
	CHARACTER*(*) TEXT
	INCLUDE '($JPIDEF)'
	INTEGER BYTLM
	CALL LIB$GETJPI ( JPI$_BYTLM, , , BYTLM )
	TYPE*,TEXT, BYTLM
	END
C-----------------------------------------------------------------
C
	SUBROUTINE UPFE_GRAPHICS_INTERCEPT ( GSTATE, BUFFER )
C+
C	Dummy routine stub.  The mission of this routine is to monitor
C	the output stream and intercept and emulate graphics commands.
C-
	INTEGER GSTATE, BUFFER(128)
	END
$!
$ RETURN