From:	CSBVAX::MRGATE!@KL.SRI.Com:zar@Hamlet.Caltech.Edu@SMTP 30-JUN-1987 10:36
To:	EVERHART
Subj:	Nanny Source V1.0 9/14

Received: from Hamlet.Caltech.Edu by KL.SRI.Com with TCP; Mon 29 Jun 87 17:38:22-PDT
Date:     Mon, 29 Jun 87 17:33:16 PDT
From:     zar@Hamlet.Caltech.Edu (Dan Zirin)
Message-Id: <870629173316.0m9@Hamlet.Caltech.Edu>
Subject:  Nanny Source V1.0 9/14
To:       info-vax@kl.sri.com

$!------------------------------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
