PROGRAM SEND_MESSAGE
C
C	Program SEND_MESSAGE
C SYSTEM:     VAX/VMS v 2.1
C FACILITY:   general utility program
C LANGUAGE:   FLECS & VAX/VMS FORTRAN
C AUTHOR:     Rick Floyd
C DATE:       2-Jan-80
C Note:  MAJOR Changes by M. Edward (Ted) Nieland to update to
C	 VMS V4.x and added new features.  Totally coverted to
C	 VAX/VMS FORTRAN at that time.
C;-
C
C****PURPOSE: SEND allows a user to send a message to another terminal.
C
C****RESTRICTIONS:  Must be installed with OPER privilege. Although SEND
C		will recognize terminals on remote systems, an attempt
C		to send a message to a remote terminal will, under VAX/VMS
C		v 2.1, result in an error.
C
C****CALLING SEQUENCE:  
C		Define the symbol
C			SEND:==$USER$EXE:SEND
C		and then use as
C			SEND terminal_id message
C		e.g.,
C			SEND TTB6: Are you done?
C		If the message contains special characters, it should
C		be enclosed in quotes ("). If the terminal_id and message are
C		omitted, they will be prompted for.
C
C****ERROR MESSAGES: Error messges are produced using SYS$PUTMSG and
C		have the form
C			%SEND-c-abbreviation-message text
C
C****RESOURCES:
C	LIBRARIES:   none
C	OTHER SUBR:  all in this module.
C	DATA CHANNELS: SYS$INPUT for input and SYS$OUTPUT for prompting. The
C			message is output on the specified terminal.
C	DISK FILES:  none
C	DEVICES:     as above
C	SGAS:        none
C	EVENT FLAGS: none
C	SYSTEM DIR:  LIB$GET_FOREIGN, SYS$TRNLOG, SYS$BRDCST,
C		SYS$GETDEV, SYS$GETJPI, LIB$GET_INPUT, LIB$PUT_OUTPUT,
C		SYS$PUTMSG, LIB$INSV
C
C****NOTES:  
C	1.  As mentioned above, SEND will accept a  specification
C	    for a terminal on a remote node, but the send will fail
C	    because SYS$BRDCST will not broadcast to a terminal on a
C	    remote node (at least if it is a non-VMS node).
C	    I don't know if DEC will expand SYS$BRDCST to
C	    do this, but in case they do...
C	2.  The terminal_id must specify an actual physical terminal. The
C	    colon is optional(NO LONGER AFTER UPDATE 8/26/85).
C;-
C	Updates:
C		10/17/85 Updated to VMS V 4.x using SYS$BRKTHRU and 
C			to use broadcast class USER1.  Also allowed to
C			use usernames in addition to terminal IDs.  Also
C			allow username/terminal ID and message to be read 
C			in with command line using LIB$GET_FOREIGN.  
C			Changed SYS$TRNLOG to SYS$TRNLNM.  Allow a list
C			destinations to be entered, separated by commas.
C
C			Updated to allow choice of having message sent
C			by MAIL if Username was specified and message 
C			could not be sent by SYS$BREAKTHRU.  Qualifier
C			/NOMAIL will prevent this option.
C
C		Changes by Ted Nieland
C
C		1/14/91 Updated to use Callable MAIL instead of DECnet Hack
C			Plus minor bug fixes.
C
C		Change by Ted Nieland
C
C		11/12/92 Fixed calls to GETJPI and TRNLNM to use Item List
C			structures.  Previous code would not work 
C			on a OpenVMS AXP system.
C
C		Change by Ted Nieland
C
C	To set up command use:
C
C		$ Send :== $ {disk}:[{directory}]SEND.EXE
C
C	This executable needs to be installed with OPER, WORLD privledges to 
C       be used by all system users.
C
	IMPLICIT NONE
	CHARACTER MESSAGE*2000,WHO*25,INPUT*9,TRAN*255,FROM*50
	CHARACTER*100 TEXT(20),EXTERNAL*100,WHOLIST
	CHARACTER TIMEBUF*8, BELL/7/
	CHARACTER*256 ERROR,NODE
	INTEGER*2 DONOTMAIL,IOSB(4)
	CHARACTER USERBUF*15,NOMAIL*6,RESP*3,DCL_CMD*59
	INTEGER*4 SEND_TYPE,STATUS,FLAGS
	INTEGER*4 TEXTLEN(20),LEN0,CONTEXT,LENUSER
	INTEGER SYS$BRKTHRUW,SYS$TRNLNM,SYS$GETJPI,SYS$GETMSG,
	1	LIB$GET_FOREIGN
	INTEGER MAIL$SEND_BEGIN,MAIL$SEND_ADD_ADDRESS,
	1	MAIL$SEND_ADD_ATTRIBUTE, MAIL$SEND_ADD_BODYPART,
	1	MAIL$SEND_END,MAIL$SEND_MESSAGE,MAIL$SEND_ABORT,
	1	MAIL$USER_BEGIN,MAIL$USER_END,MAIL$USER_GET_INFO
	INTEGER I,J,K,LENQ,ISP,LENG,LENL,LOC,ICOMMA,ISTART,LEN1,
	1	JJ,I2,ILEN,LEN2,ZERO1,LENGTH
	CHARACTER*30 SUBJECT_LINE
	DATA SUBJECT_LINE/' Message from the SEND Utility'/
	DATA INPUT/'SYS$INPUT'/,NOMAIL/'NOMAIL'/
      STRUCTURE  /ITMLST/
       UNION
        MAP
         INTEGER*2  BUFLEN , ITMCOD
         INTEGER*4  BUFADR , RETADR
        END MAP
        MAP
         INTEGER*4  END_LIST
        END MAP
       END UNION
      END STRUCTURE
C
      RECORD /ITMLST/ IN_ITM_LST(2), OUT_ITM_LST(2), Gen_ITM_LST(2)

	INCLUDE '($JPIDEF)/NOLIST'
	INCLUDE '($BRKDEF)/NOLIST'
	INCLUDE '($LNMDEF)/NOLIST'
	INCLUDE '($MAILDEF)/NOLIST'
	INCLUDE '($SSDEF)/NOLIST'
C
C	Get remainder of command line
C
	STATUS = LIB$GET_FOREIGN(EXTERNAL,,LEN0,)
C
C	If length is zero, then no additional input was given.
C
	IF (LEN0.NE.0) THEN
		I = 1
		DO WHILE (EXTERNAL(I:I).EQ.' ') ! Skip beginning blanks
			I = I + 1
		IF (I.GT.LEN0) GO TO 20
		ENDDO
C
C	Check for Qualifier /MAIL or /NOMAIL
C
		DONOTMAIL = 0
		IF (EXTERNAL(I:I).EQ.'/') THEN
		I = I + 1
		J = I
		DO WHILE ((EXTERNAL(I:I).NE.' ').AND.(I.LT.LEN0))
			I = I + 1
		ENDDO
		K = I-1
		LENQ = K-J+1
		CALL STR$UPCASE(EXTERNAL(J:I),EXTERNAL(J:I))
C		TYPE *, EXTERNAL(J:I)
		DONOTMAIL = 0
		IF ((LENQ.GT.3).AND.(EXTERNAL(J:K).EQ.NOMAIL(1:LENQ)))THEN
			DONOTMAIL = 1
		ELSEIF ((LENQ.GT.2).AND.(EXTERNAL(J:K).EQ.
	1		NOMAIL(3:LENQ+2))) THEN
			DONOTMAIL = -1
		ELSE
			TYPE 5000
5000	FORMAT(' Improper Qualifier - - Ignored')
		ENDIF
C	TYPE *, 'DONOTMAIL = ',DONOTMAIL
		DO WHILE (EXTERNAL(I:I).EQ.' ') ! Skip beginning blanks
			I = I + 1
		IF (I.GT.LEN0) GO TO 20
		ENDDO
		ENDIF
C
C	Find end of first parameter (USERNAME or Terminal ID)
C
		ISP = INDEX(EXTERNAL(I:LEN0),' ') 
		IF (ISP.EQ.0) ISP = LEN0 - I + 1
		LENG = ISP
		WHOLIST(1:LENG) = EXTERNAL(I:I+ISP) ! Set who message is to go to
		LENL = LENG
C
C	The rest of the line will be the message.
C
		LENG = LEN0 - (ISP+I) + 1
		IF (LENG.LE.0) GO TO 40  ! No additional input, prompt for it.
		TEXT(2)(1:LENG) = EXTERNAL(I+ISP:LEN0)
		TEXTLEN(2) = LENG
		J = 2
		GO TO 100
	ENDIF
20	TYPE 5020
5020	FORMAT(' Terminal ID must contain a colon(:), i.e. TTxx:'/
	1	' Terminal IDs OR Usernames? ',$)
	READ(5,5040,END=320) LENL,WHOLIST
5040	FORMAT(Q,A)
	IF(LENL.EQ.0) THEN
			TYPE 5060
5060			FORMAT(' Please specify a terminal or username')
			GO TO 20
	ENDIF
	CALL STR$UPCASE(WHOLIST,WHOLIST)
40  	TYPE 5080
5080	FORMAT(' Enter message - maximum 19 lines, (end with ctrl-Z)')
	J=2
60	READ(5,5100,END=80) TEXTLEN(J),TEXT(J)
	J=J+1
	IF (J.LE.20) GO TO 60
80	J=J-1
5100	FORMAT(Q,A)
C
C	Find out which terminal is now in use
C
100	GEN_ITM_LST(1).ITMCOD = LNM$_STRING
	GEN_ITM_LST(1).BUFLEN = 255
	GEN_ITM_LST(1).BUFADR = %LOC(TRAN)
	GEN_ITM_LST(1).RETADR = %LOC(LENGTH)

	GEN_ITM_LST(2).END_LIST = 0

	STATUS = SYS$TRNLNM (LNM$M_CASE_BLIND,'LNM$PROCESS_TABLE',
	1	INPUT,,GEN_ITM_LST)
	IF(.NOT.STATUS) GO TO 160
	K=INDEX(TRAN,'_')
C
C	Find out process name and other process information and build the
C       Header for the message.
C

	GEN_ITM_LST(1).ITMCOD = JPI$_USERNAME
	GEN_ITM_LST(1).BUFLEN = 15
	GEN_ITM_LST(1).BUFADR = %LOC(USERBUF)
	GEN_ITM_LST(1).RETADR = %LOC(LENUSER)

	GEN_ITM_LST(2).END_LIST = 0


	STATUS=SYS$GETJPI(,,,GEN_ITM_LST,,,)
	IF(.NOT.STATUS) GO TO 160
	LOC=LENGTH-K+1
	TEXT(1)(1:1)=' '
	TEXT(1)(2:7)=' From '
	TEXT(1)(8:LOC+8)=TRAN(K:LENGTH) !Terminal name
	TEXT(1)(LOC+9:LOC+9)=BELL  ! Ring Bell
	TEXT(1)(LOC+10:LOC+26)='  '//USERBUF ! Process name
	CALL TIME(TIMEBUF)
	TEXT(1)(LOC+27:LOC+38)='    '//TIMEBUF  ! Time
	TEXT(1)(LOC+39:LOC+39)= CHAR(13)
	TEXT(1)(LOC+40:LOC+40)= CHAR(10)
	TEXTLEN(1) = LOC+40
C
C	Break up destination list into seperate destinations and 
C	SEND to each one.  Loop until completed
C
	ICOMMA = 0
	DO WHILE (ICOMMA.LT.LENL)
		ISTART = ICOMMA + 1
		ICOMMA = INDEX(WHOLIST(ISTART:LENL),',')
	IF (ICOMMA.EQ.0) THEN 
		ICOMMA = LENL +1
	ELSE
		ICOMMA = ICOMMA + ISTART - 1
	ENDIF
	LEN1 = ICOMMA-ISTART
	WHO = WHOLIST(ISTART:ICOMMA-1)
C
C	If the first destination has a colon with it, assume it is a 
C	terminal and not a username and set the appropriate BRKTHRU flag
C
	IF (INDEX(WHO,'::').NE.0) THEN
		TYPE 110, WHO(1:LEN1)
110	FORMAT (' Destination:  ',A<LEN1>,' contains a nodename. '/
	1	' Message cannot be sent to a terminal.')
		GO TO 200
	ELSEIF (INDEX(WHO,':').EQ.0) THEN
		SEND_TYPE = BRK$C_USERNAME
		FLAGS = BRK$M_CLUSTER
	ELSE
		SEND_TYPE = BRK$C_DEVICE
		FLAGS = 0
	ENDIF
C
C	Place carriage control on the message 
C
	DO 120 JJ=2,J
	IF (TEXTLEN(JJ).NE.0) THEN
		TEXT(JJ)((TEXTLEN(JJ)+1):(TEXTLEN(JJ)+1)) = CHAR(13)
		TEXT(JJ)((TEXTLEN(JJ)+2):(TEXTLEN(JJ)+2)) = CHAR(10)
		TEXTLEN(JJ) = TEXTLEN(JJ) + 2
	ENDIF
120	CONTINUE
	I2 = 1
	DO 121 JJ=1,J
	IF (TEXTLEN(JJ).NE.0) THEN
		MESSAGE(ILEN:ILEN+TEXTLEN(JJ)) = TEXT(JJ)(1:TEXTLEN(JJ))
		ILEN = ILEN+TEXTLEN(JJ)+1
	ENDIF
121	CONTINUE
C
C	Send the message
C
	LEN2 = ILEN
	STATUS=SYS$BRKTHRUW(,MESSAGE(1:LEN2),WHO(1:LEN1),
	1	%VAL(SEND_TYPE),IOSB,%VAL(32),
	1	%VAL(FLAGS),%VAL(BRK$C_USER1),,,)
	IF (((.NOT.STATUS).OR.(IOSB(1).NE.1)).AND.(IOSB(2).EQ.0))GO TO 160
	IF ((IOSB(3)+IOSB(4)).NE.0) GO TO 140
	GO TO 300
C
C	If an error occured, get the proper error message
C
140	TYPE 5120, WHO(1:LEN1),IOSB(2),IOSB(3)+IOSB(4)
5120	FORMAT(' Message to be sent to ',A<LEN1>/
	1	' Message sent to ',I2,' terminal(s).'/
	1	' Message NOT sent to ',I2,' terminal(s).')
	GO TO 180
160	IF (STATUS) STATUS = IOSB(1)
	IF (STATUS.NE.1) THEN
	  JJ= SYS$GETMSG(%VAL(STATUS),LENGTH,ERROR,%VAL(1),)
	  TYPE 5140,ERROR(1:LENGTH),WHO(1:LEN1)
5140	FORMAT(' SEND failed -- error was ',A<LENGTH>/
	1	' Message was not sent to ',A<LEN1>)
	  GOTO 320
	ENDIF
180	IF (SEND_TYPE.EQ.BRK$C_USERNAME) THEN
200		IF (DONOTMAIL.EQ.0) THEN
		TYPE 5160
5160	FORMAT(' Do you wish this message sent by VAX MAIL? (Y/N)'$)
220 		READ(5,5180,ERR=240,END=300) RESP
5180	FORMAT(A3)
C
C     Affirmative responses
C
	IF(RESP.EQ.'Y'.OR.RESP.EQ.'y'.OR.RESP.EQ.'OK') GO TO  260
	IF(RESP.EQ.'YES'.OR.RESP.EQ.'yes'.OR.RESP.EQ.'ok') GO TO 260
	IF(RESP.EQ.'YE'.OR.RESP.EQ.'ye') GO TO 260
C
C     Negative responses
C
	IF(RESP.EQ.'N'.OR.RESP.EQ.'n') GO TO 300
	IF(RESP.EQ.'NO'.OR.RESP.EQ.'no') GO TO 300
C
C	Invalid response
C
240 	TYPE 5200,RESP
5200	FORMAT(' ',A3,' is an invalid response.  Reenter? ',$)
	GO TO 220
	ELSEIF (DONOTMAIL.EQ.-1) THEN

260	IN_ITM_LST(1).END_LIST = 0
	OUT_ITM_LST(1).END_LIST = 0

	STATUS = MAIL$USER_BEGIN(CONTEXT,IN_ITM_LST,OUT_ITM_LST)
	IF (STATUS.NE.SS$_NORMAL) CALL LIB$SIGNAL(%VAL(STATUS))

	IN_ITM_LST(1).ITMCOD =MAIL$_USER_USERNAME
	IN_ITM_LST(1).BUFLEN = LEN1
	IN_ITM_LST(1).BUFADR = %LOC(WHO)

	IN_ITM_LST(2).END_LIST = 0


	STATUS = MAIL$USER_GET_INFO(CONTEXT,IN_ITM_LST,OUT_ITM_LST)
	IF (STATUS.NE.SS$_NORMAL) THEN
		IN_ITM_LST(1).END_LIST = 0
		OUT_ITM_LST(1).END_LIST = 0
		STATUS = MAIL$USER_END(CONTEXT,IN_ITM_LST,OUT_ITM_LST)
		IF (STATUS.NE.SS$_NORMAL) CALL LIB$SIGNAL(%VAL(STATUS))
		GOTO 300
	ENDIF

	IN_ITM_LST(1).END_LIST = 0
	OUT_ITM_LST(1).END_LIST = 0
	STATUS = MAIL$USER_END(CONTEXT,IN_ITM_LST,OUT_ITM_LST)
	IF (STATUS.NE.SS$_NORMAL) CALL LIB$SIGNAL(%VAL(STATUS))

	IN_ITM_LST(1).END_LIST = 0
	OUT_ITM_LST(1).END_LIST = 0
	STATUS = MAIL$SEND_BEGIN(CONTEXT,IN_ITM_LST,OUT_ITM_LST)

	IF (STATUS.NE.SS$_NORMAL) CALL LIB$SIGNAL(%VAL(STATUS))

	IN_ITM_LST(1).ITMCOD = MAIL$_SEND_USERNAME
	IN_ITM_LST(1).BUFLEN = LEN1
	IN_ITM_LST(1).BUFADR = %LOC(WHO)

	IN_ITM_LST(2).END_LIST = 0


	STATUS = MAIL$SEND_ADD_ADDRESS(CONTEXT, IN_ITM_LST, OUT_ITM_LST)
	IF (STATUS.NE.SS$_NORMAL) CALL LIB$SIGNAL(%VAL(STATUS))

	IN_ITM_LST(1).ITMCOD = MAIL$_SEND_SUBJECT
	IN_ITM_LST(1).BUFLEN = 30
	IN_ITM_LST(1).BUFADR = %LOC(SUBJECT_LINE)


	STATUS = MAIL$SEND_ADD_ATTRIBUTE(CONTEXT, IN_ITM_LST, OUT_ITM_LST)
	IF (STATUS.NE.SS$_NORMAL) CALL LIB$SIGNAL(%VAL(STATUS))


	DO JJ =1,J

	IF (TEXTLEN(JJ).NE.0) THEN
	  IN_ITM_LST(1).ITMCOD = MAIL$_SEND_RECORD
 	  IN_ITM_LST(1).BUFLEN = TEXTLEN(JJ)
	  IN_ITM_LST(1).BUFADR = %LOC(TEXT(JJ))


	  STATUS = MAIL$SEND_ADD_BODYPART(CONTEXT, IN_ITM_LST, OUT_ITM_LST)
	  IF (STATUS.NE.SS$_NORMAL) CALL LIB$SIGNAL(%VAL(STATUS))

	ENDIF
	ENDDO

	IN_ITM_LST(1).END_LIST = 0


	STATUS = MAIL$SEND_MESSAGE(CONTEXT, IN_ITM_LST, OUT_ITM_LST)
	IF (STATUS.NE.SS$_NORMAL) CALL LIB$SIGNAL(%VAL(STATUS))
 

	STATUS = MAIL$SEND_END(CONTEXT, IN_ITM_LST, OUT_ITM_LST)
	IF (STATUS.NE.SS$_NORMAL) CALL LIB$SIGNAL(%VAL(STATUS))

	ENDIF
	ENDIF
300	ENDDO
320 	END