%TITLE	'HG_SEND_MAIL'
MODULE HG_SEND_MAIL (IDENT = '01-001') = 
BEGIN
!
!  Copyright 1991 by Hunter Goatley.  This code may be freely distributed
!  and modified for non-commercial purposes as long as this copyright notice
!  is retained.
!
!++
!
!  Facility:	HG_SEND_MAIL
!
!  Abstract:
!
!	This module contains a routine to send a mail message to a list
!	of users.  Either a one-line mail message or a file can be specified.
!	It uses the callable VMS MAIL interface.
!
!  Environment:
!
!	User-mode.
!
!  Author:	Hunter Goatley
!		Academic Computing, STH 226
!		Western Kentucky University
!		Bowling Green, KY 42101
!		E-mail: goathunter@WKUVX1.BITNET
!		Voice:  (502) 745-5251
!
!  Date:	July 18, 1991
!
!  Modified by:
!
!	01-001		Hunter Goatley		21-JUL-1991 12:27
!		Added define_sys_scratch to ensure that SYS$SCRATCH is
!		defined (it's not automatically defined for detached
!		processes).
!
!	01-000		Hunter Goatley		18-JUL-1991 16:15
!		Original version.
!
!--
!
!  LIBRARIES
!
LIBRARY 'SYS$LIBRARY:LIB';				!Pull stuff from LIB
SWITCHES ADDRESSING_MODE (EXTERNAL = GENERAL, NONEXTERNAL = WORD_RELATIVE);

LINKAGE
	local_jsb	= JSB (REGISTER = 0);
!
!  TABLE OF CONTENTS
!
FORWARD ROUTINE
	hg_send_mail,				!Send mail to list of users
	mail_handler,				!MAIL$ condition handler
	define_sys_scratch : local_jsb		!Define SYS$SCRATCH logical
	;
!
!  EXTERNAL REFERENCES
!
EXTERNAL
	LIB$_WRONUMARG;				!Status: wrong number of args

EXTERNAL ROUTINE
	MAIL$SEND_BEGIN,			!MAIL$SEND initialization
	MAIL$SEND_ADD_ADDRESS,			!Add user to recipient list
	MAIL$SEND_ADD_ATTRIBUTE,		!Add from, to, subject lines
	MAIL$SEND_ADD_BODYPART,			!Add body of message
	MAIL$SEND_MESSAGE,			!Send the message
	MAIL$SEND_END				!End sending
	;

!
!  MACROS
!
MACRO
	errchk(status) =			!Error check
		IF NOT(.status) THEN RETURN (.status)%,

	$STATICDESC (len, addr) =		!Static descriptor declaration
		$BBLOCK[DSC$C_S_BLN]
		PRESET	([DSC$W_LENGTH] = len,
			 [DSC$B_DTYPE]	= DSC$K_DTYPE_T,
			 [DSC$B_CLASS]	= DSC$K_CLASS_S,
			 [DSC$A_POINTER]= addr)
	%;

%SBTTL	'HG_SEND_MAIL'
GLOBAL ROUTINE hg_send_mail (users_a, msg_a, from_user_a, subject_a,
				personal_name_a, scratch_a, flags) =
BEGIN
!+
!
!  Routine:	SEND_MAIL
!
!  Functional description:
!
!	This routine sends a mail message to a list of users.
!
!  Calling sequence:
!
!	status = hg_send_mail (recipients, message [,from_user] [,subject]
!				[,personal_name] [,scratch] [,flags]);
!
!  Formal parameters:
!
!	users_a		- Address of descriptor for comma-separated list of
!			  recipients.
!	msg_a		- Address of descriptor for the message text or
!			  filename to mail.
!	from_user_a	- Address of descriptor for "From:" name.  Optional.
!	subject_a	- Address of descriptor for "Subj:" line.  Optional.
!	personal_name_a	- Address of descriptor for personal name.  Optional.
!	scratch_a	- Address of descriptor for SYS$SCRATCH equivalence.
!			  Optional.
!	flags		- Longword containing mail flags.  By value.  Optional.
!			  The following descriptions are true of the bit is on:
!				Bit 0	- msg_a is a file name
!				Bit 1	- ignore invalid addresses
!
!  Returns:
!
!	R0		- Status (LIB$_WRONUMARG, status from MAIL$ routines)
!
!-
BIND
	users		= .users_a		: $BBLOCK,
	msg		= .msg_a		: $BBLOCK,
	from_user	= .from_user_a		: $BBLOCK,
	subject		= .subject_a		: $BBLOCK,
	personal_name	= .personal_name_a	: $BBLOCK,
	scratch		= .scratch_a		: $BBLOCK;

BIND
	fao_personal	= %ASCID'!!20<!!AD!!AS!!> "!AD"',	!With personal
	fao_no_personal	= %ASCID'!AD!AS';			!Without

MACRO
	sm_v_file	= 0,1,0%,
	sm_v_ignoreinv	= 1,1,0%;

LOCAL
	null_itmlst		: UNSIGNED LONG INITIAL(0),
	send_context		: UNSIGNED LONG INITIAL(0),
	send_begin_itmlst	: $ITMLST_DECL(ITEMS=1),
	send_to_itmlst		: $ITMLST_DECL(ITEMS=1),
	send_body_itmlst	: $ITMLST_DECL(ITEMS=1),
	send_attribute_itmlst	: $ITMLST_DECL(ITEMS=3),
	trnlnm_itmlst		: $ITMLST_DECL(ITEMS=1),
	trnlnm_buffer		: $BBLOCK[LNM$C_NAMLENGTH],
	trnlnm_length		: UNSIGNED LONG INITIAL(0),
	fao_from_format_buff	: $BBLOCK[256],
	fao_from_format		: $STATICDESC (256, fao_from_format_buff),
	from_line_buffer	: $BBLOCK[256],
	from_line		: $STATICDESC (256, from_line_buffer),
	username		: $STATICDESC (0, 0),
	users_len		: UNSIGNED LONG,
	users_ptr		: REF $BBLOCK,
	itmlst_ptr		: REF $BBLOCK;

BUILTIN
	ACTUALCOUNT;		!Number of parameters passed

REGISTER
	temp			: UNSIGNED LONG,
	user_flags		: UNSIGNED LONG INITIAL(0),
	status			: UNSIGNED LONG;

  !
  !  Establish a condition handler to keep the MAIL$ routines from signalling
  !  their errors.
  !
  ENABLE mail_handler;

  IF (ACTUALCOUNT() LSSU 2) OR			!If the number of arguments
     (ACTUALCOUNT() GTRU 7)			!... is invalid, return an
  THEN						!... error
      RETURN (LIB$_WRONUMARG);

  status = define_sys_scratch ((IF (ACTUALCOUNT() GEQU 6)
				THEN
				   scratch
				ELSE
				   0));
  errchk(status);				!Return any errors

  IF (ACTUALCOUNT() EQLU 7)			!Did caller specify user flags?
  THEN						!If so, grab them.  If not,
     user_flags = .flags;			!... just leave as default (0)

  !
  !  Handle the personal name, if the caller specified one.
  !
  itmlst_ptr = send_begin_itmlst;		!Point to MAIL$SEND_BEGIN itmlst
  IF (ACTUALCOUNT() GEQU 5) AND			!If personal name was given
     (personal_name NEQU 0) AND			!... and it's not 0 or 0
     (.personal_name[DSC$W_LENGTH] GTRU 0)	!... length, then process it
  THEN
     BEGIN
     itmlst_ptr[ITM$W_ITMCOD] = MAIL$_SEND_PERS_NAME;	!Set item code in list
     temp = (IF (.personal_name[DSC$W_LENGTH] GTRU 127)	!Ensure that the length
	     THEN					!... is no more than
		127					!... 127 bytes
	     ELSE
		.personal_name[DSC$W_LENGTH]
	     );
     itmlst_ptr[ITM$W_BUFSIZ] = .temp;		!Set the buffer size and addr
     itmlst_ptr[ITM$L_BUFADR] = .personal_name[DSC$A_POINTER];
     itmlst_ptr[ITM$L_RETLEN] = 0;		!No return length
     itmlst_ptr = .itmlst_ptr + ITM$S_ITEM;	!Bump item list pointer
     !
     !  Format the $FAO format string in case we have to generate the "From:"
     !  line.
     !
     status = $FAO (fao_personal, fao_from_format, fao_from_format,
			.temp, .personal_name[DSC$A_POINTER]);
     END
  ELSE
     !
     !  No personal name was given.  Set up the $FAO format address to leave
     !  it out.
     !
     BEGIN
     fao_from_format[DSC$W_LENGTH] = .fao_no_personal<0,16,0>;
     fao_from_format[DSC$A_POINTER] = .(fao_no_personal + 4);
     END;

  itmlst_ptr[0,0,32,0] = 0;			!Signal end of item list

  !
  !  Set up the attributes item list.  This includes the from, to, and subject
  !  lines, if specified.
  !
  !  Just copy the list of recipients as the "To:" line.  Don't worry
  !  about whether or not it's right.
  !
  itmlst_ptr = send_attribute_itmlst;
  itmlst_ptr[ITM$W_ITMCOD] = MAIL$_SEND_TO_LINE;
  itmlst_ptr[ITM$W_BUFSIZ] = .users[DSC$W_LENGTH];
  itmlst_ptr[ITM$L_BUFADR] = .users[DSC$A_POINTER];
  itmlst_ptr[ITM$L_RETLEN] = 0;
  itmlst_ptr = .itmlst_ptr + ITM$S_ITEM;

  !
  !  If the caller specified a "From:" name, then format the "From:" line.
  !  We have to include the DECnet node name, if it exists, and the personal
  !  name.  The fao_from_format descriptor points to one of two FAO format
  !  strings---one with the personal name and the other without.
  !
  IF (ACTUALCOUNT() GEQU 3) AND
     (from_user NEQU 0)     AND
     (.from_user[DSC$W_LENGTH] NEQU 0)
  THEN
     BEGIN
     itmlst_ptr[ITM$W_ITMCOD] = MAIL$_SEND_FROM_LINE;
     !
     !  Translate SYS$NODE to get the DECnet node name.
     !
     $ITMLST_INIT (ITMLST = trnlnm_itmlst,
	(ITMCOD = LNM$_STRING,
	 BUFSIZ = LNM$C_NAMLENGTH,
	 BUFADR = trnlnm_buffer,
	 RETLEN = trnlnm_length));
     status = $TRNLNM ( TABNAM	= %ASCID'LNM$SYSTEM_TABLE',
			LOGNAM	= %ASCID'SYS$NODE',
			ITMLST	= trnlnm_itmlst);
     !
     !  Now format the "From:" line.  Ignore any errors from $TRNLNM, since
     !  the trnlnm_length will still be 0 and no node will be inserted if
     !  the logical wasn't defined.
     !
     status = $FAO (fao_from_format, from_line, from_line,
			.trnlnm_length, trnlnm_buffer, from_user);
     itmlst_ptr[ITM$W_BUFSIZ] = .from_line[DSC$W_LENGTH];
     itmlst_ptr[ITM$L_BUFADR] = .from_line[DSC$A_POINTER];
     itmlst_ptr[ITM$L_RETLEN] = 0;
     itmlst_ptr = .itmlst_ptr + ITM$S_ITEM;
     END;
  !
  !  Process the subject line, if it was given.
  !
  IF (ACTUALCOUNT() GEQU 4) AND
     (subject NEQU 0)	    AND
     (.subject[DSC$W_LENGTH] NEQU 0)
  THEN
     BEGIN
     itmlst_ptr[ITM$W_ITMCOD] = MAIL$_SEND_SUBJECT;
     itmlst_ptr[ITM$W_BUFSIZ] = .subject[DSC$W_LENGTH];
     itmlst_ptr[ITM$L_BUFADR] = .subject[DSC$A_POINTER];
     itmlst_ptr[ITM$L_RETLEN] = 0;
     itmlst_ptr = .itmlst_ptr + ITM$S_ITEM;
     END;
  itmlst_ptr[0,0,32,0] = 0;			!End of item list

  !
  !  Now set up the MAIL$SEND_BODY item list with either a file name or
  !  a one-line message.
  !
  $ITMLST_INIT (ITMLST = send_body_itmlst,
	(ITMCOD = (IF (.user_flags<sm_v_file>)		!Is msg a filename?
		   THEN					!If so, set item code to
			MAIL$_SEND_FILENAME		!... SEND_FILENAME
		   ELSE
			MAIL$_SEND_RECORD),		!Else, just one record
	 BUFSIZ = .msg[DSC$W_LENGTH],
	 BUFADR = .msg[DSC$A_POINTER]));

  !
  !  Finally, start calling the routines to make it all happen!
  !
  status = MAIL$SEND_BEGIN (send_context, send_begin_itmlst, null_itmlst);
  errchk(status);

  !
  !  Now get ready to start adding all of the specified addresses.
  !
  !  Initialize the static portions of the MAIL$SEND_ADD_ADDRESS item list.
  !
  send_to_itmlst[0,ITM$W_ITMCOD] = MAIL$_SEND_USERNAME;
  send_to_itmlst[0,ITM$L_RETLEN] = 0;
  send_to_itmlst[1,0,0,32,0] = 0;
  !
  !  Set up work pointer and length for processing the user list.
  !
  users_ptr = .users[DSC$A_POINTER];		!Point to list of recipients
  users_len = .users[DSC$W_LENGTH];		!Get the length

  !
  !  Loop through the list of users, adding each one to the mail list.
  !
  WHILE (.users_len GTRU 0) DO			!While there are more users in
      BEGIN					!... the list
      LOCAL	temp : REF $BBLOCK;
      send_to_itmlst[0,ITM$L_BUFADR] = .users_ptr;
      temp = CH$FIND_CH (.users_len, .users_ptr, %C',');
      IF NOT(CH$FAIL(.temp))
      THEN
         BEGIN
         temp = CH$DIFF(.temp, .users_ptr);
         send_to_itmlst[0,ITM$W_BUFSIZ] = .temp;
         users_ptr = (.users_ptr) + (.temp) + 1;
         users_len = (.users_len) - (.temp) - 1;
         END
      ELSE
         BEGIN
         send_to_itmlst[0,ITM$W_BUFSIZ] = .users_len;
         users_len = 0;
         END;
      !
      !  Here, the send_to_itmlst has been set up to point to the current
      !  username.
      !
      status = MAIL$SEND_ADD_ADDRESS (send_context, send_to_itmlst,
						 null_itmlst);
      IF NOT(.user_flags<sm_v_ignoreinv>)		!Ignore invalid addrs?
      THEN						!No, return error, if
	errchk(status);					!... there is one
      END;

  !
  !  Add the From, To, and Subject lines....
  !
  status = MAIL$SEND_ADD_ATTRIBUTE (send_context, send_attribute_itmlst,
					null_itmlst);
  errchk(status);

  !
  !  Tell it to send a record or a file....
  !
  status = MAIL$SEND_ADD_BODYPART (send_context, send_body_itmlst, null_itmlst);
  errchk(status);

  !
  !  Now send the message!
  !
  status = MAIL$SEND_MESSAGE (send_context, null_itmlst, null_itmlst);
  errchk(status);

  !
  !  If the send was successful, free up our context.  Note that any other
  !  errors will cause our MAIL$SEND context to not be freed!
  !
  status = MAIL$SEND_END (send_context, null_itmlst, null_itmlst);

  RETURN (.status);

END;

!
!  Condition handler that will unwind the stack 1 frame to return to the
!  caller of a routine that signals the condition.  This routine is used
!  to keep the MAIL$ routines from signalling their conditions.
!
ROUTINE mail_handler =
  RETURN ($UNWIND (DEPADR = %REF(1)));


ROUTINE define_sys_scratch (scratch_a) : local_jsb =
BEGIN
!+
!
!  Routine:	DEFINE_SYS_SCRATCH
!
!  Functional description:
!
!	This routine ensures that SYS$SCRATCH is defined.  The callable mail
!	routines use SYS$SCRATCH, which is not automatically defined for
!	detached processes.
!
!	An optional scratch directory can be passed in.  If it is omitted,
!	the default device and directory for the username under which the
!	program is running is used as the SYS$SCRATCH equivalence string.
!
!  Formal parameters:
!
!	scratch_a	- Address of descriptor for the SYS$SCRATCH equivalence
!			  string.  Optional.
!
!  Returns:
!
!	R0		- Status (from $TRNLNM, $GETJPIW, $GETUAI, $CRELNM)
!
!  Side effects:
!
!	May define a user-mode logical SYS$SCRATCH in the LNM$JOB table.
!
!-
BIND
	scratch	= .scratch_a	: $BBLOCK;

BIND
	lnm$job		= %ASCID'LNM$JOB',
	sys$scratch	= %ASCID'SYS$SCRATCH';

LOCAL
	trnlnm_itmlst		: $ITMLST_DECL (ITEMS = 1),
	trnlnm_buffer		: $BBLOCK[LNM$C_NAMLENGTH],
	trnlnm_retlen		: UNSIGNED LONG,
	temp_itmlst		: $ITMLST_DECL (ITEMS = 2),
	temp_buffer		: $BBLOCK[UAF$S_DEFDEV+UAF$S_DEFDIR],
	device			: $BBLOCK[UAF$S_DEFDEV],
	directory		: $BBLOCK[UAF$S_DEFDIR],
	temp_len		: UNSIGNED LONG,
	temp2_len		: UNSIGNED LONG,
	temp_ptr		: REF $BBLOCK,
	temp2_ptr		: REF $BBLOCK,
	username_buffer		: $BBLOCK[UAF$S_USERNAME],
	username_length		: UNSIGNED LONG,
	username		: $STATICDESC (0, username_buffer);

REGISTER
	status			: UNSIGNED LONG;

  !
  !  See if SYS$SCRATCH is already defined.  If it is, just return to the
  !  caller.
  !
  $ITMLST_INIT (ITMLST = trnlnm_itmlst,			!Set up $TRNLNM item
	(BUFSIZ	= LNM$C_NAMLENGTH,			!... list to receive
	 ITMCOD	= LNM$_STRING,				!... the equivalence
	 BUFADR	= trnlnm_buffer));			!... string

  IF (status = $TRNLNM (LOGNAM = sys$scratch,		!If SYS$SCRATCH is
			TABNAM = lnm$job,		!... defined, then
			ITMLST = trnlnm_itmlst))	!... just return to
  THEN							!... our caller
     RETURN (.status);

  IF (scratch NEQU 0)       AND				!... If equivalence
     (.scratch[DSC$W_LENGTH] NEQU 0)			!... passed and it's not
  THEN							!... 0 or 0 length,
     BEGIN						!... then define it
     trnlnm_itmlst[0, ITM$W_BUFSIZ] = .scratch[DSC$W_LENGTH];
     trnlnm_itmlst[0, ITM$L_BUFADR] = .scratch[DSC$A_POINTER];
     END
  ELSE
     BEGIN
     !
     !  Here, the caller didn't give a device.  Let's use the default device
     !  and directory for the username under which we're running.  To do this,
     !  call $GETJPI to get our username, then call $GETUAI to get our default
     !  device and directory.
     !
     $ITMLST_INIT (ITMLST = temp_itmlst,		!Initialize item list
	(ITMCOD	= JPI$_USERNAME,			!... for $GETJPI call
	 BUFSIZ	= UAF$S_USERNAME,			!... to get our username
	 BUFADR	= username_buffer,			!...
	 RETLEN	= username_length));			!...
     status = $GETJPIW (ITMLST = temp_itmlst);		!Get our username
     errchk(status);					!Return any errors
     username[DSC$W_LENGTH] = .username_length;		!Set length in desc.
     !
     !  Now set up call to $GETUAI to get the default device and directory.
     !
     $ITMLST_INIT (ITMLST = temp_itmlst,		!Set up the item list
	(ITMCOD	= UAI$_DEFDEV,				!... to get the default
	 BUFSIZ	= UAF$S_DEFDEV,				!... device and
	 BUFADR	= device),				!... directory for this
	(ITMCOD	= UAI$_DEFDIR,				!... username
	 BUFSIZ	= UAF$S_DEFDIR,				!...
	 BUFADR	= directory));				!...
     status = $GETUAI (USRNAM = username, ITMLST = temp_itmlst);
     errchk(status);					!Return any errors
     !
     !  Now copy the ASCIC device and directory strings into temp_buffer.
     !
     temp2_ptr = temp_buffer;				!Point to destination
     temp_ptr = device;					!Point to the device
     temp_len = CH$RCHAR_A (temp_ptr);			!Get the length
     CH$MOVE (.temp_len, .temp_ptr, .temp2_ptr);	!Copy the device name
     temp2_ptr = .temp2_ptr + .temp_len;		!Bump the dest. pointer
     temp_ptr = directory;				!Point to the directory
     temp_len = CH$RCHAR_A (temp_ptr);			!Get the length
     CH$MOVE (.temp_len, .temp_ptr, .temp2_ptr);	!Copy the directory
     !
     !  Now set up the item list to point to the string in temp_buffer.
     !
     trnlnm_itmlst[0, ITM$W_BUFSIZ] =			!Set the itmlst length
		CH$DIFF (.temp2_ptr, temp_buffer) + .temp_len;
     trnlnm_itmlst[0, ITM$L_BUFADR] = temp_buffer;	!Set the address
     END;

  !
  !  The trnlnm_itmlst has been set up to point to the proper equivalence
  !  string, so go ahead and create the logical name.
  !
  status = $CRELNM (LOGNAM = sys$scratch,		!Create SYS$SCRATCH
		    TABNAM = lnm$job,			!... in LNM$JOB
		    ITMLST = trnlnm_itmlst);		!...
!		    ACMODE = PSL$C_EXEC);
  RETURN (.status);					!Return status to caller

END;

END						!End of module BEGIN
ELUDOM						!End of module