



		    add_mail_table_entry.pl1        10/02/89  0909.7rew 10/02/89  0815.0      196038



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(89-07-17,Lee), approve(89-08-01,MCR8124),
     audit(89-09-25,LZimmerman), install(89-10-02,MR12.3-1079):
     phx20861 (Mail 507) - modified update_mail_table_entry command to validate
     address; modified update/add_mail_table_entry to not require participant
     access to meetings which are added/updated by calling the new procedure
     get_meeting_arg for meeting arguments.
  2) change(89-08-02,Lee), approve(89-08-22,MCR8128),
     audit(89-09-25,LZimmerman), install(89-10-02,MR12.3-1079):
     phx20700 (Mail 504), phx20967 (Mail 445) - modified
     delete_mail_table_entry command to handle entry names case-insensitively
     by calling mail_table_priv_$get to fetch the name with the exact case for
     deleting; modified update_mail_table_entry command to delete alias entries
     case-insensitively by calling the newly added
     mail_table_priv_$delete_alias_case_ins instead of
     mail_table_priv_$delete_alias; reformatting.
                                                   END HISTORY COMMENTS */


/* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */

/* (add update delete)_mail_table_entry: these commands are used by
   administrators to manipulate Mail Table entries. */

/* Written: July 1983 by B. Margolin */
/* Modified: 6 March 1984 by G. Palter to fix error #0427 -- delete_mail_table_entry does not give a usage message when
   invoked with no arguments.  In addition, the error message produced when attempting to delete an entry corresponding to
   a PNT entry is incorrect */
/* Modified: 10 April 1984 by G. Palter to fix error #0440 -- the mail table administrative commands do not enforce the
   "acs" suffix on the ACS pathname */

add_mail_table_entry:
     proc options (variable);

	dcl     acs_dir		char (168);
	dcl     acs_entry		char (32);
	dcl     acs_given		bit (1);
	dcl     acs_type		fixed bin (2);
	dcl     addr		builtin;
	dcl     address_ptr		ptr;
	dcl     alias		(1000) char (32) varying based (alias_ptr);
	dcl     alias_count		fixed bin;
	dcl     alias_ptr		ptr;
	dcl     arg		char (arg_len) based (arg_ptr);
	dcl     arg_count		fixed bin;
	dcl     arg_idx		fixed bin;
	dcl     arg_len		fixed bin (21);
	dcl     arg_ptr		ptr;
	dcl     buffer		char (256);
	dcl     buffer_used		char (buffer_used_len) based (addr (buffer));
	dcl     buffer_used_len	fixed bin (21);
	dcl     cleanup		condition;
	dcl     code		fixed bin (35);
	dcl     dl_alias		(1000) char (32) varying based (dl_alias_ptr);
	dcl     dl_alias_count	fixed bin;
	dcl     dl_alias_ptr	ptr;
	dcl     index		builtin;
	dcl     length		builtin;
	dcl     maxlength		builtin;
	dcl     min		builtin;
	dcl     1 mte		aligned like mail_table_entry;
	dcl     null		builtin;
	dcl     1 pcao		aligned like parse_ca_options;
	dcl     (name, name1)	char (32) varying;
	dcl     sci_ptr		ptr;
	dcl     substr		builtin;
	dcl     VERSION		char (4) int static options (constant) init ("1.0");
	dcl     WHOAMI		char (32);
	dcl     yes_sw		bit (1);

	dcl     (
	        error_table_$bad_arg,
	        error_table_$bad_subr_arg,
	        error_table_$badopt,
	        error_table_$bigarg,
	        error_table_$id_already_exists,
	        error_table_$id_not_found,
	        error_table_$noarg,
	        error_table_$noentry,
	        error_table_$too_many_args,
	        mlsys_et_$ambiguous_address,
	        forum_error_table_$not_eligible
	        )			fixed bin (35) ext static;

	dcl     com_err_		entry () options (variable);
	dcl     command_query_$yes_no entry () options (variable);
	dcl     expand_pathname_$add_suffix
				entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$status_minf	entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				fixed bin (35));
	dcl     mail_system_$free_address
				entry (ptr, fixed bin (35));
	dcl     mail_system_$validate_address
				entry (ptr, bit (1) aligned, fixed bin (35));
	dcl     mail_table_$get	entry (char (*) var, ptr, char (*), fixed bin (35));
	dcl     mail_table_priv_$add	entry (ptr, bit (1), fixed bin (35));
	dcl     mail_table_priv_$add_alias
				entry (char (*) var, char (*) var, bit (1), fixed bin (35));
	dcl     mail_table_priv_$delete
				entry (char (*) var, bit (1), fixed bin (35));
	dcl     mail_table_priv_$delete_alias_case_ins
				entry (char (*) var, bit (1), fixed bin (35));
	dcl     mail_table_priv_$get	entry (char (*) var, ptr, fixed bin (35));
	dcl     mail_table_priv_$update
				entry (ptr, bit (1), fixed bin (35));
	dcl     mlsys_utils_$format_address_field
				entry (char (*) var, ptr, fixed bin, ptr, fixed bin (21), fixed bin (21),
				fixed bin (35));
	dcl     mlsys_utils_$parse_address_control_args
				entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
	dcl     mlsys_utils_$print_validate_results
				entry (ptr, ptr, fixed bin (35));
	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_$get_temp_segment entry (ptr, char (*), ptr);
	dcl     ssu_$print_message	entry () options (variable);
	dcl     ssu_$release_temp_segment
				entry (ptr, ptr);
	dcl     ssu_$standalone_invocation
				entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
%page;
%include mail_table_entry;
%page;
%include mlsys_parse_ca_options;
%page;
%include status_structures;
%page;

	WHOAMI = "add_mail_table_entry";
	code = 0;
	acs_given = "0"b;
	sci_ptr, address_ptr, alias_ptr = null ();
	acs_dir, acs_entry = "";
	on cleanup call cleanup_amte ();
	call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_amte, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Creating standalone subsystem invocation.");
	     return;
	end;
	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count < 2 then call ssu_$abort_line (sci_ptr, 0, "Usage: ^a name address {-control_args}", WHOAMI);
	arg_idx = 1;
	call get_name_arg ();
	call ssu_$get_temp_segment (sci_ptr, "aliases", alias_ptr);
	alias_count = 0;
	pcao.version = PARSE_CA_OPTIONS_VERSION_1;
	pcao.logbox_creation_mode = QUERY_TO_CREATE_MAILBOX;
	pcao.savebox_creation_mode = QUERY_TO_CREATE_MAILBOX;
	pcao.abort_on_errors = "1"b;
	pcao.flags.mbz = ""b;
	do arg_idx = 2 to arg_count;

	     pcao.validate_addresses = "1"b;

	     call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
	     if arg = "-alias" then do;
		call get_alias_arg (alias, alias_count);
		if check_ambiguous_name (alias (alias_count)) then do;
		     call ssu_$print_message (sci_ptr, error_table_$id_already_exists,
			"^/The alias ""^a"" will not be added.", alias (alias_count));
		     alias_count = alias_count - 1;
		end;
	     end;
	     else if arg = "-acs_path" then call get_acs_arg ();
	     else if arg = "-mtg" | arg = "-meeting" then call get_meeting_args ();
	     else call get_address_args ();
	end;
	if check_ambiguous_name (name) then
	     call ssu_$abort_line (sci_ptr, error_table_$id_already_exists, "The name ""^a"".", name);
	if address_ptr = null () then
	     call ssu_$abort_line (sci_ptr, error_table_$noarg, "An address must be supplied.");
	mte.version = MAIL_TABLE_ENTRY_VERSION_1;
	mte.name = name;
	if acs_given then do;
	     mte.dir = acs_dir;
	     mte.entry = acs_entry;
	end;
	else mte.dir, mte.entry = "";
	mte.default_project = "";
	buffer_used_len = 0;
	call mlsys_utils_$format_address_field ("", address_ptr, -1, addr (buffer),
	     min (maxlength (mte.mailing_address), length (buffer)), buffer_used_len, code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Formatting address.");
	mte.mailing_address = buffer_used;
	call mail_table_priv_$add (addr (mte), "0"b, code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Adding Mail table entry for ""^a"".", name);
	do arg_idx = 1 to alias_count;
	     call mail_table_priv_$add_alias (name, alias (arg_idx), "0"b, code);
	     if code ^= 0 then do;
		if code = error_table_$id_not_found then
		     call ssu_$abort_line (sci_ptr, code,
			"^/The new Mail Table entry for ""^a"" has been deleted by another user.", name);
		call ssu_$print_message (sci_ptr, code, "Adding alias ""^a"" to ""^a"";this one will be skipped.",
		     alias (arg_idx), name);
		code = 0;
	     end;
	end;
RETURN_FROM_AMTE:
	call cleanup_amte ();
	return;

cleanup_amte:
     proc ();

	if alias_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, alias_ptr);
	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_amte;

abort_amte:
     proc ();

	go to RETURN_FROM_AMTE;

     end abort_amte;

update_mail_table_entry:
     entry options (variable);

	WHOAMI = "update_mail_table_entry";
	code = 0;
	address_ptr, sci_ptr, alias_ptr, dl_alias_ptr = null ();
	alias_count, dl_alias_count = 0;
	acs_given = "0"b;
	acs_dir, acs_entry = "";
	on cleanup call cleanup_umte ();
	call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_umte, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Creating standalone subsystem invocation.");
	     return;
	end;
	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count < 2 then call ssu_$abort_line (sci_ptr, 0, "Usage: ^a name {address} {-control_args}", WHOAMI);
	arg_idx = 1;
	call get_name_arg ();
	call ssu_$get_temp_segment (sci_ptr, "add_aliases", alias_ptr);
	call ssu_$get_temp_segment (sci_ptr, "dl_aliases", dl_alias_ptr);
	pcao.version = PARSE_CA_OPTIONS_VERSION_1;
	pcao.logbox_creation_mode = QUERY_TO_CREATE_MAILBOX;
	pcao.savebox_creation_mode = QUERY_TO_CREATE_MAILBOX;
	pcao.abort_on_errors = "1"b;
	pcao.flags.mbz = ""b;

	do arg_idx = 2 to arg_count;
	     pcao.validate_addresses = "1"b;
	     call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
	     if arg = "-alias" then do;
		call get_alias_arg (alias, alias_count);
		if check_ambiguous_name (alias (alias_count)) then do;
		     call ssu_$print_message (sci_ptr, error_table_$id_already_exists,
			"^/The alias ""^a"" will not be added.", alias (alias_count));
		     alias_count = alias_count - 1;
		end;
	     end;
	     else if arg = "-delete_alias" then do;
		call get_alias_arg (dl_alias, dl_alias_count);
		if ^check_ambiguous_name (dl_alias (dl_alias_count)) then do;
		     call ssu_$print_message (sci_ptr, error_table_$id_not_found,
			"^/The alias ""^a"" will not be deleted.", dl_alias (dl_alias_count));
		     dl_alias_count = dl_alias_count - 1;
		end;
	     end;
	     else if arg = "-acs_path" then call get_acs_arg ();
	     else call get_address_args ();
	end;
	mte.version = MAIL_TABLE_ENTRY_VERSION_1;
	call mail_table_priv_$get (name, addr (mte), code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Retrieving old Mail Table entry for ""^a"".", name);
	if acs_given then do;
	     mte.dir = acs_dir;
	     mte.entry = acs_entry;
	end;
	if address_ptr ^= null () then do;
	     buffer_used_len = 0;
	     call mlsys_utils_$format_address_field ("", address_ptr, -1, addr (buffer),
		min (maxlength (mte.mailing_address), length (buffer)), buffer_used_len, code);
	     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Formatting address.");
	     mte.mailing_address = buffer_used;
	end;
	if acs_given | address_ptr ^= null () then do;	/* Don't bother if just hacking aliases */
	     call mail_table_priv_$update (addr (mte), "0"b, code);
	     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Updating the Mail Table entry for ""^a"".", name);
	end;
	name1 = mte.name;
	do arg_idx = 1 to alias_count;
	     call mail_table_priv_$add_alias (name1, alias (arg_idx), "0"b, code);
	     if code ^= 0 then do;
		if code = error_table_$id_not_found then
		     call ssu_$abort_line (sci_ptr, code,
			"The Mail Table entry for ""^a"" has been deleted by another process.", name1);
		call ssu_$print_message (sci_ptr, code, "Adding alias ""^a"" for ""^a""; skipping this one.",
		     alias (arg_idx), name);
		code = 0;
	     end;
	end;
	do arg_idx = 1 to dl_alias_count;
	     call mail_table_priv_$get (dl_alias (arg_idx), addr (mte), code);
	     if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "Looking up the alias ""^a""; skipping this one.",
		     dl_alias (arg_idx));
		code = 0;
	     end;
	     else do;
		if mte.name = name1 then do;
		     call mail_table_priv_$delete_alias_case_ins (dl_alias (arg_idx), "0"b, code);
		     if code ^= 0 then do;
			if code = error_table_$bad_subr_arg then
			     call ssu_$print_message (sci_ptr, 0,
				"The name ""^a"" is a primary name or login alias; skipping this one.",
				dl_alias (arg_idx));
			else call ssu_$print_message (sci_ptr, code, "Deleting the alias ""^a""; skiping this one.",
				dl_alias (arg_idx));
			code = 0;
		     end;
		end;
		else call ssu_$print_message (sci_ptr, 0, """^a"" is not an alias for ""^a""; skipping this one.",
			dl_alias (arg_idx), name);
	     end;
	end;
RETURN_FROM_UMTE:
	call cleanup_umte ();
	return;

cleanup_umte:
     proc ();

	if alias_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, alias_ptr);
	if dl_alias_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, dl_alias_ptr);
	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_umte;

abort_umte:
     proc ();

	go to RETURN_FROM_UMTE;

     end abort_umte;

delete_mail_table_entry:
     entry options (variable);

	WHOAMI = "delete_mail_table_entry";
	code = 0;
	sci_ptr, alias_ptr = null ();
	on cleanup
	     begin;
		if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr);
	     end;
	call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_dmte, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Creating standalone invocation.");
	     return;
	end;
	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count = 0 then call ssu_$abort_line (sci_ptr, 0, "Usage: ^a names", WHOAMI);
	call ssu_$get_temp_segment (sci_ptr, "names", alias_ptr);
	do arg_idx = 1 to arg_count;			/* Validate all the args first */
	     call get_name_arg ();
	     alias (arg_idx) = name;
	end;

	mte.version = MAIL_TABLE_ENTRY_VERSION_1;

	do arg_idx = 1 to arg_count;			/* Now process them */

	     call mail_table_priv_$get (alias (arg_idx), addr (mte), code);
	     if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "Looking up the Mail Table entry ""^a""; skipping this one.",
		     alias (arg_idx));
		code = 0;
	     end;
	     else do;

		call mail_table_priv_$delete (mte.name, "0"b, code);
		if code ^= 0 then
		     if code = error_table_$bad_subr_arg then
			call ssu_$print_message (sci_ptr, error_table_$bad_arg,
			     "The Mail Table entry ""^a"" corresponds to a registered user and may not be deleted.",
			     alias (arg_idx));
		     else call ssu_$print_message (sci_ptr, code, "Deleting ""^a""; it will be skipped.",
			     alias (arg_idx));
	     end;
	end;
RETURN_FROM_DMTE:
	call ssu_$release_temp_segment (sci_ptr, alias_ptr);
	call ssu_$destroy_invocation (sci_ptr);
	return;

abort_dmte:
     proc ();

	go to RETURN_FROM_DMTE;

     end abort_dmte;

get_alias_arg:
     proc (P_alias_array, P_alias_count);

	dcl     P_alias_array	(*) char (*) varying;
	dcl     P_alias_count	fixed bin;

	dcl     ctl_arg		char (12);

	ctl_arg = arg;
	if arg_idx = arg_count then do;
NO_ALIAS:
	     call ssu_$abort_line (sci_ptr, error_table_$noarg, "^a must be followed by a name.", ctl_arg);
	end;
	arg_idx = arg_idx + 1;
	call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
	if arg = "" then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "An alias may not be the null string.");
	if substr (arg, 1, 1) = "-" then go to NO_ALIAS;
	if arg_len > maxlength (mte.name) then
	     call ssu_$abort_line (sci_ptr, error_table_$bigarg, "^/The alias ""^a"" is longer than ^d characters.",
		arg, maxlength (mte.name));
	P_alias_count = P_alias_count + 1;
	P_alias_array (P_alias_count) = arg;
	return;

     end get_alias_arg;


get_acs_arg:
     proc ();

	if arg_idx = arg_count then do;
NO_ACS_PATH:
	     call ssu_$abort_line (sci_ptr, error_table_$noarg, "-acs_path must be followed by a pathname.");
	end;
	arg_idx = arg_idx + 1;
	call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
	if index (arg, "-") = 1 then go to NO_ACS_PATH;
	if arg = "" then
	     acs_dir, acs_entry = "";
	else do;
	     call expand_pathname_$add_suffix (arg, "acs", acs_dir, acs_entry, code);
	     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Expanding pathname ""^a"".", arg);
	     call hcs_$status_minf (acs_dir, acs_entry, 1, acs_type, (0), code);
	     if code = 0 then do;
		if acs_type ^= Segment then do;
		     call command_query_$yes_no (yes_sw, 0, WHOAMI,
			"A valid ACS must be a segment, but ^a is a directory.^/Set this ACS pathname anyway?",
			"The specified ACS, ^a, is not a segment.  Set it anyway?", pathname_ (acs_dir, acs_entry));
		     if ^yes_sw then return;
		end;
	     end;
	     else if code = error_table_$noentry then do;
		call command_query_$yes_no (yes_sw, error_table_$noentry, WHOAMI,
		     "The specified ACS does not exist, so it will be treated as if there were^/no ACS path until the segment is created.^/Set this ACS pathname anyway?",
		     "The specified ACS, ^a, does not exist.  Set it anyway?", pathname_ (acs_dir, acs_entry));
		if ^yes_sw then return;
	     end;
	     else call ssu_$abort_line (sci_ptr, code, "The acs segment ^a.", pathname_ (acs_dir, acs_entry));
	end;
	acs_given = "1"b;
	return;

     end get_acs_arg;

get_name_arg:
     proc ();

	call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
	if arg = "" then
	     call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		"The null string is not a valid Mail Table entry name.");
	if substr (arg, 1, 1) = "-" then		/* First arg must be name, not control arg */
	     if WHOAMI = "delete_mail_table_entry" then
		call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
	     else call ssu_$abort_line (sci_ptr, error_table_$noarg,
		     "^/The first argument must be the Mail Table entry name.");
	if arg_len > maxlength (mte.name) then
	     call ssu_$abort_line (sci_ptr, error_table_$bigarg, "^/""^a"" is longer than ^d characters.", arg,
		maxlength (mte.name));
	name = arg;
	return;
     end get_name_arg;



get_meeting_args:
     proc ();

	dcl     ca_address_ptr	ptr;

	ca_address_ptr = null ();
	on cleanup
	     begin;
		if ca_address_ptr ^= null () then call mail_system_$free_address (ca_address_ptr, (0));
	     end;

	pcao.validate_addresses = "0"b;		/* we'll do our own validation */
	call mlsys_utils_$parse_address_control_args (sci_ptr, arg_idx, addr (pcao), ca_address_ptr, code);
	pcao.validate_addresses = "1"b;		/* re-enable validation for others */
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Parsing address arguments");
	call mail_system_$validate_address (ca_address_ptr, "0"b, code);
	if code = forum_error_table_$not_eligible then code = 0;
						/* not being a participant is okay */

	if code ^= 0 then do;
	     call mlsys_utils_$print_validate_results (sci_ptr, ca_address_ptr, code);
	     call mail_system_$free_address (ca_address_ptr, (0));
	     call ssu_$abort_line (sci_ptr);
	end;

	if address_ptr ^= null () then do;		/* Already gave an address */
	     call mail_system_$free_address (ca_address_ptr, (0));
	     call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "Only one address may be specified.");
	end;
	revert cleanup;
	address_ptr = ca_address_ptr;
	arg_idx = arg_idx - 1;			/* do loop will increment */
	return;

     end get_meeting_args;


get_address_args:
     proc ();

	dcl     ca_address_ptr	ptr;

	call mlsys_utils_$parse_address_control_args (sci_ptr, arg_idx, addr (pcao), ca_address_ptr, code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Parsing address arguments");
	if address_ptr ^= null () then do;		/* Already gave an address */
	     call mail_system_$free_address (ca_address_ptr, (0));
	     call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "Only one address may be specified.");
	end;
	address_ptr = ca_address_ptr;
	arg_idx = arg_idx - 1;			/* do loop will increment */
	return;

     end get_address_args;

/**** Returns TRUE if the name is in use (case-insensitively) ****/
check_ambiguous_name:
     proc (P_name) returns (bit (1));

	dcl     P_name		char (*) varying parameter;

	dcl     address_ptr		ptr;
	dcl     code		fixed bin (35);

	address_ptr = null ();
	code = 0;
	on cleanup
	     begin;
		if address_ptr ^= null () then call mail_system_$free_address (address_ptr, (0));
	     end;
	call mail_table_$get (P_name, address_ptr, (""), code);
	if address_ptr ^= null () then call mail_system_$free_address (address_ptr, (0));
	revert cleanup;
	if code = 0 | code = mlsys_et_$ambiguous_address then return ("1"b);
	else if code = error_table_$id_not_found then return ("0"b);
	else call ssu_$abort_line (sci_ptr, code, "Looking for ""^a"" in the Mail Table.", P_name);

     end check_ambiguous_name;


     end add_mail_table_entry;




		    canonicalize_mailbox.pl1        05/22/86  1109.6r w 05/22/86  1012.1      268938



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */

/* canonicalize_mailbox: reads all the messages out of a mailbox, and stores
   them back in there.  This way read_mail's reg-exp search does not have to
   reformat the message, since they are stored in canonical format until we
   go to binary messages. */
/* Written: October 1983 by B. Margolin */
/* Modified: 11 November 1983 by B. Margolin to add -force */
/* Modified: 29 November 1983 by B. Margolin to make it copy into a
   new mbx, and to add -privilege and AIM checking. */
/* Modified: 6 January 1984 by B. Margolin to not reference through null
   pointer when using -force on an already-canonical mailbox. */
/* Modified: 5 April 1984 by G. Palter to fix mail system error #0439 -- The explanation for canonicalizing a mailbox
   whose access class is higher than the process authorization contains the word "unaccessible"; it should be
   "inaccessible" */

canonicalize_mailbox:
     proc options (variable);

	/*** Automatic ***/

	dcl     area_ptr		ptr;
	dcl     arg_count		fixed bin;
	dcl     arg_idx		fixed bin;
	dcl     arg_len		fixed bin (21);
	dcl     arg_ptr		ptr;
	dcl     code		fixed bin (35);
	dcl     dir_priv		fixed bin (35);
	dcl     enable_privs	bit (1);
	dcl     error_return	bit (1);
	dcl     force_access	bit (1);
	dcl     link_flag		bit (1);
	dcl     1 local_close_options aligned like close_options;
	dcl     1 local_delete_options
				aligned like delete_mailbox_options;
	dcl     1 local_open_options	aligned like open_options;
	dcl     1 local_status_branch aligned like status_branch;
	dcl     mbx_dir		char (168);
	dcl     mbx_entry		char (32);
	dcl     mbx_path_len	fixed bin (21);
	dcl     mbx_path_ptr	ptr;
	dcl     1 my_acl_entry	aligned,
		2 header		like mailbox_acl.header,
		2 acl_term	like mailbox_acl.acl_terms;
	dcl     ring1_priv		fixed bin (35);
	dcl     sci_ptr		ptr;
	dcl     seg_priv		fixed bin (35);
	dcl     star_code		fixed bin (35);
	dcl     user_auth		bit (72) aligned;

	/*** Based ***/

	dcl     arg		char (arg_len) based (arg_ptr);
	dcl     mbx_path		char (mbx_path_len) based (mbx_path_ptr);
	dcl     my_area		area based (area_ptr);

	/*** Entries ***/

	dcl     (
	        aim_check_$equal,
	        aim_check_$greater
	        )			entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned) reducible;
	dcl     check_star_name_$entry
				entry (char (*), fixed bin (35));
	dcl     com_err_		entry () options (variable);
	dcl     command_query_$yes_no entry () options (variable);
	dcl     convert_authorization_$to_string_short
				entry (bit (72) aligned, char (*), fixed bin (35));
	dcl     cu_$arg_list_ptr	entry (ptr);
	dcl     cu_$generate_call	entry (entry, ptr);
	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_authorization_, get_max_authorization_)
				entry () returns (bit (72) aligned) reducible;
	dcl     get_group_id_	entry () returns (char (32));
	dcl     hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35));
	dcl     hcs_$get_link_target	entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$get_max_length	entry (char (*), char (*), fixed bin, fixed bin (35));
	dcl     hcs_$get_safety_sw	entry (char (*), char (*), bit (1), fixed bin (35));
	dcl     hcs_$get_user_access_modes
				entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
				bit (36) aligned, fixed bin (35));
	dcl     hcs_$star_		entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
				fixed bin (35));
	dcl     hcs_$status_	entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     (
	        ioa_,
	        ioa_$nnl
	        )			entry () options (variable);
	dcl     mail_system_$close_mailbox
				entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$copy_message
				entry (ptr, char (*), char (*), fixed bin (35));
	dcl     mail_system_$open_mailbox
				entry (char (*), char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     mail_system_$read_message
				entry (ptr, fixed bin, fixed bin (35));
	dcl     mail_system_$read_message_canonical_form
				entry (ptr, fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     mail_system_$read_new_messages
				entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     mailbox_$chname_file	entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     mailbox_$get_mode_file
				entry (char (*), char (*), bit (7), fixed bin (35));
	dcl     mailbox_$set_max_length_file
				entry (char (*), char (*), fixed bin (19), fixed bin (35));
	dcl     mailbox_$set_safety_switch
				entry (char (*), char (*), bit (1), fixed bin (35));
	dcl     mlsys_utils_$add_mailbox_acl_entries
				entry (char (*), char (*), ptr, fixed bin (35));
	dcl     mlsys_utils_$create_mailbox
				entry (char (*), char (*), fixed bin (35));
	dcl     mlsys_utils_$delete_mailbox
				entry (char (*), char (*), char (*), ptr, fixed bin (35));
	dcl     mlsys_utils_$list_mailbox_acl
				entry (char (*), char (*), ptr, char (8), ptr, fixed bin (35));
	dcl     mlsys_utils_$replace_mailbox_acl_entries
				entry (char (*), char (*), 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_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_$get_area	entry (ptr, ptr, char (*), ptr);
	dcl     ssu_$print_message	entry () options (variable);
	dcl     ssu_$standalone_invocation
				entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	dcl     (
	        system_privilege_$dir_priv_off,
	        system_privilege_$dir_priv_on,
	        system_privilege_$ring1_priv_off,
	        system_privilege_$ring1_priv_on,
	        system_privilege_$seg_priv_off,
	        system_privilege_$seg_priv_on
	        )			entry (fixed bin (35));
	dcl     (
	        system_privilege_$reclassify_branch,
	        system_privilege_$reclassify_sys_seg
	        )			entry (char (*), char (*), bit (72) aligned, fixed bin (35));
	dcl     unique_chars_	entry (bit (*)) returns (char (15));

	/*** Static ***/

	dcl     (
	        error_table_$bad_arg,
	        error_table_$badopt,
	        error_table_$incorrect_access,
	        error_table_$insufficient_access,
	        error_table_$noarg,
	        error_table_$noentry,
	        error_table_$not_privileged,
	        error_table_$rqover,
	        error_table_$too_many_args,
	        mlsys_et_$no_message_canonical_form,
	        mlsys_et_$no_more_messages
	        )			fixed bin (35) ext static;
	dcl     sys_info$access_class_ceiling /* system_high */
				bit (72) aligned ext static;
	dcl     MBX_SUFFIX		char (3) int static options (constant) init ("mbx");
	dcl     WHOAMI		char (20) int static options (constant) init ("canonicalize_mailbox");
	dcl     VERSION		char (3) int static options (constant) init ("1.0");

	/*** Misc ***/

	dcl     (cleanup, linkage_error)
				condition;
	dcl     (addr, mod, null, pointer, string, substr, sum)
				builtin;
%page;
%include access_mode_values;
%page;
%include mlsys_close_options;
%page;
%include mlsys_delete_error_info;
%page;
%include mlsys_delete_mailbox;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_mailbox_acl;
%page;
%include mlsys_mailbox_modes;
%page;
%include mlsys_message;
%page;
%include mlsys_open_options;
%page;
%include status_structures;
%page;
%include star_structures;
%page;	/*** Initialize things used in cleanup handler ***/
	sci_ptr = null ();
	ring1_priv, dir_priv, seg_priv = -1;
	enable_privs = "0"b;
	on cleanup call cleanup_canon_mbx ();

	call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_canon_mbx, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Attempting to create standalone subsystem invocation.");
						/* GMP, forgive me... */
	     return;
	end;
	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count = 0 then call ssu_$abort_line (sci_ptr, 0, "Usage: canonicalize_mailbox mbx_pathname {-ctl_args}");
	mbx_path_ptr = null ();
	force_access = "0"b;
	do arg_idx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
	     if arg = "" then
		call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "The mailbox pathname may not be a null string.")
		     ;
	     if substr (arg, 1, 1) = "-" then do;
		if arg = "-force" | arg = "-fc" then force_access = "1"b;
		else if arg = "-no_force" | arg = "-nfc" then force_access = "0"b;
		else if arg = "-privilege" | arg = "-priv" then enable_privs = "1"b;
		else if arg = "-no_privilege" | arg = "-npriv" then enable_privs = "0"b;
		else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
	     end;
	     else if mbx_path_ptr ^= null () then
		call ssu_$abort_line (sci_ptr, error_table_$too_many_args,
		     "Only one mailbox pathname may be specified.");
	     else do;
		mbx_path_ptr = arg_ptr;
		mbx_path_len = arg_len;
	     end;
	end;
	if mbx_path_ptr = null () then
	     call ssu_$abort_line (sci_ptr, error_table_$noarg, "A mailbox pathname must be supplied.");

	call expand_pathname_$add_suffix (mbx_path, MBX_SUFFIX, mbx_dir, mbx_entry, code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "The pathname ^a", requote_string_ (mbx_path));
	call check_star_name_$entry (mbx_entry, star_code);
	if star_code > 2 | star_code < 0 then
	     call ssu_$abort_line (sci_ptr, star_code, "The pathname ^a",
		requote_string_ (pathname_ (mbx_dir, mbx_entry)));
	else if star_code = 2 then
	     call ssu_$abort_line (sci_ptr, 0, "Invalid return code from check_star_name_$entry.");

	if enable_privs then do;
	     if ^aim_check_$equal (get_max_authorization_ (), sys_info$access_class_ceiling) then
		call ssu_$abort_line (sci_ptr, error_table_$not_privileged,
		     "A maximum authorization of system_high is required.");
	     on linkage_error
		call ssu_$abort_line (sci_ptr, error_table_$not_privileged,
		     "Access to the system_privilege_ gate is required.");
	     call system_privilege_$ring1_priv_on (ring1_priv);
	     call system_privilege_$dir_priv_on (dir_priv);
	     call system_privilege_$seg_priv_on (seg_priv);
	end;
	else user_auth = get_authorization_ ();


	close_options_ptr = addr (local_close_options);
	close_options.version = CLOSE_OPTIONS_VERSION_2;
	string (close_options.flags) = ""b;
	delete_mailbox_options_ptr = addr (local_delete_options);
	delete_mailbox_options.version = DELETE_MAILBOX_OPTIONS_VERSION_1;
	string (delete_mailbox_options.flags) = ""b;
	delete_mailbox_options.force = "1"b;
	open_options_ptr = addr (local_open_options);
	open_options.version = OPEN_OPTIONS_VERSION_2;
	open_options.message_selection_mode = ALL_MESSAGES;
	open_options.sender_selection_mode = ALL_MESSAGES;
	open_options.message_reading_level = READ_KEYS;
	status_ptr = addr (local_status_branch);

	if force_access then do;			/* in case we have to */
	     my_acl_entry.version = MAILBOX_ACL_VERSION_1;
	     my_acl_entry.n_acl_terms = 1;
	     my_acl_entry.access_name = get_group_id_ ();
	     my_acl_entry.extended_mode = ADROSW_MBX_ACCESS;
	end;
	call ssu_$get_area (sci_ptr, null (), "ACLs/starnames/names", area_ptr);
	status_area_ptr = area_ptr;

	if star_code = 0 then
	     call canon_one_mbx (mbx_dir, mbx_entry, abort_nonstar_canon);
	else /* if star_code = 1 then */
	     call canon_star_mbx (mbx_dir, mbx_entry);
GLOBAL_EXIT:
	call cleanup_canon_mbx ();
	return;

abort_canon_mbx:
     proc ();

	go to GLOBAL_EXIT;

     end abort_canon_mbx;

cleanup_canon_mbx:
     proc ();

	if enable_privs then do;
	     if ring1_priv = 0 then call system_privilege_$ring1_priv_off ((0));
	     if dir_priv = 0 then call system_privilege_$dir_priv_off ((0));
	     if seg_priv = 0 then call system_privilege_$seg_priv_off ((0));
	end;
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);

	return;

     end cleanup_canon_mbx;
%page;
canon_one_mbx:
     proc (P_dir, P_entry, P_abort_label);

	dcl     (P_dir, P_entry)	char (*) parameter;
	dcl     P_abort_label	entry () options (variable) variable parameter;

	dcl     access_class	bit (72) aligned;
	dcl     auth_string		char (256);
	dcl     code		fixed bin (35);
	dcl     (delete_new, delete_original, delete_original_by_shriek_entry)
				bit (1);
	dcl     dir_access_class	bit (72) aligned;
	dcl     max_length		fixed bin;
	dcl     messages_processed	fixed bin;
	dcl     message_idx		fixed bin;
	dcl     n_new_messages	fixed bin;
	dcl     name_idx		fixed bin;
	dcl     safety_sw		bit (1);
	dcl     save_acl_ptr	ptr;
	dcl     shriek_entry	char (32);
	dcl     (target_dir, target_dir_dir)
				char (168);
	dcl     (target_dir_entry, target_entry)
				char (32);
	dcl     temp_entry		char (32);
	dcl     this_name		char (32);

	save_acl_ptr, mailbox_ptr = null ();
	delete_new, delete_original, delete_original_by_shriek_entry, error_return = "0"b;
	status_branch.names_relp = ""b;
	on cleanup
	     begin;
		if mailbox_ptr ^= null () then call mail_system_$close_mailbox (mailbox_ptr, close_options_ptr, (0));
		if delete_original & error_return then
		     if delete_original_by_shriek_entry then
			call mlsys_utils_$delete_mailbox (target_dir, shriek_entry, WHOAMI,
			     delete_mailbox_options_ptr, (0));
		     else call mlsys_utils_$delete_mailbox (target_dir, target_entry, WHOAMI,
			     delete_mailbox_options_ptr, (0));
		else if force_access & (save_acl_ptr ^= null ()) then call restore_mbx_access ("1"b);
		if save_acl_ptr ^= null () then free save_acl_ptr -> mailbox_acl in (my_area);
		if status_branch.names_relp ^= ""b then free status_entry_names in (my_area);
		if delete_new then
		     call mlsys_utils_$delete_mailbox (target_dir, temp_entry, WHOAMI, delete_mailbox_options_ptr,
			(0));
	     end;

	/*** Check access ***/
	call check_mbx_access ();

	/*** Find the real mailbox, in case it's a link ***/
	if star_code = 0 then do;			/* Can only be link if not starname */
	     call hcs_$status_ (P_dir, P_entry, 0, status_ptr, null (), code);
	     if code ^= 0 then call P_abort_label (sci_ptr, code, "Getting status on ^a.", pathname_ (P_dir, P_entry));
	     link_flag = (status_branch.type = Link);
	end;
	else link_flag = "0"b;

	if link_flag then do;
	     call hcs_$get_link_target (P_dir, P_entry, target_dir, target_entry, code);
	     if code ^= 0 then
		if code = error_table_$noentry then	/* Null link */
		     call P_abort_label (sci_ptr, code, "The target of the link ^a, ^a, does not exist.",
			pathname_ (P_dir, P_entry), pathname_ (target_dir, target_entry));
		else call P_abort_label (sci_ptr, code, "Trying to find link target of ^a.",
			pathname_ (P_dir, P_entry));
	end;
	else do;
	     target_dir = P_dir;
	     target_entry = P_entry;
	end;

	call ioa_$nnl ("Canonicalizing ^a ^[(actually link target ^a)^]...", pathname_ (P_dir, P_entry), link_flag,
	     pathname_ (target_dir, target_entry));

	/*** Check that we have appropriate access ***/
	call check_dir_access (target_dir, P_abort_label);

	call mail_system_$open_mailbox (P_dir, P_entry, open_options_ptr, MAILBOX_VERSION_2, mailbox_ptr, code);
	if code ^= 0 then call P_abort_label (sci_ptr, code, "Opening ^a", pathname_ (P_dir, P_entry));

	/*** Create the new mailbox ***/
	temp_entry = unique_chars_ (""b) || ".can.mbx";
	call mlsys_utils_$create_mailbox (target_dir, temp_entry, code);
	if code ^= 0 then
	     call P_abort_label (sci_ptr, code, "Cannot create new mailbox ^a.", pathname_ (target_dir, temp_entry));

	delete_new = "1"b;
	if enable_privs then do;
	     call expand_pathname_ (target_dir, target_dir_dir, target_dir_entry, (0));
	     call hcs_$get_access_class (target_dir_dir, target_dir_entry, dir_access_class, code);
	     if code ^= 0 then
		call P_abort_label (sci_ptr, code, "Cannot determine access class of directory ^a.", target_dir);
	     if aim_check_$equal (dir_access_class, access_class) then
						/* not upgraded (i.e. multiclass) */
		call system_privilege_$reclassify_branch (target_dir, temp_entry, access_class, code);
	     else call system_privilege_$reclassify_sys_seg (target_dir, temp_entry, access_class, code);
	     if code ^= 0 then do;
		call convert_authorization_$to_string_short (access_class, auth_string, (0));
		call P_abort_label (sci_ptr, code, "Can't set access class of new mailbox ^a to ""^a"".",
		     pathname_ (target_dir, temp_entry), auth_string);
	     end;
	end;
	call hcs_$get_max_length (P_dir, P_entry, max_length, code);
	if code = 0 then do;
	     call mailbox_$set_max_length_file (target_dir, temp_entry, (max_length), code);
	     if code ^= 0 then do;
		call print_message (sci_ptr, code, "Warning: Can't set max length of the new mailbox ^a to ^d.",
		     pathname_ (target_dir, temp_entry), max_length);
		code = 0;
	     end;
	end;
	else do;
	     call print_message (sci_ptr, code,
		"Can't get max length of ^a;^/the canonicalized mailbox will be the default size.",
		pathname_ (P_dir, P_entry));
	     code = 0;
	end;
%page;	/*** Begin copying messages ***/
	if mailbox_not_canonical () then do;
	     n_new_messages = mailbox.n_messages;
	     messages_processed = 0;

	     do while (n_new_messages > 0);
		do message_idx = messages_processed + 1 to mailbox.n_messages;
		     if mailbox.messages (message_idx).message_ptr = null () then do;
			call mail_system_$read_message (mailbox_ptr, message_idx, code);
			if code ^= 0 then
			     call P_abort_label (sci_ptr, code, "Reading message #^d from ^a", message_idx,
				pathname_ (P_dir, P_entry));
		     end;
		     message_ptr = mailbox.messages (message_idx).message_ptr;
		     if ^enable_privs & ^aim_check_$equal (message.access_class, user_auth) then
			call P_abort_label (sci_ptr, 0,
			     "^a^/contains messages at a lower access class than the process authorization.^/Use the -privilege control argument or see a system maintainer for help."
			     , pathname_ (P_dir, P_entry));
		     call mail_system_$copy_message (message_ptr, target_dir, temp_entry, code);
		     if code ^= 0 then
			if code = error_table_$rqover then
			     call P_abort_label (sci_ptr, code,
				"^/The directory ^a^/does not have enough quota for the canonicalized copy of ^a.",
				target_dir, target_entry);
			else call P_abort_label (sci_ptr, code, "Copying message #^d from ^a to ^a.", message_idx,
				pathname_ (P_dir, P_entry), pathname_ (target_dir, temp_entry));
		     if mod (message_idx, 50) = 0 then call ioa_$nnl (" ^d", message_idx);
		end;
		messages_processed = mailbox.n_messages;
		call mail_system_$read_new_messages (mailbox_ptr, n_new_messages, (0), (0), code);
		if code ^= 0 then do;
		     if code = mlsys_et_$no_more_messages then do;
			n_new_messages = 0;
			code = 0;
		     end;
		     else call P_abort_label (sci_ptr, code, "Trying to read new messages from ^a.",
			     pathname_ (P_dir, P_entry));
		end;
	     end;
	end;
	else do;					/* mailbox is already canonical */
	     /*** So clean up the mess we've made ... ***/
	     call mail_system_$close_mailbox (mailbox_ptr, close_options_ptr, (0));
	     if force_access then
		call restore_mbx_access ("0"b);
	     else free save_acl_ptr -> mailbox_acl in (my_area);
	     call mlsys_utils_$delete_mailbox (target_dir, temp_entry, WHOAMI, delete_mailbox_options_ptr, (0));
	     /*** ... and punt ***/
	     call ioa_ ("");
	     return;
	end;

	call ioa_ ("");				/* newline when done */

	delete_new = "0"b;
	call mail_system_$close_mailbox (mailbox_ptr, close_options_ptr, (0));
%page;	/*** Copy safety switch, ACL, and names to new mailbox ***/

	call hcs_$get_safety_sw (P_dir, P_entry, safety_sw, code);
	if code ^= 0 then do;
	     call print_message (sci_ptr, code,
		"Can't get safety switch of ^a;^/canonicalized mailbox will have safety switch off.",
		pathname_ (P_dir, P_entry));
	     safety_sw = "0"b;
	     code = 0;
	end;
	else do;
	     call mailbox_$set_safety_switch (target_dir, temp_entry, safety_sw, code);
	     if code ^= 0 then do;
		call print_message (sci_ptr, code,
		     "Warning: Can't turn o^[n^;ff^] safety switch of the new mailbox ^a.", safety_sw,
		     pathname_ (target_dir, temp_entry));
		code = 0;
	     end;
	end;

	call mlsys_utils_$replace_mailbox_acl_entries (target_dir, temp_entry, save_acl_ptr, code);
	if code ^= 0 then do;
	     call print_message (sci_ptr, code, "Warning: Can't copy ACL from ^a to ^a.", pathname_ (P_dir, P_entry),
		pathname_ (target_dir, temp_entry));
	     code = 0;
	end;
	delete_original = "1"b;			/* Everything but names copied, so it is safe to delete it */
						/* as the error messages will tell the user where the good */
						/* mailbox is. */

	shriek_entry = unique_chars_ (""b) || ".can_old.mbx";
	call mailbox_$chname_file (target_dir, target_entry, "", shriek_entry, code);
	if code ^= 0 then
	     call P_abort_label (sci_ptr, code, "Adding name ^a to ^a.^/Canonicalized mailbox is ^a.", shriek_entry,
		pathname_ (target_dir, target_entry), pathname_ (target_dir, temp_entry));

	delete_original_by_shriek_entry = "1"b;		/* As of now, the original name may be on the canonicalized */
						/* mailbox; be sure we don't accidently delete the new */
						/* mailbox if we are unable to move all the names */

	/*** Now copy the real names and delete the .can.mbx name ***/
	call hcs_$status_ (target_dir, target_entry, 0, status_ptr, area_ptr, code);
	if code ^= 0 then
	     call P_abort_label (sci_ptr, code, "Getting names of ^a.^/Canonicalized mailbox is ^a.",
		pathname_ (target_dir, target_entry), pathname_ (target_dir, temp_entry));
	do name_idx = 1 to status_branch.nnames;
	     this_name = status_entry_names (name_idx);
	     if this_name ^= shriek_entry then /* Leave shriek name */ call move_name (this_name);
	end;

	call mailbox_$chname_file (target_dir, temp_entry, temp_entry, "", code);
						/* Delete .can.mbx name */
	if code ^= 0 then do;
	     call print_message (sci_ptr, code, "Warning: Can't delete the name ^a from the canonicalized mailbox ^a.",
		temp_entry, pathname_ (target_dir, target_entry));
	     code = 0;
	end;


	/*** Now that we have successfully (hopefully) copied everything,
	     delete the original. ***/
	call mlsys_utils_$delete_mailbox (target_dir, shriek_entry, WHOAMI, delete_mailbox_options_ptr, code);
	if code ^= 0 then do;
	     call print_message (sci_ptr, code, "Can't delete the original mailbox, now named ^a.",
		pathname_ (target_dir, shriek_entry));
	end;
	free status_entry_names in (my_area);
	free save_acl_ptr -> mailbox_acl in (my_area);
	return;
%page;
move_name:
     proc (P_name);

	dcl     P_name		char (*) parameter;

	call mailbox_$chname_file (target_dir, shriek_entry, P_name, "", code);
						/* delete from the old */
	if code ^= 0 then
	     call P_abort_label (sci_ptr, code, "Deleting name ^a from ^a.^/Canonicalized mailbox is ^a.", P_name,
		pathname_ (target_dir, shriek_entry), pathname_ (target_dir, temp_entry));
	call mailbox_$chname_file (target_dir, temp_entry, "", P_name, code);
						/* Add to the new */
	if code ^= 0 then
	     call P_abort_label (sci_ptr, code, "Adding name ^a to the canonicalized maibox ^a.", P_name,
		pathname_ (target_dir, temp_entry));
     end move_name;

mailbox_not_canonical:
     proc () returns (bit (1) aligned);

	dcl     code		fixed bin (35);
	dcl     message_idx		fixed bin;

	do message_idx = 1 to mailbox.n_messages;
	     call mail_system_$read_message_canonical_form (mailbox_ptr, message_idx, (null ()), (0), code);
	     if code = mlsys_et_$no_message_canonical_form then return ("1"b);
	     else if code ^= 0 then
		call P_abort_label (sci_ptr, code, "Checking format of message #^d in ^a", message_idx,
		     pathname_ (P_dir, P_entry));
	end;
	return ("0"b);

     end mailbox_not_canonical;


check_mbx_access:
     proc ();

	dcl     mbx_mode		bit (7);
	dcl     yes_sw		bit (1);

	call mailbox_$get_mode_file (P_dir, P_entry, mbx_mode, code);
	if code ^= 0 then call P_abort_label (sci_ptr, code, "Checking access to ^a", pathname_ (P_dir, P_entry));
	if (mbx_mode & (A_MBX_ACCESS | D_MBX_ACCESS | R_MBX_ACCESS)) = (A_MBX_ACCESS | D_MBX_ACCESS | R_MBX_ACCESS) then
	     call get_mbx_access ();
	else if force_access then do;
	     call get_mbx_access ();
	     call mlsys_utils_$add_mailbox_acl_entries (P_dir, P_entry, addr (my_acl_entry), code);
	     if code ^= 0 then call P_abort_label (sci_ptr, code, "Forcing access to ^a", pathname_ (P_dir, P_entry));
	end;
	else call P_abort_label (sci_ptr, error_table_$insufficient_access, "adr access is required to ^a",
		pathname_ (P_dir, P_entry));

	/*** Get the access class of the mbx ***/
	call hcs_$get_access_class (P_dir, P_entry, access_class, code);
	if code ^= 0 then
	     call P_abort_label (sci_ptr, code, "Getting the access class of ^a", pathname_ (P_dir, P_entry));
	if ^enable_privs & aim_check_$greater (access_class, user_auth) then do;
	     call command_query_$yes_no (yes_sw, 0, WHOAMI,
		"The maximum access class of ^a^/is greater than your process authorization, so there may be inaccessible^/"
		||
		"messages which will be lost during canonicalization.^/You may wish to use the -privilege option or see a system administrator.^/Canonicalize anyway?"
		,
		"^a^/may contain messages which will be lost due to AIM restrictions.^/Canonicalize anyway? (type ""?"" for more details)"
		, pathname_ (P_dir, P_entry));
	     if ^yes_sw then call P_abort_label (sci_ptr, 0);
	end;

	return;

get_mbx_access:
     proc ();

	call mlsys_utils_$list_mailbox_acl (P_dir, P_entry, area_ptr, MAILBOX_ACL_VERSION_1, save_acl_ptr, code);
	if code ^= 0 then call P_abort_label (sci_ptr, code, "Getting the ACL of ^a", pathname_ (P_dir, P_entry));
	return;

     end get_mbx_access;

     end check_mbx_access;

restore_mbx_access:
     proc (P_silent);

	dcl     P_silent		bit (1) aligned parameter;

	call mlsys_utils_$replace_mailbox_acl_entries (P_dir, P_entry, save_acl_ptr, code);
	free save_acl_ptr -> mailbox_acl in (my_area);
	save_acl_ptr = null ();
	if P_silent | (code = 0) then
	     return;
	else call P_abort_label (sci_ptr, code, "Restoring access on mailbox ^s", pathname_ (P_dir, P_entry));
	return;

     end restore_mbx_access;

print_message:
     proc () options (variable);

	dcl     arg_list_ptr	ptr;

	call ioa_ ("");				/* So error message comes out at beginning of line */
	call cu_$arg_list_ptr (arg_list_ptr);
	call cu_$generate_call (ssu_$print_message, arg_list_ptr);

     end print_message;

     end canon_one_mbx;

abort_nonstar_canon:
     proc () options (variable);

	dcl     arg_list_ptr	ptr;

	error_return = "1"b;			/* So we'll clean up useless original */
	call ioa_ ("");				/* So error message comes out at beginning of line */
	call cu_$arg_list_ptr (arg_list_ptr);
	call cu_$generate_call (ssu_$abort_line, arg_list_ptr);

     end abort_nonstar_canon;

check_dir_access:
     proc (P_dir, P_abort_label);

	dcl     P_dir		char (*) parameter;
	dcl     P_abort_label	entry () options (variable) variable parameter;

	dcl     access_class	bit (72) aligned;
	dcl     code		fixed bin (35);
	dcl     dir_dir		char (168);
	dcl     dir_entry		char (32);
	dcl     mode		bit (36) aligned;

	call expand_pathname_ (P_dir, dir_dir, dir_entry, (0));
	call hcs_$get_user_access_modes (dir_dir, dir_entry, "", -1, mode, (""b), code);
	if code ^= 0 then call P_abort_label (sci_ptr, code, "^/Determining access to the directory ^a.", P_dir);
	if mode ^= SMA_ACCESS then
	     call P_abort_label (sci_ptr, error_table_$incorrect_access, "^/sma access is required to ^a.", P_dir);
	if ^enable_privs then do;
	     call hcs_$get_access_class (dir_dir, dir_entry, access_class, code);
	     if code ^= 0 then
		call P_abort_label (sci_ptr, code, "^/Determining access class of the directory ^a.", P_dir);
	     if ^aim_check_$equal (user_auth, access_class) then
		call P_abort_label (sci_ptr, error_table_$incorrect_access,
		     "^/The access class of ^a must equal the process authorization.", P_dir);
	end;
	return;

     end check_dir_access;


canon_star_mbx:
     proc (P_dir, P_starname);

	dcl     (P_dir, P_starname)	char (*) parameter;

	dcl     code		fixed bin (35);
	dcl     entry_idx		fixed bin;

	/*** First check that we have appropriate access to the dir ***/
	call check_dir_access (P_dir, ssu_$abort_line);

	call hcs_$star_ (P_dir, P_starname, star_BRANCHES_ONLY, area_ptr, star_entry_count, star_entry_ptr,
	     star_names_ptr, code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Starname ^a.", pathname_ (P_dir, P_starname));
	do entry_idx = 1 to star_entry_count;
	     if star_entries (entry_idx).type = star_SEGMENT then
		call canon_one_mbx (P_dir, star_names (star_entries (entry_idx).nindex), abort_one_canon);
NEXT_MBX:
	end;

/* Don't bother freeing star structures, as ssu_ destroys the area */

abort_one_canon:
     proc () options (variable);

	dcl     arg_list_ptr	ptr;

	error_return = "1"b;			/* So we'll clean up useless original */
	call ioa_ ("");				/* So error message comes out at beginning of line */
	call cu_$arg_list_ptr (arg_list_ptr);
	call cu_$generate_call (ssu_$print_message, arg_list_ptr);
	if entry_idx ^= star_entry_count then		/* no next mailbox */
	     call ssu_$print_message (sci_ptr, 0, "Skipping to next mailbox matching starname.");
	go to NEXT_MBX;

     end abort_one_canon;

     end canon_star_mbx;

     end canonicalize_mailbox;




		    compact_mail_table.pl1          11/01/83  1112.1r w 11/01/83  1038.0       29574



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */

/* compact_mail_table: the command interface to mail_table_priv_$salvage. */

/* Written 5 Aug 1983 by B. Margolin */

compact_mail_table:
salvage_mail_table:
     proc ();

	dcl     arg		char (arg_len) based (arg_ptr);
	dcl     arg_count		fixed bin;
	dcl     arg_len		fixed bin (21);
	dcl     arg_ptr		ptr;
	dcl     code		fixed bin (35);
	dcl     message		char (256);
	dcl     new_size		fixed bin;
	dcl     sci_ptr		ptr;

	dcl     VERSION		char (3) int static options (constant) init ("1.0");
	dcl     WHOAMI		char (18) int static options (constant) init ("compact_mail_table");
	dcl     (
	        error_table_$bad_conversion,
	        error_table_$badopt,
	        error_table_$too_many_args
	        )			fixed bin (35) ext static;

	dcl     com_err_		entry () options (variable);
	dcl     cv_dec_check_	entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     mail_table_priv_$count_entries
				entry (fixed bin, fixed bin (35));
	dcl     mail_table_priv_$salvage
				entry (fixed bin, char (*), fixed bin (35));
	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));


	sci_ptr = null ();
	code = 0;
	call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_cmt, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Creating standalone subsystem invocation.");
	     return;
	end;
	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count > 1 then
	     call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "^/Usage:  ^a {new_size}", WHOAMI);
	if arg_count = 1 then do;
	     call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_len);
	     if arg = "" then go to BAD_CONVERSION;	/* cv_dec_check_ turns "" into 0 */
	     if substr (arg, 1, 1) = "-" then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
	     new_size = cv_dec_check_ (arg, code);
	     if code ^= 0 then do;
BAD_CONVERSION:
		call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
		     "The argument must be a positive decimal integer, not ""^a"".", arg);
	     end;
	end;
	else do;
	     call mail_table_priv_$count_entries (new_size, code);
	     if code ^= 0 then
		call ssu_$abort_line (sci_ptr, code, "Counting the number of used entries in the old Mail Table.");
	     new_size = 3 * new_size;			/* This is a good size */
	end;
	call mail_table_priv_$salvage (new_size, message, code);
	if code ^= 0 then
	     call ssu_$abort_line (sci_ptr, code, "^[Salvaging the mail table.^;^a^]", (message = ""), message);
GLOBAL_EXIT:
	call ssu_$destroy_invocation (sci_ptr);
	return;

abort_cmt:
     proc ();

	go to GLOBAL_EXIT;

     end abort_cmt;

     end compact_mail_table;




		    convert_v2_mail_table_.pl1      12/05/84  1422.4r w 12/05/84  1238.3       32409



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: style2 */

convert_v2_mail_table_:
     procedure (P_dirname, P_entryname, P_code);

/**** This subroutine is the target of the gate 
      mail_table_priv_$convert_v2_mail_table_.  It converts the specified
      mail table from a Version 2 MSTB to a Version 3 MSTB. */

/***** Written 1984-08-03 by E. Swenson */

/* Parameters */

	dcl     P_dirname		 char (*) parameter;
	dcl     P_entryname		 char (*) parameter;
	dcl     P_code		 fixed bin (35) parameter;

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     dirname		 char (168);
	dcl     entryname		 char (32);
	dcl     new_entryname	 char (32);
	dcl     old_entryname	 char (32);
	dcl     old_newname		 char (32);
	dcl     saved_level		 fixed bin (3);
	dcl     table_ptr		 ptr;

/* External Entries */

	dcl     convert_v2_mstb_	 entry (char (*), char (*), char (*), char (*), entry, fixed bin (18) unsigned,
				 fixed bin (35));
	dcl     convert_v2_mstb_$default_convert_proc
				 entry (ptr, ptr, ptr, fixed bin (35));
	dcl     hcs_$chname_file	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$level_get	 entry (fixed bin (3));
	dcl     hcs_$level_set	 entry (fixed bin (3));
	dcl     get_ring_		 entry () returns (fixed bin (3));
	dcl     ms_table_mgr_v2_$close entry (ptr, fixed bin (35));
	dcl     ms_table_mgr_$delete	 entry (char (*), char (*), fixed bin (35));
	dcl     ms_table_mgr_v2_$open	 entry (char (*), char (*), char (*) aligned, ptr, ptr, fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));

/* Constants */

	dcl     SAME_SIZE		 fixed bin (18) unsigned internal static options (constant) initial (0);

/* Conditions */

	dcl     cleanup		 condition;
%page;
/* Program */

	dirname = P_dirname;			/* Copy arguments -- we're a gate */
	entryname = P_entryname;

	saved_level = -1;				/* For cleanup handler */
	on condition (cleanup)
	     begin;
		if saved_level ^= -1
		then do;
			call hcs_$level_set (saved_level);
			saved_level = -1;
		     end;
	     end;

	call hcs_$level_get (saved_level);
	call hcs_$level_set (get_ring_ ());

/**** First check to see if it exists and is a mail table */

	call ms_table_mgr_v2_$open (dirname, entryname, "mail_table", table_ptr, (null ()), code);
	if code ^= 0
	then goto RETURN_TO_CALLER;

/**** That was all we needed, close it now. */

	call ms_table_mgr_v2_$close (table_ptr, (0));

	new_entryname = rtrim (substr (entryname, 1, 14)) || "." || unique_chars_ (""b);

	call convert_v2_mstb_ (dirname, entryname, dirname, new_entryname, convert_v2_mstb_$default_convert_proc,
	     SAME_SIZE, code);
	if code ^= 0
	then goto RETURN_TO_CALLER;

	old_newname = rtrim (substr (entryname, 1, 14)) || "." || unique_chars_ (""b);

/* Add shriekname to old mail table */

	call hcs_$chname_file (dirname, entryname, "", old_newname, code);
	if code ^= 0
	then goto RETURN_TO_CALLER;

/* Delete real name from old mail table */

	call hcs_$chname_file (dirname, entryname, entryname, "", code);
	if code ^= 0
	then goto RETURN_TO_CALLER;

/* Rename the new one to the real name */

	call hcs_$chname_file (dirname, new_entryname, new_entryname, entryname, code);

RETURN_TO_CALLER:
	call hcs_$level_set (saved_level);
	saved_level = -1;
	P_code = code;
	return;

     end convert_v2_mail_table_;




		    create_mail_table.pl1           03/14/85  0836.8r w 03/13/85  1015.0       51615



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */

/* create_mail_table: Used by privileged user (generally the
   Initializer before the Ansewring Service is brought up) to create
   the Mail Table and populate it with Mail Table entries for all
   the Person_ids and aliases in the PNT. */

/* Written: July 1983 by B. Margolin */
/* Modified: November 1983 by B. Margolin to not hard-code the PNT pathname,
   but to use the new entrypoint pnt_manager_$table_data. */
/* Modified 1984-08-15 by E. Swenson for Ring-1 PNTs and Version 3 MSTBs. */

create_mail_table:
     proc options (variable);

	/*** Automatic ***/

	dcl     arg_count		fixed bin;
	dcl     code		fixed bin (35);
	dcl     1 mte		aligned like mail_table_entry;
	dcl     pnt_idx		fixed bin (35);
	dcl     1 pnt_mti		aligned like ms_table_info;
	dcl     1 pnte		aligned like pnt_entry;
	dcl     sci_ptr		ptr;

	/*** Static ***/

	dcl     (
	        error_table_$bad_index,
	        error_table_$checksum_failure,
	        error_table_$id_already_exists,
	        error_table_$no_record,
	        error_table_$unimplemented_version
	        )			fixed bin (35) ext static;
	dcl     VERSION		char (3) int static options (constant) init ("1.0");
	dcl     WHOAMI		char (17) int static options (constant) init ("create_mail_table");

	/*** Entries ***/

	dcl     com_err_		entry () options (variable);
	dcl     ioa_		entry () options (variable);
	dcl     mail_table_priv_$add	entry (ptr, bit (1), fixed bin (35));
	dcl     mail_table_priv_$add_alias
				entry (char (*), char (*), bit (1), fixed bin (35));
	dcl     mail_table_priv_$create
				entry (fixed bin, fixed bin (35));
	dcl     pathname_		entry (char (*), char (*)) returns (char (168));
	dcl     pnt_manager_$get_abs_entry
				entry (fixed bin (35), ptr, fixed bin (35));
	dcl     pnt_manager_$table_data
				entry (ptr, fixed bin (35), fixed bin (35));
	dcl     ssu_$abort_line	entry () options (variable);
	dcl     ssu_$arg_count	entry (ptr, fixed bin);
	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));

	/*** Misc ***/

	dcl     cleanup		condition;
	dcl     (addr, null, rtrim)	builtin;
%page;
%include mail_table_entry;
%page;
%include ms_table_info;
%page;
%include pnt_entry;

	code = 0;
	sci_ptr = null ();
	on cleanup call cleanup_proc ();
	call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_cmt, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Error while creating standalone invocation.");
	     return;
	end;
	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count > 0 then call ssu_$abort_line (sci_ptr, 0, "The create_mail_table command takes no arguments.");
	/*** Find out the size of the PNT ***/
	call pnt_manager_$table_data (addr (pnt_mti), (0), code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Error getting PNT size info.");
	if pnt_mti.version ^= MS_TABLE_INFO_VERSION_3 then
	     call ssu_$abort_line (sci_ptr, error_table_$unimplemented_version, "The PNT is a version ^d MSTB.",
		pnt_mti.version);
	call mail_table_priv_$create ((pnt_mti.max_entries), code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Error attempting to create the Mail Table MSTB.");
	call ioa_ ("Created Mail Table with max_entries = ^d.  Now copying info from PNT.", pnt_mti.max_entries);
	mte.version = MAIL_TABLE_ENTRY_VERSION_1;
	do pnt_idx = 1 repeat (pnt_idx + 1);
	     call pnt_manager_$get_abs_entry (pnt_idx, addr (pnte), code);
	     if code = 0 then call copy_entry ();
	     else if code = error_table_$bad_index then /* Went off the end */ goto DONE_COPYING;
	     else if code ^= error_table_$no_record & code ^= error_table_$checksum_failure then
						/* Unused entry */
		call ssu_$abort_line (sci_ptr, code, "Error reading PNT entry #^d; copy aborted.", pnt_idx);
	end;
DONE_COPYING:
	call ioa_ ("PNT info copied into Mail Table.");
GLOBAL_EXIT:
	call cleanup_proc ();
	return;

abort_cmt:
     proc ();

	go to GLOBAL_EXIT;

     end abort_cmt;

cleanup_proc:
     proc ();

	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	return;

     end cleanup_proc;

copy_entry:
     proc ();

	mte.name = rtrim (pnte.user_id);
	mte.acs_path.entry, mte.acs_path.dir = "";
	mte.default_project = rtrim (pnte.default_project);
	mte.mailing_address = "";
	call mail_table_priv_$add (addr (mte), "1"b, code);
	if code ^= 0 then
	     if code = error_table_$id_already_exists then do;
		call ssu_$print_message (sci_ptr, code, "Skipping PNT entry for ""^a"".", mte.name);
		code = 0;
	     end;
	     else call ssu_$abort_line (sci_ptr, code, "Error copying PNT entry for ""^a"".  PNT copy aborted.",
		     mte.name);
	if pnte.alias ^= "" then do;			/* Add the alias to the Mail Table */
	     call mail_table_priv_$add_alias ((mte.name), rtrim (pnte.alias), "1"b, code);
	     if code ^= 0 then
		if code = error_table_$id_already_exists then do;
		     call ssu_$print_message (sci_ptr, code, "Skipping adding alias ""^a"" to ""^a"".",
			rtrim (pnte.alias), mte.name);
		     code = 0;
		end;
		else call ssu_$abort_line (sci_ptr, code, "Error adding alias ""^a"" to ""^a"".  Aborting PNT copy.",
			rtrim (pnte.alias), mte.name);
	end;
	return;

     end copy_entry;

     end create_mail_table;




		    have_mail.pl1                   10/27/83  1606.7rew 10/27/83  1437.7       89424



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

/* format: off */

/* Returns "true" if there are messages in the specified mailbox */

/* Created:  September 1982 by G. Palter */
/* Modified: July 1983 by G. Palter for new mail system interface */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


have_mail:
     procedure () options (variable);


dcl  command_name character (32);

dcl  code fixed binary (35);

dcl  argument character (argument_lth) unaligned based (argument_ptr);
dcl  argument_ptr pointer;
dcl  argument_lth fixed binary (21);
dcl  (n_arguments, argument_idx) fixed binary;
dcl  active_function bit (1) aligned;

dcl  return_value character (return_value_max_lth) varying based (return_value_ptr);
dcl  return_value_max_lth fixed binary (21);
dcl  return_value_ptr pointer;

dcl  sci_ptr pointer;

dcl  1 local_pcao aligned like parse_ca_options;

dcl  have_mailbox bit (1) aligned;			/* ON => have a pathname argument already */
dcl  mailbox_dirname character (168);
dcl  mailbox_ename character (32);
dcl  mailbox_address_ptr pointer;

dcl  (interactive_messages, mail) bit (1) aligned;	/* ON => this type of mail is being sought */
dcl  default_mailbox bit (1) aligned;			/* ON => default mailbox is being checked */

dcl  include_by_type bit (1) aligned;
dcl  n_messages fixed binary;				/* # of mesasges in it */
dcl  (n_ordinary_messages, n_interactive_messages) fixed binary;

dcl  HAVE_MAIL_OR_MESSAGES_VERSION character (32) static options (constant) initial ("3.0a");

dcl  mlsys_data_$user_default_mailbox_address pointer external;

/* format: off */
dcl (error_table_$inconsistent, error_table_$too_many_args)
	fixed binary (35) external;
/* format: on */

dcl  active_fnc_err_ entry () options (variable);
dcl  com_err_ entry () options (variable);
dcl  cu_$af_return_arg entry (fixed binary, pointer, fixed binary (21)) returns (fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  ioa_ entry () options (variable);
dcl  mail_system_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mail_system_$create_mailbox_address
	entry (character (*), character (*), character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$free_address entry (pointer, fixed binary (35));
dcl  mail_system_$get_address_pathname entry (pointer, character (*), character (*), character (*), fixed binary (35));
dcl  mail_system_$get_message_counts
	entry (character (*), character (*), bit (1) aligned, fixed binary, fixed binary, fixed binary,
	fixed binary (35));
dcl  mlsys_utils_$parse_mailbox_control_args
	entry (pointer, fixed binary, pointer, character (*), character (*), fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21));
dcl  ssu_$destroy_invocation entry (pointer);
dcl  ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21));
dcl  ssu_$standalone_invocation entry (pointer, character (*), character (*), pointer, entry, fixed binary (35));

dcl  cleanup condition;

dcl  (addr, index, null, string) builtin;
%page;
/* Defaults to check for mail and interactive messages */

/* have_mail: entry () options (variable); */

	command_name = "have_mail";
	mail, interactive_messages = "1"b;
	go to COMMON;


/* Defaults to check for interactive messages only */

have_messages:
     entry () options (variable);

	command_name = "have_messages";
	mail = "0"b;
	interactive_messages = "1"b;
	go to COMMON;


/* Argument scanning */

COMMON:
	sci_ptr, mailbox_address_ptr = null ();		/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
		if mailbox_address_ptr ^= null () then call mail_system_$free_address (mailbox_address_ptr, (0));
	     end;

	call ssu_$standalone_invocation (sci_ptr, command_name, HAVE_MAIL_OR_MESSAGES_VERSION, cu_$arg_list_ptr (),
	     abort_have_mail_or_messages_command, code);
	if code ^= 0 then do;			/* please forgive the following but ... */
	     if cu_$af_return_arg ((0), (null ()), (0)) = 0 then
		call active_fnc_err_ (code, command_name, "Can not establish standalone subsystem invocation.");
	     else call com_err_ (code, command_name, "Can not establish standalone subsystem invocation.");
	     return;
	end;

	call ssu_$return_arg (sci_ptr, n_arguments, active_function, return_value_ptr, return_value_max_lth);

	have_mailbox = "0"b;
	default_mailbox = "0"b;

	local_pcao.version = PARSE_CA_OPTIONS_VERSION_1;
	local_pcao.logbox_creation_mode,		/* logbox/savebox must already exist */
	     local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX;
	string (local_pcao.flags) = ""b;
	local_pcao.abort_on_errors = "1"b;		/* any errors are immediately fatal */
	local_pcao.validate_addresses = "1"b;		/* insure that any mailbox specified actually exists */

	do argument_idx = 1 to n_arguments;

	     call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth);

	     if index (argument, "-") = 1 then		/* a control argument */
		if (argument = "-interactive_messages") | (argument = "-im") then interactive_messages = "1"b;
		else if (argument = "-no_interactive_messages") | (argument = "-nim") then
		     interactive_messages = "0"b;

		else if (argument = "-mail") | (argument = "-ml") then mail = "1"b;
		else if (argument = "-no_mail") | (argument = "-nml") then mail = "0"b;

		else go to TRY_ARGUMENT_AS_MAILBOX_PATHNAME;
						/* unknown control argument: maybe a mailbox specifier? */

	     else do;				/* not a control argument: must be a mailbox specifier */
TRY_ARGUMENT_AS_MAILBOX_PATHNAME:
		call mlsys_utils_$parse_mailbox_control_args (sci_ptr, argument_idx, addr (local_pcao),
		     mailbox_dirname, mailbox_ename, code);
						/* ... above entrypoint aborts us if anything's wrong */
		argument_idx = argument_idx - 1;	/* ... do loop will increment it again */
		if have_mailbox then		/* ... this one's OK and we already have one (sigh) */
		     call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "Only one mailbox may be specified.");
		have_mailbox = "1"b;		/* ... now we've got the mailbox to be examined */
	     end;
	end;

	if ^mail & ^interactive_messages then
	     call ssu_$abort_line (sci_ptr, error_table_$inconsistent, """-no_mail"" and ""-no_interactive_messages""");


/* Use the user's default mailbox as a default if necessary; otherwise, check if the supplied mailbox is the user's
   default mailbox so that the appropriate form of message ("You have mail" vs.  "There is mail") will be printed */

	if ^have_mailbox then do;
	     call mail_system_$get_address_pathname (mlsys_data_$user_default_mailbox_address, mailbox_dirname,
		mailbox_ename, ((32)" "), code);
	     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting the pathname of your mailbox.");
	     default_mailbox = "1"b;			/* know this for certain */
	end;

	else do;
	     call mail_system_$create_mailbox_address (mailbox_dirname, mailbox_ename, "", "", mailbox_address_ptr,
		code);
	     if code ^= 0 then
		call ssu_$abort_line (sci_ptr, code, "Getting an address for ^a.",
		     pathname_ (mailbox_dirname, mailbox_ename));
	     default_mailbox =
		mail_system_$compare_addresses (mailbox_address_ptr, mlsys_data_$user_default_mailbox_address, (0));
	     call mail_system_$free_address (mailbox_address_ptr, (0));
	end;


/* Actual processing */

	include_by_type = ^mail | ^interactive_messages;

	call mail_system_$get_message_counts (mailbox_dirname, mailbox_ename, include_by_type, n_messages,
	     n_ordinary_messages, n_interactive_messages, code);
	if code ^= 0 then
	     call ssu_$abort_line (sci_ptr, code, "Determining the number of messages in ^a.",
		pathname_ (mailbox_dirname, mailbox_ename));

	if n_messages = 0 then do;			/* mailbox is empty */
	     if active_function then
		return_value = "false";
	     else call ioa_ ("No ^[messages^;mail^].", (^mail & interactive_messages));
	end;

	else if (mail & interactive_messages) then do;	/* don't care what type */
	     if active_function then return_value = "true";
	     else if default_mailbox then call ioa_ ("You have mail.");
	     else call ioa_ ("There is mail.");
	end;

	else do;					/* checking by type */
	     if mail then do;			/* ... only want ordinary mail */
		if n_ordinary_messages = 0 then
		     if active_function then
			return_value = "false";
		     else call ioa_ ("No mail.");
		else if active_function then return_value = "true";
		else if default_mailbox then call ioa_ ("You have mail.");
		else call ioa_ ("There is mail.");
	     end;

	     else do;				/* ... only want interactive messages */
		if n_interactive_messages = 0 then
		     if active_function then
			return_value = "false";
		     else call ioa_ ("No messages.");
		else if active_function then return_value = "true";
		else if default_mailbox then call ioa_ ("You have messages.");
		else call ioa_ ("There are messages.");
	     end;
	end;

RETURN_FROM_HAVE_MAIL_OR_MESSAGES_COMMAND:
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	if mailbox_address_ptr ^= null () then call mail_system_$free_address (mailbox_address_ptr, (0));

	return;



/* Invoked by ssu_$abort_line and ssu_$abort_subsystem to terminate execution of have_mail/have_messages */

abort_have_mail_or_messages_command:
     procedure ();

	go to RETURN_FROM_HAVE_MAIL_OR_MESSAGES_COMMAND;

     end abort_have_mail_or_messages_command;
%page;
%include mlsys_parse_ca_options;

     end have_mail;




		    mail_system_r2_tv_.alm          05/22/86  1109.6rew 05/22/86  1009.3       53694



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-01-09,Herbst), approve(86-03-25,MCR7367),
"     audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059):
"     Added $set_message_switch.
"                                                      END HISTORY COMMENTS


" Primitive functions provided by the Multics Mail System

" Created:  June 1983 by G. Palter
" Modified: March 1984 by G. Palter to rename initialize_static_data to get_users_addresses
"    and to add set_users_full_name


	name	mail_system_r2_tv_


	macro	transfer
	segdef	&1
&1:	getlp
	tra	&2
	&end


	transfer	abort_delete_operation,mlsys_mailbox_mgr_$abort_delete_operation
	transfer	acknowledge_message,mlsys_mailbox_mgr_$acknowledge_message
	transfer	add_address,mlsys_address_list_mgr_$add_address_writeable
	transfer	add_body_section,mlsys_message_mgr_$add_body_section_new
	transfer	add_reply_reference,mlsys_message_mgr_$add_reply_reference_new

	transfer	add_user_field,mlsys_message_mgr_$add_user_field_new
	transfer	close_mailbox,mlsys_mailbox_mgr_$close_mailbox
	transfer	compare_addresses,mlsys_address_mgr_$compare_addresses
	transfer	copy_address_list,mlsys_address_list_mgr_$copy_address_list
	transfer	copy_message,mlsys_transmit_$copy_message

	transfer	create_address_list,mlsys_address_list_mgr_$create_writeable_address_list
	transfer	create_foreign_address,mlsys_address_mgr_$create_foreign_address
	transfer	create_forum_address,mlsys_address_mgr_$create_forum_address
	transfer	create_invalid_address,mlsys_address_mgr_$create_invalid_address
	transfer	create_logbox_address,mlsys_address_mgr_$create_logbox_address

	transfer	create_mail_table_address,mlsys_address_mgr_$create_mail_table_address
	transfer	create_mailbox_address,mlsys_address_mgr_$create_mailbox_address
	transfer	create_mailing_list_address,mlsys_address_mgr_$create_mailing_list_address
	transfer	create_message,mlsys_message_mgr_$create_new_message
	transfer	create_named_group_address,mlsys_address_mgr_$create_named_group_address

	transfer	create_savebox_address,mlsys_address_mgr_$create_savebox_address
	transfer	create_user_mailbox_address,mlsys_address_mgr_$create_user_mailbox_address
	transfer	decode_message_id,mlsys_message_id_mgr_$decode_message_id
	transfer	delete_address,mlsys_address_list_mgr_$delete_address_writeable
	transfer	delete_body_section,mlsys_message_mgr_$delete_body_section_new

	transfer	delete_reply_reference,mlsys_message_mgr_$delete_reply_reference_new
	transfer	delete_user_field,mlsys_message_mgr_$delete_user_field_new
	transfer	deliver_message,mlsys_transmit_$deliver_message
	transfer	eliminate_duplicate_addresses,mlsys_transmit_$eliminate_duplicate_addrs_write
	transfer	expand_list_address,mlsys_address_mgr_$expand_list_address

	transfer	expunge_messages,mlsys_mailbox_mgr_$expunge_messages
	transfer	free_address,mlsys_address_mgr_$free_address
	transfer	free_address_list,mlsys_address_list_mgr_$free_address_list_writeable
	transfer	free_message,mlsys_message_mgr_$free_message_new
	transfer	get_address_comment,mlsys_address_mgr_$get_address_comment

	transfer	get_address_name,mlsys_address_mgr_$get_address_name
	transfer	get_address_pathname,mlsys_address_mgr_$get_address_pathname
	transfer	get_address_route,mlsys_address_mgr_$get_address_explicit_route
	transfer	get_address_string,mlsys_address_mgr_$get_address_string
	transfer	get_address_system,mlsys_address_mgr_$get_address_system

	transfer	get_address_type,mlsys_address_mgr_$get_address_type
	transfer	get_mail_table_address,mlsys_address_mgr_$get_mail_table_address
	transfer	get_named_group_display_flag,mlsys_address_mgr_$get_named_group_display_flag
	transfer	get_message_counts,mlsys_mailbox_mgr_$get_message_counts
	transfer	get_users_addresses,mlsys_address_mgr_$get_users_addresses

	transfer	get_user_field_id,mlsys_field_id_mgr_$get_user_field_id
	transfer	get_user_field_name,mlsys_field_id_mgr_$get_user_field_name
	transfer	log_message,mlsys_transmit_$log_message
	transfer	mark_message_for_deletion,mlsys_mailbox_mgr_$mark_message_for_deletion
	transfer	merge_address_lists,mlsys_address_list_mgr_$merge_address_lists_writeable

	transfer	open_mailbox,mlsys_mailbox_mgr_$open_mailbox
	transfer	read_message,mlsys_mailbox_mgr_$read_message
	transfer	read_message_canonical_form,mlsys_mailbox_mgr_$read_message_canonical_form
	transfer	read_message_canonical_form_p,mlsys_mailbox_mgr_$read_message_canonical_form_p
	transfer	read_new_messages,mlsys_mailbox_mgr_$read_new_messages

	transfer	redistribute_message,mlsys_transmit_$redistribute_message
	transfer	replace_address,mlsys_address_list_mgr_$replace_address_writeable
	transfer	replace_bcc,mlsys_message_mgr_$replace_bcc_new
	transfer	replace_body,mlsys_message_mgr_$replace_body_new
	transfer	replace_body_section,mlsys_message_mgr_$replace_body_section_new

	transfer	replace_cc,mlsys_message_mgr_$replace_cc_new
	transfer	replace_from,mlsys_message_mgr_$replace_from_new
	transfer	replace_reply_reference,mlsys_message_mgr_$replace_reply_reference_new
	transfer	replace_reply_to,mlsys_message_mgr_$replace_reply_to_new
	transfer	replace_subject,mlsys_message_mgr_$replace_subject_new

	transfer	replace_to,mlsys_message_mgr_$replace_to_new
	transfer	replace_user_field,mlsys_message_mgr_$replace_user_field_new
	transfer	save_message,mlsys_transmit_$save_message
	transfer	set_access_class,mlsys_message_mgr_$set_access_class_new
	transfer	set_message_switch,mlsys_mailbox_mgr_$set_message_switch
	transfer	set_users_full_name,mlsys_address_mgr_$set_users_full_name

	transfer	unmark_message_for_deletion,mlsys_mailbox_mgr_$unmark_message_for_deletion
	transfer	validate_address,mlsys_transmit_$validate_address

	end




		    mail_table_mgr_.pl1             10/02/89  0910.2rew 10/02/89  0813.2      372150



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(88-09-13,Blair), approve(88-09-13,MCR7990), audit(88-09-21,Dupuis),
     install(88-09-26,MR12.2-1121):
     Change mail_table_priv_$salvage to unlock the original mail-table before
     it is closed and to base the like header for the new table on its ptr.
     Mail error_list #510.
  2) change(88-12-14,Parisek), approve(89-01-11,MCR8044),
     audit(89-01-16,Farley), install(89-01-19,MR12.3-1006):
     Added the get_name_by_index non privileged entry for returning the
     mail-table name based on an index into the mail-table.  Useful for
     scanning the mail-table while matching starnames (ie, dsmla <starname>).
  3) change(89-08-02,Lee), approve(89-08-22,MCR8128),
     audit(89-09-25,LZimmerman), install(89-10-02,MR12.3-1079):
     phx20967 (Mail 445) - added entry delete_alias_case_ins to allow the
     update_mail_table_entry command to delete alias entries
     case-insensitively; phx17774, phx21076 (Mail 445) - modified
     mail_table_mgr_$put to search for entries case-insensitively.
                                                   END HISTORY COMMENTS */


/* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */

/* mail_table_mgr_: this program manipulates the system Mail
   Table, which is used to find out the electronic mail address of
   users when you don't know the project, or for non-user objects
   that you wish to address mail to as if they were users (i.e.  not
   by pathname).  Users may update their own mailing addresses,
   privileged users may update any mail table entry, and ACS may be
   set up by privileged users to control who may update particular
   addresses. */

/* Written: June/July 1983 by B. Margolin */
/* Modified: 15 August 1984 by E. Swenson for V3 MSTBs */
/* Modified: 17 December 1984 by E. Swenson and Gary M. Palter to properly
   ignore error_table_$checksum_error, to properly update entries, and to
   rechain aliases correctly when deleting an alias */

mail_table_mgr_:
     proc ();

	/*** Parameters ***/

	dcl     P_acs_path		char (*) parameter; /* ACS pathname */
	dcl     P_address_ptr	ptr parameter;	/* -> Mail system address */
	dcl     P_alias		char (*) varying parameter;
						/* Alias */
	dcl     P_area_ptr		ptr parameter;	/* -> area */
	dcl     P_code		fixed bin (35) parameter;
	dcl     P_count		fixed bin parameter;/* Number of entries */
	dcl     P_dft_proj		char (*) parameter; /* Default project */
	dcl     P_id		char (*) varying parameter;
						/* Name or alias */
	dcl     P_index		fixed bin parameter;/* Index into mail table */
	dcl     P_message		char (*) parameter; /* More detailed error message for salvage */
	dcl     P_mta_ptr		ptr parameter;	/* -> mail_table_aliases */
	dcl     P_mte_ptr		ptr parameter;	/* -> mail_table_entry */
	dcl     P_mtre_ptr		ptr parameter;	/* -> mail_table_raw_entry */
	dcl     P_pnt		bit (1) parameter;	/* Manipulate entries which correspond to PNT entries */
	dcl     P_return_id		char (*) varying parameter;
						/* Name or alias returned by get_name_by_index */
	dcl     P_test_dir		char (*) parameter; /* Directory containing mil table for testing */
	dcl     P_version		char (*) parameter; /* Version string */

	/*** Automatic ***/

	dcl     address		char (256) varying; /* Formatted address */
	dcl     alias		char (32) varying;
	dcl     already_in_fatal_error
				bit (1);
	dcl     anon		fixed bin;	/* For all you Shakespeare lovers */
	dcl     by_name_number	bit (1);		/* For name_by_index entrypoint */
	dcl     by_number		bit (1);		/* Which get_raw entrypoint? */
	dcl     case_insensitive_sw	bit (1);		/* Perform case-insensitive search */
	dcl     cur_mtep		ptr;		/* -> mail table entry */
	dcl     day		fixed bin;
	dcl     (disp_day, disp_hour, disp_minute, disp_month)
				pic "99";
	dcl     entry_num		fixed bin (35);
	dcl     hour		fixed bin;
	dcl     i			fixed bin;
	dcl     ignore_code		fixed bin (35);
	dcl     ignore_rs		fixed bin (35);
	dcl     index		fixed bin;
	dcl     initial_ring	fixed bin;
	dcl     key		char (32);
	dcl     mail_table_locked	bit (1);
	dcl     minute		fixed bin;
	dcl     month		fixed bin;
	dcl     1 msti		aligned like ms_table_info;
	dcl     my_area		area based (my_area_ptr);
	dcl     my_area_ptr		ptr;		/* -> my_area */
	dcl     new		bit (1);		/* New entry or updating? */
	dcl     new_mtep		ptr;		/* -> New mail table entry */
	dcl     new_name		char (32);
	dcl     new_new_name	char (32);
	dcl     next_name		char (32) varying;
	dcl     original_time	fixed bin (71);	/* Used by reader locking */
	dcl     original_write_count	fixed bin;	/* ditto */
	dcl     person_id		char (32) varying;	/* Name of entry */
	dcl     pnt		bit (1);		/* Does entry correspond to PNT entry? */
	dcl     real_mtep		ptr;		/* -> real_mte */
	dcl     theres_more		bit (1);

	/*** Based ***/

	dcl     1 mail_table_header	aligned based (mthp),
		2 write_lock	bit (36),
		2 write_count	fixed bin,
		2 entry_count	fixed bin;	/* Count of mail table entries */
	dcl     1 real_mte				/** In case we ever want non-external data (like locks) **/
				aligned based (real_mtep),
		2 raw_entry	aligned like mail_table_raw_entry;

	/*** Entries ***/

	dcl     (
	        cu_$level_get,
	        cu_$level_set
	        )			entry (fixed bin);
	dcl     decode_clock_value_$date_time
				entry (fixed bin (71), fixed bin, fixed bin, fixed bin (35), fixed bin, fixed bin,
				fixed bin (35), fixed bin (35), fixed bin (35), char (3), fixed bin (35));
	dcl     get_ring_		entry () returns (fixed bin (3));
	dcl     hcs_$chname_file	entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     ms_table_mgr_$close	entry (ptr, fixed bin (35));
	dcl     ms_table_mgr_$abs_entry
				entry (ptr, fixed bin (35), char (*), bit (1) aligned, ptr, fixed bin (35),
				fixed bin (35));
	dcl     ms_table_mgr_$create	entry (char (*), char (*), ptr, fixed bin (35));
	dcl     ms_table_mgr_$delete_entry
				entry (ptr, char (*), fixed bin (35));
	dcl     ms_table_mgr_$find_entry
				entry (ptr, char (*), ptr, bit (1) aligned, fixed bin (35), fixed bin (35));
	dcl     ms_table_mgr_$find_entry_case_ins
				entry (ptr, char (*), ptr, bit (1) aligned, fixed bin (35), fixed bin (35));
	dcl     ms_table_mgr_$new_entry
				entry (ptr, char (*), ptr, fixed bin (35));
	dcl     ms_table_mgr_$open	entry (char (*), char (*), char (*) aligned, ptr, ptr, fixed bin (35));
	dcl     ms_table_mgr_$update_entry
				entry (ptr, ptr, fixed bin (35));
	dcl     pathname_		entry (char (*), char (*)) returns (char (168));
	dcl     probe		entry options (variable);
	dcl     set_lock_$lock	entry (bit (36) aligned, fixed bin, fixed bin (35));
	dcl     set_lock_$unlock	entry (bit (36) aligned, fixed bin (35));
	dcl     timer_manager_$sleep	entry (fixed bin (71), bit (2));
	dcl     unique_chars_	entry (bit (*)) returns (char (15));
	dcl     user_info_$login_data entry (char (*), char (*), char (*), fixed bin);

	/*** Constants and Static ***/

	dcl     already_inited	bit (1) int static init ("0"b);
	dcl     anonymous_user	bit (1) int static; /* This is an anonymous process */
	dcl     BIG_NUMBER		fixed bin (17) int static options (constant) init (32767);
	dcl     DEBUGGING		bit (1) int static options (constant) init ("0"b);
	dcl     (
	        error_table_$action_not_performed,
	        error_table_$argerr,
	        error_table_$bad_index,
	        error_table_$bad_subr_arg,
	        error_table_$bigarg,
	        error_table_$checksum_failure,
	        error_table_$id_already_exists,
	        error_table_$id_not_found,
	        error_table_$insufficient_access,
	        error_table_$invalid_lock_reset,
	        error_table_$lock_wait_time_exceeded,
	        error_table_$locked_by_other_process,
	        error_table_$no_record,
	        error_table_$null_info_ptr,
	        error_table_$request_id_ambiguous,
	        error_table_$smallarg,
	        error_table_$unexpected_condition,
	        error_table_$unimplemented_version,
	        mlsys_et_$ambiguous_address,
	        mlsys_et_$bad_mail_table
	        )			fixed bin (35) ext static;
	dcl     LOCK_WAIT_TIME	fixed bin int static options (constant) init (30);
	dcl     MAIL_TABLE_DIR	char (168) int static init ("");
						/* Not constant */
	dcl     MAIL_TABLE_NAME	char (32) int static options (constant) init ("MAIL_TABLE");
	dcl     MAIL_TABLE_TYPE_STRING
				char (32) aligned int static options (constant) init ("mail_table");
	dcl     mlsys_data_$system_directory
				char (168) ext static;
	dcl     mt_ptr		ptr int static init (null ());
						/* -> Mail table structure */
	dcl     mthp		ptr int static init (null ());
						/* -> mail_table_header */
	dcl     my_person_id	char (32) internal static;
	dcl     NO_WRITE		bit (1) aligned internal static options (constant) initial ("0"b);
	dcl     sys_info$max_seg_size fixed bin (19) external static;

	/*** Builtins and Conditions ***/

	dcl     (addr, bool, character, clock, length, maxlength, null, rtrim, size, string, substr)
				builtin;
	dcl     (any_other, cleanup)	condition;
%page;
%include access_mode_values;
%page;
%include acl_structures;
%page;
%include mail_table_entry;
%page;
%include ms_table_info;

/**** Get the user-accessible information from a mail table entry.
      This is the target of the gate mail_table_$get
****/

mail_table_mgr_$get:
     entry (P_id, P_address_ptr, P_acs_path, P_code);

	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	if length (P_id) = 0 then
	     person_id = my_person_id;
	else person_id = P_id;
GET_TRY_AGAIN:
	call get_write_count ();
	call retrieve_real_mte (person_id, "1"b, "1"b, real_mtep);
	call get_address (real_mte, P_address_ptr);
	if real_mte.acs_path.dir = "" then
	     P_acs_path = "";
	else P_acs_path = pathname_ ((real_mte.acs_path.dir), (real_mte.acs_path.entry));
	if mt_modified () then go to GET_TRY_AGAIN;
	call exit_proc ();

/**** This entrypoint is used by normal users to change their mail
      table information.  This is the target of the gate mail_table_$set.
****/

mail_table_mgr_$put:
     entry (P_id, P_address_ptr, P_code);

	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	if P_id = "" then				/* Null-string means self */
	     if anonymous_user then
		call fatal_error (error_table_$action_not_performed);
						/* Anonymous users have no mail table entries */
	     else person_id = my_person_id;
	else person_id = P_id;
	if length (P_id) > maxlength (mail_table_entry.name) then call fatal_error (error_table_$bigarg);
	if P_address_ptr = null () then
	     address = "";				/* Revert to default project */
	else call format_address (P_address_ptr, address);
	call lock_mail_table ();
	call retrieve_real_mte (person_id, "1"b, "1"b, real_mtep);
						/* phx17774, phx21076 RL: get it case-insensitively */
	if real_mte.name ^= my_person_id then call check_acs_access (real_mte.acs_path);
	if ^real_mte.registered_user & P_address_ptr = null () then call fatal_error (error_table_$bad_subr_arg);
						/* Non-users have no default project */
	real_mte.mailing_address = address;
	call update_new_entry (real_mtep);
	call unlock_mail_table ();
	call exit_proc ();

/**** This entrypoint just sets the default project in a mail table
      entry.  It is the target of mail_table_initializer_$set_dft_proj.
****/

mail_table_mgr_$set_dft_proj:
     entry (P_id, P_dft_proj, P_code);

	person_id = P_id;
	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	call lock_mail_table ();
	call retrieve_real_mte (person_id, "0"b, "0"b, real_mtep);
	real_mte.default_project = P_dft_proj;
	call update_new_entry (real_mtep);
	call unlock_mail_table ();
	call exit_proc ();

/**** This entrypoint adds a new entry to the mail table.  It is the
      target of mail_table_priv_$add.
****/

mail_table_mgr_$add:
     entry (P_mte_ptr, P_pnt, P_code);

	new = "1"b;
	go to ADD_UPDATE_COMMON;

/**** This entrypoint updates an existing entry in the mail table.  It is the
      target of mail_table_priv_$update.
****/

mail_table_mgr_$update:
     entry (P_mte_ptr, P_pnt, P_code);

	new = "0"b;

ADD_UPDATE_COMMON:
	pnt = P_pnt;
	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	call check_mtep (P_mte_ptr);
	mail_table_entry_ptr = P_mte_ptr;
	/*** Check for inconsistency ***/
	if
	/*** (pnt & mail_table_entry.default_project = "") |
	     Taken out because there are PNT entries with blank
	     default projects, damn - barmar 9/2/83 ***/
	     (new & ^pnt & mail_table_entry.default_project ^= "") then
	     call fatal_error (error_table_$bad_subr_arg);
	real_mtep = null ();
	call lock_mail_table ();
	if new then do;
	     call make_new_entry (mail_table_entry.name, real_mtep);
	     string (real_mte.flags) = ""b;
	     real_mte.version = MAIL_TABLE_RAW_ENTRY_VERSION_1;
	     real_mte.name, real_mte.primary_name = mail_table_entry.name;
	     real_mte.registered_user = pnt;
	     real_mte.n_names = 1;
	     real_mte.next_name, real_mte.prev_name = "";
	end;
	else do;
	     call retrieve_real_mte (mail_table_entry.name, "1"b, "0"b, real_mtep);
	     if (^pnt & mail_table_entry.default_project ^= real_mte.default_project)
		| (pnt & ^real_mte.registered_user) then
		call fatal_error (error_table_$bad_subr_arg);
	end;
	real_mte.acs_path = mail_table_entry.acs_path;
	real_mte.default_project = mail_table_entry.default_project;
	real_mte.mailing_address = mail_table_entry.mailing_address;
	call update_new_entry (real_mtep);
	call unlock_mail_table ();
	call exit_proc ();

/**** This entrypoint deletes a mail table entry.  It is the target of
      mail_table_priv_$delete.
****/

mail_table_mgr_$delete:
     entry (P_id, P_pnt, P_code);

	pnt = P_pnt;
	person_id = P_id;
	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	call lock_mail_table ();
	call retrieve_real_mte (person_id, "1"b, "0"b, real_mtep);
	if pnt ^= real_mte.registered_user then call fatal_error (error_table_$bad_subr_arg);
	do while (real_mte.next_name ^= "");
	     next_name = real_mte.next_name;
	     call delete_real_mte (real_mte);
	     call retrieve_real_mte (next_name, "0"b, "1"b, real_mtep);
	end;
	call delete_real_mte (real_mte);
	call unlock_mail_table ();
	call exit_proc ();

/**** This entrypoint gets most of the information from a mail table entry,
      in the same structure that is acceptible to mail_table_mgr_$update.
      It is the target of the gate mail_table_priv_$get.
****/

mail_table_mgr_$priv_get:
     entry (P_id, P_mte_ptr, P_code);

	person_id = P_id;
	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	call check_mtep (P_mte_ptr);
	mail_table_entry_ptr = P_mte_ptr;
TRY_PRIV_GET_AGAIN:
	call get_write_count ();
	call retrieve_real_mte (person_id, "1"b, "1"b, real_mtep);
	mail_table_entry.name = real_mte.name;
	mail_table_entry.mailing_address = real_mte.mailing_address;
	mail_table_entry.default_project = real_mte.default_project;
	mail_table_entry.acs_path = real_mte.acs_path;
	if mt_modified () then go to TRY_PRIV_GET_AGAIN;
	call exit_proc ();

/**** This entrypoint returns a copy of the actual structure stored in the
      mail table, after chasing alias links.  It is the target of the gate
      mail_table_priv_$get_raw_by_name.
****/

mail_table_mgr_$get_raw_by_name:
     entry (P_id, P_mtre_ptr, P_code);

	by_number = "0"b;
	by_name_number = "0"b;
	person_id = P_id;
	go to GET_RAW_COMMON;

/**** This is the same as get_raw_by_name, except that it takes an
      index into the mail table array and it does not chase links.
      It is the target of the gate mail_table_priv_$get_raw_by_index.
****/

mail_table_mgr_$get_raw_by_index:
     entry (P_index, P_mtre_ptr, P_code);

	by_number = "1"b;
	by_name_number = "0"b;
	index = P_index;
	go to GET_RAW_COMMON;


/**** This is the same as get_raw_by_index, except that it returns
      only the mail table name without chasing links.  It is the
      target of the gate mail_table_$get_name_by_index.
****/

mail_table_mgr_$get_name_by_index:
     entry (P_index, P_version, P_return_id, P_code);

	by_number = "0"b;
	by_name_number = "1"b;
	index = P_index;

GET_RAW_COMMON:
	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	if by_name_number then do;
	     if P_version ^= MAIL_TABLE_RAW_ENTRY_VERSION_1 then call fatal_error (error_table_$unimplemented_version);
	end;
	else do;
	     call check_mtrep (P_mtre_ptr);
	     mail_table_raw_entry_ptr = P_mtre_ptr;
	end;
TRY_GET_RAW_AGAIN:
	call get_write_count ();
	if by_number | by_name_number then do;
	     call retrieve_real_mte_n (index, real_mtep);
	     if by_name_number then P_return_id = real_mtep -> real_mte.name;
	end;
	else call retrieve_real_mte (person_id, "1"b, "0"b, real_mtep);
	if ^by_name_number then mail_table_raw_entry = real_mte.raw_entry;
	if mt_modified () then go to TRY_GET_RAW_AGAIN;
	call exit_proc ();

/**** This entrypoint adds an alias to an existing entry.
      This is the target of the gate mail_table_priv_$add_alias.
****/

mail_table_mgr_$add_alias:
     entry (P_id, P_alias, P_pnt, P_code);

	pnt = P_pnt;
	person_id = P_id;
	alias = P_alias;
	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	if alias = "" then call fatal_error (error_table_$bad_subr_arg);
	if length (alias) > maxlength (mail_table_entry.name) then call fatal_error (error_table_$bigarg);
	on cleanup call cleanup_proc ();
	call setup ();
	real_mtep, new_mtep = null ();
	call lock_mail_table ();
	call retrieve_real_mte (person_id, "1"b, "1"b, real_mtep);
	if pnt & ^real_mte.registered_user then call fatal_error (error_table_$bad_subr_arg);
	cur_mtep = real_mtep;
	if pnt then
	     do next_name = real_mte.next_name /* If setting the login alias */
		repeat cur_mtep -> real_mte.next_name while (cur_mtep -> real_mte.next_name ^= "");
	     call retrieve_real_mte (next_name, "0"b, "0"b, cur_mtep);
	     if cur_mtep -> real_mte.registered_user then do;
		cur_mtep -> real_mte.registered_user = "0"b;
						/* then turn off the old one */
		go to ADD_THE_ALIAS;
	     end;
	end;
	cur_mtep = null ();				/* Didn't find one */

ADD_THE_ALIAS:
	begin;					/* for on unit */
	     on cleanup
		begin;
		     if new_mtep ^= null () then do;
			call delete_real_mte (new_mtep -> real_mte);
			if pnt & cur_mtep ^= null () /* Fix the old login alias */ then
			     cur_mtep -> real_mte.registered_user = "1"b;
		     end;
		end;
	     call make_new_entry (alias, new_mtep);
	     new_mtep -> real_mte.version = MAIL_TABLE_RAW_ENTRY_VERSION_1;
	     new_mtep -> real_mte.name = alias;
	     new_mtep -> real_mte.primary_name = real_mte.name;
	     string (new_mtep -> real_mte.flags) = "0"b;
	     new_mtep -> real_mte.registered_user = pnt;
	     new_mtep -> real_mte.alias_entry = "1"b;
	     new_mtep -> real_mte.prev_name = "";
	     new_mtep -> real_mte.next_name = real_mte.next_name;
	     /*** Null out the unused components ***/
	     new_mtep -> real_mte.acs_path.dir, new_mtep -> real_mte.acs_path.entry,
		new_mtep -> real_mte.default_project, new_mtep -> real_mte.mailing_address = "";
	     call update_new_entry (new_mtep);
	end;
	if cur_mtep ^= null then call update_new_entry (cur_mtep);
	real_mte.n_names = real_mte.n_names + 1;
	real_mte.next_name = alias;
	call update_new_entry (real_mtep);
	call unlock_mail_table ();
	call exit_proc ();

/**** This entrypoint deletes a specified alias entry.  It is the target
      of the gate mail_table_priv_$delete_alias.
****/

mail_table_mgr_$delete_alias:
     entry (P_alias, P_pnt, P_code);

	pnt = P_pnt;
	alias = P_alias;
	case_insensitive_sw = "0"b;
	go to DELETE_ALIAS_COMMON;

/**** This entrypoint deletes a specified alias entry case-insensitively.
      It is the target of the gate mail_table_priv_$delete_alias_case_ins.
****/

mail_table_mgr_$delete_alias_case_ins:
     entry (P_alias, P_pnt, P_code);

	pnt = P_pnt;
	alias = P_alias;
	case_insensitive_sw = "1"b;

DELETE_ALIAS_COMMON:
	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	call lock_mail_table ();
	call retrieve_real_mte (alias, "0"b, case_insensitive_sw, real_mtep);
	if ^real_mte.alias_entry /* it's not an alias */ | pnt ^= real_mte.registered_user /* wrong entrypoint */ then
	     call fatal_error (error_table_$bad_subr_arg);
	/*** Remove this alias from the chain: only the "forward" chain is maintained */
	call retrieve_real_mte (real_mte.primary_name, "0"b, "0"b, cur_mtep);
	do while (cur_mtep ^= null ());
	     if cur_mtep -> real_mte.next_name = real_mtep -> real_mte.name then do;
		cur_mtep -> real_mte.next_name = real_mtep -> real_mte.next_name;
		call update_new_entry (cur_mtep);
		cur_mtep = null ();			/* rechaining complete */
	     end;
	     else if cur_mtep -> real_mte.next_name = "" then cur_mtep = null ();
						/* chain was broken by an earlier bug */
	     else call retrieve_real_mte (cur_mtep -> real_mte.next_name, "0"b, "0"b, cur_mtep);
	end;
	/*** Now delete the alias' entry */
	person_id = real_mte.primary_name;
	call delete_real_mte (real_mte);
	call retrieve_real_mte (person_id, "0"b, "0"b, real_mtep);
	real_mte.n_names = real_mte.n_names - 1;
	call update_new_entry (real_mtep);
	call unlock_mail_table ();
	call exit_proc ();

/**** This entrypoint lists the aliases for a specified entry.
      It is the target of the gate mail_table_$get_aliases.
****/

mail_table_mgr_$get_aliases:
     entry (P_id, P_version, P_area_ptr, P_mta_ptr, P_code);

	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	if P_version ^= MAIL_TABLE_ALIASES_VERSION_1 then call fatal_error (error_table_$unimplemented_version);
	person_id = P_id;
	if P_area_ptr = null () then call fatal_error (error_table_$null_info_ptr);
TRY_GET_ALIASES_AGAIN:
	call get_write_count ();
	my_area_ptr = P_area_ptr;
	call retrieve_real_mte (person_id, "1"b, "1"b, real_mtep);
	mail_table_aliases_extent = real_mte.n_names;
	call raise_validation ();			/* In case area extends */
	allocate mail_table_aliases in (my_area);
	call lower_validation ();
	mail_table_aliases.version = MAIL_TABLE_ALIASES_VERSION_1;
	do i = 1 to mail_table_aliases.n_names;
	     mail_table_aliases.names (i) = real_mte.name;
	     if real_mte.next_name ^= "" then call retrieve_real_mte (real_mte.next_name, "0"b, "0"b, real_mtep);
	end;
	if mt_modified () then do;
	     free mail_table_aliases in (my_area);
	     go to TRY_GET_ALIASES_AGAIN;
	end;
	P_mta_ptr = mail_table_aliases_ptr;
	call exit_proc ();

/**** This entrypoint just returns the number of mail table entries,
      both primary names and aliases.  It is the target of
      mail_table_priv_$count_entries.
****/

mail_table_mgr_$count_entries:
     entry (P_count, P_code);

	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	P_count = mail_table_header.entry_count;
	call exit_proc ();

/**** This entrypoint creates a mail table of the specified size.
      It is the target of the gate mail_table_priv_$create.
****/

mail_table_mgr_$create_table:
     entry (P_count, P_code);

	dcl     code		fixed bin (35);

	P_code = 0;
	code = 0;
	msti.version = MS_TABLE_INFO_VERSION_3;
	msti.type = MAIL_TABLE_TYPE_STRING;
	msti.header_size = size (mail_table_header);
	msti.entry_size = size (real_mte);
	msti.max_entries = P_count;
	msti.max_size = sys_info$max_seg_size;
	msti.keep_meters = "0"b;			/* Do not keep meters */
	mt_ptr = null ();
	call cu_$level_get (initial_ring);
	on cleanup
	     begin;
		call close_mail_table ();
		call raise_validation ();
	     end;
	on any_other call fatal_create_error (error_table_$unexpected_condition);
	call lower_validation ();
	if MAIL_TABLE_DIR = "" then MAIL_TABLE_DIR = mlsys_data_$system_directory;
	call ms_table_mgr_$create (MAIL_TABLE_DIR, MAIL_TABLE_NAME, addr (msti), code);
	if code ^= 0 then call fatal_create_error (code);
	call open_mail_table ();
	mail_table_header.entry_count = 0;
	mail_table_header.write_lock = ""b;
	mail_table_header.write_count = 0;
	call close_mail_table ();
	call set_mail_table_acl ();
	call raise_validation ();
	revert cleanup;
	go to JUST_EXIT;

/**** This entrypoint sets the directory in which the mail table will be
      found, for use in testing.
      It is the target of the gate mail_table_priv_$test.
****/

mail_table_mgr_$test:
     entry (P_test_dir);

	call close_mail_table ();
	MAIL_TABLE_DIR = P_test_dir;
	return;

/**** This entrypoint copies the mail table, thus freeing up the
      wasted space left from deleted entries.  The code is mostly ripped
      off from the salvage_mstb command.  This is the target of the
      gate mail_table_priv_$salvage.
****/

mail_table_mgr_$salvage:
     entry (P_count, P_message, P_code);

	P_message = "";
	on cleanup call cleanup_proc ();
	on any_other call any_other_proc ();
	call setup ();
	if P_count < mail_table_header.entry_count then do;
	     P_message = "The specified Mail Table size is smaller than the existing number of entries.";
	     call fatal_error (error_table_$smallarg);
	end;
	msti.version = MS_TABLE_INFO_VERSION_3;
	msti.type = MAIL_TABLE_TYPE_STRING;
	msti.header_size = size (mail_table_header);
	msti.entry_size = size (real_mte);
	msti.max_entries = P_count;
	msti.max_size = sys_info$max_seg_size;
	msti.keep_meters = "0"b;			/* Don't keep meters */
	new_name = rtrim (MAIL_TABLE_NAME) || "." || unique_chars_ (""b);
	call ms_table_mgr_$create (MAIL_TABLE_DIR, new_name, addr (msti), code);
	if code ^= 0 then do;
	     P_message = "Creating the new MSTB: " || pathname_ (MAIL_TABLE_DIR, new_name);
	     call fatal_error (code);
	end;
	begin;					/* For on unit */
	     dcl	   nmt_ptr	     ptr;
	     dcl	   nmth_ptr	     ptr;
	     dcl	   1 nmth		     aligned like mail_table_header based (nmth_ptr);

	     nmt_ptr = null ();
	     on cleanup
		begin;
		     if nmt_ptr ^= null () then call ms_table_mgr_$close (nmt_ptr, ignore_code);
		end;
	     call ms_table_mgr_$open (MAIL_TABLE_DIR, new_name, MAIL_TABLE_TYPE_STRING, nmt_ptr, nmth_ptr, code);
	     if code ^= 0 then do;
		P_message = "Opening the new Mail Table: " || pathname_ (MAIL_TABLE_DIR, new_name);
		call fatal_error (code);
	     end;
	     nmth.entry_count = 0;
	     nmth.write_lock = "0"b;
	     nmth.write_count = 0;
	     P_message = "Locking the old Mail Table.";	/* In case the next call gets an error. */
	     call lock_mail_table ();
	     theres_more = "1"b;
	     do entry_num = 1 by 1 while (theres_more);
		call ms_table_mgr_$abs_entry (mt_ptr, entry_num, key, NO_WRITE, real_mtep, ignore_rs, code);
		if code = 0 then do;
		     call ms_table_mgr_$new_entry (nmt_ptr, key, new_mtep, code);
		     if code = 0 then do;
			new_mtep -> real_mte = real_mte;
			nmth.entry_count = nmth.entry_count + 1;
			call ms_table_mgr_$update_entry (nmt_ptr, new_mtep, code);
			if code ^= 0 then goto CREATE_ERROR;
		     end;
		     else if code = error_table_$id_already_exists /* Ignore this */ then code = 0;
		     else do;
CREATE_ERROR:
			P_message = "Creating new entry for the name """ || rtrim (key) || """.";
			call fatal_error (code);
		     end;
		end;
		else if code = error_table_$no_record then code = 0;
						/* Skip unused or deleted entries */
		else if code = error_table_$bad_index then do;
		     theres_more = "0"b;
		     code = 0;
		end;
		else do;
		     P_message = "Reading entry #" || character (entry_num);
		     call fatal_error (code);
		end;
	     end;
	     call ms_table_mgr_$close (nmt_ptr, ignore_code);
	end;					/* of begin block */
	/*** Rename the old and new tables ***/
	call decode_clock_value_$date_time (clock (), month, day, ignore_rs, hour, minute, ignore_rs, ignore_rs,
	     ignore_rs, (""), ignore_code);
	disp_month = month;				/* These are pic(99) vars */
	disp_day = day;
	disp_hour = hour;
	disp_minute = minute;
	new_new_name =
	     /* MAIL_TABLE.MMDDYY.HHMM */ rtrim (MAIL_TABLE_NAME) || "." || disp_month || "/" || disp_day || "."
	     || disp_hour || disp_minute;
	call hcs_$chname_file (MAIL_TABLE_DIR, MAIL_TABLE_NAME, "", new_new_name, code);
	if code ^= 0 then do;
	     P_message =
		"Adding the name " || rtrim (new_new_name) || " to " || pathname_ (MAIL_TABLE_DIR, MAIL_TABLE_NAME);
	     call fatal_error (code);
	end;
	call hcs_$chname_file (MAIL_TABLE_DIR, MAIL_TABLE_NAME, MAIL_TABLE_NAME, "", code);
						/* Get rid of old name */
	if code ^= 0 then do;
	     P_message = "Removing the name " || pathname_ (MAIL_TABLE_DIR, MAIL_TABLE_NAME);
	     call fatal_error (code);
	end;
	call unlock_mail_table ();
	call close_mail_table ();			/* Close the old one */
	call hcs_$chname_file (MAIL_TABLE_DIR, new_name, new_name, MAIL_TABLE_NAME, code);
						/* and put it on new table */
	if code ^= 0 then do;
	     P_message = "Renaming " || pathname_ (MAIL_TABLE_DIR, new_name) || " to " || MAIL_TABLE_NAME;
	     call fatal_error (code);
	end;
	call set_mail_table_acl ();
	call exit_proc ();

%skip (10);
/**** Come to this page when exiting (either through exit_proc or fatal_error)
****/

GLOBAL_EXIT:
	call cleanup_proc ();
JUST_EXIT:					/* For when we die during error handling */
	return;

	/*** INTERNAL SUBROUTINES ***/

raise_validation:
     proc ();

	call cu_$level_set (initial_ring);
	return;

     end raise_validation;

lower_validation:
     proc ();

	call cu_$level_get (initial_ring);
	call cu_$level_set ((get_ring_ ()));
	return;

     end lower_validation;

setup:
     proc ();

	mail_table_locked = "0"b;
	already_in_fatal_error = "0"b;
	call lower_validation ();
	if ^already_inited then do;
	     call user_info_$login_data (my_person_id, (""), (""), anon);
	     if anon = 1 then
		anonymous_user = "1"b;
	     else anonymous_user = "0"b;
	     if MAIL_TABLE_DIR = "" then MAIL_TABLE_DIR = mlsys_data_$system_directory;
	     call open_mail_table ();
	     already_inited = "1"b;
	end;
	return;

     end setup;

cleanup_proc:
     proc ();

	call unlock_mail_table ();
	call raise_validation ();
	return;

     end cleanup_proc;

any_other_proc:
     proc ();

	call fatal_error (mlsys_et_$bad_mail_table);

     end any_other_proc;

/**** Use this for normal exit ***/
exit_proc:
     proc ();

	P_code = 0;
	go to GLOBAL_EXIT;

     end exit_proc;

fatal_create_error:
     proc (P_fe_code);

	dcl     P_fe_code		fixed bin (35);

	P_code = P_fe_code;
	if DEBUGGING then call probe ();
	go to JUST_EXIT;

     end fatal_create_error;

fatal_error:
     proc (P_fe_code);

	dcl     P_fe_code		fixed bin (35);

	P_code = P_fe_code;
	if DEBUGGING then call probe ();
	if already_in_fatal_error /* recursive error */ then
	     go to JUST_EXIT;			/* ... and don't do anything else */
	else do;
	     already_in_fatal_error = "1"b;
	     go to GLOBAL_EXIT;
	end;

     end fatal_error;

open_mail_table:
     proc ();

	dcl     code		fixed bin (35);

	code = 0;
	if mt_ptr ^= null () then return;
	call ms_table_mgr_$open (MAIL_TABLE_DIR, MAIL_TABLE_NAME, MAIL_TABLE_TYPE_STRING, mt_ptr, mthp, code);
	if code ^= 0 then call fatal_error (code);

	return;

     end open_mail_table;

close_mail_table:
     proc ();

	dcl     code		fixed bin (35);

	code = 0;
	already_inited = "0"b;
	if mt_ptr = null () then return;		/* Already closed */
	call ms_table_mgr_$close (mt_ptr, code);
	if code ^= 0 then call fatal_error (code);
	mt_ptr = null ();
	return;

     end close_mail_table;

lock_mail_table:
     proc ();

	dcl     code		fixed bin (35);

	mail_table_locked = "1"b;
	code = 0;
	call set_lock_$lock (mail_table_header.write_lock, LOCK_WAIT_TIME, code);
	if code ^= 0 then
	     if code ^= error_table_$invalid_lock_reset then do;
		mail_table_locked = "0"b;
		call fatal_error (code);
	     end;
	if mail_table_header.write_count = BIG_NUMBER then
	     mail_table_header.write_count = 0;
	else mail_table_header.write_count = mail_table_header.write_count + 1;
	return;

     end lock_mail_table;

unlock_mail_table:
     proc ();

	dcl     code		fixed bin (35);

	if ^mail_table_locked then return;
	code = 0;
	call set_lock_$unlock (mail_table_header.write_lock, code);
	if code ^= 0 & code ^= error_table_$locked_by_other_process then call fatal_error (code);
	mail_table_locked = "0"b;
	return;

     end unlock_mail_table;

get_write_count:
     proc ();

	dcl     code		fixed bin (35);
	dcl     temp_lock		bit (36) aligned;

	original_time = clock ();
GET_COUNT_AGAIN:
	code = 0;
	original_write_count = mail_table_header.write_count;
	temp_lock = mail_table_header.write_lock;	/* We may not be able to modify the real lock */
	call set_lock_$lock (temp_lock, 0, code);
	if code ^= 0 then
	     if code = error_table_$lock_wait_time_exceeded then do;
						/* It was locked, so wait */
		if too_long () then call fatal_error (error_table_$lock_wait_time_exceeded);
		call timer_manager_$sleep (1, "11"b);	/* Sleep for 1 second */
		go to GET_COUNT_AGAIN;
	     end;
	     else if code ^= error_table_$invalid_lock_reset then call fatal_error (code);
	if mt_modified () then go to GET_COUNT_AGAIN;
	return;

     end get_write_count;

mt_modified:
     proc () returns (bit (1));

	if mail_table_header.write_count = original_write_count then return ("0"b);
	else if too_long () then			/* We've been trying for too long */
	     call fatal_error (error_table_$lock_wait_time_exceeded);
	else return ("1"b);

     end mt_modified;

too_long:
     proc () returns (bit (1));

	return (clock () - original_time > LOCK_WAIT_TIME * 1e6);

     end too_long;

make_new_entry:
     proc (P_id, P_real_mtep);

	dcl     P_id		char (*) varying;
	dcl     P_real_mtep		ptr;		/* Output -> real_mte */

	dcl     code		fixed bin (35);
	dcl     person_id		char (32);
	dcl     rmte_ptr		ptr;		/* -> new entry */

	code = 0;
	person_id = P_id;
	rmte_ptr = null ();
	call ms_table_mgr_$new_entry (mt_ptr, person_id, rmte_ptr, code);
	if code ^= 0 then call fatal_error (code);
	mail_table_header.entry_count = mail_table_header.entry_count + 1;
	P_real_mtep = rmte_ptr;
	return;

     end make_new_entry;

update_new_entry:
     procedure (P_real_mtep);

	dcl     P_real_mtep		ptr parameter;
	dcl     rmte_ptr		ptr;
	dcl     code		fixed bin (35);

	rmte_ptr = P_real_mtep;
	call ms_table_mgr_$update_entry (mt_ptr, rmte_ptr, code);
	if code ^= 0 then call fatal_error (code);
	P_real_mtep = null ();			/* Just to make sure no one updates without telling ms_table_mgr_ */
	return;
     end update_new_entry;

delete_real_mte:
     proc (P_real_mte);

	dcl     1 P_real_mte	aligned like real_mte;

	dcl     code		fixed bin (35);
	dcl     person_id		char (32);

	code = 0;
	person_id = P_real_mte.name;
	call ms_table_mgr_$delete_entry (mt_ptr, person_id, code);
	if code ^= 0 then call fatal_error (code);
	mail_table_header.entry_count = mail_table_header.entry_count - 1;
	return;

     end delete_real_mte;

retrieve_real_mte:
     proc (P_id, P_chase, P_case_ins, P_real_mtep);

	dcl     P_case_ins		bit (1) parameter;	/* Try case insensitive */
	dcl     P_chase		bit (1) parameter;	/* Chase alias links */
	dcl     P_id		char (*) varying parameter;
						/* Name of entry to retrieve */
	dcl     P_real_mtep		ptr parameter;	/* Output ptr to entry */
	dcl     code		fixed bin (35);
	dcl     name		char (32);
	dcl     person_id		char (32);	/* Non-varying name */
	dcl     1 rmte		aligned like real_mte based (rmtep);
	dcl     rmtep		ptr;

	code = 0;
	P_real_mtep = null ();
	person_id = P_id;
	call ms_table_mgr_$find_entry (mt_ptr, person_id, rmtep, NO_WRITE, ignore_rs, code);
	if code = error_table_$checksum_failure then code = 0;
	if code ^= 0 then
	     /*** Look for case insensitive match ***/
	     if P_case_ins & code = error_table_$id_not_found then do;
		code = 0;
		call ms_table_mgr_$find_entry_case_ins (mt_ptr, person_id, rmtep, NO_WRITE, ignore_rs, code);
		if code = error_table_$checksum_failure then code = 0;
		if code = error_table_$request_id_ambiguous then call fatal_error (mlsys_et_$ambiguous_address);
		if code ^= 0 then call fatal_error (code);
	     end;
	     else call fatal_error (code);
	if P_chase & rmte.alias_entry then do;
	     name = rmte.primary_name;
	     call ms_table_mgr_$find_entry (mt_ptr, name, rmtep, NO_WRITE, ignore_rs, code);
	     if code = error_table_$checksum_failure then code = 0;
	     if code ^= 0 then call fatal_error (code);
	end;
	P_real_mtep = rmtep;
	return;

     end retrieve_real_mte;

retrieve_real_mte_n:
     proc (P_index, P_real_mtep);

	dcl     P_index		fixed bin parameter;
	dcl     P_real_mtep		ptr parameter;

	dcl     index		fixed bin (35);
	dcl     rmtep		ptr;

	code = 0;
	P_real_mtep = null ();
	index = P_index;
	call ms_table_mgr_$abs_entry (mt_ptr, index, (""), NO_WRITE, rmtep, ignore_rs, code);
	if code ^= 0 then call fatal_error (code);
	P_real_mtep = rmtep;
	return;

     end retrieve_real_mte_n;

get_address:
     proc (P_mte, P_address);

	dcl     1 P_mte		aligned like real_mte;
	dcl     P_address		ptr;

	dcl     code		fixed bin (35);
	dcl     mail_system_$create_user_mailbox_address
				entry (char (*) var, char (*) var, char (*) var, ptr, fixed bin (35));
	dcl     mlsys_utils_$parse_address_text
				entry (char (*), ptr, fixed bin (35));

	code = 0;
	P_address = null ();
	if P_mte.registered_user & P_mte.mailing_address = "" then
	     call mail_system_$create_user_mailbox_address (P_mte.name || "." || P_mte.default_project, "", "",
		P_address, code);

	else call mlsys_utils_$parse_address_text ((P_mte.mailing_address), P_address, code);
	if code ^= 0 then call fatal_error (code);
	return;
     end get_address;

format_address:
     proc (P_address, P_string);

	dcl     P_address		ptr;
	dcl     P_string		char (*) varying;

	dcl     buffer		char (256);
	dcl     buffer_used		fixed bin (21);
	dcl     code		fixed bin (35);

	dcl     mlsys_utils_$format_address_field
				entry (char (*) var, ptr, fixed bin, ptr, fixed bin (21), fixed bin (21),
				fixed bin (35));

	code = 0;
	P_string = "";
	buffer_used = 0;
	call mlsys_utils_$format_address_field ("", P_address, -1, addr (buffer), length (buffer), buffer_used, code);
	if code = error_table_$smallarg then /* buffer is not large enough */ call fatal_error (error_table_$bigarg);
						/* means address is too big */
	if code ^= 0 then call fatal_error (code);
	P_string = substr (buffer, 1, buffer_used);
	return;
     end format_address;

check_acs_access:
     proc (P_path);

	dcl     1 P_path		aligned like mail_table_raw_entry.acs_path;
	dcl     hcs_$get_user_access_modes
				entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
				bit (36) aligned, fixed bin (35));
	dcl     code		fixed bin (35);
	dcl     modes		bit (36) aligned;

	code = 0;
	if P_path.dir = "" then call fatal_error (error_table_$insufficient_access);
						/* Noone has access to nonexistent ACS */
	call hcs_$get_user_access_modes ((P_path.dir), (P_path.entry), "", initial_ring, modes, (""b), code);
	if code ^= 0 | bool (modes, RW_ACCESS, "0100"b) then call fatal_error (error_table_$insufficient_access);
	return;

     end check_acs_access;

check_mtep:
     proc (P_mtep);

	dcl     P_mtep		ptr parameter;

	if P_mtep = null () then call fatal_error (error_table_$null_info_ptr);
	if P_mtep -> mail_table_entry.version ^= MAIL_TABLE_ENTRY_VERSION_1 then
	     call fatal_error (error_table_$unimplemented_version);
	return;

     end check_mtep;

check_mtrep:
     proc (P_mtrep);

	dcl     P_mtrep		ptr parameter;

	if P_mtrep = null () then call fatal_error (error_table_$null_info_ptr);
	if P_mtrep -> mail_table_raw_entry.version ^= MAIL_TABLE_RAW_ENTRY_VERSION_1 then
	     call fatal_error (error_table_$unimplemented_version);
	if P_mtrep -> mail_table_raw_entry.mbz ^= ""b /* MUST be zero */ then
	     call fatal_error (error_table_$bad_subr_arg);
	return;

     end check_mtrep;

set_mail_table_acl:
     proc ();

	dcl     code		fixed bin (35);
	dcl     fcb_ptr		ptr;
	dcl     1 mt_acl		aligned like segment_acl_entry;
	dcl     msf_manager_$open	entry (char (*), char (*), ptr, fixed bin (35));
	dcl     msf_manager_$close	entry (ptr);
	dcl     msf_manager_$acl_replace
				entry (ptr, ptr, fixed bin, bit (1), fixed bin (35));

	fcb_ptr = null ();
	code = 0;
	on cleanup
	     begin;
		if fcb_ptr ^= null () then call msf_manager_$close (fcb_ptr);
	     end;
	call msf_manager_$open (MAIL_TABLE_DIR, MAIL_TABLE_NAME, fcb_ptr, code);
	if code ^= 0 then call fatal_create_error (code);
	mt_acl.access_name = "*.*.*";
	mt_acl.mode = RW_ACCESS;
	mt_acl.extended_mode = ""b;
	mt_acl.status_code = 0;
	call msf_manager_$acl_replace (fcb_ptr, addr (mt_acl), 1, "1"b, code);
	if code ^= 0 & code ^= error_table_$argerr then call fatal_create_error (code);
	if mt_acl.status_code ^= 0 then call fatal_create_error (mt_acl.status_code);
	call msf_manager_$close (fcb_ptr);
	return;

     end set_mail_table_acl;

     end mail_table_mgr_;




		    mlsys_address_list_mgr_.pl1     06/30/86  1410.2r w 06/30/86  1343.8      217341



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *********************************************************** */

/* format: off */

/* Address list management for the Multics Mail System */

/* Created:  May 1981 by G. Palter */
/* Modified: 3 September 1981 by G. Palter to special case empty address lists in cv_address_list_to_* */
/* Modified: July 1983 by G. Palter to convert to new mail system specification */
/* Modified: 6 March 1984 by G. Palter to fix error #0422 -- mail_system_$free_address_list may damage the mail system's
      internal storage if called with a pointer to an already freed address list */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen,^indcomtxt */


mlsys_address_list_mgr_:
     procedure () options (rename ((alloc_, mlsys_storage_mgr_$allocate)));

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_address_list_ptr pointer parameter;
dcl  P_code fixed binary (35) parameter;

dcl  P_address_list_version character (8) parameter;	/* create_*_address_list, add_address_*: version of
						      address_list structure desired by the caller */

dcl  P_new_address_list_ptr pointer parameter;		/* copy_address_list: set -> copy of old address list;
						   merge_address_lists_*: set -> merger of input lists */

dcl  P_old_address_list_ptr pointer parameter;		/* copy_address_list -> address list to be copied */

dcl  P_address_list_1_ptr pointer parameter;		/* merge_address_lists_*: -> first list to be merged */
dcl  P_address_list_2_ptr pointer parameter;		/* merge_address_lists_*: -> second list to be merged */
dcl  P_eliminate_duplicates bit (1) aligned parameter;	/* merge_address_lists_*: ON => eliminate duplicate addresses
						      from the merged list */

dcl  P_address_ptr pointer parameter;			/* add_address_*, replace_address_*: -> the new address */

dcl  P_address_position fixed binary parameter;		/* delete_address_*, replace_address_*: identifies which
						      address in the address_list to delete/replace */
/**** format: indcomtxt */


/* Local copies of parameters */

dcl  address_list_ptr_as_array (1) pointer aligned based (addr (address_list_ptr));

dcl  (old_address_list_ptr, address_list_1_ptr, address_list_2_ptr, new_address_list_ptr) pointer;

dcl  address_ptr pointer;


/* Definition of the reserved data in the address_list structure */

dcl  1 address_list_reserved_data aligned based (addr (address_list.reserved)),
       2 n_addresses_allocated fixed binary,		/* actual # of address slots available in the structure */
       2 reference_count fixed binary,			/* # of mail system objects which are using this list */
       2 flags,
         3 read_only bit (1) unaligned,			/* ON => user may not modify this address list */
         3 user_freeable bit (1) unaligned,		/* ON => user may free this list no matter the type */
         3 pad bit (34) unaligned;


/* Remaining declarations */

dcl  read_only_address_list bit (1) aligned;		/* whether to create a read-only to user-ring address list */
dcl  user_freeable_address_list bit (1) aligned;		/* whether to allow user-ring to free it anyway */

dcl  increment_reference_counts bit (1) aligned;

dcl  (idx, jdx) fixed binary;

/* format: off */
dcl (error_table_$bad_index, error_table_$bad_subr_arg, error_table_$unimplemented_version, mlsys_et_$empty_address_list,
     mlsys_et_$not_address_list, mlsys_et_$read_only_address_list)
	fixed binary (35) external;
/* format: on */

dcl  mlsys_address_mgr_$decrement_reference_count entry (pointer);
dcl  mlsys_address_mgr_$increment_reference_count entry (pointer);
dcl  mlsys_address_mgr_$verify_address entry (pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mlsys_transmit_$eliminate_duplicate_addrs entry ((*) pointer, fixed binary (35));

dcl  (addr, baseno, binary, mod, null, string) builtin;
%page;
/* Create an empty address list */

create_read_only_address_list:			/* ... writeable only by the mail system */
     entry (P_address_list_version, P_address_list_ptr, P_code);

	read_only_address_list = "1"b;
	user_freeable_address_list = "0"b;
	go to CREATE_ADDRESS_LIST_COMMON;


create_user_freeable_address_list:			/* ... not writeable by user-ring but can be freed there */
     entry (P_address_list_version, P_address_list_ptr, P_code);

	read_only_address_list, user_freeable_address_list = "1"b;
	go to CREATE_ADDRESS_LIST_COMMON;


create_writeable_address_list:			/* ... writeable by the user: target of the user-ring gate */
     entry (P_address_list_version, P_address_list_ptr, P_code);

	read_only_address_list = "0"b;
	user_freeable_address_list = "1"b;


CREATE_ADDRESS_LIST_COMMON:
	if P_address_list_version ^= ADDRESS_LIST_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	address_list_n_addresses = mlsys_data_$address_list_allocation;
						/* allows some room for the first few addresses */

	allocate address_list in (mlsys_area) set (address_list_ptr);

	address_list.version = ADDRESS_LIST_VERSION_2;

	address_list_reserved_data.n_addresses_allocated = address_list_n_addresses;
	address_list.n_addresses = 0;			/* the list is empty */

	address_list_reserved_data.reference_count = 0;	/* nothing has referenced this list yet */

	string (address_list_reserved_data.flags) = ""b;
	address_list_reserved_data.read_only = read_only_address_list;
	address_list_reserved_data.user_freeable = user_freeable_address_list;

	P_address_list_ptr = address_list_ptr;		/* give it to the caller */
	P_code = 0;				/* success */

	return;
%page;
/* Convert the supplied address list into a read-only address list: used to prevent the user from modifying an address
   list once it is being used by a message */

set_read_only:
     entry (P_address_list_ptr);

	address_list_ptr = copy_ptr (P_address_list_ptr);

	address_list_reserved_data.read_only = "1"b;
	address_list_reserved_data.user_freeable = "0"b;

	return;



/* Free an address list if its reference count is zero (ie: if no other mail system object has a pointer to this list) */

free_address_list:					/* ... any type of address list */
     entry (P_address_list_ptr, P_code);

	if ^verify_address_list (P_address_list_ptr, P_code) then return;
	go to FREE_ADDRESS_LIST_COMMON;


free_address_list_writeable:				/* ... only if the user-ring can free it */
     entry (P_address_list_ptr, P_code);

	if ^verify_writeable_address_list (P_address_list_ptr, P_code) then return;


FREE_ADDRESS_LIST_COMMON:
	address_list_ptr = copy_ptr (P_address_list_ptr);
	P_address_list_ptr = null ();			/* insure the caller doesn't use it anymore */

	if address_list_reserved_data.reference_count <= 0 then do;
	     do idx = 1 to address_list.n_addresses;
		call mlsys_address_mgr_$decrement_reference_count (address_list.addresses (idx));
	     end;					/* no longer interested in the addresses */
	     free address_list in (mlsys_area);
	end;

	P_code = 0;				/* success */

	return;
%page;
/* Increment the reference count of an address list: to avoid the user accidently freeing an address list structure which
   is in use by other parts of the mail system (eg: references within a message or certain types of addresses) */

increment_reference_count:
     entry (P_address_list_ptr);

	address_list_ptr = P_address_list_ptr;

	address_list_reserved_data.reference_count = address_list_reserved_data.reference_count + 1;

	return;



/* Decrement the reference count of an address list:  If the reference count reaches zero, nothing in the mail system is
   using this address list any longer and its storage is released */

decrement_reference_count:
     entry (P_address_list_ptr);

	address_list_ptr = P_address_list_ptr;

	address_list_reserved_data.reference_count = address_list_reserved_data.reference_count - 1;

	if address_list_reserved_data.reference_count <= 0 then call free_address_list (P_address_list_ptr, (0));

	P_address_list_ptr = null ();			/* keep the caller from using it anymore */

	return;
%page;
/* Copy an address list: always creates a user-ring modifiable address list */

copy_address_list:
     entry (P_old_address_list_ptr, P_new_address_list_ptr, P_code);

	if ^verify_address_list (P_old_address_list_ptr, P_code) then return;
	old_address_list_ptr = copy_ptr (P_old_address_list_ptr);

	address_list_n_addresses =			/* use same # of slots as the original list */
	     addr (old_address_list_ptr -> address_list.reserved) -> address_list_reserved_data.n_addresses_allocated;

	allocate address_list in (mlsys_area) set (address_list_ptr);

	address_list.version = ADDRESS_LIST_VERSION_2;
	address_list_reserved_data.n_addresses_allocated = address_list_n_addresses;
	address_list_reserved_data.reference_count = 0;	/* nothing has reference this list yet */
	string (address_list_reserved_data.flags) = ""b;	/* turns off read-only flag: user can always modify ... */
	address_list_reserved_data.user_freeable = "1"b;	/* ... an address list created by this entrypoint */

	address_list.n_addresses = old_address_list_ptr -> address_list.n_addresses;

	do idx = 1 to address_list.n_addresses;
	     address_list.addresses (idx) = old_address_list_ptr -> address_list.addresses (idx);
	     call mlsys_address_mgr_$increment_reference_count (address_list.addresses (idx));
	end;

	P_new_address_list_ptr = address_list_ptr;	/* success */
	P_code = 0;

	return;
%page;
/* Merge two address lists: optionally eliminate any duplicate addresses in the resulting list; the output may replace
   either of the input lists if desired */

merge_address_lists:				/* ... writeable only by the mail system */
     entry (P_address_list_1_ptr, P_address_list_2_ptr, P_eliminate_duplicates, P_new_address_list_ptr, P_code);

	read_only_address_list = "1"b;
	go to MERGE_ADDRESS_LISTS_COMMON;


merge_address_lists_writeable:			/* ... writeable by the user: target of the user-ring gate */
     entry (P_address_list_1_ptr, P_address_list_2_ptr, P_eliminate_duplicates, P_new_address_list_ptr, P_code);

	read_only_address_list = "0"b;


MERGE_ADDRESS_LISTS_COMMON:
	address_list_1_ptr = copy_ptr (P_address_list_1_ptr);
	address_list_2_ptr = copy_ptr (P_address_list_2_ptr);


/* Validate the input arguments:  Insure that all non-null address_list_ptr's do indeed reference address_list strucutres,
   that the caller is not attempting to merge 3 lists simultaneously, and, if invoked via the mail_system_ gate, that the
   user-ring may modify the output address_list structure */

	if address_list_1_ptr ^= null () then		/* it's OK for an input list to not be present */
	     if ^verify_address_list (address_list_1_ptr, P_code) then return;

	if address_list_2_ptr ^= null () then
	     if ^verify_address_list (address_list_2_ptr, P_code) then return;

	if P_new_address_list_ptr ^= null () then do;	/* must be one of the input lists ... */
	     if (addr (P_new_address_list_ptr) ^= addr (P_address_list_1_ptr))
		& (addr (P_new_address_list_ptr) ^= addr (P_address_list_2_ptr)) then do;
		P_code = error_table_$bad_subr_arg;
		return;
	     end;
	     if ^read_only_address_list then		/* ... furthermore it must be modifiable by the user-ring */
		if ^verify_writeable_address_list (P_new_address_list_ptr, P_code) then return;
	end;

	if empty_address_list (address_list_1_ptr) & empty_address_list (address_list_2_ptr) then do;
	     P_code = mlsys_et_$empty_address_list;	/* they can't both be empty lists */
	     return;
	end;


/* Supplied input arguments are OK: perform the merger */

	if address_list_1_ptr = null () then		/* compute the number of addresses needed in the new list */
	     address_list_n_addresses = 0;
	else address_list_n_addresses = address_list_1_ptr -> address_list.n_addresses;

	if address_list_2_ptr ^= null () then		/* some addresses from the second list also */
	     address_list_n_addresses = address_list_n_addresses + address_list_2_ptr -> address_list.n_addresses;

	address_list_n_addresses =			/* room for expansion please ... */
	     address_list_n_addresses + mlsys_data_$address_list_allocation
	     - mod (address_list_n_addresses, mlsys_data_$address_list_allocation);

	allocate address_list in (mlsys_area) set (address_list_ptr);

	address_list.version = ADDRESS_LIST_VERSION_2;
	address_list_reserved_data.n_addresses_allocated = address_list_n_addresses;
	address_list.n_addresses = 0;			/* the list is empty */
	address_list_reserved_data.reference_count = 0;	/* nothing has referenced this list yet */
	string (address_list_reserved_data.flags) = ""b;
	address_list_reserved_data.read_only = read_only_address_list;
	address_list_reserved_data.user_freeable = ^read_only_address_list;

	if addr (P_new_address_list_ptr) = addr (P_address_list_1_ptr) then do;
						/* new list is going to replace the first list ... */
	     increment_reference_counts = "0"b;		/* ... don't change address reference counts */
	     if address_list_1_ptr ^= null () then do;	/* ... and copy the internal data if present */
		address_list.reserved = address_list_1_ptr -> address_list.reserved;
		address_list_reserved_data.n_addresses_allocated = address_list_n_addresses;
	     end;					/* ... but don't lose the size of the new list */
	end;
	else increment_reference_counts = "1"b;		/* new list: will have to bump address reference counts */

	if address_list_1_ptr ^= null () then do;	/* have some addresses to be copied into the new list ... */
	     do idx = 1 to address_list_1_ptr -> address_list.n_addresses;
		address_list.n_addresses, jdx = address_list.n_addresses + 1;
		address_list.addresses (jdx) = address_list_1_ptr -> address_list.addresses (idx);
		if increment_reference_counts then	/* ... another new reference for this address */
		     call mlsys_address_mgr_$increment_reference_count (address_list.addresses (jdx));
	     end;
	end;

	if addr (P_new_address_list_ptr) = addr (P_address_list_2_ptr) then do;
						/* new list is going to replace the second list ... */
	     increment_reference_counts = "0"b;		/* ... don't change address reference counts */
	     if address_list_2_ptr ^= null () then do;	/* ... and copy the internal data if present */
		address_list.reserved = address_list_2_ptr -> address_list.reserved;
		address_list_reserved_data.n_addresses_allocated = address_list_n_addresses;
	     end;					/* ... but don't lose the size of the new list */
	end;
	else increment_reference_counts = "1"b;		/* new list: will have to bump address reference counts */

	if address_list_2_ptr ^= null () then do;	/* have some addresses to be copied into the new list ... */
	     do idx = 1 to address_list_2_ptr -> address_list.n_addresses;
		address_list.n_addresses, jdx = address_list.n_addresses + 1;
		address_list.addresses (jdx) = address_list_2_ptr -> address_list.addresses (idx);
		if increment_reference_counts then	/* ... another new reference for this address */
		     call mlsys_address_mgr_$increment_reference_count (address_list.addresses (jdx));
	     end;
	end;

	if P_eliminate_duplicates then		/* get rid of any duplicates in the list */
	     call mlsys_transmit_$eliminate_duplicate_addrs (address_list_ptr_as_array, (0));

	if P_new_address_list_ptr ^= null () then do;	/* get rid of the old list we are replacing */
	     new_address_list_ptr = copy_ptr (P_new_address_list_ptr);
	     free new_address_list_ptr -> address_list in (mlsys_area);
	end;

	P_new_address_list_ptr = address_list_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Add an address to the given address list, expanding the list by reallocation if necessary */

add_address:					/* ... writeable only by the mail system */
     entry (P_address_list_ptr, P_address_ptr, P_address_list_version, P_code);

	read_only_address_list = "1"b;		/* ... in case we must create the list */
	go to ADD_ADDRESS_COMMON;


add_address_writeable:				/* ... writeable by the user: target of the user-ring gate */
     entry (P_address_list_ptr, P_address_ptr, P_address_list_version, P_code);

	read_only_address_list = "0"b;


ADD_ADDRESS_COMMON:
	if ^mlsys_address_mgr_$verify_address (P_address_ptr, P_code) then return;
	address_ptr = copy_ptr (P_address_ptr);

	if P_address_list_ptr = null () then do;	/* need to create an address_list */
	     if read_only_address_list then
		call create_read_only_address_list (P_address_list_version, address_list_ptr, P_code);
	     else call create_writeable_address_list (P_address_list_version, address_list_ptr, P_code);
	     if P_code ^= 0 then return;		/* ... must be that the caller gave us the wrong version */
	end;
	else do;					/* use the already created address_list */
	     if read_only_address_list then		/* ... verify it using the appropriate criteria */
		if ^verify_address_list (P_address_list_ptr, P_code) then
		     return;
		else ;				/* ... a valid read-only address_list */
	     else if ^verify_writeable_address_list (P_address_list_ptr, P_code) then return;
	     address_list_ptr = copy_ptr (P_address_list_ptr);
	end;

	if address_list.n_addresses = address_list_reserved_data.n_addresses_allocated then do;
						/* must reallocate the list */
	     address_list_n_addresses =		/* ... plus some room to grow */
		address_list.n_addresses + mlsys_data_$address_list_allocation;
	     allocate address_list in (mlsys_area) set (new_address_list_ptr);
	     new_address_list_ptr -> address_list.version = ADDRESS_LIST_VERSION_2;
	     new_address_list_ptr -> address_list.reserved = address_list.reserved;
	     addr (new_address_list_ptr -> address_list.reserved) -> address_list_reserved_data.n_addresses_allocated =
		address_list_n_addresses;
	     new_address_list_ptr -> address_list.n_addresses = address_list.n_addresses;
	     do idx = 1 to address_list.n_addresses;	/* ... copy the addresses */
		new_address_list_ptr -> address_list.addresses (idx) = address_list.addresses (idx);
	     end;
	     free address_list in (mlsys_area);		/* ... get rid of the old one */
	     address_list_ptr = new_address_list_ptr;	/* ... this is now the address list */
	end;

	address_list.n_addresses, idx = address_list.n_addresses + 1;
						/* increment # of addresses present */

	address_list.addresses (idx) = address_ptr;	/* add it to the list ... */
	call mlsys_address_mgr_$increment_reference_count (address_ptr);
						/* ... and remember that we care about it */

	P_address_list_ptr = address_list_ptr;		/* in case we've changed it */
	P_code = 0;				/* success */

	return;
%page;
/* Delete an address from the given address list */

delete_address:					/* ... writeable only by the mail system */
     entry (P_address_list_ptr, P_address_position, P_code);

	if ^verify_address_list (P_address_list_ptr, P_code) then return;
	go to DELETE_ADDRESS_COMMON;


delete_address_writeable:				/* ... writeable by the user: target of the user-ring gate */
     entry (P_address_list_ptr, P_address_position, P_code);

	if ^verify_writeable_address_list (P_address_list_ptr, P_code) then return;


DELETE_ADDRESS_COMMON:
	address_list_ptr = copy_ptr (P_address_list_ptr); /* internal procedure uses the "standard" address list */

	if (P_address_position < 1) | (P_address_position > address_list.n_addresses) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	call delete_the_address (P_address_position);	/* do the work */

	P_code = 0;				/* success */

	return;



/* Actually delete the specified address from the address list (called by several entrypoints) */

delete_the_address:
     procedure (p_address_position);

dcl  p_address_position fixed binary parameter;
dcl  idx fixed binary;

	call mlsys_address_mgr_$decrement_reference_count (address_list.addresses (p_address_position));
						/* forget about the one being deleted */

	do idx = (p_address_position + 1) to address_list.n_addresses;
	     address_list.addresses (idx - 1) = address_list.addresses (idx);
	end;					/* move the others down so no vacate slots remain */

	address_list.n_addresses = address_list.n_addresses - 1;

	return;

     end delete_the_address;
%page;
/* Replace the specified address in an address list with a different address */

replace_address:					/* ... writeable only by the mail system */
     entry (P_address_list_ptr, P_address_position, P_address_ptr, P_code);

	if ^verify_address_list (P_address_list_ptr, P_code) then return;
	go to REPLACE_ADDRESS_COMMON;


replace_address_writeable:				/* ... writeable by the user: target of the user-ring gate */
     entry (P_address_list_ptr, P_address_position, P_address_ptr, P_code);

	if ^verify_writeable_address_list (P_address_list_ptr, P_code) then return;


REPLACE_ADDRESS_COMMON:
	if ^mlsys_address_mgr_$verify_address (P_address_ptr, P_code) then return;

	address_list_ptr = copy_ptr (P_address_list_ptr);
	address_ptr = copy_ptr (P_address_ptr);

	if (P_address_position < 1) | (P_address_position > address_list.n_addresses) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	idx = P_address_position;			/* always wise to copy parameters ... */

	call mlsys_address_mgr_$decrement_reference_count (address_list.addresses (idx));
						/* forget about the one being replaced */

	address_list.addresses (idx) = address_ptr;	/* put in the new one ... */
	call mlsys_address_mgr_$increment_reference_count (address_list.addresses (idx));
						/* ... and make a note that we care about it */

	P_code = 0;				/* success */

	return;
%page;
/* Verify that the caller supplied a pointer to a properly constructed address_list structure */

verify_address_list:
     entry (P_address_list_ptr, P_code) returns (bit (1) aligned);

	return (verify_address_list (P_address_list_ptr, P_code));



/* Actually verifies that the caller supplied an address list structure */

verify_address_list:
     procedure (p_address_list_ptr, p_code) returns (bit (1) aligned);

dcl  p_address_list_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;

	if p_address_list_ptr = null () then p_code = mlsys_et_$not_address_list;

	else if ^mlsys_data_$valid_segments (binary (baseno (p_address_list_ptr), 18, 0)) then
	     p_code = mlsys_et_$not_address_list;	/* supplied structure wasn't allocated by us */

	else if p_address_list_ptr -> address_list.version ^= ADDRESS_LIST_VERSION_2 then
	     p_code = mlsys_et_$not_address_list;	/* not an address_list structure */

	else p_code = 0;				/* supplied structure passes all tests */

	return ((p_code = 0));

     end verify_address_list;
%page;
/* Verify that the caller supplied a pointer to a properly constructed address_list structure which may be modified by
   user-ring software via the mail_system_ gate */

verify_writeable_address_list:
     entry (P_address_list_ptr, P_code) returns (bit (1) aligned);

	return (verify_writeable_address_list (P_address_list_ptr, P_code));



/* Actually verifies that the caller supplied a writeable address list structure */

verify_writeable_address_list:
     procedure (p_address_list_ptr, p_code) returns (bit (1) aligned);

dcl  p_address_list_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;

	if ^verify_address_list (p_address_list_ptr, p_code) then ;
						/* not an address_list */

	else if addr (p_address_list_ptr -> address_list.reserved) -> address_list_reserved_data.read_only then
	     p_code = mlsys_et_$read_only_address_list;	/* not an address_list which the user-ring can modify */

	else p_code = 0;				/* supplied structure passes all tests */

	return ((p_code = 0));

     end verify_writeable_address_list;
%page;
/* Determine if the given address list is empty */

empty_address_list:
     procedure (p_address_list_ptr) returns (bit (1) aligned);

dcl  p_address_list_ptr pointer parameter;

	if p_address_list_ptr = null () then
	     return ("1"b);

	else return ((p_address_list_ptr -> address_list.n_addresses = 0));

     end empty_address_list;
%page;
%include mlsys_copy_ptr;
%page;
%include mlsys_address_list;
%page;
%include mlsys_internal_data;

     end mlsys_address_list_mgr_;




		    mlsys_address_mgr_.pl1          06/30/86  1410.2r w 06/30/86  1343.8      688302



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* format: off */

/* Address management for the Multics Mail System */

/* Created:  May 1981 by G. Palter */
/* Recoded:  July 1983 by G. Palter as part of the new mail system interface */
/* Modified: March 1984 by G. Palter to fix the following mail system errors:
      #0420 -- the mail system doesn't translate error_table_$no_component into mlsys_et_$no_address_list
      #0428 -- during initialization, the mail system extracts the user's full name from the default default value segment
         (>udd>Project>Person>Person.value) rather than the current default value segment as set by value_set_path
      #0429 -- mail_system_$create_savebox_address should not create a logbox address when given the pathname of the
         user's logbox.  Similarly, mail_system_$create_mailbox_address should not create a savebox address when given
         the pathname of a savebox
      #0436 -- if a forum meeting is not found in the "forum" search list, the mail system will treat it as a version 1
         meeting in the working directory */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


mlsys_address_mgr_:
     procedure () options (rename ((alloc_, mlsys_storage_mgr_$allocate)));

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_address_ptr pointer parameter;
dcl  P_code fixed binary (35) parameter;

dcl  P_default_mailbox_address pointer parameter;		/* values returned by the get_address_constants entrypoint */
dcl  P_mail_table_address pointer parameter;		/* ... */
dcl  P_logbox_address pointer parameter;		/* ... */

dcl  P_address_name character (*) varying parameter;	/* the address name of the address */
dcl  P_address_comment character (*) varying parameter;	/* the address comment */

dcl  P_address_string character (*) varying parameter;	/* the string portion of an address (User_id, etc.) */

dcl  P_address_dirname character (*) parameter;		/* an address pathname's component parts ... */
dcl  P_address_ename character (*) parameter;		/* ... */
dcl  P_address_component character (*) parameter;		/* ... */

dcl  P_foreign_system character (256) varying parameter;	/* the foreign system on which the address resides */
dcl  P_address_route_ptr pointer parameter;		/* -> an explicit/implicit route associated with an address */

dcl  P_address_list_ptr pointer parameter;		/* -> the address list which is the address expansion */
dcl  P_display_list bit (1) aligned parameter;		/* ON => show the list in printed representation of address */

dcl  P_address_type fixed binary parameter;		/* set to the type of the given address */

dcl  P_address_route_version character (8) parameter;	/* version of address_route structure expected by caller */

dcl  P_address_1_ptr pointer parameter;			/* -> an address to be compared */
dcl  P_address_2_ptr pointer parameter;			/* ... */

dcl  P_mail_table_address_ptr pointer parameter;		/* set -> address found in the mail table */

dcl  P_address_list_version character (8) parameter;	/* version of address_list structure desired when expanding */


/* Local copies of parameters */

dcl  code fixed binary (35);

dcl  (address_1_ptr, address_2_ptr) pointer;

dcl  mail_table_address_ptr pointer;


/* Remaining declarations */

dcl  mls_text character (mls_lth) unaligned based (mls_ptr);
dcl  mls_ptr pointer;
dcl  mls_bitcount fixed binary (24);
dcl  mls_lth fixed binary (21);

dcl  comparison_result bit (1) aligned;
dcl  (address_1_dirname, address_2_dirname) character (168);
dcl  (address_1_ename, address_2_ename) character (32);
dcl  suffixless_forum_ename character (26);		/* longest valid meeting name */
dcl  (address_1_mte_address_ptr, address_2_mte_address_ptr) pointer;
dcl  (address_1_route_ptr, address_2_route_ptr) pointer;
dcl  (address_1_mls_ptr, address_2_mls_ptr) pointer;
dcl  (address_list_1_ptr, address_list_2_ptr) pointer;
dcl  (mailbox_1_uid, mailbox_2_uid) bit (36) aligned;
dcl  partial_comparison_result bit (1) aligned;
dcl  (code_1, code_2) fixed binary (35);
dcl  (forum_1_index, forum_2_index) fixed binary;
dcl  (idx, jdx) fixed binary;

dcl  current_mtle_ptr pointer;			/* used to resolve recusive mail table entries */

dcl  ANONYMOUS character (9) static options (constant) initial ("anonymous");

dcl  NULL_STRING character (1) static options (constant) initial ("");

/* format: off */
dcl (LOWERCASE	initial ("abcdefghijklmnopqrstuvwxyz"),
     UPPERCASE	initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
	character (26) static options (constant);

dcl (error_table_$entlong, error_table_$id_not_found, error_table_$no_component, error_table_$noentry,
     error_table_$smallarg, error_table_$unimplemented_version, mlsys_et_$circular_mtes, mlsys_et_$incorrect_suffix,
     mlsys_et_$mte_not_found, mlsys_et_$no_address_pathname, mlsys_et_$no_address_route, mlsys_et_$no_address_string,
     mlsys_et_$no_mailing_list, mlsys_et_$not_address, mlsys_et_$not_foreign_address, mlsys_et_$not_list_address,
     mlsys_et_$not_mail_table_address, mlsys_et_$not_named_group_address, mlsys_et_$null_foreign_address,
     mlsys_et_$null_named_group_name, mlsys_et_$unknown_system)
	fixed binary (35) external;
/* format: on */

dcl  forum_$close_forum entry (fixed binary, fixed binary (35));
dcl  forum_$open_forum entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  initiate_file_$component
	entry (character (*), character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl  mail_table_$get entry (character (*) varying, pointer, character (*), fixed binary (35));
dcl  mailbox_$get_uid_file entry (character (*), character (*), bit (36) aligned, fixed binary (35));
dcl  mlsys_address_list_mgr_$create_user_freeable_address_list entry (character (8), pointer, fixed binary (35));
dcl  mlsys_address_list_mgr_$decrement_reference_count entry (pointer);
dcl  mlsys_address_list_mgr_$free_address_list entry (pointer, fixed binary (35));
dcl  mlsys_address_list_mgr_$increment_reference_count entry (pointer);
dcl  mlsys_address_list_mgr_$verify_address_list entry (pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mlsys_address_route_mgr_$compute_optimum_route entry (pointer, pointer, fixed binary (35));
dcl  mlsys_address_route_mgr_$create_address_route entry ((*) character (256) varying, pointer);
dcl  mlsys_address_route_mgr_$decrement_reference_count entry (pointer);
dcl  mlsys_address_route_mgr_$free_address_route entry (pointer);
dcl  mlsys_address_route_mgr_$increment_reference_count entry (pointer);
dcl  mlsys_nit_interface_$get_fully_qualified_name entry (character (256) varying) returns (character (256) varying);
dcl  mlsys_parse_text_$parse_address_text entry (character (*), pointer, fixed binary (35));
dcl  mlsys_parse_text_$parse_mailing_list_text entry (character (*), character (8), pointer, fixed binary (35));
dcl  mlsys_psp_$forum_not_available entry () returns (bit (1) aligned);
dcl  mlsys_user_mte_syntax_$validate_mte_name entry (character (*) varying, fixed binary (35));
dcl  mlsys_user_mte_syntax_$validate_person_id entry (character (*) varying, fixed binary (35));
dcl  mlsys_user_mte_syntax_$validate_user_id
	entry (character (*) varying, character (*) varying, character (*) varying, fixed binary (35));
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));

dcl  cleanup condition;

dcl  (addr, baseno, binary, divide, index, length, maxlength, null, reverse, rtrim, size, string, translate) builtin;
%page;
/* Definitions of the various types of addresses used by the Multics mail system */

dcl  address_ptr pointer;				/* all following structures are based on this pointer */

%include mlsys_address_types;

dcl  WAS_FOREIGN_ADDRESS initial (-1)			/* identifies an address which was a foreign address but was
						   converted into a local address during validation */
	fixed binary static options (constant);


/* Standard header present in all addresses */

dcl  1 address_header aligned based (address_ptr),
       2 version character (8) unaligned,
       2 type fixed binary,				/* type of address (see above) */
       2 reference_count fixed binary,			/* # of address lists and messages referencing this address */
       2 name,					/* the address name */
         3 name_ptr pointer,
         3 name_lth fixed binary (21),
       2 comment,					/* the address comment */
         3 comment_ptr pointer,
         3 comment_lth fixed binary (21),
       2 flags,
         3 never_free bit (1) unaligned,		/* ON => don't free this address even if ref count is zero */
         3 free_name bit (1) unaligned,			/* ON => free the address name when freeing the address */
         3 free_comment bit (1) unaligned,		/* ON => free the address comment when freeing the address */
         3 pad bit (33) unaligned;

dcl  ADDRESS_VERSION_2 character (8) static options (constant) initial ("mlsaddr2");

dcl  address_name character (address_header.name_lth) unaligned based (address_header.name_ptr);

dcl  address_comment character (address_header.comment_lth) unaligned based (address_header.comment_ptr);
%page;
/* Address comparison dispatch table: referenced by both address types */

/* format: off */
dcl  COMPARISON_OPERATIONS (0:9, 0:9) fixed binary static options (constant) initial (
	 0, -1, -1, -1, -1, -1, -1, -1, -1, -1,		/* invalid address */
	-1,  1,  1,  1,  1, -1, -1, -1, -1, -1,		/* user mailbox address */
	-1,  1,  1,  1,  1, -1, -1, -1, -1, -1,		/* logbox address */
	-1,  1,  1,  1,  1, -1, -1, -1, -1, -1,		/* savebox address */
	-1,  1,  1,  1,  1, -1, -1, -1, -1, -1,		/* mailbox address */
	-1, -1, -1, -1, -1,  2, -1, -1, -1, -1,		/* forum address */
	-1, -1, -1, -1, -1, -1,  3, -1, -1, -1,		/* foreign address */
	-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,		/* mail table address (never used) */
	-1, -1, -1, -1, -1, -1, -1, -1,  4,  5,		/* mailing list address */
	-1, -1, -1, -1, -1, -1, -1, -1,  5,  5);	/* named group address */
/* format: on */
%page;
/* format: ^indcomtxt */

/* WAS_FOREGIN_ADDRESS:  When a foreign address is created, the mail system does not actually validate that the address
   is, indeed, an off-site address.  Therefore, it is possible to create a "foreign" address for what is, in fact, a local
   address.  When the address is finally validated, the mail system will create the proper address and convert the foreign
   address into a was-foreign address.	The was-foreign address serves as a place holder in the various messages, address
   lists, etc. that already had a pointer to the foreign address */

dcl  1 was_foreign_address aligned based (address_ptr),
       2 header like address_header,
       2 actual_address_ptr pointer,			/* -> the actual local address into which it was converted */
       2 unused (size (foreign_address) - size (address_header) - size (address_ptr)) bit (36);


/* INVALID_ADDRESS: is used by the mail system to represent a text string which could not be converted into one of the
   other, standard addresses.	 It is used when parsing old-style ring-1 messages and, optionally, when requested by
   user-ring applications which allow users to create message headers (eg: "qedx -header" in send_mail) */

dcl  1 invalid_address aligned based (address_ptr),
       2 header like address_header,
       2 text,					/* the text which could not be parsed */
         3 text_ptr pointer,
         3 text_lth fixed binary (21),
       2 flags,
         3 free_text bit (1) unaligned,			/* ON => free the invalid text when freeing this address */
         3 pad bit (35) unaligned;

dcl  invalid_address_text character (invalid_address.text_lth) unaligned based (invalid_address.text_ptr);


/* Common portion of all addresses which reference one of a specific user's mailboxes (default mailbox/logbox/savebox) */

dcl  1 user_address_template aligned based (address_ptr),
       2 header like address_header,
       2 person_id character (32) varying,		/* the user's Person_id ... */
       2 project_id character (32) varying,		/* ... and Project_id */
       2 flags,
         3 is_anonymous bit (1) unaligned,		/* ON => this is the address of an anonymous user's mailbox */
         3 pad bit (35) unaligned;


/* USER_MAILBOX_ADDRESS: identifies a user's default mailbox.  The pathname of a user's default mailbox is:
	>udd>Project_id>Person_id>Person_id.mbx */

dcl  1 user_mailbox_address aligned based (address_ptr),
       2 user like user_address_template;


/* LOGBOX_ADDRESS: identifies a user's logbox.  The pathname of a user's logbox is:
	>udd>Project_id>Person_id>Person_id.sv.mbx */

dcl  1 logbox_address aligned based (address_ptr),
       2 user like user_address_template;


/* SAVEBOX_ADDRESS: identifies one of a user's saveboxes by pathname */

dcl  1 savebox_address aligned based (address_ptr),
       2 user like user_address_template,
       2 mbx_dirname character (168) unaligned,		/* pathname of directory containing the savebox */
       2 mbx_ename character (32) unaligned;		/* entryname of the savebox including "sv.mbx" suffix */


/* MAILBOX_ADDRESS: identifies an arbitrary mailbox by pathname */

dcl  1 mailbox_address aligned based (address_ptr),
       2 header like address_header,
       2 mbx_dirname character (168) unaligned,		/* pathname of directory containing the mailbox */
       2 mbx_ename character (32) unaligned;		/* entryname of the mailbox including "mbx" suffix */


/* FORUM_ADDRESS: identifies an arbitrary forum meeting by pathname */

dcl  1 forum_address aligned based (address_ptr),
       2 header like address_header,
       2 forum_dirname character (168) unaligned,		/* pathname of directory containing the meeting */
       2 forum_ename character (32) unaligned;		/* entryname of meeting including "control"/"forum" suffix */


/* FOREIGN_ADDRESS: identifies a user (or group of user) on another computer system */

dcl  1 foreign_address aligned based (address_ptr),
       2 header like address_header,
       2 local_part,				/* the name of the user/entity on the foreign system */
         3 local_part_ptr pointer,
         3 local_part_lth fixed binary (21),
       2 foreign_system character (256) varying,		/* the name of the foreign system */
       2 explicit_route pointer,			/* -> optional explicit route given by a user */
       2 implicit_route pointer,			/* -> an implicit route also associated with this address */
       2 flags,
         3 free_local_part bit (1) unaligned,		/* ON => free the local part text when freeing the address */
         3 pad bit (35) unaligned;

dcl  foreign_address_local_part character (foreign_address.local_part_lth) unaligned
	based (foreign_address.local_part_ptr);


/* MAIL_TABLE_ADDRESS: identifies an entry in the system-wide mail table which provides a translation between an arbitrary
   character string (usually a user's Person_id) and a mail system address */

dcl  1 mail_table_address aligned based (address_ptr),
       2 header like address_header,
       2 mte_name character (32) varying;		/* the name of the entry in the mail table */


/* MAILING_LIST_ADDRESS: identifies an arbitrary mailing list by pathname.  A mailing list may be an archive component in
   addition to a segment and is an ASCII file containing the printed representations of one or more addresses to which
   mail is to be sent whenever mail is sent to the mailing list */

dcl  1 mailing_list_address aligned based (address_ptr),
       2 header like address_header,
       2 mls_dirname character (168) unaligned,		/* pathname of the directory containing the mailing list */
       2 mls_ename character (32) unaligned,		/* entryname of the mailing list or containing archive */
       2 mls_component character (32) unaligned;		/* component name of the list including "mls" suffix */


/* NAMED_GROUP_ADDRESS: identifies a named group of addresses.  A named group is different from a mailing list in that it
   is intended to be a temporary grouping and, as such, does not have a permanent form (eg: segment/archive component) */

dcl  1 named_group_address aligned based (address_ptr),
       2 header like address_header,
       2 address_list pointer,			/* -> to the address list itself */
       2 flags,
         3 display_list bit (1) unaligned,		/* ON => include actual list in the printed representation */
         3 pad bit (35) unaligned;

/* format: indcomtxt */
%page;
/* Protect the supplied address from being accidentaly freed (used for the mlsys_data_$*_address variables) */

protect_address:
     entry (P_address_ptr);

	P_address_ptr -> address_header.never_free = "1"b;

	return;



/* Return the three address constants created in the mail system's ring to the caller:  These "constants" represent the
   user's default mailbox, mail table, and logbox addresses */

get_users_addresses:
     entry (P_default_mailbox_address, P_mail_table_address, P_logbox_address);

	P_default_mailbox_address = mlsys_data_$user_default_mailbox_address;

	P_mail_table_address = mlsys_data_$user_mail_table_address;

	P_logbox_address = mlsys_data_$user_logbox_address;

	return;



/* Set the full name for the user's default mailbox and mail table addresses */

set_users_full_name:
     entry (P_address_name);

	if mlsys_data_$user_default_mailbox_address -> user_mailbox_address.name_lth = 0 then
	     call set_address_variable_string (P_address_name,
		mlsys_data_$user_default_mailbox_address -> user_mailbox_address.name,
		mlsys_data_$user_default_mailbox_address -> user_mailbox_address.free_name);

	if mlsys_data_$user_mail_table_address -> mail_table_address.name_lth = 0 then
	     call set_address_variable_string (P_address_name,
		mlsys_data_$user_mail_table_address -> mail_table_address.name,
		mlsys_data_$user_mail_table_address -> mail_table_address.free_name);

	return;
%page;
/* Create an invalid address */

create_invalid_address:
     entry (P_address_string, P_address_name, P_address_comment, P_address_ptr, P_code);

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (INVALID_ADDRESS);

	call set_address_variable_string (P_address_string, invalid_address.text, invalid_address.free_text);

	call set_address_variable_string (P_address_name, invalid_address.name, invalid_address.free_name);
	call set_address_variable_string (P_address_comment, invalid_address.comment, invalid_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Create a user default mailbox address */

create_user_mailbox_address:
     entry (P_address_string, P_address_name, P_address_comment, P_address_ptr, P_code);

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (USER_MAILBOX_ADDRESS);

	call mlsys_user_mte_syntax_$validate_user_id (P_address_string, user_mailbox_address.person_id,
	     user_mailbox_address.project_id, code);
	if code ^= 0 then do;			/* invalid syntax */
BAD_USER_MAILBOX_ADDRESS:
	     call free_address (address_ptr, (0));
	     P_code = code;
	     return;
	end;

	if user_mailbox_address.person_id = ANONYMOUS then do;
	     user_mailbox_address.is_anonymous = "1"b;
	     if P_address_name ^= "" then do;		/* this must be the anonymous user's Person_id */
		call mlsys_user_mte_syntax_$validate_person_id (P_address_name, code);
		if code ^= 0 then go to BAD_USER_MAILBOX_ADDRESS;
		user_mailbox_address.person_id = P_address_name;
	     end;
	end;

	else if (user_mailbox_address.person_id = mlsys_data_$person_id)
		& (user_mailbox_address.project_id = mlsys_data_$project_id) & mlsys_data_$user_is_anonymous then
	     user_mailbox_address.is_anonymous = "1"b;

	else call set_address_variable_string (P_address_name, user_mailbox_address.name,
		user_mailbox_address.free_name);

	call set_address_variable_string (P_address_comment, user_mailbox_address.comment,
	     user_mailbox_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Create a logbox address */

create_logbox_address:
     entry (P_address_string, P_address_name, P_address_comment, P_address_ptr, P_code);

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (LOGBOX_ADDRESS);

	call mlsys_user_mte_syntax_$validate_user_id (P_address_string, logbox_address.person_id,
	     logbox_address.project_id, code);
	if code ^= 0 then do;			/* invalid syntax */
BAD_LOGBOX_ADDRESS:
	     call free_address (address_ptr, (0));
	     P_code = code;
	     return;
	end;

	if logbox_address.person_id = ANONYMOUS then do;
	     logbox_address.is_anonymous = "1"b;
	     if P_address_name ^= "" then do;		/* this must be the anonymous user's Person_id */
		call mlsys_user_mte_syntax_$validate_person_id (P_address_name, code);
		if code ^= 0 then go to BAD_LOGBOX_ADDRESS;
		logbox_address.person_id = P_address_name;
	     end;
	end;

	else if (logbox_address.person_id = mlsys_data_$person_id)
		& (logbox_address.project_id = mlsys_data_$project_id) & mlsys_data_$user_is_anonymous then
	     logbox_address.is_anonymous = "1"b;

	else call set_address_variable_string (P_address_name, logbox_address.name, logbox_address.free_name);

	call set_address_variable_string (P_address_comment, logbox_address.comment, logbox_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Create a savebox address */

create_savebox_address:
     entry (P_address_string, P_address_dirname, P_address_ename, P_address_name, P_address_comment, P_address_ptr,
	P_code);

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (SAVEBOX_ADDRESS);

	call mlsys_user_mte_syntax_$validate_user_id (P_address_string, savebox_address.person_id,
	     savebox_address.project_id, code);
	if code ^= 0 then do;			/* invalid syntax */
BAD_SAVEBOX_ADDRESS:
	     call free_address (address_ptr, (0));
	     P_code = code;
	     return;
	end;

	savebox_address.mbx_dirname = P_address_dirname;

	if validate_entryname (P_address_ename, ".sv.mbx", savebox_address.mbx_ename, code) then
	     savebox_address.mbx_ename = P_address_ename;
	else go to BAD_SAVEBOX_ADDRESS;

	if savebox_address.person_id = ANONYMOUS then do;
	     savebox_address.is_anonymous = "1"b;
	     if P_address_name ^= "" then do;		/* this must be the anonymous user's Person_id */
		call mlsys_user_mte_syntax_$validate_person_id (P_address_name, code);
		if code ^= 0 then go to BAD_SAVEBOX_ADDRESS;
		savebox_address.person_id = P_address_name;
	     end;
	end;

	else if (savebox_address.person_id = mlsys_data_$person_id)
		& (savebox_address.project_id = mlsys_data_$project_id) & mlsys_data_$user_is_anonymous then
	     savebox_address.is_anonymous = "1"b;

	else call set_address_variable_string (P_address_name, savebox_address.name, savebox_address.free_name);

	call set_address_variable_string (P_address_comment, savebox_address.comment, savebox_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Create a mailbox address */

create_mailbox_address:
     entry (P_address_dirname, P_address_ename, P_address_name, P_address_comment, P_address_ptr, P_code);

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (MAILBOX_ADDRESS);

	mailbox_address.mbx_dirname = P_address_dirname;

	if validate_entryname (P_address_ename, ".mbx", mailbox_address.mbx_ename, code) then
	     mailbox_address.mbx_ename = P_address_ename;
	else do;					/* something's wrong with the entry name */
	     call free_address (address_ptr, (0));
	     P_code = code;
	     return;
	end;

	call set_address_variable_string (P_address_name, mailbox_address.name, mailbox_address.free_name);
	call set_address_variable_string (P_address_comment, mailbox_address.comment, mailbox_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Create a forum address */

create_forum_address:
     entry (P_address_dirname, P_address_ename, P_address_name, P_address_comment, P_address_ptr, P_code);

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (FORUM_ADDRESS);

	forum_address.forum_dirname = P_address_dirname;

	if validate_entryname (P_address_ename, ".control", forum_address.forum_ename, code)
	     | validate_entryname (P_address_ename, ".forum", forum_address.forum_ename, code) then
	     forum_address.forum_ename = P_address_ename;

	else if mlsys_psp_$forum_not_available () | (forum_address.forum_dirname = "") then
	     /*** no Forum PSP or making an address for a meeting not found in the search list ... */
	     if validate_entryname (P_address_ename, "", suffixless_forum_ename, code) then
		forum_address.forum_ename = P_address_ename;
	     else go to BAD_FORUM_ADDRESS;

	else do;					/* something's wrong with the entry name */
	     if validate_entryname (P_address_ename, "", suffixless_forum_ename, code) then
		code = mlsys_et_$incorrect_suffix;
BAD_FORUM_ADDRESS:
	     call free_address (address_ptr, (0));
	     P_code = code;
	     return;
	end;

	call set_address_variable_string (P_address_name, forum_address.name, forum_address.free_name);
	call set_address_variable_string (P_address_comment, forum_address.comment, forum_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Create a foreign address */

create_foreign_address:
     entry (P_address_string, P_foreign_system, P_address_route_ptr, P_address_name, P_address_comment, P_address_ptr,
	P_code);

	if P_address_string = "" then do;		/* can't allow a null local part */
	     P_code = mlsys_et_$null_foreign_address;
	     return;
	end;

	if P_foreign_system = "" then do;		/* can't allow a null system name */
	     P_code = mlsys_et_$unknown_system;
	     return;
	end;

	if P_address_route_ptr ^= null () then		/* check for proper version ... */
	     if P_address_route_ptr -> address_route.version ^= ADDRESS_ROUTE_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (FOREIGN_ADDRESS);

	call set_address_variable_string (P_address_string, foreign_address.local_part, foreign_address.free_local_part)
	     ;

	if P_address_route_ptr = null () then		/* we should know the foreign system name */
	     foreign_address.foreign_system = mlsys_nit_interface_$get_fully_qualified_name (P_foreign_system);
	else foreign_address.foreign_system = translate (P_foreign_system, UPPERCASE, LOWERCASE);

	if P_address_route_ptr ^= null () then do;	/* user has supplied an explicit route ... */
	     address_route_ptr = copy_ptr (P_address_route_ptr);
						/* ... for following call to work ... */
	     call mlsys_address_route_mgr_$create_address_route (address_route.relays, foreign_address.explicit_route);
	     call mlsys_address_route_mgr_$increment_reference_count (foreign_address.explicit_route);
	end;

	call set_address_variable_string (P_address_name, foreign_address.name, foreign_address.free_name);
	call set_address_variable_string (P_address_comment, foreign_address.comment, foreign_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Create a mail table address */

create_mail_table_address:
     entry (P_address_string, P_address_name, P_address_comment, P_address_ptr, P_code);

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (MAIL_TABLE_ADDRESS);

	call mlsys_user_mte_syntax_$validate_mte_name (P_address_string, code);
	if code ^= 0 then do;
	     call free_address (address_ptr, (0));
	     P_code = code;
	     return;
	end;

	mail_table_address.mte_name = P_address_string;
	call set_address_variable_string (P_address_name, mail_table_address.name, mail_table_address.free_name);
	call set_address_variable_string (P_address_comment, mail_table_address.comment,
	     mail_table_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Create a mailing list address */

create_mailing_list_address:
     entry (P_address_dirname, P_address_ename, P_address_component, P_address_name, P_address_comment, P_address_ptr,
	P_code);

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (MAILING_LIST_ADDRESS);	/* sets mls_component to a null string */

	mailing_list_address.mls_dirname = P_address_dirname;

	if P_address_component = "" then		/* mailing list is in a segment */
	     if validate_entryname (P_address_ename, ".mls", mailing_list_address.mls_ename, code) then
		mailing_list_address.mls_ename = P_address_ename;
	     else do;				/* something's wrong with the entry/component name */
BAD_MAILING_LIST_ADDRESS:
		call free_address (address_ptr, (0));
		P_code = code;
		return;
	     end;

	else do;					/* mailing list is in an archive component */
	     if validate_entryname (P_address_ename, ".archive", mailing_list_address.mls_ename, code) then do;
		mailing_list_address.mls_ename = P_address_ename;
		if validate_entryname (P_address_component, ".mls", mailing_list_address.mls_component, code) then
		     mailing_list_address.mls_component = P_address_component;
	     end;
	     if code ^= 0 then go to BAD_MAILING_LIST_ADDRESS;
	end;

	call set_address_variable_string (P_address_name, mailing_list_address.name, mailing_list_address.free_name);
	call set_address_variable_string (P_address_comment, mailing_list_address.comment,
	     mailing_list_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Create a named group address */

create_named_group_address:
     entry (P_address_name, P_address_list_ptr, P_display_list, P_address_comment, P_address_ptr, P_code);

	if ^mlsys_address_list_mgr_$verify_address_list (P_address_list_ptr, P_code) then return;

	if P_address_name = "" then do;		/* can't be a blank name */
	     P_code = mlsys_et_$null_named_group_name;
	     return;
	end;

	address_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call free_address (address_ptr, (0));
	     end;

	call initialize_address (NAMED_GROUP_ADDRESS);

	named_group_address.address_list = copy_ptr (P_address_list_ptr);
	call mlsys_address_list_mgr_$increment_reference_count (named_group_address.address_list);

	named_group_address.display_list = P_display_list;

	call set_address_variable_string (P_address_name, named_group_address.name, named_group_address.free_name);
	call set_address_variable_string (P_address_comment, named_group_address.comment,
	     named_group_address.free_comment);

	P_address_ptr = address_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Free an address if its reference count is zero (ie: if no other mail system object has a pointer to this address) */

free_address:
     entry (P_address_ptr, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	address_ptr = copy_ptr (P_address_ptr);
	P_address_ptr = null ();			/* insure that the caller doesn't use it anymore */

	P_code = 0;				/* indicates that this call has succeeded */

	if address_header.never_free | (address_header.reference_count > 0) then return;
						/* someone's still using it */

	if address_header.free_name then		/* the address name was allocated simultaneously */
	     free address_name in (mlsys_area);
	if address_header.free_comment then free address_comment in (mlsys_area);

	go to FREE_ADDRESS (address_header.type);

FREE_ADDRESS (-1):					/* was-foreign address */
	call decrement_reference_count (was_foreign_address.actual_address_ptr);
	free was_foreign_address in (mlsys_area);	/* above call probably will free the real address */
	return;

FREE_ADDRESS (0):					/* invalid address */
	if invalid_address.free_text then		/* we allocated this text when we created the address */
	     free invalid_address_text in (mlsys_area);
	free invalid_address in (mlsys_area);
	return;

FREE_ADDRESS (1):					/* user mailbox address */
	free user_mailbox_address in (mlsys_area);
	return;

FREE_ADDRESS (2):					/* logbox address */
	free logbox_address in (mlsys_area);
	return;

FREE_ADDRESS (3):					/* savebox address */
	free savebox_address in (mlsys_area);
	return;

FREE_ADDRESS (4):					/* mailbox address */
	free mailbox_address in (mlsys_area);
	return;

FREE_ADDRESS (5):					/* forum address */
	free forum_address in (mlsys_area);
	return;

FREE_ADDRESS (6):					/* foreign address */
	if foreign_address.free_local_part then		/* the local part was allocated simultaneously */
	     free foreign_address_local_part in (mlsys_area);
	if foreign_address.explicit_route ^= null () then
	     call mlsys_address_route_mgr_$decrement_reference_count (foreign_address.explicit_route);
	if foreign_address.implicit_route ^= null () then
	     call mlsys_address_route_mgr_$decrement_reference_count (foreign_address.implicit_route);
	free foreign_address in (mlsys_area);
	return;

FREE_ADDRESS (7):					/* mail table address */
	free mail_table_address in (mlsys_area);
	return;

FREE_ADDRESS (8):					/* mailing list address */
	free mailing_list_address in (mlsys_area);
	return;

FREE_ADDRESS (9):					/* named group address */
	call mlsys_address_list_mgr_$decrement_reference_count (named_group_address.address_list);
	free named_group_address in (mlsys_area);
	return;
%page;
/* Increment the reference count of an address: to avoid the user accidently freeing an address which is in use by other
   parts of the mail system (eg: references within a message, an address list, or another address) */

increment_reference_count:
     entry (P_address_ptr);

	P_address_ptr -> address_header.reference_count = P_address_ptr -> address_header.reference_count + 1;

	return;



/* Decrement the reference count of an address:  If the reference count reaches zero, nothing in the mail system is using
   this address any longer and its storage is released */

decrement_reference_count:
     entry (P_address_ptr);

	P_address_ptr -> address_header.reference_count = P_address_ptr -> address_header.reference_count - 1;

	if (P_address_ptr -> address_header.reference_count <= 0) & ^P_address_ptr -> address_header.never_free then
	     call free_address (P_address_ptr, (0));

	P_address_ptr = null ();			/* keep the caller from using it anymore */

	return;



/* Decrement the reference count of an address but do not free it when the reference count reaches zero */

decrement_reference_count_no_free:
     entry (P_address_ptr);

	P_address_ptr -> address_header.reference_count = P_address_ptr -> address_header.reference_count - 1;

	P_address_ptr = null ();			/* keep the caller from using it anymore */

	return;
%page;
/* Return the type of the given address */

get_address_type:
     entry (P_address_ptr, P_address_type, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	P_address_type = address_header.type;
	P_code = 0;				/* success */

	return;



/* Return the character string associated with the given address, if any:  The address string has various interpretations
   dependent on the address type (eg: User_id, foreign user/entity name, etc.) */

get_address_string:
     entry (P_address_ptr, P_address_string, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	go to GET_ADDRESS_STRING (address_header.type);

GET_ADDRESS_STRING (0):				/* invalid address */
	call set_output_variable (invalid_address_text, P_address_string, P_code);
	return;

GET_ADDRESS_STRING (1):				/* user mailbox address */
GET_ADDRESS_STRING (2):				/* logbox address */
GET_ADDRESS_STRING (3):				/* savebox address */
	if user_address_template.is_anonymous then
	     call set_output_variable ((ANONYMOUS || "." || user_address_template.project_id), P_address_string, P_code)
		;
	else call set_output_variable ((user_address_template.person_id || "." || user_address_template.project_id),
		P_address_string, P_code);
	return;

GET_ADDRESS_STRING (4):				/* mailbox address */
GET_ADDRESS_STRING (5):				/* forum address */
	P_code = mlsys_et_$no_address_string;
	return;

GET_ADDRESS_STRING (6):				/* foreign address */
	call set_output_variable (foreign_address_local_part, P_address_string, P_code);
	return;

GET_ADDRESS_STRING (7):				/* mail table address */
	call set_output_variable ((mail_table_address.mte_name), P_address_string, P_code);
	return;

GET_ADDRESS_STRING (8):				/* mailing list address */
GET_ADDRESS_STRING (9):				/* named group address */
	P_code = mlsys_et_$no_address_string;
	return;
%page;
/* Return the pathname associated with the given address, if any */

get_address_pathname:
     entry (P_address_ptr, P_address_dirname, P_address_ename, P_address_component, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	go to GET_ADDRESS_PATHNAME (address_header.type);

GET_ADDRESS_PATHNAME (0):				/* invalid address */
	P_code = mlsys_et_$no_address_pathname;
	return;

GET_ADDRESS_PATHNAME (1):				/* user mailbox address */
	P_address_dirname = ">udd>" || user_mailbox_address.project_id || ">" || user_mailbox_address.person_id;
	P_address_ename = user_mailbox_address.person_id || ".mbx";
	P_address_component = "";
	P_code = 0;
	return;

GET_ADDRESS_PATHNAME (2):				/* logbox address */
	P_address_dirname = ">udd>" || logbox_address.project_id || ">" || logbox_address.person_id;
	P_address_ename = logbox_address.person_id || ".sv.mbx";
	P_address_component = "";
	P_code = 0;
	return;

GET_ADDRESS_PATHNAME (3):				/* savebox address */
	P_address_dirname = savebox_address.mbx_dirname;
	P_address_ename = savebox_address.mbx_ename;
	P_address_component = "";
	P_code = 0;
	return;

GET_ADDRESS_PATHNAME (4):				/* mailbox address */
	P_address_dirname = mailbox_address.mbx_dirname;
	P_address_ename = mailbox_address.mbx_ename;
	P_address_component = "";
	P_code = 0;
	return;

GET_ADDRESS_PATHNAME (5):				/* forum address */
	P_address_dirname = forum_address.forum_dirname;
	P_address_ename = forum_address.forum_ename;
	P_address_component = "";
	P_code = 0;
	return;

GET_ADDRESS_PATHNAME (6):				/* foreign address */
GET_ADDRESS_PATHNAME (7):				/* mail table address */
	P_code = mlsys_et_$no_address_pathname;
	return;

GET_ADDRESS_PATHNAME (8):				/* mailing list address */
	P_address_dirname = mailing_list_address.mls_dirname;
	P_address_ename = mailing_list_address.mls_ename;
	P_address_component = mailing_list_address.mls_component;
	P_code = 0;
	return;

GET_ADDRESS_PATHNAME (9):				/* named group address */
	P_code = mlsys_et_$no_address_pathname;
	return;
%page;
/* Return the explicit route to be used to send mail to the given address which must be a foreign address:  The explicit
   route is a route supplied by a user (either local or foreign) and is always used even though the mail system could
   compute a shorter route to the foreign system if permitted */

get_address_explicit_route:
     entry (P_address_ptr, P_address_route_version, P_address_route_ptr, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	if address_header.type = FOREIGN_ADDRESS then
	     if foreign_address.explicit_route ^= null () then
		if P_address_route_version = ADDRESS_ROUTE_VERSION_1 then do;
		     P_address_route_ptr = foreign_address.explicit_route;
		     P_code = 0;			/* ... success */
		end;
		else P_code = error_table_$unimplemented_version;

	     else P_code = mlsys_et_$no_address_route;	/* no route at this time */

	else P_code = mlsys_et_$not_foreign_address;

	return;



/* Return the name of the foreign system associated with the given address which must be a foreign address */

get_address_system:
     entry (P_address_ptr, P_foreign_system, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	if address_header.type = FOREIGN_ADDRESS then do;
	     P_foreign_system = foreign_address.foreign_system;
	     P_code = 0;
	end;

	else P_code = mlsys_et_$not_foreign_address;

	return;
%page;
/* Set the implicit route associated with the given address which must be a foreign address:  The implicit route is a
   route associated with all the addresses in a message that is used by the mail system to send mail to the given address
   if it can not compute a route on its own */

set_address_implicit_route:
     entry (P_address_ptr, P_address_route_ptr, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADRESS type */

	if address_header.type = FOREIGN_ADDRESS then
	     if P_address_route_ptr -> address_route.version = ADDRESS_ROUTE_VERSION_1 then do;
		address_route_ptr = copy_ptr (P_address_route_ptr);
		if foreign_address.implicit_route ^= null () then
		     call mlsys_address_route_mgr_$decrement_reference_count (foreign_address.implicit_route);
		if mlsys_data_$valid_segments (binary (baseno (address_route_ptr), 18, 0)) then
		     foreign_address.implicit_route = address_route_ptr;
		else call mlsys_address_route_mgr_$create_address_route (address_route.relays,
			foreign_address.implicit_route);
		call mlsys_address_route_mgr_$increment_reference_count (foreign_address.implicit_route);
		P_code = 0;			/* success */
	     end;
	     else P_code = error_table_$unimplemented_version;

	else P_code = mlsys_et_$not_foreign_address;

	return;



/* Return the implicit route associated with the given address which must be a foreign address */

get_address_implicit_route:
     entry (P_address_ptr, P_address_route_version, P_address_route_ptr, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	if address_header.type = FOREIGN_ADDRESS then
	     if foreign_address.implicit_route ^= null () then
		if P_address_route_version = ADDRESS_ROUTE_VERSION_1 then do;
		     P_address_route_ptr = foreign_address.implicit_route;
		     P_code = 0;			/* ... success */
		end;
		else P_code = error_table_$unimplemented_version;

	     else P_code = mlsys_et_$no_address_route;	/* no route at this time */

	else P_code = mlsys_et_$not_foreign_address;

	return;
%page;
/* Return the setting of the display_list flag of the given address which must be a named group address */

get_named_group_display_flag:
     entry (P_address_ptr, P_display_list, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	if address_header.type = NAMED_GROUP_ADDRESS then do;
	     P_display_list = named_group_address.display_list;
	     P_code = 0;
	end;

	else P_code = mlsys_et_$not_named_group_address;

	return;



/* Return the address name of the given address */

get_address_name:
     entry (P_address_ptr, P_address_name, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();

	if (address_header.type = USER_MAILBOX_ADDRESS) | (address_header.type = LOGBOX_ADDRESS)
	     | (address_header.type = SAVEBOX_ADDRESS) then
	     if user_address_template.is_anonymous then	/* the address name for anonymous users is their Person_id */
		call set_output_variable ((user_address_template.person_id), P_address_name, P_code);
	     else call set_output_variable (address_name, P_address_name, P_code);
	else call set_output_variable (address_name, P_address_name, P_code);

	return;



/* Return the address comment of the given address */

get_address_comment:
     entry (P_address_ptr, P_address_comment, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	call set_output_variable (address_comment, P_address_comment, P_code);

	return;
%page;
/* Compares two addresses for equality:  Two addresses are equal if mail transmitted to either address will be delivered
   to the same set of recipients */

compare_addresses:
     entry (P_address_1_ptr, P_address_2_ptr, P_code) returns (bit (1) aligned);

	if ^verify_address (P_address_1_ptr, P_code) then return ("0"b);
	if ^verify_address (P_address_2_ptr, P_code) then return ("0"b);

	P_code = 0;				/* the comparison will succeed */

	if P_address_1_ptr = P_address_2_ptr then	/* they are the same physical structure */
	     return ("1"b);

	address_1_mte_address_ptr,			/* for cleanup handler */
	     address_2_mte_address_ptr, address_1_route_ptr, address_2_route_ptr, address_1_mls_ptr, address_2_mls_ptr,
	     address_list_1_ptr, address_list_2_ptr, address_list_ptr = null ();
	forum_1_index, forum_2_index = 0;

	on condition (cleanup) call cleanup_address_comparison ();

	address_1_ptr = copy_ptr (P_address_1_ptr);	/* copy inputs and check for was-foreign addresses */
	if address_1_ptr -> address_header.type = FOREIGN_ADDRESS then call check_if_actually_local (address_1_ptr);
						/* ... might not really be a foreign address */
	if address_1_ptr -> address_header.type = WAS_FOREIGN_ADDRESS then
	     address_1_ptr = address_1_ptr -> was_foreign_address.actual_address_ptr;

	address_2_ptr = copy_ptr (P_address_2_ptr);
	if address_2_ptr -> address_header.type = FOREIGN_ADDRESS then call check_if_actually_local (address_2_ptr);
	if address_2_ptr -> address_header.type = WAS_FOREIGN_ADDRESS then
	     address_2_ptr = address_2_ptr -> was_foreign_address.actual_address_ptr;


/* Lookup any mail table addresses before proceeeding:  If both addresses are mail table addresses, check if they have the
   same mail table name right now.  If only one is a mail table address or the names do not match and one or both can not
   be found in the mail table, then we can guarentee that the addresses aren't equal */

	if (address_1_ptr -> address_header.type = MAIL_TABLE_ADDRESS)
	     & (address_2_ptr -> address_header.type = MAIL_TABLE_ADDRESS) then
	     if address_1_ptr -> mail_table_address.mte_name = address_2_ptr -> mail_table_address.mte_name then
		call return_comparison_result ("1"b);

	if address_1_ptr -> address_header.type = MAIL_TABLE_ADDRESS then do;
	     call get_mail_table_address (address_1_ptr, address_1_mte_address_ptr, code);
	     if code ^= 0 then call return_comparison_result ("0"b);
	     address_1_ptr = address_1_mte_address_ptr;	/* need 2nd copy as address_1_ptr may get changed */
	     if address_1_ptr -> address_header.type = FOREIGN_ADDRESS then
		call check_if_actually_local (address_1_ptr);
	     if address_1_ptr -> address_header.type = WAS_FOREIGN_ADDRESS then
		address_1_ptr = address_1_ptr -> was_foreign_address.actual_address_ptr;
	end;

	if address_2_ptr -> address_header.type = MAIL_TABLE_ADDRESS then do;
	     call get_mail_table_address (address_2_ptr, address_2_mte_address_ptr, code);
	     if code ^= 0 then call return_comparison_result ("0"b);
	     address_2_ptr = address_2_mte_address_ptr;	/* need 2nd copy as address_2_ptr may get changed */
	     if address_2_ptr -> address_header.type = FOREIGN_ADDRESS then
		call check_if_actually_local (address_2_ptr);
	     if address_2_ptr -> address_header.type = WAS_FOREIGN_ADDRESS then
		address_2_ptr = address_2_ptr -> was_foreign_address.actual_address_ptr;
	end;


/* If one of the addresses is a mailing list or named group but the other is not, expand the list address and compare the
   expansion with the other address -- all addresses in the expansion must equal the other address */

	if (is_list_address (address_1_ptr) & ^is_list_address (address_2_ptr))
	     | (is_list_address (address_2_ptr) & ^is_list_address (address_1_ptr)) then do;

	     if is_list_address (address_1_ptr) then	/* we know that only one is a list address */
		call expand_list_address (address_1_ptr, ADDRESS_LIST_VERSION_2, address_list_ptr, code);
	     else do;
		call expand_list_address (address_2_ptr, ADDRESS_LIST_VERSION_2, address_list_ptr, code);
		address_2_ptr = address_1_ptr;	/* "swap" the two addresses */
	     end;
	     if code ^= 0 then call return_comparison_result ("0"b);
						/* couldn't expand: can't be equal */

	     if address_list.n_addresses = 0 then	/* the address list is empty: can't be equal */
		comparison_result = "0"b;
	     else do;
		comparison_result = "1"b;		/* really need do until here ... */
		do idx = 1 to address_list.n_addresses while (comparison_result);
		     comparison_result = compare_addresses (address_list.addresses (idx), address_2_ptr, (0));
		end;
	     end;

	     call return_comparison_result (comparison_result);
	end;


/* Both addresses are simple or both are list addresses */

	go to COMPARE_ADDRESSES (
	     COMPARISON_OPERATIONS (address_1_ptr -> address_header.type, address_2_ptr -> address_header.type));

COMPARE_ADDRESSES (-1):				/* incompatible types */
	call return_comparison_result ("0"b);


COMPARE_ADDRESSES (0):				/* two invalid addresses: do a string comparison */
	begin;
dcl  address_1_text char (address_1_ptr -> invalid_address.text_lth) based (address_1_ptr -> invalid_address.text_ptr);
dcl  address_2_text char (address_2_ptr -> invalid_address.text_lth) based (address_2_ptr -> invalid_address.text_ptr);
	     call return_comparison_result (address_1_text = address_2_text);
	end;


/* Both are addresses of mailboxes: check the pathnames before actually trying to find their UIDs */

COMPARE_ADDRESSES (1):
	call get_address_pathname (address_1_ptr, address_1_dirname, address_1_ename, ((32)" "), (0));
	call get_address_pathname (address_2_ptr, address_2_dirname, address_2_ename, ((32)" "), (0));

	if (address_1_dirname = address_2_dirname) & (address_1_ename = address_2_ename) then
	     call return_comparison_result ("1"b);	/* pathname strings match (whew) */

	call mailbox_$get_uid_file (address_1_dirname, address_1_ename, mailbox_1_uid, code_1);
	call mailbox_$get_uid_file (address_2_dirname, address_2_ename, mailbox_2_uid, code_2);

	if (code_1 = 0) & (code_2 = 0) then		/* got both UIDs */
	     comparison_result = (mailbox_1_uid = mailbox_2_uid);
	else comparison_result = "0"b;		/* got only one UID (or none): can't be equal */

	call return_comparison_result (comparison_result);


/* Both are addresses of forum meetings: check the pathnames before actually trying to access the meetings */

COMPARE_ADDRESSES (2):
	call get_address_pathname (address_1_ptr, address_1_dirname, address_1_ename, ((32)" "), (0));
	call get_address_pathname (address_2_ptr, address_2_dirname, address_2_ename, ((32)" "), (0));

	if (address_1_dirname = address_2_dirname) & (address_1_ename = address_2_ename) then
	     call return_comparison_result ("1"b);	/* pathname strings match (whew) */

	if mlsys_psp_$forum_not_available () then	/* if no forum on system ... */
	     call return_comparison_result ("0"b);	/* ... they can't be equal as pathnames don't match */

	if (address_1_dirname = "") | (address_2_dirname = "") then call return_comparison_result ("0"b);
						/* at least one of the forums doesn't exist */

	call forum_$open_forum (address_1_dirname, address_1_ename, forum_1_index, code_1);
	call forum_$open_forum (address_2_dirname, address_2_ename, forum_2_index, code_2);

	if (code_1 = 0) & (code_2 = 0) then		/* were able to open both */
	     comparison_result = (forum_1_index = forum_2_index);
	else comparison_result = "0"b;		/* couldn't open one or both: can't be equal */

	call return_comparison_result (comparison_result);


/* Both are foreign addresses */

COMPARE_ADDRESSES (3):
	begin;
dcl  address_1_local_part character (address_1_ptr -> foreign_address.local_part_lth)
	based (address_1_ptr -> foreign_address.local_part_ptr);
dcl  address_2_local_part character (address_2_ptr -> foreign_address.local_part_lth)
	based (address_2_ptr -> foreign_address.local_part_ptr);
	     if address_1_local_part ^= address_2_local_part then call return_comparison_result ("0"b);
	end;					/* can't be equal if local parts differ */

	/*** check system names and routes */
	call mlsys_address_route_mgr_$compute_optimum_route (address_1_ptr, address_1_route_ptr, code_1);
	call mlsys_address_route_mgr_$compute_optimum_route (address_2_ptr, address_2_route_ptr, code_2);
						/* these routes includes the actual target system */

	if (code_1 = 0) & (code_2 = 0) then		/* have a way to get to both systems */
	     if address_1_route_ptr -> address_route.n_relays = address_2_route_ptr -> address_route.n_relays then do;
		comparison_result = "1"b;		/* ... need do until */
		do idx = 1 to address_1_route_ptr -> address_route.n_relays while (comparison_result);
		     comparison_result =
			(translate (address_1_route_ptr -> address_route.relays (idx), UPPERCASE, LOWERCASE)
			= translate (address_2_route_ptr -> address_route.relays (idx), UPPERCASE, LOWERCASE));
		end;
	     end;
	     else comparison_result = "0"b;		/* ... not the same number of hops */
	else comparison_result = "0"b;		/* ... can't get to one or both */

	call return_comparison_result (comparison_result);


/* Both are mailing list addresses: check for the same segment/archive components before checking the actual addresses in
   the two lists */

COMPARE_ADDRESSES (4):
	if (address_1_ptr -> mailing_list_address.mls_dirname = address_2_ptr -> mailing_list_address.mls_dirname)
	     & (address_1_ptr -> mailing_list_address.mls_ename = address_2_ptr -> mailing_list_address.mls_ename)
	     & (address_1_ptr -> mailing_list_address.mls_component
	     = address_2_ptr -> mailing_list_address.mls_component) then
	     call return_comparison_result ("1"b);	/* pathnames match */

	call initiate_file_$component (address_1_ptr -> mailing_list_address.mls_dirname,
	     address_1_ptr -> mailing_list_address.mls_ename, address_1_ptr -> mailing_list_address.mls_component,
	     R_ACCESS, address_1_mls_ptr, (0), code_1);
	call initiate_file_$component (address_2_ptr -> mailing_list_address.mls_dirname,
	     address_2_ptr -> mailing_list_address.mls_ename, address_2_ptr -> mailing_list_address.mls_component,
	     R_ACCESS, address_2_mls_ptr, (0), code_2);

	if (code_1 = 0) & (code_2 = 0) then		/* got them both: are they the same? */
	     comparison_result = (address_1_mls_ptr = address_2_mls_ptr);
	else comparison_result = "0"b;		/* couldn't initiate both: this will fail again later */

	if comparison_result then			/* they match */
	     call return_comparison_result ("1"b);
	/*** not the same mailing list: fall through and check their contents */


/* Both are list addresses: check the individual addresses within the two lists */

COMPARE_ADDRESSES (5):
	call expand_list_address (address_1_ptr, ADDRESS_LIST_VERSION_2, address_list_1_ptr, code_1);
	call expand_list_address (address_2_ptr, ADDRESS_LIST_VERSION_2, address_list_2_ptr, code_2);

	if (code_1 ^= 0) | (code_2 ^= 0) then		/* couldn't expand both: can't be equal */
	     call return_comparison_result ("0"b);

	if (address_list_1_ptr -> address_list.n_addresses = 0) & (address_list_2_ptr -> address_list.n_addresses = 0)
	then comparison_result = "1"b;		/* both lists are empty */

	else if (address_list_1_ptr -> address_list.n_addresses = 0)
		| (address_list_2_ptr -> address_list.n_addresses = 0) then
	     comparison_result = "0"b;		/* one is empty and the other isn't: can't be equal */

	else do;					/* must check each address in both lists */
	     comparison_result = "1"b;		/* ... need do until again */
	     do idx = 1 to address_list_1_ptr -> address_list.n_addresses while (comparison_result);
		partial_comparison_result = "0"b;
		do jdx = 1 to address_list_2_ptr -> address_list.n_addresses while (^partial_comparison_result);
		     partial_comparison_result =
			compare_addresses (address_list_1_ptr -> address_list.addresses (idx),
			address_list_2_ptr -> address_list.addresses (jdx), (0));
		end;
		comparison_result = partial_comparison_result;
	     end;					/* ... stop as soon as we find one not in the other list */
	     do idx = 1 to address_list_2_ptr -> address_list.n_addresses while (comparison_result);
		partial_comparison_result = "0"b;
		do jdx = 1 to address_list_2_ptr -> address_list.n_addresses while (^partial_comparison_result);
		     partial_comparison_result =
			compare_addresses (address_list_2_ptr -> address_list.addresses (idx),
			address_list_1_ptr -> address_list.addresses (jdx), (0));
		end;
		comparison_result = partial_comparison_result;
	     end;					/* ... stop as soon as we find one not in the other list */
	end;

	call return_comparison_result (comparison_result);



/* Return the result of the address comparison (after proper cleanup, of course) */

return_comparison_result:
     procedure (p_result);

dcl  p_result bit (1) aligned;

	call cleanup_address_comparison ();

	comparison_result = p_result;			/* set the result in the caller's stack frame */

	go to RETURN_FROM_COMPARE_ADDRESSES;

     end return_comparison_result;

RETURN_FROM_COMPARE_ADDRESSES:			/* actually return point for mail_system_$compare_addresses */
	return (comparison_result);



/* Cleanup after an address comparison operation */

cleanup_address_comparison:
     procedure ();

	if address_1_mte_address_ptr ^= null () then call free_address (address_1_mte_address_ptr, (0));
	if address_2_mte_address_ptr ^= null () then call free_address (address_2_mte_address_ptr, (0));

	if address_list_ptr ^= null () then call mlsys_address_list_mgr_$free_address_list (address_list_ptr, (0));

	if forum_1_index ^= 0 then call forum_$close_forum (forum_1_index, (0));
	if forum_2_index ^= 0 then call forum_$close_forum (forum_2_index, (0));
	forum_1_index, forum_2_index = 0;

	if address_1_route_ptr ^= null () then call mlsys_address_route_mgr_$free_address_route (address_1_route_ptr);
	if address_2_route_ptr ^= null () then call mlsys_address_route_mgr_$free_address_route (address_2_route_ptr);

	if address_1_mls_ptr ^= null () then call terminate_file_ (address_1_mls_ptr, 0, TERM_FILE_TERM, (0));
	if address_2_mls_ptr ^= null () then call terminate_file_ (address_2_mls_ptr, 0, TERM_FILE_TERM, (0));
	address_1_mls_ptr, address_2_mls_ptr = null ();

	if address_list_1_ptr ^= null () then call mlsys_address_list_mgr_$free_address_list (address_list_1_ptr, (0));
	if address_list_2_ptr ^= null () then call mlsys_address_list_mgr_$free_address_list (address_list_2_ptr, (0));

	return;

     end cleanup_address_comparison;
%page;
/* Return the actual address in the system's mail table corresponding to the given address */

get_mail_table_address:
     entry (P_address_ptr, P_mail_table_address_ptr, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	if address_header.type ^= MAIL_TABLE_ADDRESS then do;
	     P_code = mlsys_et_$not_mail_table_address;
	     return;
	end;

	current_mtle_ptr = null ();			/* this is the top of the list */
	call lookup_mail_table_entry (mail_table_address.mte_name);

	P_mail_table_address_ptr = mail_table_address_ptr;
	code = 0;					/* success */

RETURN_FROM_GET_MAIL_TABLE_ADDRESS:
	P_code = code;

	return;



/* Searches the mail table for the given name:  If found, a check is made for a circular definition as the mail table
   software does not prevent recursive entries */

lookup_mail_table_entry:
     procedure (p_mte_name);

dcl  p_mte_name character (32) varying parameter;

dcl  1 mtle aligned based (mtle_ptr),
       2 previous_mtle_ptr pointer,
       2 name character (32) varying;
dcl  mtle_ptr pointer;

dcl  1 local_mtle aligned like mtle;
dcl  next_mte_name character (32) varying;

	call mail_table_$get (p_mte_name, mail_table_address_ptr, ((168)" "), code);
	if code = error_table_$id_not_found then code = mlsys_et_$mte_not_found;
	if code ^= 0 then go to RETURN_FROM_GET_MAIL_TABLE_ADDRESS;

	if mail_table_address_ptr -> address_header.type ^= MAIL_TABLE_ADDRESS then return;
						/* target isn't another mail table entry: this is it */

	next_mte_name = mail_table_address_ptr -> mail_table_address.mte_name;
	call free_address (mail_table_address_ptr, (0));	/* we don't need this address anymore */

	local_mtle.name = p_mte_name;			/* put it onto the stack */
	local_mtle.previous_mtle_ptr = current_mtle_ptr;
	current_mtle_ptr = addr (local_mtle);

	do mtle_ptr = current_mtle_ptr repeat (mtle.previous_mtle_ptr) while (mtle_ptr ^= null ());
	     if next_mte_name = mtle.name then do;	/* the name is circular ... */
		code = mlsys_et_$circular_mtes;
		go to RETURN_FROM_GET_MAIL_TABLE_ADDRESS;
	     end;
	end;

	call lookup_mail_table_entry (next_mte_name);	/* recurse */

     end lookup_mail_table_entry;
%page;
/* Returns the address list which is the expansion of a list address (mailing list/named group) */

expand_list_address:
     entry (P_address_ptr, P_address_list_version, P_address_list_ptr, P_code);

	if ^verify_address (P_address_ptr, P_code) then return;

	call set_address_ptr ();			/* bypass the infamous WAS_FOREIGN_ADDRESS type */

	if ^is_list_address (address_ptr) then do;	/* must be a mailing list or a named group */
	     P_code = mlsys_et_$not_list_address;
	     return;
	end;

	if P_address_list_version ^= ADDRESS_LIST_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if address_header.type = NAMED_GROUP_ADDRESS then
	     if named_group_address.address_list = null () then
		/*** no address list: return an empty list to the caller */
		call mlsys_address_list_mgr_$create_user_freeable_address_list (P_address_list_version,
		     P_address_list_ptr, P_code);
	     else do;				/* there is a list present */
		P_address_list_ptr = named_group_address.address_list;
		P_code = 0;
	     end;

	else /*** if address_header.type = MAILING_LIST_ADDRESS then */
	     do;
	     /*** Mailing list: initiate the segment/archive component and then parse its content */
	     mls_ptr = null ();			/* for cleanup handler */
	     on condition (cleanup)
		begin;
		     if mls_ptr ^= null () then call terminate_file_ (mls_ptr, 0, TERM_FILE_TERM, (0));
		end;
	     call initiate_file_$component (mailing_list_address.mls_dirname, mailing_list_address.mls_ename,
		mailing_list_address.mls_component, R_ACCESS, mls_ptr, mls_bitcount, code);
	     if (code = error_table_$noentry) | (code = error_table_$no_component) then
		code = mlsys_et_$no_mailing_list;
	     if code = 0 then do;			/* it's there and we have access ... */
		mls_lth = divide ((mls_bitcount + 8), 9, 21, 0);
		call mlsys_parse_text_$parse_mailing_list_text (mls_text, P_address_list_version, address_list_ptr,
		     code);
	     end;
	     else address_list_ptr = null ();		/* ... no luck */
	     if mls_ptr ^= null () then call terminate_file_ (mls_ptr, 0, TERM_FILE_TERM, (0));
	     P_address_list_ptr = address_list_ptr;
	     P_code = code;
	end;

	return;



/*  Return "1"b if the supplied address is a list address (ie: either a mailing list or a named group address) */

is_list_address:
     procedure (p_address_ptr) returns (bit (1) aligned);

dcl  p_address_ptr pointer parameter;

	return ((p_address_ptr -> address_header.type = MAILING_LIST_ADDRESS)
	     | (p_address_ptr -> address_header.type = NAMED_GROUP_ADDRESS));

     end is_list_address;
%page;
/* Checks if the supplied address is actually a local address by computing the optimum route to reach said address:  If
   the route shows that the address is local, this entrypoint will convert it into its proper representation */

check_if_actually_local:
     entry (P_address_ptr);

	if P_address_ptr -> address_header.type = FOREIGN_ADDRESS then call check_if_actually_local (P_address_ptr);

	return;



/* Acutally checks if a foreign address is really local (called by several entrypoints) */

check_if_actually_local:
     procedure (p_address_ptr);

dcl  p_address_ptr pointer parameter;

dcl  foreign_local_part character (old_address_ptr -> foreign_address.local_part_lth) unaligned
	based (old_address_ptr -> foreign_address.local_part_ptr);
dcl  new_address_name character (new_address_ptr -> address_header.name_lth) unaligned
	based (new_address_ptr -> address_header.name_ptr);
dcl  new_address_comment character (new_address_ptr -> address_header.comment_lth) unaligned
	based (new_address_ptr -> address_header.comment_ptr);
dcl  (old_address_ptr, new_address_ptr, new_new_address_ptr) pointer;


	old_address_ptr = copy_ptr (p_address_ptr);

	address_route_ptr = null ();			/* not set by following procedure if there were errors */
	call mlsys_address_route_mgr_$compute_optimum_route (old_address_ptr, address_route_ptr, code);

	if (address_route_ptr ^= null ()) | (code ^= 0) then do;
	     if address_route_ptr ^= null () then call mlsys_address_route_mgr_$free_address_route (address_route_ptr);
	     return;				/* got a route or an error: it's really foreign */
	end;

	call mlsys_parse_text_$parse_address_text (foreign_local_part, new_address_ptr, code);
	if code ^= 0 then				/* won't parse: create an invalid address */
	     call create_invalid_address ((foreign_local_part), "", "", new_address_ptr, (0));

	if new_address_ptr -> address_header.type = FOREIGN_ADDRESS then do;
	     /*** New address is still foreign: check again to see if it's really local */
	     call check_if_actually_local (new_address_ptr);
	     if new_address_ptr -> address_header.type = WAS_FOREIGN_ADDRESS then do;
		/*** Eliminate an extra level of indirection: increment the real target's (new_new) reference count
		     now; otherwise, it will be freed when the middle address (new) is freed */
		new_new_address_ptr = new_address_ptr -> was_foreign_address.actual_address_ptr;
		call increment_reference_count (new_new_address_ptr);
		call free_address (new_address_ptr, (0));
		new_address_ptr = new_new_address_ptr;
	     end;
	     else new_new_address_ptr = null ();	/* used as a flag to indicated whether reference count ... */
	end;
	else new_new_address_ptr = null ();		/* ... has already been incremented for the target */

	if old_address_ptr -> foreign_address.free_local_part then free foreign_local_part in (mlsys_area);

	old_address_ptr -> address_header.type = WAS_FOREIGN_ADDRESS;

	old_address_ptr -> was_foreign_address.actual_address_ptr = new_address_ptr;
	if new_new_address_ptr = null () then		/* we didn't increment the target's refcount above ... */
	     call increment_reference_count (new_address_ptr);

	if new_address_ptr -> address_header.free_name then free new_address_name in (mlsys_area);
	if new_address_ptr -> address_header.free_comment then free new_address_comment in (mlsys_area);
						/* the address will use the original name and comment */

	new_address_ptr -> address_header.name = old_address_ptr -> address_header.name;
	new_address_ptr -> address_header.comment = old_address_ptr -> address_header.comment;
	new_address_ptr -> address_header.free_name,	/* the name and comment will be freed (if needed) ... */
	     new_address_ptr -> address_header.free_comment = "0"b;
						/* ... when the original address is freed */

	return;

     end check_if_actually_local;
%page;
/* Verify that the caller supplied a pointer to a mail system address */

verify_address:
     entry (P_address_ptr, P_code) returns (bit (1) aligned);

	return (verify_address (P_address_ptr, P_code));	/* just a transfer to the internal procedure */



/* Actually verify the supplied pointer */

verify_address:
     procedure (p_address_ptr, p_code) returns (bit (1) aligned);

dcl  p_address_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;

	if p_address_ptr = null () then p_code = mlsys_et_$not_address;

	else if ^mlsys_data_$valid_segments (binary (baseno (p_address_ptr), 18, 0)) then
	     p_code = mlsys_et_$not_address;		/* supplied "address" wasn't allocated by us */

	else if p_address_ptr -> address_header.version ^= ADDRESS_VERSION_2 then p_code = mlsys_et_$not_address;
						/* supplied "address" is some other type of structure */

	else p_code = 0;				/* it's an address */

	return ((p_code = 0));

     end verify_address;



/* Sets the local address_ptr variable from the caller's P_address_ptr parameter */

set_address_ptr:
     procedure ();

	address_ptr = copy_ptr (P_address_ptr);

	if address_header.type = WAS_FOREIGN_ADDRESS then /* bypass this place-holder address */
	     address_ptr = was_foreign_address.actual_address_ptr;

	return;

     end set_address_ptr;
%page;
/* Sets the specified string in an address to the supplied value */

set_address_variable_string:
     procedure (p_input_value, p_address_variable, p_free_address_variable);

dcl  p_input_value character (*) parameter varying;
dcl  1 p_address_variable aligned parameter,
       2 text_ptr pointer,
       2 text_lth fixed binary (21);
dcl  p_free_address_variable bit (1) unaligned parameter;

dcl  address_variable character (p_address_variable.text_lth) unaligned based (p_address_variable.text_ptr);

	if p_input_value = "" then do;		/* nothing supplied here */
	     p_address_variable.text_ptr = addr (NULL_STRING);
	     p_address_variable.text_lth = 0;
	     p_free_address_variable = "0"b;
	end;

	else do;
	     p_address_variable.text_lth = length (p_input_value);
	     allocate address_variable in (mlsys_area) set (p_address_variable.text_ptr);
	     address_variable = p_input_value;
	     p_free_address_variable = "1"b;
	end;

	return;

     end set_address_variable_string;



/* Sets the given output parameter to the supplied string while checking for truncation of the string */

set_output_variable:
     procedure (p_output_value, p_output_parameter, p_code);

dcl  p_output_value character (*) parameter;		/* the value to be returned */
dcl  p_output_parameter character (*) varying parameter;	/* the caller's output parameter */
dcl  p_code fixed binary (35) parameter;

	if length (p_output_value) > maxlength (p_output_parameter) then
	     p_code = error_table_$smallarg;		/* it's too long */

	else do;					/* it fits */
	     p_output_parameter = p_output_value;
	     p_code = 0;
	end;

	return;

     end set_output_variable;
%page;
/* Validates that the given entry name ends in the proper suffix and is also not overlength */

validate_entryname:
     procedure (p_ename, p_suffix, p_actual_ename, p_code) returns (bit (1) aligned);

dcl  (p_ename, p_suffix, p_actual_ename) character (*) parameter;
dcl  p_code fixed binary (35) parameter;

	p_code = 0;				/* assume success */

	if p_suffix ^= "" then			/* caller has a suffix to check ... */
	     if index (reverse (rtrim (p_ename)), reverse (p_suffix)) ^= 1 then p_code = mlsys_et_$incorrect_suffix;

	if p_code = 0 then				/* check length if the suffix is OK */
	     if length (rtrim (p_ename)) > length (p_actual_ename) then p_code = error_table_$entlong;

	return ((p_code = 0));			/* let caller know if it's OK */

     end validate_entryname;
%page;
/* Allocates and initializes an address of the requested type */

initialize_address:
     procedure (p_address_type);

dcl  p_address_type fixed binary parameter;

	go to INITIALIZE_ADDRESS (p_address_type);

INITIALIZE_ADDRESS (0):				/* invalid address */
	allocate invalid_address in (mlsys_area) set (address_ptr);
	call initialize_header ();
	invalid_address.text_ptr = addr (NULL_STRING);	/* haven't got the text yet */
	invalid_address.text_lth = 0;
	string (invalid_address.flags) = ""b;		/* nothing to free yet */
	return;

INITIALIZE_USER_MAILBOX_COMMON:			/* shared code for user mailboxes (default/logbox/savebox) */
	call initialize_header ();
	user_address_template.person_id, user_address_template.project_id = "";
	string (user_address_template.flags) = ""b;	/* don't know yet if it's anonymous */
	return;

INITIALIZE_ADDRESS (1):				/* user mailbox address */
	allocate user_mailbox_address in (mlsys_area) set (address_ptr);
	go to INITIALIZE_USER_MAILBOX_COMMON;

INITIALIZE_ADDRESS (2):				/* logbox address */
	allocate logbox_address in (mlsys_area) set (address_ptr);
	go to INITIALIZE_USER_MAILBOX_COMMON;

INITIALIZE_ADDRESS (3):				/* savebox address */
	allocate savebox_address in (mlsys_area) set (address_ptr);
	savebox_address.mbx_dirname, savebox_address.mbx_ename = "";
	go to INITIALIZE_USER_MAILBOX_COMMON;

INITIALIZE_ADDRESS (4):				/* mailbox address */
	allocate mailbox_address in (mlsys_area) set (address_ptr);
	call initialize_header ();
	mailbox_address.mbx_dirname, mailbox_address.mbx_ename = "";
	return;

INITIALIZE_ADDRESS (5):				/* forum address */
	allocate forum_address in (mlsys_area) set (address_ptr);
	call initialize_header ();
	forum_address.forum_dirname, forum_address.forum_ename = "";
	return;

INITIALIZE_ADDRESS (6):				/* foreign address */
	allocate foreign_address in (mlsys_area) set (address_ptr);
	call initialize_header ();
	foreign_address.local_part_ptr = addr (NULL_STRING);
						/* no local part yet */
	foreign_address.local_part_lth = 0;
	foreign_address.foreign_system = "";		/* no system name */
	foreign_address.explicit_route,		/* no explicit/implicit route */
	     foreign_address.implicit_route = null ();
	string (foreign_address.flags) = ""b;		/* nothing to free yet */
	return;

INITIALIZE_ADDRESS (7):				/* mail table address */
	allocate mail_table_address in (mlsys_area) set (address_ptr);
	call initialize_header ();
	mail_table_address.mte_name = "";
	return;

INITIALIZE_ADDRESS (8):				/* mailing list address */
	allocate mailing_list_address in (mlsys_area) set (address_ptr);
	call initialize_header ();
	mailing_list_address.mls_dirname, mailing_list_address.mls_ename, mailing_list_address.mls_component = "";
	return;

INITIALIZE_ADDRESS (9):				/* named group address */
	allocate named_group_address in (mlsys_area) set (address_ptr);
	call initialize_header ();
	named_group_address.address_list = null ();	/* nothing in the group yet */
	string (named_group_address.flags) = ""b;	/* don't know whether or not to display the addresses */
	return;



/* Internal to initialize_address: initializes the address header */

initialize_header:
	procedure ();

	     address_header.version = ADDRESS_VERSION_2;

	     address_header.type = p_address_type;	/* as requested by the caller */

	     address_header.reference_count = 0;	/* nothing else in the mail system knows about it */

	     address_header.name_ptr = addr (NULL_STRING);/* no name ... */
	     address_header.name_lth = 0;

	     address_header.comment_ptr = addr (NULL_STRING);
	     address_header.comment_lth = 0;		/* ... and no comment */

	     string (address_header.flags) = ""b;	/* nothing to free and it's OK to free it */

	     return;

	end initialize_header;

     end initialize_address;
%page;
%include mlsys_copy_ptr;
%page;
%include mlsys_data;
%page;
%include mlsys_internal_data;
%page;
%include mlsys_address_route;
%page;
%include mlsys_address_list;
%page;
%include access_mode_values;
%page;
%include terminate_file;

     end mlsys_address_mgr_;




		    mlsys_address_route_mgr_.pl1    06/30/86  1410.2r w 06/30/86  1343.8      101664



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* format: off */

/* Address route management for the Multics Mail System */

/* Created:  July 1983 by G. Palter */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


mlsys_address_route_mgr_:
     procedure () options (rename ((alloc_, mlsys_storage_mgr_$allocate)));

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_address_route_ptr pointer parameter;

dcl  P_relay_list (*) character (256) varying parameter;	/* create_address_route: the list of systems in the route */

dcl  P_address_ptr pointer parameter;			/* compute_*_route: -> address for which a route is needed */
dcl  P_code fixed binary (35) parameter;		/* compute_*_route */


/* Local copies of parameters */

dcl  address_ptr pointer;
dcl  code fixed binary (35);


/* Definition of the reserved data in the address_route structure */

dcl  1 address_route_reserved_data aligned based (addr (address_route.reserved)),
       2 reference_count fixed binary;			/* # of objects that care about this route */


/* Remaining declarations */

dcl  address_type fixed binary;
dcl  (explicit_route, implicit_route) pointer;
dcl  (foreign_system_name, first_relay_system, extra_relay_system) character (256) varying;
dcl  (n_from_explicit_route, n_from_implicit_route) fixed binary;

dcl  (route_idx, old_idx, idx) fixed binary;

/* format: off */
dcl (UPPERCASE	initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
     LOWERCASE	initial ("abcdefghijklmnopqrstuvwxyz"))
	character (26) static options (constant);

dcl (mlsys_et_$bad_explicit_route, mlsys_et_$cant_compute_route, mlsys_et_$ism_not_available)
	fixed binary (35) external;
/* format: on */

dcl  mlsys_address_mgr_$get_address_explicit_route entry (pointer, character (8), pointer, fixed binary (35));
dcl  mlsys_address_mgr_$get_address_implicit_route entry (pointer, character (8), pointer, fixed binary (35));
dcl  mlsys_address_mgr_$get_address_system entry (pointer, character (256) varying, fixed binary (35));
dcl  mlsys_address_mgr_$get_address_type entry (pointer, fixed binary, fixed binary (35));
dcl  mlsys_nit_interface_$get_fully_qualified_name entry (character (256) varying) returns (character (256) varying);
dcl  mlsys_nit_interface_$is_local_system entry (character (256) varying) returns (bit (1) aligned);
dcl  mlsys_nit_interface_$is_mail_supported entry (character (256) varying, character (256) varying, fixed binary (35));

dcl  (addr, dimension, hbound, lbound, null, translate) builtin;
%page;
/* Create an address route */

create_address_route:
     entry (P_relay_list, P_address_route_ptr);

	address_route_n_relays = dimension (P_relay_list, 1);

	allocate address_route in (mlsys_area) set (address_route_ptr);

	address_route.version = ADDRESS_ROUTE_VERSION_1;
	address_route_reserved_data.reference_count = 0;

	do idx = lbound (P_relay_list, 1) to hbound (P_relay_list, 1);
	     address_route.relays (idx - lbound (P_relay_list, 1) + 1) =
		translate (P_relay_list (idx), UPPERCASE, LOWERCASE);
	end;					/* ... don't lookup the names: we probably don't know them */

	address_route.relays (1) =			/* ... except the first relaying host should be known to us */
	     mlsys_nit_interface_$get_fully_qualified_name (address_route.relays (1));

	P_address_route_ptr = address_route_ptr;

	return;
%page;
/* Free an address route if its reference count is zero (ie: if o other mail system object has a pointer to it) */

free_address_route:
     entry (P_address_route_ptr);

	address_route_ptr = P_address_route_ptr;
	P_address_route_ptr = null ();		/* insure that the caller doesn't use it anymore */

	if address_route_reserved_data.reference_count > 0 then return;

	free address_route in (mlsys_area);

	return;



/* Increment the reference count of an address route: to avoid freeing an address route referenced by several objects
   before all the objects are themselves freed */

increment_reference_count:
     entry (P_address_route_ptr);

	addr (P_address_route_ptr -> address_route.reserved) -> address_route_reserved_data.reference_count =
	     addr (P_address_route_ptr -> address_route.reserved) -> address_route_reserved_data.reference_count + 1;

	return;



/* Decrement the reference count of an address route:  If the reference count reaches zero, nothing in the mail system is
   using this address route any longer and its storage is released */

decrement_reference_count:
     entry (P_address_route_ptr);

	addr (P_address_route_ptr -> address_route.reserved) -> address_route_reserved_data.reference_count =
	     addr (P_address_route_ptr -> address_route.reserved) -> address_route_reserved_data.reference_count - 1;

	if addr (P_address_route_ptr -> address_route.reserved) -> address_route_reserved_data.reference_count <= 0 then
	     call free_address_route (P_address_route_ptr);

	P_address_route_ptr = null ();		/* keep the caller from using it anymore */

	return;
%page;
/* Compute the route required to deliver a message to the given address */

compute_optimum_route:				/* ... best possible route: not without real name servers */
compute_route:
     entry (P_address_ptr, P_address_route_ptr, P_code);

	address_ptr = P_address_ptr;

	call mlsys_address_mgr_$get_address_type (address_ptr, address_type, code);
	if code ^= 0 then do;			/* eh? */
	     P_code = code;
	     return;
	end;

	if address_type ^= FOREIGN_ADDRESS then do;
ADDRESS_IS_LOCAL:
	     P_address_route_ptr = null ();		/* indicates a local address */
	     P_code = 0;
	     return;

	end;

	call mlsys_address_mgr_$get_address_system (address_ptr, foreign_system_name, (0));

	call mlsys_address_mgr_$get_address_explicit_route (address_ptr, ADDRESS_ROUTE_VERSION_1, explicit_route, code);
	if code ^= 0 then explicit_route = null ();	/* only possible error is that's there no route */

	call mlsys_address_mgr_$get_address_implicit_route (address_ptr, ADDRESS_ROUTE_VERSION_1, implicit_route, code);
	if code ^= 0 then implicit_route = null ();	/* only possible error is that's there no route */


/* Determine the name of the first system in the route:  If there's an explicit route, use it.  In either case, eliminate
   the local system from the start of the route.  (Ie: "via A via B via LOCAL via LOCAL" is the same as "via A via B" */

	first_relay_system = "";			/* null string means address is on our system */

	n_from_explicit_route, n_from_implicit_route = 0; /* don't know how many from each path are necessary yet */

	if explicit_route ^= null () then do;		/* check out the explicit route */
	     address_route_ptr = explicit_route;
	     n_from_explicit_route = address_route.n_relays;
	     do while ((first_relay_system = "") & (n_from_explicit_route > 0));
		idx = address_route.n_relays - n_from_explicit_route + 1;
		first_relay_system = address_route.relays (idx);
		if mlsys_nit_interface_$is_local_system (first_relay_system) then do;
		     first_relay_system = "";		/* it's local: keep looking */
		     n_from_explicit_route = n_from_explicit_route - 1;
		end;
	     end;
	end;

	if n_from_explicit_route = 0 then		/* no explicit route or all were actually us ... */
	     if mlsys_nit_interface_$is_local_system (foreign_system_name) then
		go to ADDRESS_IS_LOCAL;
	     else first_relay_system = foreign_system_name;


/* Have the first system in the route:  Check if we can send it mail; if we can't (unknown system, no mail service), try
   using the implicit route which is the route by which the message actually was transmitted to reach this system */

	extra_relay_system = "";			/* NIT may specify an extra "hop" */

	call mlsys_nit_interface_$is_mail_supported (first_relay_system, extra_relay_system, code);

	if code ^= 0 then				/* don't know how to send mail to the given system ... */
	     if code = mlsys_et_$ism_not_available then do;
		P_code = code;			/* ... no inter-system mailer should always be reported */
		return;
	     end;

	     else if implicit_route = null () then do;	/* ... no implicit route: there's no way to send mail */
		if n_from_explicit_route > 0 then	/* ... because the user gave a bad route */
		     code = mlsys_et_$bad_explicit_route;
		P_code = code;
		return;
	     end;

	     else do;				/* ... try using the implicit route */
		address_route_ptr = implicit_route;
		n_from_implicit_route = address_route.n_relays;
		do while ((first_relay_system = "") & (n_from_implicit_route > 0));
		     idx = address_route.n_relays - n_from_implicit_route + 1;
		     first_relay_system = address_route.relays (idx);
		     if mlsys_nit_interface_$is_local_system (first_relay_system) then do;
			first_relay_system = "";	/* it's local: keep looking */
			n_from_implicit_route = n_from_implicit_route - 1;
		     end;
		end;
		if n_from_implicit_route = 0 then do;	/* no help in the implicit route */
CANT_COMPUTE_ADDRESS_ROUTE:
		     P_code = mlsys_et_$cant_compute_route;
		     return;
		end;
		call mlsys_nit_interface_$is_mail_supported (first_relay_system, extra_relay_system, code);
		if code ^= 0 then			/* ... don't know how to get it by the implicit route */
		     if code = mlsys_et_$ism_not_available then do;
			P_code = code;		/* ... no inter-system mailer should always be reported */
			return;
		     end;
		     else go to CANT_COMPUTE_ADDRESS_ROUTE;
	     end;


/* Control arrives here iff there is a workable route */

	address_route_n_relays = 1;			/* always have the foreign system itself */

	address_route_n_relays = address_route_n_relays + n_from_explicit_route;
	address_route_n_relays = address_route_n_relays + n_from_implicit_route;

	if extra_relay_system ^= "" then address_route_n_relays = address_route_n_relays + 1;

	allocate address_route in (mlsys_area) set (address_route_ptr);

	address_route.version = ADDRESS_ROUTE_VERSION_1;
	address_route_reserved_data.reference_count = 0;

	if extra_relay_system ^= "" then do;		/* system from the NIT is the first hop */
	     address_route.relays (1) = extra_relay_system;
	     route_idx = 2;
	end;
	else route_idx = 1;

	if n_from_implicit_route > 0 then do;		/* put in relays from the implicit route */
	     do idx = 1 to n_from_implicit_route;
		old_idx = implicit_route -> address_route.n_relays - n_from_implicit_route + idx;
		address_route.relays (route_idx) = implicit_route -> address_route.relays (old_idx);
		route_idx = route_idx + 1;
	     end;
	end;

	if n_from_explicit_route > 0 then do;		/* put in relays from the explicit route */
	     do idx = 1 to n_from_explicit_route;
		old_idx = explicit_route -> address_route.n_relays - n_from_explicit_route + idx;
		address_route.relays (route_idx) = explicit_route -> address_route.relays (old_idx);
		route_idx = route_idx + 1;
	     end;
	end;

	address_route.relays (route_idx) = foreign_system_name;
						/* don't forget the target system */

	P_address_route_ptr = address_route_ptr;
	P_code = 0;				/* success */

	return;
%page;
%include mlsys_address_route;
%page;
%include mlsys_address_types;
%page;
%include mlsys_internal_data;

     end mlsys_address_route_mgr_;




		    mlsys_data_.cds                 06/30/86  1410.2rew 06/30/86  1342.7       64152



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *********************************************************** */



/* HISTORY COMMENTS:
  1) change(86-06-11,Mills), approve(86-06-11,MCR7419),
     audit(86-06-17,Margolin), install(86-06-30,MR12.0-1080):
     Adding initializations for mlsys_data_$domains_available = 0;
                                                   END HISTORY COMMENTS */


/* format: off */

/* Constants and static data used by the Multics mail system:  See mlsys_data.incl.pl1 and mlsys_internal_data.incl.pl1
   for an explanation of the meaning/use of these values */

/* Created:  May 1981 by G. Palter */
/* Modified: June 1983 by G. Palter to merge with mlsys_internal_data_ and for multi-ring mail system */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


mlsys_data_:
     procedure () options (variable);


dcl  1 mlsys_constants aligned,                             /* the constant data */
       2 max_opening_retries fixed binary,
       2 max_lock_wait_retries fixed binary,
       2 mailbox_allocation fixed binary,
       2 message_body_sections_allocation fixed binary,
       2 message_redistributions_list_allocation fixed binary,
       2 message_user_fields_allocation fixed binary,
       2 message_references_list_allocation fixed binary,
       2 address_list_allocation fixed binary,
       2 mailbox_link_directory character (168) unaligned,
       2 mailer_directory character (168) unaligned,
       2 system_directory character (168) unaligned;

dcl  1 mlsys_static aligned,                                /* per-process constant (ie: static) data */
       2 forum_not_available fixed binary (1),
       2 ism_not_available fixed binary (1),
       2 subsystem_ring fixed binary (3),
       2 highest_usable_ring fixed binary (3),
       2 lowest_forum_ring fixed binary (3),
       2 temp_segment_list_ptr pointer,
       2 valid_segments,                                    /* ... insures that it's word aligned */
         3 bits (0:4095) bit (1) unaligned,
       2 subsystem_area_ptr pointer,
       2 hash_tables_segment_ptr pointer,
       2 transmit_cache_ptr pointer,
       2 user_is_anonymous bit (1) aligned,
       2 person_id character (24) varying,
       2 project_id character (12) varying,
       2 user_id character (32) varying,
       2 user_default_mailbox_address pointer,
       2 user_mail_table_address pointer,
       2 user_logbox_address pointer,
       2 domains_available;


dcl  1 cds_data aligned like cds_args;                      /* arguments to create_data_segment_ subr */

dcl  code fixed binary (35);

dcl  MLSYS_DATA_ character (32) static options (constant) initial ("mlsys_data_");

dcl  create_data_segment_ entry (pointer, fixed binary (35));
dcl  com_err_ entry () options (variable);

dcl  (addr, currentsize, null, string) builtin;
%page;
/* Define the constants */

          mlsys_constants.max_opening_retries = 5;          /* retry salvaged openings five times before punting */

          mlsys_constants.max_lock_wait_retries = 20;       /* retry message transmission to locked mailbox 20 times */

          mlsys_constants.mailbox_allocation = 32;          /* see the explanation in mlsys_internal_data.incl.pl1 ... */
          mlsys_constants.message_body_sections_allocation = 1;
          mlsys_constants.message_redistributions_list_allocation = 4;
          mlsys_constants.message_user_fields_allocation = 4;
          mlsys_constants.message_references_list_allocation = 2;
          mlsys_constants.address_list_allocation = 4;

          mlsys_constants.mailbox_link_directory = ">udd>Daemon>mailboxes";
          mlsys_constants.mailer_directory = ">udd>Daemon>Network_Server";

          mlsys_constants.system_directory = ">site>mail_system_dir";
                                                            /* directory containing per-system data (mail table/queues) */


/* Initialize static data to known values */

          mlsys_static.forum_not_available = 0;             /* 1 => forum isn't available on the system or in this ring */
          mlsys_static.ism_not_available = 0;               /* 1 => no inter-system mailer on this system */
          mlsys_static.domains_available = 0;               /* 1 => domains software on this system */
          mlsys_static.subsystem_ring = -1;                 /* ring in which the mail system is secured */
          mlsys_static.highest_usable_ring = -1;            /* highest ring of execution which may access the mail system */
          mlsys_static.lowest_forum_ring = -1;              /* lowest ring of execution with access to forum */

          mlsys_static.temp_segment_list_ptr = null ();     /* -> list of all mail system temporary segments */

          string (mlsys_static.valid_segments.bits) = ""b;  /* which segments contain data allocated by the mail system */
          mlsys_static.subsystem_area_ptr = null ();        /* -> area used by the mail system for all allocations */

          mlsys_static.hash_tables_segment_ptr = null ();   /* -> hash tables used by the mail system */

          mlsys_static.transmit_cache_ptr = null ();        /* -> cache of recently used mailboxes for mlsys_transmit_ */

          mlsys_static.user_is_anonymous = "0"b;            /* whether or not the user is an anonymous */
          mlsys_static.person_id = "";                      /* the user's Person_id, Project_id, and User_id */
          mlsys_static.project_id = "";
          mlsys_static.user_id = "";

          mlsys_static.user_default_mailbox_address,        /* -> user's default mailbox address */
               mlsys_static.user_mail_table_address,        /* -> user's mail table address */
               mlsys_static.user_logbox_address = null ();  /* -> address of the user's logbox */


/* Set up arguments for call to create_data_segment_ */

          cds_data.sections (1).p = addr (mlsys_constants);
          cds_data.sections (1).len = currentsize (mlsys_constants);
          cds_data.sections (1).struct_name = "mlsys_constants";

          cds_data.sections (2).p = addr (mlsys_static);
          cds_data.sections (2).len = currentsize (mlsys_static);
          cds_data.sections (2).struct_name = "mlsys_static";

          cds_data.seg_name = MLSYS_DATA_;

          cds_data.num_exclude_names = 0;
          cds_data.exclude_array_ptr = null ();

          string (cds_data.switches) = "0"b;
          cds_data.switches.have_text = "1"b;               /* have constants ... */
          cds_data.switches.have_static = "1"b;             /* ... and static data */
          cds_data.switches.separate_static = "1"b;         /* in case we someday are prelinked */


/* Call create_data_segment_ */

          call create_data_segment_ (addr (cds_data), code);

          if code ^= 0 then call com_err_ (code, MLSYS_DATA_);

          return;
%page;
%include cds_args;

     end mlsys_data_;




		    mlsys_et_.alm                   11/05/86  1233.9r w 11/04/86  1038.2      118908



"  ***********************************************************
"  *                                                         *
"  * Copyright, (C) Honeywell Information Systems Inc., 1981 *
"  *                                                         *
"  ***********************************************************

" Error table for the Multics Mail System

" Created:  May 1981 by G. Palter
" Modified: June 1983 by G. Palter for new interface specification
" Modified: March 1984 by G. Palter to add incorrect_suffix


	name	mlsys_et_

	include	et_macros

	et	mlsys_et_


ec   address_pathname_expected,^path,
	(The pathname for the address was not supplied in the text.)

ec   address_pathname_too_long_to_q,pathlong,
	(Implementation restriction.  The inter-system mailer can not accept pathnames longer than 128 characters.)

ec   all_messages_deleted,allmsgdl,
	(All messages have been deleted.)

ec   already_marked_for_deletion,deleted,
	(Specified message has already been marked for subsequent deletion.)

ec   ambiguous_address,ambigadr,
	(The supplied name matches more than one entry in the system mail table.)

ec   bad_acknowledge_to,badackto,
	(The mail system does not support acknowledgements to the type of address specified in the message.)

ec   bad_explicit_route,badroute,
	(The explicit route supplied for this address does not allow for the delivery of mail to the address.)

ec   bad_mail_table,badmtabl,
	(The system mail table has been damaged.)

ec   ca_parse_failed,badca,
	(Errors were detected while scanning the command/request control arguments.)

ec   cant_be_deleted,cantdel,
	(Insufficient access to delete this message.)

ec   cant_compute_route,noroute,
	(Can not determine the route to be used to deliver mail to this address.)

ec   cant_determine_dtc,cntgtdt,
	(Can not determine the date/time created.)

ec   cant_determine_msgid,cntgtid,
	(Can not determine the Message-ID.)

ec   cant_determine_sender,cntgtsdr,
	(Can not determine the sender.)

ec   cant_parse_irt_field,cntgtirt,
	(Implementation restriction.  The printed representation of the In-Reply-To field can not be parsed.)

ec   cant_queue_mls_in_archive,cantqmls,
	(Implementation restriction.  The inter-system mailer can not process mailing lists which are archive components.)

ec   cant_send_acknowledgement,cantack,
	(An acknowledgement can not be delivered to the address specified in the message.)

ec   cant_update_message,cantupd,
	(Insufficient access to update the copy of this message in the mailbox.)

ec   circular_mtes,circmtes,
	(The supplied name in the system mail table expands directly or indirectly to itself.)

ec   comment_ignored,comignrd,
	(The comment was ignored.)

ec   deletion_pending,dlpend,
	(Specified action not performed due to an interrupted expunge_messages operation.)

ec   duplicate_address,dupaddr,
	(This recipient of the message was requested more than once.)

ec   duplicate_reply_reference,dupreply,
	(A reference to the given message already appears in the In-Reply-To field of this message.)

ec   duplicate_user_field,dupfield,
	(A user-defined field with the same name already appears in the message.)

ec   empty_address_list,emptylst,
	(The supplied address list is empty.)

ec   empty_address_text,noaddr,
	(The supplied text contains only comments and whitespace.)

ec   empty_mailing_list,emptymls,
	(The specified mailing list does not contain any recipients.)

ec   empty_message,emptymsg,
	(The body of the supplied message does not contain any text.)

ec   errors_in_list_address,badlist,
	(The message can not be delivered to all the recipients specified by this mailing list or named group.)

ec   extra_restricted_field,extrafld,
	(This field may not be duplicated.)

ec   foreign_address_too_long,fadrlong,
	(Implementation restriction.  The inter-system mailer can not accept foreign addresses longer than 128 characters.)

ec   forum_not_available,noforum,
	(Forum is not available on this system.)

ec   in_mailbox_only_field,inmbxfld,
	(The specified field may only appear in messages which have already been transmitted.)

ec   incomplete_address_list_text,incals,
	(The supplied text contains an incomplete address list specification.)

ec   incomplete_address_text,incaddr,
	(The supplied text contains an incomplete address specification.)

ec   incomplete_comment,incpcom,
	(The supplied comment is missing a Comment-Date or Comment-By field.)

ec   incomplete_named_group_text,incnmdgp,
	(The supplied text for a named group address does not end with a semi-colon.)

ec   incorrect_suffix,nosuffix,
	(The required suffix does not appear on the entry name.)

ec   invalid_address,badaddr,
	(The supplied address is invalid.)

ec   invalid_address_list_syntax,badals,
	(A syntax error was detected in the supplied address list specification.)

ec   invalid_address_syntax,badaddr,
	(A syntax error was detected in the supplied address specification.)

ec   invalid_mte_syntax,badmtenm,
	(The supplied mail table name is incorrectly formatted.)

ec   invalid_named_group_text,badnmdgp,
	(The supplied text for a named group address does not represent a valid address list.)

ec   invalid_person_id_syntax,badpers,
	(The supplied Person_id is incorrectly formatted.)

ec   invalid_relayed_field_syntax,badrelay,
	(A syntax error was detected in the supplied Relayed field.)

ec   invalid_route_field_syntax,badroute,
	(A syntax error was detected in the supplied Route field.)

ec   invalid_user_id_syntax,badusrnm,
	(The supplied Person_id.Project_id is incorrectly formatted.)

ec   ism_not_available,noism,
	(Inter-system mail is not available on this system.)

ec   list_address_is_all_duplicates,duplist,
	(All recipients of the message specified by this mailing list or named group were requested more than once.)

ec   logbox_created,madelog,
	(Your logbox has been created.)

ec   mailbox_exists,mbxexist,
	(The specified mailbox already exists.)

ec   mailbox_full,mbxfull,
	(There is no room in the mailbox to add the given message.)

ec   message_already_read,msgread,
	(The specified message has already been read from the mailbox.)

ec   message_delivered,msgsent,
	(The message was delivered to this recipient.)

ec   message_not_sent,msg^snt,
	(The message was not sent to any of the specified recipients.)

ec   message_partially_sent,msgpsnt,
	(The message was sent to some but not all of the specified recipients.)

ec   message_queued,msgq,
	(The message was queued for later delivery to this recipient.)

ec   message_queued_and_delivered,msgq&d,
	(The message was delivered to or queued for all the unique recipients in this mailing list or named group.)

ec   message_too_large,bigmsg,
	(This message is too large to ever fit in a mailbox.)

ec   missing_acknowledge_to,noackto,
	(The message does not specify a recipient for acknowledgements.)

ec   missing_host_name,nohost,
	(A host name must follow the symbol 'at', 'via', or '@'.)

ec   mte_not_found,nomte,
	(The supplied name was not found in the system mail table.)

ec   mte_not_mailbox,mte^mbx,
	(The supplied name in the system mail table does not identify a mailbox.)

ec   multiple_address_routes,>1route,
	(Only one set of address routing information may appear in an address.)

ec   no_a_permission,^a,
	(You do not have access to send messages to this mailbox.)

ec   no_ack_needed,noack,
	(The message does not request an acknowledgement.)

ec   no_address_pathname,nopath,
	(Specified address does not have an associated pathname.)

ec   no_address_route,noroute,
	(Specified foreign address does include an explicit/implicit route specification.)

ec   no_address_string,nostring,
	(Specified address does not have an associated text string.)

ec   no_comment_redistribution,nocomfwd,
	(A comment field in the message is not part of one of the redistributions of the message.)

ec   no_forum_this_ring,noforum,
	(Forum is not available in this ring.)

ec   no_logbox,nologbx,
	(Your logbox does not exist.)

ec   no_mailbox,nombx,
	(The specified mailbox does not exist.)

ec   no_mailing_list,nomls,
	(The specified mailing list does not exist.)

ec   no_mail_service,nomailer,
	(The system on which this address resides does not support an incoming mail service.)

ec   no_message_header,nohead,
	(There is no message header in the supplied text.)

ec   no_message_canonical_form,notext,
	(The canonical representation of this message is not available from the mailbox.)

ec   no_more_messages,nomore,
	(There are no newly arrived messages in this mailbox.)

ec   no_o_permission,^o,
	(You do not have access to read your messages in this mailbox.)

ec   no_pending_deletion,^dlpend,
	(There is no interrupted expunge_messages operation pending for this mailbox.)

ec   no_r_permission,^r,
	(You do not have access to read the messages in this mailbox.)

ec   no_recipients,^rcpts,
	(The message does not have any recipients.)

ec   no_s_permission,^s,
	(You do not have access to determine the number of messages in this mailbox.)

ec   no_savebox,nosavebx,
	(The specified savebox does not exist.)

ec   not_address,^addr,
	(Supplied data is not a mail system address.)

ec   not_address_list,^adrlist,
	(Supplied data is not a mail system address list.)

ec   not_foreign_address,^foreign,
	(Specified address is local to this system.)

ec   not_in_mailbox_message,^immsg,
	(Supplied message does not reside in a mailbox.)

ec   not_list_address,^listadr,
	(Specified address is not a mailing list or named group.)

ec   not_mail_table_address,^mtaddr,
	(Specified address does not identify an entry in the system mail-table.)

ec   not_marked_for_deletion,^deleted,
	(Specified message is not marked for subsequent deletion.)

ec   not_mailbox,^mbx,
	(Supplied data is not a mail system mailbox structure.)

ec   not_message,^msg,
	(Supplied data is not a mail system message structure.)

ec   not_message_trace,^trace,
	(Supplied data is not a mail system message_trace structure.)

ec   not_named_group_address,^namegrp,
	(Specified address is not a named group.)

ec   not_new_message,^newmsg,
	(Supplied message is not user-modifiable.)

ec   not_temporary_segment,^temp,
	(Specified segment is not a temporary segment created by the mail system.)

ec   obsolete_address_syntax,oldform,
	(An obsolete form of address specification was supplied.)

ec   only_address_route_allowed,notroute,
	(Only address routing information is allowed at this point in an address specification.)

ec   null_foreign_address,nullfadr,
	(Specified address does not include the actual address on the foreign system.)

ec   null_named_group_name,nullname,
	(Specified named group does not have a name.)

ec   null_search_string,nullsstr,
	(The supplied search string does not contain any non-whitespace characters.)

ec   read_only_address_list,rolist,
	(Supplied address list is not user-modifiable.)

ec   recursive_named_addresses,badname,
	(The content of a named address may not be another named address.)

ec   rejected_by_foreign_system,badaddr,
	(The foreign system rejected the mail destined for this recipient.)

ec   reserved_field_name,rsvfield,
	(Supplied field name is reserved for use by the mail system.)

ec   route_out_of_service,deadrout,
	(The route used to send mail to this address is temporarily out of service.)

ec   savebox_created,madesave,
	(The specified savebox has been created.)

ec   some_messages_not_deleted,^msgsdl,
	(One or more messages could not be deleted.)

ec   text_follows_address,extratxt,
	(Text follows the logical end of an address specification.)

ec   text_follows_route,extratxt,
	(Text follows the logical end of an implicit route.)

ec   text_parse_failed,badtext,
	(Errors were detected while parsing the supplied text.)

ec   too_many_recipients,tmrecipt,
	(There are too many recipients specified for the message.)

ec   unable_to_queue_mail,cantq,
	(The message can not be queued for later delivery to this address.)

ec   unbalanced_braces,unbbrace,
	(Braces do not balance.)

ec   unbalanced_parentheses,unbparen,
	(Parentheses do not balance.)

ec   unbalanced_quotes,unbquote,
	(Quotes do not balance.)

ec   unknown_body_section_type,unkbody,
	(Supplied message body section is of a type not supported by the mail system.)

ec   unknown_delivery_mode,unkdlvr,
	(Supplied delivery mode is not supported by the mail system.)

ec   unknown_message_id,unkmsgid,
	(Supplied Message-ID is not registered with the mail system.)

ec   unknown_queued_notify_mode,unkqnmd,
	(Supplied queued notification mode is not supported by the mail syste.)

ec   unknown_queueing_mode,unkqmode,
	(Supplied queueing mode is not supported by the mail system.)

ec   unknown_structured_address_type,unksat,
	(Specified type of local address is not supported by the mail system.)

ec   unknown_system,^host,
	(Specified foreign system is not known to this system.)

ec   unknown_user_field_id,ufieldid,
	(Supplied user-defined field ID is not registered with the mail system.)

ec   unknown_user_field_type,ufieldtp,
	(Supplied user-defined field is of a type not supported by the mail system.)

ec   unsupported_reserved_field_name,unsfield,
	(Supplied field name is reserved for future use by the mail system.)

	end




		    mlsys_field_id_mgr_.pl1         06/30/86  1410.2r w 06/30/86  1343.8      127296



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* format: off */

/* User-defined field name/ID management for the Multics Mail System */

/* Created:  July 1983 by G. Palter */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


mlsys_field_id_mgr_:
     procedure () options (rename ((alloc_, mlsys_storage_mgr_$allocate)));

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_field_name character (*) parameter;		/* get_system_field_type: the field name to be checked;
						   get_user_field_id: the field name to be encoded */

dcl  P_field_id bit (36) aligned parameter;		/* get_user_field_id: set to the unique field ID;
						   get_user_field_name: the field ID whose name is wanted */

dcl  P_canonical_field_name character (*) varying parameter;/* get_user_field_id, get_user_field_name: set to the
						   canonical form of the user-defined field name */

dcl  P_field_type fixed binary parameter;		/* get_system_field_id: set to the type of field supplied */

dcl  P_code fixed binary (35) parameter;


/* Local copies of parameters */

dcl  field_type fixed binary;


/* User-defined field name hash table */

dcl  1 encoded_field_id aligned,			/* the encoding used in field IDs ... */
       2 bucket_idx fixed binary (18) unaligned unsigned,	/* ... in which bucket this field name may be found */
       2 n_steps fixed binary (18) unaligned unsigned;	/* ... # of steps from base of bucket to the name */

dcl  1 field_name_slot aligned based (field_name_slot_ptr), /* a single slot in the hash table ... */
       2 next_slot_ptr pointer,			/* ... -> next slot in the hash table */
       2 field_name_lth fixed binary (21),		/* ... length of the field name in this slot */
       2 field_name character (field_name_slot_field_name_lth refer (field_name_slot.field_name_lth));
dcl  (field_name_slot_ptr, last_field_name_slot_ptr) pointer;
dcl  field_name_slot_field_name_lth fixed binary (21);


/* Remaining declarations */

dcl  n_real_steps fixed binary;

dcl  HYPHEN character (1) static options (constant) initial ("-");
dcl  HTSP character (2) static options (constant) initial ("	 ");

/* format: off */
dcl (UPPERCASE	initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
     LOWERCASE	initial ("abcdefghijklmnopqrstuvwxyz"))
	character (26) static options (constant);

dcl (error_table_$smallarg, mlsys_et_$reserved_field_name, mlsys_et_$unknown_user_field_id,
     mlsys_et_$unsupported_reserved_field_name)
	fixed binary (35) external;
/* format: on */

dcl  mlsys_hash_$hash entry (character (*), fixed binary) returns (fixed binary);

dcl  (dimension, divide, hbound, index, lbound, length, ltrim, maxlength, null, rtrim, search, substr, translate, unspec,
     verify) builtin;
%page;
/* format: off */

dcl  FIELD_TYPES_BASE_MULTIPLIER fixed binary static options (constant) initial (100);
						/* to get from field_type_bases to real base value */


/* Recognized field name prefixes used to change the class of a header field */

dcl  RECOGNIZED_PREFIXES (5) character (32) varying static options (constant) initial (
	"Redistributed-",	"Remailed-",	"Resent-",	"Forwarded-",	"Comment-");

dcl  FIELD_TYPE_BASES (5) fixed binary static options (constant) initial (
	1,		1,		1,		1,		2);


/* Indicates which combination of field name and class are actually supported by the mail system */

dcl  SUPPORTED_FIELDS (0:2, 18) bit (1) aligned static options (constant) initial (
	/*** ordinary fields */
	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,
	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,
	/*** redistribution fields */
	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,	"1"b,
	"0"b,	"0"b,	"1"b,	"0"b,	"0"b,	"0"b,	"0"b,	"1"b,	"1"b,
	/*** comment fields */
	"0"b,	"1"b,	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"1"b,	"0"b,
	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"1"b,	"0"b);


/* All known canonical field names sorted in the ASCII collating sequence for use within lookup_field_name */

dcl  SORTED_FIELD_NAMES (25) character (32) static options (constant) initial (
	"Access-Class",	"Acknowledge-To",	"Bcc",		"By",		"Cc",
	"Comment",	"Comments",	"Date",		"Delivery-By",	"Delivery-Date",
	"From",		"In-Reply-To",	"Message-Id",	"Posted-Date",	"Re",
	"Received",	"Relayed",	"Reply-To",	"Return-Path",	"Route",
	"Sender",		"Subj",		"Subject",	"To",		"Via");

dcl  SORTED_FIELD_TYPES (25) fixed binary static options (constant) initial (
	16,		 7,		14,		 2,		13,
	17,		17,		8,		 6,		 5,
	 9,		15,		18,		 1,		10,
	 4,		 4,		11,		 3,		 3,
	 2,		10,		10,		12,		 4);

/* format: on */
%page;
/* Determine if a given field name identifies a field supported by the system and, if so, return the type of the field */

get_system_field_type:
     entry (P_field_name, P_field_type, P_code);

	call lookup_field_name ((P_field_name), P_field_type, P_code);
						/* try the input name first as an optimization */

	if P_code = mlsys_et_$unsupported_reserved_field_name then return;
	if (P_field_type ^= USER_DEFINED_FIELD) & (P_code = 0) then return;

	begin;					/* optimization failed: we must canonicalize the name */

dcl  canonical_field_name character (length (P_field_name)) varying;

	     call canonicalize_field_name (P_field_name, canonical_field_name);

	     call lookup_field_name (canonical_field_name, P_field_type, P_code);
	end;

	return;
%page;
/* Determine the per-process unique ID for a supplied user-defined field name along with the canonical form of said field
   name; an error code is returned, however, if the supplied field name is one of those reserved for use by the mail
   system */

get_user_field_id:
     entry (P_field_name, P_field_id, P_canonical_field_name, P_code);

	begin;

dcl  canonical_field_name character (length (P_field_name)) varying;

	     call canonicalize_field_name (P_field_name, canonical_field_name);

	     call lookup_field_name (canonical_field_name, field_type, P_code);
	     if P_code ^= 0 then return;		/* a field that's reserved for possible future use */

	     if field_type ^= USER_DEFINED_FIELD then do;
		P_code = mlsys_et_$reserved_field_name;
		return;
	     end;

	     encoded_field_id.bucket_idx =
		mlsys_hash_$hash ((canonical_field_name),
		dimension (hash_tables_segment.field_name_hash_table.buckets, 1));
	     encoded_field_id.n_steps = 0;		/* assume it's the first one in this bucket ... */

	     last_field_name_slot_ptr = null ();	/* needed in case we must add a new slot */
	     do field_name_slot_ptr = hash_tables_segment.field_name_hash_table.buckets (encoded_field_id.bucket_idx)
		repeat (field_name_slot.next_slot_ptr) while (field_name_slot_ptr ^= null ());
		if field_name_slot.field_name = canonical_field_name then go to HAVE_ENCODED_FIELD_ID;
		encoded_field_id.n_steps = encoded_field_id.n_steps + 1;
		last_field_name_slot_ptr = field_name_slot_ptr;
	     end;

	     /*** Control arrives here iff there's no matching field name already in the hash table */
	     field_name_slot_field_name_lth = length (canonical_field_name);
	     allocate field_name_slot in (hash_tables_segment.hash_area) set (field_name_slot_ptr);
	     field_name_slot.field_name = canonical_field_name;
	     field_name_slot.next_slot_ptr = null ();
	     if last_field_name_slot_ptr = null () then	/* first one in this bucket */
		hash_tables_segment.field_name_hash_table.buckets (encoded_field_id.bucket_idx) = field_name_slot_ptr;
	     else last_field_name_slot_ptr -> field_name_slot.next_slot_ptr = field_name_slot_ptr;

	     /*** Control arrives here once the field ID has been determined */
HAVE_ENCODED_FIELD_ID:
	     unspec (P_field_id) = unspec (encoded_field_id);
	     P_canonical_field_name = canonical_field_name;

	     if length (canonical_field_name) > maxlength (P_canonical_field_name) then
		P_code = error_table_$smallarg;	/* didn't fit */
	     else P_code = 0;
	end;

	return;
%page;
/* Return the canonical form of the user-defined field name corresponding to the given unique ID */

get_user_field_name:
     entry (P_field_id, P_canonical_field_name, P_code);

	unspec (encoded_field_id) = unspec (P_field_id);	/* get the field ID into usable form */

	if (encoded_field_id.bucket_idx < lbound (hash_tables_segment.field_name_hash_table.buckets, 1))
	     | (encoded_field_id.bucket_idx > hbound (hash_tables_segment.field_name_hash_table.buckets, 1)) then do;
UNKNOWN_FIELD_ID:
	     P_code = mlsys_et_$unknown_user_field_id;
	     return;
	end;

	n_real_steps = 0;
	do field_name_slot_ptr = hash_tables_segment.field_name_hash_table.buckets (encoded_field_id.bucket_idx)
	     repeat (field_name_slot.next_slot_ptr) while (field_name_slot_ptr ^= null ());
	     if n_real_steps = encoded_field_id.n_steps then do;
		if field_name_slot.field_name_lth <= maxlength (P_canonical_field_name) then do;
		     P_canonical_field_name = field_name_slot.field_name;
		     P_code = 0;			/* ... it fits */
		end;
		else P_code = error_table_$smallarg;
		return;
	     end;
	     n_real_steps = n_real_steps + 1;		/* not the right slot yet ... */
	end;

	go to UNKNOWN_FIELD_ID;			/* we get here iff there aren't enough slots in the bucket */
%page;
/* Return the type of a header/envelope/redistribution field given its name */

lookup_field_name:
     procedure (p_canonical_field_name, p_field_type, p_code);

dcl  p_canonical_field_name character (*) varying parameter;
dcl  p_field_type fixed binary parameter;
dcl  p_code fixed binary (35) parameter;

dcl  prefixless_field_name character (length (p_canonical_field_name)) varying;
dcl  (field_type_base, field_type, name_idx, lb, hb, idx) fixed binary;

	field_type_base = ORDINARY_FIELDS_BASE;		/* until proven otherwise */
	prefixless_field_name = p_canonical_field_name;

	do idx = lbound (RECOGNIZED_PREFIXES, 1) to hbound (RECOGNIZED_PREFIXES, 1)
	     while (field_type_base = ORDINARY_FIELDS_BASE);
	     if length (RECOGNIZED_PREFIXES (idx)) < length (prefixless_field_name) then
		if substr (prefixless_field_name, 1, length (RECOGNIZED_PREFIXES (idx))) = RECOGNIZED_PREFIXES (idx)
		then do;
		     prefixless_field_name = substr (prefixless_field_name, (length (RECOGNIZED_PREFIXES (idx)) + 1));
		     field_type_base = FIELD_TYPE_BASES (idx);
		end;
	end;

	lb = lbound (SORTED_FIELD_NAMES, 1);		/* prepare for binary search */
	hb = hbound (SORTED_FIELD_NAMES, 1);
	field_type = USER_DEFINED_FIELD;

	do while ((field_type = USER_DEFINED_FIELD) & (hb >= lb));
	     name_idx = divide ((hb + lb), 2, 17, 0);
	     if prefixless_field_name = SORTED_FIELD_NAMES (name_idx) then field_type = SORTED_FIELD_TYPES (name_idx);
	     else if prefixless_field_name > SORTED_FIELD_NAMES (name_idx) then lb = name_idx + 1;
	     else hb = name_idx - 1;
	end;

	if field_type ^= USER_DEFINED_FIELD then
	     if SUPPORTED_FIELDS (field_type_base, field_type) then
		field_type = field_type + (FIELD_TYPES_BASE_MULTIPLIER * field_type_base);
	     else do;				/* reserved for future use */
		p_code = mlsys_et_$unsupported_reserved_field_name;
		return;
	     end;

	if field_type = COMMENT_FIELD then field_type = field_type + COMMENT_FIELDS_BASE;

	p_field_type = field_type;			/* here iff the field type is OK */
	p_code = 0;

	return;

     end lookup_field_name;
%page;
/* Create the canonical form of a field name:  The canonical form is created by replacing each sequence of whitespace with
   a single "-" and translating the first character of each resulting "token" to uppercase while translating the remaining
   characters in the "token" to lowercase */

canonicalize_field_name:
     procedure (p_field_name, p_canonical_field_name);

dcl  p_field_name character (*) parameter;
dcl  p_canonical_field_name character (*) varying parameter;

dcl  (start, token_lth, idx) fixed binary (21);

	begin;					/* caller's canonical_field_name is always large enough */

dcl  field_name character (length (p_field_name)) varying;
dcl  canonical_field_name character (maxlength (p_canonical_field_name)) varying;

	     field_name = ltrim (rtrim (p_field_name, HTSP), HTSP);
						/* copy input while removing leading/trailing whitespace */
	     canonical_field_name = "";		/* start out with nothing */

	     start = 1;
	     do while (start <= length (field_name));
		idx = search (substr (field_name, start), HTSP);
		if idx = 0 then do;			/* no more whitespace in the name */
		     canonical_field_name = canonical_field_name || substr (field_name, start);
		     start = length (field_name) + 1;
		end;
		else do;
		     canonical_field_name = canonical_field_name || substr (field_name, start, (idx - 1));
		     canonical_field_name = canonical_field_name || HYPHEN;
						/* replace whitespace with a hyphen */
		     start = start + idx;		/* past all the whitespace ... */
		     idx = verify (substr (field_name, start), HTSP);
		     if idx > 1 then start = start + idx - 1;
		end;
	     end;

	     start = 1;				/* now to fix the "tokens" */
	     do while (start <= length (canonical_field_name));
		idx = index (substr (canonical_field_name, start), HYPHEN);
		if idx = 0 then			/* the last token ... */
		     token_lth = length (canonical_field_name) - start + 1;
		else token_lth = idx - 1;
		if token_lth > 0 then		/* there's a least one character ... */
		     substr (canonical_field_name, start, 1) =
			translate (substr (canonical_field_name, start, 1), UPPERCASE, LOWERCASE);
		if token_lth > 1 then		/* ... and there's more than one, in fact */
		     substr (canonical_field_name, (start + 1), (token_lth - 1)) =
			translate (substr (canonical_field_name, (start + 1), (token_lth - 1)), LOWERCASE,
			UPPERCASE);
		start = start + token_lth + 1;	/* move past the "token" and the hyphen */
	     end;

	     p_canonical_field_name = canonical_field_name;
	end;

	return;

     end canonicalize_field_name;
%page;
%include mlsys_hash_tables_seg;
%page;
%include mlsys_internal_data;
%page;
%include mlsys_field_types;

     end mlsys_field_id_mgr_;




		    mlsys_fips98_.pl1               10/27/83  1606.7rew 10/27/83  1438.3       17073



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* format: off */

/* Mail System Utilities which encode/decode a message according to the Federal Information Processing Standard #98
      format for CBMS messages */

/* Created:  September 1983 by G. Palter as an interim measure until FIPS-98 support is actually implemented */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


mlsys_fips98_:
     procedure ();

	return;					/* not an entrypoint */


/* decode_message Parameters */

dcl  P_fips98_message_bytes (*) bit (9) unaligned parameter;/* the FIPS-98 encoding of the message */
dcl  P_message_version character (8) parameter;		/* version of message structure desired by caller */
dcl  P_im_message_info_ptr pointer parameter;		/* ->im_message_info describing the in-mailbox message */
dcl  P_last_delivered_by pointer;			/* -> address of user ring-1 claims delivered the message */
dcl  P_last_date_time_delivered fixed binary (71) parameter;/* date/time when ring-1 delivered the message */
dcl  P_requests_acknowledgement bit (1) aligned parameter;	/* ON => the message expects an acknowledgement */
dcl  P_message_ptr pointer parameter;			/* set -> the message created by this entrypoint */
dcl  P_code fixed binary (35) parameter;



/* Converts the FIPS-98 encoding of an in-mailbox message into its internal representation */

decode_message:
     entry (P_fips98_message_bytes, P_message_version, P_im_message_info_ptr, P_last_delivered_by,
	P_last_date_time_delivered, P_requests_acknowledgement, P_message_ptr, P_code);

	P_code = -1;				/* not yet implemented */

	return;

     end mlsys_fips98_;




		    mlsys_format_.pl1               04/26/87  1602.0rew 04/26/87  1555.0     1421154



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(83-07-01,Palter), approve(), audit(), install():
     Pre-hcom comments:
     Created:  July 1983 by G. Palter
     Modified: March 1984 by G. Palter to fix the following mail system errors:
        #0426 -- when formatting an address comment, if the comment has to be quoted, the formatter leaves off the closing
           quote character
        #0434 -- when a message is mailed to a forum, the mail system formats the header using the brief formatting mode.
           As a result, most of the header fields, including user-defined fields, are omitted from the copy in the forum
           making replies, etc. difficult
        #0436 -- if a forum meeting is not found in the "forum" search list, the mail system will treat it as a version 1
           forum in the working directory
  2) change(87-04-09,Lippard), approve(86-11-24,MCR7576),
     audit(87-04-21,Dickson), install(87-04-26,MR12.1-1026):
     Modified to use time_names.incl.pl1 instead of time_zones_.incl.pl1.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Mail System Utilities which convert the internal form of various mail system objects (messages, addresses, etc.) into
   their printed representations */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen,^indcomtxt */


mlsys_format_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_fieldname character (*) varying parameter;		/* name of the field being printed */

dcl  P_line_length fixed binary parameter;		/* line length for folding; -1 => no folding */

dcl  P_buffer_ptr pointer parameter;			/* -> user's output buffer for formatting entries */
dcl  P_buffer_size fixed binary (21) parameter;		/* size of user's buffer */
dcl  P_buffer_used fixed binary (21) parameter;		/* amount of said buffer in use at any time (input/output) */

dcl  P_output_switch pointer parameter;			/* -> IOCB on which to print results */

dcl  P_code fixed binary (35) parameter;

dcl  P_message_ptr pointer parameter;			/* *_message, format_message_canonical_form,
						   format_message_for_*, format_canon_redistributed_msg:
						      -> the message to be formatted or printed;
						   *_message_envelope, *_message_header,
						   *_redistributions_list, *_message_body: -> message
						      containing the specified part to be printed/formatted */

dcl  P_format_message_options_ptr pointer parameter;	/* format_message, print_message,
						   format_message_canonical_form: -> options describing how to
						      format the message */

dcl  P_buffer_size_words fixed binary (19) parameter;	/* format_message_for_mailbox, format_canon_redistributed_msg:
						      size of available buffer in words */
dcl  P_buffer_used_words fixed binary (19) parameter;	/* format_message_for_mailbox, format_canon_redistributed_msg:
						      set to # of words occupied by message text and data
						      structures */

dcl  P_original_mf_ptr pointer parameter;		/* format_canon_redistributed_msg: -> mail_format structure of
						      original message */
dcl  P_original_mf_extension_ptr pointer parameter;	/* format_canon_redistributed_msg: -> mf_extension strucutre
						      of original message */

dcl  P_formatting_mode fixed binary parameter;		/* *_message_envelope, *_message_header,
						   *_redistributions_list: controls how the specified part
						      will be printed/formatted */

dcl  P_message_trace_ptr pointer parameter;		/* *_message_trace: -> the message trace to format/print */
dcl  P_format_redistribution_trace bit (1) aligned parameter;
						/* *_message_trace: ON => include "Redistributed-" prefix in
						      the trace field names */

dcl  P_access_class bit (72) aligned parameter;		/* *_access_class_field: the access class to format/print */

dcl  P_address_ptr pointer parameter;			/* *_address_field: -> the address to format/print */

dcl  P_address_list_ptr pointer parameter;		/* *_address_list_field: -> address list to format/print */

dcl  P_date_time fixed binary (71) parameter;		/* *_date_time_field: the date/time to format/print */
dcl  P_include_dow bit (1) aligned parameter;		/* *_date_time_field: ON => include day of week in output */

dcl  P_message_id bit (72) aligned parameter;		/* *_message_id_field: the Message-ID to format/print */

dcl  P_message_references_list_ptr pointer parameter;	/* *_references_list_field: -> the list of references to
						      format/print */

dcl  P_text character (*) parameter;			/* *_text_field: the text to format/print */
dcl  P_multiline_text bit (1) aligned parameter;		/* *_text_field: ON => format the text as a multiline field */

dcl  P_message_body_section_parameter_ptr pointer parameter;/* *_body_section: -> the body section to format/print */

dcl  P_address_string character (*) varying parameter;	/* format_address_for_ism: the actual address on the foreign
						      system to which the message will be sent */
dcl  P_address_route_ptr pointer parameter;		/* format_address_for_ism: -> the route to be used to send the
						      message */
dcl  P_user_name character (*) varying parameter;		/* format_address_for_ism: set to the "user name" to be
						      supplied to the inter-system mailer */
dcl  P_host_name character (*) varying parameter;		/* format_address_for_ism: set to the host name to be supplied
						      to the inter-system mailer */
/**** format: indcomtxt */


/* Local copies of parameters */

dcl  buffer character (buffer_size) unaligned based (buffer_ptr);
dcl  buffer_ptr pointer;
dcl  (buffer_size, buffer_used) fixed binary (21);

dcl  output_switch pointer;

dcl  original_mf_ptr pointer;
dcl  original_mf_extension_ptr pointer;

dcl  code fixed binary (35);


/* Remaining declarations */

dcl  printing bit (1) aligned;			/* ON => print the results; OFF => returns them to caller */

/* format: ^indcomtxt */
dcl  1 ifo aligned,					/* internal formatting options */
       2 buffer_overflow entry () variable,		/* ... procedure to be invoked when output buffer overflows */
       2 line_length fixed binary,			/* ... line length to use for folding (if enabled) */
       2 indentation fixed binary,			/* ... continuation lines are indented by this # of spaces */
       2 flags aligned,
         3 rfc822_format bit (1),			/* ... ON => use RFC822 formatting rules; OFF => use ours */
         3 forum_format bit (1),			/* ... ON => formatting for inclusion in a forum */
         3 include_local_system_name bit (1),		/* ... ON => put local system name on all local addresses */
         3 dont_canonicalize_system_names bit (1),	/* ... ON => don't convert system names to canonical form */
         3 dont_show_logsave bit (1),			/* ... ON => don't use {logbox} / {save path} format */
         3 wrap bit (1),				/* ... ON => fold overly long lines to the requested length */
         3 count_lines bit (1),			/* ... ON => count the # of lines formatted/printed */
         3 include_message_id bit (1),			/* ... ON => always include the Message-ID */
         3 include_trace bit (1),			/* ... ON => always include message/redistribution traces */
         3 reverse_redistributions bit (1),		/* ... ON => put redistributions before envelope/header and
							   in reverse chronological order (newest first) */
         3 use_canonical_fieldnames bit (1),		/* ... ON => use canonical names of cc/bcc fields */
         3 build_mf_extension bit (1),			/* ... ON => construct list of text fragments to be examined
							   by subsequent string searches */
         3 include_forum_suffix bit (1);		/* ... ON => include suffix of forum meeting when formatting
							   addresses as it will have to be parsed later */

dcl  1 mail_format_header aligned like mail_format.header based (mail_format_ptr);
dcl  mail_format_header_lth fixed binary (21);

dcl  original_mf_text character (original_mf_ptr -> mail_format.text_len) unaligned
	based (addr (original_mf_ptr -> mail_format.text));
dcl  new_mf_extension_ptr pointer;

dcl  last_column_used fixed binary;			/* last character of formatted text is in this column */
dcl  line_count fixed binary;				/* # of lines printed/formatted */

dcl  local_buffer character (256);			/* buffer used by the print_* entrypoints */

dcl  full_fieldname character (64) varying;

dcl  need_separator bit (1) aligned;

dcl  (idx, jdx) fixed binary;

/* format: off */
dcl (CANONICAL_BCC_FIELDNAME		initial ("Bcc"),
     CANONICAL_CC_FIELDNAME		initial ("Cc"),
     RESENT_PREFIX			initial ("Resent-"),
     RECIPIENTS_FIELDNAME		initial ("Recipients"),
     COMMENT_FIELDNAME		initial ("Comment"),
     LAST_RESENT_FIELDNAME		initial ("Last-Resent"),
     LAST_REDISTRIBUTED_FIELDNAME	initial ("Last-Redistributed"))
	character (32) varying static options (constant);
/* format: on */

dcl  MAX_MULTILINE_INDENTATION fixed binary static options (constant) initial (15);
dcl  STANDARD_MULTILINE_INDENTATION fixed binary static options (constant) initial (10);
dcl  MULTILINE_BLANK_LINE_DESIGNATOR character (2) static options (constant) initial ("--");

dcl  STACK_EXTENSION fixed binary (18) static options (constant) initial (128);

dcl  FIELDNAME_SUFFIX character (3) static options (constant) initial (":  ");

dcl  SPACES character (32) static options (constant) initial ((32)" ");

dcl  SINGLE_WIDTH_CHARACTERS character (95) static options (constant)
	initial (" !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");

dcl  ONE_MINUTE fixed binary (71) static options (constant) initial (60000000);
dcl  ONE_HOUR fixed binary static options (constant) initial (60);

/* format: off */
dcl (UPPERCASE	initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
     LOWERCASE	initial ("abcdefghijklmnopqrstuvwxyz"))
	character (26) static options (constant);

dcl  MONTHS (12) character (12) varying static options (constant) initial (
	"January",     "February",	"March",		"April",		"May",	     "June",
	"July",	     "August",	"September",	"October",	"November",    "December");
dcl  RFC822_MONTHS (12) character (3) static options (constant) initial (
	"Jan",	     "Feb",	"Mar",		"Apr",		"May",	     "Jun",
	"Jul",	     "Aug",	"Sep",		"Oct",		"Nov",	     "Dec");

dcl  DAY_OF_WEEKS (7) character (12) varying static options (constant) initial (
	"Monday",	     "Tuesday",	"Wednesday",	"Thursday",	"Friday",	     "Saturday",    "Sunday");
dcl  RFC822_DAY_OF_WEEKS (7) character (3) static options (constant) initial (
	"Mon",	     "Tue",	"Wed",		"Thu",		"Fri",	     "Sat",	"Sun");

dcl  RFC822_ZONES (35) character (4) static options (constant) initial (
	"GMT",	"UT",	"EST",	"EDT",	"CST",	"CDT",	"MST",	"MDT",	"PST",	"PDT",
	"Z",	"A",	"B",	"C",	"D",	"E",	"F",	"G",	"H",	"I",
	"K",	"L",	"M",	"N",	"O",	"P",	"Q",	"R",	"S",	"T",
	"U",	"V",	"W",	"X",	"Y");
dcl  RFC822_ZONE_OFFSETS (35) fixed binary static options (constant) initial (
	   0,	   0,	-300,	-240,	-360,	-300,	-420,	-360,	-480,	-420,
	   0,	 -60,	-120,	-180,	-240,	-300,	-360,	-420,	-480,	-540,
	-600,	-660,	-720,	  60,	 120,	 180,	 240,	 300,	 360,	 420,
	 480,	 540,	 600,	 660,	 720);
/* format: on */

dcl  time_data_$time_delta fixed binary (71) external;

dcl  sys_info$access_class_ceiling bit (72) aligned external;

dcl  iox_$user_output pointer external;

/* format: off */
dcl  (error_table_$bad_subr_arg, error_table_$inconsistent, error_table_$smallarg, error_table_$unimplemented_version,
      mlsys_et_$foreign_address_too_long, mlsys_et_$not_address_list, mlsys_et_$not_message, mlsys_et_$not_message_trace,
      mlsys_et_$unknown_body_section_type)
	fixed binary (35) external;
/* format: on */

dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  convert_authorization_$to_string_short entry (bit (72) aligned, character (*), fixed binary (35));
dcl  cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35));
dcl  decode_clock_value_$date_time
	entry (fixed binary (71), fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary,
	fixed binary (71), fixed binary, character (3), fixed binary (35));
dcl  get_authorization_ entry () returns (bit (72) aligned);
dcl  get_line_length_$switch entry (pointer, fixed binary (35)) returns (fixed binary);
dcl  ioa_$rsnnl entry () options (variable);
dcl  iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  mail_system_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mail_system_$decode_message_id
	entry (bit (72) aligned, character (*) varying, character (256) varying, bit (1) aligned, fixed binary (35));
dcl  mail_system_$expand_list_address entry (pointer, character (8), pointer, fixed binary (35));
dcl  mail_system_$get_address_comment entry (pointer, character (*) varying, fixed binary (35));
dcl  mail_system_$get_address_name entry (pointer, character (*) varying, fixed binary (35));
dcl  mail_system_$get_address_pathname entry (pointer, character (*), character (*), character (*), fixed binary (35));
dcl  mail_system_$get_address_route entry (pointer, character (8), pointer, fixed binary (35));
dcl  mail_system_$get_address_string entry (pointer, character (*) varying, fixed binary (35));
dcl  mail_system_$get_address_system entry (pointer, character (256) varying, fixed binary (35));
dcl  mail_system_$get_address_type entry (pointer, fixed binary, fixed binary (35));
dcl  mail_system_$get_named_group_display_flag entry (pointer, bit (1) aligned, fixed binary (35));
dcl  mail_system_$get_user_field_name entry (bit (36) aligned, character (*) varying, fixed binary (35));
dcl  mlsys_misc_utils_$get_best_address_name entry (pointer, character (*) varying, fixed binary (35));
dcl  mlsys_nit_interface_$canonicalize_system_name entry (character (256) varying) returns (character (256) varying);
dcl  mlsys_nit_interface_$get_local_system_name entry () returns (character (256) varying);
dcl  mlsys_nit_interface_$is_local_system entry (character (256) varying) returns (bit (1) aligned);
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  pathname_$component entry (character (*), character (*), character (*)) returns (character (194));

dcl  (abs, addcharno, addr, addwordno, after, binary, bit, clock, convert, currentsize, divide, hbound, index, lbound,
     length, ltrim, max, maxlength, min, mod, null, reverse, rtrim, search, size, string, substr, translate, unspec,
     verify) builtin;
%page;
/* Convert a message into its printed representation */

format_message:					/* ... into the caller's buffer */
     entry (P_message_ptr, P_format_message_options_ptr, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_MESSAGE_COMMON;


print_message:					/* ... and print it on the given output switch */
     entry (P_message_ptr, P_format_message_options_ptr, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_MESSAGE_COMMON:
	message_ptr = P_message_ptr;
	format_message_options_ptr = P_format_message_options_ptr;

	if message.version ^= MESSAGE_VERSION_2 then do;
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	if format_message_options.version ^= FORMAT_MESSAGE_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if (format_message_options.envelope_formatting_mode < NONE_FORMATTING_MODE)
	     | (format_message_options.envelope_formatting_mode > LONG_FORMATTING_MODE)
	     | (format_message_options.envelope_formatting_mode = BRIEF_FORMATTING_MODE)
	     | (format_message_options.header_formatting_mode < NONE_FORMATTING_MODE)
	     | (format_message_options.header_formatting_mode > LONG_FORMATTING_MODE)
	     | (format_message_options.redistributions_list_formatting_mode < NONE_FORMATTING_MODE)
	     | (format_message_options.redistributions_list_formatting_mode > LONG_FORMATTING_MODE) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	if (format_message_options.envelope_formatting_mode = NONE_FORMATTING_MODE)
	     & (format_message_options.header_formatting_mode = NONE_FORMATTING_MODE)
	     & (format_message_options.redistributions_list_formatting_mode = NONE_FORMATTING_MODE)
	     & ^format_message_options.include_body then do;
	     P_code = error_table_$inconsistent;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = format_message_options.line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (format_message_options.line_length = 0) then ;
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	need_separator =
	     (format_message_options.envelope_formatting_mode ^= NONE_FORMATTING_MODE)
	     | (format_message_options.header_formatting_mode ^= NONE_FORMATTING_MODE)
	     | (format_message_options.redistributions_list_formatting_mode ^= NONE_FORMATTING_MODE);

	if format_message_options.envelope_formatting_mode ^= NONE_FORMATTING_MODE then
	     call format_envelope (addr (message.envelope), "0"b, message.date_time_created, message.from,
		format_message_options.envelope_formatting_mode);

	if format_message_options.header_formatting_mode ^= NONE_FORMATTING_MODE then
	     call format_header (format_message_options.header_formatting_mode);

	if format_message_options.redistributions_list_formatting_mode ^= NONE_FORMATTING_MODE then
	     call format_redistributions_list_internal (format_message_options.redistributions_list_formatting_mode);

	if format_message_options.include_body then do;	/* and now the body ... */
	     if need_separator then call add_to_buffer_fixed (NL);
	     call format_body ();
	end;

	if printing then				/* dump the last part */
	     call print_buffer ();
	else P_buffer_used = buffer_used;

	P_code = 0;

	return;
%page;
/* Convert a message into its canonical form:  The canonical form of a message is the text used by the mail system when it
   stores the message in a mailbox */

format_message_canonical_form:
     entry (P_message_ptr, P_format_message_options_ptr, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	message_ptr = P_message_ptr;
	if message.version ^= MESSAGE_VERSION_2 then do;	/* simple validity check */
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	format_message_options_ptr = P_format_message_options_ptr;
	if format_message_options.version ^= FORMAT_MESSAGE_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if format_message_options.line_length ^= -1 then do;
	     P_code = error_table_$bad_subr_arg;	/* canonical form is not allowed to have wrapped fields */
	     return;
	end;

	if ((format_message_options.envelope_formatting_mode ^= NONE_FORMATTING_MODE)
	     & (format_message_options.envelope_formatting_mode ^= DEFAULT_FORMATTING_MODE))
	     | ((format_message_options.header_formatting_mode ^= NONE_FORMATTING_MODE)
	     & (format_message_options.header_formatting_mode ^= DEFAULT_FORMATTING_MODE))
	     | ((format_message_options.redistributions_list_formatting_mode ^= NONE_FORMATTING_MODE)
	     & (format_message_options.redistributions_list_formatting_mode ^= DEFAULT_FORMATTING_MODE)) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	if (format_message_options.envelope_formatting_mode = NONE_FORMATTING_MODE)
	     & (format_message_options.header_formatting_mode = NONE_FORMATTING_MODE)
	     & (format_message_options.redistributions_list_formatting_mode = NONE_FORMATTING_MODE)
	     & ^format_message_options.include_body then do;
	     P_code = error_table_$inconsistent;
	     return;
	end;

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	string (ifo.flags) = ""b;			/* standard formatting options, but ... */
	ifo.rfc822_format = "0"b;			/* ... standard Multics format */
	ifo.forum_format = "0"b;			/* ... never suppress anything important */
	ifo.include_message_id = "1"b;		/* ... always include the Message-ID fields */
	ifo.include_trace = "1"b;			/* ... always include the message/redistribution traces */
	ifo.reverse_redistributions = "1"b;		/* ... put redistributions list first */
	ifo.use_canonical_fieldnames = "1"b;		/* ... use the canonical names of the cc/bcc fields */
	ifo.include_forum_suffix = "1"b;		/* ... need to distinguish forum versions later */

	ifo.line_length = -1;			/* ... don't wrap */

	need_separator =
	     (format_message_options.envelope_formatting_mode ^= NONE_FORMATTING_MODE)
	     | (format_message_options.header_formatting_mode ^= NONE_FORMATTING_MODE)
	     | (format_message_options.redistributions_list_formatting_mode ^= NONE_FORMATTING_MODE);

	if format_message_options.redistributions_list_formatting_mode ^= NONE_FORMATTING_MODE then
	     call format_redistributions_list_internal (format_message_options.redistributions_list_formatting_mode);

	if format_message_options.envelope_formatting_mode ^= NONE_FORMATTING_MODE then
	     call format_envelope (addr (message.envelope), "0"b, message.date_time_created, message.from,
		format_message_options.envelope_formatting_mode);

	if format_message_options.header_formatting_mode ^= NONE_FORMATTING_MODE then
	     call format_header (format_message_options.header_formatting_mode);

	if format_message_options.include_body then do;	/* and now the body ... */
	     if need_separator then call add_to_buffer_fixed (NL);
	     call format_body ();
	end;

	P_buffer_used = buffer_used;			/* success */
	P_code = 0;

	return;
%page;
/* Convert a message into the appropriate text and data structures for subsequent delivery to a mailbox:  The text used is
   the canonical form as described in message_format.gi.info; the text is then enclosed in a mail_format structure.  In
   addition, a mf_extension structure is placed after the mail_format; the mf_extension identifies the start and length in
   the text of the message body, subject, any redistribution comments, and any user-defined text fields.  This information
   will be needed in future releases to insure reasonable performance for context searching of the messages in a mailbox
   */

format_message_for_mailbox:
     entry (P_message_ptr, P_buffer_ptr, P_buffer_size_words, P_buffer_used_words, P_code);

	message_ptr = P_message_ptr;
	if message.version ^= MESSAGE_VERSION_2 then do;	/* a simple validity check */
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	mail_format_ptr, buffer_ptr = P_buffer_ptr;

	buffer_size = 4 * P_buffer_size_words;
	mail_format_header_lth, buffer_used = 4 * currentsize (mail_format_header);
	line_count = 0;

	printing = "0"b;
	output_switch = null ();			/* shouldn't be used, but ... */

	ifo.buffer_overflow = report_smallarg;
	ifo.line_length = -1;			/* don't bother wrapping in a mailbox */

	string (ifo.flags) = ""b;
	ifo.rfc822_format = "0"b;			/* ... standard Multics format */
	ifo.forum_format = "0"b;			/* ... never suppress anything important */
	ifo.dont_show_logsave = "1"b;			/* ... don't use {logbox}/{save PATH} form of addresses */
	ifo.count_lines = "1"b;			/* ... need the line count */
	ifo.include_message_id = "1"b;		/* ... always include the Message-ID fields */
	ifo.include_trace = "1"b;			/* ... always include the message/redistribution traces */
	ifo.reverse_redistributions = "1"b;		/* ... put redistributions list first */
	ifo.use_canonical_fieldnames = "1"b;		/* ... use the canonical names of the cc/bcc fields */
	ifo.build_mf_extension = "1"b;		/* ... record location of fields for string search */
	ifo.include_forum_suffix = "1"b;		/* ... need to distinguish forum versions later */

	mf_extension_n_text_fragments = 1		/** the body */
	     + 1					/** the subject */
	     + message.n_user_fields + message.n_redistributions;
	call cu_$grow_stack_frame (size (mf_extension), mf_extension_ptr, (0));
	mf_extension.n_text_fragments = 0;		/* nothing recorded yet */


/* Create the canonical form of the message */

	call format_redistributions_list_internal (DEFAULT_FORMATTING_MODE);

	call format_envelope (addr (message.envelope), "0"b, message.date_time_created, message.from,
	     DEFAULT_FORMATTING_MODE);

	call format_header (DEFAULT_FORMATTING_MODE);

	call add_to_buffer_fixed (NL);

	call format_body ();

	mail_format.lines = line_count;
	mail_format.text_len = buffer_used - mail_format_header_lth;


/* Add the mf_extension to the buffer */

	if (currentsize (mail_format) + currentsize (mf_extension)) > P_buffer_size_words then call report_smallarg ();

	new_mf_extension_ptr = addwordno (mail_format_ptr, currentsize (mail_format));
	new_mf_extension_ptr -> mf_extension.n_text_fragments = mf_extension.n_text_fragments;
	new_mf_extension_ptr -> mf_extension.text_fragments = mf_extension.text_fragments;

	mf_extension_ptr = new_mf_extension_ptr;	/* switch to the one in the buffer */
	do idx = 1 to mf_extension.n_text_fragments;
	     mf_extension.text_fragments (idx).start = mf_extension.text_fragments (idx).start - mail_format_header_lth;
	end;					/* compensate for the mail_format.header structure */


/* Success */

	P_buffer_used_words = currentsize (mail_format) + currentsize (mf_extension);
	P_code = 0;

	return;
%page;
/* Convert a message into the appropriate text and data structures for subsequent delivery to a mailbox: used only for
   canonical in-mailbox messages which are being redistributed.  This entrypoint will format the new redistribution, add
   Delivery-Date and Delivery-By fields, if needed, and then use the canonical text and mf_extension structures of the
   original message to avoid extra formatting and computation */

format_canon_redistributed_msg:
     entry (P_message_ptr, P_original_mf_ptr, P_original_mf_extension_ptr, P_buffer_ptr, P_buffer_size_words,
	P_buffer_used_words, P_code);

	message_ptr = P_message_ptr;
	if message.version ^= MESSAGE_VERSION_2 then do;	/* a simple validity check */
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	original_mf_ptr = P_original_mf_ptr;
	original_mf_extension_ptr = P_original_mf_extension_ptr;
	mail_format_ptr, buffer_ptr = P_buffer_ptr;

	buffer_size = 4 * P_buffer_size_words;
	mail_format_header_lth, buffer_used = 4 * currentsize (mail_format_header);
	line_count = 0;

	printing = "0"b;
	output_switch = null ();			/* shouldn't be used, but ... */

	ifo.buffer_overflow = report_smallarg;
	ifo.line_length = -1;			/* don't bother wrapping in a mailbox */

	string (ifo.flags) = ""b;
	ifo.rfc822_format = "0"b;			/* ... standard Multics format */
	ifo.forum_format = "0"b;			/* ... never suppress anything important */
	ifo.dont_show_logsave = "1"b;			/* ... don't use {logbox}/{save PATH} form of addresses */
	ifo.count_lines = "1"b;			/* ... need the line count */
	ifo.include_message_id = "1"b;		/* ... always include the Message-ID fields */
	ifo.include_trace = "1"b;			/* ... always include the message/redistribution traces */
	ifo.reverse_redistributions = "1"b;		/* ... put redistributions list first */
	ifo.use_canonical_fieldnames = "1"b;		/* ... use the canonical names of the cc/bcc fields */
	ifo.build_mf_extension = "1"b;		/* ... record location of fields for string search */
	ifo.include_forum_suffix = "1"b;		/* ... need to distinguish forum versions later */

	mf_extension_n_text_fragments =		/* all prior text fragments plus the new redistribution */
	     original_mf_extension_ptr -> mf_extension.n_text_fragments + 1;
	call cu_$grow_stack_frame (size (mf_extension), mf_extension_ptr, (0));
	mf_extension.n_text_fragments = original_mf_extension_ptr -> mf_extension.n_text_fragments;
	mf_extension.text_fragments = original_mf_extension_ptr -> mf_extension.text_fragments;


/* Format the new redistribution */

	message_redistribution_ptr =
	     addr (message_redistributions_list.redistributions (message_redistributions_list.n_redistributions));
	call format_redistribution (DEFAULT_FORMATTING_MODE);


/* Add Delivery-Date and Delivery-By fields for the original mailing or previous redistribution if they differ from the
   Posted-Date and Sender fields, respectively */

	if message_redistributions_list.n_redistributions > 1 then do;
	     message_redistribution_ptr =		/* look at last redistribution actually in the mailbox */
		addr (message_redistributions_list
		.redistributions (message_redistributions_list.n_redistributions - 1));
	     full_fieldname = REDISTRIBUTED_PREFIX || DATE_TIME_DELIVERED_FIELDNAME;
	     if ^date_time_equal (message_redistribution.date_time_delivered, message_redistribution.date_time_mailed)
		then
		call format_date_time_field_internal (full_fieldname, message_redistribution.date_time_delivered,
		     "0"b, "1"b);
	     full_fieldname = REDISTRIBUTED_PREFIX || DELIVERED_BY_FIELDNAME;
	     if message_redistribution.delivered_by ^= null () then
		call format_address_field_internal (full_fieldname, message_redistribution.delivered_by, "1"b);
	end;

	else do;					/* use the original mailing */
	     if ^date_time_equal (message.date_time_delivered, message.date_time_mailed) then
		call format_date_time_field_internal (DATE_TIME_DELIVERED_FIELDNAME, message.date_time_delivered,
		     "0"b, "1"b);
	     if message.delivered_by ^= null () then	/* ... guarenteed non-null only if not equal to Sender */
		call format_address_field_internal (DELIVERED_BY_FIELDNAME, message.delivered_by, "1"b);
	end;


/* Relocate the text fragments of the original message to compensate for the text just added above */

	do idx = 1 to original_mf_extension_ptr -> mf_extension.n_text_fragments;
	     mf_extension.text_fragments (idx).start = mf_extension.text_fragments (idx).start + buffer_used;
	end;


/* Add the canonical form of the original message */

	call add_to_buffer_fixed (original_mf_text);

	mail_format.lines = line_count;
	mail_format.text_len = buffer_used - mail_format_header_lth;


/* Add the mf_extension to the buffer */

	if (currentsize (mail_format) + currentsize (mf_extension)) > P_buffer_size_words then call report_smallarg ();

	new_mf_extension_ptr = addwordno (mail_format_ptr, currentsize (mail_format));
	new_mf_extension_ptr -> mf_extension.n_text_fragments = mf_extension.n_text_fragments;
	new_mf_extension_ptr -> mf_extension.text_fragments = mf_extension.text_fragments;

	mf_extension_ptr = new_mf_extension_ptr;	/* switch to the one in the buffer */
	do idx = 1 to mf_extension.n_text_fragments;
	     mf_extension.text_fragments (idx).start = mf_extension.text_fragments (idx).start - mail_format_header_lth;
	end;					/* compensate for the mail_format.header structure */


/* Success */

	P_buffer_used_words = currentsize (mail_format) + currentsize (mf_extension);
	P_code = 0;

	return;
%page;
/* Convert a message into the appropriate text for subsequent delivery to a forum meeting or foreign address */

format_message_for_forum:				/* ... for delivery to a forum meeting */
     entry (P_message_ptr, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	string (ifo.flags) = ""b;			/* setup entry-specific flags ... */
	ifo.rfc822_format = "0"b;			/* ... standard Multics format */
	ifo.forum_format = "1"b;			/* ... exclude Date/From if redundant */
	ifo.include_message_id, ifo.include_trace = "0"b; /* ... never include Message-ID or message traces */

	go to FORMAT_MESSAGE_FOR_FORUM_OR_NETWORK;


format_message_for_rfc822_network:			/* ... for delivery to a foreign user */
     entry (P_message_ptr, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	string (ifo.flags) = ""b;			/* setup entry-specific flags ... */
	ifo.rfc822_format = "1"b;			/* ... ARPA network standard format */
	ifo.forum_format = "0"b;			/* ... never suppress anything important */
	ifo.include_local_system_name = "1"b;		/* ... all addresses must have host names */
	ifo.dont_canonicalize_system_names = "1"b;	/* ... all system names must be fully qualified */
	ifo.include_message_id = "1"b;		/* ... always include Mesage-ID fields */
	ifo.include_trace = "0"b;			/* ... never include message/redistribution traces */
	ifo.include_forum_suffix = "1"b;		/* ... need to distinguish forum versions later */


FORMAT_MESSAGE_FOR_FORUM_OR_NETWORK:
	message_ptr = P_message_ptr;
	if message.version ^= MESSAGE_VERSION_2 then do;
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = 0;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	ifo.line_length = 72;			/* wrap the header */
	ifo.wrap = "1"b;

	ifo.dont_show_logsave = "1"b;			/* don't use {logbox}/{save PATH} form of addresses */

	if ^ifo.forum_format then			/* no envelope for forum meetings */
	     call format_envelope (addr (message.envelope), "0"b, message.date_time_created, message.from,
		DEFAULT_FORMATTING_MODE);

	call format_header (DEFAULT_FORMATTING_MODE);

	call format_redistributions_list_internal (DEFAULT_FORMATTING_MODE);

	call add_to_buffer_fixed (NL);		/* separator before the body */

	call format_body ();

	P_buffer_used = buffer_used;			/* tell the caller what was formatted */

	P_code = 0;

	return;
%page;
/* Convert the envelope of a given message into its printed representation */

format_message_envelope:				/* ... into the caller's buffer */
     entry (P_message_ptr, P_formatting_mode, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_MESSAGE_ENVELOPE_COMMON;


print_message_envelope:				/* ... and print it on the given output switch */
     entry (P_message_ptr, P_formatting_mode, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_MESSAGE_ENVELOPE_COMMON:
	message_ptr = P_message_ptr;
	if message.version ^= MESSAGE_VERSION_2 then do;
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	if (P_formatting_mode ^= DEFAULT_FORMATTING_MODE) & (P_formatting_mode ^= LONG_FORMATTING_MODE) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_envelope (addr (message.envelope), "0"b, message.date_time_created, message.from, P_formatting_mode)
	     ;

	if printing then				/* dump the last part */
	     call print_buffer ();
	else P_buffer_used = buffer_used;

	P_code = 0;

	return;
%page;
/* Convert the header of a given message into its printed representation */

format_message_header:				/* ... into the caller's buffer */
     entry (P_message_ptr, P_formatting_mode, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_MESSAGE_HEADER_COMMON;


print_message_header:				/* ... and print it on the given output switch */
     entry (P_message_ptr, P_formatting_mode, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_MESSAGE_HEADER_COMMON:
	message_ptr = P_message_ptr;
	if message.version ^= MESSAGE_VERSION_2 then do;
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	if (P_formatting_mode < BRIEF_FORMATTING_MODE) | (P_formatting_mode > LONG_FORMATTING_MODE) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_header (P_formatting_mode);

	if printing then				/* dump the last part */
	     call print_buffer ();
	else P_buffer_used = buffer_used;

	P_code = 0;

	return;
%page;
/* Convert the redistributions list of a given message into its printed representation */

format_redistributions_list:				/* ... into the caller's buffer */
     entry (P_message_ptr, P_formatting_mode, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_MESSAGE_REDISTRIBUTIONS_LIST_COMMON;


print_redistributions_list:				/* ... and print it on the given output switch */
     entry (P_message_ptr, P_formatting_mode, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_MESSAGE_REDISTRIBUTIONS_LIST_COMMON:
	message_ptr = P_message_ptr;
	if message.version ^= MESSAGE_VERSION_2 then do;
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	if (P_formatting_mode < BRIEF_FORMATTING_MODE) | (P_formatting_mode > LONG_FORMATTING_MODE) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_redistributions_list_internal (P_formatting_mode);

	if printing then				/* dump the last part */
	     call print_buffer ();
	else P_buffer_used = buffer_used;

	P_code = 0;

	return;
%page;
/* Convert the body of a given message into its printed representation */

format_message_body:				/* ... into the caller's buffer */
     entry (P_message_ptr, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_MESSAGE_BODY_COMMON;


print_message_body:					/* ... and print it on the given output switch */
     entry (P_message_ptr, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_MESSAGE_BODY_COMMON:
	message_ptr = P_message_ptr;
	if message.version ^= MESSAGE_VERSION_2 then do;
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_body ();

	if printing then				/* dump the last part */
	     call print_buffer ();
	else P_buffer_used = buffer_used;

	P_code = 0;

	return;
%page;
/* Convert the given message trace into its printed representation */

format_message_trace:				/* ... into the caller's buffer */
     entry (P_message_trace_ptr, P_format_redistribution_trace, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used,
	P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_MESSAGE_TRACE_COMMON;


print_message_trace:				/* ... and print it on the given output switch */
     entry (P_message_trace_ptr, P_format_redistribution_trace, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_MESSAGE_TRACE_COMMON:
	message_trace_ptr = P_message_trace_ptr;
	if message_trace.version ^= MESSAGE_TRACE_VERSION_2 then do;
	     P_code = mlsys_et_$not_message_trace;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_trace (message_trace_ptr, P_format_redistribution_trace);

	if printing then				/* dump the last part */
	     call print_buffer ();
	else P_buffer_used = buffer_used;

	P_code = 0;

	return;
%page;
/* Convert an AIM access class field into its printed representation */

format_access_class_field:				/* ... into the caller's buffer */
     entry (P_fieldname, P_access_class, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_ACCESS_CLASS_FIELD_COMMON;


print_access_class_field:				/* ... and print it on the given switch */
     entry (P_fieldname, P_access_class, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_ACCESS_CLASS_FIELD_COMMON:
	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;	/* don't check line length if we set it */
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_access_class_field_internal (P_fieldname, P_access_class, printing);

	if printing then				/* make sure the last part gets out to the switch */
	     call print_buffer ();
	else P_buffer_used = buffer_used;		/* reflect what's been used to the caller */

	P_code = 0;				/* success */

	return;



/* Actually formats an access class field (called by several entrypoints) */

format_access_class_field_internal:
     procedure (p_fieldname, p_access_class, p_add_trailing_NL);

dcl  p_fieldname character (*) varying parameter;
dcl  p_access_class bit (72) aligned parameter;
dcl  p_add_trailing_NL bit (1) aligned parameter;

	last_column_used = 0;			/* nothing printed/formatted yet */

	if length (p_fieldname) > 0 then do;		/* a non-blank fieldname should be output first */
	     call add_to_buffer_varying (p_fieldname);
	     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
	end;

	ifo.indentation = last_column_used;		/* indent additional lines by this amount */

	call format_access_class (p_access_class);

	if p_add_trailing_NL then call add_to_buffer_fixed (NL);

	return;

     end format_access_class_field_internal;
%page;
/* Convert an address field into its printed representation */

format_address_field:				/* ... into the caller's buffer */
     entry (P_fieldname, P_address_ptr, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_ADDRESS_FIELD_COMMON;


print_address_field:				/* ... and print it on the given switch */
     entry (P_fieldname, P_address_ptr, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_ADDRESS_FIELD_COMMON:
	call mail_system_$get_address_type (P_address_ptr, (0), code);
	if code ^= 0 then do;			/* not a valid address */
	     P_code = code;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;	/* don't check line length if we set it */
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_address_field_internal (P_fieldname, P_address_ptr, printing);

	if printing then				/* make sure the last part gets out to the switch */
	     call print_buffer ();
	else P_buffer_used = buffer_used;		/* reflect what's been used to the caller */

	P_code = 0;				/* success */

	return;



/* Actually formats an address field (called by several entrypoints) */

format_address_field_internal:
     procedure (p_fieldname, p_address_ptr, p_add_trailing_NL);

dcl  p_fieldname character (*) varying parameter;
dcl  p_address_ptr pointer parameter;
dcl  p_add_trailing_NL bit (1) aligned parameter;

	last_column_used = 0;			/* nothing printed/formatted yet */

	if length (p_fieldname) > 0 then do;		/* a non-blank fieldname should be output first */
	     call add_to_buffer_varying (p_fieldname);
	     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
	end;

	ifo.indentation = last_column_used;		/* indent additional lines by this amount */

	call format_address (p_address_ptr, "");

	if p_add_trailing_NL then call add_to_buffer_fixed (NL);

	return;

     end format_address_field_internal;
%page;
/* Convert an address list field into its printed representation */

format_address_list_field:				/* ... into the caller's buffer */
     entry (P_fieldname, P_address_list_ptr, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_ADDRESS_LIST_FIELD_COMMON;


print_address_list_field:				/* ... and print it on the given switch */
     entry (P_fieldname, P_address_list_ptr, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_ADDRESS_LIST_FIELD_COMMON:
	if P_address_list_ptr -> address_list.version ^= ADDRESS_LIST_VERSION_2 then do;
	     P_code = mlsys_et_$not_address_list;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;	/* don't check line length if we set it */
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_address_list_field_internal (P_fieldname, P_address_list_ptr, printing);

	if printing then				/* make sure the last part gets out to the switch */
	     call print_buffer ();
	else P_buffer_used = buffer_used;		/* reflect what's been used to the caller */

	P_code = 0;				/* success */

	return;



/* Actually formats an address list field (called by several entrypoints) */

format_address_list_field_internal:
     procedure (p_fieldname, p_address_list_ptr, p_add_trailing_NL);

dcl  p_fieldname character (*) varying parameter;
dcl  p_address_list_ptr pointer parameter;
dcl  p_add_trailing_NL bit (1) aligned parameter;

	last_column_used = 0;			/* nothing printed/formatted yet */

	if length (p_fieldname) > 0 then do;		/* a non-blank fieldname should be output first */
	     call add_to_buffer_varying (p_fieldname);
	     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
	end;

	ifo.indentation = last_column_used;		/* indent additional lines by this amount */

	call format_address_list (p_address_list_ptr);

	if p_add_trailing_NL then call add_to_buffer_fixed (NL);

	return;

     end format_address_list_field_internal;
%page;
/* Convert a date/time field into its printed representation */

format_date_time_field:				/* ... into the caller's buffer */
     entry (P_fieldname, P_date_time, P_include_dow, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_DATE_TIME_FIELD_COMMON;


print_date_time_field:				/* ... and print it on the given switch */
     entry (P_fieldname, P_date_time, P_include_dow, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_DATE_TIME_FIELD_COMMON:
	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;	/* don't check line length if we set it */
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_date_time_field_internal (P_fieldname, P_date_time, P_include_dow, printing);

	if printing then				/* make sure the last part gets out to the switch */
	     call print_buffer ();
	else P_buffer_used = buffer_used;		/* reflect what's been used to the caller */

	P_code = 0;				/* success */

	return;



/* Actually formats a date/time field (called by several entrypoints) */

format_date_time_field_internal:
     procedure (p_fieldname, p_date_time, p_include_dow, p_add_trailing_NL);

dcl  p_fieldname character (*) varying parameter;
dcl  p_date_time fixed binary (71) parameter;
dcl  p_include_dow bit (1) aligned parameter;
dcl  p_add_trailing_NL bit (1) aligned parameter;

	last_column_used = 0;			/* nothing printed/formatted yet */

	if length (p_fieldname) > 0 then do;		/* a non-blank fieldname should be output first */
	     call add_to_buffer_varying (p_fieldname);
	     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
	end;

	ifo.indentation = last_column_used;		/* indent additional lines by this amount */

	call format_date_time (p_date_time, p_include_dow);

	if p_add_trailing_NL then call add_to_buffer_fixed (NL);

	return;

     end format_date_time_field_internal;
%page;
/* Convert a Message-ID field into its printed representation */

format_message_id_field:				/* ... into the caller's buffer */
     entry (P_fieldname, P_message_id, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_MESSAGE_ID_FIELD_COMMON;


print_message_id_field:				/* ... and print it on the given switch */
     entry (P_fieldname, P_message_id, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_MESSAGE_ID_FIELD_COMMON:
	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;	/* don't check line length if we set it */
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_message_id_field_internal (P_fieldname, P_message_id, printing);

	if printing then				/* make sure the last part gets out to the switch */
	     call print_buffer ();
	else P_buffer_used = buffer_used;		/* reflect what's been used to the caller */

	P_code = 0;				/* success */

	return;



/* Actually formats a Message-ID field (called by several entrypoints) */

format_message_id_field_internal:
     procedure (p_fieldname, p_message_id, p_add_trailing_NL);

dcl  p_fieldname character (*) varying parameter;
dcl  p_message_id bit (72) aligned parameter;
dcl  p_add_trailing_NL bit (1) aligned parameter;

	last_column_used = 0;			/* nothing printed/formatted yet */

	if length (p_fieldname) > 0 then do;		/* a non-blank fieldname should be output first */
	     call add_to_buffer_varying (p_fieldname);
	     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
	end;

	ifo.indentation = last_column_used;		/* indent additional lines by this amount */

	call format_message_id (p_message_id);

	if p_add_trailing_NL then call add_to_buffer_fixed (NL);

	return;

     end format_message_id_field_internal;
%page;
/* Convert a header/envelope/redistribution field which is a list of message references into its printed representation */

format_references_list_field:				/* ... into the caller's buffer */
     entry (P_fieldname, P_message_references_list_ptr, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code)
	;

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_REFERENCES_LIST_FIELD_COMMON;


print_references_list_field:				/* ... and print it on the given switch */
     entry (P_fieldname, P_message_references_list_ptr, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_REFERENCES_LIST_FIELD_COMMON:
	if P_message_references_list_ptr -> message_references_list.version ^= MESSAGE_REFERENCES_LIST_VERSION_2
	then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;	/* don't check line length if we set it */
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_references_list_field_internal (P_fieldname, P_message_references_list_ptr, printing);

	if printing then				/* make sure the last part gets out to the switch */
	     call print_buffer ();
	else P_buffer_used = buffer_used;		/* reflect what's been used to the caller */

	P_code = 0;				/* success */

	return;



/* Actually formats a field which is a list of message references (called by several entrypoints) */

format_references_list_field_internal:
     procedure (p_fieldname, p_message_references_list_ptr, p_add_trailing_NL);

dcl  p_fieldname character (*) varying parameter;
dcl  p_message_references_list_ptr pointer parameter;
dcl  p_add_trailing_NL bit (1) aligned parameter;

	last_column_used = 0;			/* nothing printed/formatted yet */

	if length (p_fieldname) > 0 then do;		/* a non-blank fieldname should be output first */
	     call add_to_buffer_varying (p_fieldname);
	     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
	end;

	ifo.indentation = last_column_used;		/* indent additional lines by this amount */

	call format_references_list (p_message_references_list_ptr);

	if p_add_trailing_NL then call add_to_buffer_fixed (NL);

	return;

     end format_references_list_field_internal;
%page;
/* Convert a text field into its printed representation */

format_text_field:					/* ... into the caller's buffer */
     entry (P_fieldname, P_text, P_multiline_text, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_TEXT_FIELD_COMMON;


print_text_field:					/* ... and print it on the given switch */
     entry (P_fieldname, P_text, P_multiline_text, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_TEXT_FIELD_COMMON:
	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;	/* don't check line length if we set it */
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);

	call format_text_field_internal (P_fieldname, P_text, P_multiline_text, printing);

	if printing then				/* make sure the last part gets out to the switch */
	     call print_buffer ();
	else P_buffer_used = buffer_used;		/* reflect what's been used to the caller */

	P_code = 0;				/* success */

	return;



/* Actually formats a text field (called by several entrypoints) */

format_text_field_internal:
     procedure (p_fieldname, p_text, p_multiline_text, p_add_trailing_NL);

dcl  p_fieldname character (*) varying parameter;
dcl  p_text character (*) parameter;
dcl  p_multiline_text bit (1) aligned parameter;
dcl  p_add_trailing_NL bit (1) aligned parameter;

	last_column_used = 0;			/* nothing printed/formatted yet */

	if length (p_fieldname) > 0 then do;		/* a non-blank fieldname should be output first */
	     call add_to_buffer_varying (p_fieldname);
	     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
	end;

	ifo.indentation = last_column_used;		/* indent additional lines by this amount */

	if ifo.build_mf_extension then do;		/* subsequent string searches will examine this field ... */
	     mf_extension.n_text_fragments = mf_extension.n_text_fragments + 1;
	     mf_extension.text_fragments (mf_extension.n_text_fragments).start = buffer_used + 1;
	end;

	call format_text (p_text, p_multiline_text);

	if ifo.build_mf_extension then		/* also record the field's length */
	     mf_extension.text_fragments (mf_extension.n_text_fragments).lth =
		buffer_used - mf_extension.text_fragments (mf_extension.n_text_fragments).start + 1;

	if p_add_trailing_NL then call add_to_buffer_fixed (NL);

	return;

     end format_text_field_internal;
%page;
/* Convert a section of the message body into its printed representation */

format_body_section:				/* ... into the caller's buffer */
     entry (P_message_body_section_parameter_ptr, P_line_length, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code);

	buffer_ptr = P_buffer_ptr;			/* use the caller's buffer */
	buffer_size = P_buffer_size;
	buffer_used = P_buffer_used;

	printing = "0"b;
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_smallarg;

	go to FORMAT_BODY_SECTION_COMMON;


print_body_section:					/* ... and print it on the given switch */
     entry (P_message_body_section_parameter_ptr, P_line_length, P_output_switch, P_code);

	buffer_ptr = addr (local_buffer);		/* format it into our automatic buffer */
	buffer_size = length (local_buffer);
	buffer_used = 0;

	printing = "1"b;				/* need to know this when we're done formatting */
	output_switch = P_output_switch;
	if output_switch = null () then output_switch = iox_$user_output;

	ifo.buffer_overflow = print_buffer;


FORMAT_BODY_SECTION_COMMON:
	message_body_section_parameter_ptr = P_message_body_section_parameter_ptr;
	if message_body_section_parameter.version ^= MESSAGE_BODY_SECTION_PARAMETER_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;
	if (message_body_section_parameter.section_type < MESSAGE_PREFORMATTED_BODY_SECTION)
	     | (message_body_section_parameter.section_type > MESSAGE_BIT_STRING_BODY_SECTION) then do;
	     P_code = mlsys_et_$unknown_body_section_type;
	     return;
	end;

	string (ifo.flags) = ""b;			/* standard formatting options */

	ifo.line_length = P_line_length;

	if printing & (ifo.line_length = 0) then	/* default to line length of the output switch */
	     ifo.line_length = get_line_length_$switch (output_switch, (0));

	if printing & (P_line_length = 0) then ;	/* don't check line length if we set it */
	else if (ifo.line_length ^= -1) & (ifo.line_length ^> 30) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	ifo.wrap = (ifo.line_length ^= -1);
	ifo.count_lines = "1"b;			/* we need to return the line count */
	line_count = 0;

	call format_body_section_internal (addr (message_body_section_parameter.section));

	if printing then				/* make sure the last part gets out to the switch */
	     call print_buffer ();
	else P_buffer_used = buffer_used;		/* reflect what's been used to the caller */

	message_body_section_parameter.section.section_n_lines = line_count;

	P_code = 0;				/* success */

	return;
%page;
/* format: ^indcomtxt */
/* Formats an address for use by the interim inter-system mailer (mlsys_mailer_):  The format used by mlsys_mailer_ is a
   variant of the Multics standard format for a local address.  In particular, RFC822 quoting is used and the keywords
   "at" and "via" are both replaced by commerical at-signs (@).  In addition, the formatted address is broken into two
   parts -- the "user name" and "host name".  The "user name" consists of the actual foreign address and, if any relay
   systems are needed to send the message, the name of the foreign system and all but the first relay system.  The "host
   name" is either the name of the foreign system if there are no relays or the name of the first relay system.  For
   example, the address:
	GMP at MIT-MC via MIT-MULTICS.ARPA via CISL-SERVICE-MULTICS.ARPA
   is formatted for mlsys_mailer_ as:
	GMP@MIT-MC@MIT-MULTICS.ARPA   and   CISL-SERVICE-MULTICS.ARPA */
/* format: indcomtxt */

format_address_for_ism:
     entry (P_address_string, P_address_route_ptr, P_user_name, P_host_name, P_code);

	printing = "0"b;				/* formatting data to be returned to the caller */
	output_switch = null ();			/* shouldn't get used, but ... */

	ifo.buffer_overflow = report_foreign_address_too_long;
	ifo.line_length = -1;			/* don't wrap */
	ifo.indentation = 0;
	string (ifo.flags) = ""b;			/* setup entry-specific flags ... */
	ifo.rfc822_format = "1"b;			/* ... ARPA network standard format */

	address_route_ptr = P_address_route_ptr;

	begin;
dcl  user_name_buffer character (maxlength (P_user_name));
dcl  host_name_buffer character (maxlength (P_host_name));

	     /*** Format the "user name" */
	     buffer_ptr = addr (user_name_buffer);
	     buffer_size = length (user_name_buffer);
	     buffer_used = 0;			/* nothing in it yet */
	     call format_top_level_string (P_address_string);
						/* the actual address on the foreign system ... */
	     do idx = address_route.n_relays to 2 by -1;
		/*** ... plus the names of all but the first relay system */
		call add_to_buffer_fixed (ATSIGN);
		call format_top_level_string (address_route.relays (idx));
	     end;
	     P_user_name = substr (user_name_buffer, 1, buffer_used);

	     /*** Format the "host name" */
	     buffer_ptr = addr (host_name_buffer);
	     buffer_size = length (host_name_buffer);
	     buffer_used = 0;
	     call format_top_level_string (address_route.relays (1));
	     P_host_name = substr (host_name_buffer, 1, buffer_used);
	end;

	P_code = 0;				/* can only get here if OK */

	return;
%page;
/* Format/print the contents of a message/redistribution envelope */

format_envelope:
     procedure (p_envelope_ptr, p_is_redistribution, p_date_time_created, p_from, p_formatting_mode);

dcl  p_envelope_ptr pointer parameter;
dcl  p_is_redistribution bit (1) aligned parameter;
dcl  p_date_time_created fixed binary (71) parameter;
dcl  p_from pointer parameter;
dcl  p_formatting_mode fixed binary parameter;

dcl  1 p_envelope aligned based (p_envelope_ptr) like message_envelope;

dcl  (delivered_by, sender) pointer;
dcl  full_fieldname character (64) varying;
dcl  fieldname_prefix character (32) varying;
dcl  (sender_is_different, delivered_by_is_different) bit (1) aligned;


	if p_envelope.date_time_mailed = 0 then		/* can't display the envelope if it has never been mailed */
	     return;

	if p_is_redistribution then			/* setup fieldname prefix */
	     if ifo.rfc822_format then
		fieldname_prefix = RESENT_PREFIX;
	     else fieldname_prefix = REDISTRIBUTED_PREFIX;
	else fieldname_prefix = "";

	sender = p_envelope.sender;			/* get a value for the Sender field */
	if sender = null () then do;			/* ... From field is guarenteed to have 1 address */
	     sender = p_from -> address_list.addresses (1);
	     sender_is_different = "0"b;
	end;
	else if p_from -> address_list.n_addresses = 1	/* Sender and From field may be identical */
	     then
	     sender_is_different = ^mail_system_$compare_addresses (sender, p_from -> address_list.addresses (1), (0));
	else sender_is_different = "1"b;		/* multiple authors */

	delivered_by = p_envelope.delivered_by;		/* get a value for the Delivery-By field */
	if delivered_by = null () then do;
	     delivered_by = sender;
	     delivered_by_is_different = "0"b;
	end;
	else delivered_by_is_different = ^mail_system_$compare_addresses (delivered_by, sender, (0));

	full_fieldname = fieldname_prefix || DATE_TIME_DELIVERED_FIELDNAME;
	if p_envelope.date_time_delivered > 0 then	/* it's been delivered ... */
	     if (p_formatting_mode = LONG_FORMATTING_MODE)
		| ^date_time_equal (p_envelope.date_time_delivered, p_envelope.date_time_mailed) then
		call format_date_time_field_internal (full_fieldname, p_envelope.date_time_delivered, "0"b, "1"b);

	full_fieldname = fieldname_prefix || DELIVERED_BY_FIELDNAME;
	if (p_formatting_mode = LONG_FORMATTING_MODE) | delivered_by_is_different then
	     call format_address_field_internal (full_fieldname, delivered_by, "1"b);

	full_fieldname = fieldname_prefix || DATE_TIME_MAILED_FIELDNAME;
	if (p_formatting_mode = LONG_FORMATTING_MODE)
	     | ^date_time_equal (p_envelope.date_time_mailed, p_date_time_created) then
	     call format_date_time_field_internal (full_fieldname, p_envelope.date_time_mailed, "0"b, "1"b);

	full_fieldname = fieldname_prefix || SENDER_FIELDNAME;
	if (p_formatting_mode = LONG_FORMATTING_MODE) | sender_is_different then
	     call format_address_field_internal (full_fieldname, sender, "1"b);

	if (ifo.include_trace | (p_formatting_mode = LONG_FORMATTING_MODE)) & (p_envelope.trace ^= null ()) then
	     call format_trace (p_envelope.trace, p_is_redistribution);

	full_fieldname = fieldname_prefix || ACKNOWLEDGE_TO_FIELDNAME;
	if p_envelope.acknowledge_to ^= null () then	/* only if it's present */
	     call format_address_field_internal (full_fieldname, p_envelope.acknowledge_to, "1"b);

	return;

     end format_envelope;
%page;
/* Actually format the header of a message (called by several entrypoints):  Contrary to the documentation, the Date and
   From fields can be ommitted from the printed representation; however, this only occurs when formatting a new message as
   a new message's Date field is not available to the caller to avoid problems with "qedx -header" like uses of the
   printed representation and the From field is empty unless the user has set it to a non-default value as the default is
   supplied at message delivery time */

format_header:
     procedure (p_formatting_mode);

dcl  p_formatting_mode fixed binary parameter;

dcl  user_fieldname character (256) varying;		/* should be big enough for any conceivable field name */
dcl  value_picture picture "-----------9v";
dcl  six_digits_picture picture "zzzzz9";
dcl  user_is_recipient bit (1) aligned;
dcl  (n_recipients, idx) fixed binary;


	if message.date_time_created > 0 then		/* there's a Date field ... */
	     if ifo.forum_format & date_time_equal (message.date_time_created, clock ()) then
		;				/* ... but not if the same as what forum will display */
	     else call format_date_time_field_internal (DATE_TIME_CREATED_FIELDNAME, message.date_time_created, "1"b,
		     "1"b);

	if message.from ^= null () then		/* always show the From it it's not empty ... */
	     if message.from -> address_list.n_addresses > 0 then
		if ifo.forum_format & (message.from -> address_list.n_addresses = 1) then
		     if mail_system_$compare_addresses (mlsys_data_$user_default_mailbox_address,
			message.from -> address_list.addresses (1), (0))
			|
			mail_system_$compare_addresses (mlsys_data_$user_mail_table_address,
			message.from -> address_list.addresses (1), (0)) then
			;			/* ... unless it's the same as what forum will display */
		     else call format_address_list_field_internal (FROM_FIELDNAME, message.from, "1"b);
		else call format_address_list_field_internal (FROM_FIELDNAME, message.from, "1"b);

	if ^ifo.forum_format & (message.subject.text_lth > 0) then
						/* always show Subject if present and not going to a forum */
	     call format_text_field_internal (SUBJECT_FIELDNAME, message_subject, "0"b, "1"b);

	if p_formatting_mode > BRIEF_FORMATTING_MODE then
	     if message.reply_to ^= null () then	/* only display the Reply-To field if not -brief_header */
		if message.reply_to -> address_list.n_addresses > 0 then
		     call format_address_list_field_internal (REPLY_TO_FIELDNAME, message.reply_to, "1"b);

	if p_formatting_mode > BRIEF_FORMATTING_MODE then
	     if message.to ^= null () then		/* only display the To field if not -brief_header */
		if message.to -> address_list.n_addresses > 0 then
		     call format_address_list_field_internal (TO_FIELDNAME, message.to, "1"b);

	if p_formatting_mode > BRIEF_FORMATTING_MODE then
	     if message.cc ^= null () then		/* only display the cc field if not -brief_header */
		if message.cc -> address_list.n_addresses > 0 then
		     if ifo.use_canonical_fieldnames then
			call format_address_list_field_internal (CANONICAL_CC_FIELDNAME, message.cc, "1"b);
		     else call format_address_list_field_internal (CC_FIELDNAME, message.cc, "1"b);

	if p_formatting_mode > BRIEF_FORMATTING_MODE then
	     if message.bcc ^= null () then		/* only display the bcc field if not -brief_header */
		if message.bcc -> address_list.n_addresses > 0 then
		     if ifo.use_canonical_fieldnames then
			call format_address_list_field_internal (CANONICAL_BCC_FIELDNAME, message.bcc, "1"b);
		     else call format_address_list_field_internal (BCC_FIELDNAME, message.bcc, "1"b);

	if p_formatting_mode = BRIEF_FORMATTING_MODE then do;
	     /*** Check for multiple recipients and/or the user not being the recipient */
	     user_is_recipient = "0"b;
	     n_recipients = 0;
	     do address_list_ptr = message.to, message.cc, message.bcc;
		if address_list_ptr ^= null () then do; /* ... there are some addresses on this list */
		     n_recipients = n_recipients + address_list.n_addresses;
		     do idx = 1 to address_list.n_addresses while (^user_is_recipient);
			if mail_system_$compare_addresses (mlsys_data_$user_default_mailbox_address,
			     address_list.addresses (idx), (0)) then
			     user_is_recipient = "1"b;
			else if
			     mail_system_$compare_addresses (mlsys_data_$user_mail_table_address,
			     address_list.addresses (idx), (0)) then
			     user_is_recipient = "1"b;
		     end;
		end;
	     end;
	     if (^user_is_recipient & (n_recipients > 0)) | (n_recipients > 1) then do;
		call add_to_buffer_varying (RECIPIENTS_FIELDNAME);
		call add_to_buffer_fixed (FIELDNAME_SUFFIX);
		if user_is_recipient then do;		/* must be others beside this person */
		     call add_to_buffer_fixed ("Yourself and ");
		     n_recipients = n_recipients - 1;	/* ... don't count ourselves twice */
		end;
		call add_to_buffer_fixed (ltrim (convert (six_digits_picture, n_recipients)));
		if n_recipients = 1 then
		     call add_to_buffer_fixed (" other");
		else call add_to_buffer_fixed (" others");
		call add_to_buffer_fixed (NL);
	     end;
	end;

	if p_formatting_mode > BRIEF_FORMATTING_MODE then
	     if message.reply_references ^= null () then	/* include the In-Reply-To field only if not -brief_header */
		if message.reply_references -> message_references_list.n_references > 0 then
		     call format_references_list_field_internal (REPLY_REFERENCES_FIELDNAME, message.reply_references,
			"1"b);

	if (p_formatting_mode = LONG_FORMATTING_MODE)
	     | ((p_formatting_mode = DEFAULT_FORMATTING_MODE)
	     & ^aim_check_$equal (message.access_class, get_authorization_ ())) then
	     call format_access_class_field_internal (ACCESS_CLASS_FIELDNAME, message.access_class, "1"b);

	if ifo.include_message_id | (p_formatting_mode = LONG_FORMATTING_MODE) then
						/* always display Message-ID when asked or in long form ... */
	     if message.message_id ^= ""b then		/* ... but not for new messages (they don't have one) */
		call format_message_id_field_internal (MESSAGE_ID_FIELDNAME, message.message_id, "1"b);

	/*** Finally, process the user-defined fields */
	if p_formatting_mode > BRIEF_FORMATTING_MODE then /* ... but only if not -brief_header */
	     if message.user_fields_list ^= null () then do;
		do idx = 1 to message_user_fields_list.n_user_fields;
		     message_user_field_ptr = addr (message_user_fields_list.user_fields (idx));
		     call mail_system_$get_user_field_name (message_user_field.field_id, user_fieldname, code);
		     if code = 0 then do;		/* ... I'd be real suprised if it isn't */
			if message_user_field.field_type = MESSAGE_TEXT_USER_FIELD then do;
			     if (message_text_user_field.text_ptr ^= null ())
				& (message_text_user_field.text_lth ^= 0) then
				call format_text_field_internal (user_fieldname, message_text_user_field_text,
				     (message_text_user_field.multiline_text), "1"b);
			end;
			else if message_user_field.field_type = MESSAGE_ADDRESS_LIST_USER_FIELD then do;
			     if message_address_list_user_field.address_list_ptr ^= null () then
				if message_address_list_user_field.address_list_ptr -> address_list.n_addresses
				     > 0 then
				     call format_address_list_field_internal (user_fieldname,
					message_address_list_user_field.address_list_ptr, "1"b);
			end;
			else if message_user_field.field_type = MESSAGE_DATE_USER_FIELD then do;
			     call format_date_time_field_internal (user_fieldname,
				message_date_user_field.date_time, "0"b, "1"b);
			end;
			else /*** if message_user_field.field_type = MESSAGE_INTEGER_USER_FIELD then */
			     do;
			     call add_to_buffer_varying (user_fieldname);
			     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
			     call add_to_buffer_fixed (
				ltrim (convert (value_picture, message_integer_user_field.value)));
			     call add_to_buffer_fixed (NL);
			end;
		     end;
		end;
	     end;

	return;

     end format_header;
%page;
/* Actually formats the redistributions list of a message (called by several entrypoints) */

format_redistributions_list_internal:
     procedure (p_formatting_mode);

dcl  p_formatting_mode fixed binary parameter;
dcl  (first_idx, last_idx, idx_increment, idx) fixed binary;

	if message.redistributions_list = null () then return;

	if ifo.reverse_redistributions then do;		/* format most recent redistribution first */
	     first_idx = message_redistributions_list.n_redistributions;
	     last_idx = 1;
	     idx_increment = -1;
	end;
	else do;					/* format oldest redistribution first */
	     first_idx = 1;
	     last_idx = message_redistributions_list.n_redistributions;
	     idx_increment = 1;
	end;

	if ifo.reverse_redistributions then		/* display Last-Redistributed field at very top */
	     call format_last_redistributed_if_needed ();

	do idx = first_idx to last_idx by idx_increment;
	     message_redistribution_ptr = addr (message_redistributions_list.redistributions (idx));
	     if (p_formatting_mode > BRIEF_FORMATTING_MODE) | (message_redistribution.comment.text_lth > 0) then
		call format_redistribution (p_formatting_mode);
	end;					/* only if there's a comment when brief ... */

	if ^ifo.reverse_redistributions then		/* display Last-Redistributed at the end if chronological */
	     call format_last_redistributed_if_needed ();

	return;



/* Internal to format_redistributions_list_internal: includes a "Last-Redistributed" field if the last redistributions
   does not have a comment and brief formatting is in effect */

format_last_redistributed_if_needed:
	procedure ();

	     if (p_formatting_mode ^= BRIEF_FORMATTING_MODE) | (message_redistributions_list.n_redistributions = 0) then
		return;

	     message_redistribution_ptr =
		addr (message_redistributions_list.redistributions (message_redistributions_list.n_redistributions));

	     if message_redistribution.comment.text_lth = 0 then do;
		last_column_used = 0;		/* starting a new line of output here ... */
		if ifo.rfc822_format then
		     call add_to_buffer_varying (LAST_RESENT_FIELDNAME);
		else call add_to_buffer_varying (LAST_REDISTRIBUTED_FIELDNAME);
		call add_to_buffer_fixed (FIELDNAME_SUFFIX);
		ifo.indentation = last_column_used;	/* ... and we need to know where to indent things */
		call format_date_time (message_redistribution.date_time_created, "0"b);
		call add_to_buffer_fixed (" by ");
		call format_address_list (message_redistribution.from);
		call add_to_buffer_fixed (NL);
	     end;

	     return;

	end format_last_redistributed_if_needed;

     end format_redistributions_list_internal;
%page;
/* Actually formats the body of a message (called by several entrypoints) */

format_body:
     procedure ();

dcl  idx fixed binary;

	if ifo.build_mf_extension then do;		/* subsequent string searches will examine the body ... */
	     mf_extension.n_text_fragments = mf_extension.n_text_fragments + 1;
	     mf_extension.text_fragments (mf_extension.n_text_fragments).start = buffer_used + 1;
	end;

	do idx = 1 to message.n_body_sections;

	     if idx > 1 then			/* separate it from the previous part */
		call add_to_buffer_fixed (NL);

	     call format_body_section_internal (addr (message.body_sections (idx)));
	end;

	if ifo.build_mf_extension then		/* also record the body's length */
	     mf_extension.text_fragments (mf_extension.n_text_fragments).lth =
		buffer_used - mf_extension.text_fragments (mf_extension.n_text_fragments).start + 1;

	return;

     end format_body;
%page;
/* Actually formats a message trace (called by several entrypoints) */

format_trace:
     procedure (p_trace_ptr, p_is_redistribution);

dcl  p_trace_ptr pointer parameter;
dcl  p_is_redistribution bit (1) aligned parameter;

dcl  1 the_relay aligned like message_trace.relays based (the_relay_ptr);
dcl  the_relay_ptr pointer;

dcl  fieldname_prefix character (32) varying;
dcl  canonicalize bit (1) aligned;
dcl  idx fixed binary;


	if ifo.rfc822_format then return;		/* can't allow old trace into RFC822 messages as SMTP will add
						   new fields which would be indistinguishable from the old
						   ones */

	message_trace_ptr = p_trace_ptr;		/* can't use like because of refer-extents */

	if p_is_redistribution then
	     fieldname_prefix = REDISTRIBUTED_PREFIX;
	else fieldname_prefix = "";

	if message_trace.implicit_route ^= null () then do;
	     address_route_ptr = message_trace.implicit_route;
	     last_column_used = 0;			/* will need this for proper formatting */
	     call add_to_buffer_varying ((fieldname_prefix || IMPLICIT_ROUTE_FIELDNAME));
	     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
	     ifo.indentation = last_column_used;
	     do idx = address_route.n_relays to 1 by -1;
		if ifo.wrap then			/* check if we should start a continuation line ... */
		     if last_column_used > ifo.indentation then
			if (idx = 1) & ^ifo.dont_canonicalize_system_names then
			     if (last_column_used + length (SP_VIA_SP)
				+
				top_level_length (
				mlsys_nit_interface_$canonicalize_system_name (address_route.relays (idx))))
				> ifo.line_length then
				call new_line ();
			     else ;
			else if (last_column_used + length (SP_VIA_SP)
			     + top_level_length (address_route.relays (idx))) > ifo.line_length then
			     call new_line ();
		call add_to_buffer_fixed (SP_VIA_SP);
		if (idx = 1) & ^ifo.dont_canonicalize_system_names then
		     call format_top_level_string (
			mlsys_nit_interface_$canonicalize_system_name (address_route.relays (idx)));
		else call format_top_level_string (address_route.relays (idx));
	     end;
	     call add_to_buffer_fixed (NL);		/* end of that field */
	end;

	do idx = 1 to message_trace.n_relays;
	     the_relay_ptr = addr (message_trace.relays (idx));
	     last_column_used = 0;			/* need the indentation point again */
	     call add_to_buffer_varying ((fieldname_prefix || RELAY_FIELDNAME));
	     call add_to_buffer_fixed (FIELDNAME_SUFFIX);
	     ifo.indentation = last_column_used;
	     canonicalize =
		^ifo.dont_canonicalize_system_names & mlsys_nit_interface_$is_local_system (the_relay.receiving_host);
	     call add_to_buffer_fixed ("from ");
	     if canonicalize then
		call add_to_buffer_varying (mlsys_nit_interface_$canonicalize_system_name (the_relay.sending_host));
	     else call add_to_buffer_varying (the_relay.sending_host);
	     if canonicalize then
		call add_phrase ("to", mlsys_nit_interface_$canonicalize_system_name (the_relay.receiving_host));
	     else call add_phrase ("to", the_relay.receiving_host);
	     if the_relay.mail_protocol ^= "" then call add_phrase ("using", rtrim (the_relay.mail_protocol));
	     if the_relay.communications_protocol ^= "" then
		call add_phrase ("with", rtrim (the_relay.communications_protocol));
	     if the_relay.communications_media ^= "" then
		call add_phrase ("via", rtrim (the_relay.communications_media));
	     if the_relay.relay_id ^= ""b then do;
		if ifo.wrap then			/* ... perform a simple check to insure there's some room */
		     if last_column_used > ifo.indentation then
			if (last_column_used + length ("ID") + 12) > ifo.line_length then call new_line ();
		call add_to_buffer_fixed (" ID ");
		call format_message_id (the_relay.relay_id);
	     end;
	     if the_relay.relay_recipient ^= null () then do;
		if ifo.wrap then			/* ... perform a simple check to insure there's some room */
		     if last_column_used > ifo.indentation then
			if (last_column_used + length ("for") + 12) > ifo.line_length then call new_line ();
		call add_to_buffer_fixed (" for ");
		call format_address (the_relay.relay_recipient, "");
	     end;
	     call add_to_buffer_fixed (SEMICOLON);
	     call add_to_buffer_fixed (SP);
	     call format_date_time (the_relay.date_time_relayed, "0"b);
	     call add_to_buffer_fixed (NL);
	end;

	return;



/* Internal to format_trace: adds a phrase to the current Relayed field */

add_phrase:
	procedure (p_phrase_prefix, p_phrase);

dcl  p_phrase_prefix character (*) parameter;
dcl  p_phrase character (*) varying parameter;

	     if ifo.wrap then			/* try no to overflow the line */
		if last_column_used > ifo.indentation then
		     if (last_column_used + length (p_phrase_prefix) + 2 + top_level_length (p_phrase))
			> ifo.line_length then
			call new_line ();

	     call add_to_buffer_fixed (SP);
	     call add_to_buffer_fixed (p_phrase_prefix);
	     call add_to_buffer_fixed (SP);

	     call format_top_level_string (p_phrase);

	     return;

	end add_phrase;

     end format_trace;
%page;
/* Actually formats a single redistribution (called directly by one entrypoint) */

format_redistribution:
     procedure (p_formatting_mode);

dcl  p_formatting_mode fixed binary parameter;
dcl  full_fieldname character (64) varying;
dcl  fieldname_prefix character (32) varying;
dcl  six_digits_picture picture "zzzzz9";
dcl  user_is_recipient bit (1) aligned;
dcl  (n_recipients, idx) fixed binary;

	if ifo.rfc822_format then
	     fieldname_prefix = RESENT_PREFIX;
	else fieldname_prefix = REDISTRIBUTED_PREFIX;

	if ^ifo.forum_format & (p_formatting_mode > BRIEF_FORMATTING_MODE) then
	     call format_envelope (addr (message_redistribution.envelope), "1"b,
		message_redistribution.date_time_created, message_redistribution.from, p_formatting_mode);

	if message_redistribution.date_time_created > 0 then do;
	     full_fieldname = fieldname_prefix || DATE_TIME_CREATED_FIELDNAME;
	     call format_date_time_field_internal (full_fieldname, message_redistribution.date_time_created, "0"b, "1"b)
		;
	end;					/* always show the Redistributed-Date if it's present */

	if message_redistribution.from ^= null () then
	     if message_redistribution.from -> address_list.n_addresses > 0 then do;
		full_fieldname = fieldname_prefix || FROM_FIELDNAME;
		call format_address_list_field_internal (full_fieldname, message_redistribution.from, "1"b);
	     end;					/* always show the Redistributed-From it it's not empty ... */

	if p_formatting_mode > BRIEF_FORMATTING_MODE then
	     if message_redistribution.to ^= null () then
		if message_redistribution.to -> address_list.n_addresses > 0 then do;
		     full_fieldname = fieldname_prefix || TO_FIELDNAME;
		     call format_address_list_field_internal (full_fieldname, message_redistribution.to, "1"b);
		end;				/* only display the Redistributed-To field if not -bfhe */

	if p_formatting_mode = BRIEF_FORMATTING_MODE then do;
	     /*** Check for multiple recipients and/or the user not being the recipient */
	     user_is_recipient = "0"b;
	     n_recipients = 0;
	     address_list_ptr = message_redistribution.to;
	     if address_list_ptr ^= null () then do;	/* ... there are some addresses on this list */
		n_recipients = n_recipients + address_list.n_addresses;
		do idx = 1 to address_list.n_addresses while (^user_is_recipient);
		     if mail_system_$compare_addresses (mlsys_data_$user_default_mailbox_address,
			address_list.addresses (idx), (0)) then
			user_is_recipient = "1"b;
		     else if
			mail_system_$compare_addresses (mlsys_data_$user_mail_table_address,
			address_list.addresses (idx), (0)) then
			user_is_recipient = "1"b;
		end;
	     end;
	     if (^user_is_recipient & (n_recipients > 0)) | (n_recipients > 1) then do;
		full_fieldname = fieldname_prefix || RECIPIENTS_FIELDNAME;
		call add_to_buffer_varying (full_fieldname);
		call add_to_buffer_fixed (FIELDNAME_SUFFIX);
		if user_is_recipient then do;		/* must be others beside this person */
		     call add_to_buffer_fixed ("Yourself and ");
		     n_recipients = n_recipients - 1;
		end;				/* ... don't count ourselves twice */
		call add_to_buffer_fixed (ltrim (convert (six_digits_picture, n_recipients)));
		if n_recipients = 1 then
		     call add_to_buffer_fixed (" other");
		else call add_to_buffer_fixed (" others");
		call add_to_buffer_fixed (NL);
	     end;
	end;

	if message_redistribution.comment.text_lth > 0 then do;
	     full_fieldname = fieldname_prefix || COMMENT_FIELDNAME;
	     call format_text_field_internal (full_fieldname, message_redistribution_comment, "1"b, "1"b);
						/* always display the Redistributed-Comment */
	end;

	if ifo.include_message_id | (p_formatting_mode = LONG_FORMATTING_MODE) then
	     if message_redistribution.message_id ^= ""b then do;
		full_fieldname = fieldname_prefix || MESSAGE_ID_FIELDNAME;
		call format_message_id_field_internal (full_fieldname, message_redistribution.message_id, "1"b);
	     end;					/* only display Redistributed-Message-ID in long mode */

	return;

     end format_redistribution;
%page;
/* Actually formats an access class (called by numerous entrypoints) */

format_access_class:
     procedure (p_access_class);

dcl  p_access_class bit (72) aligned parameter;

dcl  short_string character (200);
dcl  (string_lth, comma_lth, used, idx) fixed binary;

	call convert_authorization_$to_string_short (p_access_class, short_string, (0));
						/* above string is large enough for any access class */

	if short_string = "" then			/* special case it so it will say something */
	     short_string = "system_low";
	else if aim_check_$equal (p_access_class, sys_info$access_class_ceiling) then short_string = "system_high";
						/* make's it easier to read */

	string_lth = length (rtrim (short_string));
	used = 0;					/* haven't examined any of it yet */

	do while (used < string_lth);
	     begin;
dcl  rest_of_string character (string_lth - used) unaligned defined (short_string) position (used + 1);
		idx = index (rest_of_string, COMMA);
		if idx = 0 then idx = length (rest_of_string) + 1;
	     end;

	     begin;
dcl  next_word character (idx - 1) unaligned defined (short_string) position (used + 1);
		if (length (next_word) + used + 1) > string_lth then
		     comma_lth = 0;
		else comma_lth = length (COMMA_SP);

		if ifo.wrap then			/* check for overflow */
		     if last_column_used > ifo.indentation then
			if (last_column_used + length (next_word) + comma_lth) > ifo.line_length then
			     call new_line ();

		call add_to_buffer_fixed (next_word);
		if comma_lth > 0 then call add_to_buffer_fixed (COMMA_SP);

		used = used + idx;			/* to the next word */
	     end;
	end;

	return;

     end format_access_class;
%page;
/* Actually formats an address (called by numerous entrypoints) */

format_address:
     procedure (p_address_ptr, p_address_suffix) options (non_quick);

dcl  p_address_ptr pointer parameter;
dcl  p_address_suffix character (*) varying parameter;

dcl  address_string character (address_string_max_lth) varying based (address_string_ptr);
dcl  address_name character (address_name_max_lth) varying based (address_name_ptr);
dcl  address_comment character (address_comment_max_lth) varying based (address_comment_ptr);
dcl  (address_string_ptr, address_name_ptr, address_comment_ptr) pointer;
dcl  (address_string_max_lth, address_name_max_lth, address_comment_max_lth) fixed binary (21);

dcl  (local_address_string, local_address_name, local_address_comment) character (256) varying;

dcl  saved_indentation fixed binary;
dcl  (have_address_data, display_list) bit (1) aligned;

dcl  address_pathname character (204);			/* pathname associated with the address */
dcl  (address_pathname_varying, address_system) character (256) varying;
dcl  address_dirname character (168);
dcl  (address_ename, address_component) character (32);

dcl  address_representation_lth fixed binary (21);
dcl  address_type fixed binary;


	call mail_system_$get_address_type (p_address_ptr, address_type, (0));

	call get_address_variable (local_address_name, address_name_ptr, address_name_max_lth,
	     mail_system_$get_address_name);

	call get_address_variable (local_address_comment, address_comment_ptr, address_comment_max_lth,
	     mail_system_$get_address_comment);

	have_address_data = "0"b;

	if ^ifo.wrap then go to BEGIN_TO_FORMAT;	/* if we don't care about line wrapping ... */

	have_address_data = "1"b;			/* don't bother to fetch things twice */

	address_representation_lth = length (p_address_suffix);

	if length (address_name) > 0 then		/* there's a name: compute how long it will be */
	     address_representation_lth =
		address_representation_lth + phrase_length (address_name) + length (SP_LEFT_ANGLE_BRACKET)
		+ length (RIGHT_ANGLE_BRACKET);

	if length (address_comment) > 0 then		/* there's a comment: compute how long it will be */
	     address_representation_lth =
		address_representation_lth + comment_length (address_comment) + length (SP_OPEN_PAREN)
		+ length (CLOSE_PAREN);

	go to COMPUTE_ADDRESS_WIDTH (address_type);

COMPUTE_ADDRESS_WIDTH (0):				/* invalid address */
	call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
	     mail_system_$get_address_string);
	address_representation_lth =
	     address_representation_lth + structured_length (address_string) + length ("{invalid }")
	     + quotes_if_rfc822 ();
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;

COMPUTE_ADDRESS_WIDTH (1):				/* user mailbox address */
	call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
	     mail_system_$get_address_string);
	address_representation_lth = address_representation_lth + top_level_length (address_string);
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;

COMPUTE_ADDRESS_WIDTH (2):				/* logbox address */
	call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
	     mail_system_$get_address_string);
	if ifo.dont_show_logsave | (address_string ^= mlsys_data_$user_id) then
	     address_representation_lth = address_representation_lth + top_level_length (address_string);
	else address_representation_lth = address_representation_lth + length ("{logbox}") + quotes_if_rfc822 ();
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;

COMPUTE_ADDRESS_WIDTH (3):				/* savebox address */
	call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
	     mail_system_$get_address_string);
	call mail_system_$get_address_pathname (p_address_ptr, address_dirname, address_ename, ((32)" "), (0));
	if ifo.dont_show_logsave | (address_string ^= mlsys_data_$user_id) then do;
	     address_representation_lth = address_representation_lth + top_level_length (address_string);
	     address_pathname_varying = reverse (after (reverse (address_ename), reverse (".sv.mbx")));
	     address_representation_lth =
		address_representation_lth + comment_length (address_pathname_varying) + length (SP_OPEN_PAREN)
		+ length (CLOSE_PAREN);
	end;
	else do;
	     address_pathname = pathname_ (address_dirname, address_ename);
	     address_pathname_varying = reverse (after (reverse (address_pathname), reverse (".sv.mbx")));
	     address_representation_lth =
		address_representation_lth + structured_length (address_pathname_varying) + length ("{save }")
		+ quotes_if_rfc822 ();
	end;
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;

COMPUTE_ADDRESS_WIDTH (4):				/* mailbox address */
	call mail_system_$get_address_pathname (p_address_ptr, address_dirname, address_ename, ((32)" "), (0));
	address_pathname = pathname_ (address_dirname, address_ename);
	address_pathname_varying = reverse (after (reverse (address_pathname), reverse (".mbx")));
	address_representation_lth =
	     address_representation_lth + structured_length (address_pathname_varying) + length ("{mbx }")
	     + quotes_if_rfc822 ();
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;

COMPUTE_ADDRESS_WIDTH (5):				/* forum address */
	call mail_system_$get_address_pathname (p_address_ptr, address_dirname, address_ename, ((32)" "), (0));
	if address_dirname = "" then			/* ... null dirname => not found in "forum" search list */
	     address_pathname_varying = rtrim (address_ename);
	else address_pathname_varying = rtrim (pathname_ (address_dirname, address_ename));
	if ^ifo.include_forum_suffix then		/* ... caller doesn't need the suffix for later use */
	     if index (reverse (address_pathname_varying), reverse (".forum")) = 1 then
		address_pathname_varying =
		     substr (address_pathname_varying, 1, (length (address_pathname_varying) - length (".forum")));
	     else if index (reverse (address_pathname_varying), reverse (".control")) = 1 then
		address_pathname_varying =
		     substr (address_pathname_varying, 1, (length (address_pathname_varying) - length (".control")));
	address_representation_lth =
	     address_representation_lth + structured_length (address_pathname_varying) + length ("{forum }")
	     + quotes_if_rfc822 ();
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;

COMPUTE_ADDRESS_WIDTH (6):				/* foreign address */
	call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
	     mail_system_$get_address_string);
	call mail_system_$get_address_system (p_address_ptr, address_system, (0));
	address_route_ptr = null ();			/* ... assume no route initially */
	call mail_system_$get_address_route (p_address_ptr, ADDRESS_ROUTE_VERSION_1, address_route_ptr, (0));
	address_representation_lth = address_representation_lth + top_level_length (address_string);
	if ifo.rfc822_format then
	     address_representation_lth = address_representation_lth + length (ATSIGN);
	else address_representation_lth = address_representation_lth + length (SP_AT_SP);
	if address_route_ptr ^= null () then		/* ... have a route: system name may not be known to us */
	     address_representation_lth = address_representation_lth + top_level_length (address_system);
	else if ifo.dont_canonicalize_system_names then	/* ... can't use partial names across top-level domains */
	     address_representation_lth = address_representation_lth + top_level_length (address_system);
	else address_representation_lth =
		address_representation_lth
		+ top_level_length (mlsys_nit_interface_$canonicalize_system_name (address_system));
	if address_route_ptr ^= null () then do;	/* ... include the explicit route */
	     do idx = 1 to address_route.n_relays;
		if ifo.rfc822_format then		/* ... RFC 822 form is:  <@HOST,...,@HOST:LOCAL@HOST> */
		     address_representation_lth = address_representation_lth + length (ATSIGN) + length (COMMA);
		else address_representation_lth = address_representation_lth + length (SP_VIA_SP);
		if idx = 1 then			/* ... only the first relay name is in our NIT */
		     if ifo.dont_canonicalize_system_names then
			address_representation_lth =
			     address_representation_lth + top_level_length (address_route.relays (1));
		     else address_representation_lth =
			     address_representation_lth
			     +
			     top_level_length (
			     mlsys_nit_interface_$canonicalize_system_name (address_route.relays (1)));
		else address_representation_lth =
			address_representation_lth + top_level_length (address_route.relays (idx));
	     end;
	     if ifo.rfc822_format & (length (address_name) = 0) then
		address_representation_lth = address_representation_lth + length (ANGLE_BRACKETS);
	end;
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;

COMPUTE_ADDRESS_WIDTH (7):				/* mail table address */
	call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
	     mail_system_$get_address_string);
	address_representation_lth = address_representation_lth + top_level_length (address_string);
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;

COMPUTE_ADDRESS_WIDTH (8):				/* mailing list address */
	call mail_system_$get_address_pathname (p_address_ptr, address_dirname, address_ename, address_component, (0));
	address_pathname = pathname_$component (address_dirname, address_ename, address_component);
	address_pathname_varying = reverse (after (reverse (address_pathname), reverse (".mls")));
	address_representation_lth =
	     address_representation_lth + structured_length (address_pathname_varying) + length ("{list }")
	     + quotes_if_rfc822 ();
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;

COMPUTE_ADDRESS_WIDTH (9):				/* named group address */
	call mail_system_$get_named_group_display_flag (p_address_ptr, display_list, (0));
	go to END_COMPUTE_ADDRESS_WIDTH_CASE;		/* ... is treated quite differently */

END_COMPUTE_ADDRESS_WIDTH_CASE:
	if ifo.include_local_system_name & ((address_type ^= FOREIGN_ADDRESS) & (address_type ^= NAMED_GROUP_ADDRESS))
	then do;
	     if ifo.dont_canonicalize_system_names then
		address_representation_lth =
		     address_representation_lth + top_level_length (mlsys_nit_interface_$get_local_system_name ());
	     else address_representation_lth =
		     address_representation_lth
		     +
		     top_level_length (
		     mlsys_nit_interface_$canonicalize_system_name (mlsys_nit_interface_$get_local_system_name ()));
	     if ifo.rfc822_format then
		address_representation_lth = address_representation_lth + length (ATSIGN);
	     else address_representation_lth = address_representation_lth + length (SP_AT_SP);
	end;

	if address_type = NAMED_GROUP_ADDRESS then	/* special case: start a newline if it's not first */
	     if display_list then			/* ... but only if the list is going to be displayed */
		if (last_column_used > ifo.indentation) then
		     call new_line ();
		else ;
	     else go to STANDARD_WRAP_CRITERIA;		/* ... otherwise treat it as a normal address */

	else
STANDARD_WRAP_CRITERIA:
	     if (last_column_used > ifo.indentation)	/* never output a newline if the line's still empty */
	     & ((last_column_used + address_representation_lth) > ifo.line_length) then
	     call new_line ();


BEGIN_TO_FORMAT:
	if length (address_name) > 0 then do;		/* put out the address_name */
	     call format_phrase_string (address_name);
	     if address_type = NAMED_GROUP_ADDRESS then
		call add_to_buffer_fixed (COLON_SP);
	     else call add_to_buffer_fixed (SP_LEFT_ANGLE_BRACKET);
	end;

	go to FORMAT_ADDRESS (address_type);

FORMAT_ADDRESS (0):					/* invalid address */
	if ^have_address_data then
	     call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
		mail_system_$get_address_string);
	call format_structured_string ("invalid", address_string);
	go to END_FORMAT_ADDRESS_CASE;

FORMAT_ADDRESS (1):					/* user mailbox address */
	if ^have_address_data then
	     call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
		mail_system_$get_address_string);
	call format_top_level_string (address_string);
	go to END_FORMAT_ADDRESS_CASE;

FORMAT_ADDRESS (2):					/* logbox address */
	if ^have_address_data then
	     call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
		mail_system_$get_address_string);
	if ifo.dont_show_logsave | (address_string ^= mlsys_data_$user_id) then
	     call format_top_level_string (address_string);
	else call format_structured_string ("logbox", "");
	go to END_FORMAT_ADDRESS_CASE;

FORMAT_ADDRESS (3):					/* savebox address */
	if ^have_address_data then do;
	     call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
		mail_system_$get_address_string);
	     call mail_system_$get_address_pathname (p_address_ptr, address_dirname, address_ename, ((32)" "), (0));
	     address_pathname = pathname_ (address_dirname, address_ename);
	end;
	if ifo.dont_show_logsave | (address_string ^= mlsys_data_$user_id) then do;
	     call format_top_level_string (address_string);
	     address_pathname_varying = reverse (after (reverse (address_ename), reverse (".sv.mbx")));
	     call format_comment_string (address_pathname_varying);
	end;
	else do;
	     address_pathname_varying = reverse (after (reverse (address_pathname), reverse (".sv.mbx")));
	     call format_structured_string ("save", address_pathname_varying);
	end;
	go to END_FORMAT_ADDRESS_CASE;

FORMAT_ADDRESS (4):					/* mailbox address */
	if ^have_address_data then do;
	     call mail_system_$get_address_pathname (p_address_ptr, address_dirname, address_ename, ((32)" "), (0));
	     address_pathname = pathname_ (address_dirname, address_ename);
	end;
	address_pathname_varying = reverse (after (reverse (address_pathname), reverse (".mbx")));
	call format_structured_string ("mbx", address_pathname_varying);
	go to END_FORMAT_ADDRESS_CASE;

FORMAT_ADDRESS (5):					/* forum address */
	if ^have_address_data then do;
	     call mail_system_$get_address_pathname (p_address_ptr, address_dirname, address_ename, ((32)" "), (0));
	     if address_dirname = "" then		/* ... null dirname => not found in "forum" search list */
		address_pathname_varying = rtrim (address_ename);
	     else address_pathname_varying = rtrim (pathname_ (address_dirname, address_ename));
	end;
	if ^ifo.include_forum_suffix then		/* ... caller doesn't need the suffix for later use */
	     if index (reverse (address_pathname_varying), reverse (".forum")) = 1 then
		address_pathname_varying =
		     substr (address_pathname_varying, 1, (length (address_pathname_varying) - length (".forum")));
	     else if index (reverse (address_pathname_varying), reverse (".control")) = 1 then
		address_pathname_varying =
		     substr (address_pathname_varying, 1, (length (address_pathname_varying) - length (".control")));
	call format_structured_string ("forum", address_pathname_varying);
	go to END_FORMAT_ADDRESS_CASE;

FORMAT_ADDRESS (6):					/* foreign address */
	if ^have_address_data then do;
	     call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
		mail_system_$get_address_string);
	     call mail_system_$get_address_system (p_address_ptr, address_system, (0));
	     address_route_ptr = null ();		/* ... in case there is no route */
	     call mail_system_$get_address_route (p_address_ptr, ADDRESS_ROUTE_VERSION_1, address_route_ptr, (0));
	end;
	if ifo.rfc822_format then do;			/* ... RFC 822 format */
	     if address_route_ptr ^= null () then do;	/* ... ... we'll be creating a "path": add "<" if nameless */
		if length (address_name) = 0 then call add_to_buffer_fixed (LEFT_ANGLE_BRACKET);
		do idx = 1 to address_route.n_relays;
		     if idx > 1 then call add_to_buffer_fixed (COMMA);
		     call add_to_buffer_fixed (ATSIGN);
		     if idx = 1 then		/* ... only the first relay name is in our tables */
			if ifo.dont_canonicalize_system_names then
			     call format_top_level_string (address_route.relays (1));
			else call format_top_level_string (
				mlsys_nit_interface_$canonicalize_system_name (address_route.relays (1)));
		     else call format_top_level_string (address_route.relays (idx));
		end;
		call add_to_buffer_fixed (COLON);
	     end;
	     call format_top_level_string (address_string);
	     call add_to_buffer_fixed (ATSIGN);
	     if address_route_ptr ^= null () then	/* ... if there's a route, this name may not be in NIT */
		call format_top_level_string (address_system);
	     else if ifo.dont_canonicalize_system_names then call format_top_level_string (address_system);
	     else call format_top_level_string (mlsys_nit_interface_$canonicalize_system_name (address_system));
	     if (address_route_ptr ^= null ()) & (length (address_name) = 0) then
		call add_to_buffer_fixed (RIGHT_ANGLE_BRACKET);
	end;
	else do;					/* ... Multics format */
	     call format_top_level_string (address_string);
	     call add_to_buffer_fixed (SP_AT_SP);
	     if address_route_ptr ^= null () then	/* ... if there's a route, this name may not be in NIT */
		call format_top_level_string (address_system);
	     else if ifo.dont_canonicalize_system_names then call format_top_level_string (address_system);
	     else call format_top_level_string (mlsys_nit_interface_$canonicalize_system_name (address_system));
	     if address_route_ptr ^= null () then	/* Multics routes come out "backwards" */
		do idx = address_route.n_relays to 1 by -1;
		call add_to_buffer_fixed (SP_VIA_SP);
		if idx = 1 then			/* ... only the first relay name is in our tables */
		     if ifo.dont_canonicalize_system_names then
			call format_top_level_string (address_route.relays (1));
		     else call format_top_level_string (
			     mlsys_nit_interface_$canonicalize_system_name (address_route.relays (1)));
		else call format_top_level_string (address_route.relays (idx));
	     end;
	end;
	go to END_FORMAT_ADDRESS_CASE;

FORMAT_ADDRESS (7):					/* mail table address */
	if ^have_address_data then
	     call get_address_variable (local_address_string, address_string_ptr, address_string_max_lth,
		mail_system_$get_address_string);
	call format_top_level_string (address_string);
	go to END_FORMAT_ADDRESS_CASE;

FORMAT_ADDRESS (8):					/* mailing list address */
	if ^have_address_data then do;
	     call mail_system_$get_address_pathname (p_address_ptr, address_dirname, address_ename, address_component,
		(0));
	     address_pathname = pathname_$component (address_dirname, address_ename, address_component);
	end;
	address_pathname_varying = reverse (after (reverse (address_pathname), reverse (".mls")));
	call format_structured_string ("list", address_pathname_varying);
	go to END_FORMAT_ADDRESS_CASE;

FORMAT_ADDRESS (9):					/* named group address */
	if ^have_address_data then call mail_system_$get_named_group_display_flag (p_address_ptr, display_list, (0));
	if display_list then do;			/* ... show the list */
	     saved_indentation = ifo.indentation;
	     ifo.indentation = last_column_used;	/* ... make the address in the list line up */
	     call mail_system_$expand_list_address (p_address_ptr, ADDRESS_LIST_VERSION_2, address_list_ptr, (0));
	     call format_address_list (address_list_ptr);
	     ifo.indentation = saved_indentation;
	end;

END_FORMAT_ADDRESS_CASE:
	if ifo.include_local_system_name & ((address_type ^= FOREIGN_ADDRESS) & (address_type ^= NAMED_GROUP_ADDRESS))
	then do;
	     if ifo.rfc822_format then
		call add_to_buffer_fixed (ATSIGN);
	     else call add_to_buffer_fixed (SP_AT_SP);
	     if ifo.dont_canonicalize_system_names then
		call format_top_level_string (mlsys_nit_interface_$get_local_system_name ());
	     else call format_top_level_string (
		     mlsys_nit_interface_$canonicalize_system_name (mlsys_nit_interface_$get_local_system_name ()));
	end;

	if length (address_name) > 0 then		/* close off the address */
	     if address_type = NAMED_GROUP_ADDRESS then
		call add_to_buffer_fixed (SEMICOLON);
	     else call add_to_buffer_fixed (RIGHT_ANGLE_BRACKET);

	if length (address_comment) > 0 then call format_comment_string (address_comment);

	if length (p_address_suffix) > 0 then call add_to_buffer_varying (p_address_suffix);

	return;



/* Internal to format_address: gets one of the variables (string, name, comment) associated with an address; it will grow
   the format_address stack frame as necessary */

get_address_variable:
	procedure (p_local_variable, p_variable_ptr, p_variable_max_lth, p_get_primitive);

dcl  p_local_variable character (256) varying parameter;
dcl  p_variable_ptr pointer parameter;
dcl  p_variable_max_lth fixed binary (21) parameter;
dcl  p_get_primitive entry (pointer, character (*) varying, fixed binary (35));

dcl  p_variable character (p_variable_max_lth) varying based (p_variable_ptr);
dcl  code fixed binary (35);

	     p_variable_ptr = addr (p_local_variable);	/* assume it will fit in the preallocated space */
	     p_variable_max_lth = maxlength (p_local_variable);

	     call p_get_primitive (p_address_ptr, p_variable, code);

	     if code = error_table_$smallarg then do;	/* too large for the preallocated space ... */
		call cu_$grow_stack_frame (STACK_EXTENSION, p_variable_ptr, (0));
		p_variable_max_lth = 4 * (STACK_EXTENSION - 1);

		call p_get_primitive (p_address_ptr, p_variable, code);
						/* try again using space at the end of the stack ... */

		do while (code = error_table_$smallarg);/* ... and keep trying 'till it fits */
		     call cu_$grow_stack_frame (STACK_EXTENSION, (null ()), (0));
		     p_variable_max_lth = p_variable_max_lth + (4 * STACK_EXTENSION);
		     call p_get_primitive (p_address_ptr, p_variable, code);
		end;
	     end;

	     return;

	end get_address_variable;

     end format_address;
%page;
/* Actually formats an address list (called by numerous entrypoints) */

format_address_list:
     procedure (p_address_list_ptr);

dcl  p_address_list_ptr pointer parameter;
dcl  idx fixed binary;

	if p_address_list_ptr -> address_list.n_addresses = 0 then return;

	do idx = 1 to (p_address_list_ptr -> address_list.n_addresses - 1);
	     call format_address (p_address_list_ptr -> address_list.addresses (idx), (COMMA_SP));
	end;

	call format_address (p_address_list_ptr
	     -> address_list.addresses (p_address_list_ptr -> address_list.n_addresses), "");

	return;

     end format_address_list;
%page;
/* Actually formats a date/time (called by numerous entrypoints) */

format_date_time:
     procedure (p_date_time, p_include_dow);

dcl  p_date_time fixed binary (71) parameter;
dcl  p_include_dow bit (1) aligned parameter;

dcl  four_digits_picture picture "9999";
dcl  two_digits_picture picture "99";
dcl  time_zone character (3);
dcl  recognized_zone bit (1) aligned;
dcl  code fixed binary (35);
dcl  (month, day_of_month, year, hour, minute, day_of_week, offset, hours, minutes, process_zone_offset, idx) fixed
	binary;


	time_zone = "";				/* use the time zone of this process */

	call decode_clock_value_$date_time (p_date_time, month, day_of_month, year, hour, minute, (0), (0), day_of_week,
	     time_zone, code);
	if code ^= 0 then do;			/* shouldn't happen: provide some output anyway */
	     month, day_of_month = 1;			/* ... use the base time for Multics clocks */
	     day_of_week = 2;			/* ... which was a Tuesday */
	     year = 1901;
	     hour, minute = 0;
	     time_zone = "gmt";
	end;

	if ifo.rfc822_format then			/* networks use uppercase zones; Multics uses lowercase */
	     time_zone = translate (time_zone, UPPERCASE, LOWERCASE);
	else time_zone = translate (time_zone, LOWERCASE, UPPERCASE);

	if printing then				/* always use the process time-zone if displaying the date */
	     recognized_zone = "1"b;
	else do;					/* check if other processes/systems will understand it */
	     recognized_zone = "0"b;
	     if ifo.rfc822_format then do;		/* ... formatting for the network (ie: other systems) */
		process_zone_offset = divide ((-time_data_$time_delta), ONE_MINUTE, 17, 0);
		do idx = lbound (RFC822_ZONES, 1) to hbound (RFC822_ZONES, 1) while (^recognized_zone);
		     if (time_zone = RFC822_ZONES (idx)) & (process_zone_offset = RFC822_ZONE_OFFSETS (idx)) then
			recognized_zone = "1"b;
		end;
	     end;
	     else do;				/* ... formatting for this Multics system */
		do idx = 1 to ti_zone.number_lang while (^recognized_zone);
		     do jdx = 1 to ti_zone.number_zone while (^recognized_zone);
			if (time_zone = translate (ti_zone.short (idx, jdx), LOWERCASE, UPPERCASE))
			     & (time_data_$time_delta = ti_zone.delta (idx, jdx)) then
			     recognized_zone = "1"b;
		     end;
		end;
	     end;
	end;

	if p_include_dow then do;			/* callers wants the day of the week */
	     if ifo.rfc822_format then		/* ... networks use short names; Multics uses long names */
		call add_to_buffer_fixed (RFC822_DAY_OF_WEEKS (day_of_week));
	     else call add_to_buffer_varying (DAY_OF_WEEKS (day_of_week));
	     call add_to_buffer_fixed (COMMA_SP);
	end;

	call add_to_buffer_fixed (ltrim (convert (two_digits_picture, day_of_month), "0"));
	call add_to_buffer_fixed (SP);

	if ifo.rfc822_format then			/* networks use short names; Multics uses long names */
	     call add_to_buffer_fixed (RFC822_MONTHS (month));
	else call add_to_buffer_varying (MONTHS (month));
	call add_to_buffer_fixed (SP);

	if ifo.rfc822_format then			/* networks use 2 digit years; Multics uses four digits */
	     call add_to_buffer_fixed (convert (two_digits_picture, mod (year, 100)));
	else call add_to_buffer_fixed (convert (four_digits_picture, year));
	call add_to_buffer_fixed (SP);

	call add_to_buffer_fixed (convert (two_digits_picture, hour));
	call add_to_buffer_fixed (COLON);

	call add_to_buffer_fixed (convert (two_digits_picture, minute));

	if recognized_zone then do;			/* we recognize the time zone */
	     call add_to_buffer_fixed (SP);
	     call add_to_buffer_fixed (rtrim (time_zone));
	end;
	else do;					/* non-standard zone: record its offset instead */
	     if time_data_$time_delta > 0 then		/* ... Multics uses negative of the ISO offset */
		call add_to_buffer_fixed (HYPHEN);
	     else call add_to_buffer_fixed (PLUS);
	     offset = divide (abs (time_data_$time_delta), ONE_MINUTE, 35, 0);
	     hours = divide (offset, ONE_HOUR, 17, 0);	/* ... convert into HHMM */
	     minutes = mod (offset, ONE_HOUR);
	     call add_to_buffer_fixed (convert (two_digits_picture, hours));
	     call add_to_buffer_fixed (convert (two_digits_picture, minutes));
	end;

	return;

     end format_date_time;
%page;
/* Actually formats a Message-ID */

format_message_id:
     procedure (p_message_id) options (non_quick);

dcl  p_message_id bit (72) aligned parameter;

dcl  message_id_string character (message_id_string_max_lth) varying based (message_id_string_ptr);
dcl  message_id_string_ptr pointer;
dcl  message_id_string_max_lth fixed binary (21);

dcl  local_message_id_string character (256) varying;
dcl  message_id_system character (256) varying;
dcl  is_local_system bit (1) aligned;
dcl  code fixed binary (35);


	message_id_string_ptr = addr (local_message_id_string);
	message_id_string_max_lth = maxlength (local_message_id_string);
						/* assume it will fit in the preallocated space */

	call mail_system_$decode_message_id (p_message_id, message_id_string, message_id_system, is_local_system, code);

	if code = error_table_$smallarg then do;	/* too large for the preallocated space ... */
	     call cu_$grow_stack_frame (STACK_EXTENSION, message_id_string_ptr, (0));
	     message_id_string_max_lth = 4 * (STACK_EXTENSION - 1);

	     call mail_system_$decode_message_id (p_message_id, message_id_string, message_id_system, is_local_system,
		code);				/* try again using space at the end of the stack ... */

	     do while (code = error_table_$smallarg);	/* ... and keep trying 'till it fits */
		call cu_$grow_stack_frame (STACK_EXTENSION, (null ()), (0));
		message_id_string_max_lth = message_id_string_max_lth + (4 * STACK_EXTENSION);
		call mail_system_$decode_message_id (p_message_id, message_id_string, message_id_system,
		     is_local_system, code);
	     end;
	end;

	call add_to_buffer_fixed (LEFT_ANGLE_BRACKET);

	call format_top_level_string (message_id_string);

	if ifo.include_local_system_name | ^is_local_system then do;
	     if ifo.rfc822_format then
		call add_to_buffer_fixed (ATSIGN);
	     else call add_to_buffer_fixed (SP_AT_SP);
	     if ifo.dont_canonicalize_system_names then
		call add_to_buffer_varying (message_id_system);
	     else call add_to_buffer_varying (mlsys_nit_interface_$canonicalize_system_name (message_id_system));
	end;

	call add_to_buffer_fixed (RIGHT_ANGLE_BRACKET);

	return;

     end format_message_id;
%page;
/* Actually formats a list of references to other messages */

format_references_list:
     procedure (p_message_references_list_ptr) options (non_quick);

dcl  p_message_references_list_ptr pointer parameter;
dcl  idx fixed binary;

	message_references_list_ptr = p_message_references_list_ptr;

	do idx = 1 to message_references_list.n_references;
	     call format_reference (addr (message_references_list.references (idx)));
	     if idx < message_references_list.n_references then do;
		call add_to_buffer_fixed (COMMA);	/* must separate each reference from the next */
		call new_line ();
	     end;
	end;

	return;



/* Internal to format_references_list: formats a single message reference.  If the reference only has a Message-ID, the
   text of the ID is used as the text of the field */

format_reference:
	procedure (p_message_reference_ptr);

dcl  p_message_reference_ptr pointer parameter;

dcl  message_id_string character (message_id_string_max_lth) varying based (message_id_string_ptr);
dcl  message_id_string_ptr pointer;
dcl  message_id_string_max_lth fixed binary (21);

dcl  author_string character (256) varying;		/* will be truncated if necessary */
dcl  local_message_id_string character (256) varying;
dcl  code fixed binary (35);


	     message_reference_ptr = p_message_reference_ptr;

	     ifo.indentation = ifo.indentation + 5;	/* in case something wraps (which it won't) */

	     if (message_reference.date_time_created > 0) & (message_reference.from ^= null ()) then do;
		/*** A modern reference: create the "Message of DATE from AUTHOR" format of reference */
		call add_to_buffer_fixed ("Message of ");
		call format_date_time (message_reference.date_time_created, "0"b);
		call add_to_buffer_fixed (" from ");
		call mlsys_misc_utils_$get_best_address_name (message_reference.from -> address_list.addresses (1),
		     author_string, (0));
		call format_top_level_string (author_string);
	     end;

	     else do;
		/*** A old reference: get its text from the Message-ID and print it (newlines and all) */
		message_id_string_ptr = addr (local_message_id_string);
		message_id_string_max_lth = maxlength (local_message_id_string);
		call mail_system_$decode_message_id (message_reference.message_id, message_id_string, (""), ("0"b),
		     code);
		if code = error_table_$smallarg then do;
		     call cu_$grow_stack_frame (STACK_EXTENSION, message_id_string_ptr, (0));
		     message_id_string_max_lth = 4 * (STACK_EXTENSION - 1);
		     call mail_system_$decode_message_id (message_reference.message_id, message_id_string, (""),
			("0"b), code);
		     do while (code = error_table_$smallarg);
			call cu_$grow_stack_frame (STACK_EXTENSION, (null ()), (0));
			message_id_string_max_lth = message_id_string_max_lth + (4 * STACK_EXTENSION);
			call mail_system_$decode_message_id (message_reference.message_id, message_id_string, (""),
			     ("0"b), code);
		     end;
		end;
		call add_to_buffer_varying (message_id_string);
	     end;					/* sure would be nice to format it but it's random text */

	     ifo.indentation = ifo.indentation - 5;

	     return;

	end format_reference;

     end format_references_list;
%page;
/* Actually formats a piece of text which is to appear in the message envelope, header, or redistributions list (called by
   several entrypoints) */

format_text:
     procedure (p_text, p_multiline_text);

dcl  p_text character (*) parameter;
dcl  p_multiline_text bit (1) aligned parameter;

	if p_multiline_text then			/* just invoke the proper internal procedure */
	     call format_multiline_text (p_text);
	else call format_single_line_text (p_text);

	return;



/* Internal to format_text: formats a piece of text which is a single line field; as the mail system will turn such text
   back into a single line field, this procedure will wrap the text at the requested line length for readability */

format_single_line_text:
	procedure (p_text);

dcl  p_text character (*) parameter;

dcl  (text_lth, text_used, space_left_on_line, idx) fixed binary (21);


	     text_used = verify (p_text, SP) - 1;	/* mail system guarentees only spaces; no other whitespace */
	     if text_used = -1 then return;		/* ... it's a blank field */

	     begin;				/* strip trailing whitespace */
dcl  text character (length (p_text) - text_used) unaligned defined (p_text) position (text_used + 1);
		text_lth = length (rtrim (text, SP));
		text_lth = text_lth + text_used;	/* ... get true length for proper use of defined */
	     end;


	     if ifo.wrap then do;			/* text must be split to fit within request line length ... */

		do while (text_used < text_lth);
		     begin;
dcl  rest_of_text character (text_lth - text_used) unaligned defined (p_text) position (text_used + 1);

			space_left_on_line = ifo.line_length - last_column_used;

			if length (rest_of_text) <= space_left_on_line then
			     idx = length (rest_of_text) + 1;

			else do;			/* find an appropriate place to split the text */
			     begin;
dcl  text_substring character (space_left_on_line) unaligned defined (p_text) position (text_used + 1);
				idx = length (text_substring) - index (reverse (text_substring), SP) + 1;
				if idx = (length (text_substring) + 1) then do;
				     idx = index (rest_of_text, SP);
				     if idx = 0 then idx = length (rest_of_text) + 1;
				end;		/* do-group is executed iff the substring is a ... */
			     end;			/* ... single word longer than the space left on the line */
			end;

			begin;			/* output all but the space on which we split the text */
dcl  output_substring character (idx - 1) unaligned defined (p_text) position (text_used + 1);
			     call add_to_buffer_fixed (output_substring);
			end;

			text_used = text_used + idx;	/* the SP is never actuall sent: but a NL is if needed */

			if text_used < length (p_text) then call new_line ();
		     end;				/* ... there's more to come */
		end;
	     end;


	     else call add_to_buffer_fixed (p_text);	/* no line wrapping requested: just output the text as is */


	     return;

	end format_single_line_text;



/* Internal to format_text: formats a multiline text text fieldfor subsquent displayby insuring each line starts out at
   least at the indentation column and that no blank lines appear in the printed representation */

format_multiline_text:
	procedure (p_text);

dcl  p_text character (*) parameter;

dcl  first_line bit (1) aligned;
dcl  (text_lth, text_used, idx) fixed binary (21);


	     text_used = verify (p_text, WHITESPACE) - 1;
	     if text_used = -1 then return;		/* nothing in the field but whitespace */

	     begin;				/* strip trailing whitespace */
dcl  text character (length (p_text) - text_used) unaligned defined (p_text) position (text_used + 1);
		text_lth = length (rtrim (text, WHITESPACE));
		text_lth = text_lth + text_used;	/* ... get proper length for use of defined */
	     end;


	     if ifo.indentation <= MAX_MULTILINE_INDENTATION then do;
		ifo.indentation = max (1, (ifo.indentation - length (MULTILINE_BLANK_LINE_DESIGNATOR)));
		first_line = "1"b;			/* ... this line is already at the proper indentation */
	     end;

	     else do;				/* enforce a maximum indentation for aesthetic reasons */
		begin;				/* ... strip any trailing whitespace after fieldname ... */
dcl  buffer_in_use character (buffer_used) unaligned defined (buffer) position (1);
		     buffer_used = length (rtrim (buffer_in_use, SP));
		end;
		ifo.indentation = STANDARD_MULTILINE_INDENTATION - length (MULTILINE_BLANK_LINE_DESIGNATOR);
		call new_line ();			/* ... and start a new line */
		first_line = "0"b;
	     end;


	     do while (text_used < length (p_text));
		begin;
dcl  rest_of_text character (length (p_text) - text_used) unaligned defined (p_text) position (text_used + 1);

		     idx = index (rest_of_text, NL);
		     if idx = 0 then idx = length (rest_of_text) + 1;
		end;

		begin;
dcl  the_line character (idx - 1) unaligned defined (p_text) position (text_used + 1);

		     if verify (the_line, WHITESPACE) = 0 then
			call add_to_buffer_fixed (MULTILINE_BLANK_LINE_DESIGNATOR);

		     else do;
			if ^first_line then call add_to_buffer_fixed (SPSP);
			call add_to_buffer_fixed (the_line);
		     end;
		end;

		first_line = "0"b;			/* can't be on the first line anymore */
		text_used = text_used + idx;		/* skip to next line */

		if text_used < text_lth then call new_line ();
	     end;					/* more to come */

	     return;

	end format_multiline_text;

     end format_text;
%page;
/* Actually formats a section of the message body (called by several entrypoints):  This procedure violates the modularity
   of this program by its use of the knowledge of whether we are printing or formatting in order to cut down on the number
   iox_$put_chars calls per body section */

format_body_section_internal:
     procedure (p_body_section_ptr);

dcl  p_body_section_ptr pointer parameter;

dcl  the_line character (80) varying;
dcl  words (4) bit (36) aligned;
dcl  words_as_characters (4) character (4) aligned based (addr (words));
dcl  last_line_printed (4) bit (36) aligned;
dcl  translated_words (4) character (4) aligned;
dcl  in_duplicate bit (1) aligned;
dcl  (n_words, n_lines, n_words_on_line, n_bits_in_last_word, offset, idx, jdx, kdx) fixed binary;


	message_body_section_ptr = p_body_section_ptr;	/* none of our caller's uses this variable */

	go to FORMAT_BODY_SECTION (message_body_section.section_type);


FORMAT_BODY_SECTION (1):				/* preformatted text: use single iox_$put_chars if possible */
	if printing then do;
	     call print_buffer ();			/* ... dump anything that's still pending */
	     call iox_$put_chars (output_switch, message_preformatted_body_section.text_ptr,
		message_preformatted_body_section.text_lth, code);
	     if code ^= 0 then do;			/* ... fatal error */
		P_code = code;
		go to RETURN_FROM_FORMAT_ENTRY_WITH_ERROR;
	     end;
	     if substr (message_preformatted_body_section_text, message_preformatted_body_section.text_lth, 1) ^= NL
		then
		call iox_$put_chars (output_switch, addr (NL), 1, (0));
	     line_count = count_lines_in_text (message_preformatted_body_section_text);
	     last_column_used = 0;			/* ... guarenteed to now be at the start of a line */
	end;

	else do;
	     call add_to_buffer_fixed (message_preformatted_body_section_text);
	     if substr (message_preformatted_body_section_text, message_preformatted_body_section.text_lth, 1) ^= NL
		then
		call add_to_buffer_fixed (NL);	/* ... insure a trailing newline in the section */
	end;

	return;


FORMAT_BODY_SECTION (2):				/* bit string: generated dump_segment-like output */
	n_words = divide ((message_bit_string_body_section.bit_string_lth + 35), 36, 18, 0);
	n_lines = divide ((n_words + 3), 4, 18, 0);

	unspec (last_line_printed) = ""b;		/* nothing printed (will set this before it's checked) */
	in_duplicate = "0"b;			/* not suppressing duplicate lines yet */

	offset = 0;				/* offset from start of the string */

	do idx = 1 to n_lines;
	     if idx = n_lines then do;
		n_words_on_line = mod (n_words, 4);
		if n_words_on_line = 0 then n_words_on_line = 4;
		n_bits_in_last_word = mod (message_bit_string_body_section.bit_string_lth, 36);
		if n_bits_in_last_word = 0 then n_bits_in_last_word = 36;
	     end;
	     else do;
		n_words_on_line = 4;
		n_bits_in_last_word = 36;
	     end;
	     do jdx = 1 to (n_words_on_line - 1);
		unspec (words (jdx)) =
		     substr (message_bit_string_body_section_bit_string, (36 * (4 * (idx - 1) + jdx - 1) + 1), 36);
	     end;
	     unspec (words (n_words_on_line)) =
		substr (message_bit_string_body_section_bit_string, (36 * (4 * (idx - 1) + n_words_on_line - 1) + 1),
		n_bits_in_last_word);
	     do jdx = 1 to n_words_on_line;
		do kdx = 1 to 4;
		     if index (SINGLE_WIDTH_CHARACTERS, substr (words_as_characters (jdx), kdx, 1)) = 0 then
			substr (translated_words (jdx), kdx, 1) = ".";
		     else substr (translated_words (jdx), kdx, 1) = substr (words_as_characters (jdx), kdx, 1);
		end;
	     end;
	     if (idx = 1) & (idx = n_lines) then do;	/* don't perform duplicate suppression on 1st/last lines */
DISPLAY_THIS_LINE_OF_DUMP:
		call ioa_$rsnnl ("^6.3b", the_line, (0), bit (binary (offset, 18, 0), 18));
		call ioa_$rsnnl ("^a^v( ^12.3b^)", the_line, (0), the_line, n_words_on_line, words (*));
		call ioa_$rsnnl ("^a^vx^v(^4a^)", the_line, (0), the_line, (13 * (4 - n_words_on_line) + 1),
		     n_words_on_line, translated_words (*));
		call add_to_buffer_varying (the_line);
		call add_to_buffer_fixed (NL);
		unspec (last_line_printed) = unspec (words);
		in_duplicate = "0"b;
	     end;
	     else if unspec (words) ^= unspec (last_line_printed) then go to DISPLAY_THIS_LINE_OF_DUMP;
	     else do;				/* a duplicate line */
		if ^in_duplicate then do;
		     call add_to_buffer_fixed ("======");
		     call add_to_buffer_fixed (NL);
		end;
		in_duplicate = "1"b;
	     end;


	     offset = offset + 4;
	end;

	return;

     end format_body_section_internal;
%page;
/* Computes the width of phrases which appear outside of comments and structured addresses */

simple_lengths:
     procedure (p_string) returns (fixed binary (21));

	return (0);				/* not an entrypoint */

dcl  p_string character (*) varying parameter;

dcl  must_requote bit (1) aligned;
dcl  (string_lth, used, idx) fixed binary (21);


phrase_length:					/* RFC822 format may contain spaces but no unquoted periods */
     entry (p_string) returns (fixed binary (21));

	if ifo.rfc822_format then			/* check for requoting with the proper specials */
	     must_requote =
		(search (p_string, TOP_LEVEL_RFC822_REQUOTE) ^= 0) | (index (p_string, PERIOD) ^= 0)
		| (index (p_string, SPSP) ^= 0);
	else must_requote = (search (p_string, TOP_LEVEL_REQUOTE) ^= 0) | (index (p_string, SPSP) ^= 0);
	go to COMPUTE_THE_LENGTH;


top_level_length:					/* RFC822 format must be quoted for single spaces */
     entry (p_string) returns (fixed binary (21));

	if ifo.rfc822_format then			/* check for requoting with the proper specials */
	     must_requote = (search (p_string, TOP_LEVEL_RFC822_REQUOTE) ^= 0) | (index (p_string, SP) ^= 0);
	else must_requote = (search (p_string, TOP_LEVEL_REQUOTE) ^= 0) | (index (p_string, SPSP) ^= 0);


COMPUTE_THE_LENGTH:
	if must_requote then			/* start out with surrounding quotes */
	     string_lth = 2 * length (QUOTE);
	else return (length (p_string));		/* can use it just the way it is */

	used = 0;

	do while (used < length (p_string));
	     if ifo.rfc822_format then		/* find next character which must be escaped */
		idx = search (substr (p_string, (used + 1)), BACKSLASH_QUOTE_NL);
	     else idx = search (substr (p_string, (used + 1)), QUOTE_NL);
	     if idx = 0 then idx = length (p_string) - used + 1;
	     string_lth = string_lth + idx - 1;
	     used = used + idx - 1;			/* skip past normal characters */
	     if used < length (p_string) then do;
		string_lth = string_lth + 2;		/* escape character (quote/backslash) plus the character */
		used = used + 1;
		if ifo.rfc822_format then		/* for RFC822: newlines are printed as three characters */
		     if substr (p_string, used, 1) = NL then string_lth = string_lth + 1;
	     end;
	end;

	return (string_lth);

     end simple_lengths;
%page;
/* Computes the length of a string which is used within a structured address: always uses Multics conventions for those
   characters which must be escaped but, for RFC822 format, the entire text will be quoted */

structured_length:
     procedure (p_string) returns (fixed binary (21));

dcl  p_string character (*) varying parameter;

dcl  must_requote bit (1) aligned;
dcl  (string_lth, used, idx) fixed binary (21);


	if ifo.rfc822_format then			/* check for requoting with the proper specials */
	     must_requote = (search (p_string, STRUCTURED_RFC822_REQUOTE) ^= 0);
	else must_requote = (search (p_string, STRUCTURED_REQUOTE) ^= 0);

	if must_requote then			/* start out with surrounding quotes */
	     if ifo.rfc822_format then		/* ... these quotes are within quotes: preceed them "\" */
		string_lth = 2 * length (BACKSLASH_QUOTE);
	     else string_lth = 2 * length (QUOTE);
	else return (length (p_string));		/* can use it just the way it is */

	used = 0;

	do while (used < length (p_string));
	     if ifo.rfc822_format then		/* find next character which must be escaped */
		idx = search (substr (p_string, (used + 1)), BACKSLASH_QUOTE_NL);
	     else idx = search (substr (p_string, (used + 1)), QUOTE_NL);
	     if idx = 0 then idx = length (p_string) - used + 1;
	     string_lth = string_lth + idx - 1;
	     used = used + idx - 1;			/* skip past normal characters */
	     if used < length (p_string) then do;
		string_lth = string_lth + 2;		/* escape character (quote/backslash) plus the character */
		used = used + 1;
		if ifo.rfc822_format then		/* for RFC822: newlines are printed as three characters */
		     if substr (p_string, used, 1) = NL then string_lth = string_lth + 1;
		if ifo.rfc822_format then		/* for RFC822: quotes are printed as four(!) characters */
		     if substr (p_string, used, 1) = QUOTE then string_lth = string_lth + length (BACKSLASH_QUOTE);
	     end;
	end;

	return (string_lth);

     end structured_length;
%page;
/* Computes the width of a string which is a comment */

comment_length:
     procedure (p_string) returns (fixed binary (21));

dcl  p_string character (*) varying parameter;

dcl  must_requote bit (1) aligned;
dcl  (string_lth, used, idx) fixed binary (21);

	if ifo.rfc822_format then			/* check for requoting with the proper specials */
	     must_requote = (search (p_string, COMMENT_RFC822_REQUOTE) ^= 0);
	else must_requote = (search (p_string, COMMENT_REQUOTE) ^= 0);

	if must_requote then
	     if ifo.rfc822_format then		/* RFC822 comment: quotes aren't special */
		string_lth = 0;
	     else string_lth = 2 * length (QUOTE);	/* start out with surrounding quotes */
	else return (length (p_string));		/* can use it just the way it is */

	used = 0;

	do while (used < length (p_string));
	     if ifo.rfc822_format then		/* find next character which must be escaped */
		idx = search (substr (p_string, (used + 1)), BACKSLASH_PARENS_NL);
	     else idx = search (substr (p_string, (used + 1)), QUOTE_NL);
	     if idx = 0 then idx = length (p_string) - used + 1;
	     string_lth = string_lth + idx - 1;
	     used = used + idx - 1;			/* skip past normal characters */
	     if used < length (p_string) then do;
		string_lth = string_lth + 2;		/* escape character (quote/backslash) plus the character */
		used = used + 1;
		if ifo.rfc822_format then		/* for RFC822: newlines are printed as three characters */
		     if substr (p_string, used, 1) = NL then string_lth = string_lth + 1;
	     end;
	end;

	return (string_lth);

     end comment_length;
%page;
/* Places phrases which appear outside of comments and structured addresses into the output buffer */

format_simple_strings:
     procedure (p_string);

	return;					/* not an entrypoint */

dcl  p_string character (*) varying parameter;

dcl  1 the_string aligned based (addr (p_string)),
       2 lth fixed binary (21),
       2 string character (maxlength (p_string));

dcl  the_character character (1);
dcl  must_requote bit (1) aligned;
dcl  (used, idx) fixed binary (21);


format_phrase_string:				/* RFC822 format may contain spaces but no unquoted periods */
     entry (p_string);

	if ifo.rfc822_format then			/* check for requoting with the proper specials */
	     must_requote =
		(search (p_string, TOP_LEVEL_RFC822_REQUOTE) ^= 0) | (index (p_string, PERIOD) ^= 0)
		| (index (p_string, SPSP) ^= 0);
	else must_requote = (search (p_string, TOP_LEVEL_REQUOTE) ^= 0) | (index (p_string, SPSP) ^= 0);
	go to OUTPUT_THE_STRING;


format_top_level_string:				/* RFC822 format must be quoted for single spaces */
     entry (p_string);

	if ifo.rfc822_format then			/* check for requoting with the proper specials */
	     must_requote = (search (p_string, TOP_LEVEL_RFC822_REQUOTE) ^= 0) | (index (p_string, SP) ^= 0);
	else must_requote = (search (p_string, TOP_LEVEL_REQUOTE) ^= 0) | (index (p_string, SPSP) ^= 0);


OUTPUT_THE_STRING:
	if ^must_requote then do;			/* simplest case: just put it out verbatim */
	     call add_to_buffer_varying (p_string);
	     return;
	end;

	call add_to_buffer_fixed (QUOTE);

	used = 0;

	do while (used < length (p_string));
	     if ifo.rfc822_format then		/* find next character which must be escaped */
		idx = search (substr (p_string, (used + 1)), BACKSLASH_QUOTE_NL);
	     else idx = search (substr (p_string, (used + 1)), QUOTE_NL);
	     if idx = 0 then idx = length (p_string) - used + 1;
	     if idx > 1 then call add_to_buffer (addcharno (addr (the_string.string), used), (idx - 1));
	     used = used + idx - 1;			/* skip past normal characters */
	     if used < length (p_string) then do;	/* process the special character */
		used = used + 1;
		the_character = substr (p_string, used, 1);
		if ifo.rfc822_format then do;
		     call add_to_buffer_fixed (BACKSLASH);
		     call add_to_buffer_fixed (the_character);
		     if the_character = NL then call add_to_buffer_fixed (SP);
		end;
		else do;
		     if the_character = QUOTE then
			call add_to_buffer_fixed (QUOTE_QUOTE);
		     else call add_to_buffer_fixed (NLSP);
		end;
	     end;
	end;

	call add_to_buffer_fixed (QUOTE);		/* close the string */

	return;

     end format_simple_strings;
%page;
/* format: ^indcomtxt */

/* Places a structured address into the output buffer:  When generating Multics format, the entire address is left
   unquoted (ie: the braces ({}) are the first and last characters of the address) and the arguument string, if any, is
   quoted if necessary.  When generating RFC822 format, however, the entire address is quoted as it would be syntactically
   incorrect otherwise.  Further, if the argument string needs quoting, it is done using the Multics doubling convention
   with the RFC822 backslash escape added on top.  In other words, if the printed presentation on Multics is

				  {list ">udd>""Multi Homed"">hackers"}

   then the RFC822 representation will be

			        "{list \">udd>\"\"Multi Homed\"\">hackers\"}"
   */

/* format: indcomtxt */

format_structured_string:
     procedure (p_address_type_string, p_string);

dcl  p_address_type_string character (*) parameter;
dcl  p_string character (*) varying parameter;

dcl  1 the_string aligned based (addr (p_string)),
       2 lth fixed binary (21),
       2 string character (maxlength (p_string));

dcl  the_character character (1);
dcl  must_requote bit (1) aligned;
dcl  (used, idx) fixed binary (21);


	if ifo.rfc822_format then			/* always quote these addresses in RFC 822 land */
	     call add_to_buffer_fixed (QUOTE_LEFT_BRACE);
	else call add_to_buffer_fixed (LEFT_BRACE);

	call add_to_buffer_fixed (p_address_type_string);

	if length (p_string) > 0 then do;		/* it has an argument ... */
	     call add_to_buffer_fixed (SP);

	     if ifo.rfc822_format then		/* check for requoting with the proper specials */
		must_requote = (search (p_string, STRUCTURED_RFC822_REQUOTE) ^= 0);
	     else must_requote = (search (p_string, STRUCTURED_REQUOTE) ^= 0);

	     if must_requote then do;			/* start out with surrounding quotes */
		if ifo.rfc822_format then		/* ... these quotes are within quotes: preceed them "\" */
		     call add_to_buffer_fixed (BACKSLASH_QUOTE);
		else call add_to_buffer_fixed (QUOTE);

		used = 0;

		do while (used < length (p_string));
		     if ifo.rfc822_format then	/* find next character which must be escaped */
			idx = search (substr (p_string, (used + 1)), BACKSLASH_QUOTE_NL);
		     else idx = search (substr (p_string, (used + 1)), QUOTE_NL);
		     if idx = 0 then idx = length (p_string) - used + 1;
		     if idx > 1 then call add_to_buffer (addcharno (addr (the_string.string), used), (idx - 1));
		     used = used + idx - 1;		/* skip past normal characters */
		     if used < length (p_string) then do;
						/* needs to be quoted */
			used = used + 1;
			the_character = substr (p_string, used, 1);
			if ifo.rfc822_format then do;
			     if the_character = QUOTE then do;
				call add_to_buffer_fixed (BACKSLASH_QUOTE);
				call add_to_buffer_fixed (BACKSLASH_QUOTE);
			     end;
			     else do;
				call add_to_buffer_fixed (BACKSLASH);
				call add_to_buffer_fixed (the_character);
				if the_character = NL then call add_to_buffer_fixed (SP);
			     end;
			end;
			else do;			/* Multics format */
			     if the_character = QUOTE then
				call add_to_buffer_fixed (QUOTE_QUOTE);
			     else call add_to_buffer_fixed (NLSP);
			end;
		     end;
		end;

		if ifo.rfc822_format then
		     call add_to_buffer_fixed (BACKSLASH_QUOTE);
		else call add_to_buffer_fixed (QUOTE);
	     end;

	     else call add_to_buffer_varying (p_string);
	end;

	if ifo.rfc822_format then
	     call add_to_buffer_fixed (RIGHT_BRACE_QUOTE);
	else call add_to_buffer_fixed (RIGHT_BRACE);

	return;

     end format_structured_string;
%page;
/* Places a comment into the output buffer */

format_comment_string:
     procedure (p_string);

dcl  p_string character (*) varying parameter;

dcl  1 the_string aligned based (addr (p_string)),
       2 lth fixed binary (21),
       2 string character (maxlength (p_string));

dcl  the_character character (1);
dcl  must_requote bit (1) aligned;
dcl  (used, idx) fixed binary (21);

	call add_to_buffer_fixed (SP_OPEN_PAREN);

	if ifo.rfc822_format then			/* check for requoting with the proper specials */
	     must_requote = (search (p_string, COMMENT_RFC822_REQUOTE) ^= 0);
	else must_requote = (search (p_string, COMMENT_REQUOTE) ^= 0);

	if must_requote then do;			/* there are special characters in the comment */
	     if ^ifo.rfc822_format then		/* Multics supports quoted comments */
		call add_to_buffer_fixed (QUOTE);

	     used = 0;

	     do while (used < length (p_string));
		if ifo.rfc822_format then		/* find next character which must be escaped */
		     idx = search (substr (p_string, (used + 1)), BACKSLASH_PARENS_NL);
		else idx = search (substr (p_string, (used + 1)), QUOTE_NL);
		if idx = 0 then idx = length (p_string) - used + 1;
		if idx > 1 then call add_to_buffer (addcharno (addr (the_string.string), used), (idx - 1));
		used = used + idx - 1;		/* skip past normal characters */
		if used < length (p_string) then do;
		     used = used + 1;
		     the_character = substr (p_string, used, 1);
		     if ifo.rfc822_format then do;
			call add_to_buffer_fixed (BACKSLASH);
			call add_to_buffer_fixed (the_character);
			if the_character = NL then call add_to_buffer_fixed (SP);
		     end;
		     else do;
			if the_character = QUOTE then
			     call add_to_buffer_fixed (QUOTE_QUOTE);
			else call add_to_buffer_fixed (NLSP);
		     end;
		end;
	     end;

	     if ^ifo.rfc822_format then call add_to_buffer_fixed (QUOTE);
	end;

	else call add_to_buffer_varying (p_string);

	call add_to_buffer_fixed (CLOSE_PAREN);

	return;

     end format_comment_string;
%page;
/* Returns either 0 or 2 depending on whether something will be surrounded by quotes in RFC822 format text */

quotes_if_rfc822:
     procedure () returns (fixed binary);

	if ifo.rfc822_format then
	     return (2);
	else return (0);

     end quotes_if_rfc822;



/* Start a new line with the level of indentation presently in effect */

new_line:
     procedure ();

dcl  n_spaces_to_add fixed binary (21);

	call add_to_buffer_fixed (NL);

	n_spaces_to_add = ifo.indentation;
	do while (n_spaces_to_add > length (SPACES));
	     call add_to_buffer_fixed (SPACES);
	     n_spaces_to_add = n_spaces_to_add - length (SPACES);
	end;

	call add_to_buffer (addr (SPACES), n_spaces_to_add);

	return;

     end new_line;
%page;
/* Output a piece of text to the buffer and invoke the overflow handler if necessary */

add_to_buffer:
     procedure (p_text_ptr, p_text_lth);

dcl  p_text_ptr pointer parameter;
dcl  p_text_lth fixed binary (21) parameter;
dcl  p_fixed_text character (*) parameter;
dcl  p_varying_text character (*) varying parameter;

dcl  text character (text_lth) unaligned based (text_ptr);
dcl  text_ptr pointer;
dcl  (text_lth, text_used) fixed binary (21);

dcl  1 varying_string aligned based,			/* need to know PL/I's internal format to set text_ptr */
       2 lth fixed binary (21),
       2 string character (maxlength (p_varying_text));


/* add_to_buffer: entry (p_text_ptr, p_text_lth); */

	text_ptr = p_text_ptr;
	text_lth = p_text_lth;
	go to ADD_TO_BUFFER_COMMON;


add_to_buffer_fixed:				/* a fixed length string */
     entry (p_fixed_text);

	text_ptr = addr (p_fixed_text);
	text_lth = length (p_fixed_text);
	go to ADD_TO_BUFFER_COMMON;


add_to_buffer_varying:				/* a varying length string */
     entry (p_varying_text);

	text_ptr = addr (addr (p_varying_text) -> varying_string.string);
	text_lth = length (p_varying_text);


ADD_TO_BUFFER_COMMON:
	text_used = 0;

	do while (text_used < text_lth);		/* while there's stuff left to output */
	     begin;
dcl  rest_of_text character (text_lth - text_used) unaligned defined (text) position (text_used + 1);

		begin;

dcl  rest_of_buffer character (buffer_size - buffer_used) unaligned defined (buffer) position (buffer_used + 1);

		     begin;
dcl  next_piece_of_text character (min (length (rest_of_buffer), length (rest_of_text))) unaligned defined (text)
	position (text_used + 1);

			substr (rest_of_buffer, 1, length (next_piece_of_text)) = next_piece_of_text;
			call update_last_column (next_piece_of_text);
			if ifo.count_lines then do;
			     line_count = line_count + count_lines_in_text (next_piece_of_text);
			     if substr (next_piece_of_text, length (next_piece_of_text), 1) ^= NL then
				line_count = line_count - 1;
			end;			/* ... count_lines_in_text always counts partial pieces */
			buffer_used = buffer_used + length (next_piece_of_text);
			text_used = text_used + length (next_piece_of_text);
		     end;
		end;
	     end;

	     if text_used < text_lth then		/* only can happen due to buffer overflow */
		call ifo.buffer_overflow ();
	end;

	return;



/* Internal to add_to_buffer: computes the last column occupied by the given string */

update_last_column:
	procedure (p_string);

dcl  p_string character (*) parameter;

dcl  the_character character (1);
dcl  (string_used, idx) fixed binary (21);


	     string_used = 0;

	     do while (string_used < length (p_string));

		begin;
dcl  rest_of_string character (length (p_string) - string_used) unaligned defined (p_string) position (string_used + 1);

		     idx = verify (rest_of_string, SINGLE_WIDTH_CHARACTERS);
		     if idx = 0 then idx = length (rest_of_string) + 1;

		     last_column_used = last_column_used + idx - 1;
		     string_used = string_used + idx - 1;
		end;				/* update where we are */

		if string_used < length (p_string) then do;
						/* we did find a special character */
		     the_character = substr (p_string, (string_used + 1), 1);
		     string_used = string_used + 1;

		     if the_character = HT then last_column_used = last_column_used + 10 - mod (last_column_used, 10);

		     else if the_character = BS then last_column_used = max ((last_column_used - 1), 0);

		     else if (the_character = NL) | (the_character = CR) | (the_character = VT) | (the_character = FF)
			then
			last_column_used = 0;

		     else ;			/* ... all others are non-printing */
		end;
	     end;

	     return;

	end update_last_column;

     end add_to_buffer;
%page;
/* Buffer overflow handler for the formatting entrypoints: returns error_table_$smallarg to the caller */

report_smallarg:
     procedure ();

	P_code = error_table_$smallarg;

	go to RETURN_FROM_FORMAT_ENTRY_WITH_ERROR;

     end report_smallarg;

RETURN_FROM_FORMAT_ENTRY_WITH_ERROR:
	return;



/* Buffer overflow handler for the format_address_for_ism entrypoint: returns mlsys_et_$foreign_address_too_long */

report_foreign_address_too_long:
     procedure ();

	P_code = mlsys_et_$foreign_address_too_long;

	go to RETURN_FROM_FORMAT_ENTRY_WITH_ERROR;

     end report_foreign_address_too_long;



/* Buffer overflow handler for the printing entrypoints: prints the buffer, empties it, and then continues */

print_buffer:
     procedure ();

	call iox_$put_chars (output_switch, buffer_ptr, buffer_used, code);
	if code ^= 0 then do;			/* fatal error of some kind */
	     P_code = code;
	     go to RETURN_FROM_FORMAT_ENTRY_WITH_ERROR;
	end;

	buffer_used = 0;

	return;

     end print_buffer;
%page;
/* Compare two date/times for equality with appropriate fuzz factor */

date_time_equal:
     procedure (p_date_time_1, p_date_time_2) returns (bit (1) aligned);

dcl  (p_date_time_1, p_date_time_2) fixed binary (71) parameter;

	return (abs ((p_date_time_1 - p_date_time_2)) < ONE_MINUTE);

     end date_time_equal;



/* Count the lines in a piece of text */

count_lines_in_text:
     procedure (p_text) returns (fixed binary (21));

dcl  p_text character (*) parameter;
dcl  (text_lth, n_lines, used, idx) fixed binary (21);

	text_lth = length (p_text);

	n_lines, used = 0;

	do while (used < text_lth);

	     begin;

dcl  rest_of_text character (text_lth - used) unaligned defined (p_text) position (used + 1);

		idx = index (rest_of_text, NL);
		if idx = 0 then idx = length (rest_of_text) + 1;

		n_lines = n_lines + 1;
		used = used + idx;
	     end;
	end;

	return (n_lines);

     end count_lines_in_text;
%page;
%include mlsys_format_options;
%page;
%include mlsys_field_names;
%page;
%include mlsys_message;
%page;
%include mlsys_address_types;
%page;
%include mlsys_address_list;
%page;
%include mlsys_address_route;
%page;
%include mlsys_data;
%page;
%include mlsys_internal_data;
%page;
%include mail_format;
%page;
%include mlsys_mf_extension;
%page;
%include time_names;
%page;
%include mlsys_special_chars;

     end mlsys_format_;




		    mlsys_hash_.pl1                 06/30/86  1410.2r w 06/30/86  1343.9       39177



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/* format: off */

/* Hash table management for the Multics Mail System */

/* Created:  July 1983 by G. Palter */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


mlsys_hash_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_string character (*) parameter;			/* hash: the string to be hashed */
dcl  P_hash_table_size fixed binary parameter;		/* hash: # of slots in the hash table */


/* Remaining declarations */

dcl  hash_value fixed binary (71);
dcl  1 hash_value_words aligned based (addr (hash_value)),
       2 upper fixed binary (35),
       2 lower fixed binary (35);

dcl  1 local_ai aligned like area_info;
dcl  code fixed binary (35);
dcl  old_validation_level fixed binary (3);

dcl  hash_result fixed binary (35);
dcl  n_words fixed binary (18);
dcl  idx fixed binary;

dcl  MAIL_SYSTEM_ character (32) static options (constant) initial ("mail_system_");

dcl  BLANKS_AS_CHARACTERS character (4) aligned static options (constant) initial ("    ");
dcl  BLANKS fixed binary (35) based (addr (BLANKS_AS_CHARACTERS));

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl  cu_$level_get entry (fixed binary (3));
dcl  cu_$level_set entry (fixed binary (3));
dcl  define_area_ entry (pointer, fixed binary (35));
dcl  get_ring_ entry () returns (fixed binary (3));
dcl  mlsys_storage_mgr_$get_temp_segment entry (pointer, fixed binary (35));
dcl  sub_err_ entry () options (variable);

dcl  cleanup condition;

dcl  (abs, addr, divide, length, null, string, wordno) builtin;
%page;
/* Initialize the hash tables used by the mail system */

initialize:
     entry ();

	call cu_$level_get (old_validation_level);

	on condition (cleanup)
	     begin;
		call cu_$level_set (old_validation_level);
	     end;

	call cu_$level_set (get_ring_ ());

	call mlsys_storage_mgr_$get_temp_segment (mlsys_data_$hash_tables_segment_ptr, code);
	if code ^= 0 then do;
RESIGNAL_INITIALIZATION_FAILURE:
	     call sub_err_ (code, MAIL_SYSTEM_, ACTION_CANT_RESTART, null (), (0),
		"Unable to initialize the mail system hash tables.^/Contact your system programming staff.");
	     go to RESIGNAL_INITIALIZATION_FAILURE;
	end;

	local_ai.version = area_info_version_1;
	string (local_ai.control) = ""b;
	local_ai.extend = "1"b;			/* an extensible area not that it should matter ... */
	local_ai.system = "1"b;			/* ... which is extended with proper ring bracket copying */
	local_ai.owner = MAIL_SYSTEM_;
	local_ai.size = sys_info$max_seg_size - wordno (addr (hash_tables_segment.hash_area));
	local_ai.areap = addr (hash_tables_segment.hash_area);

	call define_area_ (addr (local_ai), code);
	if code ^= 0 then go to RESIGNAL_INITIALIZATION_FAILURE;

	hash_tables_segment.field_name_hash_table.buckets (*) = null ();

	hash_tables_segment.message_id_hash_table.buckets (*) = null ();

	call cu_$level_set (old_validation_level);

	return;
%page;
/* Compute the index in a hash table of the specified string: patterned after the hash_index_ ALM subroutine but designed
   to work on strings longer than 32 characters */

hash:
     entry (P_string, P_hash_table_size) returns (fixed binary);

	n_words = divide ((length (P_string) + 3), 4, 18, 0);

	begin;

dcl  the_string character (4 * n_words) aligned;		/* needed to get the last word filled with blanks */
dcl  words (n_words) fixed binary (35) based (addr (the_string));

	     the_string = P_string;

	     hash_value = 0;			/* no bias */

	     do idx = 1 to n_words;
		if words (idx) ^= BLANKS then		/* add all non-blank words together */
		     hash_value = hash_value + words (idx);
	     end;

	     hash_result =				/* really mod (hash_value_words.lower, P_hash_table_size) */
		hash_value_words.lower
		- P_hash_table_size * divide (hash_value_words.lower, P_hash_table_size, 35, 0);

	     return (abs (hash_result));		/* always want a positive result ... */

	end;
%page;
%include mlsys_hash_tables_seg;
%page;
%include mlsys_internal_data;
%page;
%include area_info;
%page;
%include sub_err_flags;

     end mlsys_hash_;




*/
                                          -----------------------------------------------------------


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

*/
