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