[comp.os.vms] Nanny Source V1.0 5/14

zar@HAMLET.CALTECH.EDU (Dan Zirin) (06/30/87)

$!------------------------------Cut Here-------------------------
$ chk = "2063871130"
$ create wakeacp.for
$ deck/dollars="ThEgReAtZaR"
        IMPLICIT INTEGER(A-Z)
        CHARACTER*128 INLINE
        CHARACTER*40  PROM
        CHARACTER*23  REQ_DATE
        CHARACTER*14  REQ_USER
        CHARACTER*12  MBXNAM
        INTEGER*4     QWAIT(2)
        INTEGER*2     REQ_ID,REQ_UIC(2)
        LOGICAL*1     ILOGI,BUFF(28)
        EQUIVALENCE   (BUFF(1),REQ_ID ),(REQ_UIC,BUFF(3))
        EQUIVALENCE   (REQ_USER,BUFF(7)),(QWAIT,BUFF(21))
c
        OPEN(UNIT=1,NAME='NANNYS$BOX',SHARED,STATUS='OLD',ERR=2)
        CALL SYS$CREMBX(%VAL(0),MBXCHN,,,,,'NAN$RET')
        CALL SYS$TRNLOG('NAN$RET',,MBXNAM,,,)
        CALL LIB$GET_FOREIGN(INLINE,,L)
        IF (L.EQ.0) THEN
          WRITE(6,'(A)') '$To(username or terminal): '
          READ(5,'(A)',END=2) PROM
          IF (LENCH(PROM).EQ.0) GOTO 2
          CALL STR$UPCASE(PROM,PROM)
          INLINE='WAKE '//PROM(:LENCH(PROM))//':'
          WRITE(6,'(A)') '$Time(dd-mmm-yyyy hh:mm:ss.ss): '
          READ(5,'(A)',END=2) PROM
          IF (LENCH(PROM).EQ.0) PROM='-- ::.'
          CALL STR$UPCASE(PROM,PROM)
          IF (SYS$BINTIM(PROM,QWAI).GT.1) GOTO 3
          INLINE=INLINE(:LENCH(INLINE))//' '//PROM(:LENCH(PROM))//' "'
          WRITE(6,'(A)') '$Message: '
          READ(5,'(A)',END=2) PROM
          IF (LENCH(PROM).EQ.0) GOTO 2
          IF (PROM(1:1).EQ.'"') PROM=PROM(2:)
          INLINE=INLINE(:LENCH(INLINE))//PROM
        ELSE IF (INDEX(INLINE,'/S').NE.0.OR.INDEX(INLINE,'/s').NE.0)
     1  THEN
          WRITE(6,'(A)') ' '
          WRITE(6,'(A)') '  * Wake-up queue "Nanny" Joblim=25'
          WRITE(6,'(A)') ' '
          INLINE='WSHOW '//MBXNAM(:LENCH(MBXNAM))//' '
          WRITE(1,'(A)') ' '//INLINE(:LENCH(INLINE)+1)
1         CODE=SYS$QIOW(,%VAL(MBXCHN),%VAL('31'X),,,,BUFF,%VAL(28),,,,)
          IF (CODE.NE.1) CALL SYS$EXIT(%VAL(CODE))
          IF (REQ_ID.NE.-1) THEN
            CODE=SYS$ASCTIM(,REQ_DATE(:23),QWAIT,)
            IF (CODE.NE.1) CALL SYS$EXIT(%VAL(CODE))
            DO I=LEN1(REQ_USER),14
             REQ_USER(I:I)=' '
            END DO
            WRITE(6,'(A,I2,A,O3,A,O3,A)') '   #',REQ_ID+9,' from [',
     1      REQ_UIC(2),',',REQ_UIC(1),'] to '//REQ_USER//' at '//
     2      REQ_DATE(:20)
            GOTO 1
          END IF
          CALL EXIT
        ELSE IF (INDEX(INLINE,'/D').NE.0.OR.INDEX(INLINE,'/d').NE.0)
     1  THEN
          IF (INDEX(INLINE,'=').EQ.0) THEN
            INLINE='WCLR '//MBXNAM(:LENCH(MBXNAM))//' * '
          ELSE
            INLINE=INLINE(INDEX(INLINE,'=')+1:)
            IF (LENCH(INLINE).EQ.0) STOP 'Invalid request number'
            INLINE='WCLR '//INLINE(:2)
          END IF
        ELSE
          I=INDEX(INLINE,'"')
          IF (I.EQ.0) STOP 'No message'
          I=INDEX(INLINE,'-')
          IF (I.EQ.0) STOP 'No date'
          I=INDEX(INLINE,':')
          IF (I.EQ.0) STOP 'Bad time specified'
          I=INDEX(INLINE,'.')
          IF (I.EQ.0) STOP 'Bad time specified'
          I=INDEX(INLINE,' ')
          IF (INLINE(I-1:I-1).NE.':') INLINE=INLINE(1:I-1)//
     1    ':'//INLINE(I:)
          INLINE='WAKE '//INLINE
        END IF
        INLINE=INLINE(:5)//MBXNAM(:LENCH(MBXNAM))//' '//INLINE(6:)
        WRITE(1,'(A)') ' '//INLINE(:LENCH(INLINE))
        CALL SYS$QIOW(,%VAL(MBXCHN),%VAL('31'X),,,,ILOGI,%VAL(1),,,,)
        I=ILOGI
        IF (I.LT.0) WRITE(6,'(A,I2,A)') ' Wake-up call request #',I*-1,
     1  ' queued'
        IF (I.GT.1) STOP 'Nanny could not process request; try again.'
        IF (I.EQ.1) STOP 'Request cancelled'
2       CALL EXIT
3       STOP 'Bad date/time'
        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 wakeacp.for
$ if chk.nes.checksum$checksum then write sys$output -
  "WAKEACP.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ chk = "1460773486"
$ create nm1.for
$ deck/dollars="ThEgReAtZaR"
        program         Nanny
c
c       My Daemon (Nanny)
c
c       Written by Daniel M. Zirin for Zar Limited
c       ZAR @ CITCHEM (bitnet) ZAR @ XHMEIA.Caltech.Edu ([192.12.19.15] arpa)
c       XHMEIA::ZAR (area 5 node 920 span/hepnet)
c
c       command syntax:
c               command ret_mail_box parameters ascii_blank
c
c Nanny input bit masks:
c       Debugging        0 - No debugging messages
c       (Bits 31 & 32    1 - Do not execute vital functions and display
c       of the Function      extra messages
c       mask)            2 - Execute all functions and display extra
c                            messages
c
c       Function mask   Bit  Meaning
c                        1 - Allow batch priority dither
c                        2 - Allow detach priority dither
c                        3 - Allow normal user priority dither
c                        4 - Allow network process priority dither
c                        5 - Allow subprocess priority dither
c                        6 - CPU total is accumulated by all dup procs
c                        7 - Allow suspending on low memory
c                        8 - Allow batch processes to be suspended
c                        9 - Allow detach processes to be suspended
c                       10 - Allow normal processes to be suspended
c                       11 - Allow network processes to be suspended
c                       12 - Allow subprocesses to be suspended
c                       13 - If set, logoff entire process tree when
c                            idle. If clear, logoff process with no
c                            subprocesses first
c                       14 - If set, system users are subject to idle-
c                            time logout (interactive only)
c                       15 - Give idle time warning @1/2 maxidle
c                       16 - Give idle time warning @<60 seconds left
c                       17 - Give CPU warning @time-cycle
c                       18 - Allow preference dither
c                       19 - Not used
c                       27 - Not used
c                       28 - Assign/system node name and load average
c                            to sys$announce
c                       29 - Assign/system the day of week and allow
c                            time reset for DST
c                       30 - Reserved
c                       31 - Debugging bit 1
c                       32 - Debugging bit 2
c
c       Command msk     Bit  Meaning
c                        1 - Disable ADDACC command
c                        2 - Disable DIE command
c                        3 - Disable ENTER command
c                        4 - Disable FORGET command
c                        5 - Disable FREE command
c                        6 - Disable GRAB command
c                        7 - Disable IGNORE command
c                        8 - Disable KILL command
c                        9 - Disable LISTEN command
c                       10 - Disable NEW command
c                       11 - Disable ODIS command
c                       12 - Disable OEN command
c                       13 - Disable QSTART command
c                       14 - Disable QSTOP command
c                       15 - Disable REQUEUE command
c                       16 - Disable RESUME command
c                       17 - Disable STOP command
c                       18 - Disable SUSPEND command
c                       19 - Disable WAKE command *
c                       20 - Disable WCLR command *
c                       21 - Disable WSHOW command *
c                       22 - Not used
c                       32 - Not used
c
c       OUTPUT routine   0 - Output to OPA0: only
c                        1 - Output to logfile only
c                        2 - Output to OPA0: and logfile
c
c * = Returns special values/output in return mailbox. See help file.
c
c       Created         Zar ltd.    20-May-83
c       Revised         Zar ltd.    30-Jun-83
c       Revised         Zar ltd.     2-Aug-83
c       Revised         Zar ltd.    30-Oct-83
c       Revised         Zar ltd.     5-Oct-85 for VMS V4
c       Revised         Zar ltd.     9-Jun-87
c
c       (c) Zar Ltd. 1983,1985,1986,1987
c
        parameter       pcb$v_batch    = '00e'x
        parameter       pcb$v_netwrk   = '015'x
        implicit        integer*4 (a-z)
        include         'nanny.inc'
        include         '($brkdef)'
        include         '($ssdef)'
        character*100   message
        character*12    username(maxuser)
        character*10    terminal(maxuser),phy_term(maxuser)
        character*9     cur_date
        character*8     account(maxuser)
        character*2     old_date
        integer*4       authpriv(maxuser,2)
        integer*4       bufio(maxuser)
        integer*4       cputim(maxuser)
        integer*4       dirio(maxuser)
        integer*4       ncputim(maxuser,max_average)
        integer*4       owner(maxuser)
        integer*4       pageflts(maxuser)
        integer*4       second3(2)
        integer*4       seedpid
        integer*4       sts(maxuser)
        integer*4       warn(maxuser)
        integer*4       wssize(maxuser)
        integer*4       wstore(2)
        integer*2       o_seqnum
        integer*2       uic(maxuser,2)
        integer*2       usedpri(0:31)
        real*4          new_cputim
        real*4          preadd
        logical*1       dst_chk
        logical*1       dumy
        logical*1       first
        logical*1       limwarn(maxuser)
        logical*1       resumeok
        logical*1       suspendok
        logical*1       susp_flg(maxuser)
        logical*1       warned(maxuser)
        logical*1       ws_mem_purge
        external        nanjpi,gotmess,wait_rel,boost
ThEgReAtZaR
$ checksum nm1.for
$ if chk.nes.checksum$checksum then write sys$output -
  "NM1.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ exit