zar@HAMLET.CALTECH.EDU (Dan Zirin) (06/30/87)
$!------------------------------Cut Here-------------------------
$ chk = "1783915820"
$ create nf8.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
ThEgReAtZaR
$ checksum nf8.for
$ if chk.nes.checksum$checksum then write sys$output -
"NF8.FOR didn't pass checksum. File may be corrupted."
$ if chk.nes.checksum$checksum then exit %x2c
$ exit