program kill
C-----------------------------------------------------------------------
C       Program deletes a specified process by $DELPRC system service.
C       It asks the user to supply the PID of the process. The process
C       must have the same UIC as the current user . The program must
C       be INSTALLED with GROUP and OPER privileges .
C
C       T. J. Pearson,  23-Sep-1982
C-----------------------------------------------------------------------
        implicit integer (a-z)
        integer itmlst(20)
        character command*256, imagname*128, prcnam*15, terminal*7,
     1            username*12, uic*9
        include '($jpidef)'
C
C		See if there is a PID waiting
C
	l = 0
	i = lib$get_foreign(command,,l)
C
C               Set up item list for $GETJPI
C
        itmlst(1) = jpi$_grp *2**16 + 4
        itmlst(2) = %loc(grp)
        itmlst(3) = 0
        itmlst(4) = jpi$_mem *2**16 + 4
        itmlst(5) = %loc(mem)
        itmlst(6) = 0
        itmlst(7) = jpi$_terminal *2**16 + len(terminal)
        itmlst(8) = %loc(terminal)
        itmlst(9) = %loc(l_terminal)
        itmlst(10) = jpi$_username *2**16 + len(username)
        itmlst(11) = %loc(username)
        itmlst(12) = %loc(l_username)
        itmlst(13) = jpi$_prcnam *2**16 + len(prcnam)
        itmlst(14) = %loc(prcnam)
        itmlst(15) = %loc(l_prcnam)
        itmlst(16) = jpi$_imagname *2**16 + len(imagname)
        itmlst(17) = %loc(imagname)
        itmlst(18) = %loc(l_imagname)
        itmlst(19) = 0
C
C               Get an event flag
C
        call lib$get_ef(ef)
C
C               Find UIC of current user
C
        ownpid = 0
        ier = sys$getjpi(%val(ef),ownpid,,itmlst,,,)
        if (ier.ne.1) call exit(ier)
        call sys$waitfr(%val(ef))
        owngrp = grp
        ownmem = mem
C
C               Get the PID of the process to be killed
C
	if (l.ge.1) goto 20
10      call lib$get_input(command,'Process id: ',l)
20      if (l.lt.1) call exit
        if (command(1:l).eq.' ') call exit
        read (command(1:l),'(Z20)',iostat=ios) pid
	if (ios .ne. 0) then
	    call lib$put_output('PID value must be hexadecimal number')
	    goto 10
	endif
C
C               Get information about the process
C
        ier = sys$getjpi(%val(ef),pid,,itmlst,,,)
        if (ier.ne.1) then
            call sys$getmsg(%val(ier),l,command,,)
            call lib$put_output(command(1:l))
            goto 10
        end if
        call sys$waitfr(%val(ef))
        if (.not.(grp.eq.owngrp .and. mem.eq.ownmem)) then
	    call lib$put_output('You can only delete processes with your UIC')
            goto 10
        end if
        if (pid.eq.ownpid) then
            call lib$put_output('You may not delete your own process')
            goto 10
        end if
C
C               Display process and ask for confirmation
C
        write (uic,'(1H[,O3.3,1H,O3.3,1H])') grp,mem
        call lib$put_output('- Process name: '//prcnam(1:l_prcnam))
        call lib$put_output('- User name:    '//username(1:l_username))
        call lib$put_output('- UIC:          '//uic)
        call lib$put_output('- Terminal:     '//terminal(1:l_terminal))
        call lib$put_output('- Image:        '//imagname(1:l_imagname))
	call lib$get_input(command,'Is this the correct process to kill? ',l)
	if (command(1:1).ne.'y' .and. command(1:1).ne.'Y') goto 10
C
C               Send a message to the terminal (if
C               there is a terminal attached)
C
        command = char(7)//'*** Process '//prcnam(1:l_prcnam)//', '//
     1            terminal(1:l_terminal)//' aborted by KILL ***\'
        l_command = index(command,'\') - 1
        call lib$put_output(command(1:l_command))
        if (l_terminal.gt.0) then
	   call sys$brdcst(command(1:l_command),terminal(1:l_terminal),,)
        end if
C
C               Attempt to delete the process
C
        ier = sys$delprc(pid,)
        if (ier.ne.1) call exit(ier)
C
        call exit
        end