subroutine mod_ann(sys_announce,sys_intl, 1 announce,loadave,wstotal,maxwstot) c c Change the text string for the logical name SYS$ANNOUNCE c parameter ss$_normal = 1 implicit integer*4 (a-z) include '($lnmdef)' include '($syidef)' character*(*) sys_announce,announce character*255 new_ann,tst_ann character*15 node_name character*8 vmsver integer*4 uptime(2),boottime(2),sys_intl integer*4 loadave(4),syilis(22),syi_lis(22) c c Get the optional string to append to the existing SYS$ANNOUNCE c (up to 80 characters) c new_l = 1 new_ann = sys_announce tst_l = 0 tst_ann = ' ' if (lench(announce).ne.0) then do while(announce(1:1).eq.' ') announce = announce(2:) end do c c Check for text in double quotes c if (announce(1:1).eq.'"') then announce = announce(2:) i = index(announce,'"') if (i.gt.1) then announce = announce(:i-1) tst_ann = announce tst_l = i - 1 end if c c Check for text in single quotes c else if (announce(1:1).eq.'''') then announce = announce(2:) i = index(announce,'''') if (i.gt.1) then announce = announce(:i-1) tst_ann = announce tst_l = i - 1 end if c c Try to translate the text as a logical name c else i = len1(announce) if (announce(i:i).eq.':'.and.index(announce(:i),' ') 1 .eq.0) then j = lnm$m_case_blind tst_ann = ' ' syi_lis(1) = lnm$_string * 2**16 + 256 syi_lis(2) = %loc(tst_ann) syi_lis(3) = 0 syi_lis(4) = 0 code = sys$trnlnm(j,%descr('LNM$SYSTEM_TABLE'), 1 %descr(announce(:i-1)),,syi_lis) if (code.eq.ss$_normal) then if (tst_ann(:i-1).ne.announce(:i-1).and.lench( 1 tst_ann(:78)).gt.0) tst_l = len1(tst_ann(:78)) end if c c Straight text c else tst_ann = announce tst_l = len1(announce) end if end if end if end if if (tst_l.gt.0) sys_intl = 0 if (sys_intl.eq.0) then c c Get lots of neat information about this computer c syi_lis(1) = syi$_ijoblim * 2**16 + 4 syi_lis(2) = %loc(ijoblim) syi_lis(3) = 0 syi_lis(4) = syi$_version * 2**16 + 8 syi_lis(5) = %loc(vmsver) syi_lis(6) = 0 syi_lis(7) = syi$_nodename * 2**16 + 15 syi_lis(8) = %loc(node_name) syi_lis(9) = 0 syi_lis(10) = syi$_boottime * 2**16 + 8 syi_lis(11) = %loc(boottime) syi_lis(12) = 0 syi_lis(13) = syi$_node_area * 2**16 + 4 syi_lis(14) = %loc(node_area) syi_lis(15) = 0 syi_lis(16) = syi$_node_number * 2**16 + 4 syi_lis(17) = %loc(node_number) syi_lis(18) = 0 syi_lis(19) = syi$_cpu * 2**16 + 4 syi_lis(20) = %loc(cpu_type) syi_lis(21) = 0 syi_lis(22) = 0 code = sys$getsyiw(,,,syi_lis,,,) if (bug(code,'GETSYI').ne.ss$_normal) return c c If the node name wasn't defined by SYSGEN, translate the logical c name SYS$NODE c if (lench(node_name).eq.0) then syi_lis(1) = lnm$_string * 2**16 + 15 syi_lis(2) = %loc(node_name) syi_lis(3) = 0 syi_lis(4) = 0 code = sys$trnlnm(,%descr('LNM$SYSTEM_TABLE'), 1 %descr('SYS$NODE'),,syi_lis) if (.not.code) node_name = ' ' end if do while(node_name(1:1).eq.'_') node_name = node_name(2:) end do i = index(node_name,':') if (i.gt.1) node_name = node_name(:i-1) if (lench(node_name).eq.0) node_name = ' ' c c Start to construct the system announce string with the c node name c i = lench(node_name) if (i.gt.0) then new_ann = node_name(:i)//' ' new_l = i + 2 c c Next add the node area and number (VAXCluster only) c if (node_area.gt.0.and.node_number.gt.0) then new_ann(new_l:new_l) = '(' j = int(log10(float(node_area))) write(new_ann(new_l+1:new_l+j+1),'(i)') 1 node_area new_l = new_l + j + 3 new_ann(new_l-1:new_l-1) = '.' j = int(log10(float(node_number))) write(new_ann(new_l:new_l+j),'(i)') 1 node_number new_l = new_l + j + 3 new_ann(new_l-2:new_l-1) = ') ' end if end if c c What version of VMS are we using c i = lench(vmsver) if (i.gt.0) then new_ann(new_l:new_l+i+7) = 'VAX/VMS '//vmsver new_l = new_l + i + 8 end if new_ann(new_l:new_l+1) = char(13)//char(10) new_l = new_l + 2 c c When did we boot c if (tst_l.eq.0) then if (boottime(1).ne.0.or.boottime(2).ne.0) then new_ann(new_l:) = 'Booted: ' new_l = new_l + 8 code = sys$asctim(,new_ann(new_l:new_l+22), 1 boottime,) if (.not.code) then new_l = new_l - 8 else new_ann = new_ann(:new_l-1)// 1 new_ann(new_l+3:new_l+3)//char(ichar( 2 new_ann(new_l+4:new_l+4))+32)//char( 3 ichar(new_ann(new_l+5:new_l+5))+32)// 4 new_ann(new_l-1:new_l+1)//new_ann( 5 new_l+11:new_l+16) new_l = new_l + 12 if (new_ann(new_l-8:new_l-8).eq.' ') then new_ann = new_ann(:new_l-9)// 1 new_ann(new_l-7:) new_l = new_l - 1 end if end if end if c c What is the interactive login limit c new_ann(new_l:) = ', Login Limit: ' sys_intl = new_l + 15 !Remember where to insert end if else new_ann(sys_intl:) = ' ' syi_lis(1) = syi$_ijoblim * 2**16 + 4 syi_lis(2) = %loc(ijoblim) syi_lis(3) = 0 syi_lis(4) = 0 code = sys$getsyiw(,,,syi_lis,,,) if (bug(code,'GETSYI').ne.ss$_normal) return end if if (tst_l.eq.0) then if (ijoblim.gt.0) then i = int(log10(float(ijoblim))) else i = 0 end if write(new_ann(sys_intl:sys_intl+i),'(i)') 1 ijoblim new_l = sys_intl + i + 3 new_ann(new_l-2:new_l-1) = char(13)//char(10) c c Insert current system load on next line c if (ijoblim.gt.0.and.loadave(1)+loadave(2)+loadave(3)+ 1 loadave(4).gt.0) then new_ann(new_l:) = ' ' new_ann(new_l:new_l+38) = 'Load: i/ s/'// 1 ' b/ o' write(new_ann(new_l+6:new_l+9),'(i4)',err=10) 1 loadave(1) write(new_ann(new_l+12:new_l+15),'(i4)',err=10) 1 loadave(2) write(new_ann(new_l+18:new_l+21),'(i4)',err=10) 1 loadave(3) write(new_ann(new_l+24:new_l+27),'(i4)',err=10) 1 loadave(4) i = 0 do while(new_ann(new_l+24:new_l+24).eq.' ') new_ann = new_ann(:new_l+23)// 1 new_ann(new_l+25:) i = i - 1 end do do while(new_ann(new_l+18:new_l+18).eq.' ') new_ann = new_ann(:new_l+17)// 1 new_ann(new_l+19:) i = i - 1 end do do while(new_ann(new_l+12:new_l+12).eq.' ') new_ann = new_ann(:new_l+11)// 1 new_ann(new_l+13:) i = i - 1 end do do while(new_ann(new_l+6:new_l+6).eq.' ') new_ann = new_ann(:new_l+5)// 1 new_ann(new_l+7:) i = i - 1 end do new_l = new_l + 29 + i c c Display memory usage statistics c if (wstotal.gt.0.and.maxwstot.gt.0) then new_ann(new_l:) = ', Mem Use: / ' write(new_ann(new_l+11:new_l+16),'(i6)',err=10) 1 wstotal write(new_ann(new_l+18:new_l+23),'(i6)',err=10) 1 maxwstot i = 0 do while(new_ann(new_l+18:new_l+18).eq.' ') new_ann = new_ann(:new_l+17)// 1 new_ann(new_l+19:) i = i - 1 end do do while(new_ann(new_l+11:new_l+11).eq.' ') new_ann = new_ann(:new_l+10)// 1 new_ann(new_l+12:) i = i - 1 end do new_l = new_l + 23 + i end if else new_l = new_l - 3 end if c c Add in optional text to SYS$ANNOUNCE now c else i = index(new_ann,char(13)) + 2 if (i.gt.2) then new_ann(i:) = tst_ann(:tst_l) new_l = i + tst_l - 1 end if end if c c Supercede the existing SYS$ANNOUNCE logical name in the c system table in executive mode (requires SYSNAM priv) c 10 if (new_l.gt.0) then if (new_l.gt.128) then !SYS$ANNOUNCE bug in VMS new_ann(128:128) = '>' new_l = 128 end if imode = 1 !Indicates EXEC mode syi_lis(1) = lnm$_string * 2**16 + new_l syi_lis(2) = %loc(new_ann) syi_lis(3) = 0 syi_lis(4) = 0 code = sys$crelnm(,%descr('LNM$SYSTEM_TABLE'), 1 %descr('SYS$ANNOUNCE'),imode,syi_lis) if (bug(code,'CRELNM').eq.ss$_normal) 1 sys_announce = new_ann(:new_l) end if return end c subroutine wait_rel c c (c) Zar Ltd. 1985 c parameter ss$_abort = '2c'x parameter ss$_normal = '01'x implicit integer*4 (a-z) code = sys$wake(,) if (bug(code,'WAKE').ne.ss$_normal) then call output(2,'Forced exit: Waking error') call sys$exit(%val(ss$_abort)) end if return end c subroutine account(inline,dumy) C C Insert a message into the VMS accounting log file with the C service $SNDACC. p1 of INLINE is the requesting PID and p2 C is the message to insert. c c (c) Zar Ltd. 1985 c parameter min = '0 0:0:3.0' implicit integer*4 (a-z) include 'nanny.inc' include '($jpidef)' include '($sjcdef)' include '($ssdef)' character*(*) inline character*115 message character*12 username integer*4 getlis(4),jbclis(4),qmin(2) logical*1 dumy c c Initialize c dumy = nan$_invcom getlis(1) = jpi$_username * 2**16 + 12 getlis(2) = %loc(username) getlis(3) = 0 getlis(4) = 0 code = sys$bintim(min,qmin) if (bug(code,'BINTIM').ne.ss$_normal) goto 999 c c Get rid of the command string c if (inline(1:7).ne.'ADDACC ') return inline = inline(8:) if (lench(inline).eq.0) goto 999 do while(inline(1:1).eq.' ') inline = inline(2:) end do C C Get the requestor's Process ID C pidc = loop_iosb(2) C C Get the requesters username C code = sys$setimr(%val(5),qmin,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 code = sys$getjpi(%val(6),pidc,,getlis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 999 code = sys$wflor(%val(5),%val(2**5.or.2**6)) call bug(code,'WFLOR') C C Construct the accounting message and send it C message = username(:len1(username))//':'//inline i = len1(message) jbclis(1) = sjc$_accounting_message * 2**16 + i jbclis(2) = %loc(message) jbclis(3) = 0 jbclis(4) = 0 code = sys$setimr(%val(5),qmin,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 jbcstat = sys$sndjbc(%val(6),%val(sjc$_write_accounting), 1 ,jbclis,,,) if (bug(code,'SNDJBC').ne.ss$_normal) goto 888 code = sys$wflor(%val(5),%val(2**5.or.2**6)) call bug(code,'WFLOR') C C Get the status returned from job_control C if (bug(jbcstat,'SNDACC').ne.ss$_normal) goto 888 C C Stamp the log file with completion C call output(2,'Accounting record sent by '// 1 username(:len1(username))//' was successful') dumy = 1 return C C Error C 888 call output(1,'Accounting record sent by '// 1 username(:len1(username))//' was aborted on error') dumy = nan$_retwarn return 999 call output(1,'Unable to send accounting record '// 1 'for '//username(:len1(username))) return end c c Modifies the argument to remove all tabs and returns c LEN1(argument) in R0. c c (c) Zar Ltd. 1985 c integer*4 function detab(str) character*(*) str i = index(str,char(9)) do while(i.ne.0) str(i:i) = char(32) i = index(str,char(9)) end do detab = len1(str) return end c c (c) Zar Ltd. 1985 c integer*4 function len1(str) character*(*) str i = lench(str) if (i.eq.0) i = 1 len1 = i return end c c Function Lench c c This function takes a character string and finds out how long the c "actual" string is (i.e. not including padded blanks on the right). c c (c) Zar Ltd. 1985 c integer*4 function lench(string) character*(*) string character*255 dumy c do while(index(string,char(0)).ne.0) i = index(string,char(0)) string(i:i) = ' ' end do call str$trim(dumy,string,line_l) lench = line_l return end c subroutine alloc(inline,dumy) c c Routine to allocate or deallocate devices to keep users c from accessing them. c c (c) Zar Ltd. 1985 c parameter nan$_invcom = '1d'x parameter nan$_nopriv = '20'x parameter nan$_retwarn = '1c'x implicit integer*4 (a-z) include '($ssdef)' character*(*) inline character*20 devnam,phydevnam character*4 funct logical*1 dumy c c Get the command c dumy = nan$_invcom if (lench(inline).eq.0) goto 999 do while(inline(1:1).eq.' ') inline=inline(2:) end do i=index(inline,' ')-1 if (i.lt.1) goto 999 funct=inline(:i) call str$upcase(funct,funct) c c Get the device to allocate or deallocate c inline=inline(i+2:) if (lench(inline).eq.0) goto 999 do while(inline(1:1).eq.' ') inline=inline(2:) end do i=index(inline,' ')-1 if (i.lt.1.or.i.gt.20) goto 999 devnam=inline(:i) if (lench(devnam).eq.0) goto 999 c c Do the dirty deed c if (funct.eq.'GRAB') then code = sys$alloc(devnam(:len1(devnam)),dev_l,phydevnam,,) else if (funct.eq.'FREE') then code = sys$dalloc(devnam(:len1(devnam)),) else goto 999 end if if (bug(code,'ALLOC').ne.ss$_normal) goto 999 c c Write out an appropriate message c if (funct.eq.'GRAB') then call output(2,phydevnam(:dev_l)//' has been allocated and '// 1 'is no longer available') else call output(2,phydevnam(:dev_l)//' has been deallocated and'// 1 ' is available for use') end if dumy = 1 return c c An error occurred c 999 call output(1,'Unable to '//funct//' device '//devnam(:len1( 1 devnam))) return end c subroutine boost c c Return all processes to what we think their authorized c priority is. c c (c) Zar Ltd. 1985 c implicit integer*4 (a-z) include 'nanny.inc' include '($ssdef)' include '($syidef)' integer*4 syilis(4) c c Get the system's DEFPRI c syilis(1) = syi$_defpri * 2**16 + 4 syilis(2) = %loc(defpri) syilis(3) = 0 syilis(4) = 0 code = sys$getsyiw(,,,syilis,,,) if (bug(code,'GETSYI').eq.ss$_normal) then c c Loop for processes c do i=1,crush_p if (crush(i).ne.0) then pt = ipid(i) if (system(pt).ne.nan$v_inter.and.system(pt).ne. 1 nan$v_subproc.and.crpri(i).le.defpri) then code = sys$setpri(crush(i),,%val(crpri(i)),) if (code.ne.ss$_nonexpr.and.code.ne.ss$_normal) then call bug(code,'SETPRI') call output(1,'Unable to reset a specific priority') else prib(pt) = crpri(i) end if end if crush(i) = 0 crpri(i) = 0 end if end do crush_p = 0 end if return end c integer*4 function bug(code,routine) c c Error handler for the Nanny c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) character*(*) routine character*132 message c c If the code is not equal to a normal status, get the error c message c bug = -1 if (code.ne.ss$_normal) then i = sys$getmsg(%val(code),message_l,message,%val(15),) c c Couldn't get the error message c if (i.ne.ss$_normal) then write(message,'(a,z8)',err=999) 'Unable to receive '// 1 'message for error number ',code call output(1,'Message from routine '//routine(:len1( 1 routine))//char(13)//char(10)//' '//message(:51)) c c Write out only Errors, Fatals, Warnings, and Unknowns c else i = index(message,'-') + 1 if (message(i:i).ne.'S'.and.message(i:i).ne.'I'.and. 1 message(i+2:i+7).ne.'NORMAL') then call output(1,'Message from routine '//routine(:len1( 1 routine))//char(13)//char(10)//' '// 2 message(:message_l)) else bug = ss$_normal end if end if c c No error c else bug = ss$_normal end if 999 return end c subroutine nan$die c c Routine to stop the Nanny cleanly. This subroutine won't c be rudely interrupted by an AST because this is called c by an AST routine to read messages from NANNYS$BOX. c c (c) Zar Ltd. 1985 c implicit integer*4 (a-z) include 'nanny.inc' include '($ssdef)' c c Set users priorities back to normal c call output(2,'Request to exit approved') call boost c c Resume any jobs we suspended c do i=1,suspids if (susp_ipid(i).ne.0) then code = sys$resume(pid(susp_ipid(i)),) if (code.ne.ss$_nonexpr) call bug(code,'RESUME') end if end do c c Flag the exit and return to operation c die = 1 call wait_rel return end c subroutine dskchk(inp_disks,start_flg) c c Routine to check disks for low space. If low, a message is c sent to the operator console. c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' include '($dvidef)' character*(*) inp_disks integer*4 dvi_lis(7) logical*1 start_flg c c New list of disk names are coming so delete the existing c disk names c if (inp_disks(:6).eq.'') then do cnt=1,maxdisks disks(cnt) = ' ' lasterr(cnt) = 0 end do return else c c The input disk string is empty c if (lench(inp_disks).eq.0) then return else c c Trim off comment and leading spaces from disk name c i = 1 do while(inp_disks(1:1).eq.' ') i = i + 1 end do j = index(inp_disks,'!') - 1 if (j.eq.-1) j = lench(inp_disks) k = index(inp_disks(:j),' ') - 1 if (k.eq.-1) k = lench(inp_disks(:j)) c c If there is a disk specified, find an empty location c in our disk array c if (k-i.ge.0) then j = 1 do while(lench(disks(j)).gt.0.and.j.le.maxdisks) j = j + 1 end do c c If we don't exceed the maxdisks value, get the REAL device c name of the input string c if (j.le.maxdisks) then dvi_lis(1) = dvi$_maxblock * 2**16 + 4 dvi_lis(2) = %loc(l) dvi_lis(3) = 0 dvi_lis(4) = dvi$_devnam * 2**16 + 64 dvi_lis(5) = %loc(disks(j)) dvi_lis(6) = 0 dvi_lis(7) = 0 code = sys$getdviw(,,inp_disks(i:k),dvi_lis, 1 ,,,) c c If we got the name ok and there are disk blocks, then c notify someone of our success c if (bug(code,'GETDVI').eq.ss$_normal.and. 1 l.gt.0) then if (debugging.eq.2) call output(1,'Disk '// 1 'watch requested for '//disks(j)(:len1( 2 disks(j)))) else disks(j) = ' ' return end if else return end if else return end if end if end if c c Start the disk checking mechanism c if (start_flg) call dsk_loop('0 0:0:13.0') return end c subroutine dsk_loop(cycle) c c Routine to setup AST for disk checker c c (c) Zar Ltd. 1985 c parameter cycle_tim = '0 0:15:0.0' parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' character*(*) cycle integer*4 qwait(2) external dskmon c c Setup timer c if (lench(cycle).eq.0) then code = sys$bintim(cycle_tim,qwait) else code = sys$bintim(cycle(:len1(cycle)),qwait) end if if (bug(code,'BINTIM').ne.ss$_normal) goto 1 call sys$cantim(%val(4),) code = sys$setimr(,qwait,dskmon,%val(4)) if (bug(code,'SETIMR').ne.ss$_normal) goto 1 return c c An error occurred c 1 call output(1,'Disk monitor crash') return end c subroutine dskmon c c Subroutine to check disk space on flagged disks to check if c low on space. c c (c) Zar Ltd. 1985 c parameter maxerr = 10 parameter wait_time = '0 0:0:3.0' implicit integer*4 (a-z) include 'nanny.inc' include '($dvidef)' include '($ssdef)' integer*4 dvilis(10),qwait(2) logical*1 errflg c c Loop for each disk c if (lench(disks(1)).le.0) return errflg = .false. dvilis(1) = dvi$_errcnt * 2**16 + 4 dvilis(2) = %loc(errcnt) dvilis(3) = 0 dvilis(4) = dvi$_freeblocks * 2**16 + 4 dvilis(5) = %loc(freeblks) dvilis(6) = 0 dvilis(7) = dvi$_maxblock * 2**16 + 4 dvilis(8) = %loc(maxblock) dvilis(9) = 0 dvilis(10) = 0 code = sys$bintim(wait_time,qwait) if (code.ne.ss$_normal) goto 1 do icnt=1,maxdisks c c Get the device information c if (lench(disks(icnt)).gt.0) then code = sys$setimr(%val(3),qwait,,) if (code.eq.ss$_normal) then dvicode = sys$getdvi(%val(4),,disks(icnt)(:len1(disks( 1 icnt))),dvilis,,,,) if (dvicode.eq.ss$_normal.or.dvicode.eq.ss$_concealed) 1 code = sys$wflor(%val(3),%val(2**3.or.2**4)) if (dvicode.eq.ss$_normal.or.dvicode.eq.ss$_concealed) then c c Check the space left c blks = maxblock / lowdivd if (blks.gt.freeblks) call output(2,'Device '// 1 disks(icnt)(:len1(disks(icnt)))//' is low on '// 2 'disk space') c c Check for large increases in error count c if (errcnt-lasterr(icnt).ge.maxerr) call output(2, 1 'Device '//disks(icnt)(:len1(disks(icnt)))// 2 ' is receiving excessive errors') if (errcnt-lasterr(icnt).ge.maxerr) errflg = .true. lasterr(icnt) = errcnt end if end if end if end do c c Reset the timer to AST this routine c 1 if (errflg) then call dsk_loop('0 0:2:0.0') else call dsk_loop(' ') end if return end c subroutine forget(inline,dumy) C C Remove/Enter a process from/into the Nanny's watch. c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 parameter wait_time = '0 0:0:3.0' implicit integer*4 (a-z) include 'nanny.inc' include '($jpidef)' character*(*) inline character*80 message character*12 userc,usert character*6 funct integer*4 getlis(4),qwait(2) logical*1 dumy C C Get the target process id C dumy = nan$_invcom i=index(inline,' ')-1 funct=inline(1:i) inline=inline(i+2:) if (lench(inline).eq.0) goto 999 do while(lench(inline(1:1)).eq.0) inline=inline(2:) end do i=index(inline,' ')-1 read(inline(1:i),'(z)',err=999) pidt inline=inline(i+2:) C C Are we watching the target process? C point=0 do i=1,maxuser if (pid(i).eq.pidt) point=i end do if (point.eq.0) goto 999 C C Get his username C getlis(1) = jpi$_username * 2**16 + 12 getlis(2) = %loc(usert) getlis(3) = 0 getlis(4) = 0 code = sys$bintim(wait_time,qwait) if (bug(code,'BINTIM').ne.ss$_normal) goto 999 code = sys$setimr(%val(8),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 code = sys$getjpi(%val(7),pidt,,getlis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 999 code = sys$wflor(%val(7),%val(2**7.or.2**8)) call bug(code,'WFLOR') C C Decode the requesting process ID C pidc = loop_iosb(2) C C Get the requestor's username C getlis(1) = jpi$_username * 2**16 + 12 getlis(2) = %loc(userc) getlis(3) = 0 getlis(4) = 0 code = sys$setimr(%val(8),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 code = sys$getjpi(%val(7),pidc,,getlis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 999 code = sys$wflor(%val(7),%val(2**7.or.2**8)) call bug(code,'WFLOR') C C Remove the process and write a message. C if (funct.eq.'FORGET') system(point) =nan$v_unknown if (funct(:5).eq.'ENTER') system(point)=nan$v_inter+nan$_system message = funct(:lench(funct))//' '//usert(:len1(usert))// 1 ' by '//userc(:len1(userc))//'''s command.' call output(2,message(:len1(message))) dumy=1 return 999 message = 'Unable to '//funct(:lench(funct))//' '// 1 usert(:len1(usert)) call output(1,message(:len1(message))) return end c subroutine gotmess C C Routine to communicate with outside world C Message format is: C command return_mbx src_pid args ascii_space C c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 parameter wait_time = '0 0:0:3.0' implicit integer*4 (a-z) include 'nanny.inc' include '($dvidef)' include '($iodef)' include '($jpidef)' character*128 inline character*12 retmbxnam character*9 dat character*8 tst_pid,ret_pid integer*4 dvilis(4) integer*4 qwait(2) integer*2 retmbx,uict(2),uicd(2) logical*1 dumy equivalence (inbuff,inline) external loop C dumy = nan$_nopriv call detab(inline) if (lench(inline).eq.0) goto 999 !There was no message do while(lench(inline(1:1)).eq.0) inline=inline(2:) end do i = index(inline,' ') call str$upcase(inline(:i),inline(:i)) funct_l = i-1 if (startup_flg) then uict(2)=0 uict(1)=0 goto 5 end if C C Get the return mailbox name C j = i+1 if (lench(inline(j:)).eq.0) goto 2 do while(inline(j:j).eq.' ') inline=inline(1:j-1)//inline(j+1:) end do k = index(inline(j:),' ')+j-2 if (k.lt.j) goto 2 retmbxnam = inline(j:k) inline = inline(1:i)//inline(k+2:) C C Get the return process I.D. C j = i+1 if (lench(inline(j:)).eq.0) goto 2 do while(inline(j:j).eq.' ') inline=inline(1:j-1)//inline(j+1:) end do k = index(inline(j:),' ')+j-2 if (k.lt.j) goto 2 do while(j.lt.k.and.inline(j:j).eq.'0') j = j + 1 !Strip leading 0s end do ret_pid = inline(j:k) inline = inline(1:i)//inline(k+2:) C C Is the PID of the return mailbox the same as the PID C sending a message to NANNYS$BOX (security) C write(tst_pid,'(z8)',err=2) loop_iosb(2) if (lench(tst_pid).eq.0) goto 2 do while(tst_pid(1:1).eq.' ') tst_pid = tst_pid(2:) end do if (ret_pid(:len1(ret_pid)).ne.tst_pid(:len1(tst_pid))) 1 goto 6 C C Get the UIC of the requestor from the requestor's PID C dvilis(1) = jpi$_uic * 2**16 + 4 dvilis(2) = %loc(uicd) dvilis(3) = 0 dvilis(4) = 0 code = sys$getjpiw(%val(10),loop_iosb(2),,dvilis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 6 C C Get the UIC of the owner of this mailbox C dvilis(1) = dvi$_ownuic * 2**16 + 4 dvilis(2) = %loc(uict) dvilis(3) = 0 dvilis(4) = 0 code = sys$bintim(wait_time,qwait) if (bug(code,'BINTIM').ne.ss$_normal) goto 2 code = sys$setimr(%val(9),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 2 code = sys$getdvi(%val(10),,retmbxnam,dvilis,,,,) if (bug(code,'GETDVI').ne.ss$_normal) goto 2 code = sys$wflor(%val(9),%val(2**9.or.2**10)) call bug(code,'WFLOR') c c If the UIC of the process sending the request doesn't c match the UIC of the owner of the return mailbox, you've c got a BIG problem c if (uict(1).ne.uicd(1).or.uict(2).ne.uicd(2)) goto 6 C C Assign a channel to the mailbox C code = sys$assign(retmbxnam,retmbx,,) if (bug(code,'ASSIGN').ne.ss$_normal) goto 2 C C Current commands(32 max): C ADDACC - Insert an accounting record into acc file C DIE - Request the Nanny to exit C ENTER - Request the Nanny to enter a process into C her tables C FORGET - Request to consider a process system owned C FREE - Deallocate a device for system use C GRAB - Allocate a device and make it unavailable C IDLESET - Reserved for future development C IGNORE - Stop sending messages to NANNY$PEEK C ISHOW - Request the current idle cycle setting for C a user C KILL - Request to delete a process C LISTEN - Start sending messages to NANNY$PEEK C NEW - Reread parameter file and reopen log file C ODIS - Disable a terminal for operator messages C OEN - Enable a terminal for operator messages C PAUSE - Stop a batch/device queue and pause current C job (if any) C QSTART - Start a batch/device queue C QSTOP - Stop a batch/device queue C READ - Ask that a new parameter file be read now or C at an optional date/time in the future C REQUEUE - Stop a device queue and requeue current job C RESUME - Request to resume a process C STOP - Request to force exit a process C SUSPEND - Request to suspend a process C VERSION - Request the current version number of Nanny C WAKE - Request a wakeup call C WCLR - Request to clear a wake-up call C WDUMP - Save wake-up calls to a file C WSHOW - Request to return queue information on all C wake-up calls C 5 if (inline(:7).eq.all_commands(nan$c_addacc)(:7)) then i=lib$extzv(nan$c_addacc-1,1,disable) if (i.ne.1) call account(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:4).eq.all_commands(nan$c_die)(:4)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_die-1,1,disable) if (i.ne.1) call nan$die if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 dumy = nan$_normal else if (inline(:6).eq.all_commands(nan$c_enter)(:6)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_enter-1,1,disable) if (i.ne.1) call forget(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:7).eq.all_commands(nan$c_forget)(:7)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_forget-1,1,disable) if (i.ne.1) call forget(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:5).eq.all_commands(nan$c_free)(:5)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_free-1,1,disable) if (i.ne.1) call alloc(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:5).eq.all_commands(nan$c_grab)(:5)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_grab-1,1,disable) if (i.ne.1) call alloc(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:8).eq.all_commands(nan$c_idleset)(:8)) then i=lib$extzv(nan$c_idleset-1,1,disable) if (i.ne.1) call mod_idle(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:7).eq.all_commands(nan$c_ignore)(:7)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_ignore-1,1,disable) if (i.ne.1) call listener(0) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 dumy = nan$_normal else if (inline(:6).eq.all_commands(nan$c_ishow)(:6)) then i=lib$extzv(nan$c_ishow-1,1,disable) if (i.ne.1) call sho_idle(inline,retmbx,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:5).eq.all_commands(nan$c_kill)(:5)) then i=lib$extzv(nan$c_kill-1,1,disable) if (i.ne.1) call kill(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:7).eq.all_commands(nan$c_listen)(:7)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_listen-1,1,disable) if (i.ne.1) call listener(1) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 dumy = nan$_normal else if (inline(:4).eq.all_commands(nan$c_new)(:4)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_new-1,1,disable) if (i.ne.1) call new_log(dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:5).eq.all_commands(nan$c_odis)(:5)) then i=lib$extzv(nan$c_odis-1,1,disable) if (i.ne.1) call oprman(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:4).eq.all_commands(nan$c_oen)(:4)) then i=lib$extzv(nan$c_oen-1,1,disable) if (i.ne.1) call oprman(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:6).eq.all_commands(nan$c_pause)(:6)) then i=lib$extzv(nan$c_pause-1,1,disable) if (i.ne.1) call queman(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:7).eq.all_commands(nan$c_qstart)(:7)) then i=lib$extzv(nan$c_qstart-1,1,disable) if (i.ne.1) call queman(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:6).eq.all_commands(nan$c_qstop)(:6)) then i=lib$extzv(nan$c_qstop-1,1,disable) if (i.ne.1) call queman(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:5).eq.all_commands(nan$c_read)(:5)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_read-1,1,disable) if (i.ne.1) call new_read(inline(6:),dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:8).eq.all_commands(nan$c_requeue)(:8)) then i=lib$extzv(nan$c_requeue-1,1,disable) if (i.ne.1) call queman(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:7).eq.all_commands(nan$c_resume)(:7)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_resume-1,1,disable) if (i.ne.1) call kill(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:5).eq.all_commands(nan$c_stop)(:5)) then i=lib$extzv(nan$c_stop-1,1,disable) if (i.ne.1) call kill(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:8).eq.all_commands(nan$c_suspend)(:8)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_suspend-1,1,disable) if (i.ne.1) call kill(inline,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:8).eq.all_commands(nan$c_version)(:8)) then i=lib$extzv(nan$c_version-1,1,disable) if (i.ne.1) call sndver(retmbx,version) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 dumy = nan$_normal else if (inline(:5).eq.all_commands(nan$c_wake)(:5)) then i=lib$extzv(nan$c_wake-1,1,disable) if (i.ne.1) call waker(inline,1,uict,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:5).eq.all_commands(nan$c_wclr)(:5)) then i=lib$extzv(nan$c_wclr-1,1,disable) if (i.ne.1) call wakeclr(inline,uict,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:6).eq.all_commands(nan$c_wdump)(:6)) then if (uict(2).gt.sysgrp) goto 4 i=lib$extzv(nan$c_wdump-1,1,disable) if (i.ne.1) call wdump(inline(7:),0,dumy) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 else if (inline(:6).eq.all_commands(nan$c_wshow)(:6)) then i=lib$extzv(nan$c_wshow-1,1,disable) if (i.ne.1) call showake(retmbx) if (i.eq.1) dumy = nan$_comdis if (i.eq.1) goto 1 dumy = nan$_normal else call output(1,'Received unknown message: '// 1 inline(:len1(inline))) dumy = nan$_nosuchcom end if if (.not.startup_flg) goto 3 c c Clear the read buffer and return to what we were doing c 999 do i=1,128 inbuff(i)=0 end do c c Requeue next read of message in 3 seconds (avoid user abuse) c code=sys$setimr(,qwait,loop,) if (bug(code,'SETIMR').ne.ss$_normal) call output(2, 1 'Requeue of GETMESS read failed. Incoming commands '// 2 'will be ignored.') return c c Command disabled c 1 call output(1,inline(1:funct_l)//' command aborted. '// 1 'Function disabled.') c c All messages are returned to sender here c 3 code=sys$qio(,%val(retmbx),%val(io$_writevblk+io$m_now), 1 ,,,dumy,%val(1),,,,) call bug(code,'QIO') code=sys$dassgn(%val(retmbx)) call bug(code,'DASSGN') goto 999 c c No return mailbox was specified c 2 call output(1,inline(1:funct_l)//' command aborted. '// 1 'No return mailbox.') goto 999 c c Non system user tried to issue a system command c 4 call output(1,inline(1:funct_l)//' command aborted. Non-'// 1 'system user.') dumy = nan$_nonsys goto 3 c c Security problem c 6 call output(2,inline(:len1(inline))//' aborted. PID '// 1 'mismatch! PID='//tst_pid(:len1(tst_pid))) dumy = nan$_nopriv goto 3 end c integer*4 function nanjpi_ini() c c Do a random getjpi on system (needs WORLD privilege) c c (c) Zar Ltd. 1985 c parameter maxwait = '0 0:0:2.0' implicit integer*4 (a-z) include 'nanny.inc' include '($dvidef)' include '($jpidef)' include '($ssdef)' integer*4 dvilist(4),jpilist(40),qwait(2) c c Initialize c c_account = ' ' c_authpriv(1) = 0 c_authpriv(2) = 0 c_bufio = 0 c_cpulim = 0 c_cputim = 0 c_dirio = 0 c_owner = 0 c_pageflts = 0 c_phy_term = ' ' c_pid = 0 c_prccnt = 0 c_prib = 0 c_ipid = 0 c_state = 0 c_sts = 0 c_terminal = ' ' c_uic(1) = 0 c_uic(2) = 0 c_username = ' ' c_wssize = 0 jpilist(1) = jpi$_account *2**16 + 8 jpilist(2) = %loc(c_account) jpilist(3) = 0 jpilist(4) = jpi$_authpriv *2**16 + 8 jpilist(5) = %loc(c_authpriv) jpilist(6) = 0 jpilist(7) = jpi$_cpulim *2**16 + 4 jpilist(8) = %loc(c_cpulim) jpilist(9) = 0 jpilist(10) = jpi$_owner *2**16 + 4 jpilist(11) = %loc(c_owner) jpilist(12) = 0 jpilist(13) = jpi$_pid *2**16 + 4 jpilist(14) = %loc(c_pid) jpilist(15) = 0 jpilist(16) = jpi$_prccnt *2**16 + 2 jpilist(17) = %loc(c_prccnt) jpilist(18) = 0 jpilist(19) = jpi$_prib *2**16 + 2 jpilist(20) = %loc(c_prib) jpilist(21) = 0 jpilist(22) = jpi$_proc_index *2**16 + 4 jpilist(23) = %loc(c_ipid) jpilist(24) = 0 jpilist(25) = jpi$_state *2**16 + 4 jpilist(26) = %loc(c_state) jpilist(27) = 0 jpilist(28) = jpi$_sts *2**16 + 4 jpilist(29) = %loc(c_sts) jpilist(30) = 0 jpilist(31) = jpi$_terminal *2**16 + 10 jpilist(32) = %loc(c_terminal) jpilist(33) = 0 jpilist(34) = jpi$_uic *2**16 + 4 jpilist(35) = %loc(c_uic) jpilist(36) = 0 jpilist(37) = jpi$_username *2**16 + 12 jpilist(38) = %loc(c_username) jpilist(39) = 0 jpilist(40) = 0 dvilist(1) = dvi$_tt_phydevnam *2**16 + 10 dvilist(2) = %loc(c_phy_term) dvilist(3) = 0 dvilist(4) = 0 nanjpi_ini = ss$_normal c c Convert MAXWAIT to system time c code = sys$bintim(maxwait,qwait) if (code.ne.ss$_normal) then nanjpi_ini = ss$_abort return end if c c Set a timer c code = sys$setimr(%val(1),qwait,,%val(3)) if (code.eq.ss$_normal) then c c Do the $GETJPI service c jpicode = sys$getjpi(%val(2),ranjpipid,,jpilist,,,) if (jpicode.eq.ss$_normal) code = sys$wflor(%val(1), 1 %val(2**1.or.2**2)) end if if (lench(c_terminal).gt.0.and.index(c_terminal,'VTA') 1 .ne.0) then if (index(c_terminal,':').eq.0) c_terminal = 1 c_terminal(:len1(c_terminal))//':' c c Get the physical terminal name if a terminal field exists c First cancel the previous timer if its still alive and set a c new timer c code = sys$cantim(%val(3),) code = sys$setimr(%val(1),qwait,,%val(3)) if (code.eq.ss$_normal) then c c Do the $GETDVI service c dvicode = sys$getdvi(%val(17),,c_terminal,dvilist,,,,) if (dvicode.eq.ss$_normal) code = sys$wflor(%val(1), 1 %val(2**1.or.2**17)) end if else c_phy_term = c_terminal end if c c Clear R0 and return c code = sys$cantim(%val(3),) nanjpi_ini = jpicode return end c integer*4 function nanjpi() c c Do a more info hungry getjpi on system (needs c WORLD privilege) c c (c) Zar Ltd. 1985 c parameter maxwait = '0 0:0:2.0' implicit integer*4 (a-z) include 'nanny.inc' include '($jpidef)' include '($ssdef)' integer*4 jpilist(19),qwait(2) integer*4 gpgcnt,ppgcnt c c Initialize c c_bufio = 0 c_cputim = 0 c_dirio = 0 gpgcnt = 0 c_pageflts = 0 ppgcnt = 0 c_wssize = 0 jpilist(1) = jpi$_bufio *2**16 + 4 jpilist(2) = %loc(c_bufio) jpilist(3) = 0 jpilist(4) = jpi$_cputim *2**16 + 4 jpilist(5) = %loc(c_cputim) jpilist(6) = 0 jpilist(7) = jpi$_dirio *2**16 + 4 jpilist(8) = %loc(c_dirio) jpilist(9) = 0 jpilist(10) = jpi$_gpgcnt *2**16 + 4 jpilist(11) = %loc(gpgcnt) jpilist(12) = 0 jpilist(13) = jpi$_pageflts *2**16 + 4 jpilist(14) = %loc(c_pageflts) jpilist(15) = 0 jpilist(16) = jpi$_ppgcnt *2**16 + 4 jpilist(17) = %loc(ppgcnt) jpilist(18) = 0 jpilist(19) = 0 nanjpi = ss$_normal c c Convert MAXWAIT to system time c code = sys$bintim(maxwait,qwait) if (code.ne.ss$_normal) then nanjpi = ss$_abort return end if c c Set a timer c code = sys$setimr(%val(1),qwait,,%val(3)) if (code.eq.ss$_normal) then c c Do the $GETJPI service c jpicode = sys$getjpi(%val(2),c_pid,,jpilist,,,) if (jpicode.eq.ss$_normal) code = sys$wflor(%val(1), 1 %val(2**1.or.2**2)) end if c_wssize = gpgcnt + ppgcnt c c Clear R0 and return c code = sys$cantim(%val(3),) nanjpi = jpicode return end c subroutine kill(inline,dumy) C C Routine to delete, force exit, suspend, or resume a process. C Both the calling process and the target process must have the C same UIC. c c (c) Zar Ltd. 1985 c parameter ss$_abort = '2c'x parameter ss$_normal = 1 parameter wait_time = '0 0:0:3.0' implicit integer*4 (a-z) include 'nanny.inc' include '($jpidef)' character*(*) inline character*80 message character*12 userc,usert character*8 fnction integer*4 getlis(7),qwait(2) integer*2 uict(2),uicc(2) logical*1 dumy C C Initialize and get command C dumy = nan$_invcom call str$upcase(inline,inline) if (inline(1:5).ne.'KILL '.and.inline(1:5).ne.'STOP '.and. 1 inline(1:8).ne.'SUSPEND '.and.inline(1:7).ne.'RESUME ') return i=index(inline,' ')-1 fnction=inline(1:i) C C Decode the target Process ID C inline=inline(i+2:) if (lench(inline).eq.0) goto 999 do while(inline(1:1).eq.' ') inline=inline(2:) end do j=index(inline,' ')-1 read(inline(:j),'(z)',err=999) pidt inline=inline(j+2:) C C Try to get the target UIC C getlis(1) = jpi$_uic * 2**16 + 4 getlis(2) = %loc(uict) getlis(3) = 0 getlis(4) = jpi$_username * 2**16 + 12 getlis(5) = %loc(usert) getlis(6) = 0 getlis(7) = 0 code = sys$bintim(wait_time,qwait) if (bug(code,'BINTIM').ne.ss$_normal) goto 999 code = sys$setimr(%val(11),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 code = sys$getjpi(%val(12),pidt,,getlis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 999 code = sys$wflor(%val(11),%val(2**11.or.2**12)) call bug(code,'WFLOR') C C Decode the requesting Process ID C pidc = loop_iosb(2) C C Try to get the requesting UIC C getlis(1) = jpi$_uic * 2**16 + 4 getlis(2) = %loc(uicc) getlis(3) = 0 getlis(4) = jpi$_username * 2**16 + 12 getlis(5) = %loc(userc) getlis(6) = 0 getlis(7) = 0 code = sys$setimr(%val(11),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 code = sys$getjpi(%val(12),pidc,,getlis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 999 code = sys$wflor(%val(11),%val(2**11.or.2**12)) call bug(code,'WFLOR') C C If the two UICs aren't the same, don't delete. C if (uicc(2).gt.sysgrp.and.(uicc(1).ne.uict(1).or.uicc(2).ne. 1 uict(2))) goto 888 if (uicc(2).gt.sysgrp.and.(usert.ne.userc.or.pidt.eq.0)) 1 goto 888 C C Delete the target process and raise its priority to make C sure it goes away. C if (fnction.eq.'KILL') then code = sys$forcex(pidt,,%val(ss$_abort)) call bug(code,'FORCEX') code = sys$delprc(pidt,) if (bug(code,'DELPRC').eq.ss$_normal) then code = sys$setpri(pidt,,%val(13),) call bug(code,'SETPRI') else goto 999 end if C C Force a process to stop execution of the image it's running. C else if (fnction.eq.'STOP') then code = sys$forcex(pidt,,%val(ss$_abort)) if (bug(code,'FORCEX').ne.ss$_normal) goto 999 C C Suspend a process C else if (fnction.eq.'SUSPEND') then code = sys$suspnd(pidt,) if (bug(code,'SUSPND').ne.ss$_normal) goto 999 C C Resume a process C else if (fnction.eq.'RESUME') then code = sys$resume(pidt,) if (bug(code,'RESUME').ne.ss$_normal) goto 999 end if C C Stamp SYS$OUTPUT with a completion message C message = 'Request to '//fnction(:len1(fnction))//' process '// 1 usert(:len1(usert))//' by '//userc(:len1(userc))//' approved' call output(2,message(:len1(message))) dumy=1 return 888 message = 'Request to '//fnction(:len1(fnction))//' process '// 1 usert(:len1(usert))//' by '//userc(:len1(userc))//' denied' call output(1,message(:len1(message))) dumy = nan$_retwarn return 999 message = 'Request to '//fnction(:len1(fnction))//' process '// 1 usert(:len1(usert))//' by '//userc(:len1(userc))//' aborted'// 2 ' on error' call output(1,message(:len1(message))) return end c subroutine loop c c Be recursive c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' include '($iodef)' external gotmess c code = sys$qio(,%val(mbxchan),%val(io$_readvblk),loop_iosb, 1 gotmess,,inbuff,%val(128),,,,) if (bug(code,'QIO').ne.ss$_normal) 1 call output(2,'Recursive I/O stopped. Input will be ignored') return end c subroutine read_loop c c Called by a timed READ request c logical*1 dumy call new_log(dumy) return end c subroutine new_read(inline,dumy) c c Change the logical name NANNY$START and setup a timer-queued c AST to read new parameter file at a future date/time c c (c) Zar Ltd. 1985 c implicit integer*4 (a-z) parameter ss$_normal = 1 include '($lnmdef)' character*(*) inline character*40 file character*16 delta integer*4 lnmlis(4),qwait(2),qtst(2) logical*1 dumy external read_loop c c Extract file name (must exist) c dumy = 32 if (lench(inline).eq.0) then call output(1,'READ: No alternate parameter file specified') return end if do while(inline(1:1).eq.' ') inline = inline(2:) end do i = index(inline,' ') - 1 if (i.le.0) goto 2 call str$upcase(inline(:i),inline(:i)) file = inline(:i) delta = ' ' c c Change the logical name NANNY$START now c acmode = 1 !1 indicates EXEC mode lnmlis(1) = lnm$_string * 2**16 + i lnmlis(2) = %loc(file) lnmlis(3) = 0 lnmlis(4) = 0 code = sys$crelnm(,%descr('LNM$SYSTEM_TABLE'), 1 %descr('NANNY$START'),acmode,lnmlis) if (bug(code,'CRELNM').ne.ss$_normal) goto 2 c c Check for an optional date/time in absolute or delta format c and extract c inline = inline(i+2:) if (lench(inline).eq.0) goto 1 do while(inline(1:1).eq.' ') inline = inline(2:) end do i = lench(inline) if (i.le.0) goto 1 c c Create a quadword system time for 5 minutes from now c call sys$bintim('-- ::.',qtst) call sys$bintim('0 0:5:0.0',qwait) call lib$subx(qtst,qwait,qtst) c c Try to convert the time to quadword format. If it converts, c queue the AST to call NEW_LOG c code = sys$bintim(inline(:i),qwait) if (bug(code,'BINTIM').ne.ss$_normal) goto 2 c c Before we queue the AST check that the requested time isn't c less than 5 minutes in the future c if (qwait(2).lt.0) then call sys$bintim('0 0:5:0.0',qtst) call lib$subx(qtst,qwait,qtst) else call lib$subx(qwait,qtst,qtst) end if if (qtst(2).lt.0.or.(qtst(1).eq.0.and.qtst(2).eq.0)) call 1 sys$bintim('0 0:5:0.0',qwait) code = sys$setimr(,qwait,read_loop,) if (bug(code,'SETIMR').ne.ss$_normal) goto 2 if (qwait(2).ge.0) then call sys$bintim('-- ::.',qtst) call lib$subx(qtst,qwait,qwait) end if code = sys$asctim(,delta,qwait,) call bug(code,'ASCTIM') if (code) then do while(delta(1:1).eq.' ') delta = delta(2:) end do end if c c Normal exit c 1 dumy = ss$_normal do while(index(file,']').ne.0) i = index(file,']') file = file(i+1:) end do call output(1,'READ command completed for file '// 1 file(:len1(file))//' in '//delta(:len1(delta))) return c c Error c 2 call output(1,'READ command failed') return end c subroutine new_log(dumy) c c Get parameters for this run from startup file. c c (c) Zar Ltd. 1985 c implicit integer*4 (a-z) include 'nanny.inc' character*80 disknams,oprttys,oannounce,com_file character*15 onan_prcnam character*9 dat character*8 osysaccnam integer*4 otruewait(2) logical*1 dumy,opurgews,opchk c c Reread the parameter file c progress = 0 opchk = .false. dumy = nan$_nopriv open(unit=1,name='NANNY$START:',readonly,shared,err=6, 1 carriagecontrol='list',status='old') goto 7 6 open(unit=1,name='SYS$INPUT:',readonly,shared,err=3, 1 carriagecontrol='list',status='old') c c Get the name of an alternate parameter file to read next c and when to read it c 7 if (lench(nan_prcnam).eq.0) opchk = .true. read(1,100,err=3,end=3) com_file call detab(com_file) i=index(com_file,'!')-1 if (i.gt.0) com_file=com_file(:i) if (lench(com_file).gt.0) call new_read(com_file,i) progress=progress+1 c c Get the name of a file containing Nanny commands to issue c when the current input parameter file is read c read(1,100,err=3,end=3) com_file call detab(com_file) i=index(com_file,'!')-1 if (i.gt.0) com_file=com_file(:i) if (lench(com_file).gt.0) call new_com(com_file) com_file = ' ' progress=progress+1 c c Get the process name c read(1,110,err=3,end=3) onan_prcnam call detab(onan_prcnam) if (nan_prcnam.ne.onan_prcnam) then code=sys$setprn(onan_prcnam) if (bug(code,'SETPRN').eq.ss$_normal) then call output(1,'New process name = '//onan_prcnam) nan_prcnam=onan_prcnam end if end if progress=progress+1 c c Get the system group UIC c read(1,120,err=3,end=3) osysgrp if (osysgrp.lt.1.or.osysgrp.gt.255) goto 3 if (osysgrp.ne.sysgrp) then write(com_file(1:6),120,err=3) osysgrp call output(1,'New system group UIC = ['//com_file(:6)// 1 ',*]') end if progress=progress+1 c c Get the system account name c read(1,100,err=3,end=3) osysaccnam call detab(osysaccnam) if (sysaccnam.ne.osysaccnam) then sysaccnam = osysaccnam call output(1,'New system account = '//osysaccnam) end if progress=progress+1 c c Get the cycle time c read(1,*,err=3,end=3) owaitim if (owaitim.lt.1000.or.owaitim.gt.30000) goto 3 c c Convert cycle time to system quadword format c k=owaitim i=float(k)/6000. k=k-i*6000 j=float(k)/100. k=k-j*100 dat='0 0:' l=5 m=0 if (i.gt.9) m=1 write(dat(l:l+m),'(i)',err=3) i l=l+m+2 dat(l-1:l-1)=':' m=0 if (j.gt.9) m=1 write(dat(l:l+m),'(i)',err=3) j l=l+m+2 dat(l-1:l-1)='.' m=0 if (k.gt.9) m=1 write(dat(l:l+m),'(i)',err=3) k l=l+m if (sys$bintim(dat(:l),otruewait).ne.1) goto 3 if (otruewait(1).ne.truewait(1).or.otruewait(2).ne. 1 truewait(2)) call output(1,'New cycle time = '//dat(:l)) progress=progress+1 c c Get the number of cycles to use for CPU use average c read(1,*,err=3,end=3) ocpu_average if (ocpu_average.lt.1.or.ocpu_average.gt.max_average) goto 3 if (ocpu_average.ne.cpu_average) then write(com_file(1:6),'(i6)',err=3) ocpu_average do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New CPU average count = '//com_file(:len1( 1 com_file))) end if progress=progress+1 c c Get the maximum idle time lower, default, and upper c bounds for a terminal and the maximum elapsed time c limit for interactive processes in "cycle" units c read(1,*,err=3,end=3) ominidle,odefidle,omaxidle,omaxelapsed if (ominidle.gt.8640.or.omaxidle.gt.8640.or.omaxelapsed 1 .gt.65535) goto 3 if ((ominidle.ne.0.and.ominidle.lt.3).or.(omaxidle.ne.0.and. 1 omaxidle.lt.3)) goto 3 if ((omaxidle.ne.0.and.omaxidle.lt.ominidle).or.(omaxelapsed 1 .ne.0.and.omaxelapsed.lt.omaxidle)) goto 3 if ((odefidle.lt.ominidle).or.(odefidle.gt.omaxidle)) goto 3 if (ominidle.ne.minidle) then write(com_file(1:6),'(i6)',err=3) ominidle do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New minimum idle cycles = '//com_file(: 1 len1(com_file))) end if if (odefidle.ne.defidle) then write(com_file(1:6),'(i6)',err=3) odefidle do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New default idle cycles = '//com_file(: 1 len1(com_file))) end if if (omaxidle.ne.maxidle) then write(com_file(1:6),'(i6)',err=3) omaxidle do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New maximum idle cycles = '//com_file(: 1 len1(com_file))) end if if (omaxelapsed.ne.maxelapsed) then write(com_file(1:6),'(i6)',err=3) omaxelapsed do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New maximum elapsed time cycles = '// 1 com_file(:len1(com_file))) end if progress=progress+1 c c Get the minimum time to be considered not idle c read(1,*,err=3,end=3) omintim,ominio if (omintim.lt.0.or.omintim.gt.299) goto 3 if (ominio.lt.0.or.ominio.gt.299) goto 3 if (omintim.ne.mintim) then write(com_file(1:6),'(i6)',err=3) omintim do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New non-idle CPU use requirement = '// 1 com_file(:len1(com_file))) end if if (ominio.ne.minio) then write(com_file(1:6),'(i6)',err=3) ominio do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New non-idle buffered+direct I/O '// 1 'requirement = '//com_file(:len1(com_file))) end if progress=progress+1 c c Get the maximum usable physical memory(guestimate) to c suspend jobs and define memory size to resume suspended jobs c read(1,*,err=3,end=3) omaxphymem,olowphymem if (omaxphymem.ne.0.and.(omaxphymem.lt.2048.or.omaxphymem 1 .gt.65536)) goto 3 !Between 1-32 Megabytes of memory if (omaxphymem.ne.maxphymem) then write(com_file(1:6),'(i6)',err=3) omaxphymem do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New maximum memory use for suspending '// 1 'jobs = '//com_file(:len1(com_file))) end if if (olowphymem.ne.0.and.(olowphymem.lt.128.or.olowphymem 1 .gt.65536)) goto 3 !Between 0-32 Meg of memory if (olowphymem.gt.omaxphymem) olowphymem = omaxphymem if (olowphymem.ne.lowphymem) then write(com_file(1:6),'(i6)',err=3) olowphymem do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New memory available level for '// 1 'suspending jobs = '//com_file(:len1(com_file))) end if progress=progress+1 c c Get the maximum suspend time for suspended jobs c read(1,*,err=3,end=3) omaxsuspend if (omaxsuspend.lt.0.or.omaxsuspend.gt.65000) goto 3 if (omaxsuspend.ne.maxsuspend) then write(com_file(1:6),'(i6)',err=3) omaxsuspend do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New maximum suspend cycles = '// 1 com_file(:len1(com_file))) end if progress=progress+1 c c Get the day of the year to advance and reverse time for c standard and daylight savings time c read(1,*,err=3,end=3) oadv_dstday,obck_dstday if (oadv_dstday.ne.0.and.(oadv_dstday.lt.1.or.oadv_dstday 1 .gt.366)) goto 3 if (oadv_dstday.ne.0.and.(oadv_dstday.eq.obck_dstday)) goto 3 if (oadv_dstday.ne.adv_dstday) then write(com_file(1:3),'(i3)',err=3) oadv_dstday do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New day-of-year to advance time = '// 1 com_file(:len1(com_file))) end if if (obck_dstday.ne.0.and.(obck_dstday.lt.1.or.obck_dstday 1 .gt.366)) goto 3 if (obck_dstday.ne.bck_dstday) then write(com_file(1:3),'(i3)',err=3) obck_dstday do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do call output(1,'New day-of-year to backup time = '// 1 com_file(:len1(com_file))) end if progress=progress+1 c c Should we purge the working set c read(1,140,err=3,end=3) dat call detab(dat) call str$upcase(dat,dat) opurgews = .false. if (dat(1:1).eq.'1'.or.dat(1:1).eq.'Y'.or.dat(1:1) 1 .eq.'T') opurgews = .true. if (opurgews.ne.purgews) then com_file = '.TRUE.' if (.not.opurgews) com_file = '.FALSE.' call output(1,'New setting for working set purge = '// 1 com_file(:len1(com_file))) end if progress=progress+1 c c Get the number of disks to watch c read(1,*,err=3,end=3) i if (i.lt.0.or.i.gt.maxdisks) goto 3 progress=progress+1 c c Get the denominator for determining critical disk space availability c if (i.gt.0) then read(1,*,err=3,end=3) olowdivd if (olowdivd.le.0.or.olowdivd.gt.200) goto 3 if (olowdivd.ne.lowdivd) then write(com_file(1:5),'(f5.3)',err=3) 1./float(olowdivd) call output(1,'New setting for low disk space = '// 1 com_file(3:4)//'.'//com_file(5:5)//'%') end if progress=progress+1 end if c c Get the disk names to watch c call dskchk('',opchk) do while(i.gt.0) read(1,100,err=3,end=3) disknams call detab(disknams) j=index(disknams,'!')-1 if (j.gt.0) disknams=disknams(:j) call dskchk(disknams,opchk) progress=progress+1 i=i-1 end do c c Get the number of operator terminals to send messages c to other than OPA0: c read(1,*,err=3,end=3) i if (i.lt.0.or.i.gt.8) goto 3 progress=progress+1 c c Get the names of the Nanny operator terminals c call opr_par('') do while(i.gt.0) read(1,100,err=3,end=3) oprttys call detab(oprttys) j=index(oprttys,'!')-1 if (j.gt.0) oprttys=oprttys(:j) call opr_par(oprttys) progress=progress+1 i=i-1 end do c c Get the disable bit mask c read(1,150,err=3,end=3) odisable if (odisable.ne.disable) then write(com_file(1:8),150,err=3) odisable call output(1,'New command disable bit mask = '// 1 com_file(:8)) com_file = ' Enabled:' do i=1,max_commands if (lib$extzv(i-1,1,odisable).eq.0) then j = lench(com_file) if (com_file(j:j).eq.':') then com_file(j+1:j+1) = ' ' else com_file(j+1:j+1) = ',' end if com_file(j+2:) = all_commands(i) if (lench(com_file).gt.48) then call output(1,com_file(:len1(com_file))) com_file = ' Enabled:' end if end if end do i = lench(com_file) if (com_file(i:i).ne.':') call output(1,com_file(: 1 len1(com_file))) end if progress=progress+1 c c Get the function enable bit mask c read(1,150,err=3,end=3) ofunctmsk if (ofunctmsk.ne.functmsk) then write(com_file(1:8),150,err=3) ofunctmsk call output(1,'New function enable bit mask = '// 1 com_file(:8)) com_file = ' Enabled:' do i=1,32 if (lib$extzv(i-1,1,ofunctmsk).eq.1) then j = lench(com_file) if (com_file(j:j).eq.':') then com_file(j+1:j+1) = ' ' else com_file(j+1:j+1) = ',' end if if (lench(all_functs(i)).gt.0) then com_file(j+2:) = all_functs(i) if (lench(com_file).gt.48) then call output(1,com_file(:len1(com_file))) com_file = ' Enabled:' end if end if end if end do i = lench(com_file) if (com_file(i:i).ne.':') call output(1,com_file(: 1 len1(com_file))) end if progress=progress+1 c c Get the number of users to ignore c read(1,*,err=3,end=3) i if (i.lt.0.or.i.gt.maxig_user) goto 3 progress=progress+1 c c Get the names of users to ignore c ig_p = 1 do while(i.gt.0) read(1,100,err=3,end=3) com_file call detab(com_file) j=index(com_file,'!')-1 if (j.gt.0) com_file=com_file(:j) if (lench(com_file).gt.0) then do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do j=index(com_file,' ') if (j.eq.0) j=lench(com_file)+1 ig_user(ig_p)=com_file(:j-1) if (debugging.eq.2) call output(1,'Ignoring user '// 1 com_file(:j-1)) ig_p=ig_p+1 end if progress=progress+1 i=i-1 end do do i=ig_p,maxig_user ig_user(i) = ' ' end do c c Get the number of terminals to ignore c read(1,*,err=3,end=3) i if (i.lt.0.or.i.gt.maxig_term) goto 3 progress=progress+1 c c Get the names of terminals to ignore c ig_p = 1 do while(i.gt.0) read(1,100,err=3,end=3) com_file call detab(com_file) j=index(com_file,'!')-1 if (j.gt.0) com_file=com_file(:j) if (lench(com_file).gt.0) then do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do j=index(com_file,' ') if (j.eq.0) j=lench(com_file)+1 ig_term(ig_p)=com_file(:j-1) if (debugging.eq.2) call output(1,'Ignoring terminal '// 1 com_file(:j-1)) ig_p=ig_p+1 end if progress=progress+1 i=i-1 end do do i=ig_p,maxig_term ig_term(i) = ' ' end do c c System annouce text -- possibly a logical name (optional) c read(1,100,end=4) com_file call detab(com_file) if (index(com_file,'!').gt.1) com_file = com_file(:index( 1 com_file,'!')-1) c c If nothing specified, use the existing announce text c if (lench(com_file).eq.0) then oannounce = announce else do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do oannounce = com_file end if progress = progress + 1 c c Group account preference values (optional) c i = 0 5 read(1,100,end=4) com_file call detab(com_file) if (index(com_file,'!').gt.1) com_file = com_file(:index( 1 com_file,'!')-1) if (lench(com_file).eq.0) goto 4 prefacc(i+1) = com_file(1:8) com_file = com_file(10:) if (lench(com_file).eq.0) goto 5 do while(com_file(1:1).eq.' ') com_file = com_file(2:) end do line_l = lench(com_file) per_loc = index(com_file,'.') if (per_loc.eq.0) goto 5 read(com_file,'(f.)',err=5) prefadd( 1 i+1) if (prefadd(i+1).eq.-1.1250) prefadd(i+1) = -1.126 i = i + 1 progress=progress+1 goto 5 4 prefadd(i+1) = 101.0 close(unit=1) c c Everything went ok. Check the idle_val settings to make them c conform with the new standards c if (ominidle.ne.minidle.or.omaxidle.ne.maxidle) then do i=1,maxuser if (pid(i).ne.0) then if (idle_val(i).lt.ominidle) idle_val(i) = ominidle if (idle_val(i).gt.omaxidle) idle_val(i) = omaxidle end if end do end if c c Set the common variables and return c sysgrp = osysgrp waitim = owaitim cpu_average = ocpu_average minidle = ominidle defidle = odefidle maxidle = omaxidle maxelapsed = omaxelapsed mintim = omintim minio = ominio truewait(1) = otruewait(1) truewait(2) = otruewait(2) purgews = opurgews maxphymem = omaxphymem lowphymem = olowphymem maxsuspend = omaxsuspend adv_dstday = oadv_dstday bck_dstday = obck_dstday lowdivd = olowdivd disable = odisable functmsk = ofunctmsk announce = oannounce dumy = nan$_normal call output(1,'Logfile initialized') return 3 write(dat,'(i3)',err=2) progress+1 call output(2,'Parameter file error on or before line'//dat) 2 return c c Formats c 100 format(a) 110 format(a15) 120 format(o6) 130 format(a8) 140 format(a1) 150 format(z8) end c subroutine new_com(file) c c This routine is called by NEW_LOG (reading the parameter c file) to issue some selected Nanny commands automatically c when the parameter file is reread. c parameter max_delay = '0 0:1:0.0' implicit integer*4 (a-z) include 'nanny.inc' character*(*) file character*80 inp_line character*8 inp_com integer*4 qtst1(2),qtst2(2),qtst3(2),day_ow integer*2 uict(2) logical*1 dumy c c Open the file c uict(2) = 0 uict(1) = 0 if (lench(file).eq.0) return c c Get the current date and time and determine what day of c the week it is today (Wed=0..Tues=6) c call sys$bintim('-- ::.',qtst1) call lib$day(day_ow) day_ow = mod(day_ow,7) c c Read an input line (skip comments) c open(unit=2,name=file(:len1(file)),carriagecontrol='list', 1 readonly,shared,err=99,status='old') 1 read(2,'(a)',end=3) inp_line call detab(inp_line) if (inp_line(1:1).eq.'!') goto 1 if (index(inp_line,'!').gt.1) inp_line = inp_line(:index( 1 inp_line,'!')-1) i = index(inp_line,char(9)) do while(i.ne.0) if (i.eq.1) then inp_line = inp_line(2:) else inp_line = inp_line(:i-1)//inp_line(i+1:) end if i = index(inp_line,char(9)) end do 2 if (lench(inp_line).eq.0) goto 1 do while(inp_line(1:1).eq.' ') inp_line = inp_line(2:) end do i = index(inp_line,' ') call str$upcase(inp_line(:i),inp_line(:i)) c c The following commands are allowed: c SPAWN (new) - Create a subprocess using the DCL c command tables to run a specified command procedure. c ADDACC, DIE, FREE, GRAB, IGNORE, LISTEN, ODIS, OEN, c PAUSE, QSTART, QSTOP, READ, REQUEUE, WAKE, WCLR, c and WDUMP are all supported. c This routine does NOT check if any of the above commands c are disabled in the Nanny command disable bit mask. c dumy = nan$_nopriv if (inp_line(:7).eq.all_commands(nan$c_addacc)(:7)) then call account(inp_line,dumy) inp_com = 'ADDACC' else if (inp_line(:4).eq.all_commands(nan$c_die)(:4)) then call nan$die inp_com = 'DIE' dumy = nan$_normal else if (inp_line(:5).eq.all_commands(nan$c_free)(:5)) then call alloc(inp_line,dumy) inp_com = 'FREE' else if (inp_line(:5).eq.all_commands(nan$c_grab)(:5)) then call alloc(inp_line,dumy) inp_com = 'GRAB' else if (inp_line(:7).eq.all_commands(nan$c_ignore)(:7)) then call listener(0) inp_com = 'IGNORE' dumy = nan$_normal else if (inp_line(:7).eq.all_commands(nan$c_listen)(:7)) then call listener(1) inp_com = 'LISTEN' dumy = nan$_normal else if (inp_line(:5).eq.all_commands(nan$c_odis)(:5)) then call oprman(inp_line,dumy) inp_com = 'ODIS' else if (inp_line(:4).eq.all_commands(nan$c_oen)(:4)) then call oprman(inp_line,dumy) inp_com = 'OEN' else if (inp_line(:6).eq.all_commands(nan$c_pause)(:6)) then call queman(inp_line,dumy) inp_com = 'PAUSE' else if (inp_line(:7).eq.all_commands(nan$c_qstart)(:7)) then call queman(inp_line,dumy) inp_com = 'QSTART' else if (inp_line(:6).eq.all_commands(nan$c_qstop)(:6)) then call queman(inp_line,dumy) inp_com = 'QSTOP' else if (inp_line(:5).eq.all_commands(nan$c_read)(:5)) then call new_read(inp_line(6:),dumy) inp_com = 'READ' else if (inp_line(:8).eq.all_commands(nan$c_requeue)(:8)) then call queman(inp_line,dumy) inp_com = 'REQUEUE' else if (inp_line(:6).eq.'SPAWN ') then call com_spawn(inp_line(7:),dumy) inp_com = 'SPAWN' else if (inp_line(:5).eq.all_commands(nan$c_wake)(:5)) then call waker(inp_line,1,uict,dumy) inp_com = 'WAKE' else if (inp_line(:5).eq.all_commands(nan$c_wclr)(:5)) then call wakeclr(inp_line,uict,dumy) inp_com = 'WCLR' else if (inp_line(:6).eq.all_commands(nan$c_wdump)(:6)) then call wdump(inp_line(7:),0,dumy) inp_com = 'WDUMP' c c Special days of the week c else if ((inp_line(:7).eq.'SUNDAY:'.and.day_ow.eq.4).or. 1 (inp_line(:7).eq.'MONDAY:'.and.day_ow.eq.5).or. 2 (inp_line(:8).eq.'TUESDAY:'.and.day_ow.eq.6).or. 3 (inp_line(:10).eq.'WEDNESDAY:'.and.day_ow.eq.0).or. 4 (inp_line(:9).eq.'THURSDAY:'.and.day_ow.eq.1).or. 5 (inp_line(:7).eq.'FRIDAY:'.and.day_ow.eq.2).or. 6 (inp_line(:9).eq.'SATURDAY:'.and.day_ow.eq.3)) then i = index(inp_line,' ') j = index(inp_line(:i),':') if (i.gt.1.and.j.gt.1.and.i-j.gt.1) then code = sys$bintim('-- '//inp_line(j+1:i-1),qtst2) if (code.and.qtst2(2).ge.0) then call lib$subx(qtst1,qtst2,qtst3) if (qtst3(2).lt.0) goto 1 !future so skip call sys$bintim(max_delay,qtst3) call lib$subx(qtst2,qtst3,qtst3) call lib$subx(qtst3,qtst1,qtst3) if (qtst3(2).lt.0) goto 1 !future so skip inp_line = inp_line(i+1:) goto 2 !Reparse for a command end if end if else c c Try to decode the first word as a time if it doesn't match c any of the above commands (format dd-mmm-yyyy:hh:mm:ss.ss). c If it is a time, this routine has from the time specified c to 5 minutes after the time specified to read the current c line and dispatch the command. c i = index(inp_line,' ') j = index(inp_line(:i),':') if (i.gt.1.and.j.gt.1.and.i-j.gt.1) then code = sys$bintim(inp_line(:j-1)//' '//inp_line(j+1:i-1), 1 qtst2) if (code.and.qtst2(2).ge.0) then call lib$subx(qtst1,qtst2,qtst3) if (qtst3(2).lt.0) goto 1 !future so skip call sys$bintim(max_delay,qtst3) call lib$subx(qtst2,qtst3,qtst3) call lib$subx(qtst3,qtst1,qtst3) if (qtst3(2).lt.0) goto 1 !future so skip inp_line = inp_line(i+1:) goto 2 !Reparse for a command end if end if end if c c Fixup for weekdays c i = index(inp_line,':') if (i.gt.0) then if (inp_line(:i).eq.'SUNDAY:'.or.inp_line(:i).eq. 1 'MONDAY:'.or.inp_line(:i).eq.'TUESDAY:'.or.inp_line(:i) 2 .eq.'WEDNESDAY:'.or.inp_line(:i).eq.'THURSDAY:'.or. 3 inp_line(:i).eq.'FRIDAY:'.or.inp_line(:i).eq.'SATURDAY:') 4 dumy = nan$_normal end if c c Write an appropriate message and go get another line c if (dumy.ne.nan$_normal) call output(1,'RDCOM - invalid '// 1 'syntax or unknown command: '//inp_line(:len1(inp_line))) goto 1 c c Finished c 3 close(unit=2) 99 return end c subroutine sho_idle(inp_line,ret_mbxchan,dumy) c c Send a user's idle logoff cycle and the manager's minimum c and maximum idle cycle restrictions c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' include '($iodef)' character*(*) inp_line character*80 mess integer*4 pidt,out_val,out_min,out_max integer*2 ret_mbxchan logical*1 dumy,buf_out(16) equivalence (buf_out(1),out_val) equivalence (buf_out(5),out_min) equivalence (buf_out(9),out_max) equivalence (buf_out(13),out_cyc) c c Get the target process id c dumy = nan$_invcom i = index(inp_line,' ') + 1 if (lench(inp_line(i:)).eq.0) then pidt = loop_iosb(2) else mess = inp_line(i:) do while(mess(1:1).eq.' ') mess = mess(2:) end do i = index(mess,' ') - 1 if (i.le.0) goto 1 read(mess(1:i),'(z)',err=1) pidt end if c c Are we watching the target process? c point = 0 do i=1,maxuser if (pid(i).eq.pidt) point = i end do if (point.eq.0) goto 1 c c Construct the output string c out_val = idle_val(point) out_min = minidle out_max = maxidle out_cyc = waitim code=sys$qio(,%val(ret_mbxchan),%val(io$_writevblk+io$m_now), 1 ,,,buf_out,%val(16),,,,) if (bug(code,'QIO').eq.ss$_normal) dumy = nan$_normal return c c Error c 1 call output(1,'ISHOW failed. Bad process ID.') return end c subroutine mod_idle(inp_line,dumy) c c Change a user's idle logoff cycle period within manager's c restrictions c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' include '($jpidef)' character*(*) inp_line character*80 mess character*12 usert,userc integer*4 new_cycle,pidt,pidc,getlis(7) integer*2 uicc(2) logical*1 dumy c c Get the target process id c dumy = nan$_invcom i = index(inp_line,' ') + 1 if (lench(inp_line(i:)).eq.0) return mess = inp_line(i:) do while(mess(1:1).eq.' ') mess = mess(2:) end do i = index(mess,' ') - 1 if (i.le.0) goto 1 read(mess(1:i),'(z)',err=1) pidt mess = mess(i+2:) c c Get the new idle cycle requested c if (lench(mess).eq.0) goto 1 do while(mess(1:1).eq.' ') mess = mess(2:) end do i = index(mess,' ') - 1 if (i.le.0) goto 1 read(mess(1:i),'(i)',err=1) new_cycle c c Are we watching the target process? c point = 0 do i=1,maxuser if (pid(i).eq.pidt) point = i end do if (point.eq.0) goto 1 c c Get his username c getlis(1) = jpi$_username * 2**16 + 12 getlis(2) = %loc(usert) getlis(3) = 0 getlis(4) = 0 code = sys$bintim(wait_time,qwait) if (bug(code,'BINTIM').ne.ss$_normal) goto 1 code = sys$setimr(%val(8),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 1 code = sys$getjpi(%val(7),pidt,,getlis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 1 code = sys$wflor(%val(7),%val(2**7.or.2**8)) call bug(code,'WFLOR') c c Decode the requesting process ID c pidc = loop_iosb(2) c c Get the requestor's username c getlis(1) = jpi$_username * 2**16 + 12 getlis(2) = %loc(userc) getlis(3) = 0 getlis(4) = jpi$_uic * 2**16 + 4 getlis(5) = %loc(uicc) getlis(6) = 0 getlis(7) = 0 code = sys$setimr(%val(8),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 1 code = sys$getjpi(%val(7),pidc,,getlis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 1 code = sys$wflor(%val(7),%val(2**7.or.2**8)) call bug(code,'WFLOR') c c If the usernames are different and this isn't a system c user, quit c if (uicc(2).gt.sysgrp.and.userc(:len1(userc)).ne. 1 usert(:len1(usert))) goto 1 c c If the new cycle is within out limits, reset the c idle cycle for this user c if (new_cycle.ge.minidle.and.new_cycle.le.maxidle) then mess = ' ' write(mess(1:12),'(i12)',err=1) new_cycle do while(mess(1:1).eq.' ') mess = mess(2:) end do call output(1,'Idle cycles changed by '//userc(:len1( 1 userc))//' for '//usert(:len1(usert))//' to '//mess(: 2 len1(mess))) idle_val(point) = new_cycle dumy = nan$_normal else call output(1,'Invalid new cycle value for IDLESET') end if return c c Error c 1 call output(1,'IDLESET failed') return end c subroutine com_spawn(inline,dumy) c c Create a subprocess using DCL to run a specified command c procedure with an (optional) logfile c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' include '($pqldef)' include '($prcdef)' include '($prvdef)' include '($syidef)' character*(*) inline character*80 comfile,logfile character*8 chrnum integer*4 uict,pidt,defpri,syilis(4) byte pqlis(71) logical*1 dumy c c Setup the privileges the process will have c dumy = nan$_nopriv prvadr = prv$m_netmbx .or. prv$m_oper .or. 1 prv$m_setprv .or. prv$m_tmpmbx c c Get the default login priority c syilis(1) = syi$_defpri * 2**16 + 4 syilis(2) = %loc(defpri) syilis(3) = 0 syilis(4) = 0 code = sys$getsyiw(,,,syilis,,,) if (.not.code) then call output(1,'RDCOM/SPAWN - unable to get DEFPRI') return end if c c Setup the UIC and process quotas c uict = 1 * 2**16 + 4 !UIC = [1,4] pqlis(1) = pql$_astlm pqlis(2) = lib$extzv(0,8,nan$_astlm) pqlis(3) = lib$extzv(8,8,nan$_astlm) pqlis(4) = lib$extzv(16,8,nan$_astlm) pqlis(5) = lib$extzv(24,8,nan$_astlm) pqlis(6) = pql$_biolm pqlis(7) = lib$extzv(0,8,nan$_biolm) pqlis(8) = lib$extzv(8,8,nan$_biolm) pqlis(9) = lib$extzv(16,8,nan$_biolm) pqlis(10) = lib$extzv(24,8,nan$_biolm) pqlis(11) = pql$_bytlm pqlis(12) = lib$extzv(0,8,nan$_bytlm) pqlis(13) = lib$extzv(8,8,nan$_bytlm) pqlis(14) = lib$extzv(16,8,nan$_bytlm) pqlis(15) = lib$extzv(24,8,nan$_bytlm) pqlis(16) = pql$_cpulim pqlis(17) = 0 pqlis(18) = 0 pqlis(19) = 0 pqlis(20) = 0 pqlis(21) = pql$_diolm pqlis(22) = lib$extzv(0,8,nan$_diolm) pqlis(23) = lib$extzv(8,8,nan$_diolm) pqlis(24) = lib$extzv(16,8,nan$_diolm) pqlis(25) = lib$extzv(24,8,nan$_diolm) pqlis(26) = pql$_enqlm pqlis(27) = lib$extzv(0,8,nan$_enqlm) pqlis(28) = lib$extzv(8,8,nan$_enqlm) pqlis(29) = lib$extzv(16,8,nan$_enqlm) pqlis(30) = lib$extzv(24,8,nan$_enqlm) pqlis(31) = pql$_fillm pqlis(32) = lib$extzv(0,8,nan$_fillm) pqlis(33) = lib$extzv(8,8,nan$_fillm) pqlis(34) = lib$extzv(16,8,nan$_fillm) pqlis(35) = lib$extzv(24,8,nan$_fillm) pqlis(36) = pql$_jtquota pqlis(37) = lib$extzv(0,8,nan$_jtquota) pqlis(38) = lib$extzv(8,8,nan$_jtquota) pqlis(39) = lib$extzv(16,8,nan$_jtquota) pqlis(40) = lib$extzv(24,8,nan$_jtquota) pqlis(41) = pql$_pgflquota pqlis(42) = lib$extzv(0,8,nan$_pgflquota) pqlis(43) = lib$extzv(8,8,nan$_pgflquota) pqlis(44) = lib$extzv(16,8,nan$_pgflquota) pqlis(45) = lib$extzv(24,8,nan$_pgflquota) pqlis(46) = pql$_prclm pqlis(47) = lib$extzv(0,8,nan$_prclm) pqlis(48) = lib$extzv(8,8,nan$_prclm) pqlis(49) = lib$extzv(16,8,nan$_prclm) pqlis(50) = lib$extzv(24,8,nan$_prclm) pqlis(51) = pql$_tqelm pqlis(52) = lib$extzv(0,8,nan$_tqelm) pqlis(53) = lib$extzv(8,8,nan$_tqelm) pqlis(54) = lib$extzv(16,8,nan$_tqelm) pqlis(55) = lib$extzv(24,8,nan$_tqelm) pqlis(56) = pql$_wsdefault pqlis(57) = lib$extzv(0,8,nan$_wsdefault) pqlis(58) = lib$extzv(8,8,nan$_wsdefault) pqlis(59) = lib$extzv(16,8,nan$_wsdefault) pqlis(60) = lib$extzv(24,8,nan$_wsdefault) pqlis(61) = pql$_wsextent pqlis(62) = lib$extzv(0,8,nan$_wsextent) pqlis(63) = lib$extzv(8,8,nan$_wsextent) pqlis(64) = lib$extzv(16,8,nan$_wsextent) pqlis(65) = lib$extzv(24,8,nan$_wsextent) pqlis(66) = pql$_wsquota pqlis(67) = lib$extzv(0,8,nan$_wsquota) pqlis(68) = lib$extzv(8,8,nan$_wsquota) pqlis(69) = lib$extzv(16,8,nan$_wsquota) pqlis(70) = lib$extzv(24,8,nan$_wsquota) pqlis(71) = pql$_listend c c Sort out the command file and the optional logfile (if any) c if (lench(inline).le.0) return do while(inline(1:1).eq.' ') inline = inline(2:) end do i = index(inline,' ') if (i.le.1) i = len1(inline) if (i.le.1) return comfile = inline(:i-1) logfile = inline(i+1:) if (lench(logfile).le.0) then logfile = nan$_cp_out else do while(logfile(1:1).eq.' ') logfile = logfile(2:) end do end if c c Create the detached process as requested c code = sys$creprc(pidt,%descr('sys$system:loginout.exe'), 1 %descr(comfile(:len1(comfile))),%descr(logfile(:len1( 2 logfile))),%descr(logfile(:len1(logfile))),prvadr,pqlis,, 3 %val(defpri),%val(uict),,%val(prc$m_ssrwait.or.prc$m_detach 4 .or.prc$m_nopassword)) if (bug(code,'$CREPRC').eq.ss$_normal) then write(chrnum,'(z8)',err=1) pidt if (lench(chrnum).eq.0) goto 1 do while(chrnum(1:1).eq.' ') chrnum = chrnum(2:) end do call output(1,'RDCOM/SPAWN - created process I.D. '// 1 'is '//chrnum(:len1(chrnum))) dumy = nan$_normal return end if 1 call output(1,'RDCOM/SPAWN - process created') dumy = nan$_normal return end c subroutine oprman(inline,dumy) C C This will set a terminl to receive operator messages or C to terminate operator messages to a terminal(REPLY/ENABLE C or REPLY/DISABLE). c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 parameter wait_time = '0 0:0:3.0' implicit integer*4 (a-z) include 'nanny.inc' include '($dvidef)' include '($iodef)' include '($jpidef)' character*(*) inline character*80 message character*23 oprmes character*12 user,term,tty character*4 funct integer*4 getlis(10),qwait(2),dvilis(7),unit_num integer*2 jbcret,unit,uicc(2) byte tty_l,opc$_rq_terme logical*1 dumy,edmask(3) equivalence (opc$_rq_terme,oprmes(1:1)) equivalence (edmask,oprmes(2:4)) equivalence (opc$m_nm_all,oprmes(5:8)),(unit,oprmes(9:10)) equivalence (tty_l,oprmes(11:11)),(tty,oprmes(12:23)) data opc$_rq_terme,opc$m_nm_all/1,'ffffffff'x/ C dumy = nan$_invcom call sys$bintim(wait_time,qwait) C C Get the function(OEN or ODIS) C i=index(inline,' ')+1 if (i.le.2) goto 999 funct=inline(1:i-2) inline=inline(i:) C C Get the process I.D. of the requestor C pidc = loop_iosb(2) C C Get the username, uic, and terminal of the requestor C getlis(1) = jpi$_username * 2**16 + 12 getlis(2) = %loc(user) getlis(3) = 0 getlis(4) = jpi$_uic * 2**16 + 4 getlis(5) = %loc(uicc) getlis(6) = 0 getlis(7) = jpi$_terminal * 2**16 + 12 getlis(8) = %loc(term) getlis(9) = 0 getlis(10) = 0 code = sys$setimr(%val(13),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 code = sys$getjpi(%val(14),pidc,,getlis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 999 code = sys$wflor(%val(13),%val(2**13.or.2**14)) call bug(code,'WFLOR') C C A terminal was requested so get the name C if (lench(inline).ne.0) then if (uicc(2).gt.sysgrp) goto 999 do while(inline(1:1).eq.' ') inline=inline(2:) end do i=index(inline,' ')-1 if (i.le.0) goto 888 term=inline(1:i) end if C C No terminal was specified. Cut up the requestors C i=index(term,':') if (i-4.lt.1) goto 888 if (i.eq.0) term=term(:len1(term))//':' if (term(1:1).ne.'_') term='_'//term tty=term tty_l=index(tty,':') C C Get the unit number and the real terminal device name C dvilis(1)=dvi$_unit*2**16 + 4 dvilis(2)=%loc(unit_num) dvilis(3)=0 dvilis(4)=dvi$_tt_phydevnam*2**16 + 12 dvilis(5)=%loc(term) dvilis(6)=0 dvilis(7)=0 code = sys$setimr(%val(13),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 code = sys$getdvi(%val(14),,tty(:tty_l),dvilis,,,,) if (bug(code,'GETDVI').ne.ss$_normal) goto 999 code = sys$wflor(%val(13),%val(2**13.or.2**14)) call bug(code,'WFLOR') unit=lib$extzv(0,16,unit_num) if (lench(term).gt.0) tty = term edmask(1)=0 edmask(2)=0 edmask(3)=0 C C Do the dirty deed C if (funct(:3).eq.'OEN') then edmask(1)=-1 edmask(2)=-1 edmask(3)=-1 code=sys$sndopr(%descr(oprmes(:12+tty_l-1)),%val(mbx2)) if (bug(code,'SNDOPR').ne.ss$_normal) goto 888 else if (funct.eq.'ODIS') then code=sys$sndopr(%descr(oprmes(:12+tty_l-1)),%val(mbx2)) if (bug(code,'SNDOPR').ne.ss$_normal) goto 888 end if C C Read from the mailbox for the completion status C code = sys$setimr(%val(13),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 888 code = sys$qio(%val(14),%val(mbx2),%val(io$_readvblk), 1 ,,,jbcret,%val(2),,,,) if (bug(code,'QIO').ne.ss$_normal) goto 888 code = sys$wflor(%val(13),%val(2**13.or.2**14)) call bug(code,'WFLOR') if (jbcret.ne.0) then if (bug(jbcret,'SNDOPR').ne.ss$_normal) goto 888 end if code = sys$cancel(%val(mbx2)) call bug(code,'CANCEL') C C We did it! Let's write out a message now. C dumy=1 call output(2,'Command '//funct(:len1(funct))//' requested '// 1 'by '//user(:len1(user))//' completed') return c c Error c 888 code = sys$cancel(%val(mbx2)) call bug(code,'CANCEL') dumy = nan$_retwarn 999 call output(1,'Command '//funct(:len1(funct))//' requested '// 1 'by '//user(:len1(user))//' aborted') return end c subroutine output(out_msk,message) c c Send a specified message to either the logfile or c the logfile and the operator console. c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' include '($brkdef)' include '($iodef)' character*(*) message character*216 oprmsg character*132 mess character*23 datim logical*1 buff(132) equivalence (buff,mess) c c Output the message to the logfile no matter what c open(unit=6,name='SYS$OUTPUT:',carriagecontrol='list',err=2, 1 access='append',recl=512,status='old') goto 3 2 open(unit=6,name='SYS$OUTPUT:',carriagecontrol='list',err=4, 1 recl=512,status='new') 3 call lib$date_time(datim) mess_l=len1(message) if (mess_l.gt.132) mess_l=132 if (out_msk.ne.0) write(6,100) datim//' '//message(:mess_l) if (out_msk.eq.1) goto 1 c c Construct a message for the operator and send it c oprmsg = char(13)//char(10)//char(10)//'%NANNY, '//datim//', '// 1 message(:mess_l)//char(13)//char(7)//char(7)//char(7) do i=1,8 if (lench(consoles(i)).gt.0) then code = sys$brkthru(,%descr(oprmsg(:len1(oprmsg))),%descr( 1 consoles(i)(:len1(consoles(i)))),%val(brk$c_device),,,,, 2 %val(5),,) call bug(code,'BRKTHRU') end if end do code = sys$brkthru(,%descr(oprmsg(:len1(oprmsg))),%descr(opcom), 1 %val(brk$c_device),,,,,%val(5),,) c c Stamp the logfile c if (bug(code,'BRKTHRU').ne.ss$_normal) write(6,100) ' '// 1 ' OPCOM didn''t receive message' c c Send message to listening mailbox c 1 close(unit=6) if (.not.listen) return mess = message code = sys$qio(,%val(mbx3),%val(io$_writevblk+io$m_now), 1 ,,,buff,%val(132),,,,) call bug(code,'QIO') return c c Can't open our output file (SYS$OUTPUT) c 4 call sys$exit(%val('123'x)) stop 100 format(a) end c subroutine opr_par(oprttys) c c Parse line for terminal names to receive Nanny messages c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' character*(*) oprttys c c Loop for tty names c if (oprttys(:6).eq.'') then do i=1,8 consoles(i)=' ' end do else point=1 do while(lench(consoles(point)).ne.0.and.point.le.8) point=point+1 end do if (point.le.8) then do while(oprttys(1:1).eq.' ') oprttys=oprttys(2:) end do i=index(oprttys,' ')-1 if (i.lt.5.and.lench(oprttys).gt.0) i=lench(oprttys) if (i.lt.5) return consoles(point)=oprttys(1:i) if (consoles(point)(1:1).ne.'_') consoles(point)='_'// 1 consoles(point) if (debugging.eq.2) call output(1,'Nanny operator '// 1 'terminal enabled: '//consoles(point)) end if end if end c subroutine list_loop c c Recursive read attention on NANNY$PEEK mailbox (needs LOG_IO) c c (c) Zar Ltd. 1985 c implicit integer*4 (a-z) parameter ss$_normal = 1 include 'nanny.inc' include '($iodef)' external peek_write c code = sys$qiow(,%val(mbx3),%val(io$_setmode+io$m_readattn), 1 ,,,peek_write,,,,,) if (bug(code,'QIO').ne.ss$_normal) call output(1,'NANNY$PEEK'// 1 ' will be ignored') return end c subroutine peek_write c c This is started when someone asks for data with a read c on NANNY$PEEK c c (c) Zar Ltd. 1985 c implicit integer*4 (a-z) parameter ss$_normal = 1 include 'nanny.inc' include '($iodef)' character*80 mess logical*1 buff equivalence (mess,buff) external list_loop c c Construct an informative message from current system load c if (listen) then if (loadave(1)+loadave(2)+loadave(3)+loadave(4) 1 .gt.0) then mess = ' i, s, b, and o processes on '// 1 'the system...' write(mess(1:4),'(i4)',err=1) loadave(1) write(mess(8:11),'(i4)',err=1) loadave(2) write(mess(15:18),'(i4)',err=1) loadave(3) write(mess(26:29),'(i4)',err=1) loadave(4) do while(mess(26:26).eq.' ') mess = mess(:25)//mess(27:) end do do while(mess(15:15).eq.' ') mess = mess(:14)//mess(16:) end do do while(mess(8:8).eq.' ') mess = mess(:7)//mess(9:) end do do while(mess(1:1).eq.' ') mess = mess(2:) end do else 1 mess = '-No users found on the system' end if else mess = 'NANNY$PEEK is disabled' end if code = sys$qio(,%val(mbx3),%val(io$_writevblk+io$m_now), 1 ,,,buff,%val(80),,,,) call bug(code,'QIO') c c Requeue AST in one cycle (to keep a user from causing an c infinite loop by requeuing reads on NANNY$PEEK every second c or faster) c code = sys$setimr(,truewait,list_loop,) if (bug(code,'SETIMR').ne.ss$_normal) call output(1, 1 'Requeue of PEEKRD failed. NANNY$PEEK will be ignored.') return end c subroutine listener(how) c c Set the LISTEN flag for debugging purposes c c (c) Zar Ltd. 1985 c implicit integer*4 (a-z) include 'nanny.inc' integer*4 how c if (how.eq.0) then listen = .false. call output(1,'IGNORE command issued: NANNY$PEEK closed') else listen = .true. call list_loop call output(1,'LISTEN command issued: NANNY$PEEK opened') end if return end c subroutine queman(inline,dumy) c c This will STOP, STOP/NEXT, START, and STOP/REQUEUE batch, c print, or server queues via the $SNDSMB system service. c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 parameter wait_time = '0 0:0:3.0' implicit integer*4 (a-z) include 'nanny.inc' include '($jpidef)' include '($sjcdef)' character*(*) inline character*80 message character*16 queue character*12 user character*7 funct integer*4 getlis(4),qwait(2),sjclis(4),iosb(2) logical*1 dumy c c Initialize c dumy = nan$_invcom call sys$bintim(wait_time,qwait) c c Get the function c i=index(inline,' ')+1 funct=inline(1:i-2) inline=inline(i:) c c Get the queue name to execute the function on c if (lench(inline).eq.0) goto 999 do while(inline(1:1).eq.' ') inline=inline(2:) end do i=index(inline,' ')+1 if (i-2.lt.1) goto 999 queue=inline(:i-2) queue_l=i-2 inline=inline(i:) c c Get the process I.D. of the requestor c pidc=loop_iosb(2) c c Get the UIC of the requestor c getlis(1) = jpi$_username*2**16 + 12 getlis(2) = %loc(user) getlis(3) = 0 getlis(4) = 0 code = sys$setimr(%val(15),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 code = sys$getjpi(%val(16),pidc,,getlis,,,) if (bug(code,'GETJPI').ne.ss$_normal) goto 999 code = sys$wflor(%val(15),%val(2**15.or.2**16)) call bug(code,'WFLOR') c c Do the dirty deed c code = sys$setimr(%val(15),qwait,,) if (bug(code,'SETIMR').ne.ss$_normal) goto 999 sjclis(1) = sjc$_queue * 2**16 + queue_l sjclis(2) = %loc(queue) sjclis(3) = 0 sjclis(4) = 0 if (funct(:7).eq.'REQUEUE') then sjcode = sys$sndjbc(%val(16),%val(sjc$_reset_queue), 1 ,sjclis,iosb,,) else if (funct(:6).eq.'QSTART') then sjcode = sys$sndjbc(%val(16),%val(sjc$_start_queue), 1 ,sjclis,iosb,,) else if (funct(:5).eq.'PAUSE') then sjcode = sys$sndjbc(%val(16),%val(sjc$_pause_queue), 1 ,sjclis,iosb,,) else if (funct(:5).eq.'QSTOP') then sjcode = sys$sndjbc(%val(16),%val(sjc$_stop_queue), 1 ,sjclis,iosb,,) end if if (bug(sjcode,'SNDJBC').ne.ss$_normal) goto 999 code = sys$wflor(%val(15),%val(2**15.or.2**16)) call bug(code,'WFLOR') if (bug(sjcode,'SNDJBC').ne.ss$_normal) goto 999 if (bug(iosb(1),'SNDJBC').ne.ss$_normal) goto 999 c c We did it! Let's write out a message now. c dumy = 1 call output(2,'Command '//funct(:len1(funct))// 1 ' requested by '//user(:len1(user))//' completed') return c c Errors c 999 call output(1,'Command '//funct(:len1(funct))// 1 ' requested by '//user(:len1(user))//' aborted') return end c subroutine dayweek(start,day_year) c c Assign/system the days of the week c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' include '($lnmdef)' character*23 dat,datim character*9 week_day(0:6) integer*4 qdate(2),lnmlis(4),day logical*1 start data week_day/'WEDNESDAY','THURSDAY','FRIDAY','SATURDAY', 1 'SUNDAY','MONDAY','TUESDAY'/ c c Define the day of the week c call lib$date_time(datim) if (datim(13:14).eq.'00'.or.start) then call lib$day(day) day = mod(day,7) call str$upcase(dat,week_day(day)) lnmlis(1) = lnm$_string * 2**16 + len1(week_day(day)) lnmlis(2) = %loc(week_day(day)) lnmlis(3) = 0 lnmlis(4) = 0 code = sys$crelnm(,%descr('LNM$SYSTEM_TABLE'), 1 %descr('TODAY'),,lnmlis) call bug(code,'CRELNM') return end if if (start) return c c Reset time because of DST? c if (datim(13:14).eq.'02'.and.(day_year.eq.adv_dstday.or. 1 day_year.eq.bck_dstday)) then if (day_year.eq.adv_dstday) then call sys$bintim('-- 03::.',qdate) else call sys$bintim('-- 01::.',qdate) end if code = sys$setime(qdate) if (bug(code,'SETIME').eq.ss$_normal) call output(2, 1 'DST time change') end if return end c subroutine waker(inline,flag,inp_uic,dumy) c c Leave a wake-up call for a terminal. c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' character*(*) inline character*80 message character*40 mess(max_wake) character*14 term(max_wake) integer*2 id(max_wake),req_uic(max_wake,2),flag integer*2 inp_uic(2) logical*1 dumy double precision qwait(max_wake) common/nan$wake1/qwait,id,req_uic common/nan$wake2/term,mess external wake c c If the initialize flag, zero values and return c dumy = nan$_invcom if (flag.eq.0) then do i=1,max_wake id(i)=0 req_uic(i,2)=0 req_uic(i,1)=0 call sys$cantim(%val(i+9),) end do dumy=1 return end if c c Disallow multiple wake-up calls by a single requestor c imsk='fff7ffff'x.or.functmsk !Function 20 if (imsk.eq.'ffffffff'x) then do i=1,max_wake if (id(i).ne.0.and.req_uic(i,1).eq.inp_uic(1).and. 1 req_uic(i,2).eq.inp_uic(2)) return end do end if c c Search for an empty wake-up slot c do i=1,max_wake if (id(i).eq.0) then c c Get the name(tty or user) to send the wake-up call to c j=index(inline,' ')+1 if (lench(inline(j:)).eq.0) goto 111 do while(inline(j:j).eq.' ') inline=inline(1:j-1)//inline(j+1:) end do k=index(inline,':') if (k.eq.0) goto 111 l=j+index(inline(j+1:),' ') if (k.gt.l) k=l-1 if (inline(j:j).eq.'_') j=j+1 if (j.gt.k) goto 111 if (inline(k:k).eq.':') term(i)='_'//inline(j:k) if (inline(k:k).ne.':') term(i)=inline(j:k) call str$upcase(term(i),term(i)) c c Get the date and time to issue the wake-up call c inline=inline(k+2:) if (lench(inline).eq.0) goto 111 do while(inline(1:1).eq.' ') inline=inline(2:) end do k=index(inline,'.') if (k.eq.0) goto 111 j=index(inline,'"')+1 if (j.lt.4) goto 111 call str$upcase(inline(:j-3),inline(:j-3)) if (sys$bintim(inline(:k),qwait(i)).gt.1) goto 111 c c Get the message, flag this slot as used, and set a timer c for the wake-up call, and return. c do ii=1,31 if (index(inline(j:),char(ii)).ne.0) goto 111 end do if (index(inline(j:),char(127)).ne.0) goto 111 do ii=129,255 if (index(inline(j:),char(ii)).ne.0) goto 111 end do mess(i)=inline(j:) code=sys$setimr(,qwait(i),wake,%val(i+9)) if (bug(code,'SETIMR').ne.ss$_normal) goto 111 id(i)=1 req_uic(i,2)=inp_uic(2) req_uic(i,1)=inp_uic(1) write(message,'(a,o6,a,o6,a)') 'Wake-up call request'// 1 'ed to terminal '//term(i)(:len1(term(i)))//' by [', 2 inp_uic(2),',',inp_uic(1),']' call output(2,message(:62)) dumy = (i+9) * -1 return end if end do dumy = nan$_noslot c c An error occurred or no empty wakeup slots c 111 call output(1,'Unable to issue wake-up call for '// 1 term(i)) return end c subroutine wake c c Wake a user. c c (c) Zar Ltd. 1985 c parameter maxwait = '0 0:0:3.0' parameter cdat = '-- ::.' implicit integer*4 (a-z) include 'nanny.inc' include '($brkdef)' include '($dcdef)' include '($dvidef)' include '($ssdef)' character*40 mess(max_wake) character*14 term(max_wake),test_term character*12 unams character*9 dat character*7 ttys integer*4 qpause(2),resdat(2),jpibuf(7),dvilis(4) integer*2 id(max_wake),ttys_l logical*1 sent double precision qwait(max_wake),curdat common/nan$wake1/qwait,id common/nan$wake2/term,mess c c Initialize some stuff c sent = .false. call sys$bintim(cdat,curdat) c c Figure out which wakeup call it is(all calls with dates c in the past) c do i=1,max_wake if (id(i).ne.0) then call lib$subx(qwait(i),curdat,resdat) if (resdat(2).le.0) then c c Get the time and zero this wakeup slot c call time(dat) id(i)=0 c c If the tty location is a username, look for him/her on c the system. c k=brk$c_username !Assume its a username call str$upcase(term(i),term(i)) dvilis(1)=dvi$_devclass * 2**16 + 4 dvilis(2)=%loc(dev_type) dvilis(3)=0 dvilis(4)=0 c c Are they real terminals c test_term=term(i) istat=sys$getdviw(,,test_term,dvilis,,,,) if (istat.and.dev_type.eq.dc$_term) k=brk$c_device if (k.eq.brk$c_username) then if (term(i)(1:1).eq.'_') term(i)=term(i)(2:) j=len1(term(i)) if (term(i)(j:j).eq.':') term(i)=term(i)(:j-1) end if c c Send the wake-up call c code=sys$brkthru(,%descr(dat//'Wake-up call from your '// 1 'Nanny: '//mess(i)//char(7)//char(7)//char(7)),%descr(term( 2 i)(:len1(term(i)))),%val(k),,,%val(brk$m_cluster),%val( 3 brk$c_urgent),%val(5),,) call bug(code,'BRKTHRU') call output(1,'Wake completed to '//term(i)) sent=.true. end if end if end do return end c subroutine wakeclr(inline,inp_uic,dumy) c c Clear one or all wake up calls c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' character*(*) inline integer*2 req_uic(max_wake,2),inp_uic(2),id(max_wake) logical*1 dumy double precision qwait(max_wake) common/nan$wake1/qwait,id,req_uic c c Get the number of the timer request to clear c dumy=nan$_invcom i=index(inline,' ')+1 inline=inline(i:) if (lench(inline).eq.0) goto 111 do while(lench(inline(1:1)).eq.0) inline=inline(2:) end do i=lench(inline) if (inline(1:1).eq.'*') then if (inp_uic(2).gt.sysgrp) then dumy=nan$_nonsys return end if req_num=1 end_num=max_wake else read(inline(1:i),'(i)',err=111) req_num req_num=req_num-9 end_num=req_num end if c c Make sure its the same UIC that requested the wake c if (inp_uic(2).gt.sysgrp.and.(inp_uic(2).ne. 1 req_uic(req_num,2).or.inp_uic(1).ne. 2 req_uic(req_num,1))) then dumy=nan$_nopriv return end if c c Zero it/them and return c dumy=1 do i=req_num,end_num id(i)=0 code=sys$cantim(%val(i+9),) if (bug(code,'CANTIM').ne.ss$_normal) dumy=nan$_retwarn end do return c c Error c 111 call output(1,'WCLR command aborted on error') return end c subroutine showake(inp_mbxchan) c c Display the queue of wakeup calls c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' include '($iodef)' character*14 tty(max_wake),term integer*2 id(max_wake),req_uic(max_wake,2),inp_mbxchan integer*2 req_num,req_user(2) logical*1 buff(28) double precision qwait(max_wake),quadwait common/nan$wake1/qwait,id,req_uic common/nan$wake2/tty equivalence (buff(1),req_num),(buff(3),req_user) equivalence (buff(7),term),(buff(21),quadwait) c c Get a used request c do i=1,max_wake if (id(i).ne.0) then c c Construct the information and send it c req_num=i req_user(2)=req_uic(i,2) req_user(1)=req_uic(i,1) term=tty(i) quadwait=qwait(i) code=sys$qio(,%val(inp_mbxchan),%val(io$_writevblk+ 1 io$m_now),,,,buff,%val(28),,,,) call bug(code,'QIO') end if end do c c Send a request id of -1 to end messages c req_num=-1 code=sys$qio(,%val(inp_mbxchan),%val(io$_writevblk+io$m_now), 1 ,,,buff,%val(28),,,,) call bug(code,'QIO') return end c subroutine wdump(file,flag,dumy) c c Save outstanding wake-up calls to a file c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' include '($lnmdef)' character*(*) file character*80 filename character*40 mess(max_wake) character*14 tty(max_wake) integer*4 flag,lnmlis(4) integer*2 id(max_wake),req_uic(max_wake,2),req_user(2) logical*1 dumy double precision qwait(max_wake) common/nan$wake1/qwait,id,req_uic common/nan$wake2/tty,mess c c Cancel timers c dumy = nan$_nopriv j = 0 do i=1,max_wake if (id(i).ne.0) then j = j + 1 if (flag.eq.1) then code=sys$cantim(%val(i+9),) call bug(code,'CANTIM') end if end if end do c c If there are no wake-up calls, exit c if (j.eq.0) then dumy = nan$_normal if (flag.eq.0) call output(1,'No wake-up calls to dump') return end if c c If no file was specified, try to translate NANNY$DUMP c if (lench(file).eq.0) then filename = ' ' acmode = 1 !EXEC Mode lnmlis(1) = lnm$_string * 2**16 + 80 lnmlis(2) = %loc(filename) lnmlis(3) = 0 lnmlis(4) = 0 code = sys$trnlnm(,%descr('LNM$SYSTEM_TABLE'), 1 %descr('NANNY$DUMP'),acmode,lnmlis) if (bug(code,'TRNLNM').ne.ss$_normal) then call output(1,'WDUMP command failed. No filename.') return end if else filename = file end if c c Delete any existing wake-up dump file by the same name c open(unit=1,name=filename(:len1(filename)),err=1, 1 form='unformatted',status='old') close(unit=1,disp='delete') c c Open file and save each wake-up call c 1 open(unit=1,name=filename(:len1(filename)),err=3, 1 form='unformatted',status='new') do i=1,max_wake if (id(i).ne.0) then req_user(1) = req_uic(i,1) req_user(2) = req_uic(i,2) write(1,err=2) req_user,tty(i),qwait(i),mess(i) 2 continue end if end do close(unit=1) dumy = nan$_normal if (flag.eq.0) call output(1,'Dumped wake-up calls to '// 1 filename(:len1(filename))) return 3 call output(1,'Unable to dump to file '//filename(:len1( 1 filename))) return end c subroutine wrdmp c c Restore wake-up calls from a save file c parameter ss$_normal = 1 implicit integer*4 (a-z) include 'nanny.inc' character*80 message character*40 mess(max_wake) character*14 tty(max_wake) integer*2 id(max_wake),req_uic(max_wake,2),req_user(2) double precision qwait(max_wake) common/nan$wake1/qwait,id,req_uic common/nan$wake2/tty,mess external wake c c Open save file and read all lines c open(unit=1,name='nanny$dump',form='unformatted', 1 err=3,status='old') i = 1 1 read(1,err=2) req_user,tty(i),qwait(i),mess(i) id(i) = 1 req_uic(i,1) = req_user(1) req_uic(i,2) = req_user(2) code = sys$setimr(,qwait(i),wake,%val(i+9)) if (bug(code,'SETIMR').ne.ss$_normal) then id(i) = 0 write(message,'(a,o6,a,o6,a)') 'Wake-up call from [', 1 req_user(2),',',req_user(1),'] to '//tty(i)(:len1(tty( 2 i)))//' could not reload' call output(1,message(:len1(message))) else i = i + 1 end if goto 1 2 close(unit=1,disp='delete') call output(1,'Reloaded wake-up calls') 3 return end c subroutine sndver(mbx,version) c c Send the version number of Nanny to the return mailbox c c (c) Zar Ltd. 1985 c implicit integer*4 (a-z) include '($iodef)' character*(*) version character*10 ver integer*2 mbx logical*1 buf(10) equivalence (buf,ver) c ver=version code=sys$qio(,%val(mbx),%val(io$_writevblk+io$m_now), 1 ,,,buf,%val(10),,,,) call bug(code,'QIO') return end c subroutine warnuser(pid,ttynum,usrnam,qwait) c c Send a message to a user for being idle c c (c) Zar Ltd. 1985 c parameter ss$_normal = 1 implicit integer*4 (a-z) include '($brkdef)' character*90 message character*12 usrnam character*10 ttynum character*8 timbf character*4 mins integer*2 ttynum_l,message_l c c Clear the message buffer c message = ' ' usr_l=len1(usrnam) ttynum_l=len1(ttynum) c c Get the time of day c call time(timbf) oun=(qwait)/6000 mins=' ' write(mins,'(i4)',err=1) oun 1 if (lench(mins).gt.0) then do while(mins(1:1).eq.' ') mins=mins(2:) end do else mins='??' end if c c Assemble the message c message = char(7)//timbf//' '//usrnam(:usr_l)//' on '// 1 ttynum(:ttynum_l)//' has been idle and will be logged '// 2 'off in '//mins(:len1(mins))//' '//'minutes'//char(7)// 3 char(7) message_l = len1(message) c c We got a nice note, send it to him c e = sys$brkthru(,%descr(message(:message_l)),%descr(ttynum(: 1 len1(ttynum))),%val(brk$c_device),,,,,%val(5),,) if (bug(e,'BRKTHRU').eq.ss$_normal) then call output(1,message(11:message_l-2)) else call output(1,usrnam(:len1(usrnam))//' on '//ttynum(:len1( 1 ttynum))//' did not receive logoff warning.') end if return end