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

Received: from Hamlet.Caltech.Edu by KL.SRI.Com with TCP; Mon 29 Jun 87 17:34:32-PDT
Date:     Mon, 29 Jun 87 17:30:46 PDT
From:     zar@Hamlet.Caltech.Edu (Dan Zirin)
Message-Id: <870629173046.0m4@Hamlet.Caltech.Edu>
Subject:  Nanny Source V1.0 4/14
To:       info-vax@kl.sri.com

$!------------------------------Cut Here-------------------------
$ chk = "1342642494"
$ create nannyacp.for
$ deck/dollars="ThEgReAtZaR"
        program         nanny
c
c       Execute some of the Nanny's functions
c
        parameter       ss$_normal     = 1
        parameter       maxcom         = 21
        parameter       nan$_comdis    = '1f'x
        parameter       nan$_invcom    = '1d'x
        parameter       nan$_nonsys    = '21'x
        parameter       nan$_nopriv    = '20'x
        parameter       nan$_normal    = 1
        parameter       nan$_noslot    = '1b'x
        parameter       nan$_nosuchcom = '1e'x
        parameter       nan$_retwarn   = '1c'x
        parameter       nan_inp        = 'NANNYS$BOX:'
        implicit        integer*4 (a-z)
        include         '($jpidef)'
        include         '($lnmdef)'
        character*80    comand
        character*23    req_datim
        character*14    tty
        character*10    shoe_box_nam
        character*8     my_pid
        character*7     coms(maxcom)
        integer*4       jpilist(4),com_abv(maxcom),qwait(2),lnmlis(4)
        integer*2       term_chan,req_id,req_user(2)
        logical*1       buff,buffr(28)
        equivalence     (req_id,buffr(1)),(req_user,buffr(3))
        equivalence     (tty,buffr(7)),(qwait,buffr(21))
        data coms/'ADDACC','DIE','ENTER','FORGET','FREE','GRAB',
     1  'IGNORE','KILL','LISTEN','NEW','ODIS','OEN','QSTART','QSTOP',
     2  'REQUEUE','RESUME','STOP','SUSPEND','WAKE','WCLR','WSHOW'/
        data com_abv/1,1,2,2,2,1,1,1,1,1,2,2,4,4,3,3,2,2,2,2,2/
c
c       Create a mailbox to communicate with the Nanny
c
        code = sys$crembx(%val(0),term_chan,,,,,'SHOE_BOX')
        if (code.ne.ss$_normal) call sys$exit(%val(code))
        lnmlis(1) = lnm$_string * 2**16 + 10
        lnmlis(2) = %loc(shoe_box_nam)
        lnmlis(3) = 0
        lnmlis(4) = 0
        code = sys$trnlnm(,'LNM$JOB','SHOE_BOX',,lnmlis)
        if (code.ne.ss$_normal) call sys$exit(%val(code))
c
c       Get the user's process I.D.
c
        jpilist(1) = jpi$_pid*2**16 + 4
        jpilist(2) = %loc(pid)
        jpilist(3) = 0
        jpilist(4) = 0
        code = lib$get_ef(ef)
        if (code.ne.ss$_normal) call sys$exit(%val(code))
        code = sys$getjpi(%val(ef),,,jpilist,,,)
        if (code.ne.ss$_normal) call sys$exit(%val(code))
        call sys$waitfr(%val(ef))
        write(my_pid,'(Z8)',err=1) pid
        do while(lench(my_pid(1:1)).eq.0)
         my_pid = my_pid(2:)
        end do
        goto 2
c
c       Error converting the process I.D. to a character string.
c
1       call errsns(i,j,k,l,code)
        call sys$exit(%val(code))
c
c       Open the mailbox to the Nanny
c
2       open(unit=1,name=nan_inp,shared,err=1,status='old')
c
c       Prompt for commands
c
3       write(5,'(a)',err=4) '$Nanny> '
4       read(5,'(a)',err=3,end=999) comand
        if (lench(comand).eq.0) goto 3
        call str$upcase(comand,comand)
        do while(lench(comand(1:1)).eq.0)
         comand = comand(2:)
        end do
c
c       Give help
c
        if (comand(1:1).eq.'H') then
          write(6,100)
          goto 3
        end if
c
c       Replace the input command with the full length command
c
        comnum=0
        i=index(comand,' ')
        j=index(comand,'"')
        if (j.eq.0) j=lench(comand)
        do j=1,maxcom
         if (comand(:i-1).eq.coms(j)(:i-1)) comnum=j
        end do
        if (comnum.eq.0) then
          write(6,'(a)') ' No such command'
          goto 3
        end if
        if (i.lt.com_abv(comnum)) then
          write(6,'(a)') ' Ambiguous command'
          goto 3
        end if
        comand=coms(comnum)(:len1(coms(comnum)))//' '//comand(i+1:)
c
c       Insert the receiving mailbox
c
        i=index(comand,' ')
        comand=comand(:i)//shoe_box_nam(:len1(shoe_box_nam))//' '//
     1  comand(i+1:)
        if (comnum.eq.1.or.comnum.eq.2.or.comnum.eq.5)  goto 6
        if (comnum.eq.6.or.comnum.eq.7.or.comnum.eq.9)  goto 6
        if (comnum.eq.10.or.comnum.ge.19) goto 6
        comand=comand(:len1(comand))//' '//my_pid
6       write(1,'(a)',err=1) comand(:len1(comand))//' '
        if (comnum.ne.19) then
          write(5,'(a)',err=5) ' waiting for a reply from your Nanny...'
        else
          write(6,'(a)') ' '
          write(6,'(a)') '   * Wake-up queue "Nanny" Joblim=25'
          write(6,'(a)') ' '
7         code=sys$qiow(,%val(term_chan),%val('31'x),,,,buffr,%val(28),,
     1    ,,)
          if (code.ne.ss$_normal) then
8           write(6,'(a)') ' Error receiving queue information'
            goto 3
          end if
          if (req_id.ne.-1) then
            code=sys$asctim(,req_datim(:23),qwait,)
            if (code.ne.ss$_normal) goto 8
            do ii=len1(tty),14
             tty(ii:ii)=' '
            end do
            write(6,'(a,i2,a,o3,a,o3,a)') '   #',req_id+9,' from [',
     1      req_user(2),',',req_user(1),'] to '//tty//' at '//
     2      req_datim(:20)
            goto 7
          end if
        end if
5       code=sys$qiow(,%val(term_chan),%val('31'x),,,,buff,%val(1),,,,)
        if (code.eq.ss$_normal) then
          if (buff.eq.1) write(6,'(a)') ' Function granted by your '//
     1    'Nanny'
          if (buff.eq.nan$_nopriv) write(6,'(a)') ' Function denied'
          if (buff.eq.nan$_nonsys) write(6,'(a)') ' Function denied: '//
     1    'non-system user'
          if (buff.eq.nan$_comdis) write(6,'(a)') ' Function disabled'
          if (buff.eq.nan$_invcom) write(6,'(a)') ' Function incor'//
     1    'rectly sent'
          if (buff.eq.nan$_noslot) write(6,'(a)') ' Function denied: '//
     1    'no slot available in queue'
          if (buff.eq.nan$_retwarn) write(6,'(a)') ' Function issued:'//
     1    ' error return status from manager received'
          if (buff.lt.0) write(6,'(a,i2,a)') ' Function issued: '//
     1    'request #',-1*buff,' has been queued'
        else
          write(6,'(a)') ' Error sending request'
        end if
        goto 3
100     format(' Comands:',t20,'ADDACC  req_pid mess',/,t20,'DIE',/,
     1  t20,'ENTER   target_pid',/,t20,'FORGET  target_pid',/,
     2  t20,'FREE    devnam',/,t20,'GRAB    devnam',/,
     3  t20,'HELP',/,t20,'IGNORE',/,t20,'KILL    target_pid',/,
     4  t20,'LISTEN',/,t20,'NEW',/,
     5  t20,'ODIS',/,t20,'OEN',/,t20,'QSTART  queue',/,
     6  t20,'QSTOP   queue',/,t20,'REQUEUE queue',/,
     7  t20,'RESUME  target_pid',/,t20,'STOP    target_pid',/,
     8  t20,'SUSPEND target_pid',/,t20,'WAKE    tty date time mess',/,
     9  t20,'WCLR    tim_num',/,t20,'WSHOW',/,/,
     1  ' See "HELP @USER Nanny" for more information.')
999     end
        INTEGER FUNCTION LENCH(STRING)
C
C       This code was created solely by The Zar.
C       All portions of this routine/program are licensed
C       only by The Zar. Duplication or transportation of
C       this code is in violation of copy rights. Any
C       duplication and/or transportation of this code may
C       cause portions of this program/routine not to work.
C
C       -The Zar
C
        CHARACTER*(*) STRING
        CHARACTER*1 NUL
        DATA NUL/0/
        IF (STRING.EQ.' '.OR.STRING(1:1).EQ.NUL) THEN
                LENCH=0
                RETURN
        ENDIF
        DO 100 LENCH=LEN(STRING),1,-1
        IF (STRING(LENCH:LENCH).NE.' '.AND.STRING(LENCH:LENCH).NE.NUL)
     1  GOTO 200
100     CONTINUE
        LENCH=0
200     RETURN
        END
        FUNCTION LEN1(STR)
C
C       This code was created solely by The Zar.
C       All portions of this routine/program are licensed
C       only by The Zar. Duplication or transportation of
C       this code is in violation of copy rights. Any
C       duplication and/or transportation of this code may
C       cause portions of this program/routine not to work.
C
C       -The Zar
C
        CHARACTER*(*) STR
        I=LENCH(STR)
        IF (I.EQ.0) I=1
        LEN1=I
        RETURN
        END
ThEgReAtZaR
$ checksum nannyacp.for
$ if chk.nes.checksum$checksum then write sys$output -
  "NANNYACP.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ chk = "672852447"
$ create nf1.for
$ deck/dollars="ThEgReAtZaR"
        subroutine      wait_rel
        parameter       ss$_normal = 1
        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('2c'x))
        end if
        return
        end
        subroutine account(inline,uic,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'
        parameter       nan$_invcom  = '1d'x
        parameter       nan$_nopriv  = '20'x
        parameter       nan$_retwarn = '1c'x
        implicit        integer*4 (a-z)
        include         '($jpidef)'
        include         '($sjcdef)'
        include         '($ssdef)'
        character*(*)   inline
        character*115   message
        character*12    username
        integer*4       getlis(7),jbclis(4),qmin(2)
        integer*2       uic(2),uicc(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) = jpi$_uic * 2**16      +  4
        getlis(5) = %loc(uicc)
        getlis(6) = 0
        getlis(7) = 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
        i = index(inline,' ')-1
        if (i.lt.1) goto 999
        read(inline(:i),'(z<i>)',err=999) pidc
        inline = inline(i+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       Make sure the mailbox UIC and the requestor's are the same
C
        if (uic(1).ne.uicc(1).or.uic(2).ne.uicc(2)) then
          write(message,'(a,o3,a,o3,a)',err=999)
     1    'System being violated by UIC [',UIC(2),',',UIC(1),']'
          call output(2,message(:46))
          dumy = nan$_nopriv
          return
        end if
C
C       Construct the accounting message and send it
C
        message   = inline
        jbclis(1) = sjc$_accounting_message * 2**16 + 115
        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//' was successful')
        dumy = 1
        return
C
C       Error
C
888     call output(1,'Accounting record sent by '//
     1  username//' was aborted on error')
        dumy = nan$_retwarn
        return
999     call output(1,'Unable to send accounting record '//
     1  'for '//username)
        return
        end
ThEgReAtZaR
$ checksum nf1.for
$ if chk.nes.checksum$checksum then write sys$output -
  "NF1.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ exit
