zar@HAMLET.CALTECH.EDU (Dan Zirin) (06/30/87)
$!------------------------------Cut Here-------------------------
$ chk = "241224347"
$ create nf4.for
$ deck/dollars="ThEgReAtZaR"
c
c=======================================================================
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 (dsk_die) return
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
code = sys$setimr(,qwait,dskmon,)
if (bug(code,'BINTIM').ne.ss$_normal) goto 1
return
c
c An error occurred
c
1 call output(1,'Disk monitor crash')
return
end
c
c=======================================================================
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)'
character*60 disknam
integer*4 dvilis(13),qwait(2)
logical*1 errflg
c
c Loop for each disk
c
if (dsk_die) return
errflg = .false.
dvilis(1) = dvi$_devnam * 2**16 + 60
dvilis(2) = %loc(disknam)
dvilis(3) = %loc(disknam_l)
dvilis(4) = dvi$_errcnt * 2**16 + 4
dvilis(5) = %loc(errcnt)
dvilis(6) = 0
dvilis(7) = dvi$_freeblocks * 2**16 + 4
dvilis(8) = %loc(freeblks)
dvilis(9) = 0
dvilis(10) = dvi$_maxblock * 2**16 + 4
dvilis(11) = %loc(maxblock)
dvilis(12) = 0
dvilis(13) = 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)).ne.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 disknam(:disknam_l)//' is low on disk space')
c
c Check for large increases in error count
c
if (errcnt-lasterr(icnt).ge.maxerr) call output(2,
1 'Device '//disknam(:disknam_l)//' is receiving '//
2 '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
subroutine forget(inline,uic,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(7),qwait(2)
integer*2 uic(2),uicc(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<i>)',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) = jpi$_uic * 2**16 + 4
getlis(5) = %loc(uicc)
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(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 to requesting process I.D.
C
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<i>)',err=999) pidc
if (pidc.eq.0) goto 999
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 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 Make sure requestor and mailbox UIC are the same
C
if (uic(1).ne.uicc(1).or.uic(2).ne.uicc(2)) then
write(message,'(a,o3,a,o3,a)') 'System being violated'//
1 ' by UIC [',uic(2),',',uic(1),']'
call output(2,message(:38))
return
end if
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
subroutine gotmess
C
C Routine to communicate with outside world
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)'
character*128 inline
character*12 retmbxnam
character*9 dat
integer*4 dvilis(4)
integer*4 qwait(2)
integer*2 retmbx,uict(2)
logical*1 dumy
equivalence (inbuff,inline)
C
dumy = nan$_nopriv
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 PID 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 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 IGNORE - Stop sending messages to NANNY$PEEK
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 QSTART - Start a batch/device queue
C QSTOP - Stop a batch/device queue
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 WAKE - Request a wakeup call
C WCLR - Request to clear a wake-up call
C WSHOW - Request to return queue information on all
C wake-up calls
C
ThEgReAtZaR
$ checksum nf4.for
$ if chk.nes.checksum$checksum then write sys$output -
"NF4.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ exit