



		    accept_messages.pl1             05/20/87  1526.9rew 05/20/87  1423.1      212337



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
/* This command accepts messages on the specified mailbox. */

/****^  HISTORY COMMENTS:
  1) change(84-05-31,Lippard), approve(), audit(), install():
      Written by Jim Lippard.
  2) change(84-11-21,Lippard), approve(), audit(), install():
      Modified to use call string for -print when appropriate.
  3) change(85-01-11,Lippard), approve(), audit(), install():
      Modified to use new calling sequences for
      message_facility_$(delete_message print_message read_message
      set_seen_switch).
  4) change(86-01-05,Lippard), approve(86-05-27,MCR7418),
     audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080):
      Modified to abort if user decides not to create a nonexistent
      mailbox.
  5) change(87-01-29,Lippard), approve(87-03-18,MECR0001),
     audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002):
      Modified to strip control characters out of message comment field.
  6) change(87-01-29,Lippard), approve(87-04-20,MCR7669),
     audit(87-05-11,Fawcett), install(87-05-20,MR12.1-1032):
      Formal installation to close out MECR0001.
                                                   END HISTORY COMMENTS */

accept_messages: am: procedure options (variable);
	dcl     ME		 char (15) internal static options (constant) init ("accept_messages");
	dcl     VERSION		 char (3) internal static options (constant) init ("1.3");

	dcl     aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned) reducible;

	dcl     canonicalize_	 entry (ptr, fixed bin (21), ptr, fixed bin (21), fixed bin (35));

	dcl     com_err_		 entry () options (variable);

	dcl     command_query_$yes_no	 entry () options (variable);

	dcl     convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));

	dcl     convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));

	dcl     cu_$cp		 entry (ptr, fixed bin (21), fixed bin (35));

	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);

	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));

	dcl     get_authorization_	 entry () returns (bit (72) aligned) reducible;
	dcl     get_system_free_area_	 entry () returns (ptr);

	dcl     (ioa_, ioa_$rsnnl)	 entry () options (variable);

	dcl     iox_$user_output	 ptr ext static;

	dcl     mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35));

	dcl     mailbox_$create	 entry (char (*), char (*), fixed bin (35));
	dcl     mailbox_$get_uid_file	 entry (char (*), char (*), bit (36) aligned, fixed bin (35));

	dcl     message_facility_$default_alarm_handler entry (ptr, ptr);
	dcl     message_facility_$default_wakeup_handler entry (ptr, ptr);
	dcl     message_facility_$delete_message entry (ptr, bit (72) aligned, fixed bin (35));
	dcl     message_facility_$get_message_format entry (ptr, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$get_msg_array_ptr entry (ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35));
	dcl     message_facility_$get_wakeup_state entry (ptr, bit (*), fixed bin (35));
	dcl     message_facility_$print_message entry (ptr, ptr, bit (72) aligned, ptr, fixed bin (35));
	dcl     message_facility_$read_message entry (ptr, bit (72) aligned, ptr, ptr, fixed bin (35));
	dcl     message_facility_$set_alarm_handler entry (ptr, entry, ptr, fixed bin (71), fixed bin (35));
	dcl     message_facility_$set_message_format entry (ptr, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$set_prefix entry (ptr, char (32) var, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$set_seen_switch entry (ptr, bit (72) aligned, bit (*), fixed bin (35));
	dcl     message_facility_$set_wakeup_handler entry (ptr, entry, ptr, fixed bin (35));
	dcl     message_facility_$set_wakeup_state entry (ptr, bit (*), fixed bin (35));

	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

	dcl     requote_string_	 entry (char (*)) returns (char (*));

	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

	dcl     user_info_$whoami	 entry (char (*), char (*), char (*));

	dcl     cleanup		 condition;

	dcl     alarm_time		 fixed bin (71);

	dcl     arg_count		 fixed bin;
	dcl     arg_ptr		 ptr;
	dcl     arg_len		 fixed bin (21);
	dcl     arg		 char (arg_len) based (arg_ptr);

	dcl     authorization	 bit (72) aligned;
	dcl     auth_string		 char (170);

	dcl     alarm		 bit (1) aligned;

	dcl     brief		 bit (1) aligned;

	dcl     call		 bit (1) aligned;

	dcl     1 call_string_info	 aligned based (call_string_info_ptr),
		2 uid		 bit (36) aligned,
		2 call_string_ptr	 ptr,
		2 next_call_string_ptr ptr;

	dcl     call_string_info_ptr	 ptr;

	dcl     static_call_string_info_ptr ptr internal static init (null ());

	dcl     call_string		 char (512) based (call_string_info.call_string_ptr);
	dcl     temp_call_string	 char (512);

	dcl     command_line	 char (2000);

	dcl     create_mbx		 bit (1) aligned;

	dcl     date_time		 fixed bin (71);

	dcl     default		 bit (1) aligned;

	dcl     dname		 char (168);
	dcl     ename		 char (32);

	dcl     flags		 bit (5);
	dcl     1 local_wf		 like wakeup_flags based (local_wf_ptr);
	dcl     local_wf_ptr	 ptr;

	dcl     flush_time		 fixed bin (71);

	dcl     found		 bit (1) aligned;

	dcl     hold		 bit (1) aligned;
	dcl     nohold		 bit (1) aligned;

	dcl     hold_notify		 bit (1) aligned;
	dcl     nohold_notify	 bit (1) aligned;

	dcl     idx		 fixed bin;

	dcl     last_msg_time	 char (24);
	dcl     last_sender		 char (120);
	dcl     last_time		 fixed bin (71);

	dcl     1 local_mi		 aligned like message_info;
	dcl     1 local_pcao	 aligned like parse_ca_options;

	dcl     mail		 bit (1) aligned;
	dcl     nomail		 bit (1) aligned;

	dcl     message_sender	 char (120);

	dcl     msg_date_time	 char (24);

	dcl     msgf_mbx_ptr	 ptr;

	dcl     path		 bit (1) aligned;
	dcl     pathname		 char (256);

	dcl     person		 char (22);
	dcl     project		 char (9);

	dcl     prefix_string	 char (32) varying;
	dcl     prefix		 bit (1) aligned;

	dcl     print		 bit (1) aligned;

	dcl     sci_ptr		 ptr;

	dcl     short_format	 bit (1) aligned;
	dcl     no_short_format	 bit (1) aligned;
	dcl     short_format_switch	 bit (1) aligned;
	dcl     new_short_format_switch bit (1) aligned;
	dcl     short		 bit (1) aligned;
	dcl     short_prefix	 bit (1) aligned;

	dcl     sys_area		 area based (sys_area_ptr);
	dcl     sys_area_ptr	 ptr;

	dcl     tag		 char (10) var;

	dcl     uid		 bit (36) aligned;

	dcl     (addr, before, collate, convert, fixed, index, length, maxlength, null, rtrim, string, substr, translate) builtin;

	dcl     (conversion, size)	 condition;

	dcl     code		 fixed bin (35);

	dcl     error_table_$noarg	 fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;

	dcl     ALPHABET		 char (256) init ((8)" " || "	" || (4)" " || "" || (16)" "
				 || substr (collate (), 33)); /* space, BSHT, space, RRSBRS, space, alphanumerics */
	dcl     NLSPHT		 char (3) internal static options (constant) init ("
 	");
	dcl     BS		 char (1) aligned internal static options (constant) init ("");
	dcl     TRUE		 bit (1) aligned internal static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) aligned internal static options (constant) init ("0"b);

	dcl     FIVE_MINUTES	 fixed bin (71) internal static options (constant) init (300000000);

/* initialize variables */
	alarm, brief, call, default, hold, nohold, hold_notify, nohold_notify, nomail, path, print,
	     short_format, no_short_format = FALSE;
	mail, short_prefix = TRUE;
	last_msg_time, last_sender = "";
	last_time = 0;
	alarm_time, flush_time = 0;
	temp_call_string = "";
	prefix_string = "";
	prefix = FALSE;
	call_string_info_ptr, msg_array_ptr, sci_ptr = null ();
	sys_area_ptr = get_system_free_area_ ();

	on cleanup call cleanup_am;

/* create ssu_ invocation */
	call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_am, code);

	if code ^= 0 then do;
		call com_err_ (code, ME, "Creating standalone subsystem invocation.");
		return;
	     end;

/* process arguments */
	call ssu_$arg_count (sci_ptr, arg_count);

	do idx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
	     if arg = "-brief" | arg = "-bf" then brief, short_format = TRUE;
	     else if arg = "-long" | arg = "-lg" then do;
		     short_format = FALSE;
		     no_short_format = TRUE;
		end;
	     else if arg = "-call" then do;
		     idx = idx + 1;
		     if idx > arg_count then temp_call_string = "";

		     else do;
			     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
			     if index (arg, "-") = 1 then do;
				     temp_call_string = "";
				     idx = idx - 1;
				end;
			     else do;
				     if arg_len > length (temp_call_string) then
					call ssu_$abort_line (sci_ptr, (0), "Call string may not be longer than ^d characters. ^a", length (temp_call_string), arg);
				     temp_call_string = arg;
				end;
			end;
		     call = TRUE;
		end;
	     else if arg = "-flush" then do;
		     idx = idx + 1;
		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A flush time must be specified after ""^a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
		     call convert_date_to_binary_ (arg, flush_time, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);
		end;
	     else if arg = "-hold" | arg = "-hd" | arg = "-hold_messages" | arg = "-hdmsg" then do;
		     hold = TRUE;
		     nohold = FALSE;
		end;
	     else if arg = "-no_hold" | arg = "-nhd" | arg = "-no_hold_messages" | arg = "-nhdmsg" then do;
		     hold = FALSE;
		     nohold = TRUE;
		     alarm_time = 0;
		end;
	     else if arg = "-hold_notifications" | arg = "-hdnt" then do;
		     hold_notify = TRUE;
		     nohold_notify = FALSE;
		     mail = TRUE;
		     nomail = FALSE;
		end;
	     else if arg = "-no_hold_notifications" | arg = "-nhdnt" then do;
		     hold_notify = FALSE;
		     nohold_notify = TRUE;
		end;
	     else if arg = "-mail" | arg = "-ml" | arg = "-notifications" | arg = "-nt" then do;
		     mail = TRUE;
		     nomail = FALSE;
		end;
	     else if arg = "-no_mail" | arg = "-nml" | arg = "-no_notifications" | arg = "-nnt" then do;
		     mail = FALSE;
		     nomail = TRUE;
		     hold_notify = FALSE;
		     nohold_notify = TRUE;
		end;
	     else if arg = "-pathname" | arg = "-pn" then do;
		     idx = idx + 1;
		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A pathname must be specified after ""^a"".", arg);

		     if path then call ssu_$abort_line (sci_ptr, (0), "Usage: am {mbx_specification} {-control_args}");

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
		     call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     path = TRUE;
		end;
	     else if arg = "-prefix" | arg = "-pfx" then do;
		     idx = idx + 1;
		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A prefix must be specified after ""^a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     if arg_len > maxlength (prefix_string) then
			call ssu_$abort_line (sci_ptr, (0), "Prefix may not be longer than ^d characters. ^a", maxlength (prefix_string), arg);

		     prefix_string = arg;
		     prefix = TRUE;
		end;
	     else if arg = "-print" | arg = "-pr" then print = TRUE;
	     else if arg = "-no_print" | arg = "-npr" then print = FALSE;
	     else if arg = "-short" | arg = "-sh" then do;
		     short_format = TRUE;
		     no_short_format = FALSE;
		end;
	     else if arg = "-short_prefix" | arg = "-shpfx" then short_prefix = TRUE;
	     else if arg = "-no_short_prefix" | arg = "-nshpfx" then short_prefix = FALSE;
	     else if arg = "-time" | arg = "-tm" then do;
		     idx = idx + 1;
		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "An alarm time must be specified after ""^a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     on conversion, size go to BAD_TIME;
		     alarm_time = 60 * convert (alarm_time, arg);
		     revert conversion, size;

		     hold = TRUE;
		     nohold = FALSE;
		     alarm = TRUE;
		end;
	     else do;
						/* let mlsys_utils_ have at it */
		     local_pcao.version = PARSE_CA_OPTIONS_VERSION_1;
		     local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX;
		     local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX;
		     local_pcao.abort_on_errors = TRUE;
		     local_pcao.validate_addresses = FALSE;
		     local_pcao.mbz = ""b;

		     call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao), dname, ename, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code);

		     idx = idx - 1;

		     if path then call ssu_$abort_line (sci_ptr, (0), "Usage: am {msg_specification} {-control_args}");

		     path = TRUE;
		end;
	end;

	if ^path then do;
		call user_info_$whoami (person, project, "");
		dname = ">udd>" || rtrim (project) || ">" || person;
		ename = rtrim (person) || ".mbx";
		default = TRUE;
	     end;

	call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code);

	if code = error_table_$noentry then do;
						/* if default, create it; otherwise ask */
		if ^default then call command_query_$yes_no (create_mbx, code, ME,
			"Answer ""yes"" if you want the mailbox to be created.", "Do you want to create the mailbox ^a?", pathname_ (dname, ename));

		if create_mbx | default then do;
			call mailbox_$create (dname, ename, code);

			if code ^= 0 then call ssu_$abort_line (sci_ptr, code,
				"Creating ^[default ^]mailbox ^a.", default, pathname_ (dname, ename));
		     end;
		else call abort_am ();

		if ^brief then call ioa_ ("Creating ^[default ^]mailbox ^a.", default, pathname_ (dname, ename));

		call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code);
	     end;

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code,
		"Getting message facility mailbox pointer. ^a", pathname_ (dname, ename));

/* get wakeup state */
	call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting wakeup state. ^a", pathname_ (dname, ename));

	local_wf_ptr = addr (flags);

	local_wf.wakeup_state = ACCEPT_MESSAGES;
	if nohold then local_wf.hold_messages = FALSE;
	else if hold then local_wf.hold_messages = TRUE;
	if nohold_notify then local_wf.hold_notifications = FALSE;
	else if hold_notify then local_wf.hold_notifications = TRUE;
	if nomail then local_wf.print_notifications = FALSE;
	else if mail then local_wf.print_notifications = TRUE;

	call message_facility_$set_wakeup_state (msgf_mbx_ptr, flags, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting wakeup state. ^a", pathname_ (dname, ename));

/* set prefix */
	if prefix then do;
		call message_facility_$set_prefix (msgf_mbx_ptr, prefix_string, short_prefix, code);

		if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting prefix. ^a", pathname_ (dname, ename));
	     end;

/* set message format */
	call message_facility_$get_message_format (msgf_mbx_ptr, short_format_switch, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting message format. ^a", pathname_ (dname, ename));

	if short_format then new_short_format_switch = TRUE;
	else if no_short_format then new_short_format_switch = FALSE;
	else new_short_format_switch = short_format_switch;

	if new_short_format_switch ^= short_format_switch then do;
		call message_facility_$set_message_format (msgf_mbx_ptr, new_short_format_switch, code);

		if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting message format. ^a", pathname_ (dname, ename));
	     end;

/* take care of call string */
	call mailbox_$get_uid_file (dname, ename, uid, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting mailbox UID. ^a", pathname_ (dname, ename));

	call_string_info_ptr = static_call_string_info_ptr;
	found = FALSE;

	do while (call_string_info_ptr ^= null () & ^found);
	     if call_string_info.uid = uid then found = TRUE;
	     else call_string_info_ptr = call_string_info.next_call_string_ptr;
	end;

	if found & call then call_string = temp_call_string;
	else if ^found then do;
		allocate call_string_info in (sys_area);
		call_string_info.uid = uid;
		allocate call_string in (sys_area);
		if call then call_string = temp_call_string;
		else call_string = "";
		call_string_info.next_call_string_ptr = static_call_string_info_ptr;
		static_call_string_info_ptr = call_string_info_ptr;
	     end;

/* set alarm handler */
	if alarm then do;
		call message_facility_$set_alarm_handler (msgf_mbx_ptr, message_facility_$default_alarm_handler,
		     addr (call_string), alarm_time, code);

		if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting alarm handler. ^a", pathname_ (dname, ename));
	     end;

	if print | flush_time ^= 0 then do;		/* only get msg array for print or flush */
		call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code);

		if code ^= 0 then call ssu_$abort_line (sci_ptr, code,
			"Getting message array pointer. ^a", pathname_ (dname, ename));

/* print old messages */
		if print then do;
			do idx = 1 to n_messages;
			     call print_message (idx, msg_array.message_id (idx));
			end;
		     end;

/* flush messages from before flush_time */
		if flush_time ^= 0 then do;
			do idx = 1 to n_messages;
			     if fixed (substr (msg_array.message_id (idx), 19, 54), 71) < flush_time then do;
				     call message_facility_$delete_message (msgf_mbx_ptr, msg_array.message_id (idx), code);

				end;
			end;
		     end;
	     end;					/* only get msg array for print or flush */

/* set wakeup handler */
	call message_facility_$set_wakeup_handler (msgf_mbx_ptr, message_facility_$default_wakeup_handler,
	     addr (call_string), code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting wakeup handler. ^a", pathname_ (dname, ename));

	call cleanup_am;
RETURN_FROM_AM:
	return;

BAD_TIME:
	call ssu_$abort_line (sci_ptr, (0), """^a"" is not a decimal integer.", arg);
	return;

/* This procedure removes control characters (except backspace, tab,
   red ribbon shift, and black ribbon shift) and canonicalizes strings
   to prevent backspacing past the front of the string. */
canon: procedure (P_string, P_string_len) returns (char (*));
	dcl     P_string		 char (*) parm;
	dcl     P_string_len	 fixed bin (21) parm;
	dcl     output_string	 char (P_string_len);

	P_string = translate (P_string, ALPHABET);
	if index (P_string, BS) ^= 0 then do;
		output_string = "";
		call canonicalize_ (addr (P_string), length (P_string), addr (output_string), P_string_len, (0));
		return (output_string);
	     end;
	else return (P_string);
     end canon;

/* This procedure prints a message. */
print_message: procedure (P_message_index, P_message_id);
	dcl     P_message_index	 fixed bin parm;
	dcl     P_message_id	 bit (72) aligned parm;

	mail_format_ptr = null ();

	local_mi.version = MESSAGE_INFO_VERSION_1;

	on cleanup begin;
		if mail_format_ptr ^= null () then free mail_format in (sys_area);
		mail_format_ptr = null ();
	     end;

	call message_facility_$read_message (msgf_mbx_ptr, P_message_id, sys_area_ptr, addr (local_mi), code);
	if code ^= 0 then return;
	mail_format_ptr = local_mi.message_ptr;
	date_time = fixed (substr (P_message_id, 19, 54), 71);
	call date_time_ (date_time, msg_date_time);

/* create message sender string */
	if mail_format.sent_from = before (local_mi.sender, ".") | rtrim (mail_format.sent_from) = "" then
	     message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2);
	else message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2)
		|| " (" || rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) || ")";
	authorization = get_authorization_ ();
	if ^aim_check_$greater_or_equal (local_mi.authorization, authorization) then do;
		call convert_access_class_$to_string_short (local_mi.authorization, auth_string, code);
		if auth_string = "" then auth_string = "system_low";
		message_sender = rtrim (message_sender) || " at " || auth_string;
	     end;

	if message_sender = last_sender then short = TRUE;
	else short = FALSE;

	if temp_call_string ^= "" then do;
		call ioa_$rsnnl (" ^d ", tag, (0), msg_array.message_number (P_message_index));
		if default then pathname = "";
		else pathname = requote_string_ (pathname_ (dname, ename));
		command_line = rtrim (temp_call_string) || " " || tag || requote_string_ (rtrim (message_sender))
		     || " " || requote_string_ (rtrim (date_time_$format ("date_time", date_time, "", ""))) || " "
		     || requote_string_ (rtrim (canon (rtrim (mail_format.text, NLSPHT), length (rtrim (mail_format.text, NLSPHT))))) || " " || pathname;
		call cu_$cp (addr (command_line), length (rtrim (command_line)), (0));
	     end;

	else do;
		string (msg_print_flags) = ""b;

/* print prefix, it may contain ioa_ controls */
		if ^short | short_prefix then msg_print_flags.print_prefix = TRUE;

/* if not default mailbox, prefix with mailbox entry name */
		if ^default then msg_print_flags.print_ename = TRUE;

		if ^short_format_switch | ^short then
		     msg_print_flags.print_sender = TRUE;

		if ^short_format_switch | substr (msg_date_time, 1, 8) ^= last_msg_time then msg_print_flags.print_date_and_time = TRUE;
		else if date_time - last_time > FIVE_MINUTES then msg_print_flags.print_time = TRUE;

		last_sender = message_sender;
		last_time = date_time;
		last_msg_time = substr (msg_date_time, 1, 8);

		call message_facility_$print_message (msgf_mbx_ptr, iox_$user_output, P_message_id, addr (msg_print_flags), code);

		call message_facility_$set_seen_switch (msgf_mbx_ptr, P_message_id, DELETE_UNHELD, code);
		if mail_format_ptr ^= null () then do;
			free mail_format in (sys_area);
			mail_format_ptr = null ();
		     end;
	     end;
     end print_message;

cleanup_am: proc;
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	if msg_array_ptr ^= null () then free msg_array in (sys_area);
	return;
     end cleanup_am;

abort_am: proc;
	call cleanup_am;
	go to RETURN_FROM_AM;
     end abort_am;

%page;
%include mail_format;
%page;
%include message_info;
%page;
%include mlsys_parse_ca_options;
%page;
%include msg_array;
%page;
%include msg_print_flags;
%page;
%include msg_wakeup_flags;

     end accept_messages;




		    defer_messages.pl1              01/07/85  1505.6rew 01/07/85  1418.2       66681



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* This module implements the following commands:

      defer_messages (dm) - command to defer printing of interactive
         messages until either the immediate_messages or accept_messages
         commands are used.
      immediate_messages (im) - command to resume printing of interactive
         messages.
*/
/* Written 12/26/83 by Jim Lippard */
/* Modified 11/30/84 by Jim Lippard to make immediate_messages print out
   messages received while messages were not being accepted. */
/* Modified 12/12/84 by Jim Lippard to make immediate_messages print all
   unseen messages. */
defer_messages: dm: procedure options (variable);
	dcl     ME		 char (18);
	dcl     VERSION		 char (3) internal static options (constant) initial ("1.2");

	dcl     com_err_		 entry () options (variable);

	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));

	dcl     get_system_free_area_	 entry () returns (ptr);

	dcl     mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35));

	dcl     message_facility_$get_msg_array_ptr entry (ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35));
	dcl     message_facility_$get_wakeup_state entry (ptr, bit (*), fixed bin (35));
	dcl     message_facility_$set_wakeup_state entry (ptr, bit (*), fixed bin (35));
	dcl     message_facility_$wakeup_processor entry (ptr);

	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

	dcl     user_info_$whoami	 entry (char (*), char (*), char (*));

	dcl     cleanup		 condition;

	dcl     arg_count		 fixed bin;
	dcl     arg_ptr		 ptr;
	dcl     arg_len		 fixed bin (21);
	dcl     arg		 char (arg_len) based (arg_ptr);

	dcl     new_wakeup_state	 bit (2) aligned;

	dcl     dname		 char (168);
	dcl     ename		 char (32);

	dcl     flags		 bit (5);

	dcl     idx		 fixed bin;

	dcl     1 local_eci		 aligned like event_call_info;
	dcl     1 local_pcao	 aligned like parse_ca_options;

	dcl     msgf_mbx_ptr	 ptr;

	dcl     path		 bit (1) aligned;

	dcl     person		 char (22);
	dcl     project		 char (9);

	dcl     sci_ptr		 ptr;

	dcl     sys_area_ptr	 ptr;
	dcl     sys_area		 area based (sys_area_ptr);

	dcl     (addr, null, rtrim, unspec) builtin;

	dcl     code		 fixed bin (35);

	dcl     error_table_$noarg	 fixed bin (35) ext static;

	dcl     TRUE		 bit (1) internal static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) internal static options (constant) init ("0"b);

	ME = "defer_messages";
	new_wakeup_state = DEFER_MESSAGES;
	go to COMMON;

immediate_messages: im: entry;
	ME = "immediate_messages";
	new_wakeup_state = ACCEPT_MESSAGES;

COMMON:

/* initialize variables */
	path = FALSE;
	msg_array_ptr, sci_ptr, sys_area_ptr = null ();

	on cleanup call cleanup_dm;

/* create ssu_ invocation */
	call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_dm, code);

	if code ^= 0 then do;
		call com_err_ (code, ME, "Creating standalone subsystem invocation.");
		return;
	     end;

/* process arguments */
	call ssu_$arg_count (sci_ptr, arg_count);

	do idx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
	     if arg = "-pathname" | arg = "-pn" then do;
		     idx = idx + 1;
		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A pathname must be specified after ""^a"".", arg);

		     if path then call ssu_$abort_line (sci_ptr, (0),
			     "Usage: ^[dm^;im^] {mbx_specification}", (ME = "defer_messages"));

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
		     call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     path = TRUE;
		end;
	     else do;
						/* let mlsys_utils_ have at it */
		     local_pcao.version = PARSE_CA_OPTIONS_VERSION_1;
		     local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX;
		     local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX;
		     local_pcao.abort_on_errors = TRUE;
		     local_pcao.validate_addresses = FALSE;
		     local_pcao.mbz = ""b;

		     call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao), dname, ename, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code);

		     if path then call ssu_$abort_line (sci_ptr, (0),
			     "Usage: ^[dm^;im^] {mbx_specification}", (ME = "defer_messages"));
		     idx = idx - 1;

		     path = TRUE;
		end;
	end;

	if ^path then do;
		call user_info_$whoami (person, project, "");
		dname = ">udd>" || rtrim (project) || ">" || rtrim (person);
		ename = rtrim (person) || ".mbx";
	     end;

	call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

	call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

	if new_wakeup_state = ACCEPT_MESSAGES then do;	/* immediate_messages needs to print "pending" messages */

		sys_area_ptr = get_system_free_area_ ();

		call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code);

		if code ^= 0 then call ssu_$abort_line (sci_ptr, code,
			"Getting message array pointer. ^a", pathname_ (dname, ename));

		do idx = 1 to n_messages;
		     if ^msg_array.printed (idx) then call print_message (idx);
		end;
	     end;

	addr (flags) -> wakeup_flags.wakeup_state = new_wakeup_state;

	call message_facility_$set_wakeup_state (msgf_mbx_ptr, flags, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

	call cleanup_dm;

RETURN_FROM_DM:
	return;

cleanup_dm: proc;
	if msg_array_ptr ^= null () then free msg_array in (sys_area);
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	return;
     end;

abort_dm: proc;
	call cleanup_dm;
	go to RETURN_FROM_DM;
     end abort_dm;

/* This procedure prints a message. */
print_message: procedure (P_message_index);
	dcl     P_message_index	 fixed bin parm;

/* Set up bogotified event_call_info.  None of this info is used except
   for local_eci.message and local_eci.data_ptr. */
	local_eci.channel_id = 0;
	unspec (local_eci.message) = unspec (msg_array.message_id (P_message_index));
	local_eci.sender = ""b;
	local_eci.dev_signal = ""b;
	local_eci.ring = 0;
	local_eci.data_ptr = msgf_mbx_ptr;

	call message_facility_$wakeup_processor (addr (local_eci));
     end print_message;

%page;
%include event_call_info;
%page;
%include mlsys_parse_ca_options;
%page;
%include msg_array;
%page;
%include msg_wakeup_flags;
     end defer_messages;




		    delete_message.pl1              12/01/87  0759.6rew 11/30/87  1322.5      313074



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
/* This module implements the following commands:

      delete_message (dlm) - deletes interactive messages
      print_messages (pm) - prints interactive messages
*/

/****^  HISTORY COMMENTS:
  1) change(84-06-04,Lippard), approve(), audit(), install():
      Written by Jim Lippard.
  2) change(84-11-08,Lippard), approve(), audit(), install():
      Modified to call set_seen_switch even when -call is used.
  3) change(84-11-16,Lippard), approve(), audit(), install():
      Modified to improve message printed when no messages are selected.
  4) change(84-11-23,Lippard), approve(), audit(), install():
      Modified to complain for each message not printed/deleted (except
      in ranges).
  5) change(85-01-11,Lippard), approve(), audit(), install():
      Modified to use new calling sequences for message_facility_$(read_message
      delete_message print_message set_seen_switch) and to complain about
      negative message numbers.
  6) change(85-01-23,Lippard), approve(85-11-18,MCR7298),
     audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006):
      Modified to print "You have no messages" on user_output and make dlm say
      when all messages have been deleted (when -message_status is specified).
  7) change(85-08-15,Lippard), approve(85-11-18,MCR7298),
     audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006):
      Modified to ignore case for keywords and to print a better error message
      for "dlm -a" when there are only unseen messages.
  8) change(87-01-29,Lippard), approve(87-03-18,MECR0001),
     audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002):
      Modified to strip control characters out of message comment field.
  9) change(87-05-08,Lippard), approve(87-04-20,MCR7669),
     audit(87-05-11,Fawcett), install(87-05-20,MR12.1-1032):
      Formal installation to close out MECR0001.
 10) change(87-08-25,Lippard), approve(87-08-24,MCR7761),
     audit(87-09-25,Dickson), install(87-11-30,MR12.2-1006):
     Remove -verbose control argument (original name of -message_status).
                                                   END HISTORY COMMENTS */

delete_message: dlm: procedure options (variable);
	dcl     ME		 char (14);
	dcl     VERSION		 char (3) internal static options (constant) init ("1.4");

	dcl     aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

	dcl     canonicalize_          entry (ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35));

	dcl     com_err_		 entry () options (variable);

	dcl     convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));

	dcl     convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));

	dcl     cu_$cp		 entry (ptr, fixed bin (21), fixed bin (35));

	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);

	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));

	dcl     get_authorization_	 entry () returns (bit (72) aligned) reducible;

	dcl     get_system_free_area_	 entry () returns (ptr);

	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);

	dcl     iox_$user_output	 ptr ext static;

	dcl     mailbox_$create	 entry (char (*), char (*), fixed bin (35));
	dcl     mailbox_$get_mode_file entry (char (*), char (*), bit (36) aligned, fixed bin (35));

	dcl     mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35));

	dcl     message_facility_$delete_message entry (ptr, bit (72) aligned, fixed bin (35));
	dcl     message_facility_$get_last_message_info entry (ptr, ptr, fixed bin (35));
	dcl     message_facility_$get_msg_array_ptr entry (ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35));
	dcl     message_facility_$get_prefix entry (ptr, char (32) var, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$print_message entry (ptr, ptr, bit (72) aligned, ptr, fixed bin (35));
	dcl     message_facility_$read_message entry (ptr, bit (72) aligned, ptr, ptr, fixed bin (35));
	dcl     message_facility_$set_seen_switch entry (ptr, bit (72) aligned, bit (*), fixed bin (35));

	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

	dcl     requote_string_	 entry (char (*)) returns (char (*));

	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     ssu_$print_message	 entry () options (variable);
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

	dcl     user_info_$whoami	 entry (char (*), char (*), char (*));

	dcl     cleanup		 condition;

	dcl     after_sw		 bit (1) aligned;
	dcl     after_date_time	 fixed bin (71);

	dcl     all		 bit (1) aligned;

	dcl     arg_count		 fixed bin;
	dcl     arg_ptr		 ptr;
	dcl     arg_len		 fixed bin (21);
	dcl     arg		 char (arg_len) based (arg_ptr);

	dcl     authorization	 bit (72) aligned;
	dcl     auth_string		 char (170);

	dcl     before_sw		 bit (1) aligned;
	dcl     before_date_time	 fixed bin (71);

	dcl     brief		 bit (1) aligned;

	dcl     call_string		 char (512);

	dcl     command_line	 char (2000);

	dcl     comment		 bit (1) aligned;
	dcl     comment_string	 char (32);

	dcl     date_time		 fixed bin (71);

	dcl     delete		 bit (1) aligned;

	dcl     default		 bit (1) aligned;

	dcl     dname		 char (168);
	dcl     ename		 char (32);

	dcl     exclude		 bit (1) aligned;
	dcl     exclude_string	 char (256);

	dcl     extended_mode	 bit (36) aligned;

	dcl     force		 bit (1) aligned;

	dcl     from		 bit (1) aligned;
	dcl     from_string		 char (32);

	dcl     found		 bit (1) aligned;

	dcl     actual_hold_flags	 bit (3);

	dcl     1 hold_flags	 unaligned based (hold_flags_ptr),
		2 delete_unheld	 bit (1),
		2 hold_messages	 bit (1),
		2 hold_notifications bit (1);

	dcl     hold_flags_ptr	 ptr;

	dcl     hold_messages	 bit (1) aligned;
	dcl     no_hold_messages	 bit (1) aligned;
	dcl     hold_notifications	 bit (1) aligned;
	dcl     no_hold_notifications	 bit (1) aligned;

	dcl     (idx, jdx)		 fixed bin;

	dcl     last		 bit (1) aligned;

	dcl     last_msg_time	 char (24);
	dcl     last_sender		 char (120);
	dcl     last_time		 fixed bin (71);

	dcl     1 local_lmi		 aligned like last_message_info;
	dcl     1 local_mi		 aligned like message_info;
	dcl     1 local_pcao	 aligned like parse_ca_options;

	dcl     match		 bit (1) aligned;
	dcl     match_string	 char (256);

	dcl     message_sender	 char (120);

	dcl     msg_date_time	 char (24);

	dcl     msgf_mbx_ptr	 ptr;

	dcl     1 msg_spec		 (50) aligned,
		2 start		 fixed bin,
		2 start_spec	 bit (1) aligned,
		2 end		 fixed bin,
		2 end_spec	 bit (1) aligned,
		2 found		 bit (1) aligned,
		2 arg		 char (256);

	dcl     n_msg_specs		 fixed bin;

	dcl     messages		 bit (1) aligned;
	dcl     no_messages		 bit (1) aligned;
	dcl     notifications	 bit (1) aligned;
	dcl     no_notifications	 bit (1) aligned;

	dcl     message_status	 bit (1) aligned;

	dcl     (start, end)	 fixed bin;

	dcl     new		 bit (1) aligned;

	dcl     own		 bit (1) aligned;

	dcl     path		 bit (1) aligned;

	dcl     pathname		 char (256);

	dcl     person		 char (22);
	dcl     project		 char (9);

	dcl     prefix_string	 char (32) varying;

	dcl     print		 bit (1) aligned;

	dcl     sci_ptr		 ptr;

	dcl     short		 bit (1) aligned;
	dcl     short_format	 bit (1) aligned;
	dcl     short_prefix	 bit (1) aligned;

	dcl     something_done	 bit (1) aligned;

	dcl     sys_area		 area based (sys_area_ptr);
	dcl     sys_area_ptr	 ptr;

	dcl     tag		 char (10) varying;

	dcl     (addr, after, before, collate, convert, fixed, hbound, index,
	        length, null, rtrim, string, substr, translate) builtin;

	dcl     code		 fixed bin (35);

	dcl     error_table_$inconsistent fixed bin (35) ext static;
	dcl     error_table_$noarg	 fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$no_message fixed bin (35) ext static;

	dcl     TRUE		 bit (1) aligned internal static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) aligned internal static options (constant) init ("0"b);

	dcl     ALPHABET		 char (256) init ((8)" " || "	" || (4)" " || "" || (16)" "
				 || substr (collate (), 33)); /* space, BSHT, space, RRSBRS, space, alphanumerics */
	dcl     FIVE_MINUTES	 fixed bin (71) internal static options (constant) init (300000000);
	dcl     FIRST_MESSAGE	 fixed bin internal static options (constant) init (-2);
	dcl     LAST_MESSAGE	 fixed bin internal static options (constant) init (-1);
	dcl     NLSPHT		 char (3) internal static options (constant) init ("
 	");
	dcl     BS		 char (1) internal static options (constant) init ("");
	dcl     UPPERCASE		 char (26) internal static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
	dcl     LOWERCASE		 char (26) internal static options (constant) init ("abcdefghijklmnopqrstuvwxyz");

	ME = "delete_message";
	delete = TRUE;
	print = FALSE;
	go to COMMON;

print_messages: pm: entry;
	ME = "print_messages";
	delete = FALSE;
	print = TRUE;

COMMON:

/* initialize variables */
	after_sw, all, before_sw, brief, comment, default, exclude, force, from, last, match, new, path = FALSE;

/* The following assignments are separate to avoid a PL/I bug,
   see TR phx17760 */
	message_status = FALSE;
	messages = FALSE;
	no_messages = FALSE;
	notifications = FALSE;
	no_notifications = FALSE;
	hold_messages = FALSE;
	no_hold_messages = FALSE;
	hold_notifications = FALSE;
	no_hold_notifications = FALSE;
	short_format = TRUE;
	last_msg_time, last_sender = "";
	call_string, from_string, match_string, exclude_string = "";
	last_time = 0;
	n_msg_specs = 0;
	mail_format_ptr, msg_array_ptr, sci_ptr = null ();
	sys_area_ptr = get_system_free_area_ ();

	on cleanup call cleanup_dlm;

/* create ssu_ invocation */
	call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_dlm, code);

	if code ^= 0 then do;
		call com_err_ (code, ME, "Creating standalone subsystem invocation.");
		return;
	     end;

/* process arguments */
	call ssu_$arg_count (sci_ptr, arg_count);

	do idx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
	     if arg = "-after" then do;
		     idx = idx + 1;

		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A date/time must be specified after ""^a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     if after_sw then call ssu_$abort_line (sci_ptr, (0),
			     "Only one -after date/time may be specified. ^a", arg);

		     call convert_date_to_binary_ (arg, after_date_time, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     after_sw = TRUE;
		end;
	     else if arg = "-all" | arg = "-a" then all = TRUE;
	     else if arg = "-before" then do;
		     idx = idx + 1;

		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A date/time must be specified after ""^a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     if before_sw then call ssu_$abort_line (sci_ptr, (0),
			     "Only one -before date/time may be specified. ^a", arg);

		     call convert_date_to_binary_ (arg, before_date_time, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     before_sw = TRUE;
		end;
	     else if arg = "-brief" | arg = "-bf" then brief = TRUE;
	     else if arg = "-long" | arg = "-lg" then do;
		     if print then short_format = FALSE;
		     brief = FALSE;
		end;
	     else if (arg = "-short" | arg = "-sh") then do;
		     if print then short_format = TRUE;
		     else message_status = FALSE;
		end;
	     else if arg = "-message_status" | arg = "-msgst" then message_status = TRUE;
	     else if arg = "-no_message_status" | arg = "-nmsgst" then message_status = FALSE;
	     else if arg = "-call" & print then do;
		     idx = idx + 1;

		     if idx > arg_count then call_string = "";

		     else do;
			     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
			     if index (arg, "-") = 1 then do;
				     call_string = "";
				     idx = idx - 1;
				end;

			     else do;
				     if arg_len > length (call_string) then
					call ssu_$abort_line (sci_ptr, (0), "Call string may not be longer than ^d characters. ^a", length (call_string), arg);
				     call_string = arg;
				end;
			end;
		end;
	     else if arg = "-comment" | arg = "-com" then do;
		     idx = idx + 1;

		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A comment string must be specified after ""^a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     if comment then call ssu_$abort_line (sci_ptr, (0),
			     "Only one comment string may be supplied. ^a", arg);

		     if arg_len > length (comment_string) then
			call ssu_$abort_line (sci_ptr, (0), "Comment string may not be longer than ^d characters. ^a", length (comment_string), arg);

		     comment_string = arg;
		     comment = TRUE;
		end;
	     else if arg = "-exclude" then do;
		     idx = idx + 1;

		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "An exclude string must be specified after ""a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     if exclude then call ssu_$abort_line (sci_ptr, (0),
			     "Only one exclude string may be specified. ^a", arg);

		     if arg_len > length (exclude_string) then
			call ssu_$abort_line (sci_ptr, (0), "Exclude string may not be longer than ^d characters. ^a", length (exclude_string), arg);

		     exclude_string = arg;
		     exclude = TRUE;
		end;
	     else if (arg = "-force" | arg = "-fc") & delete then force = TRUE;
	     else if (arg = "-no_force" | arg = "-nfc") & delete then force = FALSE;
	     else if arg = "-from" | arg = "-fm" then do;
		     idx = idx + 1;

		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A from string must be specified after ""^a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     if from then call ssu_$abort_line (sci_ptr, (0),
			     "Only one from string may be specified. ^a", arg);

		     if arg_len > length (from_string) then
			call ssu_$abort_line (sci_ptr, (0), "From string may not be longer than ^d characters. ^a", length (from_string), arg);

		     from_string = arg;
		     from = TRUE;
		end;
	     else if (arg = "-hold_messages" | arg = "-hdmsg") & print then do;
		     hold_messages = TRUE;
		     no_hold_messages = FALSE;
		end;
	     else if (arg = "-no_hold_messages" | arg = "-nhdmsg") & print then do;
		     hold_messages = FALSE;
		     no_hold_messages = TRUE;
		end;
	     else if (arg = "-hold_notifications" | arg = "-hdnt") & print then do;
		     hold_notifications = TRUE;
		     no_hold_notifications = FALSE;
		end;
	     else if (arg = "-no_hold_notifications" | arg = "-nhdnt") & print then do;
		     hold_notifications = FALSE;
		     no_hold_notifications = TRUE;
		end;
	     else if (arg = "-last" | arg = "-lt") & print then last = TRUE;
	     else if arg = "-match" then do;
		     idx = idx + 1;

		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A match string must be specified after ""^a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     if match then call ssu_$abort_line (sci_ptr, (0),
			     "Only one match string may be specified. ^a", arg);

		     if arg_len > length (match_string) then
			call ssu_$abort_line (sci_ptr, (0), "Match string may not be longer than ^d characters. ^a", length (match_string), arg);

		     match_string = arg;
		     match = TRUE;
		end;
	     else if arg = "-messages" | arg = "-msg" then do;
		     messages = TRUE;
		     no_messages = FALSE;
		end;
	     else if arg = "-no_messages" | arg = "-nmsg" then do;
		     messages = FALSE;
		     no_messages = TRUE;
		end;
	     else if arg = "-notifications" | arg = "-nt" then do;
		     notifications = TRUE;
		     no_notifications = FALSE;
		end;
	     else if arg = "-no_notifications" | arg = "-nnt" then do;
		     notifications = FALSE;
		     no_notifications = TRUE;
		end;
	     else if arg = "-new" & print then new = TRUE;
	     else if arg = "-pathname" | arg = "-pn" then do;
		     idx = idx + 1;

		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A pathname must be specified after ""^a"".", arg);

		     if path then call ssu_$abort_line (sci_ptr, (0),
			     "Usage: ^[dlm^;pm^] ^[{^]msg_specs^[}^] {mbx_specification} {-control_args}", delete, print, print);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     path = TRUE;
		end;
	     else do;				/* msg spec or mbx spec */
		     start = get_msg_spec (arg, code);
		     if code = 0 then end = start;
		     else if index (arg, ":") ^= 0 then do;
			     start = get_msg_spec (before (arg, ":"), code);
			     if code = 0 then end = get_msg_spec (after (arg, ":"), code);
			     if code ^= 0 then
				call ssu_$abort_line (sci_ptr, (0), "Invalid message range. ^a", arg);
			end;
		     if code = 0 then do;
			     n_msg_specs = n_msg_specs + 1;
			     if n_msg_specs > hbound (msg_spec, 1) then call ssu_$abort_line (sci_ptr, (0),
				     "Too many message specifiers given, maximum of ^d.", hbound (msg_spec, 1));
			     msg_spec.start (n_msg_specs) = start;
			     if msg_spec.start (n_msg_specs) < 0 then msg_spec.start_spec (n_msg_specs) = TRUE;
			     else msg_spec.start_spec (n_msg_specs) = FALSE;
			     msg_spec.end (n_msg_specs) = end;
			     if msg_spec.end (n_msg_specs) < 0 then msg_spec.end_spec (n_msg_specs) = TRUE;
			     else msg_spec.end_spec (n_msg_specs) = FALSE;
			     msg_spec.found (n_msg_specs) = FALSE;
			     msg_spec.arg (n_msg_specs) = arg;
			end;
		     else if translate (arg, LOWERCASE, UPPERCASE) = "all" | translate (arg, LOWERCASE, UPPERCASE) = "a" then all = TRUE;
		     else do;			/* mbx specification */

/* let mlsys_utils_ have at it */
			     local_pcao.version = PARSE_CA_OPTIONS_VERSION_1;
			     local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX;
			     local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX;
			     local_pcao.abort_on_errors = TRUE;
			     local_pcao.validate_addresses = FALSE;
			     local_pcao.mbz = ""b;

			     call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao),
				dname, ename, code);

			     if code ^= 0 then call ssu_$abort_line (sci_ptr, code);

			     idx = idx - 1;

			     if path then call ssu_$abort_line (sci_ptr, (0),
				     "Usage: ^[dlm^;pm^] ^[{^]msg_specs^[}^] {mbx_specification} {-control_args}", delete, print, print);

			     path = TRUE;
			end;			/* mbx spec */
		end;				/* msg spec or mbx spec */
	end;					/* arg loop */

	if no_messages & no_notifications then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		"-no_messages and -no_notifications");
	if last & (after_sw | before_sw | comment | from | match | exclude | messages | notifications
	     | no_messages | no_notifications | hold_messages | hold_notifications
	     | no_hold_messages | no_hold_notifications | n_msg_specs ^= 0 | all | new) then
	     call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "No message selection arguments may be given with -last.");

	if no_messages then notifications = TRUE;
	else if no_notifications then messages = TRUE;

	if n_msg_specs = 0 then do;
		if delete & (after_sw | before_sw | comment | from | match | exclude | messages | notifications) then
		     all = TRUE;
		if delete & ^all then call ssu_$abort_line (sci_ptr, (0),
			"Usage: dlm msg_specs {mbx_specification} {-control_args}");
		if print then all = TRUE;
		n_msg_specs = n_msg_specs + 1;
		msg_spec.start (n_msg_specs) = get_msg_spec ("first", code);
		msg_spec.start_spec (n_msg_specs) = FALSE;
		msg_spec.end (n_msg_specs) = get_msg_spec ("last", code);
		msg_spec.end_spec (n_msg_specs) = FALSE;
		msg_spec.found (n_msg_specs) = FALSE;
	     end;

	if messages & notifications then messages, notifications = FALSE;

/* determine which messages are to be held */
	actual_hold_flags = ""b;
	hold_flags_ptr = addr (actual_hold_flags);
	if hold_messages then hold_flags.hold_messages = TRUE;
	else if no_hold_messages then hold_flags.hold_messages = FALSE;
	if hold_notifications then hold_flags.hold_notifications = TRUE;
	else if no_hold_notifications then hold_flags.hold_notifications = FALSE;
	if ^(hold_messages | no_hold_messages | hold_notifications | no_hold_notifications) then actual_hold_flags = DELETE_UNHELD;

	if ^path then do;
		call user_info_$whoami (person, project, "");
		dname = ">udd>" || rtrim (project) || ">" || person;
		ename = rtrim (person) || ".mbx";
		default = TRUE;
	     end;

/* get mbx ptr */
	call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code);

	if code = error_table_$noentry & default & print then do;
		call mailbox_$create (dname, ename, code);

		if code ^= 0 then call ssu_$abort_line (sci_ptr, code,
			"Creating default mailbox ^a.", pathname_ (dname, ename));

		call ioa_ ("Creating default mailbox ^a.", pathname_ (dname, ename));

		call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code);
	     end;

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

/* get prefix */
	call message_facility_$get_prefix (msgf_mbx_ptr, prefix_string, short_prefix, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

/* get mailbox mode */
	call mailbox_$get_mode_file (dname, ename, extended_mode, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

	own = substr (extended_mode, 3, 1);

/* get msg array ptr */
	call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

/* process messages */

	do idx = 1 to n_msg_specs;
	     if msg_spec.start_spec (idx) then
		if msg_spec.start (idx) = FIRST_MESSAGE then msg_spec.start (idx) = get_msg_spec ("first", code);
		else msg_spec.start (idx) = get_msg_spec ("last", code);
	     if msg_spec.end_spec (idx) then
		if msg_spec.end (idx) = FIRST_MESSAGE then msg_spec.end (idx) = get_msg_spec ("first", code);
		else msg_spec.end (idx) = get_msg_spec ("last", code);
	     if msg_spec.start (idx) > msg_spec.end (idx) then call ssu_$abort_line (sci_ptr, (0),
		     "Invalid message range. ^a", msg_spec.arg (idx));
	end;


/* print header */
	if n_messages ^= 0 & print & ^default then call ioa_ ("^[There ^[are^;is^]^;You have^s^] ^d message^[s^] in ^a.^/",
		own, (n_messages ^= 1), n_messages, (n_messages ^= 1), pathname_ (dname, ename));
	else if n_messages = 0 & ^brief & ^last then do;
		call ioa_ ("^[There are^;You have^] no interactive messages^[ in ^a^].",
		     (own & ^default), ^default, pathname_ (dname, ename));
		go to MAIN_RETURN;
	     end;

/* handle -last */
	if last then do;
		call print_message ((0), (""b));
		go to MAIN_RETURN;
	     end;

	something_done = FALSE;

	local_mi.version = MESSAGE_INFO_VERSION_1;

	do idx = 1 to n_messages;
	     if msg_array.message_id (idx) ^= ""b then do;
		     call message_facility_$read_message (msgf_mbx_ptr, msg_array.message_id (idx), sys_area_ptr, addr (local_mi), code);
		     if code = error_table_$no_message then ;
		     else if code ^= 0 then call ssu_$print_message (sci_ptr, code,
			     "While reading message ^d^[ from mailbox ^a^].", msg_array.message_number (idx), ^default, pathname_ (dname, ename));
		     else do;
			     mail_format_ptr = local_mi.message_ptr;
			     found = FALSE;
			     if ((delete & msg_array.printed (idx)) | print | force)
				& (^new | ^msg_array.printed (idx))
				& (^after_sw
				| (fixed (substr (msg_array.message_id (idx), 19, 54), 71) > after_date_time))
				& (^before_sw
				| (fixed (substr (msg_array.message_id (idx), 19, 54), 71) < before_date_time))
				& (^comment | (rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) = comment_string))
				& (^from
				| (from_match (substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2), from_string)))
				& (^messages | (messages & ^mail_format.notify))
				& (^notifications | (notifications & mail_format.notify))
				& (^match | (index (mail_format.text, rtrim (match_string)) ^= 0))
				& (^exclude
				| (index (rtrim (canon (rtrim (mail_format.text, NLSPHT), length (rtrim (mail_format.text, NLSPHT)))), rtrim (exclude_string)) = 0)) then do;
				     do jdx = 1 to n_msg_specs while (^found);
					if (msg_array.message_number (idx) >= msg_spec.start (jdx)
					     & msg_array.message_number (idx) <= msg_spec.end (jdx))
					     | ((msg_array.message_number (idx) = 0 & print & something_done) | all) then do;
						if print then call print_message (idx, msg_array.message_id (idx));
						else call message_facility_$delete_message (msgf_mbx_ptr, msg_array.message_id (idx),
							code);

						if code ^= 0 then call ssu_$print_message (sci_ptr, code,
							"While ^[deleting^;printing^] message ^d^[ in mailbox ^a^].", delete, msg_array.message_number (idx), ^default, pathname_ (dname, ename));
						else something_done = TRUE;
						msg_spec.found (jdx) = TRUE;
						found = TRUE;
					     end;
				     end;		/* jdx loop */
				end;		/* message meets specifications */
			     if mail_format_ptr ^= null () then do;
				     free mail_format in (sys_area);
				     mail_format_ptr = null ();
				end;
			end;			/* message read */
		end;				/* non-notification */
	end;					/* idx loop */

	if ^something_done then
	     if ^brief then call ssu_$print_message (sci_ptr, (0),
		     "No ^[seen ^]messages ^[to delete.^;were found that matched the selection criteria.^]", delete & ^force, delete & ^force & all);
	     else ;
	else do idx = 1 to n_msg_specs;
		if ^msg_spec.found (idx) then call ssu_$print_message (sci_ptr, (0), "No ^[seen ^]message^[s in range^] ^a found.", delete & ^force, (index (msg_spec.arg (idx), ":") ^= 0), msg_spec.arg (idx));
	     end;

	if delete & message_status then do;
		if msg_array_ptr ^= null () then free msg_array in (sys_area);

		call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code);
		if code ^= 0 then
		     call ssu_$abort_line (sci_ptr, code, "While getting message array pointer.");

		if n_messages = 0 then call ioa_ ("All messages have been deleted.");
	     end;

MAIN_RETURN:
	call cleanup_dlm;
RETURN_FROM_DLM:
	return;


/* This procedure removes control characters (except backspace, tab,
   red ribbon shift, and black ribbon shift) and canonicalizes strings
   to prevent backspacing past the front of the string. */
canon: procedure (P_string, P_string_len) returns (char (*));
	dcl     P_string		 char (*) parm;
	dcl     P_string_len	 fixed bin (21) parm;
	dcl     output_string	 char (P_string_len);

	P_string = translate (P_string, ALPHABET);
	if index (P_string, BS) ^= 0 then do;
		output_string = "";
		call canonicalize_ (addr (P_string), length (P_string), addr (output_string), P_string_len, (0));
		return (output_string);
	     end;
	else return (P_string);
     end canon;

/* This procedure parses message specifiers. */
get_msg_spec: procedure (P_arg, P_code) returns (fixed bin);
	dcl     P_arg		 char (*) parm;
	dcl     P_code		 fixed bin (35) parm;
	dcl     idx		 fixed bin;
	dcl     msg_spec               char (5);
	dcl     return_value	 fixed bin;
	dcl     (conversion, size)	 condition;

	P_code = 0;

	msg_spec = translate (P_arg, LOWERCASE, UPPERCASE);

	if msg_spec = "first" | msg_spec = "f" then do;
		if msg_array_ptr = null () | n_messages = 0 then return (FIRST_MESSAGE);
		do idx = 1 to n_messages;
		     if msg_array.message_number (idx) ^= 0 then return (msg_array.message_number (idx));
		end;
		return_value = 1;
	     end;
	else if msg_spec = "last" | msg_spec = "l" then do;
		if msg_array_ptr = null () | n_messages = 0 then return (LAST_MESSAGE);
		do idx = n_messages to 1 by -1;
		     if msg_array.message_number (idx) ^= 0 then return (msg_array.message_number (idx));
		end;
		return_value = n_messages;
	     end;
	else do;
		if P_arg = "" then go to BAD_INTEGER;
		on conversion, size go to BAD_INTEGER;
		return_value = convert (return_value, P_arg);
		revert conversion, size;
		if return_value < 1 then go to BAD_INTEGER;
	     end;

	return (return_value);

BAD_INTEGER:
	P_code = 1;
	return ((0));
     end get_msg_spec;

/* This procedure compares a user id (person.project.tag) with a from string
   (Person, .Project, or Person.Project) */
from_match: procedure (P_sender, P_from_string) returns (bit (1) aligned);
	dcl     (P_sender, P_from_string) char (*) parm;
	dcl     person		 char (22);
	dcl     project		 char (9);

	person = before (P_sender, ".");
	project = after (P_sender, ".");

	if substr (P_from_string, 1, 1) = "." then /* .Project */
	     if rtrim (P_from_string) = "." || rtrim (project) then return (TRUE);
	     else ;
	else if index (P_from_string, ".") ^= 0 then /* Person.Project */
	     if rtrim (P_from_string) = rtrim (person) || "." || rtrim (project) then return (TRUE);
	     else ;
	else /* Person */
	     if rtrim (P_from_string) = rtrim (person) then return (TRUE);
	return (FALSE);
     end from_match;

/* This procedure prints a message.  This same code is also present in
   accept_messages (-print) and message_facility_ (process_message). */
print_message: procedure (P_message_index, P_message_id);
	dcl     P_message_index	 fixed bin parm;
	dcl     P_message_id	 bit (72) aligned parm;
	dcl     last_msg		 bit (1) aligned;

	string (msg_print_flags) = ""b;

	if P_message_index = 0 then do;		/* last message */
		msg_print_flags.print_last_message = TRUE;
		last_msg = TRUE;
		local_lmi.version = LAST_MESSAGE_INFO_VERSION_1;
		call message_facility_$get_last_message_info (msgf_mbx_ptr, addr (local_lmi), code);
		if code ^= 0 then return;

		if local_lmi.last_message_id = ""b then call ssu_$abort_line (sci_ptr, (0), "No last message.");

		message_info_ptr = local_lmi.last_message_ptr;
		local_mi = message_info;
	     end;

	else do;
		last_msg = FALSE;
		on cleanup call cleanup_pm;
	     end;

	mail_format_ptr = local_mi.message_ptr;

	if last_msg then date_time = fixed (substr (local_lmi.last_message_id, 19, 54), 71);
	else date_time = fixed (substr (P_message_id, 19, 54), 71);
	call date_time_ (date_time, msg_date_time);

/* create message sender string */
	if mail_format.sent_from = before (local_mi.sender, ".") | rtrim (mail_format.sent_from) = "" then
	     message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2);
	else message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2)
		|| " (" || rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) || ")";
	authorization = get_authorization_ ();
	if ^aim_check_$greater_or_equal (local_mi.authorization, authorization) then do;
		call convert_access_class_$to_string_short (local_mi.authorization, auth_string, code);
		if auth_string = "" then auth_string = "system_low";
		message_sender = rtrim (message_sender) || " at " || auth_string;
	     end;

	if call_string ^= "" then do;
		if last_msg then call ioa_$rsnnl (" ^d ", tag, length (tag), local_lmi.last_message_number);
		else call ioa_$rsnnl (" ^d ", tag, length (tag), msg_array.message_number (P_message_index));
		if default then pathname = "";
		else pathname = requote_string_ (pathname_ (dname, ename));
		command_line = rtrim (call_string) || " " || tag || requote_string_ (rtrim (message_sender))
		     || " " || requote_string_ (rtrim (date_time_$format ("date_time", date_time, "", ""))) || " "
		     || requote_string_ (rtrim (canon (rtrim (mail_format.text, NLSPHT), length (rtrim (mail_format.text, NLSPHT))))) || " " || pathname;
		call cu_$cp (addr (command_line), length (rtrim (command_line)), (0));
	     end;

	else do;
		if message_sender = last_sender then short = TRUE;
		else short = FALSE;

/* print prefix, it may contain ioa_ controls */
		if ^short | short_prefix then msg_print_flags.print_prefix = TRUE;

/* if not default mailbox, prefix with mailbox entry name */
		if ^default then msg_print_flags.print_ename = TRUE;

		if ^short_format | ^short then
		     msg_print_flags.print_sender = TRUE;

		if ^short_format | substr (msg_date_time, 1, 8) ^= last_msg_time then
		     msg_print_flags.print_date_and_time = TRUE;
		else if date_time - last_time > FIVE_MINUTES then
		     msg_print_flags.print_time = TRUE;

		last_sender = message_sender;
		last_time = date_time;
		last_msg_time = substr (msg_date_time, 1, 8);

		call message_facility_$print_message (msgf_mbx_ptr, iox_$user_output, P_message_id, addr (msg_print_flags), code);
	     end;

	if ^last_msg then do;
		call message_facility_$set_seen_switch (msgf_mbx_ptr, P_message_id, actual_hold_flags, (0));
		if mail_format_ptr ^= null () then do;
			free mail_format in (sys_area);
			mail_format_ptr = null ();
		     end;
	     end;
     end print_message;


cleanup_dlm: proc;
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	if msg_array_ptr ^= null () then free msg_array in (sys_area);
	return;
     end cleanup_dlm;

abort_dlm: proc;
	call cleanup_dlm;
	go to RETURN_FROM_DLM;
     end abort_dlm;

cleanup_pm: proc;
	if mail_format_ptr ^= null () then free mail_format in (sys_area);
     end cleanup_pm;

%page;
%include last_message_info;
%page;
%include mail_format;
%page;
%include message_info;
%page;
%include mlsys_parse_ca_options;
%page;
%include msg_array;
%page;
%include msg_print_flags;

     end delete_message;




		    last_message_info.pl1           06/30/86  1407.4r w 06/30/86  1344.2       66690



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* This module implements the following command/active functions:

      last_message_sender (lms) - print/return the user ID of the
         last message sender.
      last_message_time (lmt) - print/return the date/time of the last
         message.
      last_message (lm) - print/return the last message.
*/
/* Written 05/30/84 by Jim Lippard */
last_message_info: procedure options (variable);
	return;					/* not an entry */

	dcl     ME		 char (19);
	dcl     VERSION		 char (3) internal static options (constant) init ("1.0");

	dcl     com_err_		 entry () options (variable);

	dcl     date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);

	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));

	dcl     ioa_		 entry () options (variable);

	dcl     mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35));

	dcl     message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35));
	dcl     message_facility_$get_last_message_info entry (ptr, ptr, fixed bin (35));

	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

	dcl     requote_string_	 entry (char (*)) returns (char (*));

	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     ssu_$return_arg	 entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21));
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

	dcl     user_info_$whoami	 entry (char (*), char (*), char (*));

	dcl     cleanup		 condition;

	dcl     active_function	 bit (1) aligned;

	dcl     arg_count		 fixed bin;
	dcl     arg_ptr		 ptr;
	dcl     arg_len		 fixed bin (21);
	dcl     arg		 char (arg_len) based (arg_ptr);

	dcl     dname		 char (168);
	dcl     ename		 char (32);

	dcl     idx		 fixed bin;

	dcl     inhibit_error	 bit (1) aligned;

	dcl     1 local_lmi		 aligned like last_message_info;

	dcl     1 local_pcao	 aligned like parse_ca_options;

	dcl     msgf_mbx_ptr	 ptr;

	dcl     msg_time		 char (250) var;

	dcl     path		 bit (1) aligned;

	dcl     person		 char (22);
	dcl     project		 char (9);

	dcl     return_ptr		 ptr;
	dcl     return_len		 fixed bin (21);
	dcl     return_arg		 char (return_len) varying based (return_ptr);

	dcl     sci_ptr		 ptr;

	dcl     (addr, fixed, length, null, rtrim, substr) builtin;

	dcl     TRUE		 bit (1) aligned internal static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) aligned internal static options (constant) init ("0"b);

	dcl     LFHTSP		 char (3) internal static options (constant) init ("
	 ");

	dcl     code		 fixed bin (35);

	dcl     error_table_$noarg	 fixed bin (35) ext static;

last_message_sender: lms: entry;
	ME = "last_message_sender";
	go to COMMON;

last_message_time: lmt: entry;
	ME = "last_message_time";
	go to COMMON;

last_message: lm: entry;
	ME = "last_message";

COMMON:

/* initialize variables */
	inhibit_error, path = FALSE;
	sci_ptr = null ();

	on cleanup call cleanup_lmi;

/* create ssu_ invocation */
	call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_lmi, code);

	if code ^= 0 then do;
		call com_err_ (code, ME, "Creating standalone subsystem invocation.");
		return;
	     end;

/* process arguments */
	call ssu_$return_arg (sci_ptr, arg_count, active_function, return_ptr, return_len);

	do idx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
	     if arg = "-inhibit_error" | arg = "-ihe" then inhibit_error = TRUE;
	     else if arg = "-pathname" | arg = "-pn" then do;
		     idx = idx + 1;
		     if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A pathname must be specified after ""^a"".", arg);

		     if path then call ssu_$abort_line (sci_ptr, (0),
			     "Usage: ^[lms^;^[lmt^;lm^]^] {mbx_specification}", (ME = "last_message_sender"), (ME = "last_message_time"));

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
		     call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     path = TRUE;
		end;
	     else do;
						/* let mlsys_utils_ have at it */
		     local_pcao.version = PARSE_CA_OPTIONS_VERSION_1;
		     local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX;
		     local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX;
		     local_pcao.abort_on_errors = TRUE;
		     local_pcao.validate_addresses = FALSE;
		     local_pcao.mbz = ""b;

		     call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao), dname, ename, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code);

		     idx = idx - 1;

		     if path then call ssu_$abort_line (sci_ptr, (0),
			     "Usage: ^[lms^;^[lmt^;lm^]^] {mbx_specification}", (ME = "last_message_sender"), (ME = "last_message_time"));

		     path = TRUE;
		end;
	end;

	if ^path then do;
		call user_info_$whoami (person, project, "");
		dname = ">udd>" || rtrim (project) || ">" || person;
		ename = rtrim (person) || ".mbx";
	     end;

	call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

	local_lmi.version = LAST_MESSAGE_INFO_VERSION_1;

	call message_facility_$get_last_message_info (msgf_mbx_ptr, addr (local_lmi), code);

	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

	if local_lmi.last_message_id = ""b then do;
		if ^inhibit_error then call ssu_$abort_line (sci_ptr, (0), "No last message.");
		else if active_function then return_arg = "";
		go to MAIN_RETURN;
	     end;

	message_info_ptr = local_lmi.last_message_ptr;

	if ME = "last_message_sender" then do;
		if active_function then return_arg =
			requote_string_ (substr (message_info.sender, 1, length (rtrim (message_info.sender)) - 2));
		else call ioa_ ("^a", substr (message_info.sender, 1, length (rtrim (message_info.sender)) - 2));
	     end;

	else if ME = "last_message_time" then do;
		msg_time = date_time_$format ("date_time", fixed (substr (local_lmi.last_message_id, 19, 54), 71), "", "");
		if active_function then return_arg = requote_string_ ((msg_time));
		else call ioa_ ("^a", msg_time);
	     end;

	else if ME = "last_message" then do;
		mail_format_ptr = message_info.message_ptr;
		if active_function then return_arg = requote_string_ (rtrim (mail_format.text, LFHTSP));
		else call ioa_ ("^a", rtrim (mail_format.text, LFHTSP));
	     end;

MAIN_RETURN:
	call cleanup_lmi;
RETURN_FROM_LMI:
	return;

cleanup_lmi: proc;
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	return;
     end;

abort_lmi: proc;
	call cleanup_lmi;
	go to RETURN_FROM_LMI;
     end abort_lmi;

%page;
%include last_message_info;
%page;
%include mail_format;
%page;
%include message_info;
%page;
%include mlsys_parse_ca_options;
     end last_message_info;




		    mail.pl1                        05/20/87  1526.9rew 05/20/87  1423.2      261972



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(86-06-02,Herbst), approve(86-06-02,MCR7432), audit(86-06-30,Wong),
     install(86-06-30,MR12.0-1080):
     Fixed to zero unused portions of mail_format.
  2) change(87-02-26,Lippard), approve(87-03-18,MECR0001),
     audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002):
     Modified to strip control characters from message comment field.
  3) change(87-05-08,Lippard), approve(87-04-20,MCR7669),
     audit(87-05-11,Fawcett), install(87-05-20,MR12.1-1032):
     Formal installation to close out MECR0001.
                                                   END HISTORY COMMENTS */


mail: ml: proc;

/* Usage:
   mail					to read own mail
   mail -path-				to read any mail
   mail  path  user1_ proj1_ ... user_i proj_i		to send a segment
   mail   *    user1_ proj1_ ... user_i proj_i		to send console input

   Mailbox names end in ".mbx"	*/


/* -notify and -no_notify added 7/27/78 by S. Herbst */
/* Modified: 1 May 1985 by G. Palter to remove reference to mseg_hdr.incl.pl1 */

% include mail_format;	/* this based structure should call the ASCII part "text" */
dcl 1 send_mail_info aligned,				/* structure for sending acknowledgement message */
    2 version fixed bin,				/* = 1 */
    2 from char (32) aligned,
    2 switches,
      3 wakeup bit (1) unal,
      3 mbz1 bit (1) unal,
      3 always_add bit (1) unal,
      3 never_add bit (1) unal,
      3 mbz2 bit (1) unal,
      3 acknowledge bit (1) unal,
      3 mbz bit (30) unal;

dcl  area area based (areap);

dcl  segment char (4096) based (segp);
dcl  page char (4096) aligned;
dcl  node_space (48) ptr aligned;			/* space for first 24 deletion nodes */

dcl  alphabet char (256) init				/* alphabetics plus BS HT NL RRS BRS */
    ((8)" " || "	
" || (3)" " || "" || (16)" " || substr (collate (), 33));
dcl  BS char (1) internal static options (constant) init ("");
dcl (buffer, dn) char (168);
dcl (en, last_sender, last_sent_from, sender, sender_name) char (32);
dcl  atime char (24);
dcl (match_person, match_project) char (32) init ("*");
dcl (exclude_person, exclude_project) char (32) init (".");
dcl  name char (22);
dcl  proj char (9);
dcl  vname char (22) varying;
dcl  vproj char (9) varying;
dcl  last_date char (8);
dcl  command char (7);
dcl  answer char (3) varying;
dcl  s char (1) init ("");
dcl  nlx char (1);
dcl  newline char (1) init ("
");

dcl  arg char (al) based (ap);

dcl  node (24) char (16) aligned based (stack_ptr);	/* deletion nodes */

dcl  stack_bits bit (3456) aligned based (stack_ptr);
dcl  clock bit (54) aligned;
dcl  exmode bit (36) aligned;
dcl (acknowledge,					/* request acknowledgement when sending */
     brief,					/* -brief option when reading */
     head_mode,					/* -header mode when reading */
     dont_print_count,
     console,					/* sending console input */
     got_input,					/* already copied into "page" */
     more,					/* more input in input mode */
     my_mbx,					/* reading from user's own mailbox */
     notify_sw,					/* send notification with the mail */
     own,						/* reading own messages */
     path_sw,					/* read mail by pathname */
     pdir_flag,					/* save mail in process directory */
     printing,					/* printing mail */
     salvaged,					/* mailbox was salvaged */
     saved,					/* already saved in unsent_mail */
     seg_initiated)					/* initiated a segment to send */
     bit (1) aligned init ("0"b);

dcl (al, anonymous, arg_count, argno, chars, header_length, i, msg_bitcnt, nlines) fixed bin;
dcl (count, mseg_index) fixed bin init (0);
dcl  node_index fixed bin init (0);
dcl (last_type, interactive init (1), mail_type init (2)) fixed bin;
dcl (five_minutes, last_time, time) fixed bin (71);
dcl  bitcnt fixed bin (24);
dcl  j fixed bin (21);
dcl  mode fixed bin (5);
dcl  chase fixed bin (1) init (1);

dcl (ap, argp, idp, node_ptr) pointer;
dcl (areap, mbxp, segp) pointer init (null);
dcl  stack_ptr ptr;

dcl 1 id_node aligned based,
    2 next pointer aligned,
    2 delete_id bit (72) aligned;			/* message id saved for deletion */

dcl 1 mseg_return_args aligned,
    2 msg_ptr pointer,				/* -> returned message */
    2 bitcnt fixed bin (18),				/* bit count of message */
    2 sender_id char (32),				/* sender's group id */
    2 level fixed bin,				/* validation level */
    2 id bit (72),					/* loc_and_time */
    2 sender_authorization bit (72),
    2 access_class bit (72);

dcl 1 query_info aligned internal static,
    2 vsn fixed bin init (1),
    2 yes_or_no_sw bit (1) unaligned init ("1"b),
    2 suppress_name_sw bit (1) unaligned init ("0"b),
    2 status_code fixed bin (35) init (0),
    2 query_code fixed bin (35) init (0);

dcl  canonicalize_ entry (ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35));
dcl  com_err_ entry options (variable);
dcl  command_query_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$grow_stack_frame entry (fixed bin, ptr, fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  get_pdir_ entry returns (char (168)aligned);
dcl  get_wdir_ entry returns (char (168)aligned);
dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35));
dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$user_input pointer external;
dcl  iox_$user_output pointer external;
dcl  send_mail_ entry (char (*)aligned, char (*)aligned, ptr, fixed bin (35));
dcl  send_message_$notify_mail entry (char (*), char (*), fixed bin (35));
dcl  user_info_ entry (char (*));
dcl  user_info_$login_data entry (char (*), char (*), char (*), fixed bin);
dcl  mailbox_$add_index entry (fixed bin, ptr, fixed bin, bit (72)aligned, fixed bin (35));
dcl  mailbox_$check_salv_bit_index entry (fixed bin, bit (1)aligned, bit (1)aligned, fixed bin (35));
dcl  mailbox_$close entry (fixed bin (17), fixed bin (35));
dcl  mailbox_$create entry (char (*), char (*), fixed bin (35));
dcl  mailbox_$delete_index entry (fixed bin, bit (72)aligned, fixed bin (35));
dcl  mailbox_$get_mode_index entry (fixed bin, bit (*)aligned, fixed bin (35));
dcl  mailbox_$incremental_read_index entry (fixed bin, ptr, bit (2), bit (72)aligned, ptr, fixed bin (35));
dcl  mailbox_$open entry (char (*), char (*), fixed bin, fixed bin (35));
dcl  mailbox_$open_if_full entry (char (*), char (*), bit (1) aligned,
     fixed bin (17), fixed bin (17), fixed bin (35));
dcl  mailbox_$own_incremental_read_index entry (fixed bin, ptr, bit (2), bit (72)aligned, ptr, fixed bin (35));
dcl  mailbox_$own_read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35));
dcl  mailbox_$read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35));
dcl  mailbox_$update_message_index entry (fixed bin, fixed bin, bit (72)aligned, ptr, fixed bin (35));


dcl  code fixed bin (35);
dcl  error_table_$bad_segment fixed bin (35) external;
dcl  error_table_$badopt fixed bin (35) external;
dcl  error_table_$long_record fixed bin (35) external;
dcl  error_table_$moderr fixed bin (35) external;
dcl  error_table_$noentry fixed bin (35) external;
dcl  error_table_$no_message fixed bin (35) external;
dcl  error_table_$root fixed bin (35) ext;
dcl  error_table_$rqover fixed bin (35) external;

dcl (cleanup, no_write_permission, program_interrupt, record_quota_overflow) condition;

dcl (addr, bin, collate, divide, fixed, index, length, min, null) builtin;
dcl (rel, reverse, rtrim, search, size, substr, translate, unspec, verify) builtin;
						/*  */
	mail_format_ptr = null;
	on condition (cleanup) call mail_cleanup;
	command = "mail";
	call cu_$arg_count (arg_count);
	buffer = "";
	path_sw = "0"b;
	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, ap, al, code);
	     if substr (arg, 1, 1) = "-" then
		if arg = "-brief" | arg = "-bf" then brief = "1"b;
		else if arg = "-header" | arg = "-he" then head_mode = "1"b;
		else if arg = "-match" then do;
		     dont_print_count = "1"b;
		     i = i + 1;
		     if i>arg_count then do;
			call com_err_ (0, command, "No value specified for -match");
			return;
		     end;
		     call cu_$arg_ptr (i, ap, al, code);
		     j = index (arg, ".");
		     if j = 0 then match_person = arg;
		     else do;
			match_person = substr (arg, 1, j-1);
			match_project = substr (arg, j+1);
		     end;
		end;
		else if arg = "-exclude" | arg = "-ex" then do;
		     dont_print_count = "1"b;
		     i = i + 1;
		     if i>arg_count then do;
			call com_err_ (0, command, "No value specified for -exclude");
			return;
		     end;
		     call cu_$arg_ptr (i, ap, al, code);
		     j = index (arg, ".");
		     if j = 0 then exclude_person = arg;
		     else do;
			exclude_person = substr (arg, 1, j-1);
			exclude_project = substr (arg, j+1);
		     end;
		end;
		else if arg = "-acknowledge" | arg = "-ack" then go to SEND;
		else if arg = "-notify" | arg = "-nt" then go to SEND;
		else if arg = "-no_notify" | arg = "-nnt" then go to SEND;
		else if arg = "-pathname" | arg = "-pn" then do;
		     if buffer ^= "" then go to SEND;
		     i = i+1;
		     if i>arg_count then do;
			call com_err_ (0, command, "No value specified for -pathname");
			return;
		     end;
		     call cu_$arg_ptr (i, ap, al, code);
		     buffer = arg;
		     path_sw = "1"b;
		end;
		else do;
		     call com_err_ (error_table_$badopt, command, "^a", arg);
		     return;
		end;
	     else if buffer ^= "" then go to SEND;
	     else buffer = arg;
	end;
	if buffer = "" then do;

/* Read from default mailbox */

READ:	     my_mbx = "1"b;
	     bitcnt = 0;
	     call user_info_$login_data (name, proj, "", anonymous);
	     if anonymous = 1 then do;		/* anonymous user */
		dn = ">udd>" || rtrim (proj) || ">anonymous";
		en = "anonymous.mbx";
	     end;
	     else do;
		dn = ">udd>" || rtrim (proj) || ">" || name;
		en = rtrim (name) || ".mbx";
	     end;
	     call mailbox_$open_if_full (dn, en, salvaged, count, mseg_index, code);
	     if code = error_table_$noentry then do;

/* Create a new mailbox */

		on condition (record_quota_overflow) begin;
		     call com_err_ (error_table_$rqover, command, "Unable to create default mailbox.");
		     go to RETURN;
		end;

		call mailbox_$create (dn, en, code);
		if code ^= 0 then do;
		     call com_err_ (code, command, "Unable to create default mailbox.");
		     go to RETURN;
		end;

		revert condition (record_quota_overflow);

		call ioa_ ("^a>^a created. No mail.", dn, en);
		return;
	     end;
	end;
	else do;

/* Read from specified mailbox */

	     if buffer = ">" then do;
		code = error_table_$root;
		go to ERROR2;
	     end;
	     else if search (buffer, "<>") ^= 0 | path_sw then do; /* mbx pathname */
		call expand_pathname_$add_suffix (buffer, "mbx", dn, en, code);
		if code ^= 0 then go to ERROR2;
	     end;
	     else do;				/* Person.Project destination */
		i = index (buffer, ".");
		if i = 0 then do;
		     call com_err_ (0, command, "No project specified for ^a", buffer);
		     return;
		end;
		call ioa_$rsnnl (">udd>^a>^a", dn, 168, substr (buffer, i+1), substr (buffer, 1, i-1));
		en = substr (buffer, 1, i-1)||".mbx";
	     end;
	     call mailbox_$open_if_full (dn, en, salvaged, count, mseg_index, code);
	end;

	if code ^= 0 & (code ^= error_table_$moderr | mseg_index = 0) then go to ERROR1;

	if salvaged then do;
	     if my_mbx then call mailbox_$check_salv_bit_index (mseg_index, "1"b, salvaged, code);
	     call ioa_ ("Mailbox ^a^[>^]^a has been salvaged since mail was last read.
Messages may have been lost.", dn, dn ^= ">", en);
	end;
	if code = 0 then do;
	     if count = 0 then do;
		if ^brief then
		     call ioa_ ("No mail.");
		go to CLOSE;
	     end;
	     if count>1 then s = "s";			/* plural */
	     if ^dont_print_count then
		call ioa_ ("^d message^a.", count, s);
	     if brief then go to CLOSE;
	end;

	areap = get_system_free_area_ ();
	argp = addr (mseg_return_args);

	call mailbox_$read_index (mseg_index, areap, "0"b, argp, code); /* read earliest message first */
	if code ^= 0 then
	     if code = error_table_$no_message then do;
		if ^brief then call ioa_ ("No mail.");
		go to CLOSE;
	     end;
	     else if code = error_table_$moderr then own = "1"b;
	     else go to ERROR1;

	if own then do;
	     call mailbox_$own_read_index (mseg_index, areap, "0"b, argp, code);
	     if code ^= 0 then if code = error_table_$no_message then do;
		     if ^brief then call ioa_ ("You have no messages in ^a^[>^]^a.", dn, dn ^= ">", en);
		     go to CLOSE;
		end;
		else go to ERROR1;
	     else if brief then do;
		call ioa_ ("You have messages in ^a^[>^]^a", dn, dn ^= ">", en);
		go to CLOSE;
	     end;
	     else call ioa_ ("^/Your messages:^/");
	end;

	printing = "1"b;

	on condition (program_interrupt) begin;		/* pi turns off printing */
	     printing = "0"b;
	     go to REMEMBER;
	end;

	last_type = mail_type;			/* initialize some variables */
	last_sender, last_date = "";
	last_time = 0;
	five_minutes = (3*10**8)* (2**18);
	idp, stack_ptr = addr (node_space);
	idp -> stack_bits = "0"b;

	do count = 1 by 1 while (code = 0);		/* if a message is deleted while in this loop,
						   all messages after it won't get printed.
						   They will appear with next "mail". */
	     mail_format_ptr = msg_ptr;

	     if ^printing then go to REMEMBER;

	     clock = substr (id, 19, 54);
	     unspec (time) = clock;
	     call date_time_ (bin (clock, 71), atime);
	     if lines ^= 1 then s = "s";
	     else s = "";
	     i = index (mseg_return_args.sender_id, " "); /* remove instance tag */
	     if i = 0 then i = 33;
	     sender = substr (mseg_return_args.sender_id, 1, i-3);
	     j = index (sender, ".");
	     if exclude_person = "*" | exclude_person = substr (sender, 1, j-1) then go to RNEXT;
	     if exclude_project = "*" | exclude_project = substr (sender, j+1) then go to RNEXT;
	     if match_person ^= "*" & match_person ^= substr (sender, 1, j-1) then go to RNEXT;
	     if match_project ^= "*" & match_project ^= substr (sender, j+1) then go to RNEXT;
	     if head_mode then nlx = ""; else nlx = newline;

	     if mail_format.wakeup then do;		/* interractive message */
		if last_type = mail_type then do;
		     call ioa_ ("");
		     last_sender = "";
		end;
		if sender = last_sender & sent_from = last_sent_from & ^head_mode then do;
		     if time-last_time>five_minutes then
			if substr (atime, 1, 8) ^= last_date then call ioa_$nnl ("=:(^a) ", atime);
			else call ioa_$nnl ("=:(^a) ", substr (atime, index (atime, ".")-4, 6));
		     else call ioa_$nnl ("=: ");
		end;
		else if sent_from = "" | sent_from = sender
		| sent_from = substr (sender, 1, length (sender)-index (reverse (sender), ".")) then
		     call ioa_ ("^aMessage from ^a  ^a:", nlx, sender, atime);
		else call ioa_ ("^aMessage from ^a (^a)  ^a:", nlx, sender, rtrim (canon (rtrim (sent_from), length (rtrim (sent_from)))), atime);
		last_type = interactive;
		last_sender = sender;
		last_sent_from = sent_from;
		last_time = time;
		last_date = substr (atime, 1, 8);
	     end;

	     else do;
		last_type = mail_type;
		if sent_from = "" | sent_from = sender
		| sent_from = substr (sender, 1, length (sender)-index (reverse (sender), "."))
		then call ioa_ ("^a^d) From: ^a  ^a^[ (^d line^a)^;^s^s^]^a",
		     nlx, count, sender, atime, (lines > 0), lines, s, nlx);
		else call ioa_ ("^a^d) From: ^a (^a)  ^a^[ (^d line^a)^;^2s^]^a",
		     nlx, count, rtrim (canon (rtrim (sent_from), length (rtrim (sent_from)))), sender, atime, (lines > 0), lines, s, nlx);
	     end;

/* Print the message */

	     if ^head_mode then do;
		i = 1;
		do while (i <= mail_format.text_len);
		     j = min (mail_format.text_len-i+1, length (buffer));
		     buffer = rtrim (canon (substr (mail_format.text, i, j), length (substr (mail_format.text, i, j))));
		     call iox_$put_chars (iox_$user_output, addr (buffer), j, code);
		     i = i+j;
		end;
		if substr (buffer, j, 1) ^= newline then call ioa_ ("");

/* Acknowledge the message */

		if mail_format.acknowledge then do;

		     send_mail_info.version = 1;
		     send_mail_info.from = "";
		     send_mail_info.wakeup = "1"b;
		     send_mail_info.mbz1 = "0"b;
		     send_mail_info.always_add = "1"b;
		     send_mail_info.never_add = "0"b;
		     send_mail_info.mbz2 = "0"b;
		     send_mail_info.acknowledge = "0"b;
		     send_mail_info.mbz = "0"b;
		     clock = substr (mseg_return_args.id, 19, 54);
		     unspec (time) = clock;
		     call date_time_ (bin (clock, 71), atime);
		     i = length (mseg_return_args.sender_id)+1-verify (reverse (mseg_return_args.sender_id), " ");

		     call send_mail_ (substr (mseg_return_args.sender_id, 1, i-2),
			"Acknowledge message of "||atime, addr (send_mail_info), code);

		     mail_format.acknowledge = "0"b;	/* turn off acknowledge bit in message */
		     call mailbox_$update_message_index (mseg_index,
			36 * (fixed (rel (addr (mail_format.text)))-fixed (rel (addr (mail_format.version)))),
			mseg_return_args.id, mseg_return_args.msg_ptr, code);
		end;
	     end;

/* Remember to delete later */

REMEMBER:	     if ^head_mode then do;
		call get_id_node;
		idp -> id_node.next = node_ptr;
		idp = node_ptr;
		idp -> id_node.next = null;
		idp -> id_node.delete_id = id;
	     end;

/* Read the next message */

RNEXT:	     free mail_format in (area);

	     if own then call mailbox_$own_incremental_read_index (mseg_index, areap, "01"b, id, argp, code);
	     else call mailbox_$incremental_read_index (mseg_index, areap, "01"b, id, argp, code);

	end;

	revert condition (program_interrupt);
	on condition (program_interrupt) go to QUERY;

	if code ^= error_table_$no_message then go to ERROR1;

QUERY:	if node_index = 0 then answer = "no";
	else call command_query_ (addr (query_info), answer, command, "Delete?");
	revert condition (program_interrupt);
	if answer ^= "yes" then go to CLOSE;

	count = 0;
	idp = addr (node_space);
	do while (idp ^= null);
	     count = count+1;
	     call mailbox_$delete_index (mseg_index, idp -> id_node.delete_id, code);
	     if code ^= 0 then do;
		call com_err_ (code, command, "Message ^d not deleted.", count);
		code = 0;
	     end;
	     idp = idp -> id_node.next;
	end;

	go to CLOSE;
						/*  */
/* Send mail */

SEND:	notify_sw = "1"b;
	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, ap, al, code);
	     if substr (arg, 1, 1) = "-" then		/* look for control arguments */
		if arg = "-acknowledge" | arg = "-ack" then acknowledge = "1"b;
		else if arg = "-notify" | arg = "-nt" then notify_sw = "1"b;
		else if arg = "-no_notify" | arg = "-nnt" then notify_sw = "0"b;
		else if arg ^= "-pathname" & arg ^= "-pn" then do;
		     call com_err_ (error_table_$badopt, "mail", "^a", arg);
		     return;
		end;
	end;

	on condition (record_quota_overflow) begin;	/* from adding a message */
	     call com_err_ (error_table_$rqover, command,
		"Unable to add message to mailbox ^a^[>^]^a", dn, dn ^= ">", en);
	     call save;
	     go to RETURN;
	end;

	argno = 1;
GET_PATH:	call cu_$arg_ptr (argno, ap, al, code);
	argno = argno+1;
	if substr (arg, 1, 1) = "-" then go to GET_PATH;
	buffer = arg;
	if buffer = ">" then do;
	     code = error_table_$root;
	     go to ERROR2;
	end;
	text_length = 0;
	mail_format_ptr = null;
	call user_info_ (sender_name);

SEND_LOOP:
	call cu_$arg_ptr (argno, ap, al, code);
	if code ^= 0 then do;			/* Normal exit - no more destinations */
CLEANUP:	     call mail_cleanup;
	     return;
	end;
	if substr (arg, 1, 1) = "-" then
	     if arg = "-pathname" | arg = "-pn" then do;
		argno = argno + 1;
		call cu_$arg_ptr (argno, ap, al, code);
		if code ^= 0 then do;
		     call com_err_ (0, command, "No value specified for -pathname");
		     return;
		end;
		call expand_pathname_$add_suffix (arg, "mbx", dn, en, code);
		if code ^= 0 then do;
		     call com_err_ (code, command, "^a", arg);
		     return;
		end;
		go to OPEN;
	     end;
	     else do;
		argno = argno+1;
		go to SEND_LOOP;
	     end;
	i = index (arg, ".");
	if i ^= 0 then do;				/* Person.Project destination */
	     argno = argno-1;
	     name, vname = substr (arg, 1, i-1);
	     proj, vproj = substr (arg, i+1);
	end;
	else do;
	     name, vname = arg;
GET_PROJ:	     call cu_$arg_ptr (argno+1, ap, al, code);
	     if code ^= 0 then do;
NO_PROJ:		call com_err_ (0, command, "No project name specified for ^a.", vname);
		call save;
		return;
	     end;
	     if substr (arg, 1, 1) = "-" then
		if arg = "-pathname" | arg = "-pn" then go to NO_PROJ;
		else do;
		     argno = argno+1;
		     go to GET_PROJ;
		end;
	     proj, vproj = arg;			/* project id for concatenating */
	end;
	en = vname || ".mbx";
	dn = ">udd>" || vproj || ">" || vname;

OPEN:	call mailbox_$open (dn, en, mseg_index, code);	/* get index of mailbox */
	if code ^= 0 then do;
	     call com_err_ (code, command, "^a^[>^]^a", dn, dn ^= ">", en);
	     call save;
	     go to NEXT;
	end;
	else do;
	     call mailbox_$get_mode_index (mseg_index, exmode, code); /* get effective access to mailbox */
	     if ^substr (exmode, 1, 1) then do;		/* no "a" access */
		call com_err_ (0, command,
		     "Insufficient access to send to ^a^[>^]^a", dn, dn ^= ">", en);
		call save;
		go to NEXT;
	     end;
	end;

	if ^got_input then do;			/* copy the message in once */

	     areap = get_system_free_area_ ();

	     nlines = 0;
	     if buffer = "*" then do;			/* console input */
		console = "1"b;
		got_input = "1"b;
		segp = addr (page);

		on condition (program_interrupt) begin; /* pi saves what is typed so far and quits */
		     call save;
		     go to CLOSE;
		end;

		call ioa_ ("Input:");

		more = "1"b;
		do while (more);
		     call iox_$get_line (iox_$user_input, addr (buffer), 168, j, code);
		     if code ^= 0 then if code ^= error_table_$long_record then do;
			     call save;
			     buffer = "user_input";
			     go to ERROR2;
			end;

		     if j = 2 & substr (buffer, 1, 1) = "." then more = "0"b; /* dot ends input mode */
		     else do;
			if text_length+j>4096 then do;
			     call com_err_ (0, command, "Message cannot be longer than 1 record.");
			     call save;
			     return;
			end;
			if code ^= error_table_$long_record then nlines = nlines + 1;
			substr (segp -> segment, text_length+1, j) = substr (buffer, 1, j); /* copy the line in */
			text_length = text_length+j;
		     end;
		end;

		revert condition (program_interrupt);
		if nlines = 0 then return;
		bitcnt = text_length*9;
	     end;
	     else do;				/* input is a segment */
		got_input = "1"b;
		call expand_pathname_ (rtrim (buffer), dn, en, code);
		if code ^= 0 then go to ERROR2;

		call hcs_$initiate_count (dn, en, "", bitcnt, 1, segp, code);
		if segp = null then go to ERROR1;

		seg_initiated = "1"b;

		call hcs_$fs_get_mode (segp, mode, code); /* see if access to read */
		if mode<1000b then if code = 0 then do;
			call com_err_ (0, command, "Need ""r"" access to ^a^[>^]^a", dn, dn ^= ">", en);
			call hcs_$terminate_noname (segp, code);
			go to CLOSE;
		     end;
		text_length = divide (bitcnt+8, 9, 17, 0);
		chars = text_length;
		if text_length>4096 then do;
		     call com_err_ (0, command, "Message cannot be longer than 1 record.");
		     go to CLOSE;
		end;
		count = 1;
NL_LOOP:		i = index (substr (segp -> segment, count, chars), newline);
		if i>0 then do;
		     count = count+i;
		     chars = chars-i;
		     nlines = nlines+1;		/* count newlines in input segment */
		     go to NL_LOOP;
		end;
	     end;
	end;

	allocate mail_format in (area) set (mail_format_ptr);
	header_length = size (mail_format)-divide (text_length, 4, 17, 0);
	mail_format.version = MAIL_FORMAT_VERSION_4;
	mail_format.sent_from = sender_name;		/* login name */
	mail_format.lines = nlines;
	mail_format.acknowledge = acknowledge;
	mail_format.wakeup, mail_format.urgent, mail_format.seen, mail_format.others = "0"b;
	mail_format.text = substr (segp -> segment, 1, text_length);
	msg_bitcnt = bitcnt+36*header_length;		/* total bit count includes header */

	call mailbox_$add_index (mseg_index, mail_format_ptr, msg_bitcnt, id, code); /* try to add the message */
	if code ^= 0 then
	     if code = error_table_$bad_segment then go to ERROR1;
	     else do;
		call com_err_ (code, command,
		     "Unable to add message to mailbox ^a^[>^]^a", dn, dn ^= ">", en);
		call save;
	     end;

	else if notify_sw then call send_message_$notify_mail (name, proj, code); /* send notification */

NEXT:	argno = argno+2;				/* on to the next pair */
	call mailbox_$close (mseg_index, code);
	go to SEND_LOOP;
						/*  */
						/* save a message in working_dir>unsent_mail */

save:	proc;

	     if saved then return;			/* do not save twice */
	     if ^console | ^got_input then return;
	     if text_length = 0 then return;
	     saved = "1"b;
	     dn = get_wdir_ ();

	     on condition (record_quota_overflow) begin;	/* from unsent_mail */
		call hcs_$delentry_file (dn, "unsent_mail", code);
		if ^pdir_flag then go to TRY_PDIR;
		call com_err_ (error_table_$rqover, command,
		     "Unable to save message in unsent_mail.");
		go to CLEANUP;
	     end;

CREATE:	     call hcs_$make_seg (dn, "unsent_mail", "", 1011b, mbxp, code);
	     if mbxp = null then do;
		if ^pdir_flag then go to TRY_PDIR;
		call com_err_ (code, command, "Unable to save message in unsent_mail.");
		go to CLOSE;
	     end;

	     on condition (no_write_permission) begin;
		if ^pdir_flag then go to TRY_PDIR;
	     end;

	     substr (mbxp -> segment, 1, text_length) = substr (segp -> segment, 1, text_length);

	     bitcnt = text_length*9;
	     call hcs_$set_bc_seg (mbxp, bitcnt, code);

	     if pdir_flag then call ioa_ ("Text was saved in unsent_mail in process directory.");
	     else call ioa_ ("Text was saved in unsent_mail.");

	     return;


TRY_PDIR:	     pdir_flag = "1"b;
	     dn = get_pdir_ ();
	     go to CREATE;

	end save;
						/*  */
ERROR1:	if code = error_table_$bad_segment then do;
	     call com_err_ (code, command,
		"^a^[>^]^a^/Mailbox has been salvaged. Try again.", dn, dn ^= ">", en);
	     call save;
	end;
	else call com_err_ (code, command, "^a^[>^]^a", dn, dn ^= ">", en);
	go to CLOSE;

ERROR2:	call com_err_ (code, command, "^a", buffer);

CLOSE:	if ^my_mbx & mseg_index ^= 0 then call mailbox_$close (mseg_index, code);
	if seg_initiated then call hcs_$terminate_noname (segp, code);

RETURN:	return;


/* This procedure removes control characters (except backspace, tab,
   red ribbon shift, and black ribbon shift) and canonicalizes strings
   to prevent backspacing past the front of the string. */
canon: procedure (P_string, P_string_len) returns (char (*));
	dcl     P_string		 char (*) parm;
	dcl     P_string_len	 fixed bin (21) parm;
	dcl     output_string	 char (P_string_len);

	P_string = translate (P_string, alphabet);
	if index (P_string, BS) ^= 0 then do;
		output_string = "";
		call canonicalize_ (addr (P_string), length (P_string), addr (output_string), P_string_len, (0));
		return (output_string);
	     end;
	else return (P_string);
     end canon;

get_id_node: proc;

	     node_index = node_index+1;
	     if node_index>24 then do;		/* allocate another block of 24 */
		call cu_$grow_stack_frame (96, stack_ptr, code);
		stack_bits = "0"b;
		node_index = 1;
	     end;
	     node_ptr = addr (node (node_index));

	end get_id_node;


mail_cleanup: proc;

	     if mail_format_ptr ^= null then free mail_format in (area);
	     if mbxp ^= null then call hcs_$terminate_noname (mbxp, code);
	     if ^my_mbx & mseg_index ^= 0 then call mailbox_$close (mseg_index, code);
	     if seg_initiated then call hcs_$terminate_noname (segp, code);

	end mail_cleanup;

     end mail;




		    message_facility_.pl1           05/04/88  0827.0rew 05/04/88  0824.7      647766



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */

/* This subroutine is the heart of the Multics message facility. */
/* This replaces the Multics message facility written 12/01/75 by
   Steve Herbst. */


/****^  HISTORY COMMENTS:
  1) change(84-05-10,Lippard), approve(), audit(), install():
      Written by Jim Lippard.
  2) change(84-11-16,Lippard), approve(), audit(), install():
      Modified to prevent messages received from getting message numbers
      lower than those already in the mailbox.
  3) change(84-11-27,Lippard), approve(), audit(), install():
      Modified to fix the last fix correctly, to only print "You have N
      messages" in the alarm handler when a call string is NOT being used,
      and to make alarms work.
  4) change(84-12-18,Lippard), approve(), audit(), install():
      Modified to make message_facility_$send_message do something reasonable
      with error_table_$no_info.
  5) change(85-01-11,Lippard), approve(), audit(), install():
      Modified to make entry points take a message_id instead of an array
      index to prevent internal message arrays and applications' arrays from
      getting out of synch.
  6) change(85-01-23,Lippard), approve(), audit(), install():
      Modified to fix code calling mlr_.
  7) change(85-01-30,Lippard), approve(), audit(), install():
      Modified to speed up message selection by using a binary search.
  8) change(85-03-26,Lippard), approve(), audit(), install():
      Modified to speed up create_message_array and compact_message_array.
  9) change(85-04-16,Lippard), approve(), audit(), install():
      Modified to properly set the last message number when a new message is
      received.
 10) change(85-05-31,Lippard), approve(85-11-18,MCR7298),
     audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006):
      Modified to initialize everything in the msg_facility_mailbox structure
      before any possible aborting/freeing takes place.
 11) change(85-09-02,Lippard), approve(85-11-18,MCR7298),
     audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006):
      Modified to only send acknowledgements when the user has d permission
      on the mailbox.
 12) change(86-04-23,Lippard), approve(86-05-27,MCR7418),
     audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080):
      Modified to make get_msg_array_ptr only call create_message_array when
      necessary.
 13) change(86-06-04,Lippard), approve(86-06-24,MCR7432),
     audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080):
      Modified to properly zero fields in mail_format when sending messages.
 14) change(86-06-05,Lippard), approve(86-06-24,MCR7437),
     audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080):
      Modified to correctly figure out when to use mailbox_$own_xxx entries.
 15) change(86-08-06,Lippard), approve(87-03-18,MECR0001),
     audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002):
      Modified to check for unseen messages in wakeup processor.
 16) change(87-01-29,Lippard), approve(87-03-18,MECR0001),
     audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002):
      Modified to strip control characters from message comment field.
 17) change(87-05-08,Lippard), approve(87-04-20,MCR7669),
     audit(87-05-11,Fawcett), install(88-05-04,MR12.2-1045):
      Formal installation to close out MECR0001 and to use the permanent
      seen switches in the mailbox when access allows.
 18) change(88-03-31,Lippard), approve(88-04-18,MCR7876),
     audit(88-04-26,Parisek), install(88-05-04,MR12.2-1045):
      Changed wakeup_processor to (a) stop setting P_code, which is not
      a parameter to that procedure and (b) check for error_table_$seg_unknown
      from mailbox_$get_mode_index.  Also changed calls to ioa_$rsnnl to
      use the returned length correctly.
                                                   END HISTORY COMMENTS */

message_facility_: procedure options (variable);
	return;					/* not an entry */

	dcl     (P_msgf_mbx_ptr, P_next_msgf_mbx_ptr) ptr parm;
	dcl     (P_dname, P_ename, P_message) char (*) parm;
	dcl     P_access_class	 bit (72) aligned;
	dcl     P_default_mbx	 bit (1) aligned parm;
	dcl     P_flags		 bit (*) parm;
	dcl     P_message_id	 bit (72) aligned parm;
	dcl     P_prefix		 char (32) varying parm;
	dcl     (P_short_prefix, P_short_format) bit (1) aligned parm;
	dcl     P_handler		 entry variable parm;
	dcl     P_info_ptr		 ptr parm;
	dcl     P_time		 fixed bin (71) parm;
	dcl     P_area_ptr		 ptr;
	dcl     P_msg_array_ptr	 ptr parm;
	dcl     P_n_messages	 fixed bin parm;
	dcl     P_iocb_ptr		 ptr;
	dcl     P_code		 fixed bin (35) parm;

	dcl     access_class	 bit (1) aligned;
	dcl     access_mode		 bit (36) aligned;
	dcl     allow_switch	 bit (36) aligned;
	dcl     array_length	 fixed bin (21);
	dcl     authorization	 bit (72) aligned;
	dcl     auth_string		 char (170);
	dcl     call_string		 char (512) based (P_info_ptr);
	dcl     change_state	 bit (1) aligned;
	dcl     command_line	 char (2000);
	dcl     count		 fixed bin;
	dcl     current_message_index	 fixed bin;
	dcl     d_permission	 bit (1) aligned;
	dcl     default_dname	 char (168);
	dcl     default_ename	 char (32);
	dcl     default_uid		 bit (36) aligned;
	dcl     destination_string	 char (array_length) based (destination_string_ptr);
	dcl     destination_string_ptr ptr;
	dcl     dname		 char (168);
	dcl     ename		 char (32);
	dcl     wakeup_flags	 bit (5) aligned;
	dcl     full_name		 char (32) internal static init ("");
	dcl     hold_this_message	 bit (1) aligned;
	dcl     hold_this_notification bit (1) aligned;
	dcl     iocb_ptr		 ptr;
	dcl     last_index		 fixed bin;
	dcl     last_message_set	 bit (1) aligned;
	dcl     last_msg_time	 char (24) internal static init ("");
	dcl     last_sender		 char (120) internal static init ("");
	dcl     last_time		 fixed bin (71) internal static init (0);
	dcl     mbx_index		 fixed bin;
	dcl     message		 char (47);
	dcl     message_bit_count	 fixed bin;
	dcl     message_id		 bit (72) aligned;
	dcl     message_ident	 char (200) varying;
	dcl     message_index	 fixed bin;
	dcl     message_sender	 char (120);
	dcl     own		 bit (1) aligned;
	dcl     person		 char (22) internal static init ("");
	dcl     project		 char (9) internal static init ("");
	dcl     person_id		 char (22);
	dcl     project_id		 char (9);
	dcl     login_name		 char (32);
	dcl     seen_switch_flags	 bit (3) aligned;
	dcl     short		 bit (1) aligned;
	dcl     source_string	 char (array_length) based (source_string_ptr);
	dcl     source_string_ptr	 ptr;
	dcl     tag		 char (10) var;
	dcl     uid		 bit (36) aligned;
	dcl     use_call_string	 bit (1) aligned;

	dcl     date_time		 fixed bin (71);
	dcl     msg_date_time	 char (24);
	dcl     current_date_time	 char (24);

	dcl     freed_msgf_mbx_ptr	 ptr;
	dcl     next_msgf_mbx_ptr	 ptr;
	dcl     static_msgf_mbx_ptr	 ptr internal static init (null ());

	dcl     area_ptr		 ptr static init (null ());
	dcl     sys_area		 area (65560) based (area_ptr);
	dcl     user_area_ptr	 ptr;
	dcl     user_area		 area based (user_area_ptr);

	dcl     1 internal_msg_array	 (msg_facility_mailbox.n_elements) aligned based (msg_facility_mailbox.messages_ptr) like msg_array;

	dcl     1 local_lmi		 aligned like last_message_info;

	dcl     1 local_mi		 aligned like message_info;

	dcl     1 local_mra		 aligned like mseg_return_args;

	dcl     1 local_pf		 unaligned like msg_print_flags based (local_pf_ptr);
	dcl     local_pf_ptr	 ptr;

	dcl     1 local_smi		 aligned like send_mail_info based (local_smi_ptr);
	dcl     local_smi_ptr	 ptr;

	dcl     new_message_number	 fixed bin;

	dcl     found		 bit (1) aligned;
	dcl     retried		 bit (1) aligned;

	dcl     (idx, jdx)		 fixed bin;

	dcl     code		 fixed bin (35);

	dcl     aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned) reducible;

	dcl     error_table_$bad_segment fixed bin (35) ext static;
	dcl     error_table_$bad_subr_arg fixed bin (35) ext static;
	dcl     error_table_$messages_off fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$no_info	 fixed bin (35) ext static;
	dcl     error_table_$no_message fixed bin (35) ext static;
	dcl     error_table_$rqover	 fixed bin (35) ext static;
	dcl     error_table_$seg_unknown fixed bin (35) ext static;
	dcl     error_table_$unimplemented_version fixed bin (35) ext static;

	dcl     (addr, after, before, clock, collate, divide, fixed, index, length, max, min, null, rel, rtrim, size, string, substr,
	        translate, unspec)	 builtin;

	dcl     (cleanup, record_quota_overflow) condition;

	dcl     canonicalize_	 entry (ptr, fixed bin (21), ptr, fixed bin (21), fixed bin (35));

	dcl     convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));

	dcl     cu_$cp		 entry (ptr, fixed bin (21), fixed bin (35));

	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);

	dcl     get_authorization_	 entry () returns (bit (72) aligned) reducible;

	dcl     get_system_free_area_	 entry () returns (ptr);


	dcl     ioa_$ioa_switch	 entry options (variable);
	dcl     ioa_$ioa_switch_nnl	 entry options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);

	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$user_io	 ptr ext static;

	dcl     ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$decl_ev_call_chn	 entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
	dcl     ipc_$delete_ev_chn	 entry (fixed bin (71), fixed bin (35));

	dcl     mailbox_$accept_wakeups_index entry (fixed bin, fixed bin (71), bit (36) aligned, fixed bin (35));
	dcl     mailbox_$close	 entry (fixed bin, fixed bin (35));
	dcl     mailbox_$delete_index	 entry (fixed bin, bit (72) aligned, fixed bin (35));
	dcl     mailbox_$get_mode_index entry (fixed bin, bit (36) aligned, fixed bin (35));
	dcl     mailbox_$get_uid_file	 entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     mailbox_$incremental_read_index entry (fixed bin, ptr, bit (2) aligned, bit (72) aligned, ptr,
				 fixed bin (35));
	dcl     mailbox_$open	 entry (char (*), char (*), fixed bin, fixed bin (35));
	dcl     mailbox_$own_incremental_read_index entry (fixed bin, ptr, bit (2) aligned, bit (72) aligned, ptr,
				 fixed bin (35));
	dcl     mailbox_$own_read_index entry (fixed bin, ptr, bit (1) aligned, ptr, fixed bin (35));
	dcl     mailbox_$read_index	 entry (fixed bin, ptr, bit (1) aligned, ptr, fixed bin (35));
	dcl     mailbox_$update_message_index entry (fixed bin, fixed bin, bit (72) aligned, ptr, fixed bin (35));
	dcl     mailbox_$wakeup_add_index entry (fixed bin, ptr, fixed bin, bit (36) aligned, bit (72) aligned,
				 fixed bin (35));
	dcl     mailbox_$wakeup_aim_add_index entry (fixed bin, ptr, fixed bin, bit (36) aligned, bit (72) aligned,
				 bit (72) aligned, fixed bin (35));

	dcl     message_facility_$alarm_processor entry (ptr);
	dcl     message_facility_$wakeup_processor entry (ptr);
	dcl     message_facility_$default_alarm_handler entry (ptr, ptr);
	dcl     message_facility_$default_wakeup_handler entry (ptr, ptr);
	dcl     message_facility_$delete_message entry (ptr, bit (72) aligned, fixed bin (35));
	dcl     message_facility_$free_msgf_mbx_ptr entry (ptr, fixed bin (35));
	dcl     message_facility_$get_last_message_info entry (ptr, ptr, fixed bin (35));
	dcl     message_facility_$print_message entry (ptr, ptr, bit (72) aligned, ptr, fixed bin (35));
	dcl     message_facility_$read_message entry (ptr, bit (72) aligned, ptr, ptr, fixed bin (35));
	dcl     message_facility_$send_message entry (char (*), char (*), char (*), ptr, fixed bin (35));
	dcl     message_facility_$set_seen_switch entry (ptr, bit (72) aligned, bit (*), fixed bin (35));

	dcl     mrl_		 entry (ptr, fixed bin (21), ptr, fixed bin (21));

	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

	dcl     requote_string_	 entry (char (*)) returns (char (*));

	dcl     sub_err_		 entry options (variable);

	dcl     timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));
	dcl     timer_manager_$reset_alarm_wakeup entry (fixed bin (71));

	dcl     user_info_$whoami	 entry (char (*), char (*), char (*));

	dcl     value_$get		 entry () options (variable);

	dcl     TRUE		 bit (1) aligned internal static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) aligned internal static options (constant) init ("0"b);
	dcl     ALPHABET		 char (256) init ((8)" " || "	" || (4)" " || "" || (16)" "
				 || substr (collate (), 33)); /* space, BSHT, space, RRSBRS, space, alphanumerics */
	dcl     FIVE_MINUTES	 fixed bin (71) internal static options (constant) init (300000000);
	dcl     MSG_ARRAY_BLOCK_SIZE	 fixed bin internal static options (constant) init (100);
	dcl     MSG_ARRAY_ELEMENT_LENGTH fixed bin internal static options (constant) init (16); /* four words, sixteen characters */
	dcl     NL		 char (1) aligned internal static options (constant) init ("
");
	dcl     NLSPHT		 char (3) aligned internal static options (constant) init ("
	");
	dcl     BS		 char (1) aligned internal static options (constant) init ("");
	dcl     PERMANENT_VALUES	 bit (36) aligned internal static options (constant) init ("200000000000"b3);
	dcl     READ_CURRENT	 bit (2) aligned internal static options (constant) init ("00"b);
	dcl     READ_FIRST		 bit (1) aligned internal static options (constant) init ("0"b);
	dcl     READ_FORWARD	 bit (2) aligned internal static options (constant) init ("01"b);
	dcl     RELATIVE_SECONDS	 bit (2) internal static options (constant) init ("11"b);

/* This entry returns the next msg facility mailbox pointer in the chain. */
get_next_msgf_mbx_ptr: entry (P_msgf_mbx_ptr, P_next_msgf_mbx_ptr);
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;
	P_next_msgf_mbx_ptr = null ();

	if msg_facility_mailbox_ptr = null () then next_msgf_mbx_ptr = static_msgf_mbx_ptr;
	else next_msgf_mbx_ptr = msg_facility_mailbox.next_mbx_ptr;

	code = 1;
	do while (code ^= 0);
	     msg_facility_mailbox_ptr = next_msgf_mbx_ptr;
	     code = 0;
	     if msg_facility_mailbox_ptr ^= null () then do; /* see if it's there and we have access */
		     call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
			msg_facility_mailbox.index, code);
		     if code ^= 0 then do;
			     call message_facility_$free_msgf_mbx_ptr (msg_facility_mailbox_ptr, (0));
			     if P_msgf_mbx_ptr = null () then next_msgf_mbx_ptr = static_msgf_mbx_ptr;
			     else next_msgf_mbx_ptr = P_msgf_mbx_ptr -> msg_facility_mailbox.next_mbx_ptr;
			end;
		end;
	end;

	P_next_msgf_mbx_ptr = next_msgf_mbx_ptr;
	return;					/* get_next_msgf_mbx_ptr */

/* This entry returns a msg facility mailbox pointer for the specified mailbox. */
get_msgf_mbx_ptr: entry (P_dname, P_ename, P_msgf_mbx_ptr, P_code);
	dname = P_dname;
	ename = P_ename;
	P_msgf_mbx_ptr = null ();
	P_code = 0;

	call mailbox_$get_uid_file (dname, ename, uid, code);

	if code ^= 0 then do;
		P_code = code;
		return;
	     end;

	msg_facility_mailbox_ptr = static_msgf_mbx_ptr;
	found = FALSE;
	do while ((msg_facility_mailbox_ptr ^= null ()) & ^found);
	     if msg_facility_mailbox.uid = uid then found = TRUE;
	     else msg_facility_mailbox_ptr = msg_facility_mailbox.next_mbx_ptr;
	end;

	if ^found then do;
						/* add a new one, at the beginning of the list */
		if area_ptr = null () then area_ptr = get_system_free_area_ ();
		allocate msg_facility_mailbox set (msg_facility_mailbox_ptr) in (sys_area);
		msg_facility_mailbox.next_mbx_ptr = static_msgf_mbx_ptr;
		static_msgf_mbx_ptr = msg_facility_mailbox_ptr;

/* initialize the structure */
		msg_facility_mailbox.version = MSG_FACILITY_MAILBOX_VERSION_1;
		msg_facility_mailbox.dname = dname;
		msg_facility_mailbox.ename = ename;
		msg_facility_mailbox.uid = uid;
		call user_info_$whoami (person, project, "");
		default_dname = ">udd>" || rtrim (project) || ">" || rtrim (person);
		default_ename = rtrim (person) || ".mbx";
		call mailbox_$get_uid_file (default_dname, default_ename, default_uid, (0));
		if uid = default_uid then msg_facility_mailbox.default_mbx = TRUE;
		else msg_facility_mailbox.default_mbx = FALSE;
		msg_facility_mailbox.event_channel = 0;

		string (msg_facility_mailbox.wakeup_flags) = ""b;
		msg_facility_mailbox.mbz = ""b;
		msg_facility_mailbox.short_format = FALSE;
		msg_facility_mailbox.prefix = "";
		msg_facility_mailbox.short_prefix = FALSE;
		msg_facility_mailbox.alarm_time = 0;
		msg_facility_mailbox.alarm_event_channel = 0;
		msg_facility_mailbox.last_message_ptr = null ();
		msg_facility_mailbox.last_id = ""b;
		msg_facility_mailbox.last_message_number = 0;
		msg_facility_mailbox.highest_message = 0;
		msg_facility_mailbox.messages_ptr = null ();
		msg_facility_mailbox.n_elements = 0;
		msg_facility_mailbox.n_messages = 0;
		msg_facility_mailbox.msg_array_compacted = TRUE;
		msg_facility_mailbox.msg_array_updated = FALSE;
		msg_facility_mailbox.wakeup_handler = message_facility_$default_wakeup_handler;
		msg_facility_mailbox.wakeup_info_ptr = null ();
		msg_facility_mailbox.alarm_handler = message_facility_$default_alarm_handler;
		msg_facility_mailbox.alarm_info_ptr = null ();

/* We do this last so that everything is initialized properly in case we have
   to free the structure. */
		call mailbox_$open (dname, ename, msg_facility_mailbox.index, code);

		if code ^= 0 then do;
			P_code = code;
			return;
		     end;

	     end;

	else do;					/* see if mailbox is still there */
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);

		if code ^= 0 then do;
			P_code = code;
			call message_facility_$free_msgf_mbx_ptr (msg_facility_mailbox_ptr, (0));
			return;
		     end;
	     end;

	P_msgf_mbx_ptr = msg_facility_mailbox_ptr;
	return;					/* get_msgf_mbx_ptr */

/* This entry makes a mailbox unknown to the message facility. */
free_msgf_mbx_ptr: entry (P_msgf_mbx_ptr, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	call mailbox_$close (msg_facility_mailbox.index, (0));

	freed_msgf_mbx_ptr = msg_facility_mailbox_ptr;
	msg_facility_mailbox_ptr = static_msgf_mbx_ptr;

	if P_msgf_mbx_ptr = static_msgf_mbx_ptr then do;	/* free first mailbox in list */
		msg_facility_mailbox_ptr = static_msgf_mbx_ptr;
		static_msgf_mbx_ptr = msg_facility_mailbox.next_mbx_ptr;
	     end;

	else do;

/* set msg_facility_mailbox_ptr to point to mbx in list just BEFORE the one we're freeing */
		found = FALSE;
		do msg_facility_mailbox_ptr = static_msgf_mbx_ptr
		     repeat (msg_facility_mailbox.next_mbx_ptr)
		     while (msg_facility_mailbox.next_mbx_ptr ^= null ()
		     & ^found);
		     if msg_facility_mailbox.next_mbx_ptr = freed_msgf_mbx_ptr then found = TRUE;
		end;

		if msg_facility_mailbox.next_mbx_ptr = null () then do; /* this msgf structure isn't in our list! */
			P_code = error_table_$unimplemented_version;
			return;
		     end;
	     end;

	P_msgf_mbx_ptr = null ();
	msg_facility_mailbox.next_mbx_ptr = freed_msgf_mbx_ptr -> msg_facility_mailbox.next_mbx_ptr;

	msg_facility_mailbox_ptr = freed_msgf_mbx_ptr;

/* reset alarm wakeups */
	if msg_facility_mailbox.alarm_time > 0 then call
		timer_manager_$reset_alarm_wakeup (msg_facility_mailbox.alarm_event_channel);

/* delete event channels */
	if msg_facility_mailbox.alarm_event_channel ^= 0 then
	     call ipc_$delete_ev_chn (msg_facility_mailbox.alarm_event_channel, (0));
	if msg_facility_mailbox.event_channel ^= 0 then call ipc_$delete_ev_chn (msg_facility_mailbox.event_channel, (0));

/* free last message mail format structure */
	if msg_facility_mailbox.last_message_ptr ^= null () then do;
		message_info_ptr = msg_facility_mailbox.last_message_ptr;
		if message_info.message_ptr ^= null () then free message_info.message_ptr -> mail_format in (sys_area);
		free message_info in (sys_area);
	     end;

/* free message array */
	if msg_facility_mailbox.messages_ptr ^= null () then free internal_msg_array in (sys_area);

	free msg_facility_mailbox in (sys_area);
	return;					/* free_msgf_mbx_ptr */

/* This entry returns the wakeup state for the specified mailbox. */
get_wakeup_state: entry (P_msgf_mbx_ptr, P_flags, P_code);
	P_flags = ""b;
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	P_flags = substr (string (msg_facility_mailbox.wakeup_flags), 1, 5);
	return;					/* get_wakeup_state */

/* This entry sets the wakeup state for the specified mailbox. */
set_wakeup_state: entry (P_msgf_mbx_ptr, P_flags, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;
	wakeup_flags = P_flags;
	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	if substr (wakeup_flags, 4, 2) = "00"b | substr (wakeup_flags, 4, 2) = "11"b then do;
						/* can't currently "unaccept" messages, 11 is undefined */
		P_code = error_table_$bad_subr_arg;
		return;
	     end;

	if msg_facility_mailbox.event_channel = 0 then do;
		call ipc_$create_ev_chn (msg_facility_mailbox.event_channel, code);

		if code ^= 0 then do;
			P_code = code;
			return;
		     end;

		call ipc_$decl_ev_call_chn (msg_facility_mailbox.event_channel, message_facility_$wakeup_processor,
		     msg_facility_mailbox_ptr, (1), code);

		if code ^= 0 then do;
			P_code = code;
			return;
		     end;
	     end;

	if wakeup_flags ^= string (msg_facility_mailbox.wakeup_flags) then
	     change_state = TRUE;

	string (msg_facility_mailbox.wakeup_flags) = wakeup_flags;

	substr (allow_switch, 1, 1) = substr (msg_facility_mailbox.wakeup_state, 1, 1);
	substr (allow_switch, 2, 1) = substr (allow_switch, 1, 1);

SET_WAKEUP_STATE:
	call mailbox_$accept_wakeups_index (msg_facility_mailbox.index, msg_facility_mailbox.event_channel,
	     allow_switch, code);

	if code = error_table_$seg_unknown then do;
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);
		if code ^= 0 then do;
			P_code = code;
			return;
		     end;
		go to SET_WAKEUP_STATE;
	     end;

	else if code ^= 0 then do;
		P_code = code;
		return;
	     end;

	if substr (allow_switch, 1, 1) = FALSE & change_state then
	     msg_facility_mailbox.msg_array_updated = FALSE;
	return;					/* set_wakeup_state */

/* This entry returns the pathname for the specified mailbox. */
get_mbx_path: entry (P_msgf_mbx_ptr, P_dname, P_ename, P_default_mbx, P_code);
	P_dname, P_ename = "";
	P_default_mbx = ""b;
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	P_dname = msg_facility_mailbox.dname;
	P_ename = msg_facility_mailbox.ename;
	P_default_mbx = msg_facility_mailbox.default_mbx;
	return;					/* get_mbx_path */

/* This entry returns the prefix information for the specified mailbox. */
get_prefix: entry (P_msgf_mbx_ptr, P_prefix, P_short_prefix, P_code);
	P_prefix = "";
	P_short_prefix = ""b;
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	P_prefix = msg_facility_mailbox.prefix;
	P_short_prefix = msg_facility_mailbox.short_prefix;
	return;					/* get_prefix */

/* This entry sets the prefix information for the specified mailbox. */
set_prefix: entry (P_msgf_mbx_ptr, P_prefix, P_short_prefix, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	msg_facility_mailbox.prefix = P_prefix;
	msg_facility_mailbox.short_prefix = P_short_prefix;
	return;					/* set_prefix */

/* This entry returns the short format switch for the specified mailbox. */
get_message_format: entry (P_msgf_mbx_ptr, P_short_format, P_code);
	P_short_format = ""b;
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	P_short_format = msg_facility_mailbox.short_format;
	return;					/* get_message_format */

/* This entry sets the short format switch for the specified mailbox. */
set_message_format: entry (P_msgf_mbx_ptr, P_short_format, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	msg_facility_mailbox.short_format = P_short_format;
	return;					/* set_message_format */

/* This entry returns the alarm handler for the specified mailbox. */
get_alarm_handler: entry (P_msgf_mbx_ptr, P_handler, P_info_ptr, P_time, P_code);
	P_info_ptr = null ();
	P_time = 0;
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	P_handler = msg_facility_mailbox.alarm_handler;
	P_info_ptr = msg_facility_mailbox.alarm_info_ptr;
	P_time = msg_facility_mailbox.alarm_time;
	return;					/* get_alarm_handler */

/* This entry sets the alarm handler for the specified mailbox. */
set_alarm_handler: entry (P_msgf_mbx_ptr, P_handler, P_info_ptr, P_time, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	if msg_facility_mailbox.event_channel = 0 then do;
		P_code = error_table_$messages_off;
		return;
	     end;

	msg_facility_mailbox.alarm_handler = P_handler;
	msg_facility_mailbox.alarm_info_ptr = P_info_ptr;
	msg_facility_mailbox.alarm_time = P_time;

/* if alarm time is nonzero, turn on hold messages mode */
	if msg_facility_mailbox.alarm_time ^= 0 then msg_facility_mailbox.hold_messages = TRUE;

/* turn off any preexisting alarm */
	if msg_facility_mailbox.alarm_event_channel ^= 0 then
	     call timer_manager_$reset_alarm_wakeup (msg_facility_mailbox.alarm_event_channel);

	if msg_facility_mailbox.alarm_event_channel = 0 then do;
		call ipc_$create_ev_chn (msg_facility_mailbox.alarm_event_channel, code);

		if code ^= 0 then do;
			P_code = code;
			return;
		     end;

		call ipc_$decl_ev_call_chn (msg_facility_mailbox.alarm_event_channel, message_facility_$alarm_processor,
		     msg_facility_mailbox_ptr, (1), code);

		if code ^= 0 then do;
			P_code = code;
			return;
		     end;
	     end;

	if P_time ^= 0 then call timer_manager_$alarm_wakeup (msg_facility_mailbox.alarm_time, RELATIVE_SECONDS,
		msg_facility_mailbox.alarm_event_channel);
	return;					/* set_alarm_handler */

/* This entry returns the wakeup handler for the specified mailbox. */
get_wakeup_handler: entry (P_msgf_mbx_ptr, P_handler, P_info_ptr, P_code);
	P_info_ptr = null ();
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	P_handler = msg_facility_mailbox.wakeup_handler;
	P_info_ptr = msg_facility_mailbox.wakeup_info_ptr;
	return;					/* get_wakeup_handler */

/* This entry sets the wakeup handler for the specified mailbox. */
set_wakeup_handler: entry (P_msgf_mbx_ptr, P_handler, P_info_ptr, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	if msg_facility_mailbox.event_channel = 0 then do;
		P_code = error_table_$messages_off;
		return;
	     end;

	msg_facility_mailbox.wakeup_handler = P_handler;
	msg_facility_mailbox.wakeup_info_ptr = P_info_ptr;
	return;					/* set_wakeup_handler */

/* This entry returns last message information for the specified mailbox. */
get_last_message_info: entry (P_msgf_mbx_ptr, P_info_ptr, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	last_message_info_ptr = P_info_ptr;

	if last_message_info.version ^= LAST_MESSAGE_INFO_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	last_message_info.last_message_ptr = msg_facility_mailbox.last_message_ptr;
	last_message_info.last_message_id = msg_facility_mailbox.last_id;
	last_message_info.last_message_number = msg_facility_mailbox.last_message_number;
	return;					/* get_last_message_info */

/* This entry returns a pointer to the message array for the specified mailbox. */
get_msg_array_ptr: entry (P_msgf_mbx_ptr, P_area_ptr, P_msg_array_ptr, P_n_messages, P_code);
	P_msg_array_ptr = null ();
	P_n_messages = 0;
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;
	user_area_ptr = P_area_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	if user_area_ptr = null () then user_area_ptr = get_system_free_area_ ();

/* Determine which mailbox_ entry points to use. */
	call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code);

	if code ^= 0 then do;
	     P_code = code;
	     return;
	end;

	own = ^substr (access_mode, 3, 1);

/* Check to see if any new messages have arrived that we missed. */
CHECK_LAST_MESSAGE:
	if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, user_area_ptr, READ_FORWARD,
	     msg_facility_mailbox.last_id, addr (local_mra), code);
	else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, user_area_ptr, READ_FORWARD,
	     msg_facility_mailbox.last_id, addr (local_mra), code);
	if code = error_table_$seg_unknown then do;
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);
		if code ^= 0 then do;
			P_code = code;
			return;
		     end;
		go to CHECK_LAST_MESSAGE;
	     end;

	if code ^= error_table_$no_message then
	     msg_facility_mailbox.msg_array_updated = FALSE;

/* If the message array has already been created in the past and we are
   accepting messages, the message array is automatically kept up-to-date
   and there is no need to waste computrons going through the entire
   mailbox. (The above code takes care of the cases where we're losing
   wakeups, due to another user accepting messages out from under us or
   whatever.) */

	if msg_facility_mailbox.wakeup_state = "10"b
	     & msg_facility_mailbox.messages_ptr ^= null ()
	     & msg_facility_mailbox.msg_array_updated then do;
		if ^msg_facility_mailbox.msg_array_compacted then
		     call compact_message_array;
	     end;
	else do;
		call create_message_array;
		if code ^= 0 then P_code = code;
	     end;

	n_messages = msg_facility_mailbox.n_messages;
	allocate msg_array in (user_area);
	array_length = MSG_ARRAY_ELEMENT_LENGTH * n_messages;
	destination_string_ptr = addr (msg_array (1));
	source_string_ptr = addr (internal_msg_array (1));
	destination_string = source_string;
	P_n_messages = n_messages;
	P_msg_array_ptr = msg_array_ptr;
	return;					/* get_msg_array_ptr */

/* This entry returns the specified message from the specified mailbox. */
read_message: entry (P_msgf_mbx_ptr, P_message_id, P_area_ptr, P_info_ptr, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;
	message_id = P_message_id;
	message_info_ptr = P_info_ptr;
	user_area_ptr = P_area_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;


	if message_info.version ^= MESSAGE_INFO_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	if user_area_ptr = null () then user_area_ptr = get_system_free_area_ ();

/* Determine which mailbox_ entry points to use. */
	call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code);

	if code ^= 0 then do;
	     P_code = code;
	     return;
	end;

	own = ^substr (access_mode, 3, 1);

READ_MESSAGE:
	if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, user_area_ptr, READ_CURRENT,
	     message_id, addr (local_mra), code);
	else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, user_area_ptr, READ_CURRENT,
	     message_id, addr (local_mra), code);
	if code = error_table_$seg_unknown then do;
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);
		if code ^= 0 then do;
			P_code = code;
			return;
		     end;
		go to READ_MESSAGE;
	     end;

/* If the message isn't found, our message array could be out of synch
   with the mailbox, so we need to call create_message_array in the next
   call to message_facility_$get_msg_array_ptr. */
	if code = error_table_$no_message then
	     msg_facility_mailbox.msg_array_updated = FALSE;

	if code ^= 0 then do;
		P_code = code;
		return;
	     end;

	message_info.sender = local_mra.sender_id;
	message_info.message_ptr = local_mra.ms_ptr;
	message_info.authorization = local_mra.sender_authorization;

	return;					/* read_message */

/* This entry sets the seen switch for the specified message in the specified mailbox. */
set_seen_switch: entry (P_msgf_mbx_ptr, P_message_id, P_flags, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;
	message_id = P_message_id;
	seen_switch_flags = P_flags;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	call get_message_index (message_id, message_index, code);

	if code ^= 0 then do;
		P_code = code;
		return;
	     end;

/* Determine which mailbox_ entry points to use. */
	call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code);

	if code ^= 0 then do;
	     P_code = code;
	     return;
	end;

	own = ^substr (access_mode, 3, 1);

SET_SEEN_SWITCH:
	if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_CURRENT,
	     message_id, addr (local_mra), code);
	else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_CURRENT,
	     message_id, addr (local_mra), code);
	if code = error_table_$seg_unknown then do;
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);
		if code ^= 0 then do;
			P_code = code;
			return;
		     end;
		go to SET_SEEN_SWITCH;
	     end;

	if code ^= 0 then do;
		P_code = code;
		return;
	     end;

	mail_format_ptr = local_mra.ms_ptr;

	d_permission = substr (access_mode, 2, 1);

	if mail_format.acknowledge & d_permission then call send_acknowledgement;
	if substr (seen_switch_flags, 1, 1) then do;	/* use defaults */
		hold_this_message = msg_facility_mailbox.hold_messages;
		hold_this_notification = msg_facility_mailbox.hold_notifications;
	     end;

	else do;					/* use supplied args */
		hold_this_message = substr (seen_switch_flags, 2, 1);
		hold_this_notification = substr (seen_switch_flags, 3, 1);
	     end;

/* set seen switch */
	internal_msg_array.printed (message_index) = TRUE;
	if d_permission then do;
		mail_format.seen = TRUE;
		call mailbox_$update_message_index (msg_facility_mailbox.index, 36 * (fixed (rel (addr (mail_format.text)))
		     - fixed (rel (addr (mail_format.version)))), message_id, local_mra.ms_ptr, (0));
	     end;

	found = FALSE;
	last_message_set = FALSE;
	last_index = 0;
	do idx = msg_facility_mailbox.n_elements to 1 by -1 while (^found);
	     if internal_msg_array.message_id (idx) ^= ""b then do;
		     found = TRUE;
		     last_index = idx;
		end;
	end;
	if (message_index = last_index & message_id ^= msg_facility_mailbox.last_id)
	     & found then do;			/* set last message info */
		last_message_set = TRUE;

		message_info_ptr = msg_facility_mailbox.last_message_ptr;
		if message_info_ptr ^= null () then do;
			mail_format_ptr = message_info.message_ptr;
			if mail_format_ptr ^= null () then free mail_format in (sys_area);
			free message_info in (sys_area);
		     end;

		mail_format_ptr = local_mra.ms_ptr;
		allocate message_info in (sys_area);
		message_info.version = MESSAGE_INFO_VERSION_1;
		message_info.sender = local_mra.sender_id;
		message_info.message_ptr = local_mra.ms_ptr;
		message_info.authorization = local_mra.sender_authorization;
		msg_facility_mailbox.last_message_ptr = message_info_ptr;
		msg_facility_mailbox.last_id = message_id;
		msg_facility_mailbox.last_message_number = internal_msg_array.message_number (message_index);
	     end;

	if d_permission
	     & ((mail_format.notify & ^hold_this_notification)
	     | (^mail_format.notify & ^hold_this_message)) then do; /* delete message */
		call message_facility_$delete_message (msg_facility_mailbox_ptr, message_id, code);

		if code ^= 0 then do;
			P_code = code;
			if ^last_message_set then
			     free mail_format in (sys_area);
			return;
		     end;
	     end;					/* delete message */

	if ^last_message_set then
	     free mail_format in (sys_area);

	return;					/* set_seen_switch */

/* This entry sends a message to the specified mailbox. */
send_message: entry (P_dname, P_ename, P_message, P_info_ptr, P_code);
	access_class = FALSE;
	go to SEND_COMMON;

send_message_access_class: entry (P_dname, P_ename, P_message, P_info_ptr, P_access_class, P_code);
	access_class = TRUE;
	authorization = P_access_class;

SEND_COMMON:
	P_code = 0;
	dname = P_dname;
	ename = P_ename;

	local_smi_ptr = P_info_ptr;

	on cleanup begin;
		if mbx_index ^= 0 then call mailbox_$close (mbx_index, (0));
	     end;

	call mailbox_$open (dname, ename, mbx_index, code);

	if code ^= 0 then do;
		P_code = code;
		return;
	     end;

	if P_message = "" then text_length = 0;
	else text_length = length (rtrim (P_message));

	message_bit_count = size (mail_format) * 36;

	begin;					/* allocate message */
	     dcl	   mail_format_space      bit (message_bit_count) aligned;
	     dcl	   1 local_mf	      aligned like mail_format based (local_mf_ptr);
	     dcl	   local_mf_ptr	      ptr;

	     local_mf_ptr = addr (mail_format_space);

	     local_mf.text_len = text_length;
	     local_mf.version = MAIL_FORMAT_VERSION_4;
	     local_mf.sent_from = local_smi.sent_from;
	     string (local_mf.switches) = ""b;
	     local_mf.wakeup = local_smi.wakeup;
	     local_mf.notify = local_smi.notify;
	     local_mf.acknowledge = local_smi.acknowledge;
	     local_mf.text = rtrim (P_message);
	     local_mf.lines = 0;

	     call get_person_and_project;

	     if local_mf.sent_from = "" then local_mf.sent_from = person;
	     else if local_mf.sent_from = person then local_mf.sent_from = full_name;

	     idx = 1;
	     count = 1;

	     do while (idx ^= 0 & text_length ^= 0);
		idx = index (substr (P_message, count, text_length), NL);
		count = count + idx;
		text_length = text_length - idx;
		local_mf.lines = local_mf.lines + 1;
	     end;

	     on record_quota_overflow begin;
		     P_code = error_table_$rqover;
		     go to RETURN_FROM_SM;
		end;

	     allow_switch = local_mf.wakeup || local_mf.urgent || local_smi.always_add || local_smi.never_add;
	     retried = FALSE;

RETRY:	     if ^access_class then call mailbox_$wakeup_add_index (mbx_index, addr (local_mf), message_bit_count,
		     allow_switch, message_id, code);
	     else call mailbox_$wakeup_aim_add_index (mbx_index, addr (local_mf), message_bit_count, allow_switch,
		     authorization, message_id, code);
	     if code = error_table_$bad_segment & ^retried then do;
		     retried = TRUE;
		     go to RETRY;
		end;

/* error_table_$no_info means the message was delivered but the wakeup may
   not have been due to AIM.  This statement will not be necessary if the
   primitives are changed to return a different error code in this case
   (e_t_$no_info from mailbox_$open IS an error, the message is not sent). */
	     else if code = error_table_$no_info then code = 0;

	     P_code = code;

	end;
RETURN_FROM_SM:
	call mailbox_$close (mbx_index, (0));
	return;					/* send_message */

/* This entry deletes a message from the specified mailbox. */
delete_message: entry (P_msgf_mbx_ptr, P_message_id, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;
	message_id = P_message_id;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	call get_message_index (message_id, message_index, code);

	if code ^= 0 then do;
		P_code = code;
		return;
	     end;

DELETE_MESSAGE:
	call mailbox_$delete_index (msg_facility_mailbox.index, message_id, code);

	if code = error_table_$seg_unknown then do;
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);
		if code ^= 0 then do;
			P_code = code;
			return;
		     end;
		go to DELETE_MESSAGE;
	     end;

	else if code ^= 0 then do;
		P_code = code;
		return;
	     end;

/* mark msg as deleted in message array */
	internal_msg_array.message_id (message_index) = ""b;
	internal_msg_array.message_number (message_index) = 0;

	msg_facility_mailbox.n_messages = msg_facility_mailbox.n_messages - 1;
	msg_facility_mailbox.msg_array_compacted = FALSE;
	return;					/* delete_message */

/* This entry prints a message. */
print_message: entry (P_msgf_mbx_ptr, P_iocb_ptr, P_message_id, P_info_ptr, P_code);
	P_code = 0;
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;
	iocb_ptr = P_iocb_ptr;
	message_id = P_message_id;
	local_pf_ptr = P_info_ptr;

	if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	if ^local_pf.print_last_message then do;
		call get_message_index (message_id, message_index, code);

		if code ^= 0 then do;
			P_code = code;
			return;
		     end;

		mail_format_ptr = null ();
		local_mi.version = MESSAGE_INFO_VERSION_1;

		on cleanup begin;
			if mail_format_ptr ^= null () then free mail_format in (sys_area);
		     end;

		call message_facility_$read_message (msg_facility_mailbox_ptr, message_id, area_ptr, addr (local_mi), code);
		if code ^= 0 then return;
	     end;
	else do;					/* use last message info */
		local_lmi.version = LAST_MESSAGE_INFO_VERSION_1;

		call message_facility_$get_last_message_info (msg_facility_mailbox_ptr, addr (local_lmi), code);

		if code ^= 0 then do;
			P_code = code;
			return;
		     end;

		if local_lmi.last_message_id = ""b then do;
			P_code = error_table_$no_message;
			return;
		     end;

		message_info_ptr = local_lmi.last_message_ptr;
		local_mi = message_info;
	     end;

	mail_format_ptr = local_mi.message_ptr;

	if ^local_pf.print_last_message then do;
		if internal_msg_array.message_number (message_index) ^= 0 then call ioa_$rsnnl ("^d) ", tag, (0),
			internal_msg_array.message_number (message_index));
		else tag = "";
	     end;
	else do;
		if local_lmi.last_message_number ^= 0 then
		     call ioa_$rsnnl ("^d) ", tag, (0), local_lmi.last_message_number);
		else tag = "";
	     end;

/* print prefix, it may contain ioa_ controls */
	if local_pf.print_prefix then call ioa_$ioa_switch_nnl (iocb_ptr,
		msg_facility_mailbox.prefix);

	message_ident = "";

	if local_pf.print_ename then message_ident = rtrim (msg_facility_mailbox.ename) || " ";

	if local_pf.print_sender then do;

/* create message sender string */
		message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2);
		if mail_format.sent_from ^= before (local_mi.sender, ".") & rtrim (mail_format.sent_from) ^= "" then
		     message_sender = rtrim (message_sender)
			|| " (" || rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) || ")";
		authorization = get_authorization_ ();
		if ^aim_check_$greater_or_equal (local_mi.authorization, authorization) then do;
			call convert_access_class_$to_string_short (local_mi.authorization, auth_string, code);
			if auth_string = "" then auth_string = "system_low";
			message_sender = rtrim (message_sender) || " at " || auth_string;
		     end;

		if tag ^= "" then message_ident = message_ident || tag || rtrim (message_sender);
		else message_ident = message_ident || "From " || rtrim (message_sender);
	     end;
	else message_ident = message_ident || tag || "=";

	if ^local_pf.print_last_message then date_time = fixed (substr (message_id, 19, 54), 71);
	else date_time = fixed (substr (local_lmi.last_message_id, 19, 54), 71);

	if local_pf.print_date_and_time then
	     message_ident = message_ident || " " || date_time_$format ("date_time", date_time, "", "");
	else if local_pf.print_time then
	     message_ident = message_ident || " " || date_time_$format ("time", date_time, "", "");

	call ioa_$ioa_switch_nnl (iocb_ptr, "^a: ^[^/^]^a^/", message_ident,
	     (length (message_ident) > 16 & (length (message_ident) + mail_format.text_len > 80)),
	     rtrim (canon (rtrim (mail_format.text), length (rtrim (mail_format.text)))));

	if ^local_pf.print_last_message then if mail_format_ptr ^= null () then free mail_format in (sys_area);
	return;					/* print_message */

/* This entry is the processor for alarms. */
alarm_processor: entry (P_info_ptr);
	event_call_info_ptr = P_info_ptr;
	msg_facility_mailbox_ptr = event_call_info.data_ptr;

	call create_message_array;

	if code = error_table_$no_message then code = 0;

	if code ^= 0 then do;
		call sub_err_ (code, "alarm", ACTION_CANT_RESTART, null (), (0),
		     "While updating message array for mailbox ^a.", pathname_ ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename)));
		return;
	     end;

	call msg_facility_mailbox.alarm_handler (msg_facility_mailbox_ptr, msg_facility_mailbox.alarm_info_ptr);

	if msg_facility_mailbox.alarm_time > 0 then call timer_manager_$alarm_wakeup (msg_facility_mailbox.alarm_time,
		RELATIVE_SECONDS, msg_facility_mailbox.alarm_event_channel);

	return;					/* alarm_processor */

/* This entry is the processor for wakeups. */
wakeup_processor: entry (P_info_ptr);
	event_call_info_ptr = P_info_ptr;
	msg_facility_mailbox_ptr = event_call_info.data_ptr;

/* Determine which mailbox_ entry points to use. */
WAKEUP_GET_MODE_INDEX:
	call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code);

	if code = error_table_$seg_unknown then do;
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);
		if code ^= 0 then return;
		go to WAKEUP_GET_MODE_INDEX;
	end;
	else if code ^= 0 then return;
	else own = ^substr (access_mode, 3, 1);

/* Check to see if any new messages have arrived that we missed. */
WAKEUP_CHECK_LAST_MESSAGE:
	if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_FORWARD,
		msg_facility_mailbox.last_id, addr (local_mra), code);
	else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_FORWARD,
		msg_facility_mailbox.last_id, addr (local_mra), code);
	if code = error_table_$seg_unknown then do;
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);
		if code ^= 0 then return;
		go to WAKEUP_CHECK_LAST_MESSAGE;
	     end;

	if code ^= error_table_$no_message then
	     msg_facility_mailbox.msg_array_updated = FALSE;

	if ^msg_facility_mailbox.msg_array_updated then
	     call create_message_array;
	else if ^msg_facility_mailbox.msg_array_compacted then
	     call compact_message_array;

	message_id = unspec (event_call_info.message);

/* Update last message info, do not mark message seen. */
PROCESSOR_READ:
	if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_CURRENT, message_id,
	     addr (local_mra), code);
	else call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_CURRENT, message_id,
	     addr (local_mra), code);
	if code = error_table_$seg_unknown then do;
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);
		if code ^= 0 then return;
		go to PROCESSOR_READ;
	     end;

	if code = error_table_$no_message then return;	/* no big deal. */

	if code ^= 0 then do;
		call sub_err_ (code, "wakeup", ACTION_CANT_RESTART, null (), (0),
		     "While reading message from mailbox ^a.", pathname_ ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename)));
	     end;

	mail_format_ptr = local_mra.ms_ptr;

	if mail_format.notify & ^msg_facility_mailbox.notify_mail then do;
		call mailbox_$delete_index (msg_facility_mailbox.index, message_id, code);
		free mail_format in (sys_area);
		return;
	     end;

	call get_message_index (message_id, current_message_index, code);
	if code = 0 then new_message_number = internal_msg_array.message_number (current_message_index);
	else if code = error_table_$no_message then do;
		if (^mail_format.notify & msg_facility_mailbox.hold_messages)
		     | (msg_facility_mailbox.hold_notifications & mail_format.notify) then do;
			new_message_number = msg_facility_mailbox.highest_message + 1;
			msg_facility_mailbox.highest_message = new_message_number;

		     end;

		else new_message_number = 0;

/* Update message array, adding new message at the end (unless it's the
   fairly rare case in which this message was added before others that
   have already been received but the wakeup came later). */
		msg_facility_mailbox.n_messages = msg_facility_mailbox.n_messages + 1;
		if msg_facility_mailbox.n_messages > msg_facility_mailbox.n_elements then do;
			n_messages = msg_facility_mailbox.n_elements + MSG_ARRAY_BLOCK_SIZE;
			allocate msg_array in (sys_area);
			if msg_facility_mailbox.messages_ptr ^= null () then do;
				array_length = MSG_ARRAY_ELEMENT_LENGTH * (msg_facility_mailbox.n_messages - 1);
				destination_string_ptr = addr (msg_array (1));
				source_string_ptr = addr (internal_msg_array (1));
				destination_string = source_string;
				free internal_msg_array in (sys_area);
			     end;
			msg_facility_mailbox.n_elements = n_messages;
			msg_facility_mailbox.messages_ptr = msg_array_ptr;
		     end;
		idx = msg_facility_mailbox.n_messages;

/* See if we need to insert this message at a different point in the
   message array. */
		if idx ^= 1 then do;
			found = FALSE;
			do while (^found & idx > 1);
			     if internal_msg_array.message_id (idx - 1) < message_id then found = TRUE;
			     else idx = idx - 1;
			end;

			if idx ^= msg_facility_mailbox.n_messages then do;
				array_length = MSG_ARRAY_ELEMENT_LENGTH * (msg_facility_mailbox.n_messages - idx);
				call mrl_ (addr (internal_msg_array (idx)), array_length,
				     addr (internal_msg_array (idx + 1)), array_length);
			     end;

		     end;

		internal_msg_array.message_id (idx) = message_id;
		internal_msg_array.message_number (idx) = new_message_number;
		d_permission = substr (access_mode, 2, 1);
		if d_permission then internal_msg_array.printed (idx) = mail_format.seen;
		else internal_msg_array.printed (idx) = FALSE;
		internal_msg_array.mbz (idx) = ""b;
		current_message_index = idx;
	     end;

/* update last message info */
	message_info_ptr = msg_facility_mailbox.last_message_ptr;
	if message_info_ptr ^= null () then do;
		mail_format_ptr = message_info.message_ptr;
		if mail_format_ptr ^= null () then free mail_format in (sys_area);
		free message_info in (sys_area);
	     end;

	allocate message_info in (sys_area);
	message_info.version = MESSAGE_INFO_VERSION_1;
	message_info.sender = local_mra.sender_id;
	message_info.message_ptr = local_mra.ms_ptr;
	message_info.authorization = local_mra.sender_authorization;
	msg_facility_mailbox.last_id = message_id;
	msg_facility_mailbox.last_message_ptr = message_info_ptr;
	msg_facility_mailbox.last_message_number = internal_msg_array.message_number (current_message_index);

/* Call handler. */
	call msg_facility_mailbox.wakeup_handler (msg_facility_mailbox_ptr, msg_facility_mailbox.wakeup_info_ptr);
	return;					/* wakeup_processor */

/* This entry is the default alarm handler. */
default_alarm_handler: entry (P_msgf_mbx_ptr, P_info_ptr);
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;
	if msg_facility_mailbox.n_messages = 0 then return;

	use_call_string = FALSE;
	if P_info_ptr ^= null then if call_string ^= "" then use_call_string = TRUE;

	if ^use_call_string then
	     call ioa_$ioa_switch (iox_$user_io, "^[You have^;There are^] ^d message^[s^]^[ in ^a^].", msg_facility_mailbox.default_mbx, msg_facility_mailbox.n_messages,
		(msg_facility_mailbox.n_messages ^= 1), ^msg_facility_mailbox.default_mbx,
		pathname_ ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename)));
	do idx = 1 to msg_facility_mailbox.n_messages;
	     call process_message (internal_msg_array.message_id (idx));
	end;
	call iox_$control (iox_$user_io, "start", null (), code);
	return;					/* default_alarm_handler */

/* This entry is the default wakeup handler. */
default_wakeup_handler: entry (P_msgf_mbx_ptr, P_info_ptr);
	msg_facility_mailbox_ptr = P_msgf_mbx_ptr;

	use_call_string = FALSE;
	if P_info_ptr ^= null () then if call_string ^= "" then use_call_string = TRUE;

	call process_message (msg_facility_mailbox.last_id);
	call iox_$control (iox_$user_io, "start", null (), code);
	return;					/* default_wakeup_handler */

/* This procedure returns a message array index given a message ID. */
get_message_index: procedure (P_message_id, P_message_index, P_code);
	dcl     P_message_id	 bit (72) aligned parm;
	dcl     P_message_index	 fixed bin parm;
	dcl     P_code		 fixed bin (35) parm;
	dcl     idx		 fixed bin;
	dcl     (max_idx, high_idx, low_idx, high_temp, low_temp) fixed bin;
	dcl     message_id		 bit (54) aligned;
	dcl     done_searching	 bit (1) aligned;

	P_message_index = 0;

	if msg_facility_mailbox.n_messages = 0 then do;
		P_code = error_table_$no_message;
		return;
	     end;

	P_code = 0;
	message_id = substr (P_message_id, 19, 54);	/* date/time portion */

	low_idx = 1;
	if ^msg_facility_mailbox.msg_array_compacted then max_idx = msg_facility_mailbox.n_elements;
	else max_idx = msg_facility_mailbox.n_messages;	/* faster */
	high_idx = max_idx;
	idx = divide (high_idx + low_idx, 2, 17, 0);
	done_searching = FALSE;

	do while (^done_searching);
	     if internal_msg_array.message_id (idx) = ""b then do; /* deleted */
		     high_temp = min (idx + 1, max_idx);
		     low_temp = max (idx - 1, 1);
		     do while (high_temp < max_idx & internal_msg_array.message_id (high_temp) = ""b);
			high_temp = high_temp + 1;
		     end;
		     do while (low_temp > 1 & internal_msg_array.message_id (low_temp) = ""b);
			low_temp = low_temp - 1;
		     end;
		     if substr (internal_msg_array.message_id (high_temp), 19, 54) > message_id
			| internal_msg_array.message_id (high_temp) = ""b then high_idx = low_temp;
		     else low_idx = high_temp;

		     if idx > high_idx then idx = high_idx;
		     else if idx < low_idx then idx = low_idx;
		end;

	     else if substr (internal_msg_array.message_id (idx), 19, 54) < message_id then do;
		     if idx >= max_idx then done_searching = TRUE;
		     else if substr (internal_msg_array.message_id (idx + 1), 19, 54) > message_id then done_searching = TRUE;
		     else do;
			     low_idx = idx;
			     idx = idx + max (divide (high_idx - idx, 2, 17, 0), 1);
			end;
		end;

	     else if idx = 1 then done_searching = TRUE;
	     else if substr (internal_msg_array.message_id (idx - 1), 19, 54) < message_id then done_searching = TRUE;
	     else do;
		     high_idx = idx;
		     idx = idx - max (divide (idx - low_idx, 2, 17, 0), 1);
		end;
	end;

	if message_id ^= substr (internal_msg_array.message_id (idx), 19, 54) then P_code = error_table_$no_message;
	else P_message_index = idx;
	return;
     end get_message_index;

/* This procedure creates or updates the message array. */
create_message_array: procedure;
	dcl     msg_existence_array	 (msg_facility_mailbox.n_messages) bit (1) aligned;
	dcl     old_msg_count	 fixed bin;
	dcl     msg_count		 fixed bin;
	dcl     n_deleted		 fixed bin;

/* initialize msg existence array */
	msg_existence_array (*) = FALSE;
	old_msg_count = msg_facility_mailbox.n_messages;
	msg_count = 0;

/* compact message array */
	if ^msg_facility_mailbox.msg_array_compacted then
	     call compact_message_array;

/* add new messages to array */
	mail_format_ptr = null ();

	on cleanup begin;
		if mail_format_ptr ^= null () then free mail_format in (sys_area);
	     end;

/* Determine which mailbox_ entry points to use. */
	call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code);

	if code ^= 0 then return;
	own = ^substr (access_mode, 3, 1);

MSG_ARRAY_NEW_READ:
	if ^own then call mailbox_$read_index (msg_facility_mailbox.index, area_ptr, READ_FIRST, addr (local_mra), code);
	else call mailbox_$own_read_index (msg_facility_mailbox.index, area_ptr, READ_FIRST, addr (local_mra), code);

	if code = error_table_$seg_unknown then do;
		call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename),
		     msg_facility_mailbox.index, code);
		if code ^= 0 then return;
		go to MSG_ARRAY_NEW_READ;
	     end;

	do while (code = 0);
	     mail_format_ptr = local_mra.ms_ptr;
	     message_id = local_mra.ms_id;
	     found = FALSE;
	     do idx = 1 to msg_facility_mailbox.n_messages while (^found);
		if internal_msg_array.message_id (idx) = message_id then do; /* found message */
			found = TRUE;
			msg_existence_array (idx) = TRUE;
			msg_count = msg_count + 1;
			if internal_msg_array.message_number (idx) = 0 then
			     if (msg_facility_mailbox.hold_messages & ^mail_format.notify)
				| (msg_facility_mailbox.hold_notifications & mail_format.notify) then
				do;		/* already in mbx, now in hold mode */
				     msg_facility_mailbox.highest_message = msg_facility_mailbox.highest_message + 1;
				     internal_msg_array.message_number (idx) = msg_facility_mailbox.highest_message;
				end;		/* assign number to old message */
			     else ;
			else /* message_number is nonzero, do we want to make it zero? */
			     if (^msg_facility_mailbox.hold_messages & ^mail_format.notify)
			     | (^msg_facility_mailbox.hold_notifications & mail_format.notify) then
			     internal_msg_array.message_number (idx) = 0; /* already in mailbox, now in non-hold mode */
		     end;				/* found message */
	     end;
	     if ^found & mail_format.wakeup then do;
						/* add this message */
		     msg_facility_mailbox.n_messages = msg_facility_mailbox.n_messages + 1;
		     if msg_facility_mailbox.n_messages > msg_facility_mailbox.n_elements then do;
			     n_messages = msg_facility_mailbox.n_elements + MSG_ARRAY_BLOCK_SIZE;
			     allocate msg_array in (sys_area);
			     if msg_facility_mailbox.messages_ptr ^= null () then do;
				     array_length = MSG_ARRAY_ELEMENT_LENGTH * (msg_facility_mailbox.n_messages - 1);
				     destination_string_ptr = addr (msg_array (1));
				     source_string_ptr = addr (internal_msg_array (1));
				     destination_string = source_string;
				     free internal_msg_array in (sys_area);
				end;
			     msg_facility_mailbox.n_elements = n_messages;
			     msg_facility_mailbox.messages_ptr = msg_array_ptr;
			end;

		     jdx = msg_facility_mailbox.n_messages;

/* See if we need to insert this message at a different point in the
   message array. */
		     if jdx ^= 1 then do;
			     found = FALSE;
			     do while (^found & jdx > 1);
				if internal_msg_array.message_id (jdx - 1) < message_id then found = TRUE;
				else jdx = jdx - 1;
			     end;

			     if jdx ^= msg_facility_mailbox.n_messages then do;
				     array_length = MSG_ARRAY_ELEMENT_LENGTH * (msg_facility_mailbox.n_messages - jdx);
				     call mrl_ (addr (internal_msg_array (jdx)), array_length,
					addr (internal_msg_array (jdx + 1)), array_length);
				end;

			end;

		     internal_msg_array.message_id (jdx) = message_id;
		     d_permission = substr (access_mode, 2, 1);
		     if d_permission then internal_msg_array.printed (jdx) = mail_format.seen;
		     else internal_msg_array.printed (jdx) = FALSE;
		     internal_msg_array.mbz (jdx) = ""b;

		     if (msg_facility_mailbox.hold_messages & ^mail_format.notify)
			| (msg_facility_mailbox.hold_notifications & mail_format.notify) then do;
			     internal_msg_array.message_number (jdx) =
				msg_facility_mailbox.highest_message + 1;
			     msg_facility_mailbox.highest_message = msg_facility_mailbox.highest_message + 1;
			end;
		     else internal_msg_array.message_number (jdx) = 0;
		end;				/* new one */
	     if mail_format_ptr ^= null () then do;
		     free mail_format in (sys_area);
		     mail_format_ptr = null ();
		end;

	     if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_FORWARD,
		     message_id, addr (local_mra), code);
	     else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_FORWARD, message_id,
		     addr (local_mra), code);
	end;


	if code = error_table_$no_message then code = 0;
	else if code ^= 0 then return;

/* Now delete messages which are no longer in the mailbox, if any. */
	if msg_count < old_msg_count then do;
		n_deleted = 0;
		msg_facility_mailbox.msg_array_compacted = FALSE;
		do idx = 1 to old_msg_count while (n_deleted < old_msg_count - msg_count);
		     if ^msg_existence_array (idx) then do; /* we didn't find this one */
			     n_deleted = n_deleted + 1;
			     msg_facility_mailbox.n_messages = msg_facility_mailbox.n_messages - 1;
			     internal_msg_array.message_id (idx) = ""b;
			     internal_msg_array.message_number (idx) = 0;
			end;
		end;
		call compact_message_array;
	     end;

/* If we don't own this mailbox (no "d") then assign numbers in sequence.
   This allows us to delete our messages by number in another's mailbox. */
	if own | ^substr (access_mode, 2, 1) then do;
		msg_facility_mailbox.highest_message = 0;
		do idx = 1 to msg_facility_mailbox.n_messages;
		     msg_facility_mailbox.highest_message = msg_facility_mailbox.highest_message + 1;
		     internal_msg_array.message_number (idx) = msg_facility_mailbox.highest_message;
		end;
	     end;

	if code = error_table_$no_message then code = 0;

	if msg_facility_mailbox.wakeup_state = "10"b then
	     msg_facility_mailbox.msg_array_updated = TRUE;
     end create_message_array;

/* This procedure compacts the message array. */
compact_message_array: procedure;
	idx, last_index = 0;
	do while (last_index < msg_facility_mailbox.n_messages);
	     idx = idx + 1;
	     last_index = last_index + 1;
	     do while (idx < msg_facility_mailbox.n_elements & internal_msg_array.message_id (idx) = ""b);
		idx = idx + 1;
	     end;
	     if idx ^= last_index & internal_msg_array.message_id (idx) ^= ""b then do;
		     internal_msg_array (last_index) = internal_msg_array (idx);
		     internal_msg_array.message_id (idx) = ""b;
		     internal_msg_array.message_number (idx) = 0;
		end;
	end;
	if msg_facility_mailbox.messages_ptr ^= null () & last_index ^= 0 then
	     if internal_msg_array.message_id (last_index) = ""b then last_index = last_index - 1;
	msg_facility_mailbox.n_messages = last_index;
	msg_facility_mailbox.msg_array_compacted = TRUE;
     end compact_message_array;

/* This procedure removes control characters (except backspace, tab,
   red ribbon shift, and black ribbon shift) and canonicalizes strings
   to prevent backspacing past the front of the string. */
canon: procedure (P_string, P_string_len) returns (char (*));
	dcl     P_string		 char (*) parm;
	dcl     P_string_len	 fixed bin (21) parm;
	dcl     output_string	 char (P_string_len);

	P_string = translate (P_string, ALPHABET);
	if index (P_string, BS) ^= 0 then do;
		output_string = "";
		call canonicalize_ (addr (P_string), length (P_string), addr (output_string), P_string_len, (0));
		return (output_string);
	     end;
	else return (P_string);
     end canon;

/* This procedure sends an acknowledgement message. */
send_acknowledgement: procedure;
	authorization = get_authorization_ ();
	if aim_check_$greater_or_equal (local_mra.sender_authorization, authorization) then do;
		call get_person_and_project;
		send_mail_info.version = send_mail_info_version_2;
		send_mail_info.sent_from = full_name;
		send_mail_info.wakeup = TRUE;
		send_mail_info.always_add = TRUE;
		send_mail_info.never_add = FALSE;
		send_mail_info.notify = TRUE;
		send_mail_info.acknowledge = FALSE;
		send_mail_info.mbz = ""b;
		person_id = before (substr (local_mra.sender_id, 1, length (rtrim (local_mra.sender_id)) - 2), ".");
		project_id = after (substr (local_mra.sender_id, 1, length (rtrim (local_mra.sender_id)) - 2), ".");
		dname = ">udd>" || rtrim (project_id) || ">" || person_id;
		ename = rtrim (person_id) || ".mbx";
		date_time = fixed (substr (local_mra.ms_id, 19, 54), 71);
		call date_time_ (date_time, msg_date_time);
		call date_time_ (clock (), current_date_time);
		if msg_date_time = current_date_time then message = "Acknowledged.";
		else message = "Acknowledge message of " || msg_date_time;

		code = 1;

		if person_id = "anonymous" then do;
			login_name = local_mra.ms_ptr -> mail_format.sent_from;
			call message_facility_$send_message (">udd>" || rtrim (project_id) || ">" || login_name,
			     rtrim (login_name) || ".mbx", message, addr (send_mail_info), code);
			if code ^= error_table_$noentry then code = 0;
		     end;

		if code ^= 0 then call message_facility_$send_message (dname, ename, message, addr (send_mail_info), (0));
	     end;

	mail_format.acknowledge = FALSE;
	call mailbox_$update_message_index (msg_facility_mailbox.index, 36 * (fixed (rel (addr (mail_format.text)))
	     - fixed (rel (addr (mail_format.version)))), message_id, local_mra.ms_ptr, (0));
     end send_acknowledgement;

/* This procedure prints out a message or executes the supplied call string. */
process_message: procedure (P_message_id);
	dcl     P_message_id	 bit (72) aligned parm;
	dcl     message_id		 bit (72) aligned;
	dcl     message_index	 fixed bin;

	message_id = P_message_id;
	mail_format_ptr = null ();
	local_mi.version = MESSAGE_INFO_VERSION_1;

	call get_message_index (message_id, message_index, code);

	if code ^= 0 then return;

	on cleanup begin;
		if mail_format_ptr ^= null () then free mail_format in (sys_area);
	     end;

	call message_facility_$read_message (msg_facility_mailbox_ptr, message_id, area_ptr, addr (local_mi), code);
	if code ^= 0 then return;
	mail_format_ptr = local_mi.message_ptr;
	date_time = fixed (substr (message_id, 19, 54), 71);
	call date_time_ (date_time, msg_date_time);

/* create message sender string */
	if mail_format.sent_from = before (local_mi.sender, ".") | rtrim (mail_format.sent_from) = "" then
	     message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2);
	else message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2)
		|| " (" || rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) || ")";
	authorization = get_authorization_ ();
	if ^aim_check_$greater_or_equal (local_mi.authorization, authorization) then do;
		call convert_access_class_$to_string_short (local_mi.authorization, auth_string, code);
		if auth_string = "" then auth_string = "system_low";
		message_sender = rtrim (message_sender) || " at " || auth_string;
	     end;

	if use_call_string then do;
		call ioa_$rsnnl ("^a ^d ^a ^a ^a^[ ^a^]", command_line, (0), call_string, internal_msg_array.message_number (message_index),
		     requote_string_ (rtrim (message_sender)),
		     requote_string_ (rtrim (date_time_$format ("date_time", date_time, "", ""))),
		     requote_string_ (rtrim (canon (rtrim (mail_format.text, NLSPHT), length (rtrim (mail_format.text, NLSPHT))))),
		     ^msg_facility_mailbox.default_mbx,
		     requote_string_ (pathname_ ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename))));

/* If this message is supposed to be deleted, do so. */
		if (mail_format.notify & ^msg_facility_mailbox.hold_notifications) |
		     (^mail_format.notify & ^msg_facility_mailbox.hold_messages) then
		     call message_facility_$set_seen_switch (msg_facility_mailbox_ptr, message_id, DELETE_UNHELD, (0));
		call cu_$cp (addr (command_line), length (rtrim (command_line)), (0));
	     end;

	else do;
						/* print message */
		string (msg_print_flags) = ""b;
		if message_sender = last_sender then short = TRUE;
		else short = FALSE;

/* print prefix, it may contain ioa_ controls */
		if ^short | msg_facility_mailbox.short_prefix then msg_print_flags.print_prefix = TRUE;

/* if not default mailbox, prefix with mailbox entry name */
		if ^msg_facility_mailbox.default_mbx then msg_print_flags.print_ename = TRUE;

		if ^msg_facility_mailbox.short_format | ^short then
		     msg_print_flags.print_sender = TRUE;

		if ^msg_facility_mailbox.short_format | substr (msg_date_time, 1, 8) ^= last_msg_time then
		     msg_print_flags.print_date_and_time = TRUE;
		else if date_time - last_time > FIVE_MINUTES then msg_print_flags.print_time = TRUE;

		last_sender = message_sender;
		last_time = date_time;
		last_msg_time = substr (msg_date_time, 1, 8);

		call message_facility_$print_message (msg_facility_mailbox_ptr, iox_$user_io, message_id, addr (msg_print_flags), code);


		call message_facility_$set_seen_switch (msg_facility_mailbox_ptr, message_id, DELETE_UNHELD, code);
	     end;
	if mail_format_ptr ^= null () then free mail_format in (sys_area);
     end process_message;

/* Get person ID, project ID, and full name. */
get_person_and_project: procedure;
	if person = "" then call user_info_$whoami (person, project, "");

/* Since the full name is stored in the "sent_from" field of the mail_format
   structure, we don't get a value from the value segment for an anonymous
   user since it is important that the login name be there so that replies
   and acknowledgements get sent to the right place.  When we change this
   to use mail_system_ more fully, we can do the right thing. */

	if full_name = "" & person ^= "anonymous" then do;
		call value_$get (null (), PERMANENT_VALUES, rtrim (person) || ".full_name._", full_name, code);
		if code ^= 0 then call value_$get (null (), PERMANENT_VALUES, "full_name._", full_name, code);
		if code ^= 0 then full_name = person;
	     end;

	else if person = "anonymous" then full_name = person;
     end get_person_and_project;

%page;
%include event_call_info;
%page;
%include last_message_info;
%page;
%include mail_format;
%page;
%include message_info;
%page;
%include mseg_return_args;
%page;
%include msg_array;
%page;
%include msg_facility_mailbox;
%page;
%include msg_print_flags;
%page;
%include send_mail_info;
%page;
%include sub_err_flags;
     end message_facility_;




		    message_status.pl1              06/30/86  1407.4rew 06/30/86  1342.8      125334



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
/* This command prints information about mailboxes on which messages
   are being accepted or deferred. */

/****^  HISTORY COMMENTS:
  1) change(84-06-11,Lippard), approve(), audit(),
     install(86-06-30,MR12.0-1080):
      Written by Jim Lippard.
  2) change(85-09-10,Lippard), approve(85-11-18,MCR7298),
     audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006):
      Modified to work as an active function.
  3) change(86-05-09,Lippard), approve(86-06-24,MCR7434),
     audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080):
      Modified to reject -all as an active function.
                                                   END HISTORY COMMENTS */

message_status: msgst: procedure options (variable);
	dcl     ME		 char (14) internal static options (constant) init ("message_status");
	dcl     VERSION		 char (3) internal static options (constant) init ("1.2");

	dcl     com_err_		 entry () options (variable);

	dcl     get_system_free_area_	 entry () returns (ptr);

	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));

	dcl     interpret_ptr_	 entry (ptr, ptr, ptr);

	dcl     ioa_		 entry () options (variable);

	dcl     mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35));

	dcl     message_facility_$default_wakeup_handler entry (ptr, ptr);
	dcl     message_facility_$default_alarm_handler entry (ptr, ptr);
	dcl     message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35));
	dcl     message_facility_$get_msg_array_ptr entry (ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     message_facility_$get_wakeup_state entry (ptr, bit (*), fixed bin (35));
	dcl     message_facility_$get_message_format entry (ptr, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$get_prefix entry (ptr, char (32) var, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$get_alarm_handler entry (ptr, entry, ptr, fixed bin (71), fixed bin (35));
	dcl     message_facility_$get_wakeup_handler entry (ptr, entry, ptr, fixed bin (35));
	dcl     message_facility_$get_next_msgf_mbx_ptr entry (ptr, ptr);
	dcl     message_facility_$get_mbx_path entry (ptr, char (*), char (*), bit (1) aligned, fixed bin (35));

	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     ssu_$print_message	 entry () options (variable);
	dcl     ssu_$return_arg	 entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21));
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

	dcl     user_info_$whoami	 entry (char (*), char (*), char (*));

	dcl     cleanup		 condition;

	dcl     active_function	 bit (1) aligned;

	dcl     alarm_handler	 variable entry (ptr, ptr);
	dcl     alarm_info_ptr	 ptr;
	dcl     alarm_time		 fixed bin (71);
	dcl     alarm_ptr		 ptr;
	dcl     alarm_dname		 char (168);
	dcl     alarm_ename		 char (32);

	dcl     all		 bit (1) aligned;

	dcl     arg_count		 fixed bin;
	dcl     arg_ptr		 ptr;
	dcl     arg_len		 fixed bin (21);
	dcl     arg		 char (arg_len) based (arg_ptr);

	dcl     call_string		 char (512) aligned based (call_string_ptr);
	dcl     call_string_ptr	 ptr;

	dcl     default		 bit (1) aligned;

	dcl     dname		 char (168);
	dcl     ename		 char (32);

	dcl     flags		 bit (5);

	dcl     idx		 fixed bin;

	dcl     1 local_pcao	 aligned like parse_ca_options;

	dcl     msgf_mbx_ptr	 ptr;

	dcl     path		 bit (1) aligned;

	dcl     person		 char (22);
	dcl     project		 char (9);

	dcl     prefix		 char (32) var;

	dcl     printed_something	 bit (1) aligned;

	dcl     return_ptr		 ptr;
	dcl     return_len		 fixed bin (21);
	dcl     return_arg		 char (return_len) varying based (return_ptr);
	dcl     return_string	 char (2000) varying;

	dcl     sci_ptr		 ptr;

	dcl     short_format	 bit (1) aligned;
	dcl     short_prefix	 bit (1) aligned;

	dcl     strp                   ptr;

	dcl     sys_area		 area based (sys_area_ptr);
	dcl     sys_area_ptr	 ptr;

	dcl     wakeup_handler	 variable entry (ptr, ptr);
	dcl     wakeup_info_ptr	 ptr;
	dcl     wakeup_ptr		 ptr;
	dcl     wakeup_dname	 char (168);
	dcl     wakeup_ename	 char (32);

	dcl     (addr, character, codeptr, environmentptr, ltrim, null, rtrim, substr) builtin;

	dcl     code		 fixed bin (35);

	dcl     TRUE		 bit (1) aligned internal static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) aligned internal static options (constant) init ("0"b);

/* initialize variables */
	all, default, path, printed_something = FALSE;
	msg_array_ptr, sci_ptr = null ();
	sys_area_ptr = get_system_free_area_ ();

	on cleanup call cleanup_msgst;

/* create ssu_ invocation */
	call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_msgst, code);

	if code ^= 0 then do;
		call com_err_ (code, ME, "Creating standalone subsystem invocation.");
		return;
	     end;

/* process arguments */
	call ssu_$return_arg (sci_ptr, arg_count, active_function, return_ptr, return_len);

	do idx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
	     if (arg = "-all" | arg = "-a") & ^active_function then all = TRUE;
	     else do;
						/* let mlsys_utils_ have at it */
		     local_pcao.version = PARSE_CA_OPTIONS_VERSION_1;
		     local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX;
		     local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX;
		     local_pcao.abort_on_errors = TRUE;
		     local_pcao.validate_addresses = FALSE;
		     local_pcao.mbz = ""b;

		     call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao), dname, ename, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code);

		     idx = idx - 1;

		     if path then call ssu_$abort_line (sci_ptr, (0), "Usage: msgst {mbx_specification} {-control_args}");

		     path = TRUE;
		end;
	end;

	if all & path then call ssu_$abort_line (sci_ptr, (0),
		"A mailbox specification and ""-all"" are mutually exclusive.");

	if ^all & ^path then do;
		call user_info_$whoami (person, project, "");
		dname = ">udd>" || rtrim (project) || ">" || person;
		ename = rtrim (person) || ".mbx";
		default = TRUE;
	     end;

	if all then do;
		call message_facility_$get_next_msgf_mbx_ptr (null (), msgf_mbx_ptr);

		do while (msgf_mbx_ptr ^= null ());
		     call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code);
		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code);
		     if substr (flags, 4, 2) ^= "00"b then do;
			     call message_facility_$get_mbx_path (msgf_mbx_ptr, dname, ename, default, code);

			     if code ^= 0 then call ssu_$abort_line (sci_ptr, code);

			     call process_mailbox;
			     printed_something = TRUE;
			end;
		     call message_facility_$get_next_msgf_mbx_ptr (msgf_mbx_ptr, msgf_mbx_ptr);
		end;
		if ^printed_something then call ssu_$abort_line (sci_ptr, (0),
			"You are not currently accepting or deferring messages on any mailboxes.");
	     end;

	else do;
		call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code);

		if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

		call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code);

		if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename));

		if substr (flags, 4, 2) = "00"b then call ssu_$abort_line (sci_ptr, (0),
			"You are not accepting or deferring messages on the specified mailbox. ^a", pathname_ (dname, ename));

		call process_mailbox;
	     end;

	call cleanup_msgst;
RETURN_FROM_MST:
	return;

process_mailbox: proc;

	return_string = "";

/* get wakeup state */
	call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code);

	if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename));
		return;
	     end;

/* get message format */
	call message_facility_$get_message_format (msgf_mbx_ptr, short_format, code);

	if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename));
		return;
	     end;

/* get prefix */
	call message_facility_$get_prefix (msgf_mbx_ptr, prefix, short_prefix, code);

	if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename));
		return;
	     end;

/* get handler info */
	call message_facility_$get_wakeup_handler (msgf_mbx_ptr, wakeup_handler, wakeup_info_ptr, code);

	if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename));
		return;
	     end;

/* get alarm info */
	call message_facility_$get_alarm_handler (msgf_mbx_ptr, alarm_handler, alarm_info_ptr, alarm_time, code);

	if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename));
		return;
	     end;

/* convert wakeup/alarm handlers to char strings */
	wakeup_ptr = codeptr (wakeup_handler);
	alarm_ptr = codeptr (alarm_handler);

	call hcs_$fs_get_path_name (wakeup_ptr, wakeup_dname, (0), wakeup_ename, code);

	if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename));
		return;
	     end;

	call hcs_$fs_get_path_name (alarm_ptr, alarm_dname, (0), alarm_ename, code);

	if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename));
		return;
	     end;
	if ^active_function then do;

/* get number of messages */
		call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code);

		if code ^= 0 then do;
			call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename));
			return;
		     end;

/* print info */
		call ioa_ ("^[^/^]Mailbox: ^a^[ (default)^]", printed_something, pathname_ (dname, ename), default);
		call ioa_ ("Number of messages: ^d", n_messages);
		call ioa_ ("Wakeup state: ^[deferring^;accepting^] messages", substr (flags, 5, 1));
		call ioa_ ("^3x^[not ^]holding messages", ^substr (flags, 1, 1));
		call ioa_ ("^3x^[not ^]holding notifications", ^substr (flags, 2, 1));
		call ioa_ ("^3x^[not ^]printing notifications", ^substr (flags, 3, 1));
		call ioa_ ("Message format: ^[short^;long^]", short_format);
		if prefix ^= "" then call ioa_ ("Prefix string: ^a^[ (short prefix)^]", prefix, short_prefix);

		call interpret_ptr_ (codeptr (wakeup_handler), environmentptr (wakeup_handler), addr (strbuf));
		call ioa_ ("Wakeup handler: ^a^a^/^3x(^a|^a)", strbuf.segment, strbuf.entryn,
		     pathname_ (wakeup_dname, wakeup_ename), strbuf.offset);
		call_string_ptr = wakeup_info_ptr;
		if wakeup_handler = message_facility_$default_wakeup_handler & wakeup_info_ptr ^= null () then
		     if call_string ^= "" then
			call ioa_ ("^[Wakeup call^;Call^] string: ^a", (wakeup_info_ptr ^= alarm_info_ptr), call_string);
		if alarm_time ^= 0 then do;
			call interpret_ptr_ (codeptr (alarm_handler), environmentptr (alarm_handler), addr (strbuf));
			call ioa_ ("Alarm handler: ^a^a^/^3x(^a|^a)", strbuf.segment, strbuf.entryn,
			     pathname_ (alarm_dname, alarm_ename), strbuf.offset);
			call ioa_ ("Alarm wakeup every ^d seconds", alarm_time);
			call_string_ptr = alarm_info_ptr;
			if (wakeup_info_ptr ^= alarm_info_ptr)
			     & (alarm_handler = message_facility_$default_alarm_handler)
			     & (alarm_info_ptr ^= null ()) then
			     if call_string ^= "" then call ioa_ ("Alarm call string: ^a", call_string);
		     end;
	     end;

	else do;					/* active function case */
		if wakeup_handler ^= message_facility_$default_wakeup_handler
		     | alarm_handler ^= message_facility_$default_alarm_handler then
		     call ssu_$abort_line (sci_ptr, (0), "The current wakeup state cannot be described by control arguments due to non-standard alarm or wakeup handler.");

		return_string = "accept_messages -mailbox " || rtrim (pathname_ (dname, ename));

		if substr (flags, 1, 1) then return_string = return_string || " -hold_messages";
		else return_string = return_string || " -no_hold_messages";

		if substr (flags, 2, 1) then return_string = return_string || " -hold_notifications";
		else return_string = return_string || " -no_hold_notifications";

		if substr (flags, 3, 1) then return_string = return_string || " -notifications";
		else return_string = return_string || " -no_notifications";

		if short_format then return_string = return_string || " -short";
		else return_string = return_string || " -long";

		return_string = return_string || " -prefix """ || prefix || """";
		if short_prefix then return_string = return_string || " -short_prefix";
		else return_string = return_string || " -no_short_prefix";

		call_string_ptr = wakeup_info_ptr;
		if wakeup_info_ptr ^= null () then
		     return_string = return_string || " -call """ || rtrim (call_string) || """";
		else return_string = return_string || " -call """"";

		return_string = return_string || " -time " || ltrim (character (alarm_time));

		if substr (flags, 5, 1) then return_string = return_string || ";defer_messages";

		return_arg = return_string;
	     end;					/* active function case */
     end process_mailbox;

cleanup_msgst: proc;
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	if msg_array_ptr ^= null () then free msg_array in (sys_area);
	return;
     end cleanup_msgst;

abort_msgst: proc;
	call cleanup_msgst;
	go to RETURN_FROM_MST;
     end abort_msgst;

%page;
%include interpret_ptr_struc;
%page;
%include mlsys_parse_ca_options;
%page;
%include msg_array;

     end message_status;




		    send_mail_.pl1                  06/30/86  1407.4rew 06/30/86  1342.1       45225



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(86-06-02,Herbst), approve(86-06-02,MCR7432), audit(86-06-30,Wong),
     install(86-06-30,MR12.0-1080):
     Changed to initialize unused portions of mail_format to zero.
                                                   END HISTORY COMMENTS */


send_mail_: proc (destination, message, send_info_ptr, code);

	/* This subroutine sends one message to a specified
	   Person.Project destination and optionally accompanies
	   it with a wakeup. Control information is input via
	   the structure send_mail_info. */

	/* Steve Herbst 7/1/75 */
/* Arguments declared char (*) 05/12/80 S. Herbst */

%include mail_format;
%include send_mail_info;
dcl 1 send_info like send_mail_info based(send_info_ptr);

dcl (destination, message) char(*);
dcl (a_dn, a_en) char (*);
dcl dn char (168);
dcl en char (32);
dcl newline char(1) aligned init("
");
dcl switch bit(36) init("0"b);
dcl (a_access_class, access_class, id) bit(72) aligned;
dcl aim_add bit(1) aligned;
dcl retried bit(1) aligned;				/* retried once already after $bad_segment */

dcl send_info_ptr ptr;

dcl (count, i, j) fixed bin;
dcl mbx_index fixed bin init(0);			/* index of recipient's mailbox */
dcl msg_bitcnt fixed bin;				/* bitcnt of message added */

dcl code fixed bin(35);
dcl error_table_$bad_segment fixed bin(35) ext;
dcl error_table_$noentry fixed bin(35) ext;
dcl error_table_$rqover fixed bin(35) ext;

dcl mailbox_$close entry(fixed bin,fixed bin(35));
dcl mailbox_$open entry(char(*),char(*),fixed bin,fixed bin(35));
dcl mailbox_$wakeup_add_index entry(fixed bin,ptr,fixed bin,bit(36),bit(72)aligned,fixed bin(35));
dcl mailbox_$wakeup_aim_add_index entry(fixed bin,ptr,fixed bin,bit(36),bit(72)aligned,bit(72)aligned,fixed bin(35));

dcl (addr, index, length, reverse, size, substr, verify) builtin;

dcl (cleanup, record_quota_overflow) condition;
/**/
	aim_add = "0"b;
	go to COMMON;

access_class: entry (destination, message, send_info_ptr, a_access_class, code);

	aim_add = "1"b;
	access_class = a_access_class;

	/* locate recipient's mailbox */

COMMON:	i = index(destination,".");
	j = length(destination) + 1 - verify(reverse(destination)," ");
	if i=0 then do;				/* invalid destination */
	     code = error_table_$noentry;		/* no such mailbox */
	     return;
	end;
	else do;
	     dn = ">udd>" || substr(destination,i+1,j-i) || ">" || substr(destination,1,i-1);
	     en = substr(destination,1,i-1) || ".mbx";
	end;
	go to OPEN;

path:	entry (a_dn, a_en, message, send_info_ptr, code);

	aim_add = "0"b;
	go to COMMON2;

path_access_class: entry (a_dn, a_en, message, send_info_ptr, a_access_class, code);

	aim_add = "1"b;
	access_class = a_access_class;

COMMON2:	dn = a_dn;
	en = a_en;
	i = length (rtrim (en));
	if i < 5 then do;
ADD_SUFFIX:    substr (en, i + 1, 4) = ".mbx";
	end;
	else if substr (en, i - 3, 4) ^= ".mbx" then go to ADD_SUFFIX;

OPEN:	on condition (cleanup) begin;
	     if mbx_index ^= 0 then call mailbox_$close (mbx_index, 0);
	end;

	call mailbox_$open(dn,en,mbx_index,code);
	if code^=0 then return;

	/* build message */

	if message="" then text_length = 0;
	else text_length = length(message)-verify(reverse(message)," ")+1;
	msg_bitcnt = size(mail_format)*36;

allocate_message: begin;

	dcl mf_space bit(msg_bitcnt) aligned;

	dcl 1 mf aligned like mail_format based(addr(mf_space));

	mf.version = MAIL_FORMAT_VERSION_4;
	mf.text_len = text_length;
	mf.sent_from = send_info.sent_from;
	mf.wakeup = send_info.wakeup;
	mf.notify = send_info.notify;
	mf.acknowledge = send_info.acknowledge;
	mf.urgent, mf.seen, mf.others = "0"b;
	mf.text = message;

	/* count lines */

	mf.lines = 0;
	count = 1;
	i = 1;
	do while(i^=0 & text_length^=0);
	     i = index(substr(message,count,text_length),newline);
	     count = count+i;
	     text_length = text_length-i;
	     mf.lines = mf.lines+1;
	end;

	/* send */

	on condition(record_quota_overflow) begin;
	     code = error_table_$rqover;
	     go to RETURN;
	end;

	switch = mf.wakeup || mf.urgent || send_info.always_add || send_info.never_add;
	retried = "0"b;
RETRY:	if aim_add then call mailbox_$wakeup_aim_add_index
	     (mbx_index,addr(mf),msg_bitcnt,switch,access_class,id,code);
	else call mailbox_$wakeup_add_index(mbx_index,addr(mf),msg_bitcnt,switch,id,code);
	if code=error_table_$bad_segment & ^retried then do;
	     retried = "1"b;
	     go to RETRY;
	end;
	call mailbox_$close(mbx_index,0);

end allocate_message;

RETURN:	return;

end send_mail_;




		    send_message.pl1                12/07/87  1327.6rew 12/07/87  1321.4      232209



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(83-11-22,Lippard), approve(), audit(), install():
      A rewrite by Jim Lippard of the send_message command which was part of
      message_facility.pl1 (written 12/01/75 by Steve Herbst).  This is the
      standard command for sending interactive messages.
  2) change(84-06-26,Lippard), approve(), audit(), install():
      Modified to merge in "accepting" (based on the original "accepting"
      written by James R. Davis on April 29, 1980 which was based on an idea
      of Paul Benjamin).
  3) change(84-11-15,Lippard), approve(), audit(), install():
      Modified to remove the short name "acc" from accepting.
  4) change(84-12-14,Lippard), approve(), audit(), install():
      Modified to do the right thing with error_table_$no_info.
  5) change(85-06-03,Lippard), approve(85-11-18,MCR7298),
     audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006):
      Modified to handle errors properly for accepting.
  6) change(85-08-19,Lippard), approve(85-11-18,MCR7298),
     audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006):
      Modified to correct the error message produced when attempting to send
      a message to a user whose mail table entry points to a mailing list,
      add -update_destination (-upds) and -no_update_destination (-nupds),
      and -acknowledge_if_deferred (-ackid).
  7) change(87-12-02,GWMay), approve(87-12-02,MCR7801),
     audit(87-12-03,Lippard), install(87-12-07,MR12.2-1008):
     Changed to terminate without error when the code error_table_$end_of_info
     is returned by iox_$get_line in the input loop.  The change allows the
     command to be used as a filter without error.
                                                   END HISTORY COMMENTS */

send_message: sm: procedure options (variable);
	dcl     ME		 char (24);
	dcl     VERSION		 char (3) internal static options (constant) initial ("1.4");

	dcl     com_err_		 entry () options (variable);

	dcl     convert_access_class_$from_string entry (bit (72) aligned, char (*), fixed bin (35));

	dcl     cu_$cp		 entry (ptr, fixed bin (21), fixed bin (35));

	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     get_system_free_area_	 entry () returns (ptr);

	dcl     ioa_		 entry () options (variable);

	dcl     iox_$get_line	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$user_input	 ptr ext static;

	dcl     mail_system_$create_user_mailbox_address entry (char (*) varying, char (*) varying, char (*) varying,
				 ptr, fixed bin (35));
	dcl     mail_system_$create_mail_table_address entry (char (*) varying, char (*) varying, char (*) varying,
				 ptr, fixed bin (35));
	dcl     mail_system_$free_address entry (ptr, fixed bin (35));
	dcl     mail_system_$get_address_pathname entry (ptr, char (*), char (*), char (*), fixed bin (35));
	dcl     mail_system_$get_mail_table_address entry (ptr, ptr, fixed bin (35));
	dcl     mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35));

	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

	dcl     message_facility_$get_last_message_info entry (ptr, ptr, fixed bin (35));
	dcl     message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35));
	dcl     message_facility_$send_message entry (char (*), char (*), char (*), ptr, fixed bin (35));
	dcl     message_facility_$send_message_access_class entry (char (*), char (*), char (*), ptr, bit (72) aligned, fixed bin (35));

	dcl     requote_string_	 entry (char (*)) returns (char (*));

	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     ssu_$print_message	 entry () options (variable);
	dcl     ssu_$return_arg	 entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21));
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

	dcl     user_info_$whoami	 entry (char (*), char (*), char (*));

	dcl     af_allowed		 bit (1) aligned;

	dcl     active_function	 bit (1) aligned;

	dcl     arg_count		 fixed bin;
	dcl     arg_ptr		 ptr;
	dcl     arg_len		 fixed bin (21);
	dcl     arg		 char (arg_len) based (arg_ptr);

	dcl     return_ptr		 ptr;
	dcl     return_len		 fixed bin (21);
	dcl     return_arg		 char (return_len) varying based (return_ptr);

	dcl     access_class	 bit (1) aligned;
	dcl     acknowledge		 bit (1) aligned;
	dcl     ack_if_deferred	 bit (1) aligned;
	dcl     comment		 bit (1) aligned;
	dcl     control_args	 bit (1) aligned;
	dcl     destination		 bit (1) aligned;
	dcl     escape		 bit (1) aligned;
	dcl     express		 bit (1) aligned;
	dcl     inhibit_error	 bit (1) aligned;
	dcl     last_destination	 bit (1) aligned;
	dcl     last_sender		 bit (1) aligned;
	dcl     long		 bit (1) aligned;
	dcl     message_allocated	 bit (1) aligned;
	dcl     print_destination	 bit (1) aligned;
	dcl     no_print_destination	 bit (1) aligned;
	dcl     pathname		 bit (1) aligned internal static;
	dcl     suppress_errors	 bit (1) aligned;
	dcl     suppress_warnings	 bit (1) aligned;
	dcl     update_destination	 bit (1) aligned;

	dcl     access_class_arg	 bit (72) aligned;
	dcl     comment_field	 char (32);
	dcl     destination_arg	 char (168);

	dcl     dname		 char (168);
	dcl     ename		 char (32);

	dcl     person		 char (22);
	dcl     project		 char (9);

	dcl     last_destination_arg	 char (168) internal static init ("");
	dcl     last_dname		 char (168) internal static init ("");
	dcl     last_ename		 char (32) internal static init ("");

	dcl     last_person		 char (22);
	dcl     last_project	 char (9);

	dcl     1 local_lmi		 aligned like last_message_info;

	dcl     msgf_mbx_ptr	 ptr;

	dcl     idx		 fixed bin;

	dcl     1 ca_options	 aligned like parse_ca_options;

	dcl     address_ptr		 ptr;
	dcl     mt_address_ptr	 ptr;

	dcl     chars_read		 fixed bin (21);

	dcl     old_message_ptr	 ptr;
	dcl     old_message_len	 fixed bin (21);
	dcl     message_ptr		 ptr;
	dcl     message_len		 fixed bin (21);
	dcl     message_space	 char (1600) aligned;
	dcl     message		 char (message_len) aligned based (message_ptr);
	dcl     start_len		 fixed bin (21);

	dcl     area_ptr		 ptr;
	dcl     area		 area based (area_ptr);

	dcl     sci_ptr		 ptr;

	dcl     cleanup		 condition;

	dcl     (addr, after, before, index, length, null, reverse, rtrim, search, substr) builtin;

	dcl     TRUE		 bit (1) internal static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) internal static options (constant) init ("0"b);
	dcl     DOT_NL		 char (2) internal static options (constant) init (".
");


	dcl     (code, old_code)	 fixed bin (35);

	dcl     (error_table_$badopt,
	        error_table_$end_of_info,
	        error_table_$long_record,
	        error_table_$messages_deferred,
	        error_table_$messages_off,
	        error_table_$no_append,
	        error_table_$noarg,
	        error_table_$no_dir,
	        error_table_$noentry,
	        error_table_$wakeup_denied) external fixed bin (35);

	dcl     mlsys_et_$invalid_user_id_syntax external fixed bin (35);

	ME = "send_message";
	af_allowed = FALSE;
	active_function = FALSE;
	go to COMMON;

accepting: entry;
	ME = "accepting";
	af_allowed = TRUE;
	go to COMMON;

last_message_destination: lmds: entry;
	ME = "last_message_destination";
	af_allowed = TRUE;
	inhibit_error = FALSE;

COMMON:
						/* initialize variables */
	sci_ptr = null ();
	address_ptr, mt_address_ptr = null ();
	area_ptr = null ();
	access_class, acknowledge, ack_if_deferred, destination, express, last_destination, last_sender, long, message_allocated,
	     suppress_errors, suppress_warnings = FALSE;
	comment, escape, update_destination = TRUE;
	print_destination, no_print_destination = FALSE;
	call user_info_$whoami (person, project, "");
	comment_field = person;

	message_ptr = addr (message_space);
	message_len = length (message_space);
	message = "";

	on cleanup call cleanup_sm;

/* create ssu invocation */
	call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null, abort_sm, code);

	if code ^= 0 then do;
		call com_err_ (code, ME, "Creating standalone subsystem invocation.");
		return;
	     end;

/* process arguments */
	if af_allowed then call ssu_$return_arg (sci_ptr, arg_count, active_function, return_ptr, return_len);
	else call ssu_$arg_count (sci_ptr, arg_count);

	if ME = "last_message_destination" then do;	/* last_message_destination ends here */
		do idx = 1 to arg_count;
		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
		     if arg = "-inhibit_error" | arg = "-ihe" then inhibit_error = TRUE;
		     else if index (arg, "-") = 1 then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
		     else call ssu_$abort_line (sci_ptr, (0), "Usage: lmds {-control_arg}");
		end;


		if last_destination_arg = "" then do;
			if ^inhibit_error then call ssu_$abort_line (sci_ptr, (0), "No last message destination.");
			else if active_function then return_arg = "";
		     end;

		else do;
			if active_function then return_arg = requote_string_ (rtrim (last_destination_arg));
			else call ioa_ ("^a", last_destination_arg);
		     end;

		go to MAIN_RETURN;
	     end;

	control_args = TRUE;

	do idx = 1 to arg_count while (control_args);
	     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

	     if (arg = "-acknowledge" | arg = "-ack") & ^af_allowed then do;
		acknowledge = TRUE;
		ack_if_deferred = FALSE;
		end;
	     else if (arg = "-no_acknowledge" | arg = "-nack") & ^af_allowed then acknowledge, ack_if_deferred = FALSE;
	     else if (arg = "-acknowledge_if_deferred" | arg = "-ackid") & ^af_allowed then do;
		     ack_if_deferred = TRUE;
		     acknowledge = FALSE;
		     end;

	     else if (arg = "-brief" | arg = "-bf") & ^af_allowed then do;
		     suppress_warnings = TRUE;
		     suppress_errors, long = FALSE;
		end;

	     else if (arg = "-long" | arg = "-lg") & ^af_allowed then do;
		     suppress_warnings, suppress_errors = FALSE;
		     long = TRUE;
		end;

	     else if (arg = "-silent" | arg = "-sil") & ^af_allowed then do;
		     suppress_warnings, suppress_errors = TRUE;
		     long = FALSE;
		end;

	     else if (arg = "-comment" | arg = "-com") & ^af_allowed then do;
		     idx = idx + 1;
		     if idx > arg_count then
			call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A character string must be given after ""^a"".", arg);
		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
		     if arg_len > length (send_mail_info.sent_from) then
			call ssu_$abort_line (sci_ptr, (0), "Comment field may be no longer than ^d characters.",
			     length (send_mail_info.sent_from));
		     comment = TRUE;
		     comment_field = arg;
		end;

	     else if (arg = "-no_comment" | arg = "-ncom") & ^af_allowed then do;
		     comment = FALSE;
		     comment_field = "";
		end;

	     else if (arg = "-escape" | arg = "-esc") & ^af_allowed then escape = TRUE;
	     else if (arg = "-no_escape" | arg = "-no_escape") & ^af_allowed then escape = FALSE;

	     else if (arg = "-express" | arg = "-xps") & ^af_allowed then express = TRUE;
	     else if (arg = "-no_express" | arg = "-nxps") & ^af_allowed then express = FALSE;
	     else if (arg = "-access_class" | arg = "-acc") & ^af_allowed then do;
		     idx = idx + 1;

		     if idx > arg_count then
			call ssu_$abort_line (sci_ptr, error_table_$noarg, "An access class must be specified after ""^a"".", arg);

		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);

		     call convert_access_class_$from_string (access_class_arg, arg, code);

		     if code ^= 0 then
			call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     access_class = TRUE;
		end;

	     else if arg = "-last_message_destination" | arg = "-lmds" then do;
		     if destination then call print_usage_message;
		     destination, last_destination, print_destination = TRUE;
		     destination_arg = last_destination_arg;
		     dname = last_dname;
		     ename = last_ename;
		end;

	     else if arg = "-last_message_sender" | arg = "-lms" then do;
		     if destination then call print_usage_message;
		     dname = ">udd>" || rtrim (project) || ">" || person;
		     ename = rtrim (person) || ".mbx";

		     call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code);
		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code,
			     "While getting message facility mailbox pointer. ^a", pathname_ (dname, ename));

		     local_lmi.version = LAST_MESSAGE_INFO_VERSION_1;
		     call message_facility_$get_last_message_info (msgf_mbx_ptr, addr (local_lmi), code);
		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code,
			     "While getting last message info. ^a", pathname_ (dname, ename));

		     if local_lmi.last_message_id = ""b then call ssu_$abort_line (sci_ptr, (0), "No last message.");

		     message_info_ptr = local_lmi.last_message_ptr;
		     destination_arg, last_destination_arg =
			substr (message_info.sender, 1, length (rtrim (message_info.sender)) - 2);
		     last_person = before (destination_arg, ".");
		     last_project = after (destination_arg, ".");
		     dname = ">udd>" || rtrim (last_project) || ">" || last_person;
		     ename = rtrim (last_person) || ".mbx";
		     destination, last_destination, last_sender, print_destination = TRUE;
		end;


	     else if arg = "-pathname" | arg = "-pn" then do;
		     idx = idx + 1;
		     if idx > arg_count then
			call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "A mailbox pathname must be given after ""^a"".", arg);
		     if destination then call print_usage_message;
		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
		     call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code);
		     if code ^= 0 then
			call ssu_$abort_line (sci_ptr, code, "^a", arg);
		     destination, pathname = TRUE;
		     destination_arg = pathname_ (dname, ename);
		end;

	     else if (arg = "-print_destination" | arg = "-prds") & ^af_allowed then do;
		     print_destination = TRUE;
		     no_print_destination = FALSE;
		end;
	     else if (arg = "-no_print_destination" | arg = "-nprds") & ^af_allowed then do;
		     print_destination = FALSE;
		     no_print_destination = TRUE;
		end;
	     else if (arg = "-update_destination" | arg = "-upds") & ^af_allowed then update_destination = TRUE;
	     else if (arg = "-no_update_destination" | arg = "-nupds") & ^af_allowed then update_destination = FALSE;
	     else if index (arg, "-") ^= 1 & destination then control_args = FALSE;

	     else if search (arg, "<>") ^= 0 then do;
		     call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code);

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     destination = TRUE;
		     destination_arg = arg;
		     pathname = TRUE;
		end;

	     else if index (arg, "-") ^= 1 then do;
		     call mail_system_$create_user_mailbox_address ((arg), "", "", address_ptr, code);

		     if code = mlsys_et_$invalid_user_id_syntax then do;
			     call mail_system_$create_mail_table_address ((arg), "", "", address_ptr, code);
			     if code = 0 then do;
				     call mail_system_$get_mail_table_address (address_ptr, mt_address_ptr, code);
				     if code = 0 then do;
					     call mail_system_$free_address (address_ptr, (0));
					     address_ptr = mt_address_ptr;
					end;
				end;
			end;

		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     call mail_system_$get_address_pathname (address_ptr, dname, ename, "", code);
		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg);

		     if before (reverse (rtrim (ename)), ".") = "slm" then call ssu_$abort_line (sci_ptr, (0), "Mailing lists are not supported by this command. ^a", arg);

		     destination = TRUE;
		     destination_arg = arg;
		     pathname = FALSE;
		end;

	     else do;				/* let mlsys_utils_ handle this potential address */
		     ca_options.version = PARSE_CA_OPTIONS_VERSION_1;
		     ca_options.logbox_creation_mode = DONT_CREATE_MAILBOX;
		     ca_options.savebox_creation_mode = DONT_CREATE_MAILBOX;
		     ca_options.abort_on_errors = TRUE;
		     ca_options.validate_addresses = FALSE;
		     ca_options.mbz = ""b;

		     call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (ca_options), dname, ename, code);
		     if code ^= 0 then call ssu_$abort_line (sci_ptr, code);
		     idx = idx - 1;			/* let the do loop increment it rather than mlsys_utils_ */

		     destination = TRUE;
		     destination_arg = pathname_ (dname, ename);
		     pathname = TRUE;
		end;
	end;					/* arg loop */

	if ^control_args & af_allowed then call print_usage_message;
	else if ^control_args then idx = idx - 1;

	if ^destination then call print_usage_message;

	if last_destination & last_destination_arg = "" then
	     call ssu_$abort_line (sci_ptr, (0), "No last destination.");

/* set last info */
	if ^af_allowed & update_destination then do;
		last_destination_arg = destination_arg;
		last_dname = dname;
		last_ename = ename;
	     end;

	if acknowledge & ^long then suppress_warnings = TRUE;

	send_mail_info.version = send_mail_info_version_2;
	send_mail_info.sent_from = comment_field;
	send_mail_info.wakeup = TRUE;
	send_mail_info.mbz1 = ""b;
	send_mail_info.always_add = ^express;
	send_mail_info.never_add = FALSE;
	send_mail_info.notify = FALSE;
	send_mail_info.acknowledge = acknowledge;
	send_mail_info.mbz = ""b;

	code = test_sendable ();
	old_code = code;

	if ack_if_deferred & (code = error_table_$messages_deferred
	     | code = error_table_$messages_off) then send_mail_info.acknowledge = TRUE;

	if af_allowed then do;			/* accepting ends here */
		if code = error_table_$messages_off
		     | code = error_table_$messages_deferred then
		     if ^active_function then call print_code ();
		     else return_arg = "false";
		else if code ^= 0 then call ssu_$print_message (sci_ptr, code, "Cannot determine accepting state. ^a", destination_arg);
		else if ^active_function then do;
			if pathname then call ssu_$print_message (sci_ptr, (0),
				"Messages are being accepted on the mailbox ^a.", destination_arg);
			else call ssu_$print_message (sci_ptr, (0), "^a is accepting messages.", destination_arg);
		     end;
		else return_arg = "true";
		go to MAIN_RETURN;
	     end;

	if code ^= 0 then call print_code ();

	if idx <= arg_count then do;			/* there is a message to send */
		start_len = 1;
		message = "";
		do idx = idx to arg_count;
		     call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len);
		     if start_len + arg_len > message_len then do; /* need more space */
			     old_message_ptr = message_ptr;
			     old_message_len = message_len;
			     message_len = message_len + arg_len + length (message_space);
			     if area_ptr = null () then area_ptr = get_system_free_area_ ();

			     allocate message in (area) set (message_ptr);
			     message_allocated = TRUE;
			     message = substr (old_message_ptr -> message, 1, old_message_len);
			     if old_message_len > length (message_space) then free old_message_ptr -> message in (area);
			     substr (message, old_message_len + 1) = "";
			end;
		     substr (message, start_len, arg_len) = arg;
		     start_len = start_len + arg_len + 1;
		end;				/* arg loop */

		if access_class then
		     call message_facility_$send_message_access_class (dname, ename, substr (message, 1, start_len - 1),
			addr (send_mail_info), access_class_arg, code);
		else call message_facility_$send_message (dname, ename, substr (message, 1, start_len - 1),
			addr (send_mail_info), code);

		if message_allocated then free message in (area);

		if print_destination & ^no_print_destination then
		     call ioa_ ("Sent to ^a^[ (last message ^[sender^;destination^])^].", destination_arg, last_destination, last_sender);

		if code ^= old_code then call print_code ();

		goto MAIN_RETURN;
	     end;					/* message on command line */

	else do;					/* input mode */
		code = 0;

		call ioa_ ("Input to ^a:", destination_arg);
		do while (code = 0);
		     call iox_$get_line (iox_$user_input, message_ptr, message_len, chars_read, code);
		     if code ^= 0 then if code = error_table_$long_record then do;
				call ssu_$print_message (sci_ptr, code, "user_input");
				call ssu_$print_message (sci_ptr, (0), "Maximum message length is ^d characters.  Message truncated to ""^a"".", message_len, message);
				code = 0;
			     end;
			else if code = error_table_$end_of_info then goto MAIN_RETURN;
			else call ssu_$abort_line (sci_ptr, code, "user_input");
			
		     if substr (message, 1, chars_read) = DOT_NL then goto MAIN_RETURN; /* exit input mode */
		     if substr (message, 1, 2) = ".." & escape then do;
			     substr (message, 1, 2) = "  ";
			     call cu_$cp (message_ptr, chars_read, code);
			     code = 0;
			end;
		     else do;
			     if access_class then
				call message_facility_$send_message_access_class (dname, ename, substr (message, 1, chars_read),
				     addr (send_mail_info), access_class_arg, code);
			     else call message_facility_$send_message (dname, ename, substr (message, 1, chars_read),
				     addr (send_mail_info), code);

			     if code ^= old_code then
				if code = 0 & ^suppress_warnings then
				     call ssu_$print_message (sci_ptr, (0), "^[A process^s^;^a^] is now accepting messages^[ on the mailbox ^a^].", pathname, destination_arg, pathname, destination_arg);
				else if code ^= 0 then call print_code ();
			     old_code = code;
			     if code ^= 0 then if (code = error_table_$messages_off
				     | code = error_table_$wakeup_denied
				     | code = error_table_$messages_deferred) then code = 0;
			end;			/* sending it */
		end;				/* input loop */
	     end;					/* message with input loop */

	if code ^= 0 & code ^= old_code then call print_code ();
MAIN_RETURN:
	call cleanup_sm ();
RETURN_FROM_SM:
	return;

cleanup_sm: proc ();
	if message_allocated then do;
		message_allocated = FALSE;
		free message in (area);
	     end;
	if address_ptr ^= null () then call mail_system_$free_address (address_ptr, (0));
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	return;
     end cleanup_sm;

abort_sm: proc ();
	call cleanup_sm ();
	go to RETURN_FROM_SM;
     end abort_sm;

test_sendable: proc () returns (fixed bin (35));
	dcl     return_code		 fixed bin (35);
	send_mail_info.never_add = TRUE;
	if access_class then
	     call message_facility_$send_message_access_class (dname, ename, "", addr (send_mail_info), access_class_arg, return_code);
	else call message_facility_$send_message (dname, ename, "", addr (send_mail_info), return_code);
	send_mail_info.never_add = FALSE;
	return (return_code);
     end test_sendable;


print_code: proc;
	dcl     error_occurred	 bit (1) aligned;
	error_occurred = FALSE;
	if code = error_table_$no_append then do;
		if ^suppress_errors then call ssu_$print_message (sci_ptr, (0),
			"Insufficient access to add a message to^[ mailbox of^] ^a", ^pathname, destination_arg);
		error_occurred = TRUE;
	     end;
	else if code = error_table_$noentry | code = error_table_$no_dir then do;
		if ^suppress_errors then call ssu_$print_message (sci_ptr, (0),
			"No mailbox^[ for^] ^a.", ^pathname, destination_arg);
		error_occurred = TRUE;
	     end;
	else if code = error_table_$messages_off then if ^suppress_warnings then do;
		     if pathname then call ssu_$print_message (sci_ptr, (0),
			     "No process is accepting messages on the mailbox ^a.", destination_arg);
		     else call ssu_$print_message (sci_ptr, (0),
			     "^a is not accepting messages or not logged in.", destination_arg);
		end;
	     else ;
	else if code = error_table_$messages_deferred then if ^suppress_warnings then do;
		     if pathname then call ssu_$print_message (sci_ptr, (0),
			     "Messages are deferred on the mailbox ^a.", destination_arg);
		     else call ssu_$print_message (sci_ptr, (0),
			     "^a has deferred messages.", destination_arg);
		end;
	     else ;
	else if code = error_table_$wakeup_denied then if ^suppress_warnings then do;
		     call ssu_$print_message (sci_ptr, (0),
			"Insufficient access to send a wakeup to ^a.  Message may not be printed immediately.", destination_arg);
		end;
	     else ;
	else do;
		error_occurred = TRUE;
		if ^suppress_errors then call ssu_$print_message (sci_ptr, code, "^a", destination_arg);
	     end;
	if express & ((suppress_warnings & error_occurred) | ^suppress_warnings) then
	     call ssu_$print_message (sci_ptr, (0), "Message not sent to ^a.", destination_arg);
	if express | error_occurred then call abort_sm ();
     end print_code;

/* This procedure prints a usage message for accepting or send_message */
print_usage_message: procedure;
	if af_allowed then
	     call ssu_$abort_line (sci_ptr, (0), "Usage: ^[[^]accepting address^[]^]", active_function, active_function);
	else call ssu_$abort_line (sci_ptr, (0), "Usage: sm {-control_args} address {message}");
     end print_usage_message;

%page;
%include last_message_info;
%page;
%include message_info;
%page;
%include send_mail_info;
%page;
%include mlsys_parse_ca_options;
     end send_message;




		    send_message_obsolete.pl1       11/08/84  0902.6rew 11/08/84  0805.7      101529



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* This module implements the following obsolete message facility commands:

      send_message_acknowledge (sma)
      send_message_express (smx)
      send_message_silent (sms)

   and the following subroutines:

      send_message_
      send_message_acknowledge_ (send_message_$acknowledge)
      send_message_express_ (send_message_$express)
      send_message_$notify_mail
*/
/* Written 12/16/83 by Jim Lippard */
send_message_obsolete: procedure options (variable);
	return;

	dcl     ME		 char (24);

	dcl     (active_fnc_err_, com_err_, com_err_$suppress_name) entry () options (variable);

	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));

	dcl     arg_count		 fixed bin;
	dcl     arg_ptr		 ptr;
	dcl     arg_len		 fixed bin (21);
	dcl     arg		 char (arg_len) based (arg_ptr);

	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));

	dcl     dname		 char (168);
	dcl     ename		 char (32);

	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

	dcl     destination_arg	 char (168);

	dcl     ioa_		 entry () options (variable);

	dcl     iox_$get_line	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$user_input	 ptr ext static;

	dcl     message_facility_$send_message entry (char (*), char (*), char (*), ptr, fixed bin (35));

	dcl     chars_read		 fixed bin (21);
	dcl     old_message_ptr	 ptr;
	dcl     old_message_len	 fixed bin (21);
	dcl     message_ptr		 ptr;
	dcl     message_len		 fixed bin (21);
	dcl     message_space	 char (1600) aligned;
	dcl     message		 char (message_len) based (message_ptr);
	dcl     start_len		 fixed bin (21);

	dcl     get_system_free_area_	 entry () returns (ptr);

	dcl     area_ptr		 ptr;
	dcl     area		 area based (area_ptr);

	dcl     user_info_$whoami	 entry (char (*), char (*), char (*));

	dcl     person		 char (22);
	dcl     project		 char (9);

	dcl     idx		 fixed bin;

	dcl     (P_person, P_project, P_message) char (*) parameter;
	dcl     P_code		 fixed bin (35) parameter;

	dcl     brief		 bit (1) aligned;
	dcl     destination		 bit (1) aligned;
	dcl     message_allocated	 bit (1) aligned;
	dcl     pathname		 bit (1) aligned;

	dcl     (addr, after, before, length, null, rtrim, substr) builtin;

	dcl     code		 fixed bin (35);

	dcl     (error_table_$long_record,
	        error_table_$messages_deferred,
	        error_table_$messages_off,
	        error_table_$no_append,
	        error_table_$no_dir,
	        error_table_$noentry,
	        error_table_$no_info,
	        error_table_$wakeup_denied) ext fixed bin (35);

	dcl     TRUE		 bit (1) aligned internal static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) aligned internal static options (constant) init ("0"b);
	dcl     DOT_NL		 char (2) aligned internal static options (constant) init (".
");
	dcl     NL		 char (1) aligned internal static options (constant) init ("
");

send_message_acknowledge: sma: entry;
	ME = "send_message_acknowledge";
	call smo_initialize ();
	send_mail_info.acknowledge = TRUE;
	call smo_command ();
	return;

send_message_express: smx: entry;
	ME = "send_message_express";
	call smo_initialize ();
	send_mail_info.always_add = FALSE;
	call smo_command ();
	return;

send_message_silent: sms: entry;
	ME = "send_message_silent";
	call smo_initialize ();
	brief = TRUE;
	call smo_command ();
	return;

send_message_: entry (P_person, P_project, P_message, P_code);
	call smo_initialize ();
	call smo_subroutine ();
	return;

send_message_acknowledge_: acknowledge: entry (P_person, P_project, P_message, P_code);
	call smo_initialize ();
	send_mail_info.acknowledge = TRUE;
	call smo_subroutine ();
	return;

send_message_express_: express: entry (P_person, P_project, P_message, P_code);
	call smo_initialize ();
	send_mail_info.always_add = FALSE;
	call smo_subroutine ();
	return;

notify_mail: entry (P_person, P_project, P_code);
	call smo_initialize ();
	send_mail_info.notify = TRUE;
	send_mail_info.always_add = FALSE;
	call smo_subroutine ();
	return;

smo_initialize: procedure ();
						/* initialize variables */
	brief = FALSE;
	area_ptr = null ();

	call user_info_$whoami (person, "", "");

	send_mail_info.version = send_mail_info_version_2;
	send_mail_info.sent_from = person;
	send_mail_info.wakeup = TRUE;
	send_mail_info.mbz1 = ""b;
	send_mail_info.always_add = TRUE;
	send_mail_info.never_add = FALSE;
	send_mail_info.notify = FALSE;
	send_mail_info.acknowledge = FALSE;
	send_mail_info.mbz = ""b;
     end smo_initialize;

smo_command: procedure ();
						/* procedure for commands */
	destination, message_allocated = FALSE;

/* process arguments */
	call cu_$arg_count (arg_count, code);

	if code ^= 0 then do;
		call active_fnc_err_ (code, ME);
		return;
	     end;

	do idx = 1 to arg_count while (^destination);
	     call cu_$arg_ptr (idx, arg_ptr, arg_len, (0));
	     if arg = "-pathname" | arg = "-pn" then do;	/* pathname destination */
		     idx = idx + 1;

		     if idx > arg_count then do;
			     call com_err_ ((0), ME, "No value specified for -pathname.");
			     return;
			end;

		     call cu_$arg_ptr (idx, arg_ptr, arg_len, (0));
		     call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code);

		     if code ^= 0 then do;
			     call com_err_ (code, ME, "^a", arg);
			     return;
			end;

		     destination_arg = pathname_ (dname, ename);
		     destination, pathname = TRUE;
		end;
	     else do;				/* person.project or person project */
		     person = before (arg, ".");
		     project = after (arg, ".");
		     if project = "" then do;		/* person project or project is missing */
			     idx = idx + 1;
			     if idx <= arg_count then do;
				     person = arg;
				     call cu_$arg_ptr (idx, arg_ptr, arg_len, (0));
				     project = arg;
				end;
			     else do;
				     call com_err_$suppress_name ((0), ME, "Usage:  ^a person.project {message}
or:^5x^a -pathname path {message}", ME, ME);
				     return;
				end;
			end;
		     dname = ">udd>" || rtrim (project) || ">" || person;
		     ename = rtrim (person) || ".mbx";
		     destination_arg = rtrim (person) || "." || project;
		     destination = TRUE;
		     pathname = FALSE;
		end;
	end;

	if ^destination then do;
		call com_err_$suppress_name ((0), ME, "Usage:  ^a person.project {message}
or:^5x^a -pathname path {message}", ME, ME);
		return;
	     end;

	message_ptr = addr (message_space);
	message_len = length (message_space);
	message = "";

	if idx <= arg_count then do;			/* message on the line */
		start_len = 1;
		do idx = idx to arg_count;
		     call cu_$arg_ptr (idx, arg_ptr, arg_len, (0));
		     if start_len + arg_len > message_len then do;
			     old_message_ptr = message_ptr;
			     old_message_len = message_len;
			     message_len = message_len + arg_len + length (message_space);
			     if area_ptr = null () then area_ptr = get_system_free_area_ ();
			     allocate message in (area) set (message_ptr);
			     message_allocated = TRUE;
			     message = substr (old_message_ptr -> message, 1, old_message_len);
			     if old_message_len > length (message_space) then free old_message_ptr -> message in (area);
			end;
		     substr (message, start_len, arg_len) = arg;
		     start_len = start_len + arg_len + 1;
		     substr (message, start_len - 1, 1) = " ";
		end;

		substr (message, start_len - 1, 1) = NL;

		call message_facility_$send_message (dname, ename, substr (message, 1, start_len - 1),
		     addr (send_mail_info), code);

		if message_allocated then do;
			message_allocated = FALSE;
			free message in (area);
		     end;
	     end;
	else do;					/* input mode */
		send_mail_info.never_add = TRUE;
		call message_facility_$send_message (dname, ename, "",
		     addr (send_mail_info), code);
		send_mail_info.never_add = FALSE;
		if code ^= 0 then
		     if (code = error_table_$messages_off | code = error_table_$messages_deferred) then do;
			     if ^send_mail_info.always_add then do;
				     call com_err_ (code, ME, "^a", destination_arg);
				     return;
				end;
			     if ^send_mail_info.acknowledge & ^brief then
				call com_err_ (code, ME, "^a", destination_arg);
			     code = 0;
			end;
		     else if code = error_table_$no_info then do;
			     if send_mail_info.acknowledge then
				call com_err_ (code, ME, "Messages to ^a cannot be acknowledged.", destination_arg);
			     else if ^brief then call com_err_ (code, ME, "^a", destination_arg);
			     code = 0;
			end;
		if code ^= 0 then goto SMO_ERROR;
		call ioa_ ("Input:");		/* input mode */
		do while (code = 0);
		     call iox_$get_line (iox_$user_input, message_ptr, message_len, chars_read, code);
		     if code ^= 0 then
			if code = error_table_$long_record then do;
				call com_err_ (code, ME, "user_input");
				code = 0;
			     end;
			else do;
				call com_err_ (code, ME, "user_input");
				return;
			     end;
		     else if substr (message, 1, chars_read) = DOT_NL then return;
		     call message_facility_$send_message (dname, ename, substr (message, 1, chars_read), addr (send_mail_info), code);
		     if code ^= 0 then
			if (code = error_table_$messages_off
			     | code = error_table_$no_info
			     | code = error_table_$messages_deferred) then code = 0;
		end;
	     end;
	if code ^= 0 then do;
SMO_ERROR:	if code = error_table_$noentry | code = error_table_$no_dir then
		     call com_err_ ((0), ME, "No mailbox^[ for^] ^a", ^pathname, destination_arg);
		else if code = error_table_$no_append then
		     call com_err_ ((0), ME, "Insufficient access to add a message to^[ mailbox of^] ^a", ^pathname,
			destination_arg);
		else if ^send_mail_info.always_add then
		     if ^brief then call ioa_ ("Not sent.");
		     else ;
		else if code = error_table_$wakeup_denied then
		     if ^brief then call com_err_ ((0), ME, "Insufficient access to send a wakeup to ^a",
			     destination_arg);
		     else ;
		else if (code = error_table_$messages_off | code = error_table_$messages_deferred) then
		     if ^send_mail_info.acknowledge & ^brief then
			call com_err_ (code, ME, "^a", destination_arg);
		     else ;
		else if code = error_table_$no_info then
		     if send_mail_info.acknowledge & ^brief then
			call com_err_ (code, ME, "Messages to ^a cannot be acknowledged.", destination_arg);
		     else ;
		else call com_err_ (code, ME, "^a", destination_arg);
	     end;
     end smo_command;

smo_subroutine: procedure ();
						/* procedure for subroutines */
	dname = ">udd>" || rtrim (P_project) || ">" || P_person;
	ename = rtrim (P_person) || ".mbx";

	if send_mail_info.notify then call message_facility_$send_message (dname, ename, "You have mail.",
		addr (send_mail_info), code);
	else call message_facility_$send_message (dname, ename, P_message, addr (send_mail_info), code);

	P_code = code;
     end smo_subroutine;

%include send_mail_info;
     end send_message_obsolete;






		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
