implicit integer*4 (a-z) include 'include.for/nolist' common /vtharea/ rchanin,lchanin byte devbuf(0:dib$k_length) ! array of bytes for the device info character*(dib$k_length) devstring ! need to pass by string desc. equivalence (devbuf,devstring) equivalence (devprocid,devbuf(dib$l_pid)) ! the proc id of modem user character*12 username ! username of vth user, for error message character*12 okayname ! used w/ above to chech permission to run vth external reset_world integer*4 exit_block(4) logical*1 halfdup ! true means a half duplex machine logical*1 uline ! underline input in session log (requires halfdup) logical*1 sendfile ! means file transfer outward is in progress logical*1 sync_wait ! waiting for sync to continue transfer logical*1 fill ! true means vth is NOT to swallow fill characters logical*1 logfile ! true means that the user wants a log made byte lchar,rchar ! buffers for the char by char I/O byte sync ! the character to use to syncronize file transfering parameter efn1 = 1, efn2 = 2, efn1_mask = 2, efn2_mask = 4 parameter efn3 = 3, efn3_mask = 8 parameter cha_ret = char(13) parameter bs_uline = '_'//char(8) parameter modemcnt = 2 character*14 dial_out_name(modemcnt) data dial_out_name(1) /'DIAL_OUT_MODEM'/ data dial_out_name(2) /'DIAL_OUT_MOD_1'/ character*63 locdev ! will be name of local physical device. character*63 remdev ! the name of the device with the modem character*80 buffer ! used by help command parameter bufsize = 1000 ! for file transfers character*(bufsize) logbuf ! buffer used to create logfile character*(bufsize) sendbuf ! used to send files out character*80 command ! input buffer for == mode commands byte command_char ! store the escape char, initialized to ^A parameter z = ichar('Z') ! letters to send to modem parameter a = ichar('A') ! for start command reset byte delecho(3) ! send backspace,space,backspace data delecho /8,32,8/ ! to echo a delete parameter linefeed = 10 ! numeric values of ascii characters parameter return = 13 call getjpi(,jpi$_username,12,%ref(username)) open(unit=21,name='_drb3:[morris]okaylist.vth',readonly, * type='old',err=9900) k = 12 do while (username(k:k).le.' ') k = k - 1 end do do while (.true.) read(21,1003,end=9900,err=9900) j,okayname if (okayname(1:j).eq.username(1:k)) goto 10 end do 9900 stop 'This program is restricted to the IDBS technical staff' 10 continue ! this person is on the okaylist sync = linefeed ! initial value of sync char command_char = 1 ! control A is initial escape waitval = -1 ! default wait is none parity = none ! default is zero in parity bits uline = .false. ! don't do underlining in session log fill = .true. ! default is to pass through fill characters logfile = .false. halfdup = .false. c readchar = %loc(io$_readpblk) + %loc(io$m_trmnoecho) + * %loc(io$m_noecho) ! the io function code that will be used. call error(10, sys$trnlog('SYS$INPUT',i,locdev,,,)) if ((locdev(5:8).ne.'__TT').and.(locdev(5:8).ne.'__OP').and. * (locdev(5:8).ne.'__PT')) then stop 'VTH must NEVER be used from a command file, or batch' end if ! figure out which terminal we are being run from call error(20, sys$assign(locdev(5:i),lchanin,,)) lchanout = lchanin ! set up channels for the users terminal ! figure out what device the dialout modem is attached to ! by translating the logical name DIAL_OUT_MODEM do j=1,modemcnt call error (30,sys$trnlog(dial_out_name(j),length,remdev,,,)) if ((remdev(:4).ne.'__TT').and.(remdev(:4).ne.'__PT').and. * (remdev(:3).ne.'_TT').AND.(remdev(:3).ne.'_PT') ) then stop 'DIAL_OUT_MODEM must be assigned to a terminal port' end if ! what device do we use as the remote terminal? retcode = sys$assign(remdev(:length),rchanin,,) ! assign a channel to the modem if (retcode.eq.ss$_devalloc) then! it is allocated to someone call error(35,sys$getdev(remdev(:length),,devstring,,)) ! get the proc id of the process owning the modem call error(37,getjpi * (devprocid,jpi$_username,12,%ref(username))) ! get the user name, to see if it is login if (username(1:7).eq.'') then ! we will kill it call error (40,sys$delprc(devprocid,)) retcode = sys$assign(remdev(:length),rchanin,,) else write (6,1001) ' modem is in use by '//username if (j.eq.modemcnt)stop 'try again later' end if end if end do call error (47,retcode) ! in case the assign failed for other reasons rchanout = rchanin ! set up channels for the modem. ! set up an exit handler exit_block(2) = %loc(reset_world) exit_block(3) = 1 exit_block(4) = %loc(status) call error (50,sys$dclexh(exit_block)) call setterm (rchanin) ! assume the port is set up properly. write (6,1001) ' Welcome to the virtual terminal handler ' cunit = 5 go to 100 99 continue if (cunit.eq.31) then close (unit=31) cunit = 5 else if (cunit.eq.5)then stop ' ' else close (unit = cunit) cunit = cunit - 1 end if 100 continue ! top of command loop if (cunit.eq.5) write (6,1002) ' == ' read (cunit,6001,end=99) command_len,command 6001 format (q,a) call str$upcase(command,command) if (command(1:1).eq.'@') then if (cunit.gt.30) then cunit = cunit + 1 else cunit = 31 end if open (unit=cunit,name=command(2:),type='old',readonly,err=602) go to 100 602 continue write (6,1001) ' file '//command(2:)//' could not be opened' cunit = 5 else if (command.eq.'START') then call setterm (lchanin) call sys$qiow(,%val(rchanout),%val(%loc(io$_writepblk)) * ,,,,z,%val(1),,,,) ! issues Z command to modem call wait(200) call sys$qiow(,%val(rchanout),%val(%loc(io$_writepblk)) * ,,,,return,%val(1),,,,) ! sends the carriage return call sys$qiow(,%val(rchanout),%val(%loc(io$_writepblk)) * ,,,,a,%val(1),,,,) ! send an A to get it in answer mode go to 150 ! go to transparent operation loop else if (command(1:6).eq.'WRITE=') then command(command_len+1:command_len+1) = cha_ret call sys$qiow(,%val(rchanout),%val(%loc(io$_writepblk)) * ,,,,%ref(command(7:)),%val(command_len-5),,,,) else if (command.eq.'ULINE') then if(.not.halfdup) write(6,1001) ' requires halfdup to work' uline = .true. else if (command.eq.'VMS') then call lib$spawn else if (command.eq.'NOULINE') then uline = .false. else if (command.eq.'QUIT') then stop ' vth termination ' else if (command.eq.'FILL') then fill = .true. else if (command.eq.'NOFILL') then fill = .false. else if (command(1:8).eq.'LOGFILE=') then command = command(9:) ! the file name logfile = .true. open (unit=22,name=command,type='new',err=125, * recl=bufsize,carriagecontrol='list') point = 0 ! buffer empty now go to 100 125 continue ! to handle file open errors write (6,1001) ' file: '//command//' could not be opened' go to 100 else if (command.eq.'CLOSE') then close (unit=22) logfile = .false. else if (command.eq.'ESCAPE') then 110 continue ! in case of an error on the read, do it again. write (6,3001) command_char 3001 format (' present escape: ',i4,' new escape: ',$) read (cunit,3002,end=110,err=110) command_char 3002 format (i) else if (command(:6).eq.'ESCAPE') then j = index (command,'^') if (j.gt.0) then command_char = ichar(command(j+1:j+1)) - 64 else call ots$cvt_ti_l(command(7:),command_char,%val(4),%val(3)) end if write (6,3007) command_char 3007 format (' escape character is:',i) else if (command.eq.'SYNC') then 120 continue write (6,3003) sync 3003 format(' present sync: ',i4,' new sync: ',$) read (cunit,3002,end=120,err=120) sync else if (command(:4).eq.'SYNC') then j = index (command,'^') if (j.gt.0) then sync = ichar(command(j+1:j+1)) - 64 else call ots$cvt_ti_l(command(5:),sync,%val(4),%val(3)) end if write (6,3006) sync 3006 format (' sync value: ',i) else if (command.eq.'WAIT') then 220 continue write (6,3004) waitval 3004 format(' present wait: ',i4,' new wait: ',$) read(cunit,3002,err=220,end=220) waitval else if (command(1:4).eq.'WAIT') then call ots$cvt_ti_l(command(5:),waitval,%val(4),%val(3)) write (6,3005) waitval 3005 format (' wait value: ',i) else if (command(1:5).eq.'SEND=') then command=command(6:) sendfile = .true. open(unit=24,name=command,type='old',err=130,shared,readonly) go to 150 130 continue write (6,1001) ' error opening file: '//command else if (command.eq.'ABORT') then sendfile = .false. cunit = 5 close (unit=24,err=100) else if (command.eq.'EVEN') then parity = even else if (command.eq.'RESTART') then call setterm (lchanin) go to 150 else if (command.eq.'ODD') then parity = odd else if (command.eq.'NONE') then parity = none else if (command.eq.'ONES') then parity = ones else if (command.eq.'HALFDUP') then halfdup = .true. else if (command.eq.'FULLDUP') then halfdup = .false. else if (command.eq.'HELP') then open (unit=21,err=900,name='drb3:[morris.termio]vth.hlp', * type='old',readonly) buffer = ' ' do while (.true.) read(21,4001,end=900) j,buffer 4001 format (q,a) write (6,1001) ' '//buffer(:j) end do 900 continue close (unit=21) else write (6,1001) ' illegal command ' end if go to 100 150 continue ! now we are ready for the main I/O loop call sys$clref(%val(3)) sync_flag = .false. if (sendfile) then read (24,1003,err=970,end=970) j,sendbuf j = j+1 sendbuf(j:j) = cha_ret ! stick a carriage return on the end if (parity.ne.none) then do n = 1,j call setpar(%ref(sendbuf(n:n)),parity) end do end if call sys$qio(%val(3),%val(rchanout),%val(%loc(io$_writepblk)) * ,,,,%ref(sendbuf),%val(j),,,,) end if ! issue a qio read in each direction, to start it off. call sys$qio(%val(1),%val(rchanin),%val(readchar),,,, * rchar,%val(1),,,,) call sys$qio(%val(2),%val(lchanin),%val(readchar),,,, * lchar,%val(1),,,,) 200 continue ! this statement is the top of the main loop. call sys$wflor(%val(0),%val(14)) ! 14 = bits 1,2, & 3 set. call sys$readef (%val(2),state) ! at this point, we know that one of the three waits has ! just been answered, the next if statement figures out ! which one. if (( state.and.efn2_mask) .ne. 0) then ! it was #2 local read done call setpar (lchar,parity) if ((lchar.and.'7f'x).ne.command_char) then call sys$qio(,%val(rchanout),%val(%loc(io$_writepblk)) * ,,,,lchar,%val(1),,,,) ! send it to the remote device. ! if half duplex, then echo the character to the user if (halfdup) then if ((lchar.and.'7f'x).ne.127) then call sys$qio(,%val(lchanout),%val( * %loc(io$_writepblk)),,,,lchar,%val(1),,,,) else ! it was a so echo space call sys$qio(,%val(lchanout),%val( * %loc(io$_writepblk)),,,,delecho, * %val(3),,,,) point = point - 1 ! take out of logfile if (uline) point = point - 2 end if if (logfile.and.(lchar.and.'7f'x).ne.127) then if (uline) then if(lchar.ne.return) then point=min(bufsize,point+2) logbuf(point-1:point)=bs_uline else point=min(bufsize,point+4) logbuf(point-3:point)='' end if end if point=min(bufsize,point+1) logbuf(point:point)=char(lchar) end if end if call sys$qio(%val(2),%val(lchanin),%val(readchar),,,, * lchar,%val(1),,,,) ! issue another local read request else call sys$cancel(%val(lchanin)) call sys$cancel(%val(rchanin)) call unsetterm (lchanin) go to 100 end if else if ((state.and.efn3_mask).ne.0.and.sendfile) then sync_wait = .true. call sys$clref (%val(efn3)) else ! it was #1, remote read done. if ((((rchar.or.'80'x).ne.'ff'x).and.rchar.ne.0).or.fill) then call sys$qio(,%val(lchanout),%val(%loc(io$_writepblk)) * ,,,,rchar,%val(1),,,,) if (rchar.eq.sync.and.sync_wait) then ! continue sending file sync_wait = .false. if(waitval.ge.0) call wait(waitval) read (24,1003,end=970,err=970) j,sendbuf j = j + 1 sendbuf(j:j) = cha_ret if (parity.ne.none) then do n = 1,j call setpar(%ref(sendbuf(n:n)),parity) end do end if call sys$qio(%val(3),%val(rchanout),%val(%loc( * io$_writepblk)),,,,%ref(sendbuf),%val(j),,,,) end if if (logfile) then ! this is the code to creat a file on the vax. We will assume that ! the linefeed character marks where one record stops, and where the ! next begins. if (rchar.eq.linefeed) then start = 1 do while (logbuf(start:start).eq.cha_ret) start = start + 1 end do do while (logbuf(point:point).eq.cha_ret) point=point - 1 end do if(point.gt.0) then write (22,5001,err=950) logbuf(start:point) else write (22,5001,err=950) end if 5001 format (a) point = 0 else ! this is a regular character point = min(bufsize,point + 1) logbuf(point:point) = char(rchar) end if go to 960 950 continue ! for error writing log file write (6,1001) ' == ERROR WRITING LOG FILE '//CHAR(7) logfile = .false. 960 continue end if end if call sys$qio(%val(1),%val(rchanin),%val(readchar),,,, * rchar,%val(1),,,,) ! issue another remote read request end if go to 200 970 continue ! for end of file on transfer outward sendfile = .false. close (unit=24,err=100) write (6,1001) char(7)//' == VTH file transfer finished'//char(7) write (6,1001) ' ' ! to place users cursor at lower left call sys$cancel(%val(lchanin)) call sys$cancel(%val(rchainin)) if (cunit.eq.31) then call unsetterm (lchanin) go to 100 else go to 150 end if 1001 format (a) 1002 format (a,$) 1003 format (q,a) end subroutine error(in,code) implicit integer*4 (a-z) character*132 mess if ((code.and.1).ne.0) return call sys$getmsg(%val(code),len,mess,%val(15),) write (6,2001) in,mess(1:len) 2001 format (' location = ',i3,2x,a) call exit end subroutine reset_world implicit integer*4 (a-z) ! this is VTH's exit handler. common /vtharea/ rchanin,lchanin call unsetterm(rchanin) call unsetterm(lchanin) return end