implicit integer*4 (a-z) include 'vth.inc/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) external send_ast character*1 sync ! the character to use to syncronize file transfering parameter cha_ret = char(13) character*2 bs_uline parameter readchar = io$_readpblk .or. io$m_trmnoecho .or. io$m_noecho * .or. io$m_timed 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) rchar,lchar ! buffers for terminal traffic character*(bufsize) logbuf ! buffer used to create logfile integer*2 riosb(4),liosb(4) character*(bufsize) sendbuf ! used to send files out character*80 command ! input buffer for == mode commands 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 = char(10) ! numeric values of ascii characters parameter return = char(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 bs_uline = char(8)//'_' sync = linefeed ! initial value of sync char command_char = char(1) ! control A is initial escape waitval = -1 ! default wait is none freq = 20 ! default frequency of polling is 0.20 seconds 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. acc_type_code = acc$k_insmsg ! the io function code that will be used. call error(10, sys$trnlog('SYS$INPUT',i,locdev,,,)) if ((locdev(5:7).ne.'_TT').and.(locdev(5:7).ne.'_OP').and. * (locdev(5:7).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 call error (30,sys$trnlog('DIAL_OUT_MODEM',length,remdev,,,)) if ((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 do while (retcode.eq.ss$_devalloc) ! 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$_uic,4,devuic)) ! get the user id code, to see if it is login-out if (devuic.eq.'80020'x) then ! we will kill the process ! 80020 hex is equal to [10,40] in modified split octal call error (40,sys$delprc(devprocid,)) retcode = sys$assign(remdev(:length),rchanin,,) else call getjpi(devprocid,jpi$_username,12,%ref(username)) write (6,1001) ' modem is in use by '//username stop 'try again later' 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) 90 continue if (inunit.eq.5) stop 'VTH termination' inunit = 5 ! assume the port is set up properly. write (6,1001) ' Welcome to the virtual terminal handler ' 100 continue ! top of command loop write (6,1002) ' == ' read (inunit,1001,end=90) command call str$upcase(command,command) if (command.eq.'START') then call setterm (lchanin) call sys$qiow(,%val(rchanout),%val(io$_writepblk) * ,,,,z,%val(1),,,,) ! issues Z command to modem call wait(200) call sys$qiow(,%val(rchanout),%val(io$_writepblk) * ,,,,return,%val(1),,,,) ! sends the carriage return call sys$qiow(,%val(rchanout),%val(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:1).eq.'@') then if (inunit.ne.5) then write (6,1001) ' no nesting of command files allowed' else command = command(2:) open (unit=26,name=command,readonly,type='old',err=95) inunit = 26 go to 100 end if 95 write (6,1001) ' error opening file: '//command go to 100 else if (command.eq.'ULINE') then if(.not.halfdup) write(6,1001) ' requires halfdup to work' uline = .true. else if (command.eq.'STATS') then write (6,6001)send_total,send_count,local_total,local_count, * remote_total,remote_count,io_count 6001 format( * ' number of characters transfered out: ',i,/, * ' number of lines transfered out: ',i,/, * ' number of characters read locally: ',i,/, * ' number of reads needed locally: ',i,/, * ' number of characters read remotelly: ',i,/, * ' number of reads needed remotelly: ',i,/, * ' total number of reads each way: ',i * ) else if (command.eq.'VMS') then call creproc else if (command.eq.'NOULINE') then uline = .false. else if (command.eq.'QUIT') then call sys$exit(%val(1)) 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, * 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 (inunit,3002,end=110,err=110) command_char 3002 format (i) else if (command.eq.'SYNC') then 120 continue write (6,3003) ichar(sync) 3003 format(' present sync: ',i4,' new sync: ',$) read (inunit,3002,end=120,err=120) isync sync = char(isync) else if (command.eq.'WAIT') then 220 continue write (6,3004) waitval 3004 format(' present wait: ',i4,' new wait: ',$) read(inunit,3002,err=220,end=220) waitval else if (command.eq.'FREQ') then 320 continue write (6,4004) freq 4004 format(' present frequency: ',i4,' new frequency: ',$) read(inunit,3002,err=320,end=320) freq else if (command(1:5).eq.'SEND=') then command=command(6:) sendfile = .true. open(unit=24,name=command,type='old',err=130,shared,readonly) send_total = 0 send_count = 0 go to 150 130 continue write (5,1001) ' error opening file: '//command else if (command.eq.'ABORT') then sendfile = .false. close (unit=24,err=100) else if (command.eq.'EVEN') then parity = even else if (command.eq.'RESTART' .or. command.eq.'BEGIN') 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 sync_flag = .false. if (sendfile) then read (24,1003,err=970,end=970) j,sendbuf send_total = send_total + j send_lines = send_lines + 1 j = j+1 sendbuf(j:j) = cha_ret ! stick a carriage return on the end if (parity.ne.none) call setpar(sendbuf(:j),parity) call sys$qio(,%val(rchanout),%val(io$_writepblk) * ,,send_ast,,%ref(sendbuf),%val(j),,,,) end if 200 continue call sys$qio(,%val(rchanin),%val(readchar),riosb,,, * %ref(rchar),%val(bufsize),,,,) call sys$qio(,%val(lchanin),%val(readchar),liosb,,, * %ref(lchar),%val(bufsize),,,,) io_count = io_count + 1 lenl = liosb(2) + liosb(4) if (lenl.gt.0) then ! we have done a local read local_total = local_total + lenl local_count = local_count + 1 if ( 0.eq.index(lchar(:lenl),command_char) ) then call setpar (lchar(:lenl),parity) call sys$qiow(,%val(rchanout), * %val(io$_writepblk),,,,%ref(lchar),%val(lenl),,,,) if (halfdup) call sys$qiow(,%val(lchanout), * %val(io$_writepblk),,,,%ref(lchar),%val(lenl),,,,) if (halfdup.and.logfile) then call lfwrite(lchar(:lenl)) if (uline) then do j = 1,2 do k = 1,lenl lchar(k:k) = bs_uline(j:j) end do call lfwrite(lchar(:lenl)) end do end if end if else call sys$cancel(%val(lchanin)) call sys$cancel(%val(rchanin)) call unsetterm (lchanin) go to 100 end if end if lenr = riosb(2) + riosb(4) if (lenr.gt.0) then ! we have a remote read done remote_total = remote_total + lenr remote_count = remote_count + 1 call sys$qiow(,%val(lchanout),%val(io$_writepblk) * ,,,,%ref(rchar),%val(lenr),,,,) if (0.ne.index(rchar(:lenr),sync).and.sync_wait) then ! continue sending the file sync_wait = .false. if(waitval.ge.0) call wait(waitval) read (24,1003,end=970,err=970) j,sendbuf send_total = send_total + j send_count = send_count + 1 j = j + 1 sendbuf(j:j) = cha_ret if (parity.ne.none) call setpar(sendbuf(:j),parity) call sys$qio(,%val(rchanout),%val( * io$_writepblk),,send_ast,,%ref(sendbuf),%val(j),,,,) end if if (logfile) call lfwrite(rchar(:lenr)) end if call wait (freq) 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 (inunit.ne.5) go to 100 go to 150 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 subroutine send_ast include 'vth.inc/nolist' sync_wait = .true. return end