PROGRAM TERMINAL_SPEED
C
C     The purpose of this program is to handle multi-speed
C     terminal ports.  It is used typically with dialup
C     modems such as the VADIC 3450 series which allow
C     callers to dial up at either 300 or 1200 baud.
C     You could even call it the terminal speed daemon!
C
C     Typically a command such as RUN TERMSPEED/UIC=[1,4]-
C        /OUT=TERMSPEED.ERR/ERR=TERMSPEED.ERR-
C        /PROCESS_NAME=TERMINAL_SPEED/PRIORITY=6
C     should be placed in your SYSTARTUP.COM followed by
C        COPY DIALUPS.DAT TERMINAL_SPEED_MBX
C     where DIALUPS.DAT looks like:
C        ANSWER TTB4:
C        ANSWER TTB5:
C        ANSWER TTB6:
C        ANSWER TTB7:
C     for example.
C     Note that the RUN command above requires privilege to be
C     executed (which the startup procedure has).
C     The advantage of this program is that you can also
C     remove lines from the speed daemon's care by something like:
C        COPY TT TERMINAL_SPEED_MBX
C        IGNORE TTcu:
C        ^Z
C     This is especially useful if you plan to use something like
C     the VAXNET software, in which a given DZ line might serve
C     alternatively for dialin and dialout.
C     At present there are no other commands the daemon understands.
C        (strong candidate for future work is a SECURE command
C        which would require a special site-wide dialup password
C        which could change frequently before invoking LOGINOUT)
C
C     If you are having trouble making this program work properly
C     on your system, recompile it with the /D_LINES qualifier
C     and examine TERMSPEED.ERR after running it.
C        NLINES is the max number of terminals you will handle.
C        Their names are assumed to be TTA0: ... in order.
C        Making it smaller saves a little space.
C        Be sure it is consistent throughout all of these routines.
      PARAMETER NLINES = 96
      IMPLICIT INTEGER*4 (S)
C        ICHAN holds the channel numbers associated with the
C        terminals in our care.
C        HOLD is true iff we currently have the line in our care.
C        MCHAN holds the channels for the termination mailboxes
C        associated with the terminals
C        B is the buffer area we use to read a character from the line
C        WTIME is the time we wait between retries to get a line.
      COMMON/CHAN/ICHAN(NLINES),HOLD(NLINES),MCHAN(NLINES),
     .   B(NLINES),CHAR_AST_ADDR,TMBX_AST_ADDR,WAIT_AST_ADDR,WTIME
      INTEGER*4 WTIME(2)
      LOGICAL HOLD
      LOGICAL ALLTERM
      BYTE B
      INTEGER*4 CHAR_AST_ADDR,TMBX_AST_ADDR,WAIT_AST_ADDR
C        TIMEOUT is a wait period after which we try again
C        to grab terminals we were unable to get the first
C        time around.
      CHARACTER*40 TIMEOUT
C        TERM_NAME is a character function which returns the
C        name associated with a given terminal number
      CHARACTER*6 TERM_NAME
C        COMMAND is a buffer to receive a request from the outside world
      CHARACTER*40 COMMAND
C        Must declare the AST addresses EXTERNAL
      EXTERNAL CHAR_AST,TMBX_AST,WAIT_AST
C        we set the timeout period to be 30 seconds
      DATA TIMEOUT/'0 0:00:30.0'/
C        initially there are no lines in our care
      DATA HOLD/NLINES*.FALSE./
C
C
C
C        set up address of character AST routine
      CHAR_AST_ADDR = %LOC(CHAR_AST)
C        ditto for termination mailbox read AST
      TMBX_AST_ADDR = %LOC(TMBX_AST)
C        and for wait AST
      WAIT_AST_ADDR = %LOC(WAIT_AST)
C        set up delay time
      CALL IFERR(SYS$BINTIM(TIMEOUT,WTIME),
     .   'UNABLE TO GET BINTIM')
C        set up mailbox for communication with outside world
      CALL IFERR(SYS$CREMBX(%VAL(1),ICHANW,,,%VAL(0),,
     .   'TERMINAL_SPEED_MBX'),
     .   'TERM_SPEED UNABLE TO CREATE PERM MAILBOX')
      CALL IFERR(SYS$DELMBX(%VAL(ICHANW)),
     .   'TERM_SPEED UNABLE TO DELETE PERM MAILBOX')
      OPEN(UNIT=1,NAME='TERMINAL_SPEED_MBX',TYPE='OLD',READONLY,
     .   CARRIAGECONTROL='LIST')
C        That's about it.  Just wait to get a request via our MBX.
10    CONTINUE
      CALL IFERR(SYS$SETAST(%VAL(1)),'UNABLE TO ENABLE ASTS')
      READ(1,100,END=80,ERR=80)L,COMMAND
100   FORMAT(Q,A)
C        Strip leading blanks and make sure the line has an embedded blank
20    L1 = INDEX(COMMAND,' ')
      IF(L1.EQ.0)THEN
D        CALL ANSWER('Improper termspeed format: no embedded blanks')
         GOTO 10
      END IF
      IF(L1.EQ.1)THEN
         COMMAND = COMMAND(2:L)
         L = L - 1
         IF(COMMAND.NE.' ')GOTO 20
D        CALL ANSWER('Improper termspeed format: blank line')
         GOTO 10
      END IF
C        Compute terminal number
      CALL CUPPER(COMMAND)
      IF(INDEX(COMMAND,':').NE.0)L = INDEX(COMMAND,':') - 1
      NUMBER = ICHAR(COMMAND(L:L)) - ICHAR('0') +
     .   8 * (ICHAR(COMMAND(L-1:L-1)) - ICHAR('A')) + 1
C        Require it to in bounds !
      IF((NUMBER.LT.1).OR.(NUMBER.GT.NLINES))THEN
D        CALL ANSWER('Illegal terminal number: '//
D    .      TERM_NAME(NUMBER))
         GOTO 10
      END IF
D     TYPE *,'TERM NUMBER IS',NUMBER
C        Enter critical section by disabling AST delivery
      CALL IFERR(SYS$SETAST(%VAL(0)),'unable to disable ASTs')
C        Was request ANSWER ?
      IF(COMMAND(1:1).EQ.'A')THEN
C           Yes.  If we already hold it that's all we do.
D        TYPE *,'GOT AN ANSWER REQUEST'
         IF(HOLD(NUMBER))THEN
D           CALL ANSWER('Terminal '//TERM_NAME(NUMBER)//
D    .         ' already held')
            GOTO 10
         END IF
C           We don't hold terminal. Get it.
         HOLD(NUMBER) = .TRUE.
         IF(.NOT.ALLTERM(NUMBER))THEN
            CALL IFERR(SYS$SETIMR(,WTIME,%VAL(WAIT_AST_ADDR),
     .         %VAL(NUMBER)),
     .         'UNABLE TO ISSUE SETIMR REQ')
D           CALL ANSWER('Trying to allocate terminal: '//
D    .         TERM_NAME(NUMBER))
            GOTO 10
         END IF
C           Next, issue a read QIO to terminal
         CALL READTERM(NUMBER)
C           Answer request
D        CALL ANSWER('Terminal '//TERM_NAME(NUMBER)//
D    .      ' is now held')
         GOTO 10
      END IF
C        Was request IGNORE ?
      IF(COMMAND(1:1).EQ.'I')THEN
D        TYPE *,'WE GOT AN IGNORE REQUEST'
C        Yes.  If we don't hold it that's all we do.
         IF(.NOT.HOLD(NUMBER))THEN
D           CALL ANSWER('Terminal '//TERM_NAME(NUMBER)//
D    .         ' was not currently held')
            GOTO 10
         END IF
C           Release the terminal
         CALL DALLTERM(NUMBER)
C           Force completion of any termination message
         CALL DALLTMBX(NUMBER)
C           clear hold
         HOLD(NUMBER) = .FALSE.
C           Answer request
D        CALL ANSWER('Terminal '//TERM_NAME(NUMBER)//
D    .      ' will be released immediately')
         GOTO 10
      END IF
C        Well ... That takes care of all the requests we recognize
D     CALL ANSWER('Unrecognized request')
      GOTO 10
C        we get here on read mailbox errors and EOFs
80    CONTINUE
C     CALL ANSWER('Bad mailbox read')
D     TYPE *,'BAD MAILBOX READ'
      GOTO 10
      END
      CHARACTER*6 FUNCTION TERM_NAME(M)
      TERM_NAME = '_TTA0:'
      N = M - 1
      TERM_NAME(4:4) = CHAR(N/8+ICHAR('A'))
      TERM_NAME(5:5) = CHAR(MOD(N,8)+ICHAR('0'))
      RETURN
      END
      LOGICAL FUNCTION ALLTERM(N)
      PARAMETER NLINES = 96
      IMPLICIT INTEGER*4 (S)
      COMMON/CHAN/ICHAN(NLINES),HOLD(NLINES),MCHAN(NLINES),
     .   B(NLINES),CHAR_AST_ADDR,TMBX_AST_ADDR,WAIT_AST_ADDR,WTIME
      INTEGER*4 WTIME(2)
      LOGICAL HOLD
      BYTE B
      CHARACTER*6 TERM_NAME
D     TYPE *,'ABOUT TO ALLOCATE TERM',N
      ALLTERM = SYS$ALLOC(TERM_NAME(N),,,)
      IF(.NOT.ALLTERM)RETURN
      ALLTERM = SYS$ASSIGN(TERM_NAME(N),ICHAN(N),,)
      RETURN
      END
      SUBROUTINE DALLTERM(N)
      IMPLICIT INTEGER*4 (S)
      PARAMETER NLINES = 96
      COMMON/CHAN/ICHAN(NLINES),HOLD(NLINES),MCHAN(NLINES),
     .   B(NLINES),CHAR_AST_ADDR,TMBX_AST_ADDR,WAIT_AST_ADDR,WTIME
      INTEGER*4 WTIME(2)
      LOGICAL HOLD
      BYTE B
      CHARACTER*6 TERM_NAME
D     TYPE *,'ABOUT TO DEALL TERMINAL',N
      CALL IFERR(SYS$CANTIM(%VAL(N),),
     .   'UNABLE TO CANCEL TIMER REQ')
      CALL SYS$DASSGN(%VAL(ICHAN(N)))
      ICHAN(N) = 0
      CALL SYS$DALLOC(TERM_NAME(N),)
      RETURN
      END
      SUBROUTINE DALLTMBX(N)
      IMPLICIT INTEGER*4 (S)
      PARAMETER NLINES = 96
      COMMON/CHAN/ICHAN(NLINES),HOLD(NLINES),MCHAN(NLINES),
     .   B(NLINES),CHAR_AST_ADDR,TMBX_AST_ADDR,WAIT_AST_ADDR,WTIME
      INTEGER*4 WTIME(2)
      LOGICAL HOLD
      BYTE B
D     TYPE *,'ABOUT TO DALL TMBX',N
      CALL SYS$CANCEL(%VAL(MCHAN(N)))
      MCHAN(N) = 0
      RETURN
      END
      SUBROUTINE READTERM(N)
      IMPLICIT INTEGER*4 (S)
      PARAMETER NLINES = 96
      COMMON/CHAN/ICHAN(NLINES),HOLD(NLINES),MCHAN(NLINES),
     .   B(NLINES),CHAR_AST_ADDR,TMBX_AST_ADDR,WAIT_AST_ADDR,WTIME
      INTEGER*4 WTIME(2)
      LOGICAL HOLD
      BYTE B
      EXTERNAL IO$_TTYREADALL,IO$M_NOECHO,IO$M_PURGE
D     TYPE *,'ABOUT TO ISSUE READ TO TERM',N
      IREADF = %LOC(IO$_TTYREADALL).OR.%LOC(IO$M_NOECHO).OR.
     .   %LOC(IO$M_PURGE)
      B(N) = 0
      CALL IFERR(SYS$QIO(,%VAL(ICHAN(N)),%VAL(IREADF),,
     .   %VAL(CHAR_AST_ADDR),%VAL(N),
     .   B(N),%VAL(1),,,,),
     .   'TERMSPEED UNABLE TO ISSUE QIO TO TERMINAL')
      RETURN
      END
      SUBROUTINE CHAR_AST(M)
      IMPLICIT INTEGER*4 (S)
      PARAMETER NLINES = 96
      CHARACTER*6 TERM_NAME
      INTEGER*4 QPRIV(2)
      COMMON/CHAN/ICHAN(NLINES),HOLD(NLINES),MCHAN(NLINES),
     .   B(NLINES),CHAR_AST_ADDR,TMBX_AST_ADDR,WAIT_AST_ADDR,WTIME
      INTEGER*4 WTIME(2)
      LOGICAL HOLD
      BYTE B
      INTEGER*2 BUF(40)
      INTEGER*4 DESC(2)
      EXTERNAL DIB$W_UNIT
      EXTERNAL IO$_SETCHAR,IO$_SENSECHAR,IO$_READVBLK
      EXTERNAL TT$C_BAUD_1200,TT$C_BAUD_300,TT$C_BAUD_110
C        BAUD is a table of BAUD rates
      INTEGER*4 BAUD(0:15)
C        IBAUD is current baud rate index for each line
      INTEGER*4 IBAUD(NLINES)
      DATA IBAUD/NLINES*0/
C        NBAUD is number of baud rates in table to try
      DATA NBAUD/2/
      DATA QPRIV/2*'FFFF'X/
C        Remember, the AST gets passed the value directly, not its address
      N = %LOC(M)
D     TYPE *,'HIT CHAR_AST WITH N =',N
C        Before we get carried away, make sure we still HOLD this one
      IF(.NOT.HOLD(N))RETURN
C     set up table of baud rates
      BAUD(0) = %LOC(TT$C_BAUD_1200)
      BAUD(1) = %LOC(TT$C_BAUD_300)
      BAUD(2) = %LOC(TT$C_BAUD_110)
C
C        WE DON'T CURRENTLY CHECK 110 BAUD BECAUSE AT THAT SPEED
C        SETTING RETURNS AND CONTROL-YS DON'T REGISTER AS
C        CHARACTERS IF THE ACTUAL BAUD RATE IS 1200.
C        THE KNOWLEDGEABLE USER CAN EASILY CIRCUMVENT
C        THIS BY HITTING BREAK WHEN STUCK BUT WHY BOTHER FOR NOW?
C
C        check for wakeup character (^C, CR, or ^Y)
      IF((B(N).NE.3).AND.(B(N).NE.13).AND.(B(N).NE.25))THEN
C        We got a bad character. Set new baud rate & try again.
         IBAUD(N) = MOD(IBAUD(N)+1,NBAUD)
         ISPEED = BAUD(IBAUD(N))
         CALL IFERR(SYS$QIOW(%VAL(2),%VAL(ICHAN(N)),IO$_SENSECHAR,,,,
     .   DESC,,,,,),
     .      'UNABLE TO SENSE TERMINAL SPEED')
         CALL IFERR(SYS$QIOW(%VAL(2),%VAL(ICHAN(N)),IO$_SETCHAR,,,,
     .   DESC,,%VAL(ISPEED),,,),
     .      'UNABLE TO SET TERMINAL SPEED')
C        wait 1/2 second before trying again.  This is
C        crucial (along with IO$M_PURGE) since if the terminal
C        is at 300 baud and you try 1200 you sometimes get
C        2 characters for each one typed.
         CALL WAIT(0.5)
C           issue another read and wait for it.
         CALL READTERM(N)
         RETURN
      END IF
C        If we get here, we got a good character from them.
C        First, create a temporary mailbox to read termination message
      CALL IFERR(SYS$CREMBX(%VAL(0),MCHAN(N),,,%VAL(0),,),
     .   'UNABLE TO CREATE TEMP MAILBOX')
C        Then, get its number
      DESC(1) = 80
      DESC(2) = %LOC(BUF)
      CALL IFERR(SYS$GETCHN(%VAL(MCHAN(N)),,DESC,,),
     .   'UNABLE TO GETCHN')
      MUNIT = BUF(%LOC(DIB$W_UNIT)/2 + 1)
D     TYPE *,'MAILBOX UNIT IS',MUNIT
C        Then, deallocate terminal
      CALL DALLTERM(N)
C        Finally, start up LOGINOUT on terminal
      CALL IFERR(SYS$CREPRC(,'SYS$SYSTEM:LOGINOUT',
     .   TERM_NAME(N),TERM_NAME(N),TERM_NAME(N),
     .   QPRIV,,TERM_NAME(N),%VAL(4),%VAL('10004'X),%VAL(MUNIT),
     .   %VAL(0)),
     .   'UNABLE TO CREATE DETACHED PROCESS')
      CALL IFERR(SYS$QIO(,%VAL(MCHAN(N)),IO$_READVBLK,,
     .   %VAL(TMBX_AST_ADDR),%VAL(N),
     .   B(N),%VAL(1),,,,),
     .   'TERMSPEED UNABLE TO ISSUE QIO TO MAILBOX')
      RETURN
      END
      SUBROUTINE TMBX_AST(M)
      IMPLICIT INTEGER*4 (S)
      PARAMETER NLINES = 96
      LOGICAL ALLTERM
      COMMON/CHAN/ICHAN(NLINES),HOLD(NLINES),MCHAN(NLINES),
     .   B(NLINES),CHAR_AST_ADDR,TMBX_AST_ADDR,WAIT_AST_ADDR,WTIME
      INTEGER*4 WTIME(2)
      LOGICAL HOLD
      BYTE B
C        The parameter we get called with is passed by value
      N = %LOC(M)
D     TYPE *,'HIT TMBX_AST WITH N =',N
C        first off, deassign the channel
      CALL SYS$DASSGN(%VAL(MCHAN(N)))
      MCHAN(N) = 0
C        Before we get carried away, make sure we hold this one
      IF(.NOT.HOLD(N))RETURN
C        assume a line terminated
C        try to allocate and assign a channel to it
      HOLD(N) = .TRUE.
      IF(.NOT.ALLTERM(N))THEN
         CALL IFERR(SYS$SETIMR(,WTIME,%VAL(WAIT_AST_ADDR),
     .      %VAL(N)),
     .      'UNABLE TO ISSUE SETIMR REQ')
      ELSE
         CALL READTERM(N)
      END IF
      RETURN
      END
      SUBROUTINE ANSWER(STRING)
      IMPLICIT INTEGER*4 (S)
      CHARACTER*(*) STRING
      EXTERNAL IO$_WRITEVBLK,IO$M_NOW
D     TYPE *,STRING
      RETURN
      END
      SUBROUTINE WAIT_AST(M)
      IMPLICIT INTEGER*4 (S)
      PARAMETER NLINES=96
      LOGICAL ALLTERM
      COMMON/CHAN/ICHAN(NLINES),HOLD(NLINES),MCHAN(NLINES),
     .   B(NLINES),CHAR_AST_ADDR,TMBX_AST_ADDR,WAIT_AST_ADDR,WTIME
      INTEGER*4 WTIME(2)
      LOGICAL HOLD
      BYTE B
      N = %LOC(M)
      IF(.NOT.ALLTERM(N))THEN
         CALL IFERR(SYS$SETIMR(,WTIME,%VAL(WAIT_AST_ADDR),
     .      %VAL(N)),
     .      'UNABLE TO ISSUE SETIMR REQ')
      ELSE
         CALL READTERM(N)
      END IF
      RETURN
      END