PROGRAM MICOM_CONTROL
C Detached process between Micom 6000 Administrative port and talking programs
C such as MICOM and MICOM_LOCATE

C Why not do QIOW's w/ large buffer  and wait for prompt '>'?
C or multiple buffer and always have a QIO outstanding ?

c Must worry about the various 'editors' inside the micom
c  e.g. for SET MSG  and SET SHELF !!

	IMPLICIT INTEGER (A-Z)
	INCLUDE '($IODEF)/NOLIST'
	INCLUDE '($LNMDEF)/NOLIST'
	INCLUDE '($SSDEF)/NOLIST'
	PARAMETER ( PRMFLG = 1)
	EXTERNAL EXIT_HANDLER
	INTEGER*2 BUFLEN, ITEMCODE, MICOM_MBX_IOSB(4),
	1 PID_MBX_IOSB(4)
	INTEGER*4 BIN_OUT_DELAY(2),DESBLK(4),EXIT_STATUS
	CHARACTER MICOM_PORT*39,COMMAND*80,
	1 MICOM_MBX_BUF*80,PID_MBX_BUF*80,PID_MBX*14
C	CHARACTER ASC_OUT_DELAY*16/'0000 00:00:00.01'/
C	CHARACTER ASC_OUT_DELAY*16/'0000 00:00:00.25'/
	CHARACTER*12 USERNAME
	CHARACTER*16 IN_STRING
	BYTE ITMLST(0:15)

	COMMON/TIMER/ DELAY_EF, BIN_OUT_DELAY

	INTEGER*2 MICOM_IOSB(4)
	CHARACTER MICOM_BUF*80
	COMMON/MICOM_QIO/MICOM_CHAN, MICOM_IOSB,MICOM_BUF

	COMMON/MICOM_MBX_QIO/MICOM_MBX_CHAN,MICOM_MBX_IOSB,
	1 MICOM_MBX_BUF
	COMMON/PID_MBX_QIO/PID_MBX_CHAN,PID_MBX_IOSB,PID_MBX_BUF
C
C equivalence for QIO status block
	EQUIVALENCE (PID, MICOM_MBX_IOSB(3))
C equivalence for translate logical name system service
	EQUIVALENCE (BUFLEN, ITMLST(0)), (ITEMCODE, ITMLST(2)),
	1 (TRANSBUF_ADR, ITMLST(4)), (RETLEN_ADR, ITMLST(8)),
	2 (LISTEND,ITMLST(12))
C
C set up for declaring exit handler
	DESBLK(2) = %LOC(EXIT_HANDLER)
	DESBLK(3) = 1
	DESBLK(4) = %LOC(EXIT_STATUS)

C Declare the exit handler to delete permanent mailbox
	ISTAT = SYS$DCLEXH(%REF(DESBLK))
	IF (ISTAT .NE. SS$_NORMAL) CALL LIB$STOP(%VAL(ISTAT))

C set up for logical name translation
	BUFLEN= 39
	ITEMCODE=LNM$_STRING
	TRANSBUF_ADR= %LOC(MICOM_PORT)
	RETLEN_ADR= %LOC(RETLEN)
	LISTEND = 0

C Get the logical name for the Micom Command Console port
	ISTAT = SYS$TRNLNM(,'LNM$SYSTEM_TABLE','MICOM_PORT',,ITMLST)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Create and assign the MICOM detached process Mailbox 
C (for input from other processes)
	ISTAT = SYS$CREMBX(%VAL(PRMFLG),MICOM_MBX_CHAN,,,
	1 %VAL('5F0F'X),,'MICOM_MBX')
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Assign a channel to the command port
	ISTAT = SYS$ASSIGN(MICOM_PORT,MICOM_CHAN,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Get an event flag for the MICOM output delay timer and Micom channel
c	ISTAT = LIB$GET_EF(DELAY_EF)
c	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

cC Convert the output delay time in ascii to binary
cD	WRITE(6,1001)ASC_OUT_DELAY
cD1001	FORMAT(' Delay time between sending characters [',A,']: ',$)
cD	READ(6,'(Q,A)')LEN,IN_STRING
cD	IF (LEN.NE.0) ASC_OUT_DELAY=IN_STRING
cD	WRITE(6,'(A)')ASC_OUT_DELAY
cC	ISTAT = SYS$BINTIM(ASC_OUT_DELAY,BIN_OUT_DELAY)
cC	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

c ONLY IF CONNECTED TO ADMINISTRATIVE PORT VIA AN ORDINARY MICOM PORT
cC Connect to MICOM by sending space and waiting for response
c	COMMAND = ' '
c	LEN = 1
c	CALL SEND_MICOM(COMMAND,LEN)  ! no requesting PID, response discarded

C Main loop for reads from input mailbox
D	TYPE *,' Main loop for reads from input mailbox'

10	IF (PID_MBX_CHAN .NE. 0 )THEN	
C If there's a channel assigned to the previous PID mbx then deassign so
C	the mailbox can be deleted by the mailbox creator.
	   ISTAT = SYS$DASSGN(%VAL(PID_MBX_CHAN))
	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
	ENDIF

C	Wait for a command
	ISTAT = SYS$QIOW(,%VAL(MICOM_MBX_CHAN),
	1 %VAL(IO$_READVBLK),MICOM_MBX_IOSB,,,
	2 %REF(MICOM_MBX_BUF),%VAL(80),,,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Who sent it? Get the PID from status block
	WRITE(PID_MBX,'(6HMICOM_,Z8.8)')PID

C Assign a channel to the pid mailbox for return messages
	ISTAT = SYS$ASSIGN(PID_MBX,PID_MBX_CHAN,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Copy the command from the buffer
	LEN = MICOM_MBX_IOSB(2)
	COMMAND = MICOM_MBX_BUF

D	WRITE(6,4001)COMMAND
D4001	FORMAT(' RECEIVED MESSAGE FROM PID_MBX -- ',A<LEN>)

C SECURITY FEATURE!  Determine the command and who sent it.  
C	If the command is SHOW CH ALL THEN 
C	   it's OK for everyone
C	ELSE 
C	   is the username for this PID SYSTEM?
C	   IF yes send the command to MICOM
C	   ELSE tell the user it's illegal command

	IF(COMMAND(1:LEN) .EQ. 'SHOW CH ALL') THEN 
	   CALL SEND_MICOM(COMMAND,LEN)
	ELSE
	   IF(USERNAME(PID).EQ.'SYSTEM')THEN
		CALL SEND_MICOM(COMMAND,LEN)
	   ELSE

C Send illegal command message
		PID_MBX_BUF = COMMAND
		RLEN = LEN
		ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEVBLK.OR.IO$M_NOW),PID_MBX_IOSB,,,
	2 %REF(PID_MBX_BUF),%VAL(RLEN),,,,)
		IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
		PID_MBX_BUF = 'NO PRIVILEGE FOR COMMAND'
		RLEN = 24
D		TYPE *,' NO PRIVILEGE COMMAND SENT TO PID_MBX'
		ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEVBLK.OR.IO$M_NOW),PID_MBX_IOSB,,,
	2 %REF(PID_MBX_BUF),%VAL(RLEN),,,,)
		IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

D		TYPE *,' SENT EOF TO PID_MBX'
		ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEOF .OR. IO$M_NOW),PID_MBX_IOSB,,,,,,,,)
		IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
	   ENDIF

	ENDIF
	GOTO 10
	END

	SUBROUTINE SEND_MICOM(STRING,LEN)
	IMPLICIT INTEGER (A-Z)
	INCLUDE '($IODEF)/NOLIST'
	INCLUDE '($SSDEF)/NOLIST'
	PARAMETER (CR = '0D'X)

	INTEGER*4 BIN_OUT_DELAY(2)
	INTEGER*4 CR_TERM(2)/0,'0000 2000'X/
	CHARACTER STRING*80,CHAR_OUT*1
	COMMON/TIMER/DELAY_EF, BIN_OUT_DELAY

	INTEGER*2 MICOM_IOSB(4)
	CHARACTER MICOM_BUF*80
	COMMON /MICOM_QIO/ MICOM_CHAN,MICOM_IOSB,MICOM_BUF

	EXTERNAL READ_AST

D	WRITE(6,2001)LEN,STRING
D2001	FORMAT(' SENDING ',I2,' CHARACTERS -- ',A<LEN>)

C Output loop for console commands.  Wait for delay event timer then QIO
	RETRY = 3
10	CONTINUE

c	DO I=1,LEN
c	   ISTAT = SYS$SETIMR(%VAL(DELAY_EF),BIN_OUT_DELAY,,)
c	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
c	   ISTAT = SYS$WAITFR(%VAL(DELAY_EF))
c	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
c
cC Primary single character output QIO to MICOM switch channel
c	   CHAR_OUT = STRING(I:I)
c	   ISTAT = SYS$QIO(,%VAL(MICOM_CHAN),
c	1	%VAL(IO$_WRITEVBLK .OR. IO$M_NOFORMAT),,,,
c	2	%REF(CHAR_BUF),%VAL(1),,,,)
c	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
c	ENDDO

	ISTAT = SYS$QIO(,%VAL(MICOM_CHAN),
	1	%VAL(IO$_WRITEVBLK .OR. IO$M_NOFORMAT),,,,
	2	%REF(STRING),%VAL(LEN),,,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Initial read QIO from Micom switch channel (with purge of typeahead)
C    should do before sending to be sure not to miss response  ??? but get echo ?
D	TYPE *,'INITIAL READ FROM MICOM'
	ISTAT = SYS$QIO(,%VAL(MICOM_CHAN),
     1 %VAL(IO$_READVBLK.OR.IO$M_NOECHO.OR.IO$M_TIMED.OR.IO$M_PURGE),
	1 MICOM_IOSB,READ_AST,,%REF(MICOM_BUF),
	2 %VAL(80),%VAL(1),CR_TERM,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Hibernate and wait for the AST to wake me after message completion (or timeout)
	ISTAT = SYS$HIBER()
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Now we're awake again, check for success and retry
	IF (MICOM_IOSB(1) .NE. SS$_NORMAL) THEN	!Something wrong w/ message recvd
	   RETRY = RETRY - 1
	   IF (RETRY .NE. 0) GOTO 10	!Send the command again

C We've exhausted our retries.  Things are seriously wrong.  Still connected?
c	   ISTAT = SYS$PUTMSG()
c	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
	   CALL EXIT
	ENDIF
	RETURN
	END

	SUBROUTINE READ_MICOM
	IMPLICIT INTEGER (A-Z)
	INCLUDE '($IODEF)/NOLIST'
	INCLUDE '($SSDEF)/NOLIST'
	INTEGER*4 CR_TERM(2)/0,'0000 2000'X/

	INTEGER*2 MICOM_IOSB(4)
	CHARACTER MICOM_BUF*80
	COMMON /MICOM_QIO/MICOM_CHAN,MICOM_IOSB,MICOM_BUF

	EXTERNAL READ_AST

	ISTAT = SYS$QIO(,%VAL(MICOM_CHAN),
	1 %VAL(IO$_READVBLK.OR.IO$M_NOECHO.OR.IO$M_TIMED),
	1 MICOM_IOSB,READ_AST,,%REF(MICOM_BUF),
	2 %VAL(80),%VAL(1),CR_TERM,,)	! one-second timeout (useful in HOST)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
	RETURN
	END

	SUBROUTINE READ_AST
	IMPLICIT INTEGER (A-Z)
	INCLUDE '($IODEF)/NOLIST'
	INCLUDE '($SSDEF)/NOLIST'
c	PARAMETER ( END_OF_MESSAGE = '00'X )	!ASCII NULL
        CHARACTER*2 LFCR
	LOGICAL EOM_RCVD
	INTEGER*2 PID_MBX_IOSB(4)
	CHARACTER PID_MBX_BUF*80

	INTEGER*2 MICOM_IOSB(4)
	CHARACTER MICOM_BUF*80
	COMMON /MICOM_QIO/ MICOM_CHAN,MICOM_IOSB,MICOM_BUF

	COMMON/PID_MBX_QIO/PID_MBX_CHAN, PID_MBX_IOSB, PID_MBX_BUF

C	IF (MICOM_IOSB(1) .EQ. SS$_PARITY) THEN
C		TYPE *,' PARITY ERROR'
C		IF(MICOM_IOSB(2).NE.0) TYPE *,MICOM_BUF
C		CALL READ_MICOM
C		RETURN
C	ENDIF
c crash on error
	IF ((MICOM_IOSB(1) .NE. SS$_NORMAL) .AND.
	1 (MICOM_IOSB(1) .NE. SS$_TIMEOUT)) 
	1 CALL EXIT(MICOM_IOSB(1))

	EOM_RCVD = .FALSE.
	IF (MICOM_IOSB(1) .EQ. SS$_TIMEOUT) THEN
D	   TYPE *,' TIMEOUT  '
	   EOM_RCVD = .TRUE.
	   RLEN = MICOM_IOSB(2)
c tack on a LFCR if timeout ?
	ENDIF

c strip LFCR if possible (note IOSB is offset of terminator.  is not length
        IF(  MICOM_BUF( MICOM_IOSB(2) : MICOM_IOSB(2)+1 ) .EQ. LFCR   )
	1	 MICOM_IOSB(2) = MICOM_IOSB(2) - 1

	IF(MICOM_IOSB(2).EQ.0) THEN
c  possibly null eaten since not passall ?
D	    TYPE *,' ZERO LENGTH RECORD RCVD (i.e. timout after NO char ?)'
C ???	    CALL READ_MICOM
C ???	    RETURN
	    EOM_RCVD = .TRUE.
	    MICOM_BUF = 'Zero length response from MICOM'
	    RLEN = 31
	    GOTO 10	! break do loop with SYS$WAKE call
	ENDIF
D	TYPE *,' MICOM_IOSB(2)=',MICOM_IOSB(2)

c don't output blank lines ? due to FORTRAN problems with zero length output ?
	IF((MICOM_IOSB(2).EQ.1).AND.(MICOM_BUF(1:1).EQ.CHAR(LF)))THEN
D	    TYPE *,' LINE FEED RECORD RCVD (blank line)'
	    CALL READ_MICOM
	    RETURN
	ENDIF

c ??? should expand this for other prompts such as '*' and Time-of-Day
	IF(  INDEX( MICOM_BUF(1:RLEN), 'A>' ) .NE. 0  ) THEN
		EOM_RCVD = .TRUE.
	ENDIF

10	CONTINUE	   

D	TYPE *,' PID_MBX_CHAN,RLEN = ',PID_MBX_CHAN,RLEN
D	TYPE *,' line from micom'
D	TYPE *,MICOM_BUF(1:RLEN)

C Send response to requestor's mailbox
	IF((PID_MBX_CHAN.NE.0).AND.(RLEN.NE.0)) THEN
	   PID_MBX_BUF(1:RLEN) = MICOM_BUF(1:RLEN)

D	   TYPE *,' MESSAGE SENT TO PID_MBX'
	   ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEVBLK.OR.IO$M_NOW),PID_MBX_IOSB,,,
	2 %REF(PID_MBX_BUF),%VAL(RLEN),,,,)
	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

	ENDIF	! there was a requestor

	IF(EOM_RCVD)THEN
D	   TYPE *,' End Of Message DETECTED'
	   IF(PID_MBX_CHAN .NE. 0) THEN
D		TYPE *,' END OF MESSAGE SENT TO PID_MBX'

		ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEOF .OR. IO$M_NOW),PID_MBX_IOSB,,,,,,,,)
		IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

	 	ENDIF

	   MICOM_IOSB(1) = 1 		!SS$_NORMAL
	   ISTAT = SYS$WAKE(,)	! wakes main program hibernating during I/O
	   RETURN
	ENDIF

C Issue another read QIO from the switch
	CALL READ_MICOM
	RETURN
	END

C
C
C FUNCTION SUBROUTINE TO DETERMINE PROCESS USERNAME
	CHARACTER*12 FUNCTION USERNAME(PID)
	IMPLICIT INTEGER (A-Z)
	INTEGER*2 IOSB(4), ITMLST(8)
	CHARACTER*12 NAMEBUF
	EQUIVALENCE (ITMLST(3), BUFADR), (ITMLST(5), RLADR),
	1 (ITMLST(7), LSTEND)
	INCLUDE '($JPIDEF)/NOLIST'
	ITMLST(1)= 12
	ITMLST(2)= JPI$_USERNAME
	BUFADR= %LOC(NAMEBUF)
	RLADR= 0
	LSTEND= 0
	STATUS= SYS$GETJPIW(,%REF(PID),, ITMLST, IOSB,,)
	IF (.NOT. STATUS) CALL EXIT(STATUS)
	USERNAME = NAMEBUF
	RETURN
	END

	SUBROUTINE EXIT_HANDLER(ISTAT)
	IMPLICIT INTEGER (A-Z)
	INCLUDE '($SSDEF)/NOLIST'
	INTEGER*2 MICOM_MBX_IOSB(4)
	INTEGER*4 BIN_OUT_DELAY(2)
	CHARACTER MICOM_MBX_BUF*80
	
	COMMON/TIMER/DELAY_EF,BIN_OUT_DELAY
	COMMON/MICOM_MBX_QIO/MICOM_MBX_CHAN,MICOM_MBX_IOSB,
	1 MICOM_MBX_BUF
	COMMON/PID_MBX_QIO/PID_MBX_CHAN,PID_MBX_IOSB,PID_MBX_BUF

C Delete the permanent mailbox 
	IF (MICOM_MBX_CHAN .NE. 0) THEN !a mailbox exists so delete it
	    STATUS = SYS$DELMBX(%VAL(MICOM_MBX_CHAN))
	    IF(STATUS.NE.SS$_NORMAL) CALL LIB$STOP(%VAL(STATUS))
	ENDIF

C Deassign channel to PID mailbox
C should be more complicated, so sends EOF ??? to keep MICOM program from hang ?
	IF (PID_MBX_CHAN .NE. 0) THEN !a mailbox exists so deassign it
	    STATUS = SYS$DASSGN(%VAL(PID_MBX_CHAN))
	    IF(STATUS.NE.SS$_NORMAL) CALL LIB$STOP(%VAL(STATUS))
	ENDIF
	
C Call the condition handler for istat
	CALL EXIT(ISTAT)
	END