program interrupt

C+
C Version:	X1-005
C
C Facility:	General Utilities
C
C Abstract:	This program will write a message to a mailbox.
C		Designed for locally written detached processors that use
C		a standard communication interface.
C
C Environment:	VMS V5.0 and later.
C
C	module interrupt_cld
C
C	define verb interrupt
C		qualifier vanilla, nonnegatable
C		qualifier nodefault, nonnegatable
C		qualifier noprefix, nonnegatable
C		parameter p1, label=utility, prompt="whom"
C				,value (required)
C		parameter p2, label=message, prompt="message"
C				,value (required, type=$rest_of_line)
C
C History:
C
C	14-Dec-1989, DBS; Version X1-001
C 001 -	Original version.
C	07-Feb-1990, DBS; Version X1-002
C 002 -	Catch a ^Z on the get_foreign prompt and don't let cli ask again.
C	26-Feb-1990, DBS; Version X1-003
C 003 -	Fix missing argument to lib$signal() call.
C	12-Jul-1990, DBS; Version X1-004
C 004 -	Prefixed the message with a char(130) to make it more difficult to
C	send bogus messages.
C	03-Nov-1993, DBS; Version X1-005
C 005 -	Added a /noprefix qualifier for use with other detached processes
C	and added /vanilla to imply /nodefault and /noprefix (saves typing).
C-

 	implicit none

	include '($CLIDEF)/nolist'
	include '($IODEF)/nolist'
	include '($RMSDEF)/nolist'

C External references

	integer*4	cli$dcl_parse
	external	cli$dcl_parse
	integer*4	cli$get_value
	external	cli$get_value
	integer*4	cli$present
	external	cli$present
	external	interrupt_cld
	external	intrupt__nomailbox
	external	intrupt__notdeliv
	external	intrupt__success
	integer*4	lib$get_foreign
	external	lib$get_foreign
	external	lib$get_input
	external	lib$put_output
	external	lib$signal
	external	str_collapse
	integer*4	str_len
	external	str_len
	external	str_uppercase
	integer*4	sys$assign
	external	sys$assign
	integer*4	sys$qiow
	external	sys$qiow

C Type declarations for variables

	integer*4	do, nothing
	integer*4	istatus
	integer*2	mbx_channel
	character	mbx_name*256
	integer*4	mbx_name_len
	integer*4	mbx_status
	character	mbx_suffix*(*)
	parameter	(mbx_suffix = '_MAILBOX')
	integer*2	qio_iosb(4)

	integer*4	cli_status
	character	cli_c_verb*9		/'INTERRUPT'/
	character	cli_c_prompt*7		/'_whom: '/
	character	cli_t_command*256
	integer*4	cli_s_command
	integer*4	cli_nodefault
	character	cli_c_nodefault*9	/'NODEFAULT'/
	integer*4	cli_noprefix
	character	cli_c_noprefix*8	/'NOPREFIX'/
	integer*4	cli_vanilla
	character	cli_c_vanilla*7		/'VANILLA'/
	character	cli_c_utility*7		/'UTILITY'/
	integer*2	cli_s_utility
	character	cli_t_utility*80
	character	cli_c_message*7		/'MESSAGE'/
	integer*2	cli_s_message
	character	cli_t_message*256

C+
C Mainline
C-

	istatus = lib$get_foreign (cli_t_command, cli_c_prompt, cli_s_command)

	if (istatus .eq. rms$_eof) then
		do = nothing
	else
	cli_t_command = cli_c_verb//' '//cli_t_command
	cli_s_command = cli_s_command + len(cli_c_verb) + 1

	call cli$dcl_parse (cli_t_command, interrupt_cld
	1			,lib$get_input, lib$get_input
	1			,cli_c_prompt)

	cli_nodefault = cli$present (cli_c_nodefault)
	cli_noprefix  = cli$present (cli_c_noprefix)
	cli_vanilla   = cli$present (cli_c_vanilla)

	if (cli_vanilla) then
		cli_nodefault = cli_vanilla
		cli_noprefix  = cli_vanilla
	endif !(cli_vanilla) then

	call cli$get_value (cli_c_utility, cli_t_utility, cli_s_utility)

	if (cli_s_utility .eq. 0) then
		do = nothing
	else
	call cli$get_value (cli_c_message, cli_t_message, cli_s_message)

	if (cli_s_message .eq. 0) then
		do = nothing
	else
	if (cli_nodefault) then
		mbx_name = cli_t_utility(1:cli_s_utility)
	else
	mbx_name = cli_t_utility(1:cli_s_utility)//mbx_suffix
	endif !(cli_nodefault) then

	call str_collapse (mbx_name, mbx_name)
	call str_uppercase (mbx_name)

	mbx_name_len = str_len (mbx_name)

	mbx_status = sys$assign (%descr(mbx_name(1:mbx_name_len))
	1			,%ref(mbx_channel),,)

	if (.not. mbx_status) then
		call lib$signal (intrupt__nomailbox
	1			,%val(1), %descr(mbx_name(1:mbx_name_len))
	1			,%val(mbx_status))
	else
	if (cli_s_message .ne. 0) then
		if (.not. cli_noprefix) then
		  cli_t_message = char(130)//cli_t_message(1:cli_s_message)
		  cli_s_message = cli_s_message + 1
		endif !(.not. cli_noprefix) then
		mbx_status = sys$qiow (,%val(mbx_channel)
	1				,%val(io$_writevblk .or. io$m_now)
	1				,%ref(qio_iosb(1)),,
	1				,%ref(cli_t_message)
	1				,%val(cli_s_message),,,,)
		if (.not. mbx_status) then
			call lib$signal (intrupt__notdeliv
	1				,%val(0)
	1				,%val(mbx_status))
		else
		call lib$signal (intrupt__success
	1			,%val(1), %descr(mbx_name(1:mbx_name_len)))
		endif !(.not. mbx_status) then
	endif !(cli_s_message .ne. 0) then
	endif !(.not. mbx_status) then
	endif !(cli_s_message .eq. 0) then
	endif !(cli_s_utility .eq. 0) then
	endif !(istatus .eq. rms$_eof) then

	end