implicit integer*4 (a-z) include 'vth.inc/nolist' parameter read_func = io$_readpblk.or.io$m_trmnoecho.or.io$m_noecho 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,read_ast integer*4 exit_block(4) byte sync ! the character to use to syncronize file transfering parameter cha_ret = char(13) parameter bs_uline = '_'//char(8) character*63 locdev ! will be name of local physical device. character*63 remdev ! the name of the device with the modem character*80 help_buffer ! used by help command 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 = 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(1) = .false. logfile(2) = .false. halfdup = .false. acc_type_code = acc$k_insmsg call error(10, sys$trnlog('SYS$ERROR',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),portchan(1),,)) ! 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),portchan(2),,) ! 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),portchan(2),,) 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 ! 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 (portchan(2)) ! assume the port is set up properly. do j = 1,buf_count bufadd(j) = %loc(buffer(1,j)) end do write (6,1001) ' Welcome to the virtual terminal handler ' 100 continue ! top of command loop write (6,1002) ' == ' read (5,1001,end=100) command call str$upcase(command,command) if (command.eq.'START') then call setterm (portchan(1)) go to 150 ! go to transparent operation loop 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 creproc else if (command.eq.'NOULINE') then uline = .false. else if (command.eq.'QUIT') then if (logfile(2)) call write_log_file(32) 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 call logfile_init open (unit=32,carriagecontrol='LIST',name=command(9:), * type='NEW') logfile(2) = .true. else if (command.eq.'CLOSE') then logfile(2) = .false. call write_log_file(32) 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 (5,3002,end=110,err=110) command_char 3002 format (i) else if (command.eq.'SYNC') then 120 continue write (6,3003) sync 3003 format(' present sync: ',i4,' new sync: ',$) read (5,3002,end=120,err=120) sync else if (command.eq.'WAIT') then 220 continue write (6,3004) waitval 3004 format(' present wait: ',i4,' new wait: ',$) read(5,3002,err=220,end=220) waitval 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 (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') then call setterm (portchan(1)) 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) help_buffer = ' ' do while (.true.) read(21,4001,end=900) j,help_buffer 4001 format (q,a) write (6,1001) ' '//help_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 portdest(1) = 2 portdest(2) = 1 bufuse(1) = 1 bufuse(2) = 2 sync_flag = .false. do j = 1,2 bsize(j) = 1 call error(1020,sys$qio(,%val(portchan(j)),%val(read_func),iosb(1,j), * read_ast,%val(j),%val(bufadd(j)),%val(1),,,,)) end do call error(1030,sys$hiber()) call sys$cancel(portchan(1)) call sys$cancel(portchan(2)) call unsetterm(portchan(1)) go to 100 1001 format (a) 1002 format (a,$) 1003 format (q,a) end subroutine readast(astprm) implicit integer*4 (a-z) include 'vth.inc' external writeast external read_ast parameter read_func = io$_readpblk.or.io$m_trmnoecho.or.io$m_noecho c come here when a read completes bufnum = %loc(astprm) port = bufuse(bufnum) ! port from which we just read outport = portdest(port) ! port to which we will write len = iosb(2,bufnum) + iosb(4,bufnum) if (logfile(port)) call make_log_file(buffer(1,bufnum),len) char_count = char_count + len io_count = io_count + 1 do j = 1,len if (buffer(j,bufnum) .eq. 1) then call error(1035,sys$wake(,)) return end if end do c c next fix the associated buffer length for the port we just read from c if (iosb(1,bufnum).eq.ss$_timeout) then bsize(port) = 1 lastport = port consec_count = 1 else if ((lastport.eq.port).and. * (len.eq.bsize(port)) .and. * (consec_count.ge.4) ) then ! the buffer is full bsize(port) = min(bsize(port)*4,max_bsize) lastport = -1 consec_count = 0 else if (lastport.eq.port) then consec_count = consec_count + 1 else consec_count = 0 end if lastport = port end if c call error(1040,sys$qio(,%val(portchan(outport)),%val(io$_writepblk), * iosb(outport,1), * writeast,%val(bufnum),%val(bufadd(bufnum)), * %val(len),,,,)) c c now that we have settled the buffer length, we can issue a new read c c first, get a free buffer c call error(1050,lib$remqhi (bufq(buf_count+1),addr)) c offset = %loc(bufq(buf_count+1)) - addr c bnum = buf_count + 1 - (offset/8) c bufuse(bnum) = port return end subroutine writeast (astprm) implicit integer*4 (a-z) include 'vth.inc' external read_ast parameter read_func = io$_readpblk.or.io$m_trmnoecho.or.io$m_noecho c bnum = %loc(astprm) port = bufuse(bnum) c j = read_func if (bsize(port).gt.1) j = j .or. io$m_timed call error(1060,sys$qio (,%val(portchan(port)), * %val(j), * iosb(1,bnum), * read_ast, * %val(bnum), * %val(bufadd(bnum)), * %val(bsize(port)), * %val(1),,,)) c call error(1070,lib$insqhi(bufq(bnum),bufq(buf_count+1))) return end c subroutine read_ast(x) integer*4 x call readast(x) return end c subroutine error(in,code) implicit integer*4 (a-z) if (code) return write (6,1001) in 1001 format (' fatal error at location ',i) call sys$exit(%val(code)) end subroutine reset_world implicit integer*4 (a-z) ! this is VTH's exit handler. return end subroutine wait(n) implicit integer*4 (a-z) common /timedummy/ time,negone time = -100000 * n negone = -1 call sys$clref (%val(5)) call sys$setimr (%val(5),time,,) call sys$waitfr (%val(5)) return end integer*4 function getjpi (procid,code,buflen,result) implicit integer*4 (a-z) integer*2 len1,len2,code1,code2 common /mbpdummy/ len1,code1,addr1,lenaddr1,len2,code2 data len2 /0/, code2 /0/, lenaddr1 /0/ ! zero out unused stuff len1 = buflen code1 = code addr1 = %loc(result) getjpi = sys$getjpi(,procid,,len1,,,) return end subroutine creproc implicit integer*4 (a-z) integer*2 mbchan,mlen,inchan integer*4 privs(2) character*64 device,inbox,mname include 'dibdef.for' include 'iodef.for' include 'jpidef.for' byte termbuf(100) character*(dib$k_length+1) chanbuf integer*2 unit byte xxx equivalence (unit,xxx) equivalence (chanbuf(13:14),xxx) call getjpi (,jpi$_authpriv,8,privs) j = sys$crembx (,mbchan,,,,,) call error(910,j) j = sys$getchn (%val(mbchan),,chanbuf,,) call error(920,j) call error(940,sys$trnlog('SYS$INPUT',len,device,,,)) j = sys$trnlog(inbox(:6),mlen,mname,,,) call error (960,j) j = sys$creprc ( ,'SYS$SYSTEM:LOGINOUT', * device(5:len),device(5:len), * device(5:len),privs,,,%VAL(4),,%val(unit),%val(0)) call error(930,j) j = sys$qiow(,%val(mbchan),%val('31'x),,,,termbuf,%val(100),,,,) return end subroutine setpar(cha,mode) byte table(0:127) include 'include.for' logical*1 temp byte cha integer*2 mode common /dummy/ table ! ! this routine receives a character and returns ! it with its parity bit set properly, according ! to mode ! temp = table(cha) .eq. 1 cha = cha .and. '7f'x if (mode .eq. none) return if (mode .eq. ones) temp = .true. if (mode .eq. even) temp = .not. temp if (temp) cha = cha .or. '80'x return end block data common /dummy/ table byte table(0:127) data table / * 0,1,1,0,1,0,0,1,1,0,0,1,0,1,1,0, * 1,0,0,1,0,1,1,0,0,1,1,0,1,0,0,1, * 1,0,0,1,0,1,1,0,0,1,1,0,1,0,0,1, * 0,1,1,0,1,0,0,1,1,0,0,1,0,1,1,0, * 1,0,0,1,0,1,1,0,0,1,1,0,1,0,0,1, * 0,1,1,0,1,0,0,1,1,0,0,1,0,1,1,0, * 0,1,1,0,1,0,0,1,1,0,0,1,0,1,1,0, * 1,0,0,1,0,1,1,0,0,1,1,0,1,0,0,1/ end C SETVAXNET.FOR C C THIS SUBROUTINE GETS THE CURRENT CHARACTERISTICS OF THE CHANNEL C ASSIGNED TO THE REMOTE VAXNET PORT. IT THEN CHANGES THE C CHARACTERISTICS SO THAT THE PORT WILL WORK PROPERLY FOR VAXNET. C ON PROPER VAXNET TERMINATION, THE ENTRY POINT SETNORMAL IS C USED TO MAKE THE PORT ACCESSIBLE TO NORMAL DIAL-UP. C C J. THOMPSON INTERMETRICS 27 JULY 1979 C SUBROUTINE setterm(chan_num) ! channel number is the channel of the terminal we want to set implicit integer*4 (a-z) include 'include.for' LOGICAL*1 B,BE(128),CLASS,TYPE,PAGELENGTH INTEGER*2 PAGEWIDTH INTEGER*4 TERM_CHAR CHARACTER*128 BUFF !CHARACTERISTICS BUFFER COMMON/RTTCHAR/ B(128) EQUIVALENCE (BE(1),BUFF(1:1)) EQUIVALENCE (CLASS,B(5)), (TYPE,B(6)) EQUIVALENCE (PAGEWIDTH,B(7)), (TERM_CHAR,B(9)) EQUIVALENCE (PAGELENGTH,B(12)) EQUIVALENCE (W1,B(1)),(W2,B(5)),(W3,B(9)) EXTERNAL TT$M_LOWER,TT$M_MECHTAB,TT$M_NOECHO EXTERNAL TT$M_WRAP,TT$M_REMOTE,TT$M_PASSALL,TT$M_SCOPE external tt$m_holdscreen,tt$m_ttsync,tt$m_halfdup external tt$m_hostsync call error(120,SYS$GETCHN(%VAL(chan_num),L1,BUFF,,,)) DO 100 I=1,L1 100 B(I)=BE(I) TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_LOWER) TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_MECHTAB) TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_NOECHO) term_char = term_char .or. %loc(tt$m_hostsync) TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_REMOTE) TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_PASSALL) TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_SCOPE) term_char = term_char.and..not.%loc(tt$m_holdscreen) term_char = term_char.and..not.%loc(tt$m_ttsync) term_char = term_char.and..not.%loc(tt$m_halfdup) NOWRAP = .NOT. %LOC(TT$M_WRAP) TERM_CHAR = TERM_CHAR .AND. NOWRAP PAGEWIDTH = 132 call error(110,SYS$QIOW(,%VAL(chan_num),%VAL(%LOC(IO$_SETMODE)),,,, * B(5),%VAL(8),,,,)) C THE %VAL(8) IS THE LENGTH OF THE CHARACTERISTICS BUFFER WHICH C STARTS AT BYTE 5 OF ARRARY B. THIS P2 PARAMETER IS NOT DOCUMENTED C UP THROUGH RELEASE 1.5 OF VMS. RETURN C RESET TERMINAL SO IT CAN BE USED AS A DIAL-UP. C (DON'T NEED TO RESET ALL CHARACTERISTICS) entry unsetterm (chan_num) call error (130,SYS$GETCHN(%VAL(chan_num),L1,BUFF,,,)) DO 200 I = 1,L1 200 B(I) = BE(I) ECHO = .NOT. %LOC(TT$M_NOECHO) INTERACTIVE = .NOT. %LOC(TT$M_PASSALL) TERM_CHAR = TERM_CHAR .AND. ECHO TERM_CHAR = TERM_CHAR .AND. INTERACTIVE TERM_CHAR = TERM_CHAR .OR. %LOC(TT$M_WRAP) term_char = term_char .or. %loc(tt$m_ttsync) PAGEWIDTH = 80 call error (140,SYS$QIOW(,%VAL(chan_num),%VAL(%LOC(IO$_SETMODE)),,,, * B(5),%VAL(8),,,,)) RETURN END