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