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

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

$!------------------------------Cut Here-------------------------
$ chk = "1783915820"
$ create nf8.for
$ deck/dollars="ThEgReAtZaR"
        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)'
        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$cancel(%val(mbx3))
        call bug(code,'CANCEL')
        code = sys$qio(,%val(mbx3),%val('70'x),,,,buff,%val(132),,,,)
        call bug(code,'QIO')
        return
4       call sys$exit(%val('123'x))
        stop
100     format(a)
        end
c
c=======================================================================
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
        do i=1,8
         consoles(i)=' '
        end do
        point=1
1       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)
        point=point+1
        if (point.gt.8) return
        oprttys=oprttys(i+2:)
        goto 1
        end
        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 output(1,'LISTEN command issued: NANNY$PEEK opened')
        end if
        return
        end
        subroutine      queman(inline,uic,dumy)
c
c       This will STOP, START, and STOP/REQUEUE batch or print
c       queues via the $SNDSMB system service.
c
c       (c) Zar Ltd. 1985
c
        parameter       ss$_normal   = 1
        parameter       nan$_invcom  = '1d'x
        parameter       nan$_nopriv  = '20'x
        parameter       nan$_retwarn = '1c'x
        parameter       wait_time    = '0 0:0:3.0'
        implicit        integer*4 (a-z)
        include         '($jpidef)'
        include         '($sjcdef)'
        character*(*)   inline
        character*80    message
        character*16    queue
        character*12    user
        character*7     funct
        integer*4       getlis(7),qwait(2),sjclis(7)
        integer*2       uic(2),uicc(2)
        logical*1       dumy
c
c       Initialize
c
        dumy     = nan$_invcom
        if (dumy.eq.nan$_invcom) return   !Remove when this module is fixed
        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='                '
        queue(2:i-2+1)=inline(:i-2)
        queue(1:1)=char(i-2)
        inline=inline(i:)
c
c       Get the process I.D. of the requestor
c
        if (lench(inline).eq.0) goto 999
        do while(inline(1:1).eq.' ')
         inline=inline(2:)
        end do
        i=index(inline,' ')-1
        read(inline(:i),'(z<i>)',err=999) pid
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) = jpi$_uic*2**16 + 4
        getlis(5) = %loc(uicc)
        getlis(6) = 0
        getlis(7) = 0
        code = sys$setimr(%val(15),qwait,,)
        if (bug(code,'SETIMR').ne.ss$_normal) goto 999
        code = sys$getjpi(%val(16),pid,,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       Make sure the requestor and the mailbox UICs 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))
          dumy = nan$_nopriv
          return
        end if
c
c       Do the dirty deed
c
        if (funct.eq.'REQUEUE') then
          sjclis(1) = sjc$_queue * 2**16 + 16
          sjclis(2) = %loc(queue)
          sjclis(3) = 0
          sjclis(4) = sjc$_requeue * 2**16
          sjclis(5) = 0
          sjclis(6) = 0
          sjclis(7) = 0
          code = sys$setimr(%val(15),qwait,,)
          if (bug(code,'SETIMR').ne.ss$_normal) goto 999
          sjcode = sys$sndjbc(%val(16),%val(sjc$_abort_job),
     1    ,sjclis,,,)
          if (bug(sjcode,'SNDJBC').ne.ss$_normal) goto 999
          code = sys$wflor(%val(15),%val(2**15.or.2**16))
          call bug(code,'WFLOR')
        else if (funct(:6).eq.'QSTART') then
          sjclis(1) = sjc$_queue * 2**16 + 16
          sjclis(2) = %loc(queue)
          sjclis(3) = 0
          sjclis(4) = 0
          code = sys$setimr(%val(15),qwait,,)
          if (bug(code,'SETIMR').ne.ss$_normal) goto 999
          sjcode = sys$sndjbc(%val(16),%val(sjc$_start_queue),
     1    ,sjclis,,,)
          if (bug(sjcode,'SNDJBC').ne.ss$_normal) goto 999
          code = sys$wflor(%val(15),%val(2**15.or.2**16))
          call bug(code,'WFLOR')
        else if (funct(:5).eq.'QSTOP') then
          sjclis(1) = sjc$_queue * 2**16 + 16
          sjclis(2) = %loc(queue)
          sjclis(3) = 0
          sjclis(4) = 0
          code = sys$setimr(%val(15),qwait,,)
          if (bug(code,'SETIMR').ne.ss$_normal) goto 999
          sjcode = sys$sndjbc(%val(16),%val(sjc$_stop_queue),
     1    ,sjclis,,,)
          if (bug(sjcode,'SNDJBC').ne.ss$_normal) goto 999
          code = sys$wflor(%val(15),%val(2**15.or.2**16))
          call bug(code,'WFLOR')
        end if
        if (bug(sjcode,'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
        subroutine      dayweek(start)
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         '($lnmdef)'
        character*23    dat,datim
        character*9     week_day(0:6)
        integer*4       qdate(2),lnmlis(4)
        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$day(day)
        day = mod(day,7)
        call lib$date_time(datim)
        if (datim(13:14).eq.'00'.or.start) then
          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(,'LNM$SYSTEM_TABLE','TODAY',,lnmlis)
          call bug(code,'CRELOG')
          return
        end if
        if (start) return
c
c       Reset time because of DST?
c
        if ((datim(4:6).eq.'APR'.or.datim(4:6).eq.'OCT').and.
     1  datim(13:14).eq.'02'.and.day.eq.4) then
          call idate(j,i,j)
          i = 30 - i
          if (datim(4:6).eq.'OCT') i = i + 1
          if (i.le.6) then
            if (datim(4:6).eq.'OCT') then
              call sys$bintim('-- 01::.',qdate)
            else
              call sys$bintim('-- 03::.',qdate)
            end if
            code = sys$setime(qdate)
            if (bug(code,'SETIME').eq.ss$_normal) call output(2,
     1      'DST time change')
          end if
        end if
        return
        end
ThEgReAtZaR
$ checksum nf8.for
$ if chk.nes.checksum$checksum then write sys$output -
  "NF8.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ exit
