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

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

$!------------------------------Cut Here-------------------------
$ chk = "34363991"
$ j = 0
$ required = "nf1.for"
$ if "''f$search(required)'".eqs."" then write sys$output -
  "File NF1.FOR must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."" then j = 1
$ required = "nf2.for"
$ if "''f$search(required)'".eqs."" then write sys$output -
  "File NF2.FOR must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."" then j = 1
$ required = "nf3.for"
$ if "''f$search(required)'".eqs."" then write sys$output -
  "File NF3.FOR must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."" then j = 1
$ required = "nf4.for"
$ if "''f$search(required)'".eqs."" then write sys$output -
  "File NF4.FOR must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."" then j = 1
$ required = "nf5.for"
$ if "''f$search(required)'".eqs."" then write sys$output -
  "File NF5.FOR must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."" then j = 1
$ required = "nf6.for"
$ if "''f$search(required)'".eqs."" then write sys$output -
  "File NF6.FOR must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."" then j = 1
$ required = "nf7.for"
$ if "''f$search(required)'".eqs."" then write sys$output -
  "File NF7.FOR must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."" then j = 1
$ required = "nf8.for"
$ if "''f$search(required)'".eqs."" then write sys$output -
  "File NF8.FOR must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."" then j = 1
$ if j.eq.1 then exit %x2c
$ create nf9.for
$ deck/dollars="ThEgReAtZaR"
        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       Search for an empty wake-up slot
c
        do i=1,25
         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
           if (inline(j:j).eq.'_') j=j+1
           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,o3,a,o3,a)') 'Wake-up call request'//
     1     'ed to terminal '//term(i)//' by [',inp_uic(2),',',
     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
c=====================================================================
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(5),,)
             call bug(code,'BRKTHRU')
             call output(2,'Wake completed to terminal '//term(i))
             sent=.true.
           end if
         end if
        end do
        return
        end
c
c=======================================================================
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<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
c=======================================================================
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'
        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('70'x),,,,buff,%val(28)
     1     ,,,,)
           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('70'x),,,,buff,%val(28)
     1  ,,,,)
        call bug(code,'QIO')
        return
        end
        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(1:10)                           = char(7)//timbf
        message_l                               = 11
        message(message_l:usr_l+message_l)      = usrnam
        message_l                               = message_l+usr_l+1
        message(message_l:message_l+ttynum_l+3) = 'on '//ttynum
        message_l                               = message_l+ttynum_l+3
c
        message(message_l:message_l+58) = ' has been inactive, and '//
     1  'will be logged off in '//mins(:len1(mins))//' '//'minutes'//
     2  char(7)//char(7)
c
c       We got a nice note, send it to him
c
        e = sys$brkthru(,%descr(message(:message_l+58)),%descr(ttynum(:
     1  len1(ttynum))),%val(brk$c_device),,,,,%val(5),,)
        message = message(11:)
        if (bug(e,'BRKTHRU').eq.ss$_normal) then
          call output(1,message(:len1(message)-2))
        else
          call output(1,usrnam(:usr_l)//' on '//ttynum//' did not '//
     1    'receive logoff warning.')
        end if
        return
        end
ThEgReAtZaR
$ checksum nf9.for
$ if chk.nes.checksum$checksum then write sys$output -
  "NF9.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ copy/log -
  nf1.for+nf2.for+nf3.for+nf4.for+nf5.for+nf6.for+nf7.for+nf8.for+nf9.for -
  nfunc.for
$ if $status then delete/log nf1.for;,nf2.for;,nf3.for;,nf4.for;,nf5.for;,-
  nf6.for;,nf7.for;,nf8.for;,nf9.for;
$ exit
