C
C Micom program to read keyboard command and pass through detached process
C to MICOM switch command console
C
      IMPLICIT INTEGER (A-Z)
      INCLUDE '($IODEF)/NOLIST'
      INCLUDE '($SSDEF)/NOLIST'
      INCLUDE '($RMSDEF)/NOLIST'
      PARAMETER ( PRMFLG = 1 )
      INTEGER*2 PID_MBX_IOSB(4)
      INTEGER*4 EXIT_STATUS,DESBLK(4),BIN_TIME(2)
      CHARACTER PID_MBX*14, PID_MBX_BUF*80, COMMAND*80, UPR_CMD*80
      COMMON/PID_MBX/PID_MBX_CHAN,PID_MBX_IOSB,PID_MBX_BUF
      COMMON/CTRL_MASK/OLDMASK
      COMMON/AST/EF_TIMER
      EXTERNAL EXIT_HANDLER,TIMER_AST
     
C
C Setup descriptor block for declaring exit handler
      DESBLK(2) = %LOC(EXIT_HANDLER)
      DESBLK(3) = 1
      DESBLK(4) = %LOC(EXIT_STATUS)
     
C Declare an exit handler
      ISTAT = SYS$DCLEXH(%REF(DESBLK))
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
C Get PID and MODE of this process
      CALL JPI(PID,MODE)
     
C Create the return mailbox name from the PID
      WRITE(PID_MBX,'(6HMICOM_,Z8.8)') PID
     
C Create the return mailbox
      ISTAT = SYS$CREMBX(%VAL(PRMFLG),PID_MBX_CHAN,,,,,PID_MBX)
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
C Assign a channel to the detached process mailbox
      ISTAT = SYS$ASSIGN('MICOM_MBX',MICOM_MBX_CHAN,,)
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
      OPEN(UNIT=2,FILE='SYS$OUTPUT',TYPE='NEW',
     1 CARRIAGECONTROL='LIST')
     
C Setup write QIO timer
      ISTAT=SYS$BINTIM('0 00:00:10.00',BIN_TIME)
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
      CALL LIB$GET_EF(EF_TIMER)
     
C Set the old control mask
      CALL LIB$DISABLE_CTRL('02000000'X,OLDMASK)
     
C Get the input from terminal or command file with ctrl Y enabled
10    CONTINUE
      CALL LIB$ENABLE_CTRL(OLDMASK)
      ISTAT = LIB$GET_INPUT(COMMAND,'MICOM> ',LEN)
      CALL STR$UPCASE(COMMAND,COMMAND)
      IF(ISTAT .EQ. RMS$_EOF) CALL EXIT(SS$_NORMAL)
      IF(ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
C Scan for comments and blank them
      ICOMMENT = INDEX(COMMAND(1:LEN),'!')
      IF (ICOMMENT .GT. 0) LEN = ICOMMENT - 1
      COMMAND = COMMAND(1:LEN)
     
C upper case the command and check for exit or help
      CALL STR$UPCASE(UPR_CMD,COMMAND)
      IF(UPR_CMD(1:4).EQ.'EXIT') CALL EXIT(SS$_NORMAL)
      IF(UPR_CMD(1:4).EQ.'HELP') THEN
         CALL LIB$SPAWN
     1 ('HELP/LIBR=MICOM$DIR:MICOM.HLB MICOM_SWITCH')
         GOTO 10
      ENDIF
     
C Disable Control-Y's
      CALL LIB$DISABLE_CTRL('02000000'X,OLDMASK)
     
C Use timer AST to exit if write QIO hangs
      ISTAT=SYS$SETIMR(%VAL(EF_TIMER),BIN_TIME,TIMER_AST,)
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
C Send MICOM command to detached process mailbox
      ISTAT = SYS$QIO(,%VAL(MICOM_MBX_CHAN),
     1 %VAL(IO$_WRITEVBLK),
     1 MICOM_MBX_IOSB,,,%REF(COMMAND),%VAL(LEN),,,,)
     
C QIO completed -- cancel timer request
      STAT=SYS$CANTIM(,)
      IF (STAT .NE. SS$_NORMAL) CALL EXIT(STAT)
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
D     WRITE(2,'('' SENT COMMAND TO DETACHED PROCESS'')')
     
C Read MICOM reply from PID mailbox
      DO WHILE (.TRUE.)
         ISTAT = SYS$QIOW(,%VAL(PID_MBX_CHAN),
     1 %VAL(IO$_READVBLK),
     1 PID_MBX_IOSB,,,%REF(PID_MBX_BUF),%VAL(80),,,,)
         IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
C Look for end of file (end of message)
         IF (PID_MBX_IOSB(1) .EQ. SS$_ENDOFFILE) THEN
D        WRITE(2,'('' END OF MESSAGE RECEIVED'')')
         GOTO 10
         ENDIF
D        WRITE(2,'('' PID_MBX_IOSB(2) = '',I2)')PID_MBX_IOSB(2)
     
C If this is the startup process (MODE=0) don't write MICOM responses
         IF(MODE.NE.JPI$K_OTHER)WRITE(2,'(A)')
     1 PID_MBX_BUF(1:PID_MBX_IOSB(2))
      ENDDO
     
C Close output file
999   CLOSE(2)
      CALL EXIT
     
      END
     
C
C
C Subroutine to determine process pid and mode
      SUBROUTINE JPI(PID,MODE)
      IMPLICIT INTEGER (A-Z)
      INCLUDE '($JPIDEF)'
      INTEGER*2 IOSB(4), ITMLST(14)
      EQUIVALENCE (ITMLST(3), BUFADR), (ITMLST(5), RLADR),
     1 (ITMLST(9), BUFADR2), (ITMLST(11), RLADR2),
     2 (ITMLST(13), LSTEND)
      ITMLST(1)= 4
      ITMLST(2)= JPI$_MODE
      BUFADR= %LOC(MODE)
      RLADR= 0
      ITMLST(7)= 4
      ITMLST(8)= JPI$_PID
      BUFADR2 = %LOC(PID)
      RLADR2= 0
      LSTEND= 0
      CALL LIB$GET_EF(EF)
      STATUS= SYS$GETJPI(%VAL(EF),,, ITMLST, IOSB,,)
      IF (.NOT. STATUS) CALL EXIT(STATUS)
      CALL SYS$WAITFR(%VAL(EF))
      IF (.NOT. IOSB(1)) CALL EXIT(IOSB(1))
D     WRITE(6,'('' MODE = '',I)')MODE
D     WRITE(6,'('' PID = '',Z8)')PID
      CALL LIB$FREE_EF(EF)
      END
     
C
C Timer AST routine -- If we get here the write QIO failer
C
      SUBROUTINE TIMER_AST
      WRITE(2,'('' WRITE TO DETACHED PROCESS FAILED'')')
      CALL EXIT(1)
      END
     
     
      SUBROUTINE EXIT_HANDLER(ISTAT)
      IMPLICIT INTEGER (A-Z)
      INCLUDE '($SSDEF)/NOLIST'
      INTEGER*2 PID_MBX_IOSB(4)
      CHARACTER PID_MBX_BUF*80
     
      COMMON/PID_MBX/PID_MBX_CHAN,PID_MBX_IOSB,PID_MBX_BUF
      COMMON/CTRL_MASK/OLDMASK
     
C Delete the permanent mailbox
      IF (PID_MBX_CHAN .NE. 0) THEN !a mailbox exists so delete it
          STATUS = SYS$DELMBX(%VAL(PID_MBX_CHAN))
          IF(STATUS.NE.SS$_NORMAL) CALL LIB$STOP(%VAL(STATUS))
      ENDIF
C Reset CTRL-Y
      CALL LIB$ENABLE_CTRL(OLDMASK)
     
      CALL LIB$FREE_EF(EF_TIMER)
     
C Call the condition handler for istat
      CALL EXIT(ISTAT)
      END
