program nanny c c Execute some of the Nanny's functions c parameter ss$_normal = 1 parameter maxcom = 28 parameter nan$_comdis = '1f'x parameter nan$_invcom = '1d'x parameter nan$_nonsys = '21'x parameter nan$_nopriv = '20'x parameter nan$_normal = 1 parameter nan$_noslot = '1b'x parameter nan$_nosuchcom = '1e'x parameter nan$_retwarn = '1c'x parameter nan_inp = 'NANNYS$BOX:' implicit integer*4 (a-z) include '($jpidef)' include '($lnmdef)' character*80 comand character*28 version character*23 req_datim character*14 tty character*10 shoe_box_nam character*8 my_pid character*7 coms(maxcom) integer*4 jpilist(4),com_abv(maxcom),qwait(2),lnmlis(4) integer*2 term_chan,req_id,req_user(2) logical*1 buff,buffr(28) equivalence (buffr,version) data coms/'ADDACC','DIE','ENTER','EXIT','FORGET','FREE', 1 'GRAB','IDLESET','IGNORE','ISHOW','KILL','LISTEN','NEW', 2 'ODIS','OEN','PAUSE','QSTART','QSTOP','READ','REQUEUE', 3 'RESUME','STOP','SUSPEND','VERSION','WAKE','WCLR','WDUMP', 4 'WSHOW'/ data com_abv/1,1,2,2,2,2,1,2,2,2,1,1,1,2,2,1,4,4,3,3,3, 1 2,2,1,2,2,2,2/ c c Create a mailbox to communicate with the Nanny c code = sys$crembx(%val(0),term_chan,,,,,'SHOE_BOX') if (code.ne.ss$_normal) call sys$exit(%val(code)) lnmlis(1) = lnm$_string * 2**16 + 10 lnmlis(2) = %loc(shoe_box_nam) lnmlis(3) = 0 lnmlis(4) = 0 code = sys$trnlnm(,'LNM$JOB','SHOE_BOX',,lnmlis) if (code.ne.ss$_normal) call sys$exit(%val(code)) c c Get the user's process I.D. c jpilist(1) = jpi$_pid*2**16 + 4 jpilist(2) = %loc(pid) jpilist(3) = 0 jpilist(4) = 0 code = lib$get_ef(ef) if (code.ne.ss$_normal) call sys$exit(%val(code)) code = sys$getjpi(%val(ef),,,jpilist,,,) if (code.ne.ss$_normal) call sys$exit(%val(code)) call sys$waitfr(%val(ef)) write(my_pid,'(Z8)',err=1) pid do while(lench(my_pid(1:1)).eq.0) my_pid = my_pid(2:) end do goto 2 c c Error converting the process I.D. to a character string. c 1 call errsns(i,j,k,l,code) call sys$exit(%val(code)) c c Open the mailbox to the Nanny c 2 open(unit=1,name=nan_inp,shared,err=1,status='old') c c Prompt for commands c 3 write(5,'(a)',err=4) '$Nanny> ' 4 read(5,'(a)',err=3,end=999) comand if (lench(comand).eq.0) goto 3 call str$upcase(comand,comand) do while(lench(comand(1:1)).eq.0) comand = comand(2:) end do c c Give help c if (comand(1:1).eq.'H'.or.comand(1:1).eq.'?') then write(6,100) goto 3 end if c c Replace the input command with the full length command c comnum=0 i=index(comand,' ') do j=1,maxcom if (comand(:i-1).eq.coms(j)(:i-1)) comnum=j end do if (comnum.eq.4) call exit if (comnum.eq.25.or.comnum.eq.26.or.comnum.eq.28) then write(6,'(a)') ' Command unavailable from this program' goto 3 end if if (comnum.eq.0) then write(6,'(a)') ' No such command. Try "HELP".' goto 3 end if if (i.lt.com_abv(comnum)) then write(6,'(a)') ' Ambiguous command' goto 3 end if c c Insert the receiving mailbox c comand=coms(comnum)(:len1(coms(comnum)))//' '//shoe_box_nam(: 1 len1(shoe_box_nam))//' '//my_pid(:len1(my_pid))//' '// 2 comand(i+1:) write(1,'(a)',err=1) comand(:len1(comand))//' ' d write(5,'(a)',err=1) ' '//comand(:len1(comand))//' ' write(5,'(a)',err=5) ' Waiting for a reply from your Nanny...' if (comnum.eq.10) then code=sys$qiow(,%val(term_chan),%val('31'x),,,,buffr, 1 %val(16),,,,) if (code.ne.ss$_normal) then write(6,'(a)') ' Error receiving idle cycle number' goto 3 end if if (lib$extzv(32,32,buffr).eq.0.and.lib$extzv(64,32,buffr) 1 .eq.0.and.lib$extzv(96,32,buffr).eq.0) then write(6,'(a)') ' Error receiving idle cycle number' goto 3 end if comand = ' ' do ii=1,4 i = lib$extzv((ii-1)*32,32,buffr) if (i.gt.0) then j = int(log10(float(i))) else j = 0 end if write(comand((ii-1)*5+1:(ii-1)*5+j+1),'(i)') i end do write(6,'(a)') ' Idle cycle number is: '//comand(1:len1( 1 comand(1:5)))//' (min='//comand(6:5+len1(comand(6:10)))// 2 ', max='//comand(11:10+len1(comand(11:15)))//', cycle '// 3 'time='//comand(16:15+len1(comand(16:20)))//')' end if if (comnum.eq.24) then code=sys$qiow(,%val(term_chan),%val('31'x),,,,buffr, 1 %val(28),,,,) if (code.ne.ss$_normal.or.version(1:1).ne.'V') then write(6,'(a)') ' Error receiving version number' goto 3 end if write(6,'(a)') ' Nanny '//version(:len1(version))// 1 ' (c) Zar Ltd.' end if 5 code=sys$qiow(,%val(term_chan),%val('31'x),,,,buff,%val(1),,,,) if (code.eq.ss$_normal) then if (buff.eq.1) write(6,'(a)') ' Function granted by your '// 1 'Nanny' if (buff.eq.nan$_nopriv) write(6,'(a)') ' Function denied' if (buff.eq.nan$_nonsys) write(6,'(a)') ' Function denied:'// 1 ' non-system user' if (buff.eq.nan$_comdis) write(6,'(a)') ' Function disabled' if (buff.eq.nan$_invcom) write(6,'(a)') ' Function incor'// 1 'rectly sent' if (buff.eq.nan$_noslot) write(6,'(a)') ' Function denied:'// 1 ' no slot available in queue' if (buff.eq.nan$_retwarn) write(6,'(a)') ' Function issued'// 1 ': error return status from manager received' else write(6,'(a)') ' Error sending request' end if goto 3 100 format(' Comands:',t11,'ADDACC mess',t40,'DIE',/,t11, 1 'ENTER pid',t40,'FORGET pid',/,t11,'FREE devnam',t40, 2 'GRAB devnam',/,t11,'HELP',t40,'IDLESET pid cycle',/,t11, 3 'IGNORE',t40,'ISHOW pid',/,t11,'KILL pid',t40,'LISTEN',/, 4 t11,'NEW',t40,'ODIS [tty]',/,t11,'OEN [tty]',t40, 5 'PAUSE queue',/,t11,'QSTART queue',t40,'QSTOP queue',/, 6 t11,'READ file [datim]',t40,'REQUEUE queue',/,t11, 7 'RESUME pid',t40,'STOP pid',/,t11,'SUSPEND pid',t40, 8 'VERSION',/,t11,'WDUMP file',/, 9 ' Control_Z or EXIT to exit') 999 end