IDENTIFICATION DIVISION.
PROGRAM-ID. FORCEX.
*
* DATE-WRITTEN. April 23, 1983.
* AUTHOR. Ken Richardson.
*
* To the glory of God.
*

ENVIRONMENT DIVISION.

CONFIGURATION SECTION.

SOURCE-COMPUTER. VAX-11.
OBJECT-COMPUTER. VAX-11.

DATA DIVISION.

WORKING-STORAGE SECTION.

01  constants.
    02	system-status-codes.
	03  ss$-nomoreproc		pic s9(9) comp value external ss$-nomoreproc.
	03  ss$-accvio			pic s9(9) comp value external ss$-accvio.
	03  ss$-devalloc		pic s9(9) comp value external ss$-devalloc.
	03  ss$-devoffline		pic s9(9) comp value external ss$-devoffline.
	03  ss$-exquota			pic s9(9) comp value external ss$-exquota.
	03  ss$-illefc			pic s9(9) comp value external ss$-illefc.
	03  ss$-insfarg			pic s9(9) comp value external ss$-insfarg.
	03  ss$-insfmem			pic s9(9) comp value external ss$-insfmem.
	03  ss$-ivchan			pic s9(9) comp value external ss$-ivchan.
	03  ss$-ivdevnam		pic s9(9) comp value external ss$-ivdevnam.
	03  ss$-noiochan		pic s9(9) comp value external ss$-noiochan.
	03  ss$-nopriv			pic s9(9) comp value external ss$-nopriv.
	03  ss$-normal			pic s9(9) comp value external ss$-normal.
	03  ss$-nosuchdev		pic s9(9) comp value external ss$-nosuchdev.
	03  ss$-unasefc			pic s9(9) comp value external ss$-unasefc.
	03  ss$-abort			pic s9(9) comp value external ss$-abort.
	03  ss$-datacheck		pic s9(9) comp value external ss$-datacheck.
	03  ss$-drverr			pic s9(9) comp value external ss$-drverr.
	03  ss$-dataoverun		pic s9(9) comp value external ss$-dataoverun.
	03  ss$-parity			pic s9(9) comp value external ss$-parity.
	03  ss$-ctrlerr			pic s9(9) comp value external ss$-ctrlerr.
	03  ss$-timeout			pic s9(9) comp value external ss$-timeout.
	03  ss$-writlck			pic s9(9) comp value external ss$-writlck.
	03  ss$-nonexpr			pic s9(9) comp value external ss$-nonexpr.
    02	ws-true				pic x value "T".

01  variables.
    02  output-terminal-size		pic s9(9) comp.
    02  pid				pic s9(9) comp.
    02  ws-pid				pic s9(9) comp.
    02  ws-imagname-size		pic s9(9) comp.
    02  ws-imagname-start		pic s9(9) comp.
    02  ws-imagname-start-1		pic s9(9) comp.
    02  ws-imagname-middle		pic s9(9) comp.
    02  ws-imagname-end			pic s9(9) comp.
    02  ws-short-imagname-size		pic s9(9) comp.
    02  ws-imagname			pic x(128).
    02  ws-prcnam-size			pic s9(9) comp.

01  output-header-1.
    02  filler				pic x(7) value spaces.
    02  filler				pic x(8) value "PID".
    02  filler				pic x value space.
    02  filler				pic x(8) value "TERMINAL".
    02  filler				pic x value space.
    02  filler				pic x(12) value "USERNAME".
    02  filler				pic x value space.
    02  filler				pic x(15) value "PROCESS NAME".
    02  filler				pic x value space.
    02  filler				pic x(15) value "IMAGE".

01  output-header-2.
    02  filler				pic x(7) value spaces.
    02  filler				pic x(8) value "--------".
    02  filler				pic x value space.
    02  filler				pic x(8) value "--------".
    02  filler				pic x value space.
    02  filler				pic x(12) value "------------".
    02  filler				pic x value space.
    02  filler				pic x(15) value "---------------".
    02  filler				pic x value space.
    02  filler				pic x(15) value "---------------".

01  output-string.
    02  filler				pic x(7) value "FORCEX ".
    02  output-pid			pic x(8).
    02  filler				pic x value space.
    02  output-terminal			pic x(8).
    02  filler				pic x value space.
    02  output-username			pic x(12).
    02  filler				pic x value space.
    02  output-prcnam			pic x(15).
    02  filler				pic x value space.

01  switches.
    02  answer-sw			pic x.
    02  end-of-input-sw			pic x value "F".
    02  call-status			pic s9(9) comp.

01  itemlist.
    02  pid-record.
        03  jpi-pid-buffer-len		pic s9(04) comp value 4.
        03  jpi-pid-item-code		pic s9(04) comp value external jpi$-pid.
        03  jpi-pid-buffer-adr		usage pointer value reference ws-pid.
        03  jpi-pid-return-adr		usage pointer.
    02  terminal-record.
        03  jpi-terminal-buffer-len	pic s9(04) comp value 8.
        03  jpi-terminal-item-code	pic s9(04) comp value external jpi$-terminal.
        03  jpi-terminal-buffer-adr	usage pointer value reference output-terminal.
        03  jpi-terminal-return-adr	usage pointer value reference output-terminal-size.
    02  username-record.
        03  jpi-username-buffer-len	pic s9(04) comp value 12.
        03  jpi-username-item-code	pic s9(04) comp value external jpi$-username.
        03  jpi-username-buffer-adr	usage pointer value reference output-username.
        03  jpi-username-return-adr	pic s9(09) comp value zero.
    02  prcnam-record.
        03  jpi-prcnam-buffer-len	pic s9(04) comp value 15.
        03  jpi-prcnam-item-code	pic s9(04) comp value external jpi$-prcnam.
        03  jpi-prcnam-buffer-adr	usage pointer value reference output-prcnam.
        03  jpi-prcnam-return-adr	usage pointer value reference ws-prcnam-size.
    02  imagname-record.
        03  jpi-imagname-buffer-len	pic s9(04) comp value 128.
        03  jpi-imagname-item-code	pic s9(04) comp value external jpi$-imagname.
        03  jpi-imagname-buffer-adr	usage pointer value reference ws-imagname.
        03  jpi-imagname-return-adr	usage pointer value reference ws-imagname-size.
    02  end-record.
        03  filler			pic s9(09) comp value zero.


PROCEDURE DIVISION.

force-exit.
	perform 10000-init-program

	perform 20000-offer-forced-exit
		until	call-status = ss$-nomoreproc
			or
			end-of-input-sw = ws-true
	stop	run
	.

10000-init-program.
	move	-1	to pid

*	Get the PID for swapper
	perform 90000-call-getjpi

*	Get the PID for the first normal process
	perform 90000-call-getjpi

	display	"Use CTRL-Z to exit."
	display	""
	display output-header-1
	display output-header-2
	.

20000-offer-forced-exit.
	perform 21000-display-line

	perform 90000-call-getjpi
	.

21000-display-line.
	call	"ots$cvt-l-tz"
		using	by reference	ws-pid
			by descriptor	output-pid
			omitted
			omitted

	move	spaces	to output-terminal ( output-terminal-size + 1 : )

	move	spaces	to output-prcnam ( ws-prcnam-size + 1 : )

	if	ws-imagname-size = zero
		move	1 to ws-imagname-start
		move	zero to ws-short-imagname-size
	else
		call	"lib$locc"
			using	by descriptor	"["
				by descriptor	ws-imagname ( 1 : ws-imagname-size )
			giving	ws-imagname-start-1

		call	"lib$locc"
			using	by descriptor	"["
				by descriptor	ws-imagname ( ws-imagname-start-1 + 1 : ws-imagname-size - ws-imagname-start-1 + 1 )
			giving	ws-imagname-start

		add	ws-imagname-start-1 to ws-imagname-start

		call	"lib$locc"
			using	by descriptor	"]"
				by descriptor	ws-imagname ( ws-imagname-start : ws-imagname-size )
			giving	ws-imagname-middle

		call	"lib$locc"
			using	by descriptor	"."
				by descriptor	ws-imagname (ws-imagname-start + ws-imagname-middle : ws-imagname-size)
			giving	ws-imagname-end

		compute ws-short-imagname-size = ws-imagname-middle + ws-imagname-end - 1
	end-if

	display	output-string
		ws-imagname ( ws-imagname-start : ws-short-imagname-size )
		" [no] ?  "
		with no advancing

	move	"N" to answer-sw
	accept	answer-sw
		at end
		move	ws-true to end-of-input-sw
	end-accept

	if	end-of-input-sw not = ws-true
	then
		if	answer-sw = "Y"
			or
			answer-sw = "y"
		then
			call	"sys$forcex"
				using	by reference	ws-pid
					by value	zero
					by value	1
				giving	call-status
			perform analyze-status
		end-if
	end-if
	.


analyze-status.
	display "Status of sys$forcex:  "
		with no advancing

	evaluate call-status
		when	ss$-accvio
			display "accvio"
		when	ss$-devalloc
			display "devalloc"
		when	ss$-devoffline
			display "devoffline"
		when	ss$-exquota
			display "exquota"
		when	ss$-illefc
			display "illefc"
		when	ss$-insfarg
			display "insfarg"
		when	ss$-insfmem
			display "insfmem"
		when	ss$-ivchan
			display "ivchan"
		when	ss$-ivdevnam
			display "ivdevnam"
		when	ss$-noiochan
			display "noiochan"
		when	ss$-nopriv
			display "nopriv"
		when	ss$-normal
			display "normal"
		when	ss$-nosuchdev
			display "nosuchdev"
		when	ss$-unasefc
			display "unasefc"
		when	ss$-abort
			display	"abort"
		when	ss$-datacheck
			display "datacheck"
		when	ss$-drverr
			display "drverr"
		when	ss$-dataoverun
			display "dataoverun"
		when	ss$-parity
			display "parity"
		when	ss$-ctrlerr
			display "ctrlerr"
		when	ss$-timeout
			display "timeout"
		when	ss$-writlck
			display "writlckl"
		when	ss$-nonexpr
			display "nonexpr"
		when	other
			display	"???"
	end-evaluate
	.

90000-call-getjpi.
	move	zero to ws-imagname-size

	call	"sys$getjpiw"
		using	by value	32
			by reference	pid
			by value	zero
			by reference	itemlist
			by value	zero
			by value	zero
			by value	zero
		giving	call-status
	.