program       idle_acp
c
c       This program is a easier interface to the Nanny commands
c       IDLESET and ISHOW. This program may also be used as a
c       template for making other user interfaces to Nanny.
c
c       To run this program, define a DCL symbol such as
c             $ idle :== $this_dev:[this_dir]IDLEACP
c       then the command
c             $ idle/show [pid]
c       will display current Nanny idle settings for the current
c       process ID or another user's idle settings if the optional
c       "pid" is specified. To change the idle settings:
c             $ idle/set value [pid]
c
c       This program requires integer functions LEN1 and LENCH
c       from NLIB.OLB or in NFUNC.FOR.
c
        implicit      integer*4 (a-z)
        include       '($dvidef)'
        include       '($jpidef)'
        character*80  com_line
        character*16  mbx_name,inbuff
        character*8   pid,opt_pid,value
        integer*4     jpilis(4),dvilis(4)
        integer*2     mbx_channel
        logical*1     set_flag
        equivalence   (inbuff(1:4),  cur_val)
        equivalence   (inbuff(5:8),  min_val)
        equivalence   (inbuff(9:12), max_val)
        equivalence   (inbuff(13:16),val_sec)
c
c       First get the DCL command line
c
        set_flag = .false.
        call lib$get_foreign(com_line,,)
c
c       Delete tabs from the input command line
c
        do while(index(com_line,char(9)).ne.0)
         i = index(com_line,char(9))
         com_line(i:i) = ' '
        end do
c
c       If there is no DCL command line, show how they are supposed
c       to use this program
c
        if (lench(com_line).eq.0) then
1         write(6,'(a)') ' Usage: IDLE/SHOW [pid] :or: IDLE/SET '//
     1    'value [pid]'
          call exit
        end if
c
c       Delete prefix spaces
c
        do while(com_line(1:1).eq.' ')
         com_line = com_line(2:)
        end do
c
c       Get the option type (either /SET or /SHOW)
c
        if (com_line(1:2).ne.'/S') goto 1
        if (com_line(1:3).eq.'/SE') set_flag = .true.
        if (com_line(1:3).ne.'/SH'.and.(.not.set_flag)) goto 1
c
c       Delete qualifier
c
        i = index(com_line,' ')
        if (i.eq.0) i = lench(com_line) + 1
        com_line = com_line(i+1:)
c
c       If /SET and there is no required value show help
c
        if (set_flag) then
          if (lench(com_line).eq.0) goto 1
c
c       Get value to change idle setting
c
          do while(com_line(1:1).eq.' ')
           com_line = com_line(2:)
          end do
          i = index(com_line,' ') - 1
          if (i.eq.-1) i = lench(com_line)
          if (i.le.0) goto 1
          read(com_line(:i),'(i<i>)',err=1) idle_val
          value = com_line(:i)
c
c       Delete the idle value from command line
c
          com_line = com_line(i+2:)
        end if
c
c       If there is a optional process ID (hex), get it now
c
        opt_pid = ' '
        if (lench(com_line).ne.0) then
          do while(com_line(1:1).eq.' ')
           com_line = com_line(2:)
          end do
          i = index(com_line,' ') - 1
          if (i.eq.-1) i = lench(com_line)
          if (i.gt.0) then
            read(com_line(:i),'(z<i>)',err=1) target_pid
            opt_pid = com_line(:i)
          end if
        end if
c
c       Get the current user's process ID
c
        jpilis(1) = jpi$_pid * 2**16 + 4
        jpilis(2) = %loc(source_pid)
        jpilis(3) = 0
        jpilis(4) = 0
        istat     = sys$getjpiw(,,,jpilis,,,)
        if (.not.istat) call sys$exit(%val(istat))
c
c       Convert the current user's PID to ASCII
c
        write(pid,'(z8)') source_pid
        i = 1
        do while(pid(i:i).eq.' ')
         pid(i:i) = '0'
         i = i + 1
        end do
        if (lench(opt_pid).eq.0) opt_pid = pid
c
c       Create a temporary mailbox
c
        istat     = sys$crembx(%val(0),mbx_channel,,,,,'NAN$RET')
        if (.not.istat) call sys$exit(%val(istat))
c
c       Get the ASCII name for our newly created mailbox
c
        dvilis(1) = dvi$_devnam * 2**16 + 16
        dvilis(2) = %loc(mbx_name)
        dvilis(3) = 0
        dvilis(4) = 0
        istat     = sys$getdviw(,%val(mbx_channel),,dvilis,,,,)
        if (.not.istat) call sys$exit(%val(istat))
c
c       Open the channel to Nanny and open our return mailbox
c
        open(unit=1,name='NANNYS$BOX:',status='old',err=2,
     1  carriagecontrol='list')
        open(unit=2,name='NAN$RET:',status='old',err=3,readonly,
     1  carriagecontrol='list')
c
c       Create a Nanny request by first concatenating our PID
c       with our return mailbox name and then prefixing the
c       appropriate command name
c
        com_line = mbx_name(:len1(mbx_name))//' '//pid
        if (set_flag) then
          com_line = 'IDLESET '//com_line
        else
          com_line = 'ISHOW '//com_line
        end if
c
c       If there was an optional PID specified, concatenate that
c       to our Nanny request or use our own PID
c
        com_line = com_line(:lench(com_line))//' '//opt_pid
c
c       For the IDLESET command concatenate the value now
c
        if (set_flag) com_line = com_line(:lench(com_line))//' '//
     1  value
c
c       Send the request to Nanny!
c
        write(1,'(a)') com_line(:lench(com_line))//' '
        close(unit=1)
c
c       If this is the ISHOW command, read the settings from the
c       return mailbox first
c
        if (.not.set_flag) then
          com_line = ' '
          read(2,'(a)') inbuff
          write(6,'(a,i8)') ' Current idle setting for PID #'//
     1    opt_pid//' is: ',cur_val
          write(6,'(a,i7,a,i8,/,a,i10,a)') ' Minimum setting: ',
     1    min_val,', Maximum setting: ',max_val,' (Units of ',
     2    val_sec*10,' milliseconds)'
        end if
c
c       Read the return status from Nanny
c
        read(2,'(a)') com_line(1:1)
        if (ichar(com_line(1:1)).eq.1) then
          write(6,'(a)') ' Command return status was normal'
          call exit
        else
          write(6,'(a)') ' Error processing command by Nanny'
          call sys$exit(%val('2c'x))
        end if
c
c       Error opening Nanny's mailbox
c
2       write(6,'(a)') ' Nanny doesn''t appear to be running'
        call sys$exit(%val('2c'x))
c
c       Error opening our own mailbox
c
3       write(6,'(a)') ' Unable to create a return mailbox'
        call sys$exit(%val('2c'x))
        end