zar@JULIET.CALTECH.EDU.UUCP (06/18/87)
$!------------------------------Cut Here-------------------------
$ chk = "1750797451"
$ i = 0
$ required = "NF1.FOR"
$ if "''f$search(required)'".eqs."" then write sys$output -
"File ''required' must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."" then i = 1
$ required = "NF2.FOR"
$ if "''f$search(required)'".eqs."" then write sys$output -
"File ''required' must exist prior to running this procedure."
$ if "''f$search(required)'".eqs."".or.i.ne.0 then exit %x2c
$ create nf3.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
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 nf3.for
$ if chk.nes.checksum$checksum then write sys$output -
"NF3.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 nfunc.for
$ if $status then delete/log nf1.for;,nf2.for;,nf3.for;
$ exit