zar@Hamlet.Caltech.EDU (Dan Zirin) (06/30/87)
$!------------------------------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