home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / vmspascal.zip / vxterm.for < prev    next >
Text File  |  1988-08-16  |  23KB  |  927 lines
  1. c
  2. c--------------------- Virtual Terminal Initialization ----------------------
  3. c
  4.  
  5.     subroutine SetUpVirtualTerminal(remChannel, remRFunc, remWFunc,
  6.      1                    locChannel, locRFunc, locWFunc,
  7.      1                    status, setType, echo, parity, speed)
  8.  
  9.     include 'VTERMDIR:vglobal.for/nolist'
  10.     include 'UTCS$INCLUDE:booleans.for/nolist'
  11.     include 'UTCS$INCLUDE:ssdef.for/nolist'
  12.     include 'UTCS$INCLUDE:iodef.for/nolist'
  13.     include 'UTCS$INCLUDE:ttdef.for/nolist'
  14.  
  15.     parameter    (oON = 0)
  16.     parameter    (oOFF = 1)
  17.     parameter    (oEVEN = 2)
  18.     parameter    (oODD =  3)
  19.     parameter    (oNONE = 4)
  20.     parameter    (o300BAUD = 300)
  21.     parameter    (o600BAUD = 600)
  22.     parameter    (o1200BAUD = 1200)
  23.     parameter    (o2400BAUD = 2400)
  24.     parameter    (o4800BAUD = 4800)
  25.     parameter    (o9600BAUD = 9600)
  26.     parameter    (PRV$V_SYSPRV = '0000001C'X)
  27.  
  28.     character*63     localDevice
  29.     character*10     remoteBaud
  30.     integer*4     status, byteCount, exitBlock(4), paritySet
  31.     integer*4     remoteChar(2), setRemote(2), setChar, lineSpeed
  32.     integer*4     localChar(2), setLocal(2), echo, parity, speed
  33.  
  34.     
  35.     remRFunc = (io$_ttyreadall + io$m_noecho)
  36.     remWFunc = (io$_writelblk + io$m_noformat)
  37.  
  38.     if (echo .eq. oOFF) then
  39.         locRFunc = (io$_ttyreadall + io$m_noecho)
  40.     else
  41.         locRFunc = io$_ttyreadall
  42.     endif
  43.  
  44.     locWFunc = (io$_writelblk + io$m_noformat)
  45.  
  46.     !
  47.     !  Set up the local channel.
  48.     !
  49.  
  50.     if (setType .eq. LOCALONLY) then
  51.         status = sys$trnlog(%descr(localLogName),
  52.      1                    %ref(byteCount),
  53.      1                    %descr(localDevice),,,)
  54.         if (status .ne. SS$_NORMAL) then
  55.             return
  56.         endif
  57.  
  58.         status = sys$assign(%descr(localDevice(1:byteCount)),
  59.      1                    %ref(localChannel),,)
  60.         if (status .ne. SS$_NORMAL) then
  61.             return
  62.         endif
  63.  
  64.         ! Get local terminal characteristics.
  65.         status = sys$qiow(,%val(localChannel),
  66.      1                   %val(io$_sensemode),
  67.      1                   %ref(localReadIosb),,,
  68.      1                   %ref(localChar),,,,,)
  69.         if (status .ne. SS$_NORMAL) then
  70.             return
  71.         endif
  72.  
  73.         setLocal(1) = localChar(1)
  74.         setLocal(2) = localChar(2)
  75.  
  76.         ! Set local terminal to full duplex.
  77.         call lib$insv(0,tt$v_halfdup,1,setLocal(2))
  78.         status = sys$qiow(,%val(localChannel),
  79.      1                   %val(io$_setmode),
  80.      1                   %ref(localReadIosb),,,
  81.      1                   %ref(setLocal),,,,,)
  82.         if (status .ne. SS$_NORMAL) then
  83.             return
  84.         endif
  85.  
  86.         locChannel = localChannel
  87.  
  88.     else
  89.         ! 
  90.         !  Set up the remote channel
  91.         !
  92.  
  93.         call GetRemoteChannel(status)
  94.  
  95.         ! Get remote system characteristics.
  96.         status = sys$qiow(,%val(remoteChannel),
  97.      1                   %val(io$_sensemode),
  98.      1                   %ref(remoteReadIosb),,,
  99.      1                   %ref(remoteChar),,,,,)
  100.         if (status .ne. SS$_NORMAL) then
  101.             return
  102.         endif
  103.  
  104.         setRemote(1) = remoteChar(1)
  105.         setRemote(2) = remoteChar(2)
  106.  
  107.         ! set term/unknown/width=511/modem/hangup-
  108.         !      /fulldup/hostsync/ttsync/passall/nobroadcast/noecho
  109.         !      other parameters are left untouched
  110.         call lib$insv(dt$_ttyunkn,8,8,setRemote(1))
  111.         call lib$insv(511,16,16,setRemote(1))
  112.         call lib$insv(1,tt$v_hostsync,1,setRemote(2))
  113.         call lib$insv(1,tt$v_ttsync,1,setRemote(2))
  114.         call lib$insv(1,tt$v_passall,1,setRemote(2))
  115.         call lib$insv(1,tt$v_nobrdcst,1,setRemote(2))
  116.         call lib$insv(1,tt$v_noecho,1,setRemote(2))
  117.         call lib$insv(1,tt$v_modem,1,setRemote(2))
  118.         call lib$insv(0,tt$v_halfdup,1,setRemote(2))
  119.  
  120.         ! Set parity parameter.
  121.         if (parity .eq. oEVEN) then
  122.             paritySet = tt$m_altrpar+tt$m_parity
  123.         else if (parity .eq. oNONE) then
  124.             paritySet = tt$m_altrpar
  125.         else
  126.             paritySet = tt$m_altrpar+tt$m_odd
  127.         endif
  128.  
  129.         ! Set speed parameter.
  130.         if (speed .eq. o300BAUD) then
  131.             lineSpeed = tt$c_baud_300
  132.         else if (speed .eq. o600BAUD) then
  133.             lineSpeed = tt$c_baud_600
  134.         else if (speed .eq. o1200BAUD) then
  135.             lineSpeed = tt$c_baud_1200
  136.         else if (speed .eq. o2400BAUD) then
  137.             lineSpeed = tt$c_baud_2400
  138.         else if (speed .eq. o4800BAUD) then
  139.             lineSpeed = tt$c_baud_4800
  140.         else if (speed .eq. o9600BAUD) then
  141.             lineSpeed = tt$c_baud_9600
  142.         endif
  143.  
  144.         status = sys$qiow(,%val(remoteChannel),
  145.      1               %val(io$_setmode),
  146.      1               %ref(remoteReadIosb),,,
  147.      1               %ref(setRemote),,
  148.      1               %val(lineSpeed),,
  149.      1               %val(paritySet),)
  150.  
  151.         if (status .ne. SS$_NORMAL) then
  152.             return
  153.         endif
  154.  
  155.         setremote(1) = 0
  156.         setremote(2) = 0
  157.         call lib$insv(1,prv$v_sysprv,1,setremote(1))
  158.         status = sys$setprv(%val(0), %ref(setremote(1)),
  159.      1                    %val(0), %val(0))
  160.  
  161.         remChannel = remoteChannel
  162.     endif
  163.  
  164.     return
  165.     end
  166.  
  167.     subroutine GetRemoteChannel(status)
  168. c
  169. c    get the name of an unassigned remote system port
  170. c     and assign a channel to it.
  171. c
  172.     include 'VTERMDIR:vglobal.for/nolist'
  173.     include 'UTCS$INCLUDE:booleans.for/nolist'
  174.     include 'UTCS$INCLUDE:ssdef.for/nolist'
  175.     include 'UTCS$INCLUDE:iodef.for/nolist'
  176.     include 'UTCS$INCLUDE:ttdef.for/nolist'
  177.  
  178.     character*63     remoteDevice, currentDevice, remLogNam, logCnt
  179.     integer*4     status, byteCount, indexBlank, logDescriptor(2), i
  180.     logical*4    found, procLogical
  181.  
  182.  
  183.     !  Determine if first logical name translates into
  184.     !  a device.  If it does'nt then abort program.
  185.     call str$concat(remLogNam, defaultLogNam, '0 ')
  186.  
  187.     !  Kluge string descriptor of remote logical name.
  188.     indexBlank = index(remLogNam, ' ')
  189.     logDescriptor(1) = indexblank - 1
  190.     logDescriptor(2) = %loc(remLogNam)
  191.  
  192.     status = sys$trnlog(%ref(logDescriptor(1)),
  193.      1                %ref(byteCount),
  194.      1                %descr(remoteDevice),,,)
  195.     if (status .ne. SS$_NORMAL) then
  196.         return
  197.     endif
  198.  
  199.     found = FALSE
  200.     i = 1
  201.     !
  202.     !  Process each device defined by the logical name translation
  203.     !  testing to see if it is available.  If it is'nt then
  204.     !  attempt a new logical name translation until all defined 
  205.     !  logical names have been translated.
  206.     !
  207.     do while ((.not.(found)) .and. (i .le. maxLogNames))
  208.         
  209.         procLogical = FALSE
  210.         do while ((.not.(procLogical)) .and. (.not.(found)))
  211.  
  212.              indexBlank = index(remoteDevice, ' ')
  213.              if (indexBlank .gt. 1) then
  214.              currentDevice = remoteDevice(1:indexBlank-1)
  215.              remoteDevice = remoteDevice(indexBlank+1:)
  216.              else
  217.              currentDevice = remoteDevice
  218.              procLogical = TRUE
  219.              endif
  220.              status = sys$assign(%descr(currentDevice),
  221.      1                               %ref(remoteChannel),,)
  222.                   if (mod(status,2) .eq. 1) found = TRUE
  223.         enddo
  224.         
  225.         ! If not found then translate next logical name.
  226.         if (.not.(found)) then
  227.             call IntToString(i, logCnt)
  228.             call str$concat(remLogNam, defaultLogNam, logCnt(1:))
  229.  
  230.             !  Kluge string descriptor of remote logical name.
  231.             indexBlank = index(remLogNam, ' ')
  232.             logDescriptor(1) = indexBlank - 1
  233.             status = sys$trnlog(%ref(logDescriptor(1)),
  234.      1                        %ref(byteCount),
  235.      1                        %descr(remoteDevice),,,)
  236.             call CheckLogicalTranslate(status)
  237.             i = i + 1
  238.         endif
  239.     enddo
  240.  
  241.     return
  242.     end
  243.  
  244.     subroutine IntToString(int,strng)
  245. c
  246. c    convert a integer to a string with ascii character set.
  247. c
  248.     include    'VTERMDIR:vglobal.for/nolist'
  249.     include 'UTCS$INCLUDE:booleans.for/nolist'
  250.  
  251.     parameter    (maxStringSize=63)
  252.     character*63    strng, tstrng
  253.     character*10    digits, char
  254.     integer*4    int, intval, remDig, j, i, strngSize
  255.     logical*4    moreDigits
  256.     
  257.     digits = '0123456789'
  258.     !  Make sign of number positive.
  259.     intval = abs(int)
  260.     moreDigits = .true.
  261.     tStrng(1:1) = ' '
  262.     strngSize = 1
  263.     
  264.     !  Generate digits.
  265.     do while (moreDigits)
  266.         strngSize = strngSize + 1
  267.         remDig = jmod(intval, 10)
  268.         tstrng(strngSize:strngSize) = digits(remDig+1:remDig+1)
  269.          intval = intval/10
  270.         if ((intval .eq. 0) .or. (strngSize .gt. maxStringSize))
  271.      1             moreDigits = .false.
  272.     enddo
  273.  
  274.     !  Place sign in string.
  275.     if (int .lt. 0) then
  276.         strngSize = strngSize + 1
  277.         tStrng(strngSize:strngSize) = '-'
  278.     endif
  279.  
  280.     !  Reverse string and then assign to output string.
  281.     j = 1
  282.     i = strngSize
  283.     do while (j .lt. i)
  284.         char = tStrng(i:i)
  285.         tStrng(i:i) = tStrng(j:j)
  286.         tStrng(j:j) = char
  287.         j = j + 1
  288.         i = i - 1
  289.     enddo
  290.     strng = tStrng(1:)    
  291.  
  292.     return
  293.     end
  294.  
  295.     subroutine CheckLogicalTranslate(statusCode)
  296. c
  297. c    Subroutine to check the status of the remote logical
  298. c    assign to determine if it is in error.  If it is
  299. c    then print a message to user and die cleanly.
  300. c
  301.     include 'VTERMDIR:vglobal.for/nolist'
  302.     include 'UTCS$INCLUDE:booleans.for/nolist'
  303.     include 'UTCS$INCLUDE:ssdef.for/nolist'
  304.     integer*4 statusCode
  305.  
  306.     !  All tranlation status' greater than one if error. 
  307.     if (statusCode .ne. SS$_NORMAL) then
  308.         !  Print warning message and exit.
  309.         call WriteUser(' ? all lines to remote system are in use')
  310.         call sys$exit(%val(SS$_NORMAL))
  311.     endif
  312.     
  313.     return
  314.     end
  315.  
  316. c
  317. c------------------------ Virtual Terminal Program ------------------------
  318. c
  319.  
  320.     subroutine VirtualTerminal(remChanl, remRFunc, remWFunc,
  321.      1                   locChanl, locRFunc, locWFunc, conStatus)
  322. c
  323. c    Initialize the program and commence execution.
  324. c
  325.     include 'VTERMDIR:vglobal.for'
  326.     include 'UTCS$INCLUDE:booleans.for'
  327.  
  328.     integer*4    remChanl, remRFunc, remWFunc
  329.     integer*4    locChanl, locRFunc, locWFunc
  330.     logical*4    conStatus
  331.  
  332.     shuttingDown = FALSE
  333.  
  334.     call InitializeProgram
  335.  
  336.     localReadFunc = locRFunc
  337.     localWriteFunc = locWFunc
  338.     localChannel = locChanl
  339.     remoteReadFunc = remRFunc 
  340.     remoteWriteFunc = remWFunc 
  341.     remoteChannel = remChanl
  342.     connected = conStatus
  343.     
  344.     !  Start up each process
  345.     call ReadRemo
  346.     call ReadLoco
  347.  
  348.     !  And wait forever
  349.     status = sys$hiber()
  350.  
  351.     !  Set return values
  352.     remChanl = remoteChannel
  353.     remRFunc = remoteReadFunc
  354.     remWFunc = remoteWriteFunc
  355.     locRFunc = localReadFunc
  356.     locWFunc = localWriteFunc
  357.     locChanl = localChannel
  358.     conStatus = connected
  359.  
  360.     return
  361.     end
  362.  
  363.     subroutine InitializeProgram
  364. c
  365. c    initialization routine
  366. c
  367.     include 'VTERMDIR:vglobal.for/nolist'
  368.     include 'UTCS$INCLUDE:booleans.for/nolist'
  369.  
  370.     character*10    selectedSystem
  371.     integer*4     exitBlock(4),status,indxBlank
  372.  
  373.  
  374.     !  Get users remote system and initialize for it.
  375.     call GetUsersRemoteSystem(selectedSystem)
  376.  
  377.     ! set status flags
  378.     localReadSize = 1
  379.     localWriteChars = 0    
  380.     remoteReadStart = 1    
  381.     localWrtIosbAvail = 0    
  382.     localWrtIosbUsed  = 0    
  383.     waitingToReadRemote = FALSE
  384.     tablePointer = 0    
  385.     tableWrapped = 0    
  386.     firstTimeRun = TRUE
  387.     firstTurn = TRUE
  388.     remoteReadCnt = 0
  389.     remoteTypeAhdFunc = io$sensemode+io$m_typeahdcnt
  390.  
  391.     call WriteUser('Proceed...')
  392.     call WriteUser(' ')
  393.  
  394.     return
  395.     end
  396.  
  397.     subroutine GetUsersRemoteSystem(charSysType)
  398. c
  399. c    Get type of remote system and configure QIO options accordingly
  400. c
  401.     include 'VTERMDIR:vglobal.for/nolist'
  402.     include 'UTCS$INCLUDE:booleans.for/nolist'
  403.     include 'UTCS$INCLUDE:iodef.for/nolist'
  404.  
  405.     character*10 systemType, charSysType
  406.  
  407.     localReadFunc = localReadFunc + io$m_noecho
  408.     charSysType = systemType
  409.  
  410.     return
  411.     end
  412.  
  413.     subroutine ReadRemo
  414. c
  415. c    start the process of reading an entire write-block from the 
  416. c    remote system.
  417. c
  418.     include 'VTERMDIR:vglobal.for/nolist'
  419.     include 'UTCS$INCLUDE:booleans.for/nolist'
  420.  
  421.     integer*4 nBytes
  422.  
  423.     if (shuttingDown)
  424.      1        return
  425.  
  426.     ! Get typeahead count.
  427.     call CheckRemo(nBytes)
  428.  
  429.     if (nbytes .eq. 0) then
  430.         ! remote hasnt sent anything; 
  431.         ! read one byte to find out when it does
  432.         call Read$remo(1,keepReading)
  433.     else
  434.         ! some data from remote already;
  435.         ! watch the typeahead buffer to get everything in one read
  436.         call WatchRemo(nBytes)
  437.     endif
  438.  
  439.     return
  440.     end
  441.  
  442.     subroutine WatchRemo(firstBytes)
  443. c
  444. c    watch the typeahead buffer for the remote system
  445. c    issue a read when it gets full or the sender stops
  446. c
  447.     include 'VTERMDIR:vglobal.for/nolist'
  448.     include 'UTCS$INCLUDE:booleans.for/nolist'
  449.     include 'UTCS$INCLUDE:iodef.for/nolist'
  450.  
  451.     integer*4 firstBytes,nBytes,oBytes
  452.     logical  sending
  453.  
  454.     if (shuttingDown)
  455.      1        return
  456.  
  457.     ! loop while the remote appears to be sending to us
  458.  
  459.     obytes = firstBytes
  460.     sending = TRUE
  461.     do while (sending)
  462.  
  463.         if (shuttingDown)
  464.      1        return
  465.  
  466.         ! wait a bit before checking again
  467.         call WaitRemo(remoteWaitTime)
  468.  
  469.         ! check typeahead buffer
  470.         call CheckRemo(nBytes)
  471.  
  472.         ! if typeahead buffer is almost full - do a read
  473.         if (nbytes .gt. typeAheadlimit) then
  474.         call Read$remo(nBytes,keepReading)
  475.         sending = FALSE
  476.  
  477.         ! if nothing arrived since last time - do a read
  478.         elseif (obytes .eq. nbytes) then
  479.         call Read$remo(nBytes,stopReading)
  480.         sending = FALSE
  481.  
  482.         ! otherwise remember how many bytes we have now for next time round
  483.         else
  484.         oBytes = nBytes
  485.         endif
  486.  
  487.     enddo
  488.  
  489.     return
  490.     end
  491.  
  492.     subroutine CheckRemo(nBytes)
  493. c
  494. c    Get typeahead count for remote system
  495. c
  496.     include 'VTERMDIR:vglobal.for/nolist'
  497.     include 'UTCS$INCLUDE:booleans.for/nolist'
  498.     include 'UTCS$INCLUDE:iodef.for/nolist'
  499.  
  500.     integer*4 nBytes
  501.     integer*2 typeAheadBuf(4)
  502.  
  503.     if (shuttingDown)
  504.      1        return
  505.  
  506.     if (firstTimeRun) then
  507.         remoteTypeAhdFunc = remoteTypeAhdFunc +io$m_purge
  508.         firstTimeRun = FALSE
  509.     endif
  510.  
  511.     status = sys$qiow(,%val(remoteChannel),
  512.      1               %val(io$_sensemode+io$m_typeahdcnt),
  513.      1               %ref(remoteReadIosb)
  514.      1               ,,,
  515.      1               %ref(typeaheadBuf),,,,,)
  516.  
  517.     call CheckStatus('CheckRemo(senseRemoteTypeAhead)',status)
  518.  
  519.     nBytes = typeaheadBuf(1)
  520.  
  521.     return
  522.     end
  523.  
  524.     subroutine WaitRemo(timeToWait)
  525. c
  526. c    subroutine to perform an in-line wait
  527. c
  528.     include 'VTERMDIR:vglobal.for/nolist'
  529.     include 'UTCS$INCLUDE:booleans.for/nolist'
  530.  
  531.     character*(*) timeToWait
  532.     integer*4 status
  533.     real*8 delta    
  534.  
  535.     if (shuttingDown)
  536.      1        return
  537.  
  538.     status = sys$bintim(%descr(timeToWait),
  539.      1                %ref(delta))
  540.     call CheckStatus('WaitRemo(bintim)',status)
  541.  
  542.     status = sys$setimr(%val(WaitRemoEfn),
  543.      1                %ref(delta),,)
  544.     call CheckStatus('WaitRemo(setimr)',status)
  545.  
  546.     status = sys$waitfr(%val(WaitRemoEfn))
  547.     call CheckStatus('WaitRemo(waitfr)',status)
  548.  
  549.     return
  550.     end
  551.  
  552.     subroutine Read$remo(nBytes,astFlag)
  553. c
  554. c    issues a QIO read to the remote system
  555. c    fires AST gotRemo on read completion
  556. c
  557.     include 'VTERMDIR:vglobal.for/nolist'
  558.     include 'UTCS$INCLUDE:booleans.for/nolist'
  559.  
  560.     integer*4 nBytes,astFlag,bufAddr, status
  561.     external gotRemo
  562.  
  563.     if (shuttingDown)
  564.      1        return
  565.  
  566.     bufAddr = %loc(remoteToLocalBuf(remoteReadStart))
  567.     status = sys$qio(,%val(remoteChannel),
  568.      1              %val(remoteReadFunc),
  569.      1              %ref(remoteReadIosb),
  570.      1              gotRemo,astFlag,
  571.      1              %val(bufAddr),
  572.      1              %val(nbytes),,
  573.      1              %ref(remoteTerminator),,)
  574.  
  575.     return
  576.     end
  577.  
  578.     subroutine GotRemo(readerSays)
  579. c
  580. c    AST routine fired when remote system read completes.
  581. c
  582.     include 'VTERMDIR:vglobal.for/nolist'
  583.     include 'UTCS$INCLUDE:booleans.for/nolist'
  584.     include 'UTCS$INCLUDE:ssdef.for/nolist'
  585.  
  586.     integer*4 readerSays
  587.     integer*4 status,nBytes,i,j
  588.  
  589.     ! check read status code.
  590.     status = remoteReadIosb(1)
  591.     if (status .eq. ss$_abort) then
  592.         ! read was cancelled; do it again
  593.         call ReadRemo
  594.         return
  595.     elseif ((status .eq. ss$_hangup) .and. (.not.(firstTurn))) then
  596.              call ShutDown(ss$_hangup)
  597.     elseif (status .ne. ss$_parity) then
  598.         call CheckStatus('remote read completion',status)
  599.     endif
  600.  
  601.     firstTurn = FALSE
  602.  
  603.     ! Get the byte count from iosb
  604.     nBytes = remoteReadIosb(2) + remoteReadIosb(4)
  605.  
  606.     ! adjust pointer for next read
  607.     remoteReadStart = remoteReadStart + nBytes
  608.  
  609.     ! increment chars-to-write counter
  610.     localWriteChars = localWriteChars + nBytes
  611.  
  612.     ! decide whether to do another read or write what we have now
  613.  
  614.     if (readerSays .eq. stopReading) then
  615.         ! the reader said no more
  616.         call WriteLoco
  617.     elseif (localWriteChars+maxTypeAhead .gt. maxLocalWrite) then
  618.         ! almost got a full block; read it
  619.         call WriteLoco
  620.     else
  621.         ! check the typeahead buffer
  622.         call CheckRemo(nBytes)
  623.         if (nBytes .eq. 0) then
  624.         ! no more data; do a write
  625.         call WriteLoco
  626.         else
  627.         ! there is more data; do another read
  628.         call WatchRemo(nBytes)
  629.         endif
  630.     endif
  631.     
  632.     return
  633.     end
  634.  
  635.     subroutine WriteLoco
  636. c
  637. c    sends a complete write-block to local terminal 
  638. c
  639. c    completion of the write runs AST sentLoco
  640. c
  641.     include 'VTERMDIR:vglobal.for/nolist'
  642.     include 'UTCS$INCLUDE:booleans.for/nolist'
  643.     
  644.     integer*4 status
  645.     external sentLoco
  646.  
  647.     status = sys$qio(,%val(localChannel),
  648.      1              %val(localWriteFunc),
  649.      1              ,
  650.      1              sentLoco,,
  651.      1              %ref(remoteToLocalBuf),
  652.      1              %val(localWriteChars),,,,)
  653.     call CheckStatus('writeLoco(immediate)',status)
  654.  
  655.     localWriteChars = 0
  656.     remoteReadStart = 1
  657.     
  658.     ! once again start read of remote terminal
  659.  
  660.     call Readremo
  661.  
  662.     return
  663.     end
  664.  
  665.     subroutine SentLoco
  666. c
  667. c    Routine used to collect statistics for tracing.
  668. c
  669.     include 'VTERMDIR:vglobal.for/nolist'
  670.     include 'UTCS$INCLUDE:booleans.for/nolist'
  671.  
  672.     return
  673.     end
  674.  
  675.     subroutine ReadLoco
  676. c
  677. c    issue a read to the local terminal
  678. c
  679. c    completion of the read runs AST WriteRemo 
  680. c
  681.     include 'VTERMDIR:vglobal.for/nolist'
  682.     include 'UTCS$INCLUDE:booleans.for/nolist'
  683.  
  684.     integer*4 status
  685.     external writeremo
  686.  
  687.     status = sys$qio(,%val(localChannel),
  688.      1              %val(localReadFunc),
  689.      1              %ref(localReadIosb),
  690.      1              writeremo,,
  691.      1              %ref(localToRemoteBuf),
  692.      1              %val(localReadSize),,
  693.      1              %ref(localterminator),,)
  694.  
  695.     call CheckStatus('ReadLoco(readLocalTerm)',status)
  696. c
  697.     return
  698.     end
  699.  
  700.     subroutine Writeremo
  701. c
  702. c    AST routine fired when local terminal read completes
  703. c    
  704. c    checks for VTerminal escape character in the received data
  705. c    if found begins termination of the program
  706. c    otherwise copies the data to the remote system
  707. c
  708. c    Completion of the write runs AST ReadLoco
  709. c
  710.     include 'VTERMDIR:vglobal.for/nolist'
  711.     include 'UTCS$INCLUDE:booleans.for/nolist'
  712.     include 'UTCS$INCLUDE:ssdef.for/nolist'
  713.     include 'UTCS$INCLUDE:iodef.for/nolist'
  714.  
  715.     integer*4 status,nBytes
  716.     logical escapeRequest
  717.     external readLoco
  718.  
  719.     ! check read status
  720.     status = localReadIosb(1)     ! Get status code.
  721.     if (status .eq. ss$_abort) then
  722.         ! read was cancelled; do it again
  723.         call ReadLoco 
  724.         return
  725.     elseif (status .eq. ss$_parity) then
  726.         call SendBreakChar
  727.         call ReadLoco
  728.         return
  729.     else
  730.             call CheckStatus('local read completion',status)
  731.     endif
  732.  
  733.     ! get number of bytes read
  734.     nBytes = localReadIosb(2) + localReadIosb(4)
  735.  
  736.     ! check for escape character
  737.     escapeRequest = FALSE
  738.     do ix=1,nBytes
  739.         if (localToRemoteBuf(ix) .eq. escapeChar) then
  740.         escapeRequest = TRUE
  741.         endif
  742.     enddo
  743.  
  744.     ! the escape character means that user wants out of session
  745.     if (escapeRequest) then
  746.         call ShutDown(ss$_normal)
  747.     else
  748.  
  749.         status = sys$qio(,%val(remoteChannel),
  750.      1                  %val(remoteWriteFunc),
  751.      1                  %ref(remoteWriteIosb),
  752.      1                  readLoco,,
  753.      1                  %ref(localToRemoteBuf),
  754.      1                  %val(nBytes),,,,)
  755.         call CheckStatus('WriteRemo(immediate)',status)
  756.  
  757.     endif
  758.  
  759.     return
  760.     end
  761.  
  762.     subroutine SendBreakChar
  763. c
  764. c    Subroutine to send a break character to the remote
  765. c    by   1. dropping remote line speed to 50 baud.
  766. c         2. sending two FF's.
  767. c         3. restoring line speed to original speed.
  768. c
  769.     include 'VTERMDIR:vglobal.for/nolist'
  770.     include 'UTCS$INCLUDE:booleans.for/nolist'
  771.     include 'UTCS$INCLUDE:iodef.for/nolist'
  772.     include 'UTCS$INCLUDE:ttdef.for/nolist'
  773.  
  774.     integer*4    remoteChar(2),lineSpeed,nBytes,status
  775.     integer*2    tempReadIosb(4), tempWriteIosb(4)
  776.     character*1    syncBytes(10)
  777.  
  778.     !  Set local write pointer to null
  779.     localWriteChars = 0
  780.  
  781.     !  Cancel all I/O on the remote channel.
  782.     status = sys$cancel(%val(remoteChannel))
  783.  
  784.     ! Get remote characteristics.
  785.     status = sys$qiow(,%val(remoteChannel),
  786.      1               %val(io$_sensemode),
  787.      1               %ref(tempReadIosb),,,
  788.      1               %ref(remoteChar),,,,,)
  789.     call CheckStatus('sendBreakChar(sensemode)', status)
  790.  
  791.     ! Save line speed from IOSB
  792.     lineSpeed = tempReadIosb(2)
  793.  
  794.     ! Set remote with 50 baud rate.
  795.     status = sys$qiow(,%val(remoteChannel),
  796.      1               %val(io$_setmode),
  797.      1               %ref(tempReadIosb),,,
  798.      1               %ref(remoteChar),,
  799.      1               %val(tt$c_baud_50),,,)
  800.     call CheckStatus('sendBreakChar(setmode50)', status)
  801.  
  802.     ! Write a three hex FF's to remote.
  803.     syncBytes(1) = char(0)
  804.     syncBytes(2) = char(0)
  805.     nBytes = 2
  806.     status = sys$qiow(,%val(remoteChannel),
  807.      1               %val(remoteWriteFunc),
  808.      1               %ref(tempWriteIosb),,,
  809.      1               %ref(syncBytes),
  810.      1               %val(nBytes),,,,)
  811.     call CheckStatus('sendBreakChar(writeBuf)',status)
  812.  
  813.     ! Set remote back to old line speed.
  814.     status = sys$qiow(,%val(remoteChannel),
  815.      1               %val(io$_setmode),
  816.      1               %ref(tempReadIosb),,,
  817.      1               %ref(remoteChar),,
  818.      1               %val(lineSpeed),,,)
  819.     call CheckStatus('sendBreakChar(setmode100)', status)
  820.  
  821.     return
  822.     end
  823.  
  824.     subroutine CheckStatus(facilityName,statusCode)
  825. c
  826. c    Subroutine to check status from a System Service.
  827. c
  828. c    Inputs:
  829. c        facilityName - Subroutine name.
  830. c        statusCode - Status code.
  831. c
  832.     include 'VTERMDIR:vglobal.for/nolist'
  833.     include 'UTCS$INCLUDE:booleans.for/nolist'
  834.     include 'UTCS$INCLUDE:iodef.for/nolist'
  835.     include 'UTCS$INCLUDE:ssdef.for/nolist'
  836.  
  837.     character*(*) facilityName
  838.     integer*4 statusCode
  839.  
  840.     character*(*) errorMessage
  841.     parameter (errorMessage = 'VTerminal Terminated with ERROR')
  842.  
  843.     character*80 message
  844.     integer*4 flags,msglen
  845.  
  846.     if (shuttingdown)
  847.      1        return
  848.  
  849.     if (mod(statusCode,2) .ne. 1) then
  850.  
  851.         ! obtain error message from the system
  852.         flags = "7    ! get text,id and severity, but not facility
  853.         call sys$getmsg(%val(statusCode),
  854.      1                %ref(msglen),
  855.      1                %descr(message),
  856.      1                %val(flags),)
  857.  
  858.         ! send it to the user
  859.         call WriteUser('%'//facilityName//'-'//message(2:msglen))
  860.  
  861.         ! and terminate
  862.         call ShutDown(statusCode)
  863.     endif
  864.  
  865.     return
  866.     end
  867.  
  868.     subroutine ShutDown(statusCode)
  869. c
  870. c    Subroutine to terminate VTerminal processing
  871. c
  872.     include 'VTERMDIR:vglobal.for/nolist'
  873.     include 'UTCS$INCLUDE:booleans.for/nolist'
  874.     include 'UTCS$INCLUDE:iodef.for/nolist'
  875.     include 'UTCS$INCLUDE:ssdef.for/nolist'
  876.  
  877.     integer*4 statusCode
  878.  
  879.     shuttingDown = TRUE
  880.  
  881.     status = sys$cancel(%val(remoteChannel))
  882.  
  883.     if (statusCode .eq. SS$_HANGUP) then
  884.         status = sys$dassgn(%val(remoteChannel))
  885.         connected = TRUE
  886.     endif
  887.  
  888.     ! Schedule a wake up for the hibernating process.
  889.     status = sys$wake(,)
  890.  
  891.     return
  892.     end
  893.  
  894.     subroutine WriteUser(message)
  895. c
  896. c    Write a message to the local terminal surrounded by CRLFs
  897. c
  898. c    Dont check completion status - called from termination 
  899. c    code so terminal may be gone.
  900. c
  901.     include 'VTERMDIR:vglobal.for/nolist'
  902.     include 'UTCS$INCLUDE:booleans.for/nolist'
  903.     include 'UTCS$INCLUDE:iodef.for/nolist'
  904.  
  905.     character*(*) message
  906.     integer*4 length,status
  907.  
  908.     print *,message
  909.  
  910.     return
  911.     end
  912. c
  913. c----------------------- Image and exit handler -------------------------
  914. c
  915.     subroutine SetUpExitHandlerVMS(swapm, priority)
  916. c
  917. c    Place the image into no swap mode, higher priority, and set up
  918. c    the exit handler.
  919. c
  920.     integer*4    status, exitBlock(4), swapm, priority
  921.  
  922.     call sys$setswm(%VAL(swapm))     
  923.     call sys$setpri(,,%VAL(priority),)     
  924.  
  925.     return
  926.     end
  927.