c c--------------------- Virtual Terminal Initialization ---------------------- c subroutine SetUpVirtualTerminal(remChannel, remRFunc, remWFunc, 1 locChannel, locRFunc, locWFunc, 1 status, setType, echo, parity, speed) include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:ssdef.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' include 'UTCS$INCLUDE:ttdef.for/nolist' parameter (oON = 0) parameter (oOFF = 1) parameter (oEVEN = 2) parameter (oODD = 3) parameter (oNONE = 4) parameter (o300BAUD = 300) parameter (o600BAUD = 600) parameter (o1200BAUD = 1200) parameter (o2400BAUD = 2400) parameter (o4800BAUD = 4800) parameter (o9600BAUD = 9600) parameter (PRV$V_SYSPRV = '0000001C'X) character*63 localDevice character*10 remoteBaud integer*4 status, byteCount, exitBlock(4), paritySet integer*4 remoteChar(2), setRemote(2), setChar, lineSpeed integer*4 localChar(2), setLocal(2), echo, parity, speed remRFunc = (io$_ttyreadall + io$m_noecho) remWFunc = (io$_writelblk + io$m_noformat) if (echo .eq. oOFF) then locRFunc = (io$_ttyreadall + io$m_noecho) else locRFunc = io$_ttyreadall endif locWFunc = (io$_writelblk + io$m_noformat) ! ! Set up the local channel. ! if (setType .eq. LOCALONLY) then status = sys$trnlog(%descr(localLogName), 1 %ref(byteCount), 1 %descr(localDevice),,,) if (status .ne. SS$_NORMAL) then return endif status = sys$assign(%descr(localDevice(1:byteCount)), 1 %ref(localChannel),,) if (status .ne. SS$_NORMAL) then return endif ! Get local terminal characteristics. status = sys$qiow(,%val(localChannel), 1 %val(io$_sensemode), 1 %ref(localReadIosb),,, 1 %ref(localChar),,,,,) if (status .ne. SS$_NORMAL) then return endif setLocal(1) = localChar(1) setLocal(2) = localChar(2) ! Set local terminal to full duplex. call lib$insv(0,tt$v_halfdup,1,setLocal(2)) status = sys$qiow(,%val(localChannel), 1 %val(io$_setmode), 1 %ref(localReadIosb),,, 1 %ref(setLocal),,,,,) if (status .ne. SS$_NORMAL) then return endif locChannel = localChannel else ! ! Set up the remote channel ! call GetRemoteChannel(status) ! Get remote system characteristics. status = sys$qiow(,%val(remoteChannel), 1 %val(io$_sensemode), 1 %ref(remoteReadIosb),,, 1 %ref(remoteChar),,,,,) if (status .ne. SS$_NORMAL) then return endif setRemote(1) = remoteChar(1) setRemote(2) = remoteChar(2) ! set term/unknown/width=511/modem/hangup- ! /fulldup/hostsync/ttsync/passall/nobroadcast/noecho ! other parameters are left untouched call lib$insv(dt$_ttyunkn,8,8,setRemote(1)) call lib$insv(511,16,16,setRemote(1)) call lib$insv(1,tt$v_hostsync,1,setRemote(2)) call lib$insv(1,tt$v_ttsync,1,setRemote(2)) call lib$insv(1,tt$v_passall,1,setRemote(2)) call lib$insv(1,tt$v_nobrdcst,1,setRemote(2)) call lib$insv(1,tt$v_noecho,1,setRemote(2)) call lib$insv(1,tt$v_modem,1,setRemote(2)) call lib$insv(0,tt$v_halfdup,1,setRemote(2)) ! Set parity parameter. if (parity .eq. oEVEN) then paritySet = tt$m_altrpar+tt$m_parity else if (parity .eq. oNONE) then paritySet = tt$m_altrpar else paritySet = tt$m_altrpar+tt$m_odd endif ! Set speed parameter. if (speed .eq. o300BAUD) then lineSpeed = tt$c_baud_300 else if (speed .eq. o600BAUD) then lineSpeed = tt$c_baud_600 else if (speed .eq. o1200BAUD) then lineSpeed = tt$c_baud_1200 else if (speed .eq. o2400BAUD) then lineSpeed = tt$c_baud_2400 else if (speed .eq. o4800BAUD) then lineSpeed = tt$c_baud_4800 else if (speed .eq. o9600BAUD) then lineSpeed = tt$c_baud_9600 endif status = sys$qiow(,%val(remoteChannel), 1 %val(io$_setmode), 1 %ref(remoteReadIosb),,, 1 %ref(setRemote),, 1 %val(lineSpeed),, 1 %val(paritySet),) if (status .ne. SS$_NORMAL) then return endif setremote(1) = 0 setremote(2) = 0 call lib$insv(1,prv$v_sysprv,1,setremote(1)) status = sys$setprv(%val(0), %ref(setremote(1)), 1 %val(0), %val(0)) remChannel = remoteChannel endif return end subroutine GetRemoteChannel(status) c c get the name of an unassigned remote system port c and assign a channel to it. c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:ssdef.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' include 'UTCS$INCLUDE:ttdef.for/nolist' character*63 remoteDevice, currentDevice, remLogNam, logCnt integer*4 status, byteCount, indexBlank, logDescriptor(2), i logical*4 found, procLogical ! Determine if first logical name translates into ! a device. If it does'nt then abort program. call str$concat(remLogNam, defaultLogNam, '0 ') ! Kluge string descriptor of remote logical name. indexBlank = index(remLogNam, ' ') logDescriptor(1) = indexblank - 1 logDescriptor(2) = %loc(remLogNam) status = sys$trnlog(%ref(logDescriptor(1)), 1 %ref(byteCount), 1 %descr(remoteDevice),,,) if (status .ne. SS$_NORMAL) then return endif found = FALSE i = 1 ! ! Process each device defined by the logical name translation ! testing to see if it is available. If it is'nt then ! attempt a new logical name translation until all defined ! logical names have been translated. ! do while ((.not.(found)) .and. (i .le. maxLogNames)) procLogical = FALSE do while ((.not.(procLogical)) .and. (.not.(found))) indexBlank = index(remoteDevice, ' ') if (indexBlank .gt. 1) then currentDevice = remoteDevice(1:indexBlank-1) remoteDevice = remoteDevice(indexBlank+1:) else currentDevice = remoteDevice procLogical = TRUE endif status = sys$assign(%descr(currentDevice), 1 %ref(remoteChannel),,) if (mod(status,2) .eq. 1) found = TRUE enddo ! If not found then translate next logical name. if (.not.(found)) then call IntToString(i, logCnt) call str$concat(remLogNam, defaultLogNam, logCnt(1:)) ! Kluge string descriptor of remote logical name. indexBlank = index(remLogNam, ' ') logDescriptor(1) = indexBlank - 1 status = sys$trnlog(%ref(logDescriptor(1)), 1 %ref(byteCount), 1 %descr(remoteDevice),,,) call CheckLogicalTranslate(status) i = i + 1 endif enddo return end subroutine IntToString(int,strng) c c convert a integer to a string with ascii character set. c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' parameter (maxStringSize=63) character*63 strng, tstrng character*10 digits, char integer*4 int, intval, remDig, j, i, strngSize logical*4 moreDigits digits = '0123456789' ! Make sign of number positive. intval = abs(int) moreDigits = .true. tStrng(1:1) = ' ' strngSize = 1 ! Generate digits. do while (moreDigits) strngSize = strngSize + 1 remDig = jmod(intval, 10) tstrng(strngSize:strngSize) = digits(remDig+1:remDig+1) intval = intval/10 if ((intval .eq. 0) .or. (strngSize .gt. maxStringSize)) 1 moreDigits = .false. enddo ! Place sign in string. if (int .lt. 0) then strngSize = strngSize + 1 tStrng(strngSize:strngSize) = '-' endif ! Reverse string and then assign to output string. j = 1 i = strngSize do while (j .lt. i) char = tStrng(i:i) tStrng(i:i) = tStrng(j:j) tStrng(j:j) = char j = j + 1 i = i - 1 enddo strng = tStrng(1:) return end subroutine CheckLogicalTranslate(statusCode) c c Subroutine to check the status of the remote logical c assign to determine if it is in error. If it is c then print a message to user and die cleanly. c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:ssdef.for/nolist' integer*4 statusCode ! All tranlation status' greater than one if error. if (statusCode .ne. SS$_NORMAL) then ! Print warning message and exit. call WriteUser(' ? all lines to remote system are in use') call sys$exit(%val(SS$_NORMAL)) endif return end c c------------------------ Virtual Terminal Program ------------------------ c subroutine VirtualTerminal(remChanl, remRFunc, remWFunc, 1 locChanl, locRFunc, locWFunc, conStatus) c c Initialize the program and commence execution. c include 'VTERMDIR:vglobal.for' include 'UTCS$INCLUDE:booleans.for' integer*4 remChanl, remRFunc, remWFunc integer*4 locChanl, locRFunc, locWFunc logical*4 conStatus shuttingDown = FALSE call InitializeProgram localReadFunc = locRFunc localWriteFunc = locWFunc localChannel = locChanl remoteReadFunc = remRFunc remoteWriteFunc = remWFunc remoteChannel = remChanl connected = conStatus ! Start up each process call ReadRemo call ReadLoco ! And wait forever status = sys$hiber() ! Set return values remChanl = remoteChannel remRFunc = remoteReadFunc remWFunc = remoteWriteFunc locRFunc = localReadFunc locWFunc = localWriteFunc locChanl = localChannel conStatus = connected return end subroutine InitializeProgram c c initialization routine c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' character*10 selectedSystem integer*4 exitBlock(4),status,indxBlank ! Get users remote system and initialize for it. call GetUsersRemoteSystem(selectedSystem) ! set status flags localReadSize = 1 localWriteChars = 0 remoteReadStart = 1 localWrtIosbAvail = 0 localWrtIosbUsed = 0 waitingToReadRemote = FALSE tablePointer = 0 tableWrapped = 0 firstTimeRun = TRUE firstTurn = TRUE remoteReadCnt = 0 remoteTypeAhdFunc = io$sensemode+io$m_typeahdcnt call WriteUser('Proceed...') call WriteUser(' ') return end subroutine GetUsersRemoteSystem(charSysType) c c Get type of remote system and configure QIO options accordingly c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' character*10 systemType, charSysType localReadFunc = localReadFunc + io$m_noecho charSysType = systemType return end subroutine ReadRemo c c start the process of reading an entire write-block from the c remote system. c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' integer*4 nBytes if (shuttingDown) 1 return ! Get typeahead count. call CheckRemo(nBytes) if (nbytes .eq. 0) then ! remote hasnt sent anything; ! read one byte to find out when it does call Read$remo(1,keepReading) else ! some data from remote already; ! watch the typeahead buffer to get everything in one read call WatchRemo(nBytes) endif return end subroutine WatchRemo(firstBytes) c c watch the typeahead buffer for the remote system c issue a read when it gets full or the sender stops c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' integer*4 firstBytes,nBytes,oBytes logical sending if (shuttingDown) 1 return ! loop while the remote appears to be sending to us obytes = firstBytes sending = TRUE do while (sending) if (shuttingDown) 1 return ! wait a bit before checking again call WaitRemo(remoteWaitTime) ! check typeahead buffer call CheckRemo(nBytes) ! if typeahead buffer is almost full - do a read if (nbytes .gt. typeAheadlimit) then call Read$remo(nBytes,keepReading) sending = FALSE ! if nothing arrived since last time - do a read elseif (obytes .eq. nbytes) then call Read$remo(nBytes,stopReading) sending = FALSE ! otherwise remember how many bytes we have now for next time round else oBytes = nBytes endif enddo return end subroutine CheckRemo(nBytes) c c Get typeahead count for remote system c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' integer*4 nBytes integer*2 typeAheadBuf(4) if (shuttingDown) 1 return if (firstTimeRun) then remoteTypeAhdFunc = remoteTypeAhdFunc +io$m_purge firstTimeRun = FALSE endif status = sys$qiow(,%val(remoteChannel), 1 %val(io$_sensemode+io$m_typeahdcnt), 1 %ref(remoteReadIosb) 1 ,,, 1 %ref(typeaheadBuf),,,,,) call CheckStatus('CheckRemo(senseRemoteTypeAhead)',status) nBytes = typeaheadBuf(1) return end subroutine WaitRemo(timeToWait) c c subroutine to perform an in-line wait c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' character*(*) timeToWait integer*4 status real*8 delta if (shuttingDown) 1 return status = sys$bintim(%descr(timeToWait), 1 %ref(delta)) call CheckStatus('WaitRemo(bintim)',status) status = sys$setimr(%val(WaitRemoEfn), 1 %ref(delta),,) call CheckStatus('WaitRemo(setimr)',status) status = sys$waitfr(%val(WaitRemoEfn)) call CheckStatus('WaitRemo(waitfr)',status) return end subroutine Read$remo(nBytes,astFlag) c c issues a QIO read to the remote system c fires AST gotRemo on read completion c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' integer*4 nBytes,astFlag,bufAddr, status external gotRemo if (shuttingDown) 1 return bufAddr = %loc(remoteToLocalBuf(remoteReadStart)) status = sys$qio(,%val(remoteChannel), 1 %val(remoteReadFunc), 1 %ref(remoteReadIosb), 1 gotRemo,astFlag, 1 %val(bufAddr), 1 %val(nbytes),, 1 %ref(remoteTerminator),,) return end subroutine GotRemo(readerSays) c c AST routine fired when remote system read completes. c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:ssdef.for/nolist' integer*4 readerSays integer*4 status,nBytes,i,j ! check read status code. status = remoteReadIosb(1) if (status .eq. ss$_abort) then ! read was cancelled; do it again call ReadRemo return elseif ((status .eq. ss$_hangup) .and. (.not.(firstTurn))) then call ShutDown(ss$_hangup) elseif (status .ne. ss$_parity) then call CheckStatus('remote read completion',status) endif firstTurn = FALSE ! Get the byte count from iosb nBytes = remoteReadIosb(2) + remoteReadIosb(4) ! adjust pointer for next read remoteReadStart = remoteReadStart + nBytes ! increment chars-to-write counter localWriteChars = localWriteChars + nBytes ! decide whether to do another read or write what we have now if (readerSays .eq. stopReading) then ! the reader said no more call WriteLoco elseif (localWriteChars+maxTypeAhead .gt. maxLocalWrite) then ! almost got a full block; read it call WriteLoco else ! check the typeahead buffer call CheckRemo(nBytes) if (nBytes .eq. 0) then ! no more data; do a write call WriteLoco else ! there is more data; do another read call WatchRemo(nBytes) endif endif return end subroutine WriteLoco c c sends a complete write-block to local terminal c c completion of the write runs AST sentLoco c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' integer*4 status external sentLoco status = sys$qio(,%val(localChannel), 1 %val(localWriteFunc), 1 , 1 sentLoco,, 1 %ref(remoteToLocalBuf), 1 %val(localWriteChars),,,,) call CheckStatus('writeLoco(immediate)',status) localWriteChars = 0 remoteReadStart = 1 ! once again start read of remote terminal call Readremo return end subroutine SentLoco c c Routine used to collect statistics for tracing. c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' return end subroutine ReadLoco c c issue a read to the local terminal c c completion of the read runs AST WriteRemo c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' integer*4 status external writeremo status = sys$qio(,%val(localChannel), 1 %val(localReadFunc), 1 %ref(localReadIosb), 1 writeremo,, 1 %ref(localToRemoteBuf), 1 %val(localReadSize),, 1 %ref(localterminator),,) call CheckStatus('ReadLoco(readLocalTerm)',status) c return end subroutine Writeremo c c AST routine fired when local terminal read completes c c checks for VTerminal escape character in the received data c if found begins termination of the program c otherwise copies the data to the remote system c c Completion of the write runs AST ReadLoco c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:ssdef.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' integer*4 status,nBytes logical escapeRequest external readLoco ! check read status status = localReadIosb(1) ! Get status code. if (status .eq. ss$_abort) then ! read was cancelled; do it again call ReadLoco return elseif (status .eq. ss$_parity) then call SendBreakChar call ReadLoco return else call CheckStatus('local read completion',status) endif ! get number of bytes read nBytes = localReadIosb(2) + localReadIosb(4) ! check for escape character escapeRequest = FALSE do ix=1,nBytes if (localToRemoteBuf(ix) .eq. escapeChar) then escapeRequest = TRUE endif enddo ! the escape character means that user wants out of session if (escapeRequest) then call ShutDown(ss$_normal) else status = sys$qio(,%val(remoteChannel), 1 %val(remoteWriteFunc), 1 %ref(remoteWriteIosb), 1 readLoco,, 1 %ref(localToRemoteBuf), 1 %val(nBytes),,,,) call CheckStatus('WriteRemo(immediate)',status) endif return end subroutine SendBreakChar c c Subroutine to send a break character to the remote c by 1. dropping remote line speed to 50 baud. c 2. sending two FF's. c 3. restoring line speed to original speed. c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' include 'UTCS$INCLUDE:ttdef.for/nolist' integer*4 remoteChar(2),lineSpeed,nBytes,status integer*2 tempReadIosb(4), tempWriteIosb(4) character*1 syncBytes(10) ! Set local write pointer to null localWriteChars = 0 ! Cancel all I/O on the remote channel. status = sys$cancel(%val(remoteChannel)) ! Get remote characteristics. status = sys$qiow(,%val(remoteChannel), 1 %val(io$_sensemode), 1 %ref(tempReadIosb),,, 1 %ref(remoteChar),,,,,) call CheckStatus('sendBreakChar(sensemode)', status) ! Save line speed from IOSB lineSpeed = tempReadIosb(2) ! Set remote with 50 baud rate. status = sys$qiow(,%val(remoteChannel), 1 %val(io$_setmode), 1 %ref(tempReadIosb),,, 1 %ref(remoteChar),, 1 %val(tt$c_baud_50),,,) call CheckStatus('sendBreakChar(setmode50)', status) ! Write a three hex FF's to remote. syncBytes(1) = char(0) syncBytes(2) = char(0) nBytes = 2 status = sys$qiow(,%val(remoteChannel), 1 %val(remoteWriteFunc), 1 %ref(tempWriteIosb),,, 1 %ref(syncBytes), 1 %val(nBytes),,,,) call CheckStatus('sendBreakChar(writeBuf)',status) ! Set remote back to old line speed. status = sys$qiow(,%val(remoteChannel), 1 %val(io$_setmode), 1 %ref(tempReadIosb),,, 1 %ref(remoteChar),, 1 %val(lineSpeed),,,) call CheckStatus('sendBreakChar(setmode100)', status) return end subroutine CheckStatus(facilityName,statusCode) c c Subroutine to check status from a System Service. c c Inputs: c facilityName - Subroutine name. c statusCode - Status code. c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' include 'UTCS$INCLUDE:ssdef.for/nolist' character*(*) facilityName integer*4 statusCode character*(*) errorMessage parameter (errorMessage = 'VTerminal Terminated with ERROR') character*80 message integer*4 flags,msglen if (shuttingdown) 1 return if (mod(statusCode,2) .ne. 1) then ! obtain error message from the system flags = "7 ! get text,id and severity, but not facility call sys$getmsg(%val(statusCode), 1 %ref(msglen), 1 %descr(message), 1 %val(flags),) ! send it to the user call WriteUser('%'//facilityName//'-'//message(2:msglen)) ! and terminate call ShutDown(statusCode) endif return end subroutine ShutDown(statusCode) c c Subroutine to terminate VTerminal processing c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' include 'UTCS$INCLUDE:ssdef.for/nolist' integer*4 statusCode shuttingDown = TRUE status = sys$cancel(%val(remoteChannel)) if (statusCode .eq. SS$_HANGUP) then status = sys$dassgn(%val(remoteChannel)) connected = TRUE endif ! Schedule a wake up for the hibernating process. status = sys$wake(,) return end subroutine WriteUser(message) c c Write a message to the local terminal surrounded by CRLFs c c Dont check completion status - called from termination c code so terminal may be gone. c include 'VTERMDIR:vglobal.for/nolist' include 'UTCS$INCLUDE:booleans.for/nolist' include 'UTCS$INCLUDE:iodef.for/nolist' character*(*) message integer*4 length,status print *,message return end c c----------------------- Image and exit handler ------------------------- c subroutine SetUpExitHandlerVMS(swapm, priority) c c Place the image into no swap mode, higher priority, and set up c the exit handler. c integer*4 status, exitBlock(4), swapm, priority call sys$setswm(%VAL(swapm)) call sys$setpri(,,%VAL(priority),) return end