



		    mlsys_initialize_.pl1           06/30/86  1410.4r w 06/30/86  1343.4       63081



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

/* format: off */

/* Initialize static data used by the Multics mail system */

/* Created:  July 1981 by G. Palter */
/* Modified: June 1983 by G. Palter to merge mlsys_data_ and mlsys_internal_data_ and for multi-ring mail system */
/* Modified: March 1984 by G. Palter to fix mail system error #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 the value_set_path command */

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


mlsys_initialize_:
     procedure ();


/* Declarations */

dcl  mlsys_gate_ptr pointer;
dcl  mlsys_gate_brackets (3) fixed binary (3);

dcl  (person_id, project_id) character (32);
dcl  anonymous_flag fixed binary;

dcl  users_full_name character (256) varying;

dcl  code fixed binary (35);

dcl  MAIL_SYSTEM_ character (32) static options (constant) initial ("mail_system_");

dcl  PERMANENT_VALUES bit (36) aligned static options (constant) initial ("200000000000"b3);

dcl  FULL_NAME_NAME character (32) static options (constant) initial ("full_name._");

dcl  get_initial_ring_ entry () returns (fixed binary (3));
dcl  get_ring_ entry () returns (fixed binary (3));
dcl  hcs_$fs_get_brackets entry (pointer, fixed binary (5), (3) fixed binary (3), fixed binary (35));
dcl  hcs_$make_ptr entry (pointer, character (*), character (*), pointer, fixed binary (35));
dcl  mail_system_$get_users_addresses entry (pointer, pointer, pointer);
dcl  mail_system_$set_users_full_name entry (character (*) varying);
dcl  mlsys_address_mgr_$create_invalid_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mlsys_address_mgr_$create_logbox_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mlsys_address_mgr_$create_mail_table_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mlsys_address_mgr_$create_user_mailbox_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mlsys_address_mgr_$protect_address entry (pointer);
dcl  mlsys_hash_$initialize entry ();
dcl  mlsys_storage_mgr_$initialize entry ();
dcl  mlsys_transmit_$initialize_cache entry ();
dcl  sub_err_ entry () options (variable);
dcl  user_info_$login_data entry (character (*), character (*), character (*), fixed binary);
dcl  value_$get entry () options (variable);

dcl  (codeptr, null, rtrim) builtin;
%page;
/* mlsys_initialize_: entry (); */

	call hcs_$make_ptr (codeptr (mlsys_initialize_), MAIL_SYSTEM_, "", mlsys_gate_ptr, code);
	if code ^= 0 then do;			/* grumble: impossible to initialize the mail system ... */
RESIGNAL_INITIALIZATION_FAILURE:
	     call sub_err_ (code, MAIL_SYSTEM_, ACTION_CANT_RESTART, null (), (0),
		"Unable to initialize the mail system.^/Contact your system programming staff.");
	     go to RESIGNAL_INITIALIZATION_FAILURE;
	end;

	call hcs_$fs_get_brackets (mlsys_gate_ptr, (0), mlsys_gate_brackets, code);
	if code ^= 0 then go to RESIGNAL_INITIALIZATION_FAILURE;

	mlsys_data_$subsystem_ring = mlsys_gate_brackets (2);
	mlsys_data_$highest_usable_ring = mlsys_gate_brackets (3);

	call user_info_$login_data (person_id, project_id, ((32)" "), anonymous_flag);

	mlsys_data_$user_is_anonymous = (anonymous_flag = 1);

	mlsys_data_$person_id = rtrim (person_id);
	mlsys_data_$project_id = rtrim (project_id);
	mlsys_data_$user_id = mlsys_data_$person_id || "." || mlsys_data_$project_id;

	if get_ring_ () <= mlsys_data_$subsystem_ring then/* in (or below) the mail system ring */
	     call initialize_mail_system_ring ();
	else call mail_system_$get_users_addresses (mlsys_data_$user_default_mailbox_address,
		mlsys_data_$user_mail_table_address, mlsys_data_$user_logbox_address);

	if get_ring_ () >= get_initial_ring_ () then	/* see the internal procedure for an explanation */
	     call set_users_full_name ();

	return;
%page;
/* Initializes static data which is only maintained by the Mail System in its protected ring:  Such data includes
   temporary areas/segments, hash tables, and the three address "constants" */

initialize_mail_system_ring:
     procedure ();

	call mlsys_storage_mgr_$initialize ();		/* area/temporary segment management */

	call mlsys_hash_$initialize ();		/* hash tables used by the mail system */

	call mlsys_transmit_$initialize_cache ();	/* cache of recently used mailboxes */

	call mlsys_address_mgr_$create_user_mailbox_address (mlsys_data_$user_id, "", "",
	     mlsys_data_$user_default_mailbox_address, (0));

	if mlsys_data_$user_is_anonymous then		/* anonymous users don't have mail table entries */
	     call mlsys_address_mgr_$create_invalid_address (mlsys_data_$person_id, "", "",
		mlsys_data_$user_mail_table_address, (0));
	else call mlsys_address_mgr_$create_mail_table_address (mlsys_data_$person_id, "", "",
		mlsys_data_$user_mail_table_address, (0));

	call mlsys_address_mgr_$create_logbox_address (mlsys_data_$user_id, "", "", mlsys_data_$user_logbox_address,
	     (0));

	/*** prevent the user from accidently destroying these addresses */
	call mlsys_address_mgr_$protect_address (mlsys_data_$user_default_mailbox_address);
	call mlsys_address_mgr_$protect_address (mlsys_data_$user_mail_table_address);
	call mlsys_address_mgr_$protect_address (mlsys_data_$user_logbox_address);

	return;

     end initialize_mail_system_ring;
%page;
/* Sets the user's full name in the constant addresses maintained by the mail system:  This procedure is only invoked from
   the user's initial ring of execution or above in case the user uses the value_set_path command to change their default
   value segment */

set_users_full_name:
     procedure ();

	if mlsys_data_$user_is_anonymous then		/* anonymous user's don't have full names */
	     users_full_name = "";
	else do;					/* look in the user's value segment */
	     call value_$get (null (), PERMANENT_VALUES, (rtrim (mlsys_data_$person_id) || "." || FULL_NAME_NAME),
		users_full_name, code);
	     if code ^= 0 then			/* ... Person_id.full_name._ not there: try just full_name._ */
		call value_$get (null (), PERMANENT_VALUES, FULL_NAME_NAME, users_full_name, code);
	     if code ^= 0 then users_full_name = "";	/* ... not found */
	end;

	if users_full_name ^= "" then call mail_system_$set_users_full_name (users_full_name);

	return;

     end set_users_full_name;
%page;
%include mlsys_data;
%page;
%include mlsys_internal_data;
%page;
%include sub_err_flags;

     end mlsys_initialize_;




		    mlsys_mailbox_mgr_.pl1          10/02/89  0857.3rew 10/02/89  0815.0      907362



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * 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.
  2) change(86-02-27,Herbst), approve(86-03-25,MCR7367),
     audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059):
     Changed $set_message_switch to work only if the caller has "d" extended
     access to the mailbox.
  3) change(86-03-25,Herbst), approve(86-03-25,MCR7367),
     audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059):
     Changed P_switch_type from fixed bin to char (4) aligned.
  4) change(86-03-25,Herbst), approve(86-03-25,MCR7367),
     audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059):
     Changed $set_message_switch to return error code from
     mailbox_$update_message without conversion; fixed to copy input args.
  5) change(86-04-28,Herbst), approve(86-04-28,MCR7367),
     audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059):
     Fixed $set_message_switch to return error code if no access to set switch.
  6) change(86-06-03,Herbst), approve(86-06-03,MCR7432), audit(86-06-30,Wong),
     install(86-06-30,MR12.0-1080):
     Fixed to zero unused portions of mail_format.
  7) change(87-03-09,Lippard), approve(87-03-18,MECR0001),
     audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002):
     Modified to strip control characters from message comment field.
  8) change(87-05-08,Lippard), approve(87-04-20,MCR7669),
     audit(87-05-11,Fawcett), install(87-05-20,MR12.1-1032):
     Formal installation to close out MECR0001.
  9) change(89-09-12,Lee), approve(89-09-12,MCR8131),
     audit(89-09-25,LZimmerman), install(89-10-02,MR12.3-1079):
     phx20316, phx19688 (Mail 491) - modified the entry deliver_acknowledgement
     to try using the sender_id (delivery_by id) instead of giving up if the
     acknowledge_to field refers to a mail table entry which does not expand to
     a local mailbox; reformatting.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Mailbox management for the Multics Mail System */

/* Created:  June 1983 by G. Palter from parts of mlsys_user_interface_ */
/* Modified: 12 April 1984 by G. Palter to fix error #0441 -- when mail_system_$read_new_messages must grow the mailbox
      structure to accomodate the new messages, it properly frees the old structure but does not update its internal
      records to reflect this fact.  Subsequently, when mail_system_$close_mailbox is called, it will attempt to free the
      storage occupied by the old mailbox structure again resulting in damage to the mail system's area */

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


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

	return;					/* not an entrypoint */


/* Common Parameters */

dcl  P_code fixed binary (35) parameter;

dcl  P_mailbox_dirname character (*) parameter;		/* pathname of directory containing the mailbox */
dcl  P_mailbox_ename character (*) parameter;		/* entryname of the mailbox: suffix is optional */
dcl  P_mailbox_ptr pointer parameter;			/* -> user-visible mailbox structure (input/output) */
dcl  P_message_ptr pointer parameter;			/* -> user-visible message structure */


/* get_message_counts Parameters */

dcl  P_include_by_type bit (1) aligned parameter;		/* ON => include breakdown by type (ordinary/interactive) */
dcl  P_n_messages fixed binary parameter;		/* set to # of messages in the mailbox */
dcl  P_n_ordinary_messages fixed binary parameter;	/*     ...     ordinary messages in the mailbox */
dcl  P_n_interactive_messages fixed binary parameter;	/*     ...     interactive messages in the mailbox */


/* open_mailbox Parameters */

dcl  P_open_options_ptr pointer parameter;		/* -> options describing how to open the mailbox */
dcl  P_mailbox_version character (8) parameter;		/* identifies the version of the mailbox structure expected to
						   be returned to the caller */


/* read_new_messages Parameters */

dcl  P_n_new_messages fixed binary parameter;		/* set to # of newly arrived messages in the mailbox */
dcl  P_n_new_ordinary_messages fixed binary parameter;	/* ... etc. ... */
dcl  P_n_new_interactive_messages fixed binary parameter;	/* ... */


/* read_message and read_message_canonical_form Parameters */

dcl  P_message_idx fixed binary parameter;		/* identifies which message is to be read */


/* read_message_canonical_form and read_message_canonical_form_p Parameters */

dcl  P_message_canonical_form_ptr pointer parameter;	/* set -> the canonical representation of the message */
dcl  P_message_canonical_form_lth fixed binary (21) parameter;


/* get_message_mf_if_canonical Parameters */

dcl  P_message_mf_ptr pointer parameter;		/* set -> the mail_format containing the canonical message */
dcl  P_message_mf_extension_ptr pointer parameter;	/* set -> the mf_extension for the above mail_format */

/* close_mailbox Parameters */

dcl  P_close_options_ptr pointer parameter;		/* defines options for closing the mailbox */

/* set_message_switch Parameters */

dcl  P_switch_type char (4) aligned;			/* seen switch, etc.; in rdm_switch_types.incl.pl1 */
dcl  P_switch_value bit (1) aligned;			/* value to set it to */


/* Local copies of parameters */

dcl  code fixed binary (35);

dcl  mailbox_dirname character (168);
dcl  mailbox_ename character (32);

dcl  (n_messages, n_new_messages) fixed binary;
dcl  (n_messages_by_type, n_new_messages_by_type) fixed binary dimension (ORDINARY_MESSAGES:INTERACTIVE_MESSAGES);

dcl  message_idx fixed binary;
dcl  switch_type char (4) aligned;
dcl  switch_value bit (1) aligned;

/* Internal description of a mailbox opened by the Multics mail system */

dcl  1 mailbox_info aligned based (mailbox_info_ptr),
       2 dirname character (168) unaligned,		/* pathname of directory containing the mailbox */
       2 ename character (32) unaligned,		/* entryname of mailbox */
       2 address_ptr pointer,				/* -> address of this mailbox */
       2 mailbox_ptr pointer,				/* -> user-visible mailbox description */
       2 delete_error_info_ptr pointer,			/* -> delete_error_info currently signalled to the user */
       2 type fixed binary,				/* type of mailbox: default, logbox, savebox, etc. */
       2 index fixed binary,				/* ring-1 mailbox index */
       2 mode_flags,				/* current effective access */
         3 add bit (1) unaligned,
         3 delete bit (1) unaligned,
         3 read bit (1) unaligned,
         3 own bit (1) unaligned,
         3 status bit (1) unaligned,			/* provides access to message count, salvaged bit */
         3 wakeup bit (1) unaligned,			/* permits sending of interactive and mail notifications */
         3 urgent bit (1) unaligned,			/* not used by present mail system ... */
         3 pad bit (29) unaligned,
       2 message_selection_mode fixed binary,		/* types of messages returned (ordinary, interactive) */
       2 sender_selection_mode fixed binary,		/* sender of messages returned (all, own, not-own) */
       2 message_reading_level fixed binary,		/* how much of message to read from mailbox */
       2 n_messages fixed binary,			/* total # of messages read from the mailbox */
       2 n_messages_by_type (ORDINARY_MESSAGES:INTERACTIVE_MESSAGES) fixed binary,
						/* ... and by message type */
       2 n_deleted_messages fixed binary,		/* # of messages marked for deletion on closing */
       2 flags,
         3 salvaged bit (1) unaligned,			/* ON => mailbox has been salvaged */
         3 use_own_mode bit (1) unaligned,		/* ON => mailbox_$own* entries needed to read from mailbox */
         3 pending_deletion bit (1) unaligned,		/* ON => there is an interrupted deletion in progress */
         3 ring1_privilege bit (1) unaligned,		/* ON => user had ring-1 privilege when computing
						   the can_be_deleted flags of the messages in the mailbox */
         3 pad bit (32) unaligned,
       2 last_message_key bit (72) aligned,		/* identifies last message read from the mailbox (if any) */
       2 last_message_area_ptr pointer,			/* -> last segment (least full) used to hold the messages */
       2 message_blocks,				/* chain of messages which are read in blocks (see below) */
         3 first pointer,
         3 last pointer;

dcl  mailbox_info_ptr pointer;


/* Message area temporary segment definition:  Due to a mis-feature of the area package, the area passed to the ring-1
   primitives can not be an extensible area.  Thus, to read a mailbox, the mail system uses a set of non-extensible areas
   each of which resides in a separate temporary segment */

dcl  1 mailbox_message_area aligned based (mailbox_message_area_ptr),
       2 previous pointer,				/* -> previous temporary segment in the list */
       2 flags,
         3 virgin_area bit (1) unaligned,		/* ON => nothing has been allocated in this segment yet */
         3 pad bit (71) unaligned,			/* force even-word boundary */
       2 area area;					/* the actual area */

dcl  mailbox_message_area_ptr pointer;


/* Message block definition: contains the description of up to 32 messages in the mailbox and is used to minimize
   allocations */

dcl  1 message_block aligned based (message_block_ptr),
       2 chain,					/* chain of message blocks for this mailbox */
         3 previous pointer,
         3 next pointer,
       2 n_used fixed binary,				/* # of slots used in this block */
       2 pad bit (36),
       2 messages (32) like im_message_info;		/* the messages in this block */

dcl  (message_block_ptr, next_message_block_ptr) pointer;


/* Definition of the reserved data in the user-visible description of a mailbox */

dcl  1 mailbox_reserved_data aligned based (addr (mailbox.reserved)),
       2 info_ptr pointer,				/* -> the corresponding mailbox_info structure */
       2 n_messages_allocated fixed binary,		/* actual size of the messages array */
       2 pad bit (36);


/* Internal description of an in-mailbox message maintained by the Multics mail system */

dcl  1 im_message_info aligned based (im_message_info_ptr),
       2 mailbox_info_ptr pointer,			/* -> the description of mailbox where this message resides */
       2 area_ptr pointer,				/* -> area into which the message was read from ring-1 */
       2 key bit (72) aligned,			/* ring-1 key for this message */
       2 format fixed binary,				/* format of the message as stored in ring-1 */
       2 type fixed binary,				/* type of message: ordinary or interactive */
       2 flags,
         3 mra_valid bit (1) unaligned,			/* ON => message has been read from ring-1 */
         3 can_be_deleted bit (1) unaligned,		/* ON => user has sufficient access to delete this message */
         3 to_be_deleted bit (1) unaligned,		/* ON => user has requested that this message be deleted */
         3 already_deleted bit (1) unaligned,		/* ON => this message is deleted: this is an empty slot now */
         3 requests_acknowledgement bit (1) unaligned,	/* ON => acknowledgement requested and user has access */
         3 pad bit (31) unaligned,
       2 message_ptr pointer,				/* -> user-visible description of the message */
       2 mra like mseg_return_args;			/* ring-1 information about this message */

dcl  im_message_info_ptr pointer;


/* Possible formats of a message when it is stored in a ring-1 mailbox */

/* format: off */
dcl (FIPS98_FORMAT_MESSAGE	     initial (1),		/* FIPS-98 encoded message (binary format) */
     MAIL_FORMAT_MESSAGE	     initial (2),		/* mail_format (old ASCII format) */
     UNKNOWN_FORMAT_MESSAGE	     initial (3))		/* unrecognized format (neither of the above) */
	fixed binary static options (constant);
/* format: on */


/* Remaining declarations */

dcl  1 local_mra aligned like mseg_return_args;

dcl  1 mra aligned based (mra_ptr) like mseg_return_args;
dcl  mra_ptr pointer;

dcl  message_bits bit (mra.ms_len) aligned based (mra.ms_ptr);

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  1 user_privileges aligned,
       2 privileges unaligned like aim_template.privileges,
       2 pad bit (18) unaligned;

dcl  mailbox_idx fixed binary;
dcl  mailbox_mode bit (36) aligned;
dcl  mailbox_salvaged_bit bit (1) aligned;

dcl  (new_mailbox_ptr, saved_message_block_ptr) pointer;
dcl  saved_message_block_n_used fixed binary;

dcl  (message_format, message_type) fixed binary;

dcl  (first_idx, idx) fixed binary;

dcl  deletion_failed bit (1) aligned;

dcl  (author_is_ack_recipient, multiple_authors, is_redistributed) bit (1) aligned;

dcl  MAIL_SYSTEM_ character (32) static options (constant) initial ("mail_system_");

dcl  NUL character (1) static options (constant) initial ("");
dcl  NL character (1) static options (constant) initial ("
");

dcl  MAIL_FORMAT_VERSION_2 fixed binary static options (constant) initial (2);
dcl  MAIL_FORMAT_VERSION_3 fixed binary static options (constant) initial (3);

/* format: off */
dcl (error_table_$bad_index,
     error_table_$bad_segment, error_table_$bad_subr_arg, error_table_$entlong,
     error_table_$messages_deferred, error_table_$messages_off, error_table_$moderr, error_table_$noalloc,
     error_table_$no_info, error_table_$no_message, error_table_$seg_unknown, error_table_$unimplemented_version,
     error_table_$wakeup_denied, mlsys_et_$all_messages_deleted, mlsys_et_$already_marked_for_deletion,
     mlsys_et_$bad_acknowledge_to, mlsys_et_$cant_be_deleted, mlsys_et_$cant_send_acknowledgement,
     mlsys_et_$cant_update_message, mlsys_et_$deletion_pending, mlsys_et_$message_already_read,
     mlsys_et_$missing_acknowledge_to, mlsys_et_$no_ack_needed, mlsys_et_$no_message_canonical_form,
     mlsys_et_$no_more_messages, mlsys_et_$no_o_permission, mlsys_et_$no_pending_deletion, mlsys_et_$no_r_permission,
     mlsys_et_$no_s_permission, mlsys_et_$not_mailbox, mlsys_et_$not_marked_for_deletion,
     mlsys_et_$some_messages_not_deleted)
	fixed binary (35) external;
/* format: on */

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  define_area_ entry (pointer, fixed binary (35));
dcl  get_authorization_ entry () returns (bit (72) aligned);
dcl  get_privileges_ entry () returns (bit (36) aligned);
dcl  get_system_free_area_ entry () returns (pointer);
dcl  mailbox_$check_salv_bit_index entry (fixed binary, bit (1) aligned, bit (1) aligned, fixed binary (35));
dcl  mailbox_$close entry (fixed binary, fixed binary (35));
dcl  mailbox_$compact_index entry (fixed binary, float binary, fixed binary (35));
dcl  mailbox_$delete_index entry (fixed binary, bit (72) aligned, fixed binary (35));
dcl  mailbox_$get_mode_index entry (fixed binary, bit (36) aligned, fixed binary (35));
dcl  mailbox_$incremental_read_index entry (fixed binary, pointer, bit (2), bit (72) aligned, pointer, fixed binary (35));
dcl  mailbox_$open entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  mailbox_$open_if_full
	entry (character (*), character (*), bit (1) aligned, fixed binary, fixed binary, fixed binary (35));
dcl  mailbox_$own_incremental_read_index
	entry (fixed binary, pointer, bit (2), bit (72) aligned, pointer, fixed binary (35));
dcl  mailbox_$own_read_index entry (fixed binary, pointer, bit (1), pointer, fixed binary (35));
dcl  mailbox_$read_index entry (fixed binary, pointer, bit (1), pointer, fixed binary (35));
dcl  mailbox_$update_message_index entry (fixed binary, fixed binary (24), bit (72) aligned, pointer, fixed binary (35));
dcl  mailbox_$wakeup_add_index
	entry (fixed binary, pointer, fixed binary (24), bit (36) aligned, bit (72) aligned, fixed binary (35));
dcl  mlsys_address_list_mgr_$add_address entry (pointer, pointer, character (8), fixed binary (35));
dcl  mlsys_address_mgr_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mlsys_address_mgr_$create_mailbox_address
	entry (character (*), character (*), character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mlsys_address_mgr_$create_user_mailbox_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mlsys_address_mgr_$decrement_reference_count entry (pointer);
dcl  mlsys_address_mgr_$free_address entry (pointer, fixed binary (35));
dcl  mlsys_address_mgr_$get_address_pathname
	entry (pointer, character (*), character (*), character (*), fixed binary (35));
dcl  mlsys_address_mgr_$get_address_type entry (pointer, fixed binary, fixed binary (35));
dcl  mlsys_address_mgr_$get_mail_table_address entry (pointer, pointer, fixed binary (35));
dcl  mlsys_address_mgr_$increment_reference_count entry (pointer);
dcl  mlsys_fips98_$decode_message
	entry ((*) bit (9) unaligned, character (8), pointer, pointer, fixed binary (71), bit (1) aligned, pointer,
	fixed binary (35));
dcl  mlsys_format_$format_date_time_field
	entry (character (*) varying, fixed binary (71), bit (1) aligned, fixed binary, pointer, fixed binary (21),
	fixed binary (21), fixed binary (35));
dcl  mlsys_mailbox_utils_$classify_mailbox_address entry (pointer, fixed binary, fixed binary (35));
dcl  mlsys_message_id_mgr_$encode_local_id entry (fixed binary (71), bit (72) aligned);
dcl  mlsys_message_mgr_$add_body_section_no_copy entry (pointer, pointer, fixed binary, fixed binary (35));
dcl  mlsys_message_mgr_$create_im_message entry (character (8), pointer, pointer, fixed binary (35));
dcl  mlsys_message_mgr_$free_message entry (pointer, fixed binary (35));
dcl  mlsys_message_mgr_$verify_im_message entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mlsys_misc_utils_$get_best_address_name entry (pointer, character (*) varying, fixed binary (35));
dcl  mlsys_parse_text_$parse_im_message_text
	entry (character (*) aligned, character (8), pointer, pointer, fixed binary (71), bit (1) aligned,
	bit (1) aligned, pointer, fixed binary (35));
dcl  mlsys_storage_mgr_$get_temp_segment entry (pointer, fixed binary (35));
dcl  mlsys_storage_mgr_$release_temp_segment entry (pointer, fixed binary (35));
dcl  sub_err_ entry () options (variable);

dcl  (area, cleanup, record_quota_overflow) condition;

dcl  (addr, addwordno, baseno, binary, before, copy, currentsize, divide, hbound, index, length, maxlength, mod, null,
     rel, reverse, rtrim, string, substr, unspec) builtin;
%page;
/* Determine the number of messages in a mailbox including a breakdown by type if requested */

get_message_counts:
     entry (P_mailbox_dirname, P_mailbox_ename, P_include_by_type, P_n_messages, P_n_ordinary_messages,
	P_n_interactive_messages, P_code);

	mailbox_dirname = P_mailbox_dirname;		/* copy inputs */
	call add_suffix (P_mailbox_ename, "mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* won't fit */

	system_area_ptr = get_system_free_area_ ();

	mra_ptr = addr (local_mra);			/* to make references to message_bits valid */

	mailbox_idx = 0;				/* for cleanup handler */
	local_mra.ms_ptr = null ();

	on condition (cleanup)
	     begin;
	     if mailbox_idx ^= 0 then do;
		call mailbox_$close (mailbox_idx, (0));
		mailbox_idx = 0;
	     end;
	     if local_mra.ms_ptr ^= null () then do;
		free message_bits in (system_area);
		local_mra.ms_ptr = null ();
	     end;
	end;


	call mailbox_$open_if_full (mailbox_dirname, mailbox_ename, ("0"b), n_messages, mailbox_idx, code);
	if code ^= 0 then do;			/* couldn't open the mailbox */
	     if code = error_table_$moderr then		/* translate to more specific explanation */
		code = mlsys_et_$no_s_permission;
	     go to RETURN_FROM_GET_MESSAGE_COUNTS;
	end;

	P_n_messages = n_messages;			/* always return this value */

	if ^P_include_by_type then go to RETURN_FROM_GET_MESSAGE_COUNTS;
						/* only wanted the total */

	if n_messages = 0 then do;			/* mailbox is empty */
	     P_n_ordinary_messages, P_n_interactive_messages = 0;
	     go to RETURN_FROM_GET_MESSAGE_COUNTS;
	end;


/* Count by message type is requested: verify that the caller has read access to the mailbox and, if they do, read each
   message in the mailbox, determine its type, and increment the appropriate counter */

	call mailbox_$get_mode_index (mailbox_idx, mailbox_mode, code);
	if code ^= 0 then go to RETURN_FROM_GET_MESSAGE_COUNTS;

	if (mailbox_mode & R_MBX_ACCESS) ^= R_MBX_ACCESS then do;
	     code = mlsys_et_$no_r_permission;
	     go to RETURN_FROM_GET_MESSAGE_COUNTS;
	end;

	n_messages_by_type (*) = 0;			/* an array is easier to use */

	call mailbox_$read_index (mailbox_idx, system_area_ptr, "0"b, addr (local_mra), code);
	if code ^= 0 then go to RETURN_FROM_GET_MESSAGE_COUNTS;
						/* must be at least one from above */

	do while (code ^= error_table_$no_message);	/* read all the messages */
	     call classify_message (local_mra.ms_ptr, local_mra.ms_len, message_format, message_type);
	     n_messages_by_type (message_type) = n_messages_by_type (message_type) + 1;
	     free message_bits in (system_area);	/* done with this one: now get next message (if any) */
	     call mailbox_$incremental_read_index (mailbox_idx, system_area_ptr, "01"b, local_mra.ms_id,
		addr (local_mra), code);
	     if (code ^= 0) & (code ^= error_table_$no_message) then go to RETURN_FROM_GET_MESSAGE_COUNTS;
	end;

	P_n_ordinary_messages = n_messages_by_type (ORDINARY_MESSAGES);
	P_n_interactive_messages = n_messages_by_type (INTERACTIVE_MESSAGES);

	code = 0;					/* entire operation was successfull */


/* Cleanup */

RETURN_FROM_GET_MESSAGE_COUNTS:
	if mailbox_idx ^= 0 then call mailbox_$close (mailbox_idx, (0));

	if local_mra.ms_ptr ^= null () then free message_bits in (system_area);

	P_code = code;				/* other output parameters have already been set */

	return;
%page;
/* Open a mailbox */

open_mailbox:
     entry (P_mailbox_dirname, P_mailbox_ename, P_open_options_ptr, P_mailbox_version, P_mailbox_ptr, P_code);

	if P_mailbox_version ^= MAILBOX_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	open_options_ptr = P_open_options_ptr;

	if open_options.version ^= OPEN_OPTIONS_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if ((open_options.message_selection_mode < ALL_MESSAGES)
	     | (open_options.message_selection_mode > INTERACTIVE_MESSAGES))
	     | ((open_options.sender_selection_mode < ACCESSIBLE_MESSAGES)
	     | (open_options.sender_selection_mode > NOT_OWN_MESSAGES))
	     | ((open_options.message_reading_level < READ_KEYS) | (open_options.message_reading_level > READ_MESSAGES))
	then do;					/* incorrectly specified option */
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	mailbox_dirname = P_mailbox_dirname;
	call add_suffix (P_mailbox_ename, "mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* entryname is too long */

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

	on condition (cleanup)
	     begin;
	     if mailbox_info_ptr ^= null () then call release_mailbox_info ();
	end;


/* Setup the internal data structure describing the mailbox, open the mailbox, and verify that the caller has the
   appropriate access to the mailbox to read the requested messages */

	allocate mailbox_info in (mlsys_area) set (mailbox_info_ptr);

	mailbox_info.dirname = mailbox_dirname;		/* fill in minimal information about the mailbox */
	mailbox_info.ename = mailbox_ename;

	mailbox_info.index = 0;			/* the following assignments keep the cleanup handler happy */
	mailbox_info.mailbox_ptr,			/* ... */
	     mailbox_info.address_ptr, mailbox_info.last_message_area_ptr, mailbox_info.delete_error_info_ptr,
	     mailbox_info.message_blocks = null ();

	call mailbox_$open (mailbox_info.dirname, mailbox_info.ename, mailbox_info.index, code);
	if code ^= 0 then go to ERROR_RETURN_FROM_OPEN_MAILBOX;
						/* couldn't open the mailbox (sigh) */

	call mailbox_$get_mode_index (mailbox_info.index, mailbox_mode, code);
	if code ^= 0 then go to ERROR_RETURN_FROM_OPEN_MAILBOX;

	string (mailbox_info.mode_flags) = mailbox_mode;	/* simpler to reference this way */

	string (user_privileges) = get_privileges_ ();	/* determine if the user has ring-1 privilege */
	mailbox_info.ring1_privilege = user_privileges.ring1;

	if (open_options.sender_selection_mode = ACCESSIBLE_MESSAGES) then
	     if mailbox_info.mode_flags.read then do;	/* can get all messages */
		mailbox_info.sender_selection_mode = ALL_MESSAGES;
		mailbox_info.use_own_mode = "0"b;
	     end;
	     else if mailbox_info.mode_flags.own then do; /* can only get our messages */
		mailbox_info.sender_selection_mode = OWN_MESSAGES;
		mailbox_info.use_own_mode = "1"b;
	     end;
	     else do;				/* can't get at anything */
		code = error_table_$moderr;
		go to ERROR_RETURN_FROM_OPEN_MAILBOX;
	     end;

	else do;					/* specific type of mode requested */
	     mailbox_info.sender_selection_mode = open_options.sender_selection_mode;
	     if (open_options.sender_selection_mode = ALL_MESSAGES)
		| (open_options.sender_selection_mode = NOT_OWN_MESSAGES) then
		if mailbox_info.mode_flags.read then	/* have appropriate access */
		     mailbox_info.use_own_mode = "0"b;
		else do;
		     code = mlsys_et_$no_r_permission;
		     go to ERROR_RETURN_FROM_OPEN_MAILBOX;
		end;
	     else if (open_options.sender_selection_mode = OWN_MESSAGES) then
		if mailbox_info.mode_flags.own then	/* have appropriate access */
		     mailbox_info.use_own_mode = "1"b;
		else do;
		     code = mlsys_et_$no_o_permission;
		     go to ERROR_RETURN_FROM_OPEN_MAILBOX;
		end;
	end;

	mailbox_info.message_selection_mode = open_options.message_selection_mode;
	mailbox_info.message_reading_level = open_options.message_reading_level;

	on condition (area)
	     begin;
	     code = error_table_$noalloc;		/* ran out of room (shouldn't happen, but...) */
	     go to ERROR_RETURN_FROM_OPEN_MAILBOX;
	end;

	call mlsys_address_mgr_$create_mailbox_address (mailbox_dirname, mailbox_ename, "", "",
	     mailbox_info.address_ptr, (0));
	call mlsys_address_mgr_$increment_reference_count (mailbox_info.address_ptr);
						/* prevent user accidently freeing it */
	call mlsys_mailbox_utils_$classify_mailbox_address (mailbox_info.address_ptr, mailbox_info.type, (0));

	if mailbox_info.mode_flags.status then do;	/* have proper permission to get salvaged bit ... */
	     call mailbox_$check_salv_bit_index (mailbox_info.index, (mailbox_info.mode_flags.delete),
		mailbox_salvaged_bit, code);		/* ... turn it off if user "owns" mbx */
	     if code ^= 0 then go to ERROR_RETURN_FROM_OPEN_MAILBOX;
						/* ... shouldn't happen, but ... */
	     mailbox_info.salvaged = mailbox_salvaged_bit;
	end;
	else mailbox_info.salvaged = "0"b;		/* don't have access to get this bit: non-fatal error */


/* Read the messages from the mailbox: classify each message by type and determine if it meets the caller's selection
   criteria */

	mailbox_info.n_messages,			/* haven't read any messages yet */
	     mailbox_info.n_messages_by_type (*), mailbox_info.n_deleted_messages = 0;
	mailbox_info.last_message_key = ""b;
	mailbox_info.message_blocks = null ();

	do while ("1"b);				/* loop is exited by other means ... */

	     call read_next_message ();		/* sets im_message_info_ptr for us ... */
	     if code ^= 0 then			/* message wasn't read because ...  */
		if code = error_table_$no_message then
		     go to ALL_MESSAGES_HAVE_BEEN_READ; /* ... reached the end of the mailbox OK */
		else go to ERROR_RETURN_FROM_OPEN_MAILBOX;
						/* ... unexpected problem */

	     if mailbox_info.message_selection_mode ^= ALL_MESSAGES then
		if im_message_info.type ^= mailbox_info.message_selection_mode then do;
EXCLUDE_CURRENT_MESSAGE:				/* this message is the wrong type */
		     free message_bits in (mailbox_message_area.area);
		     message_block.n_used = message_block.n_used - 1;
		     go to READ_NEXT_MESSAGE;		/* zap! this slot is no longer in use */
		end;

	     if mailbox_info.sender_selection_mode = NOT_OWN_MESSAGES then
		if message_from_self (im_message_info.mra.sender_id) then go to EXCLUDE_CURRENT_MESSAGE;
						/* "own" messages ignore project distinctions */

	     mailbox_info.n_messages = mailbox_info.n_messages + 1;
						/* this message is OK */
	     mailbox_info.n_messages_by_type (im_message_info.type) =
		mailbox_info.n_messages_by_type (im_message_info.type) + 1;

READ_NEXT_MESSAGE:
	end;


/* All messages have been read: create the mailbox structure to be returned to the caller */

ALL_MESSAGES_HAVE_BEEN_READ:
	mailbox_n_messages =			/* allow for late arrivals */
	     mlsys_data_$mailbox_allocation
	     *
	     divide ((mailbox_info.n_messages + mlsys_data_$mailbox_allocation), mlsys_data_$mailbox_allocation, 17, 0);

	allocate mailbox in (mlsys_area) set (mailbox_ptr);
	mailbox_info.mailbox_ptr = mailbox_ptr;		/* need to remember where it is */

	mailbox.version = MAILBOX_VERSION_2;		/* fill it in ... */

	mailbox_reserved_data.info_ptr = mailbox_info_ptr;/* given caller's mailbox_ptr need to find our data */
	mailbox_reserved_data.n_messages_allocated = mailbox_n_messages;

	mailbox.mailbox_type = mailbox_info.type;	/* just copy data from internal structure ... */
	mailbox.mailbox_address = mailbox_info.address_ptr;
	mailbox.mailbox_dirname = mailbox_info.dirname;
	mailbox.mailbox_ename = mailbox_info.ename;
	mailbox.message_selection_mode = mailbox_info.message_selection_mode;
	mailbox.sender_selection_mode = mailbox_info.sender_selection_mode;
	mailbox.message_reading_level = mailbox_info.message_reading_level;
	mailbox.mode = string (mailbox_info.mode_flags);

	string (mailbox.flags) = ""b;
	mailbox.salvaged = mailbox_info.salvaged;

	mailbox.n_messages = mailbox_info.n_messages;	/* user visible message count */
	mailbox.n_ordinary_messages = mailbox_info.n_messages_by_type (ORDINARY_MESSAGES);
	mailbox.n_interactive_messages = mailbox_info.n_messages_by_type (INTERACTIVE_MESSAGES);
	mailbox.n_deleted_messages = mailbox_info.n_deleted_messages;
						/* even though it's zero, be safe */


/* And now fill in the data for the messages ... */

	message_idx = 0;

	do message_block_ptr = mailbox_info.message_blocks.first repeat (next_message_block_ptr)
	     while (message_block_ptr ^= null ());
	     next_message_block_ptr = message_block.next;

	     do idx = 1 to message_block.n_used;
		im_message_info_ptr = addr (message_block.messages (idx));
		message_idx = message_idx + 1;	/* next slot in the user's structure */

		mailbox.messages (message_idx).key = im_message_info.key;

		if mailbox_info.message_reading_level = READ_KEYS then
		     mailbox.messages (message_idx).message_ptr = null ();

		else /*** if mailbox_info.message_reading_level = READ_MESSAGES then */
		     do;
		     call construct_user_message ();	/* construct the user-visible message structure */
		     mailbox.messages (message_idx).message_ptr = im_message_info.message_ptr;
		end;
	     end;
	end;


/* Success: return the mailbox structure to the caller */

	P_mailbox_ptr = mailbox_ptr;

	P_code = 0;

	return;


/* Control transfers here if an error is detected while opening the mailbox */

ERROR_RETURN_FROM_OPEN_MAILBOX:
	if mailbox_info_ptr ^= null () then call release_mailbox_info ();

	P_code = code;

	return;
%page;
/* Check an open mailbox to see if any new messages have arrived and, if so, read them from the mailbox and return them to
   the caller in the (possibly reallocated) user-visible mailbox structure */

read_new_messages:
     entry (P_mailbox_ptr, P_n_new_messages, P_n_new_ordinary_messages, P_n_new_interactive_messages, P_code);

	mailbox_ptr = copy_ptr (P_mailbox_ptr);

	if ^verify_mailbox () then do;		/* caller didn't supply a mailbox structure */
	     P_code = mlsys_et_$not_mailbox;
	     return;
	end;

	mailbox_info_ptr = mailbox_reserved_data.info_ptr;/* need our internal description */

	if mailbox_info.pending_deletion then do;	/* caller must complete the previous operation */
	     P_code = mlsys_et_$deletion_pending;
	     return;
	end;

	im_message_info_ptr = null ();		/* for the internal procedure ... */
	call recompute_mailbox_access (code);		/* revalidate our access to the mailbox */
	if code ^= 0 then do;			/* ... failed (mailbox deleted?) */
	     P_code = code;
	     return;
	end;

	if mailbox_info.use_own_mode then		/* check if the user still has proper access */
	     if ^mailbox_info.mode_flags.own then do;	/* no longer have permission to read our messages */
		P_code = mlsys_et_$no_o_permission;
		return;
	     end;
	     else ;				/* still has the access */
	else if ^mailbox_info.mode_flags.read then do;	/* no longer have permission to read messages */
	     P_code = mlsys_et_$no_r_permission;
	     return;
	end;


/* Read and classify the new messages in the mailbox: discard any new messages that are not of the proper type */

	new_mailbox_ptr = null ();			/* for cleanup handler */
	n_new_messages = 0;

	on condition (cleanup) call release_new_mailbox_info ();

	on condition (area)
	     begin;				/* in case there isn't enough room */
	     code = error_table_$noalloc;
	     go to ERROR_RETURN_FROM_READ_NEW_MESSAGES;
	end;

	n_new_messages = 0;				/* haven't found any new messages yet */
	n_new_messages_by_type (*) = 0;

	saved_message_block_ptr = mailbox_info.message_blocks.last;
	saved_message_block_n_used = saved_message_block_ptr -> message_block.n_used;
						/* record where last old message lives */

	do while ("1"b);				/* loop is exited by other means ... */

	     call read_next_message ();		/* sets im_message_info_ptr for us ... */
	     if code ^= 0 then			/* message wasn't read because ... */
		if code = error_table_$no_message then
		     go to READ_ALL_NEW_MESSAGES;	/* ... reached the end of the mailbox OK */
		else go to ERROR_RETURN_FROM_READ_NEW_MESSAGES;

	     if mailbox_info.message_selection_mode ^= ALL_MESSAGES then
		if im_message_info.type ^= mailbox_info.message_selection_mode then do;
EXCLUDE_NEW_MESSAGE:				/* this message is the wrong type */
		     free message_bits in (mailbox_message_area.area);
		     message_block.n_used = message_block.n_used - 1;
		     go to READ_NEXT_NEW_MESSAGE;	/* zap! this slot is no longer in use */
		end;

	     if mailbox_info.sender_selection_mode = NOT_OWN_MESSAGES then
		if message_from_self (im_message_info.mra.sender_id) then go to EXCLUDE_NEW_MESSAGE;
						/* "own" messages ignore project distinctions */

	     n_new_messages = n_new_messages + 1;	/* another new message */
	     n_new_messages_by_type (im_message_info.type) = n_new_messages_by_type (im_message_info.type) + 1;

READ_NEXT_NEW_MESSAGE:
	end;


/* All new messages have been read: reallocate the user-visible mailbox structure if necessary */

READ_ALL_NEW_MESSAGES:
	message_idx = 0;				/* for cleanup handler */

	if (mailbox_info.n_messages + n_new_messages) <= mailbox_reserved_data.n_messages_allocated then
	     new_mailbox_ptr = mailbox_ptr;		/* old structure has enough room */

	else do;					/* need a new structure */
	     mailbox_n_messages = mailbox_info.n_messages + n_new_messages;
	     mailbox_n_messages =			/* ... allow room for later growth */
		mailbox_n_messages + mlsys_data_$mailbox_allocation
		- mod (mailbox_n_messages, mlsys_data_$mailbox_allocation);

	     allocate mailbox in (mlsys_area) set (new_mailbox_ptr);

	     new_mailbox_ptr -> mailbox.version = MAILBOX_VERSION_2;
						/* fill it in ... */

	     addr (new_mailbox_ptr -> mailbox.reserved) -> mailbox_reserved_data.info_ptr = mailbox_info_ptr;
	     addr (new_mailbox_ptr -> mailbox.reserved) -> mailbox_reserved_data.n_messages_allocated =
		mailbox_n_messages;

	     new_mailbox_ptr -> mailbox.mailbox_type = mailbox_info.type;
	     new_mailbox_ptr -> mailbox.mailbox_address = mailbox_info.address_ptr;
	     new_mailbox_ptr -> mailbox.mailbox_dirname = mailbox_info.dirname;
	     new_mailbox_ptr -> mailbox.mailbox_ename = mailbox_info.ename;
	     new_mailbox_ptr -> mailbox.message_selection_mode = mailbox_info.message_selection_mode;
	     new_mailbox_ptr -> mailbox.sender_selection_mode = mailbox_info.sender_selection_mode;
	     new_mailbox_ptr -> mailbox.message_reading_level = mailbox_info.message_reading_level;
	     new_mailbox_ptr -> mailbox.mode = string (mailbox_info.mode_flags);

	     string (new_mailbox_ptr -> mailbox.flags) = ""b;
	     new_mailbox_ptr -> mailbox.salvaged = mailbox_info.salvaged;

	     new_mailbox_ptr -> mailbox.n_deleted_messages = mailbox_info.n_deleted_messages;
						/* only this one isn't going to be changed here */

	     do message_idx = 1 to mailbox.n_messages;
		new_mailbox_ptr -> mailbox.messages (message_idx) = mailbox.messages (message_idx);
	     end;					/* copy old messages' data */
	end;


/* And now fill in the data for the new messages ... */

	message_idx = mailbox_info.n_messages;		/* # of messages already present in user's structure */

	do message_block_ptr = saved_message_block_ptr repeat (next_message_block_ptr)
	     while (message_block_ptr ^= null ());
	     next_message_block_ptr = message_block.next;

	     if message_block_ptr = saved_message_block_ptr then
		first_idx = saved_message_block_n_used + 1;
						/* first block starts in the middle */
	     else first_idx = 1;

	     do idx = first_idx to message_block.n_used;
		im_message_info_ptr = addr (message_block.messages (idx));
		message_idx = message_idx + 1;	/* get appropriate slot in user's structure */

		new_mailbox_ptr -> mailbox.messages (message_idx).key = im_message_info.key;

		if mailbox_info.message_reading_level = READ_KEYS then
		     new_mailbox_ptr -> mailbox.messages (message_idx).message_ptr = null ();

		else /*** if mailbox_info.message_reading_level = READ_MESSAGES then */
		     do;
		     call construct_user_message ();	/* create the user-visible message structure */
		     mailbox.messages (message_idx).message_ptr = im_message_info.message_ptr;
		end;
	     end;
	end;


/* Success: update message counts, release old mailbox structure (if needed) and return */

	mailbox_info.n_messages = mailbox_info.n_messages + n_new_messages;
	mailbox_info.n_messages_by_type (*) = mailbox_info.n_messages_by_type (*) + n_new_messages_by_type (*);

	if mailbox_ptr ^= new_mailbox_ptr then do;
	     free mailbox_ptr -> mailbox in (mlsys_area);
	     mailbox_info.mailbox_ptr, mailbox_ptr = new_mailbox_ptr;
	end;

	mailbox.n_messages = mailbox_info.n_messages;
	mailbox.n_ordinary_messages = mailbox_info.n_messages_by_type (ORDINARY_MESSAGES);
	mailbox.n_interactive_messages = mailbox_info.n_messages_by_type (INTERACTIVE_MESSAGES);

	P_n_new_messages = n_new_messages;		/* let caller know how much is new */
	P_n_new_ordinary_messages = n_new_messages_by_type (ORDINARY_MESSAGES);
	P_n_new_interactive_messages = n_new_messages_by_type (INTERACTIVE_MESSAGES);

	P_mailbox_ptr = mailbox_ptr;			/* reflect changes */

	if n_new_messages > 0 then
	     P_code = 0;				/* something new alright */
	else P_code = mlsys_et_$no_more_messages;

	return;


/* Control transfers here if an error is detected while checking for new messages */

ERROR_RETURN_FROM_READ_NEW_MESSAGES:
	call release_new_mailbox_info ();		/* cleanup */

	P_code = code;

	return;
%page;
/* "Read" the requested message:  Actually all appropriate messages in the mailbox are read by open_mailbox or
   read_new_messages due to the lack of appropriate ring-1 mailbox primitives.  However, an application program should
   specify a message_reading_level of READ_KEYS to avoid the overhead of converting all messages in the mailbox when it
   may actually only examine a few messages in the mailbox.  To this end, this entrypoint simply converts the data read
   from ring-1 into the corresponding message structure */

read_message:
     entry (P_mailbox_ptr, P_message_idx, P_code);

	mailbox_ptr = copy_ptr (P_mailbox_ptr);

	if ^verify_mailbox () then do;
	     P_code = mlsys_et_$not_mailbox;
	     return;
	end;

	mailbox_info_ptr = mailbox_reserved_data.info_ptr;/* need our internal description */

	if mailbox_info.pending_deletion then do;	/* data structures are inconsistent */
	     P_code = mlsys_et_$deletion_pending;
	     return;
	end;

	message_idx = 0;				/* find the requested message */

	do message_block_ptr = mailbox_info.message_blocks.first repeat (next_message_block_ptr)
	     while (message_block_ptr ^= null ());
	     next_message_block_ptr = message_block.next;
	     do idx = 1 to message_block.n_used;
		im_message_info_ptr = addr (message_block.messages (idx));
		if ^im_message_info.already_deleted then do;
		     message_idx = message_idx + 1;	/* ... a message that still counts */
		     if message_idx = P_message_idx then go to FOUND_REQUESTED_MESSAGE;
		end;
	     end;
	end;

	P_code = error_table_$bad_index;		/* no such message */
	return;

FOUND_REQUESTED_MESSAGE:
	if im_message_info.message_ptr ^= null () then do;/* already been "read" */
	     P_code = mlsys_et_$message_already_read;
	     return;
	end;

	call construct_user_message ();		/* create the user-visible message structure */

	mailbox.messages (message_idx).message_ptr = im_message_info.message_ptr;

	P_code = 0;				/* success */

	return;
%page;
/* "Read" the canonical form of the requested message:  The canonical form of a message is the text used by the mail
   system when it stores the message in a mailbox using the mail_format structure */

read_message_canonical_form_p:			/* ...given the message itself: target of user-ring gate */
     entry (P_message_ptr, P_message_canonical_form_ptr, P_message_canonical_form_lth, P_code);

	if ^mlsys_message_mgr_$verify_im_message (P_message_ptr, im_message_info_ptr, P_code) then return;

	mailbox_info_ptr = im_message_info.mailbox_info_ptr;
	if mailbox_info.pending_deletion then do;	/* data structures are inconsistent */
	     P_code = mlsys_et_$deletion_pending;
	     return;
	end;

	go to CHECK_FOR_CANONICAL_FORM;


read_message_canonical_form:				/* ... given the mailbox and message number */
     entry (P_mailbox_ptr, P_message_idx, P_message_canonical_form_ptr, P_message_canonical_form_lth, P_code);

	mailbox_ptr = copy_ptr (P_mailbox_ptr);
	if ^verify_mailbox () then do;
	     P_code = mlsys_et_$not_mailbox;
	     return;
	end;

	mailbox_info_ptr = mailbox_reserved_data.info_ptr;/* need our internal description */

	if mailbox_info.pending_deletion then do;	/* data structures are inconsistent */
	     P_code = mlsys_et_$deletion_pending;
	     return;
	end;

	message_idx = 0;				/* find the requested message */

	do message_block_ptr = mailbox_info.message_blocks.first repeat (next_message_block_ptr)
	     while (message_block_ptr ^= null ());
	     next_message_block_ptr = message_block.next;
	     do idx = 1 to message_block.n_used;
		im_message_info_ptr = addr (message_block.messages (idx));
		if ^im_message_info.already_deleted then do;
		     message_idx = message_idx + 1;	/* ... a message that still counts */
		     if message_idx = P_message_idx then go to CHECK_FOR_CANONICAL_FORM;
		end;
	     end;
	end;

	P_code = error_table_$bad_index;		/* no such message */
	return;


/* Found the message: check that it has a canonical form.  Ie: it must be a mail_format message and the
   mail_format.canonical flag must be ON */

CHECK_FOR_CANONICAL_FORM:
	if im_message_info.format = MAIL_FORMAT_MESSAGE then do;
	     mail_format_ptr = im_message_info.mra.ms_ptr;
	     if mail_format.canonical then do;		/* it's the right type of message */
		P_message_canonical_form_ptr = addr (mail_format.text);
		P_message_canonical_form_lth = mail_format.text_len;
		code = 0;				/* ... success */
	     end;
	     else code = mlsys_et_$no_message_canonical_form;
	end;

	else code = mlsys_et_$no_message_canonical_form;	/* not a mail_format */

	P_code = code;				/* let caller know how he did */

	return;
%page;
/* Return the actual mail_format and mf_extension structures stored in ring-1 for the given message if and only if said
   message was stored in canonical form */

get_message_mf_if_canonical:
     entry (P_message_ptr, P_message_mf_ptr, P_message_mf_extension_ptr, P_code);

	if ^mlsys_message_mgr_$verify_im_message (P_message_ptr, im_message_info_ptr, P_code) then return;

	if im_message_info.format = MAIL_FORMAT_MESSAGE then
	     if im_message_info.mra.ms_ptr -> mail_format.canonical then do;
		P_message_mf_ptr, mail_format_ptr = im_message_info.mra.ms_ptr;
		P_message_mf_extension_ptr = addwordno (mail_format_ptr, currentsize (mail_format));
		code = 0;				/* success */
	     end;

	     else code = mlsys_et_$no_message_canonical_form;
						/* not canonical */

	else code = mlsys_et_$no_message_canonical_form;	/* not a mail_format */

	P_code = code;

	return;
%page;
/* Close a mailbox:  If caller requests, all messages previously marked for deletion will actually be deleted; see the
   notes for the mail_system_$expunge_messages entrypoint for further information */

close_mailbox:
     entry (P_mailbox_ptr, P_close_options_ptr, P_code);

	mailbox_ptr = copy_ptr (P_mailbox_ptr);
	close_options_ptr = P_close_options_ptr;

	if ^verify_mailbox () then do;		/* make sure caller passed us a mailbox */
	     P_code = mlsys_et_$not_mailbox;
	     return;
	end;

	if close_options.version ^= CLOSE_OPTIONS_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if close_options.mbz ^= ""b then do;		/* it's supposed to be zeroes */
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	mailbox_info_ptr = mailbox_reserved_data.info_ptr;/* get pointer to our internal data */

	im_message_info_ptr = null ();		/* avoid problems in the internal procedure */
	call recompute_mailbox_access (code);		/* revalidate access to this mailbox */
	if code ^= 0 then do;			/* ... failed (mailbox deleted?) */
	     P_code = code;
	     return;
	end;

	if close_options.perform_deletions then		/* delete messages awaiting deletion */
	     call perform_deletions ((close_options.report_deletion_errors), deletion_failed);
	else deletion_failed = "0"b;

	call release_mailbox_info ();			/* cleanup storage and close the mailbox */

	P_mailbox_ptr = null ();			/* make sure the caller can't reference it anymore */

	if deletion_failed then
	     P_code = mlsys_et_$some_messages_not_deleted;/* warn caller all is not perfect */
	else P_code = 0;				/* everything went perfectly */

	return;
%page;
/* Expunge the messages in a mailbox which are scheduled for deletion:  If a message being deleted is waiting for
   acknowledgement, a special acknowledgement will be delivered to inform the author that this user never read the
   message.  If any marked message can not be deleted, a sub_error_ condition will be signalled and the operation aborted;
   the caller will then be required either to complete the operation by calling this entrypoint again or to abort the
   operation by calling mail_system_$abort_delete_operation */

expunge_messages:
     entry (P_mailbox_ptr, P_code);

	mailbox_ptr = copy_ptr (P_mailbox_ptr);

	if ^verify_mailbox () then do;		/* make sure caller passed us a mailbox */
	     P_code = mlsys_et_$not_mailbox;
	     return;
	end;

	mailbox_info_ptr = mailbox_reserved_data.info_ptr;/* need our internal description */

	call perform_deletions ("1"b, deletion_failed);	/* do the deletions */
	call reconstruct_mailbox ();			/* make the mailbox structure reflect what is left */

	if deletion_failed then			/* couldn't get rid of some messages for whatever reason */
	     P_code = mlsys_et_$some_messages_not_deleted;
	else if mailbox_info.n_messages = 0 then	/* nothing left in the mailbox */
	     P_code = mlsys_et_$all_messages_deleted;
	else P_code = 0;

	return;


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

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

dcl  (collate, translate) builtin;

dcl  ALPHABET char (256) init ((8)" " || "	" || (4)" " || "" || (16)" " || substr (collate (), 33));
						/* space, BSHT, space, RRSBRS, space, alphanumerics */
dcl  BS char (1) internal static options (constant) init ("");

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


/* Actually delete the marked messages (called by several entrypoints) */

perform_deletions:
     procedure (p_report_errors, p_deletion_failed);

dcl  (p_report_errors, p_deletion_failed) bit (1) aligned parameter;
dcl  next_message_block_ptr pointer;
dcl  (message_idx, idx) fixed binary;

	p_deletion_failed = "0"b;			/* assume everything works OK */

	message_idx = 0;				/* will need the index in the user visible structure */

	do message_block_ptr = mailbox_info.message_blocks.first repeat (next_message_block_ptr)
	     while (message_block_ptr ^= null ());
	     next_message_block_ptr = message_block.next;

	     do idx = 1 to message_block.n_used;
		im_message_info_ptr = addr (message_block.messages (idx));
		message_ptr = im_message_info.message_ptr;

		if ^im_message_info.already_deleted then do;
		     message_idx = message_idx + 1;	/* this message hasn't been deleted yet */

		     if im_message_info.to_be_deleted then do;
			/*** caller has asked to delete this message */

			if im_message_info.can_be_deleted then do;
			     /*** ... and it appears that the user still has sufficient access */

			     if im_message_info.requests_acknowledgement then
				/*** ... let the sender know that this user never did read it */
				call acknowledge_for_deletion ();

			     /*** ... now delete it */
			     call mailbox_$delete_index (mailbox_info.index, im_message_info.key, code);
			     if (code = 0) | (code = error_table_$no_message) then
				im_message_info.already_deleted = "1"b;
			     else call deletion_failure (code);
			end;			/* ... it should have worked */

			else call deletion_failure (mlsys_et_$cant_be_deleted);
		     end;				/* can no longer delete it: let caller know */
		end;
	     end;
	end;

	call mailbox_$compact_index (mailbox_info.index, 0.25e0, (0));
						/* compact if more than 25% unused space */

	return;



/* Internal to perform_deletion: reflects the failure to delete a message by changing the appropriate data structures to
   indicate that said message can not be deleted; this change is required to allow future expunge or close operations to
   succeed.  If requested, this procedure also signals the sub_error_ condition to inform the caller as to why this
   particular message could not be deleted; as mail_system_ is a ring-2 gate, this condition is not restartable */

deletion_failure:
	procedure (p_code);

dcl  p_code fixed binary (35);

	     p_deletion_failed = "1"b;		/* so we can set the appropriate error code */

	     im_message_info.can_be_deleted,		/* can't delete it: record this and unmark it ... */
		im_message_info.to_be_deleted,	/* ... so that future expunge/close operations will work */
		im_message_info.message_ptr -> message.can_be_deleted,
		im_message_info.message_ptr -> message.marked_for_deletion = "0"b;

	     mailbox_info.n_deleted_messages = mailbox_info.n_deleted_messages - 1;
	     mailbox.n_deleted_messages = mailbox_info.n_deleted_messages;
						/* one less message marked for deletion */

	     if p_report_errors then do;		/* let the caller know about it ... */
		mailbox_info.pending_deletion = "1"b;	/* ... data structures are inconsistent */

		allocate delete_error_info in (mlsys_area) set (delete_error_info_ptr);
		mailbox_info.delete_error_info_ptr = delete_error_info_ptr;

		delete_error_info.version = DELETE_ERROR_INFO_VERSION_1;
		delete_error_info.message_number = message_idx;
		delete_error_info.code = p_code;
		delete_error_info.additional_info = "";

RESIGNAL_DELETION_FAILURE:
		call sub_err_ (p_code, MAIL_SYSTEM_, ACTION_CANT_RESTART, delete_error_info_ptr, (0),
		     "Unable to delete message #^d.", message_idx);

		go to RESIGNAL_DELETION_FAILURE;	/* ... not restartable: this will never be reached, but ... */
	     end;

	     return;

	end deletion_failure;

     end perform_deletions;
%page;
/* Abort a suspended call to mail_system_$expunge_messages or mail_system_$close_mailbox: by simply reconstructing the
   user-visible mailbox data structure to indicate which messages have already been deleted */

abort_delete_operation:
     entry (P_mailbox_ptr, P_code);

	mailbox_ptr = copy_ptr (P_mailbox_ptr);

	if ^verify_mailbox () then do;		/* make sure caller passed us a mailbox */
	     P_code = mlsys_et_$not_mailbox;
	     return;
	end;

	mailbox_info_ptr = mailbox_reserved_data.info_ptr;/* need our internal description */

	if mailbox_info.pending_deletion then do;	/* there were deletions in progress */
	     call reconstruct_mailbox ();
	     P_code = 0;
	end;

	else P_code = mlsys_et_$no_pending_deletion;	/* there were no deletions in progress */

	return;



/* Actually reconstructs the mailbox structure (used by several entrypoints) */

reconstruct_mailbox:
     procedure ();

dcl  next_message_block_ptr pointer;
dcl  idx fixed binary;

	mailbox_info.n_messages,			/* must recompute all message counts */
	     mailbox_info.n_messages_by_type (*), mailbox_info.n_deleted_messages = 0;

	do message_block_ptr = mailbox_info.message_blocks.first repeat (next_message_block_ptr)
	     while (message_block_ptr ^= null ());
	     next_message_block_ptr = message_block.next;

	     do idx = 1 to message_block.n_used;
		im_message_info_ptr = addr (message_block.messages (idx));

		if ^im_message_info.already_deleted then do;
		     mailbox_info.n_messages = mailbox_info.n_messages + 1;

		     mailbox.messages (mailbox_info.n_messages).key = im_message_info.key;
		     mailbox.messages (mailbox_info.n_messages).message_ptr = im_message_info.message_ptr;

		     mailbox_info.n_messages_by_type (im_message_info.type) =
			mailbox_info.n_messages_by_type (im_message_info.type) + 1;

		     if im_message_info.to_be_deleted then
						/* record that it will be deleted later ... */
			mailbox_info.n_deleted_messages = mailbox_info.n_deleted_messages + 1;
		end;
	     end;
	end;

	mailbox.n_messages = mailbox_info.n_messages;	/* update the user-visible counts */
	mailbox.n_ordinary_messages = mailbox_info.n_messages_by_type (ORDINARY_MESSAGES);
	mailbox.n_interactive_messages = mailbox_info.n_messages_by_type (INTERACTIVE_MESSAGES);
	mailbox.n_deleted_messages = mailbox_info.n_deleted_messages;

	mailbox_info.pending_deletion = "0"b;		/* no longer any deletions in progress */

	if mailbox_info.delete_error_info_ptr ^= null () then do;
	     free mailbox_info.delete_error_info_ptr -> delete_error_info in (mlsys_area);
	     mailbox_info.delete_error_info_ptr = null ();
	end;

     end reconstruct_mailbox;
%page;
/* Mark the given message for subsequent deletion */

mark_message_for_deletion:
     entry (P_message_ptr, P_code);

	if ^mlsys_message_mgr_$verify_im_message (P_message_ptr, im_message_info_ptr, P_code) then return;

	message_ptr = copy_ptr (P_message_ptr);		/* get pointers to all approrpriate data structures */
	mailbox_info_ptr = im_message_info.mailbox_info_ptr;
	mailbox_ptr = mailbox_info.mailbox_ptr;

	if mailbox_info.pending_deletion then do;	/* data structures are inconsistent */
	     P_code = mlsys_et_$deletion_pending;
	     return;
	end;

	call recompute_mailbox_access (code);		/* revalidate our access to the mailbox */
	if code ^= 0 then do;			/* ... failed: mailbox deleted? */
	     P_code = code;
	     return;
	end;

	if im_message_info.can_be_deleted then		/* it seems we can delete this message ... */
	     if im_message_info.to_be_deleted then	/* ... but it was already marked */
		code = mlsys_et_$already_marked_for_deletion;
	     else do;				/* ... and it wasn't marked earlier */
		mailbox_info.n_deleted_messages, mailbox.n_deleted_messages = mailbox_info.n_deleted_messages + 1;
		im_message_info.to_be_deleted, message.marked_for_deletion = "1"b;
		code = 0;				/* ... success */
	     end;

	else code = mlsys_et_$cant_be_deleted;		/* it isn't possible to delete this message */

	P_code = code;

	return;
%page;
/* Remove the given message from the list of messages marked for subsequent deletion */

unmark_message_for_deletion:
     entry (P_message_ptr, P_code);

	if ^mlsys_message_mgr_$verify_im_message (P_message_ptr, im_message_info_ptr, P_code) then return;

	message_ptr = copy_ptr (P_message_ptr);		/* get pointers to all approrpriate data structures */
	mailbox_info_ptr = im_message_info.mailbox_info_ptr;
	mailbox_ptr = mailbox_info.mailbox_ptr;

	if mailbox_info.pending_deletion then do;	/* data structures are inconsistent */
	     P_code = mlsys_et_$deletion_pending;
	     return;
	end;

	if im_message_info.to_be_deleted then do;	/* it's marked for deletion all right ... */
	     mailbox_info.n_deleted_messages, mailbox.n_deleted_messages = mailbox_info.n_deleted_messages - 1;
	     im_message_info.to_be_deleted, message.marked_for_deletion = "0"b;
	     code = 0;				/* ... success */
	end;

	else code = mlsys_et_$not_marked_for_deletion;	/* it isn't possible to delete this message */

	P_code = code;

	return;
%page;
/* Set a switch on an individual message */

set_message_switch:
     entry (P_message_ptr, P_switch_type, P_switch_value, P_code);


	P_code = 0;
	if ^mlsys_message_mgr_$verify_im_message (P_message_ptr, im_message_info_ptr, P_code) then return;

	message_ptr = copy_ptr (P_message_ptr);
	mailbox_info_ptr = im_message_info.mailbox_info_ptr;
	if ^mailbox_info.mode_flags.delete then do;	/* only the mailbox "owner" can set a switch */
	     P_code = mlsys_et_$cant_update_message;
	     return;
	end;

	switch_type = P_switch_type;
	switch_value = P_switch_value;

	if switch_type = PER_MESSAGE_SEEN_SWITCH_TYPE then do;
	     if im_message_info.format = FIPS98_FORMAT_MESSAGE then
		im_message_info.mra.ms_ptr -> fips98_message.seen = switch_value;
	     else if im_message_info.format = MAIL_FORMAT_MESSAGE then
		im_message_info.mra.ms_ptr -> mail_format.seen = switch_value;
	end;
	else do;
	     P_code = error_table_$bad_subr_arg;	/* only "seen" switch supported */
	     return;
	end;

	call mailbox_$update_message_index (mailbox_info.index, im_message_info.mra.ms_len, im_message_info.key,
	     im_message_info.mra.ms_ptr, code);

/* Having marked the message in the mailbox, mark the local copy */

	if switch_type = PER_MESSAGE_SEEN_SWITCH_TYPE then message.seen = switch_value;

	P_code = code;

	return;
%page;
/* Generate an acknowledgement for the given message if appropriate */

acknowledge_message:
     entry (P_message_ptr, P_code);

	if ^mlsys_message_mgr_$verify_im_message (P_message_ptr, im_message_info_ptr, P_code) then return;

	message_ptr = copy_ptr (P_message_ptr);		/* get pointers to all approrpriate data structures */
	mailbox_info_ptr = im_message_info.mailbox_info_ptr;
	mailbox_ptr = mailbox_info.mailbox_ptr;

	if mailbox_info.pending_deletion then do;	/* data structures are inconsistent */
	     P_code = mlsys_et_$deletion_pending;
	     return;
	end;

	call recompute_mailbox_access (code);		/* revalidate our access to the mailbox */
	if code ^= 0 then do;			/* ... failed: mailbox deleted? */
	     P_code = code;
	     return;
	end;

	if ^im_message_info.requests_acknowledgement then do;
	     P_code = mlsys_et_$no_ack_needed;		/* the message hasn't asked to be acknowledged */
	     return;
	end;

	call determine_acknowledgement_recipient (code);	/* determine who gets the acknowledgement */

	if code = 0 then				/* have the recipient ... */
	     call deliver_acknowledgement ("0"b, code);	/* ... send a standard acknowledgement message */

	if code = 0 then do;			/* successfully sent the acknowledgement ... */
	     if im_message_info.format = FIPS98_FORMAT_MESSAGE then
		im_message_info.mra.ms_ptr -> fips98_message.acknowledge = "0"b;
	     else if im_message_info.format = MAIL_FORMAT_MESSAGE then
		im_message_info.mra.ms_ptr -> mail_format.acknowledge = "0"b;
	     call mailbox_$update_message_index (mailbox_info.index, im_message_info.mra.ms_len, im_message_info.key,
		im_message_info.mra.ms_ptr, code);
	     if code ^= 0 then code = mlsys_et_$cant_update_message;
	end;

	call delete_acknowledge_to_fields ();		/* delete all Acknowledge-To fields */
	im_message_info.requests_acknowledgement, message.must_be_acknowledged = "0"b;
						/* if it failed, it won't help to let them call back */

	P_code = code;				/* reflect success/failure to the caller */

	return;
%page;
/* Generate a special acknowledgement message for a message which has been deleted without being "read" */

acknowledge_for_deletion:
     procedure ();

dcl  code fixed binary (35);

	call determine_acknowledgement_recipient (code);	/* determine who gets the acknowledgement */

	if code = 0 then				/* have the recipient ... */
	     call deliver_acknowledgement ("1"b, code);	/* ... send the non-standard acknowledgement message */

	return;

     end acknowledge_for_deletion;



/* Delete any and all Acknowledge-To fields in the message (there should only be one, but...) */

delete_acknowledge_to_fields:
     procedure ();

dcl  idx fixed binary;

	if message.envelope.acknowledge_to ^= null () then
	     call mlsys_address_mgr_$decrement_reference_count (message.envelope.acknowledge_to);

	do idx = 1 to message.n_redistributions;
	     if message_redistributions_list.redistributions (idx).acknowledge_to ^= null () then
		call mlsys_address_mgr_$decrement_reference_count (message_redistributions_list.redistributions (idx)
		     .acknowledge_to);
	end;

	return;

     end delete_acknowledge_to_fields;
%page;
/* Determine who is to receive the acknowledgement:  In this implementation, the recipient must have a local mailbox */

determine_acknowledgement_recipient:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

dcl  (acknowledge_to, mte_address) pointer;
dcl  code fixed binary (35);
dcl  address_type fixed binary;
dcl  delivery_by_person_id char (32) var;


	if message.n_redistributions > 0 then do;	/* redistributed: it's in the last Acknowledge-To field */
	     acknowledge_to = message_redistributions_list.redistributions (message.n_redistributions).acknowledge_to;
	     is_redistributed = "1"b;			/* ... we may need to mention this in the message */
	end;
	else do;
	     acknowledge_to = message.envelope.acknowledge_to;
	     is_redistributed = "0"b;
	end;

	if acknowledge_to = null () then do;		/* no Acknowledge-To field(?) */
	     p_code = mlsys_et_$missing_acknowledge_to;
	     return;
	end;

	if message.from -> address_list.n_addresses = 1 then do;
	     multiple_authors = "0"b;			/* only one author */
	     author_is_ack_recipient =
		mlsys_address_mgr_$compare_addresses (acknowledge_to, message.from -> address_list.addresses (1), (0))
		;
	end;
	else do;					/* several authors will affect the message format */
	     multiple_authors = "1"b;
	     author_is_ack_recipient = "0"b;
	end;

	mte_address = null ();			/* for cleanup handler */
	on condition (cleanup)
	     begin;
	     if mte_address ^= null () then call mlsys_address_mgr_$free_address (mte_address, (0));
	end;

	call mlsys_address_mgr_$get_address_type (acknowledge_to, address_type, code);
	if code ^= 0 then call bad_acknowledge_to ();	/* huh? */

	if address_type = MAIL_TABLE_ADDRESS then do;	/* mail-table address: look it up to get the target */
	     call mlsys_address_mgr_$get_mail_table_address (acknowledge_to, mte_address, code);
	     if code ^= 0 then call bad_acknowledge_to ();
	     acknowledge_to = mte_address;		/* ... rest of the procedure uses acknowledge_to value */
	     call mlsys_address_mgr_$get_address_type (acknowledge_to, address_type, code);
	     if code ^= 0 then call bad_acknowledge_to ();

	     if (address_type ^= USER_MAILBOX_ADDRESS) & (address_type ^= LOGBOX_ADDRESS)
		& (address_type ^= SAVEBOX_ADDRESS) & (address_type ^= MAILBOX_ADDRESS) then do;
						/* RL: mail table entry refers to non-mailbox, try using sender_id */
		delivery_by_person_id = rtrim (im_message_info.mra.sender_id);
		if (length (delivery_by_person_id) > 1)
		     & (substr (reverse (delivery_by_person_id), 1, 2) = reverse (".a")) then
		     delivery_by_person_id = substr (delivery_by_person_id, 1, length (delivery_by_person_id) - 2);
						/* RL: remove ".a" suffix for person_id */

		if mte_address ^= null () then call mlsys_address_mgr_$free_address (mte_address, (0));
						/* RL: free old address */
		call mlsys_address_mgr_$create_user_mailbox_address (delivery_by_person_id, "", "", mte_address, code)
		     ;

		if code ^= 0 then call bad_acknowledge_to ();
		address_type = USER_MAILBOX_ADDRESS;
	     end;

	end;

	if (address_type ^= USER_MAILBOX_ADDRESS) & (address_type ^= LOGBOX_ADDRESS)
	     & (address_type ^= SAVEBOX_ADDRESS) & (address_type ^= MAILBOX_ADDRESS) then
	     call bad_acknowledge_to ();		/* the address doesn't reference a mailbox */

	call mlsys_address_mgr_$get_address_pathname (acknowledge_to, mailbox_dirname, mailbox_ename, ((32)" "), code);
	if code ^= 0 then call bad_acknowledge_to ();	/* huh? */

	p_code = 0;				/* success */


RETURN_FROM_DETERMINE_ACKNOWLEDGEMENT_RECIPIENT:
	if mte_address ^= null () then call mlsys_address_mgr_$free_address (mte_address, (0));
	return;



/* Internal to determine_acknowledgement_recipient: returns mlsys_et_$bad_acknowledge_to to our caller */

bad_acknowledge_to:
	procedure ();

	     p_code = mlsys_et_$bad_acknowledge_to;
	     go to RETURN_FROM_DETERMINE_ACKNOWLEDGEMENT_RECIPIENT;

	end bad_acknowledge_to;

     end determine_acknowledgement_recipient;
%page;
/* Deliver the acknowledgement message */

deliver_acknowledgement:
     procedure (p_send_delete_ack, p_code);

dcl  p_send_delete_ack bit (1) aligned parameter;
dcl  p_code fixed binary (35) parameter;

dcl  date_time_string character (64) varying;
dcl  1 date_time_string_fixed aligned based (addr (date_time_string)),
       2 lth fixed binary (21),
       2 text character (64);

dcl  author_string character (256) varying;
dcl  an_author pointer;

dcl  subject character (subject_lth) unaligned based (subject_ptr);
dcl  subject_lth fixed binary (21);
dcl  subject_ptr pointer;
dcl  include_subject bit (1) aligned;

dcl  message_lth fixed binary (21);

/* format: off */

dcl (DELETION_PREFIX	initial ("Deleted, possibly without reading, "),
     READING_PREFIX		initial ("Acknowledging "),
     YOUR_MESSAGE		initial ("your message of "),
     THE_MESSAGE		initial ("the message of "),
     FROM			initial (" from "),
     ET_AL		initial (" et al"),
     FORWARDED_SUFFIX	initial (" which you forwarded"),
     SUBJECT_PREFIX		initial (";  Subject: "))
	character (48) varying static options (constant);
/* format: on */


/* Compute the length of the acknowledgement */

	if p_send_delete_ack then
	     message_lth = length (DELETION_PREFIX);
	else message_lth = length (READING_PREFIX);

	if author_is_ack_recipient then
	     message_lth = message_lth + length (YOUR_MESSAGE);
	else do;
	     message_lth = message_lth + length (THE_MESSAGE) + length (FROM);
	     an_author = message.from -> address_list.addresses (1);
	     call mlsys_misc_utils_$get_best_address_name (an_author, author_string, p_code);
	     if p_code ^= 0 then do;			/* fatal error */
		p_code = mlsys_et_$cant_send_acknowledgement;
		return;
	     end;
	     message_lth = message_lth + length (author_string);
	     if multiple_authors then message_lth = message_lth + length (ET_AL);
	end;

	if is_redistributed then			/* see if we should mention it was forwarded ... */
	     if ^author_is_ack_recipient then message_lth = message_lth + length (FORWARDED_SUFFIX);

	date_time_string_fixed.lth = 0;		/* this is an input/output parameter */
	call mlsys_format_$format_date_time_field ("", message.date_time_created, "0"b, -1,
	     addr (date_time_string_fixed.text), maxlength (date_time_string), date_time_string_fixed.lth, (0));
	message_lth = message_lth + length (date_time_string);

	if length (message_subject) > 0 then do;	/* there's a subject to be included */
	     include_subject = "1"b;
	     subject_ptr = message.subject.text_ptr;
	     subject_lth = message.subject.text_lth;	/* ... guarenteed to be only one line */
	end;

	else if message.interactive & (message.total_lines > 0) then
	     if message.body_sections (1).section_type = MESSAGE_PREFORMATTED_BODY_SECTION then do;
		include_subject = "1"b;		/* interactive: use first line of text as "subject" */
		message_body_section_ptr = addr (message.body_sections (1));
		subject_ptr = addr (message_preformatted_body_section_text);
		subject_lth = index (message_preformatted_body_section_text, NL) - 1;
		if subject_lth = -1 then subject_lth = length (message_preformatted_body_section_text);
	     end;
	     else include_subject = "0"b;		/* interactive but not composed of text */

	else include_subject = "0"b;			/* nothing to be used the subject */

	if include_subject then message_lth = message_lth + length (SUBJECT_PREFIX) + subject_lth;


/* Construct the acknowledgement */

	begin;

dcl  1 ack_message aligned,				/* use a mail_format style message */
       2 header like mail_format.header,
       2 text character (message_lth);
dcl  text_used fixed binary (21);

dcl  1 wakeup_switches aligned,			/* control switches for mailbox_$wakeup_add_index */
       2 normal_wakeup bit (1) unaligned,		/* ON => send a normal wakeup */
       2 urgent_wakeup bit (1) unaligned,		/* ON => send an urgent wakeup (requires "u" access) */
       2 always_add bit (1) unaligned,			/* ON => always add the message even if wakeup fails */
       2 never_add bit (1) unaligned,			/* ON => never add the message; test if wakeup can be sent */
       2 pad bit (32) unaligned;

	     text_used = 0;				/* nothing in the acknowledgement yet */

	     if p_send_delete_ack then		/* either "Acknowledging" or "Deleted without reading" */
		call add_to_text (DELETION_PREFIX);
	     else call add_to_text (READING_PREFIX);

	     if author_is_ack_recipient then		/* either "your message of" or "the message of" */
		call add_to_text (YOUR_MESSAGE);
	     else call add_to_text (THE_MESSAGE);

	     call add_to_text (date_time_string);

	     if ^author_is_ack_recipient then do;
		call add_to_text (FROM);
		call add_to_text (author_string);
		if multiple_authors then call add_to_text (ET_AL);
	     end;

	     if is_redistributed then			/* see if we should mention it was forwarded ... */
		if ^author_is_ack_recipient then call add_to_text (FORWARDED_SUFFIX);

	     if include_subject then do;
		call add_to_text (SUBJECT_PREFIX);
		substr (ack_message.text, (text_used + 1), subject_lth) = subject;
		text_used = text_used + subject_lth;
	     end;


/* Attempt to send the acknowledgement */

	     ack_message.version = MAIL_FORMAT_VERSION_4;
	     ack_message.sent_from = "";
	     ack_message.lines = 1;			/* guaranteed */
	     ack_message.text_len = text_used;

	     unspec (ack_message.switches) = "0"b;
	     ack_message.wakeup = "1"b;		/* acknowledgements are interactive */

	     mailbox_idx = 0;			/* for cleanup handler */

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

	     on condition (record_quota_overflow)
		begin;				/* no room in the mailbox */
		p_code = mlsys_et_$cant_send_acknowledgement;
		go to CLOSE_THE_ACK_MAILBOX;
	     end;

	     call mailbox_$open (mailbox_dirname, mailbox_ename, mailbox_idx, p_code);

	     if p_code = 0 then do;			/* have the mailbox */
		string (wakeup_switches) = ""b;
		wakeup_switches.normal_wakeup = "1"b;	/* ... send a normal wakeup (if possible) ... */
		wakeup_switches.always_add = "1"b;	/* ... and always leave it in the mailbox */
		call mailbox_$wakeup_add_index (mailbox_idx, addr (ack_message),
		     (36 * currentsize (ack_message) - 9 * (message_lth - text_used)), string (wakeup_switches),
		     ((72)"0"b), p_code);
		if (p_code = error_table_$wakeup_denied) | (p_code = error_table_$messages_deferred)
		     | (p_code = error_table_$messages_off) | (p_code = error_table_$no_info) then
		     p_code = 0;
		if p_code ^= 0 then p_code = mlsys_et_$cant_send_acknowledgement;
CLOSE_THE_ACK_MAILBOX:
		call mailbox_$close (mailbox_idx, (0));
		mailbox_idx = 0;			/* ... be sure to close the mailbox anwyay */
	     end;

	     else p_code = mlsys_et_$cant_send_acknowledgement;


/* Internal to deliver_acknowledgement begin block: add a piece of text to the message */

add_to_text:
     procedure (p_string);

dcl  p_string character (*) varying parameter;

	substr (ack_message.text, (text_used + 1), length (p_string)) = p_string;
	text_used = text_used + length (p_string);

	return;

     end add_to_text;

	end;

	return;

     end deliver_acknowledgement;
%page;
/* Verify that the caller supplied a pointer to a properly constructed mailbox structure */

verify_mailbox:
     procedure () returns (bit (1) aligned);

	if mailbox_ptr = null () then return ("0"b);

	if ^mlsys_data_$valid_segments (binary (baseno (mailbox_ptr), 18, 0)) then return ("0"b);
						/* supplied structure wasn't allocated by us */

	if mailbox.version ^= MAILBOX_VERSION_2 then	/* supplied structure isn't a mailbox structure */
	     return ("0"b);

	return ("1"b);				/* supplied mailbox structure passes */

     end verify_mailbox;



/* Add the specified suffix to an entryname if possible */

add_suffix:
     procedure (p_ename, p_suffix, p_new_ename, p_code);

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

dcl  (trimmed_ename, trimmed_suffix) character (33) varying;

	trimmed_ename = rtrim (p_ename);
	trimmed_suffix = "." || rtrim (p_suffix);

	if length (trimmed_ename) > length (p_new_ename) then do;
	     p_code = error_table_$entlong;
	     return;
	end;

	if length (trimmed_ename) > length (trimmed_suffix) then
						/* original name has room for the suffix */
	     if substr (trimmed_ename, (length (trimmed_ename) - length (trimmed_suffix) + 1)) = trimmed_suffix then
		;				/* proper suffix is already present */
	     else trimmed_ename = trimmed_ename || trimmed_suffix;
	else trimmed_ename = trimmed_ename || trimmed_suffix;

	p_new_ename = trimmed_ename;			/* return it */

	if length (trimmed_ename) <= length (p_new_ename) then
	     p_code = 0;				/* it fit */
	else p_code = error_table_$entlong;		/* sorry */

	return;

     end add_suffix;
%page;
/* Classify a message: determines the format (FIPS98, mail_format, unknown) and type (ordinary, interactive) */

classify_message:
     procedure (p_message_ptr, p_message_lth, p_message_format, p_message_type);

dcl  p_message_ptr pointer parameter;
dcl  p_message_lth fixed binary (24) parameter;
dcl  (p_message_format, p_message_type) fixed binary;

	fips98_message_ptr, mail_format_ptr = p_message_ptr;
						/* allow following references to work OK */

	if fips98_message.version = FIPS98_MESSAGE_VERSION_1 then do;
	     p_message_format = FIPS98_FORMAT_MESSAGE;
	     if fips98_message.interactive then
		p_message_type = INTERACTIVE_MESSAGES;
	     else p_message_type = ORDINARY_MESSAGES;
	end;

	else if ((mail_format.version = MAIL_FORMAT_VERSION_2) | (mail_format.version = MAIL_FORMAT_VERSION_3)
	     | (mail_format.version = MAIL_FORMAT_VERSION_4)) & (mail_format.lines <= mail_format.text_len) then do;
	     p_message_format = MAIL_FORMAT_MESSAGE;
	     if mail_format.wakeup | mail_format.urgent | mail_format.notify then
		p_message_type = INTERACTIVE_MESSAGES;
	     else p_message_type = ORDINARY_MESSAGES;
	end;

	else do;					/* not recognizable */
	     p_message_format = UNKNOWN_FORMAT_MESSAGE;
	     p_message_type = ORDINARY_MESSAGES;	/* ... as we don't know where to look in the message */
	end;

	return;

     end classify_message;



/* Returns "1"b if a message's sender_id (from ring-1) matches the criteria for "own" messages */

message_from_self:
     procedure (p_sender_id) returns (bit (1) aligned);

dcl  p_sender_id character (32) parameter;

	if before (p_sender_id, ".") = "anonymous" then	/* for anonymous users, project is important */
	     return (substr (p_sender_id, 1, length (rtrim (p_sender_id)) - 2) = mlsys_data_$user_id);

	else return (before (p_sender_id, ".") = mlsys_data_$person_id);

     end message_from_self;
%page;
/* Read the next message from a mailbox */

read_next_message:
     procedure ();

dcl  retry_count fixed binary;
dcl  retried bit (1) aligned;

	im_message_info_ptr = find_next_message_block_slot ();
	mra_ptr = addr (im_message_info.mra);		/* a place to store the data */

	mailbox_message_area_ptr = find_mailbox_message_area ("0"b);
						/* a place to allocate the mail_format */

	retry_count = 1;				/* may retry because of mailbox salvaging or ... */
	retried = "0"b;				/* ... another program closing the mailbox too many times */


/* Try to read the message */

RETRY_READ_MESSAGE:
	if mailbox_info.last_message_key = ""b then	/* read the first message ... */
	     if mailbox_info.use_own_mode then		/* ... from ourselves */
		call mailbox_$own_read_index (mailbox_info.index, addr (mailbox_message_area.area), "0"b, mra_ptr,
		     code);
	     else					/* ... in the mailbox period */
		call mailbox_$read_index (mailbox_info.index, addr (mailbox_message_area.area), "0"b, mra_ptr, code);

	else					/* read the next message ... */
	     if mailbox_info.use_own_mode then		/* ... from ourselves */
	     call mailbox_$own_incremental_read_index (mailbox_info.index, addr (mailbox_message_area.area), "01"b,
		mailbox_info.last_message_key, mra_ptr, code);
	else					/* ... in the mailbox period */
	     call mailbox_$incremental_read_index (mailbox_info.index, addr (mailbox_message_area.area),
		"01"b /* next forward */, mailbox_info.last_message_key, mra_ptr, code);

	if code ^= 0 then				/* something went wrong ... */
	     if code = error_table_$noalloc then	/* ... message won't fit in current area */
		if mailbox_message_area.virgin_area then
		     go to CANT_READ_MESSAGE;		/* ... already tried empty area: can't ever read it */
		else do;				/* ... try again with an empty area */
		     mailbox_message_area_ptr = find_mailbox_message_area ("1"b);
		     go to RETRY_READ_MESSAGE;
		end;

	     else if code = error_table_$bad_segment then do;
		mailbox_info.flags.salvaged = "1"b;	/* ... mailbox was salvaged */
		retry_count = retry_count + 1;
		if retry_count > mlsys_data_$max_opening_retries then go to CANT_READ_MESSAGE;
						/* mailbox seems permanently damaged */
		call mailbox_$close (mailbox_info.index, (0));
		mailbox_info.index = 0;		/* in case following open call fails ... */
		call mailbox_$open (mailbox_info.dirname, mailbox_info.ename, mailbox_info.index, code);
		if code = 0 then			/* it opened again OK: try reading again */
		     go to RETRY_READ_MESSAGE;
		else go to CANT_READ_MESSAGE;
	     end;

	     else if code = error_table_$seg_unknown then do;
						/* ... some other buggy program closed mailbox too often */
		if retried then go to CANT_READ_MESSAGE;/* one try at this one, please ... */
		retried = "1"b;
		call mailbox_$close (mailbox_info.index, (0));
		mailbox_info.index = 0;		/* in case the open fails ... */
		call mailbox_$open (mailbox_info.dirname, mailbox_info.ename, mailbox_info.index, code);
		if code = 0 then			/* mailbox opened OK: try again */
		     go to RETRY_READ_MESSAGE;
		else go to CANT_READ_MESSAGE;		/* something is really amiss */
	     end;

	     else go to CANT_READ_MESSAGE;		/* ... anything else is fatal */


/* Message has been successfully read */

	im_message_info.area_ptr = addr (mailbox_message_area.area);
	im_message_info.mailbox_info_ptr = mailbox_info_ptr;
	im_message_info.key = im_message_info.mra.ms_id;
	call classify_message (im_message_info.mra.ms_ptr, im_message_info.mra.ms_len, im_message_info.format,
	     im_message_info.type);
	string (im_message_info.flags) = ""b;
	im_message_info.flags.mra_valid = "1"b;		/* have data from ring-1 */

	if im_message_info.format = MAIL_FORMAT_MESSAGE then
	     if im_message_info.mra.ms_len <= 36 * currentsize (mail_format) then do;
		/*** Ring-1 message isn't long enough to hold the mf_extension structure:  The message must be treated
		     as a non-canonical message; otherwise, retransmission of the message would fail horribly */
		mail_format.obsolete = mail_format.obsolete | mail_format.canonical;
		mail_format.canonical = "0"b;
	     end;

	im_message_info.flags.can_be_deleted =		/* determine if the user can delete this message */
	     (mailbox_info.ring1_privilege | aim_check_$equal (im_message_info.mra.access_class, get_authorization_ ()))
	     & (mailbox_info.mode_flags.delete
	     | (message_from_self (im_message_info.mra.sender_id) & mailbox_info.mode_flags.own));

	if im_message_info.format = FIPS98_FORMAT_MESSAGE then
	     im_message_info.flags.requests_acknowledgement = fips98_message.acknowledge;
	else if im_message_info.format = MAIL_FORMAT_MESSAGE then
	     im_message_info.flags.requests_acknowledgement = mail_format.acknowledge;
	else /*** if im_message_info.format = UNKNOWN_FORMAT_MESSAGE then */
	     im_message_info.flags.requests_acknowledgement = "0"b;

	im_message_info.flags.requests_acknowledgement =	/* only allow acknowledgements if user "owns" the mailbox */
	     im_message_info.flags.requests_acknowledgement & mailbox_info.mode_flags.delete
	     & aim_check_$equal (im_message_info.mra.access_class, get_authorization_ ());

	im_message_info.message_ptr = null ();		/* no user-visible data yet */

	mailbox_info.last_message_key = im_message_info.key;
						/* next call will do incremental read */
	mailbox_message_area.virgin_area = "0"b;	/* something's there now */

	code = 0;					/* indicate success to caller */

	return;


/* Fatal errors during reading transfer here */

CANT_READ_MESSAGE:
	message_block.n_used = message_block.n_used - 1;	/* back to before this message */
	return;
%page;
/* Internal to read_next_message: finds the next available im_message_info datum, allocating a new message_block if
   necessary */

find_next_message_block_slot:
	procedure () returns (pointer);

	     message_block_ptr = mailbox_info.message_blocks.last;

	     if message_block_ptr = null () then	/* no previous message blocks */
		call allocate_new_message_block ();
	     else if message_block.n_used = hbound (message_block.messages, 1) then call allocate_new_message_block ();
						/* last message_block is full */

	     message_block.n_used = message_block.n_used + 1;
						/* pick the next one */

	     return (addr (message_block.messages (message_block.n_used)));



allocate_new_message_block:
	     procedure ();

dcl  new_message_block_ptr pointer;

		allocate message_block in (mlsys_area) set (new_message_block_ptr);

		new_message_block_ptr -> message_block.chain = null ();
		new_message_block_ptr -> message_block.n_used = 0;
						/* it's empty */

		if mailbox_info.message_blocks.last = null () then
		     mailbox_info.message_blocks = new_message_block_ptr;
						/* first message_block for this mailbox */

		else do;				/* chain it onto the end */
		     mailbox_info.message_blocks.last -> message_block.chain.next = new_message_block_ptr;
		     new_message_block_ptr -> message_block.chain.previous = mailbox_info.message_blocks.last;
		     mailbox_info.message_blocks.last = new_message_block_ptr;
		end;

		message_block_ptr = new_message_block_ptr;
						/* and it's now the current one */

		return;

	     end allocate_new_message_block;

	end find_next_message_block_slot;
%page;
/* Internal to read_next_message: find an area into which the mail_format for this message is to be read */

find_mailbox_message_area:
	procedure (p_force_new_segment) returns (pointer);

dcl  p_force_new_segment bit (1) aligned parameter;

dcl  1 local_area_info aligned like area_info;
dcl  new_mma_ptr pointer;

	     if p_force_new_segment | (mailbox_info.last_message_area_ptr = null ()) then do;
		call mlsys_storage_mgr_$get_temp_segment (new_mma_ptr, code);
		if code ^= 0 then go to CANT_READ_MESSAGE;
		unspec (local_area_info) = ""b;	/* setup the area: not extensible */
		local_area_info.version = area_info_version_1;
		local_area_info.areap = addr (new_mma_ptr -> mailbox_message_area.area);
		local_area_info.owner = MAIL_SYSTEM_;
		local_area_info.size =
		     sys_info$max_seg_size - binary (rel (addr (new_mma_ptr -> mailbox_message_area.area)), 18);
		call define_area_ (addr (local_area_info), code);
		if code ^= 0 then do;
		     call mlsys_storage_mgr_$release_temp_segment (new_mma_ptr, (0));
		     go to CANT_READ_MESSAGE;
		end;
		new_mma_ptr -> mailbox_message_area.previous = mailbox_info.last_message_area_ptr;
		new_mma_ptr -> mailbox_message_area.virgin_area = "1"b;
						/* not yet used */
		mailbox_info.last_message_area_ptr = new_mma_ptr;
						/* it's the latest one now */
	     end;

	     return (mailbox_info.last_message_area_ptr);

	end find_mailbox_message_area;

     end read_next_message;
%page;
/* Create the user-visible message structure describing the selected message */

construct_user_message:
     procedure ();

dcl  1 local_mbsp aligned like message_body_section_parameter;
dcl  ring_1_delivered_by pointer;
dcl  ring_1_delivered_by_comment character (32) varying;
dcl  ring_1_date_time_delivered fixed binary (71);

	unspec (ring_1_date_time_delivered) = (18)"0"b || substr (im_message_info.key, 19);

	if im_message_info.format = MAIL_FORMAT_MESSAGE then do;
	     mail_format_ptr = im_message_info.mra.ms_ptr;/* there might be a "comment" */
	     if (before (im_message_info.mra.sender_id, ".") ^= mail_format.sent_from)
		& ((mail_format.sent_from ^= "")
		& (mail_format.sent_from ^= copy (NUL, length (mail_format.sent_from)))) then
		ring_1_delivered_by_comment =
		     rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from))));
	     else ring_1_delivered_by_comment = "";
	end;
	else ring_1_delivered_by_comment = "";		/* not for any other format */

	call mlsys_address_mgr_$create_user_mailbox_address
	     ((
	     substr (im_message_info.mra.sender_id, 1, (length (rtrim (im_message_info.mra.sender_id)) - length (".a")))
	     ), "", ring_1_delivered_by_comment, ring_1_delivered_by, (0));
	call mlsys_address_mgr_$increment_reference_count (ring_1_delivered_by);

	if im_message_info.format = FIPS98_FORMAT_MESSAGE then do;
	     fips98_message_ptr = im_message_info.mra.ms_ptr;
	     call mlsys_fips98_$decode_message (fips98_message.data.bytes (*), MESSAGE_VERSION_2, im_message_info_ptr,
		ring_1_delivered_by, ring_1_date_time_delivered, (im_message_info.requests_acknowledgement),
		message_ptr, code);
	     if code ^= 0 then do;			/* couldn't decode it: act like it's a bit string */
		call create_message ();
		local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2;
		message_body_section_ptr = addr (local_mbsp.section);
		message_bit_string_body_section.section_type = MESSAGE_BIT_STRING_BODY_SECTION;
		message_bit_string_body_section.bit_string_ptr = addr (fips98_message.data);
		message_bit_string_body_section.bit_string_lth = 9 * fips98_message.n_bytes;
		call mlsys_message_mgr_$add_body_section_no_copy (message_ptr, addr (local_mbsp), (-1), (0));
	     end;
	end;

	else if im_message_info.format = MAIL_FORMAT_MESSAGE then do;
	     mail_format_ptr = im_message_info.mra.ms_ptr;
	     call mlsys_parse_text_$parse_im_message_text (mail_format.text, MESSAGE_VERSION_2, im_message_info_ptr,
		ring_1_delivered_by, ring_1_date_time_delivered, (im_message_info.requests_acknowledgement),
		(mail_format.canonical | mail_format.obsolete /* formerly "new_quoting" */), message_ptr, code);
	     if code ^= 0 then do;			/* couldn't parse it: act like it has no header */
		call create_message ();
		local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2;
		message_body_section_ptr = addr (local_mbsp.section);
		message_preformatted_body_section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION;
		message_preformatted_body_section.text_ptr = addr (mail_format.text);
		message_preformatted_body_section.text_lth = length (mail_format.text);
		call mlsys_message_mgr_$add_body_section_no_copy (message_ptr, addr (local_mbsp), (-1), (0));
	     end;
	end;

	else do;					/* unknown format: make it all a bit string */
	     call create_message ();
	     local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2;
	     message_body_section_ptr = addr (local_mbsp.section);
	     message_bit_string_body_section.section_type = MESSAGE_BIT_STRING_BODY_SECTION;
	     message_bit_string_body_section.bit_string_ptr = im_message_info.mra.ms_ptr;
	     message_bit_string_body_section.bit_string_lth = im_message_info.mra.ms_len;
	     call mlsys_message_mgr_$add_body_section_no_copy (message_ptr, addr (local_mbsp), (-1), (0));
	end;

	im_message_info.message_ptr = message_ptr;
	message.interactive = (im_message_info.type = INTERACTIVE_MESSAGES);
	message.can_be_deleted = im_message_info.can_be_deleted;
	message.must_be_acknowledged = im_message_info.requests_acknowledgement;
	message.access_class = im_message_info.mra.access_class;

	if im_message_info.format = FIPS98_FORMAT_MESSAGE then
	     message.seen = im_message_info.mra.ms_ptr -> fips98_message.seen;
	else if im_message_info.format = MAIL_FORMAT_MESSAGE then
	     message.seen = im_message_info.mra.ms_ptr -> mail_format.seen;
	else message.seen = "0"b;

	call mlsys_address_mgr_$decrement_reference_count (ring_1_delivered_by);

	return;



/* Internal to construct_user_message: creates the message structure for unknown format or unparseable messages */

create_message:
	procedure ();

	     call mlsys_message_mgr_$create_im_message (MESSAGE_VERSION_2, im_message_info_ptr, message_ptr, (0));

	     message.envelope.date_time_delivered, message.envelope.date_time_mailed, message.header.date_time_created =
		ring_1_date_time_delivered;

	     call mlsys_message_id_mgr_$encode_local_id (ring_1_date_time_delivered, message.message_id);

	     call mlsys_address_list_mgr_$add_address (message.from, ring_1_delivered_by, ADDRESS_LIST_VERSION_2, (0));

	     if im_message_info.requests_acknowledgement then do;
		message.envelope.acknowledge_to = ring_1_delivered_by;
		call mlsys_address_mgr_$increment_reference_count (message.envelope.acknowledge_to);
	     end;

	     return;

	end create_message;

     end construct_user_message;
%page;
/* Recompute user's access to a mailbox and update any information about the mailbox which changes such as which messages
   can be deleted or acknowledged */

/* Note: A change in access may prevent the user from reading desired messages in the future; this problem will be
   detected by the read_new_messages entrypoint */

recompute_mailbox_access:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

dcl  saved_im_message_info_ptr pointer;
dcl  code fixed binary (35);
dcl  retry_count fixed binary;
dcl  retried bit (1) aligned;

dcl  next_message_block_ptr pointer;
dcl  idx fixed binary;

	saved_im_message_info_ptr = im_message_info_ptr;	/* might be needed by calling procedure */

	retry_count = 1;				/* may retry because of mailbox salvaging or ... */
	retried = "0"b;				/* ... another program closing the mailbox too many times */

RETRY_GET_MAILBOX_ACCESS:
	call mailbox_$get_mode_index (mailbox_info.index, mailbox_mode, code);
	if code ^= 0 then				/* something went wrong ... */
	     if code = error_table_$moderr then ;	/* ... user no longer has access to the mailbox */

	     else if code = error_table_$bad_segment then do;
		mailbox_info.flags.salvaged = "1"b;	/* ... mailbox was salvaged */
		retry_count = retry_count + 1;
		if retry_count > mlsys_data_$max_opening_retries then go to CANT_RECOMPUTE_MAILBOX_ACCESS;
						/* mailbox seems permanently damaged */
		call mailbox_$close (mailbox_info.index, (0));
		mailbox_info.index = 0;		/* in case following open call fails ... */
		call mailbox_$open (mailbox_info.dirname, mailbox_info.ename, mailbox_info.index, code);
		if code = 0 then			/* it opened again OK: try to get access again */
		     go to RETRY_GET_MAILBOX_ACCESS;
		else if code = error_table_$moderr then ;
						/* user no longer has access to the mailbox */
		else go to CANT_RECOMPUTE_MAILBOX_ACCESS;
	     end;

	     else if code = error_table_$seg_unknown then do;
						/* ... some other buggy program closed mailbox too often */
		if retried then go to CANT_RECOMPUTE_MAILBOX_ACCESS;
		retried = "1"b;			/* one try at this one, please ... */
		call mailbox_$close (mailbox_info.index, (0));
		mailbox_info.index = 0;		/* in case the open fails ... */
		call mailbox_$open (mailbox_info.dirname, mailbox_info.ename, mailbox_info.index, code);
		if code = 0 then			/* mailbox opened OK: try again */
		     go to RETRY_GET_MAILBOX_ACCESS;
		else if code = error_table_$moderr then ;
						/* user no longer has access */
		else go to CANT_RECOMPUTE_MAILBOX_ACCESS;
	     end;

	     else do;				/* ... anything else is fatal */
CANT_RECOMPUTE_MAILBOX_ACCESS:
		p_code = code;
		return;
	     end;

	if code = error_table_$moderr then mailbox_mode = ""b;
						/* user no longer has any access to the mailbox */

	string (user_privileges) = get_privileges_ ();	/* must also check if ring-1 privilege changed */

	if (string (mailbox_info.mode_flags) = mailbox_mode) & (mailbox_info.ring1_privilege = user_privileges.ring1)
	then do;					/* access hasn't changed */
	     p_code = 0;
	     return;
	end;

	string (mailbox_info.mode_flags) = mailbox_mode;
	if mailbox_info.mailbox_ptr ^= null () then	/* reflect change to user */
	     mailbox_info.mailbox_ptr -> mailbox.mode = mailbox_mode;

	mailbox_info.ring1_privilege = user_privileges.ring1;

	message_idx = 0;				/* index into user-visible structure */

	do message_block_ptr = mailbox_info.message_blocks.first repeat (next_message_block_ptr)
	     while (message_block_ptr ^= null ());
	     next_message_block_ptr = message_block.next;

	     do idx = 1 to message_block.n_used;
		im_message_info_ptr = addr (message_block.messages (idx));

		im_message_info.flags.can_be_deleted =
		     (mailbox_info.ring1_privilege
		     | aim_check_$equal (im_message_info.mra.access_class, get_authorization_ ()))
		     & (mailbox_info.mode_flags.delete
		     | (message_from_self (im_message_info.mra.sender_id) & mailbox_info.mode_flags.own));

		if im_message_info.format = FIPS98_FORMAT_MESSAGE then
		     im_message_info.flags.requests_acknowledgement = fips98_message.acknowledge;
		else if im_message_info.format = MAIL_FORMAT_MESSAGE then
		     im_message_info.flags.requests_acknowledgement = mail_format.acknowledge;
		else /*** if im_message_info.format = UNKNOWN_FORMAT_MESSAGE then */
		     im_message_info.flags.requests_acknowledgement = "0"b;

		im_message_info.flags.requests_acknowledgement =
		     im_message_info.flags.requests_acknowledgement & mailbox_info.mode_flags.delete
		     & aim_check_$equal (im_message_info.mra.access_class, get_authorization_ ());

		if im_message_info.message_ptr ^= null () then do;
		     im_message_info.message_ptr -> message.flags.can_be_deleted =
			im_message_info.flags.can_be_deleted;
		     im_message_info.message_ptr -> message.flags.must_be_acknowledged =
			im_message_info.flags.requests_acknowledgement;
		end;
	     end;
	end;

	im_message_info_ptr = saved_im_message_info_ptr;	/* keep the caller happy */

	p_code = 0;

	return;

     end recompute_mailbox_access;
%page;
/* Release all storage associated with a mailbox and close the mailbox in ring-1 */

release_mailbox_info:
     procedure ();

dcl  (next_message_block_ptr, next_mma_ptr) pointer;
dcl  idx fixed binary;

	if mailbox_info.index ^= 0 then do;		/* there's a mailbox open in ring-1 ... */
	     call mailbox_$close (mailbox_info.index, (0));
	     mailbox_info.index = 0;			/* in case cleanup handler gets called before we're done */
	end;

	if mailbox_info.address_ptr ^= null () then	/* we don't care anymore */
	     call mlsys_address_mgr_$decrement_reference_count (mailbox_info.address_ptr);

	do mailbox_message_area_ptr = mailbox_info.last_message_area_ptr repeat (next_mma_ptr)
	     while (mailbox_message_area_ptr ^= null ());
	     next_mma_ptr = mailbox_message_area.previous;
	     call mlsys_storage_mgr_$release_temp_segment (mailbox_message_area_ptr, (0));
	end;

	if mailbox_info.delete_error_info_ptr ^= null () then do;
	     free mailbox_info.delete_error_info_ptr -> delete_error_info in (mlsys_area);
	     mailbox_info.delete_error_info_ptr = null ();
	end;

	if mailbox_info.mailbox_ptr ^= null () then do;	/* free the user-visible data structure */
	     free mailbox_info.mailbox_ptr -> mailbox in (mlsys_area);
	     mailbox_info.mailbox_ptr = null ();
	end;

	do message_block_ptr = mailbox_info.message_blocks.first repeat (next_message_block_ptr)
	     while (message_block_ptr ^= null ());
	     next_message_block_ptr = message_block.next;
	     do idx = 1 to message_block.n_used;
		im_message_info_ptr = addr (message_block.messages (idx));
		if im_message_info.message_ptr ^= null () then
		     call mlsys_message_mgr_$free_message (im_message_info.message_ptr, (0));
	     end;
	     free message_block in (mlsys_area);
	end;

	free mailbox_info in (mlsys_area);
	mailbox_info_ptr = null ();			/* just to be safe */

	return;

     end release_mailbox_info;
%page;
/* Release all storage associated with any new messages processed by read_new_messages before a fatal error occured */

release_new_mailbox_info:
     procedure ();

dcl  the_area area based;
dcl  next_message_block_ptr pointer;
dcl  (first_idx, idx) fixed binary;

	if n_new_messages > 0 then do;		/* some new messages were read ... */

	     do message_block_ptr = saved_message_block_ptr repeat (next_message_block_ptr)
		while (message_block_ptr ^= null ());
		next_message_block_ptr = message_block.next;

		if message_block_ptr = saved_message_block_ptr then
		     first_idx = saved_message_block_n_used + 1;
		else first_idx = 1;

		do idx = first_idx to message_block.n_used;
		     im_message_info_ptr = addr (message_block.messages (idx));
		     mra_ptr = addr (im_message_info.mra);
		     if mra.ms_ptr ^= null () then do;	/* ... release the message itself */
			free message_bits in (im_message_info.area_ptr -> the_area);
			mra.ms_ptr = null ();
		     end;
		     if im_message_info.message_ptr ^= null () then
			call mlsys_message_mgr_$free_message (im_message_info.message_ptr, (0));
		end;				/* ... release any user visible structures */

		if message_block_ptr ^= saved_message_block_ptr then free message_block in (mlsys_area);
	     end;

	     mailbox_info.message_blocks.last = saved_message_block_ptr;
	     saved_message_block_ptr -> message_block.next = null ();
	     saved_message_block_ptr -> message_block.n_used = saved_message_block_n_used;

	     n_new_messages = 0;			/* done with that part */
	end;

	if new_mailbox_ptr ^= null () then do;		/* started to create new mailbox ... */
	     if new_mailbox_ptr ^= mailbox_ptr then	/* ... it was different */
		free new_mailbox_ptr -> mailbox in (mlsys_area);
	     new_mailbox_ptr = null ();
	end;

	return;

     end release_new_mailbox_info;
%page;
%include mlsys_copy_ptr;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_mailbox_modes;
%page;
%include mlsys_open_options;
%page;
%include mlsys_close_options;
%page;
%include mlsys_delete_error_info;
%page;
%include mlsys_internal_data;
%page;
%include mlsys_fips98_message;
%page;
%include mail_format;
%page;
%include mseg_return_args;
%page;
%include mlsys_message;
%page;
%include mlsys_address_list;
%page;
%include mlsys_address_types;
%page;
%include aim_template;
%page;
%include area_info;
%page;
%include rdm_switch_types;
%page;
%include sub_err_flags;

     end mlsys_mailbox_mgr_;




		    mlsys_mailbox_utils_.pl1        08/06/87  1024.8rew 08/06/87  1021.7      212841



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



/****^  HISTORY COMMENTS:
  1) change(83-07-01,Palter), approve(), audit(), install():
     Created:  July 1983 by G. Palter.
  2) change(86-10-31,Lippard), approve(86-11-24,MCR7578),
     audit(87-07-13,Dickson), install(87-08-06,MR12.1-1067):
     Modified to use error_table_$bad_file_name instead of $badstar.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Mail System Utilities related to mailbox management */

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


mlsys_mailbox_utils_:
     procedure ();

	return;					/* not an entrypoint */


/* Common Parameters */

dcl  P_code fixed binary (35) parameter;

dcl  P_mailbox_dirname character (*) parameter;		/* pathname of the directory containing a mailbox */
dcl  P_mailbox_ename character (*) parameter;		/* entryname of the mailbox (suffix optional) */

dcl  P_mailbox_acl_ptr pointer parameter;		/* -> a mailbox_acl structure */


/* list_mailbox_acl Parameters */

dcl  P_area_ptr pointer parameter;			/* -> area where we'll allocate results */
dcl  P_mailbox_acl_version character (8) parameter;	/* version of mailbox_acl structure desired */


/* classify_mailbox_address Parameters */

dcl  P_mailbox_address_ptr pointer parameter;		/* -> the mailbox address to classify */
dcl  P_mailbox_type fixed binary parameter;		/* set to the type of mailbox at the address */


/* delete_mailbox Parameters */

dcl  P_command_name character (*) parameter;		/* name to be used in calls to command_query_ */
dcl  P_delete_mailbox_options_ptr pointer parameter;	/* -> options which control when to delete the mailbox */


/* Local copies of parameters */

dcl  code fixed binary (35);

dcl  mailbox_dirname character (168);
dcl  mailbox_ename character (32);

dcl  the_area area based (the_area_ptr);
dcl  the_area_ptr pointer;


/* Remaining declarations */

dcl  1 listed_acl (mailbox_acl_n_acl_terms) aligned based (listed_acl_ptr) like segment_acl_entry;
dcl  listed_acl_ptr pointer;

dcl  1 local_ma aligned,				/* for setting newly created mailbox ACLs */
       2 header like mailbox_acl.header,
       2 acl_terms (3) like mailbox_acl.acl_terms;

dcl  idx fixed binary;

dcl  addresses_match bit (1) aligned;
dcl  try_to_delete bit (1);

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

/* format: off */
dcl (error_table_$action_not_performed, error_table_$bad_subr_arg, error_table_$bad_file_name, error_table_$entlong,
     error_table_$link, error_table_$moderr, error_table_$noalloc, error_table_$noentry, error_table_$not_seg_type,
     error_table_$safety_sw_on, error_table_$unimplemented_version, mlsys_et_$mailbox_exists, mlsys_et_$no_mailbox,
     mlsys_et_$not_mailbox)
	fixed binary (35) external;
/* format: on */

dcl  command_query_$yes_no entry () options (variable);
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$get_link_target entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  mail_system_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mail_system_$get_address_pathname entry (pointer, character (*), character (*), character (*), fixed binary (35));
dcl  mailbox_$close entry (fixed binary, fixed binary (35));
dcl  mailbox_$create entry (character (*), character (*), fixed binary (35));
dcl  mailbox_$delete entry (character (*), character (*), fixed binary (35));
dcl  mailbox_$mbx_acl_add entry (character (*), character (*), pointer, fixed binary, fixed binary (35));
dcl  mailbox_$mbx_acl_delete entry (character (*), character (*), pointer, fixed binary, fixed binary (35));
dcl  mailbox_$mbx_acl_list entry (character (*), character (*), pointer, fixed binary, pointer, fixed binary (35));
dcl  mailbox_$mbx_acl_replace entry (character (*), character (*), pointer, fixed binary, fixed binary (35));
dcl  mailbox_$open entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  mailbox_$set_safety_switch entry (character (*), character (*), bit (1) aligned, fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));

dcl  (area, cleanup) condition;

dcl  (addr, index, length, max, null, reverse, rtrim, substr) builtin;
%page;
/* Create the user's default mailbox (>udd>Project_id>Person_id>Person_id.mbx) if it doesn't already exist */

create_default_mailbox:
     entry (P_code);

	call mail_system_$get_address_pathname (mlsys_data_$user_default_mailbox_address, mailbox_dirname,
	     mailbox_ename, ((32)" "), (0));		/* default mailbox pathname has to be OK */

	if mailbox_already_exists (mailbox_dirname, mailbox_ename, code) then code = mlsys_et_$mailbox_exists;
						/* like it says: it's already there */

	else if code = error_table_$noentry then do;	/* not there: try to create it */
	     call mailbox_$create (mailbox_dirname, mailbox_ename, code);
	     if code = 0 then do;			/* created it! */
		local_ma.version = MAILBOX_ACL_VERSION_1;
		local_ma.n_acl_terms = 3;
		if mlsys_data_$user_is_anonymous then	/* ... special case the user ID */
		     local_ma.acl_terms (1).access_name = ANONYMOUS || "." || mlsys_data_$project_id || ".*";
		else local_ma.acl_terms (1).access_name = mlsys_data_$person_id || ".*.*";
		local_ma.acl_terms (1).extended_mode = ADROSW_MBX_ACCESS;
		local_ma.acl_terms (2).access_name = "*.SysDaemon.*";
		local_ma.acl_terms (3).access_name = "*.*.*";
		local_ma.acl_terms (2).extended_mode, local_ma.acl_terms (3).extended_mode = AOW_MBX_ACCESS;
		call replace_mailbox_acl_entries (mailbox_dirname, mailbox_ename, addr (local_ma), code);
	     end;
	end;

	P_code = code;				/* let the caller know what happened */

	return;
%page;
/* Create the user's logbox (>udd>Project_id>Person_id>Person_id.mbx) if it doesn't already exist */

create_logbox:
     entry (P_code);

	call mail_system_$get_address_pathname (mlsys_data_$user_logbox_address, mailbox_dirname, mailbox_ename,
	     ((32)" "), (0));			/* logbox pathname has to be OK */

	if mailbox_already_exists (mailbox_dirname, mailbox_ename, code) then code = mlsys_et_$mailbox_exists;
						/* like it says: it's already there */

	else if code = error_table_$noentry then do;	/* not there: try to create it */
	     call mailbox_$create (mailbox_dirname, mailbox_ename, code);
	     if code = 0 then do;			/* created it! */
		local_ma.version = MAILBOX_ACL_VERSION_1;
		local_ma.n_acl_terms = 1;
		if mlsys_data_$user_is_anonymous then	/* ... special case the user ID */
		     local_ma.acl_terms (1).access_name = ANONYMOUS || "." || mlsys_data_$project_id || ".*";
		else local_ma.acl_terms (1).access_name = mlsys_data_$person_id || ".*.*";
		local_ma.acl_terms (1).extended_mode = ADROSW_MBX_ACCESS;
		call replace_mailbox_acl_entries (mailbox_dirname, mailbox_ename, addr (local_ma), code);
	     end;
	end;

	P_code = code;				/* let the caller know what happened */

	return;
%page;
/* Create one of the user's saveboxes */

create_savebox:
     entry (P_mailbox_dirname, P_mailbox_ename, P_code);

	mailbox_dirname = P_mailbox_dirname;

	if index (reverse (rtrim (P_mailbox_ename)), reverse (".sv")) = 1 then
	     mailbox_ename = substr (P_mailbox_ename, 1, (length (rtrim (P_mailbox_ename)) - length (".sv")));
	else mailbox_ename = P_mailbox_ename;		/* already has right suffix or will be added shortly */
	call add_suffix (mailbox_ename, "sv.mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* can't create proper pathname */

	if mailbox_already_exists (mailbox_dirname, mailbox_ename, code) then code = mlsys_et_$mailbox_exists;
						/* like it says: it's already there */

	else if code = error_table_$noentry then do;	/* not there: try to create it */
	     call mailbox_$create (mailbox_dirname, mailbox_ename, code);
	     if code = 0 then do;			/* created it! */
		local_ma.version = MAILBOX_ACL_VERSION_1;
		local_ma.n_acl_terms = 1;
		if mlsys_data_$user_is_anonymous then	/* ... special case the user ID */
		     local_ma.acl_terms (1).access_name = ANONYMOUS || "." || mlsys_data_$project_id || ".*";
		else local_ma.acl_terms (1).access_name = mlsys_data_$person_id || ".*.*";
		local_ma.acl_terms (1).extended_mode = ADROSW_MBX_ACCESS;
		call replace_mailbox_acl_entries (mailbox_dirname, mailbox_ename, addr (local_ma), code);
	     end;
	end;

	P_code = code;				/* let caller know what happened */

	return;
%page;
/* Create an arbitrary mailbox */

create_mailbox:
     entry (P_mailbox_dirname, P_mailbox_ename, P_code);

	mailbox_dirname = P_mailbox_dirname;
	call add_suffix (P_mailbox_ename, "mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* can't create proper pathname */

	if mailbox_already_exists (mailbox_dirname, mailbox_ename, code) then code = mlsys_et_$mailbox_exists;
						/* like it says: it's already there */

	else if code = error_table_$noentry then do;	/* not there: try to create it */
	     call mailbox_$create (mailbox_dirname, mailbox_ename, code);
	     if code = 0 then do;			/* created it! */
		local_ma.version = MAILBOX_ACL_VERSION_1;
		local_ma.n_acl_terms = 3;
		if mlsys_data_$user_is_anonymous then	/* ... special case the user ID */
		     local_ma.acl_terms (1).access_name = ANONYMOUS || "." || mlsys_data_$project_id || ".*";
		else local_ma.acl_terms (1).access_name = mlsys_data_$person_id || ".*.*";
		local_ma.acl_terms (1).extended_mode = ADROSW_MBX_ACCESS;
		local_ma.acl_terms (2).access_name = "*.SysDaemon.*";
		local_ma.acl_terms (3).access_name = "*.*.*";
		local_ma.acl_terms (2).extended_mode, local_ma.acl_terms (3).extended_mode = AOW_MBX_ACCESS;
		call replace_mailbox_acl_entries (mailbox_dirname, mailbox_ename, addr (local_ma), code);
	     end;
	end;

	P_code = code;				/* let caller know what happened */

	return;
%page;
/* Add the specified entries to the ACL of a mailbox:  A simpler interface than mailbox_$mbx_acl_add */

add_mailbox_acl_entries:
     entry (P_mailbox_dirname, P_mailbox_ename, P_mailbox_acl_ptr, P_code);

	mailbox_dirname = P_mailbox_dirname;
	call add_suffix (P_mailbox_ename, "mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* bad entryname */

	mailbox_acl_ptr = P_mailbox_acl_ptr;
	if mailbox_acl.version ^= MAILBOX_ACL_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if mailbox_acl.n_acl_terms < 1 then do;		/* must add at least one term */
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	begin;					/* must make a slightly different copy of the ACL structure */

dcl  1 mbx_acl_array (mailbox_acl.n_acl_terms) aligned like segment_acl_entry;

	     do idx = 1 to mailbox_acl.n_acl_terms;
		mbx_acl_array (idx).access_name = mailbox_acl.acl_terms (idx).access_name;
		mbx_acl_array (idx).mode = RW_ACCESS;	/* caller doesn't supply this ... */
		mbx_acl_array (idx).extended_mode = mailbox_acl.acl_terms (idx).extended_mode;
	     end;

	     call mailbox_$mbx_acl_add (mailbox_dirname, mailbox_ename, addr (mbx_acl_array), mailbox_acl.n_acl_terms,
		code);

	     do idx = 1 to mailbox_acl.n_acl_terms;
		mailbox_acl.acl_terms (idx).code = mbx_acl_array (idx).status_code;
	     end;
	end;

	P_code = code;				/* global result */

	return;
%page;
/* Delete the specified entries from the ACL of a mailbox:  A simpler interface than mailbox_$mbx_acl_delete */

delete_mailbox_acl_entries:
     entry (P_mailbox_dirname, P_mailbox_ename, P_mailbox_acl_ptr, P_code);

	mailbox_dirname = P_mailbox_dirname;
	call add_suffix (P_mailbox_ename, "mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* bad entryname */

	mailbox_acl_ptr = P_mailbox_acl_ptr;
	if mailbox_acl.version ^= MAILBOX_ACL_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if mailbox_acl.n_acl_terms < 1 then do;		/* must delete at least one term */
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	begin;					/* must make a slightly different copy of the ACL structure */

dcl  1 mbx_acl_array (mailbox_acl.n_acl_terms) aligned like segment_acl_entry;

	     do idx = 1 to mailbox_acl.n_acl_terms;
		mbx_acl_array (idx).access_name = mailbox_acl.acl_terms (idx).access_name;
	     end;					/* mode fields are ignored */

	     call mailbox_$mbx_acl_delete (mailbox_dirname, mailbox_ename, addr (mbx_acl_array),
		mailbox_acl.n_acl_terms, code);

	     do idx = 1 to mailbox_acl.n_acl_terms;
		mailbox_acl.acl_terms (idx).code = mbx_acl_array (idx).status_code;
	     end;
	end;

	P_code = code;				/* global result */

	return;
%page;
/* Replace the ACL of a mailbox:  A simpler interface than mailbox_$mbx_acl_replace */

replace_mailbox_acl_entries:
     entry (P_mailbox_dirname, P_mailbox_ename, P_mailbox_acl_ptr, P_code);

	mailbox_dirname = P_mailbox_dirname;
	call add_suffix (P_mailbox_ename, "mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* bad entryname */

	mailbox_acl_ptr = P_mailbox_acl_ptr;
	if mailbox_acl.version ^= MAILBOX_ACL_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	begin;					/* must make a slightly different copy of the ACL structure */

dcl  1 mbx_acl_array (max (1, mailbox_acl.n_acl_terms)) aligned like segment_acl_entry;
						/* PL/I abhors a vacuum */
dcl  n_replacement_acl_terms fixed binary;

	     do idx = 1 to mailbox_acl.n_acl_terms;
		mbx_acl_array (idx).access_name = mailbox_acl.acl_terms (idx).access_name;
		mbx_acl_array (idx).mode = RW_ACCESS;	/* caller doesn't supply this ... */
		mbx_acl_array (idx).extended_mode = mailbox_acl.acl_terms (idx).extended_mode;
	     end;

	     if mailbox_acl.n_acl_terms = 0 then	/* mailbox_ uses -1 instead of 0 for an empty ACL */
		n_replacement_acl_terms = -1;
	     else n_replacement_acl_terms = mailbox_acl.n_acl_terms;

	     call mailbox_$mbx_acl_replace (mailbox_dirname, mailbox_ename, addr (mbx_acl_array),
		n_replacement_acl_terms, code);

	     do idx = 1 to mailbox_acl.n_acl_terms;
		mailbox_acl.acl_terms (idx).code = mbx_acl_array (idx).status_code;
	     end;
	end;

	P_code = code;				/* global result */

	return;
%page;
/* List the ACL of a mailbox:  A simpler interface than mailbox_$mbx_acl_list */

list_mailbox_acl:
     entry (P_mailbox_dirname, P_mailbox_ename, P_area_ptr, P_mailbox_acl_version, P_mailbox_acl_ptr, P_code);

	mailbox_dirname = P_mailbox_dirname;
	call add_suffix (P_mailbox_ename, "mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* bad entryname */

	if P_area_ptr = null () then			/* where to put the listing */
	     the_area_ptr = get_system_free_area_ ();
	else the_area_ptr = P_area_ptr;

	if P_mailbox_acl_version ^= MAILBOX_ACL_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	mailbox_acl_ptr, listed_acl_ptr = null ();	/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if mailbox_acl_ptr ^= null () then free mailbox_acl in (the_area);
		if listed_acl_ptr ^= null () then free listed_acl in (the_area);
	     end;

	on condition (area)
	     begin;				/* something won't fit */
		code = error_table_$noalloc;
		go to ERROR_RETURN_FROM_LIST_MAILBOX_ACL;
	     end;

	call mailbox_$mbx_acl_list (mailbox_dirname, mailbox_ename, listed_acl_ptr, mailbox_acl_n_acl_terms,
	     the_area_ptr, code);

	if code = 0 then do;			/* got something back */
	     allocate mailbox_acl in (the_area) set (mailbox_acl_ptr);
	     mailbox_acl.version = MAILBOX_ACL_VERSION_1;
	     do idx = 1 to mailbox_acl.n_acl_terms;
		mailbox_acl.acl_terms (idx).access_name = listed_acl (idx).access_name;
		mailbox_acl.acl_terms (idx).extended_mode = listed_acl (idx).extended_mode;
		mailbox_acl.acl_terms (idx).code = listed_acl (idx).status_code;
	     end;
	     free listed_acl in (the_area);
	     listed_acl_ptr = null ();
	     P_mailbox_acl_ptr = mailbox_acl_ptr;	/* ... don't set output parameter unless we got something */
	end;

	P_code = code;				/* global result */

	return;


/* Control arrives here iff it wasn't possible to allocate the ACL in the caller's area */

ERROR_RETURN_FROM_LIST_MAILBOX_ACL:
	if mailbox_acl_ptr ^= null () then free mailbox_acl in (the_area);
	if listed_acl_ptr ^= null () then free listed_acl in (the_area);

	P_code = code;

	return;
%page;
/* Determine the type of a mailbox (user's default/logbox/savebox/other) given the address of the mailbox */

classify_mailbox_address:
     entry (P_mailbox_address_ptr, P_mailbox_type, P_code);

	addresses_match =				/* is it our default mailbox? */
	     mail_system_$compare_addresses (P_mailbox_address_ptr, mlsys_data_$user_default_mailbox_address, code);
	if code ^= 0 then do;			/* something's wrong (with the address probably) */
CANT_CLASSIFY_THE_MAILBOX:
	     P_code = code;
	     return;
	end;

	if addresses_match then			/* yes, it is */
	     P_mailbox_type = USER_DEFAULT_MAILBOX;

	else do;					/* no: is it the user's logbox */
	     addresses_match =
		mail_system_$compare_addresses (P_mailbox_address_ptr, mlsys_data_$user_logbox_address, code);
	     if code ^= 0 then go to CANT_CLASSIFY_THE_MAILBOX;

	     if addresses_match then
		P_mailbox_type = USER_LOGBOX;

	     else do;				/* no: either savebox/ordinary depending on suffix */
		call mail_system_$get_address_pathname (P_mailbox_address_ptr, ((168)" "), mailbox_ename, ((32)" "),
		     code);
		if code ^= 0 then go to CANT_CLASSIFY_THE_MAILBOX;

		if index (reverse (rtrim (mailbox_ename)), reverse (".sv.mbx")) = 1 then
		     P_mailbox_type = SAVEBOX;
		else P_mailbox_type = OTHER_MAILBOX;
	     end;
	end;

	P_code = 0;				/* here iff we succeeded */

	return;
%page;
/* Delete the specified mailbox:  If the mailbox is protected by its safety switch, this entrypoint will query the user
   for permission to delete the mailbox at the caller's request */

delete_mailbox:
     entry (P_mailbox_dirname, P_mailbox_ename, P_command_name, P_delete_mailbox_options_ptr, P_code);

	mailbox_dirname = P_mailbox_dirname;
	call add_suffix (P_mailbox_ename, "mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* can't create proper pathname */

	delete_mailbox_options_ptr = P_delete_mailbox_options_ptr;
	if delete_mailbox_options.version ^= DELETE_MAILBOX_OPTIONS_VERSION_1 then
	     call return_from_delete_mailbox (error_table_$unimplemented_version);
	if delete_mailbox_options.mbz ^= ""b then call return_from_delete_mailbox (error_table_$bad_subr_arg);


/* Try to delete the mailbox: chase links if necessary */

RETRY_MAILBOX_DELETE_CALL:
	call mailbox_$delete (mailbox_dirname, mailbox_ename, code);

	if (code = error_table_$bad_file_name) | (code = error_table_$not_seg_type) then
	     call return_from_delete_mailbox (mlsys_et_$not_mailbox);

	else if code = error_table_$link then		/* the pathname supplied is that of a link ... */
	     if delete_mailbox_options.chase then do;	/* ... but that's OK: try to delete the target */
		call hcs_$get_link_target (mailbox_dirname, mailbox_ename, mailbox_dirname, mailbox_ename, code);
		if code ^= 0 then call return_from_delete_mailbox (code);
		go to RETRY_MAILBOX_DELETE_CALL;
	     end;
	     else call return_from_delete_mailbox (error_table_$link);


/* Safety switch processing */

	if code = error_table_$safety_sw_on then
	     if delete_mailbox_options.force then do;	/* turn of the safety switch (if possible) and try again... */
		call mailbox_$set_safety_switch (mailbox_dirname, mailbox_ename, "0"b, code);
		if code ^= 0 then call return_from_delete_mailbox (code);
		go to RETRY_MAILBOX_DELETE_CALL;
	     end;

	     else if delete_mailbox_options.query then do;/* ask the user's permission to delete it */
		call command_query_$yes_no (try_to_delete, 0, P_command_name, "",
		     "^a is protected by safety switch.  Do you want to delete it?",
		     pathname_ (mailbox_dirname, mailbox_ename));
		if try_to_delete then do;		/* ... user said it's OK to try ... */
		     call mailbox_$set_safety_switch (mailbox_dirname, mailbox_ename, "0"b, code);
		     if code ^= 0 then call return_from_delete_mailbox (code);
		     go to RETRY_MAILBOX_DELETE_CALL;
		end;
		else call return_from_delete_mailbox (error_table_$action_not_performed);
	     end;					/* ... inform caller that the user denied permission */

	     else call return_from_delete_mailbox (error_table_$safety_sw_on);


/* Inform the caller of the success/failure of the deletion */

	if code = error_table_$noentry then		/* we never return this code ... */
	     call return_from_delete_mailbox (mlsys_et_$no_mailbox);
	else call return_from_delete_mailbox (code);



/* Returns from the delete_mailbox entrypoint with the specified status code */

return_from_delete_mailbox:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	P_code = p_code;				/* set the caller's status code */
	go to RETURN_FROM_DELETE_MAILBOX;

     end return_from_delete_mailbox;

RETURN_FROM_DELETE_MAILBOX:
	return;
%page;
/* Add the specified suffix to an entryname if possible */

add_suffix:
     procedure (p_ename, p_suffix, p_new_ename, p_code);

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

dcl  (trimmed_ename, trimmed_suffix) character (33) varying;

	if length (rtrim (p_ename)) > length (p_new_ename) then do;
	     p_code = error_table_$entlong;
	     return;
	end;

	trimmed_ename = rtrim (p_ename);
	trimmed_suffix = "." || rtrim (p_suffix);

	if length (trimmed_ename) > length (trimmed_suffix) then
						/* original name has room for the suffix */
	     if substr (trimmed_ename, (length (trimmed_ename) - length (trimmed_suffix) + 1)) = trimmed_suffix then
		;				/* proper suffix is already present */
	     else trimmed_ename = trimmed_ename || trimmed_suffix;
	else trimmed_ename = trimmed_ename || trimmed_suffix;

	p_new_ename = trimmed_ename;			/* return it */

	if length (trimmed_ename) <= length (p_new_ename) then
	     p_code = 0;				/* it fit */
	else p_code = error_table_$entlong;		/* sorry */

	return;

     end add_suffix;
%page;
/* Determines if the specified mailbox already exists */

mailbox_already_exists:
     procedure (p_mailbox_dirname, p_mailbox_ename, p_code) returns (bit (1) aligned);

dcl  p_mailbox_dirname character (*) parameter;
dcl  p_mailbox_ename character (*) parameter;
dcl  p_code fixed binary (35);

dcl  mailbox_index fixed binary;

	mailbox_index = 0;				/* for cleanup handler */

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

	call mailbox_$open (p_mailbox_dirname, p_mailbox_ename, mailbox_index, p_code);
	if p_code = error_table_$moderr then p_code = 0;	/* ... it's there but we don't have access */

	call mailbox_$close (mailbox_index, (0));	/* don't need it open anymore */
	mailbox_index = 0;

	return ((p_code = 0));

     end mailbox_already_exists;
%page;
%include mlsys_data;
%page;
%include mlsys_internal_data;
%page;
%include mlsys_mailbox_acl;
%page;
%include mlsys_delete_mailbox;
%page;
%include acl_structures;
%page;
%include access_mode_values;
%page;
%include mlsys_mailbox_modes;
%page;
%include mlsys_mailbox;

     end mlsys_mailbox_utils_;




		    mlsys_message_id_mgr_.pl1       06/30/86  1410.4r w 06/30/86  1343.4       86670



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

/* format: off */

/* Message-ID management for the Multics Mail System */

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

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


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

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_message_id bit (72) aligned parameter;

dcl  P_message_id_system character (256) varying;		/* encode_foreign_id, encode_psuedo_id: name of system from
						      whence this message ID originated;
						   decode_message_id: set to name of originating system */

dcl  P_clock_reading fixed binary (71) parameter;		/* encode_local_id: the date/time to be encoded;
						   encode_psuedo_id: date/time created of the message */

dcl  P_message_id_text character (*) parameter;		/* encode_foreign_id: the actual Message-ID text */

dcl  P_from_field pointer parameter;			/* encode_psuedo_id: -> the From field of the message */

dcl  P_message_id_string character (*) varying parameter;	/* decode_message_id: set to the text of the ID */
dcl  P_system_is_local bit (1) aligned parameter;		/* decode_message_id: set ON => ID is for the local system */
dcl  P_code fixed binary (35) parameter;		/* decode_message_id only */
/**** format: indcomtxt */


/* Message-ID hash table used to encode text strings purporting to be message unique identifies from other systems */

dcl  1 encoded_message_id aligned,			/* the encoding used in Message-IDs ... */
       2 flags,
         3 hashed_id bit (1) unaligned,			/* ... ON => the ID is encoded in the hash table;
						   OFF => the ID is a local clock reading */
         3 pad bit (35) unaligned,
       2 bucket_idx fixed binary (18) unaligned unsigned,	/* ... in which bucket this ID may be found */
       2 n_steps fixed binary (18) unaligned unsigned;	/* ... # of steps from base of bucket to the ID */

dcl  1 local_encoded_message_id aligned based (addr (encoded_message_id)),
       2 flags,
         3 hashed_id bit (1) unaligned,			/* ... OFF for local IDs */
         3 pad bit (17) unaligned,
         3 clock_reading fixed binary (54) unaligned unsigned;
						/* ... the local clock reading */

dcl  1 message_id_slot aligned based (message_id_slot_ptr), /* a single slot in the hash table ... */
       2 next_slot_ptr pointer,			/* ... -> next slot in the hash table */
       2 system_name character (256) varying,		/* ... name of system that generated this ID */
       2 flags,
         3 local_system bit (1) unaligned,		/* ... ON => it's the local system */
         3 pad bit (35) unaligned,
       2 message_id_lth fixed binary (21),		/* ... length of the ID text in this slot */
       2 message_id character (message_id_slot_message_id_lth refer (message_id_slot.message_id_lth));
dcl  (message_id_slot_ptr, last_message_id_slot_ptr) pointer;
dcl  message_id_slot_message_id_lth fixed binary (21);


/* Remaining declarations */

dcl  n_real_steps fixed binary;

dcl  full_system_name character (256) varying;

dcl  the_address pointer;
dcl  author_name character (256) varying;

dcl  error_table_$smallarg fixed binary (35) external;
dcl  mlsys_et_$unknown_message_id fixed binary (35) external;

dcl  mlsys_hash_$hash entry (character (*), fixed binary) returns (fixed binary);
dcl  mlsys_misc_utils_$get_best_address_name entry (pointer, character (*) varying, fixed binary (35));
dcl  mlsys_nit_interface_$get_fully_qualified_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  request_id_ entry (fixed binary (71)) returns (character (19));

dcl  (dimension, hbound, lbound, length, maxlength, null, string, unspec) builtin;
%page;
/* Encode a Message-ID from the local system */

encode_local_id:
     entry (P_clock_reading, P_message_id);

	encoded_message_id.hashed_id = "0"b;		/* just make sure this flag is off */

	local_encoded_message_id.clock_reading = P_clock_reading;
	local_encoded_message_id.pad = ""b;

	unspec (P_message_id) = unspec (encoded_message_id);

	return;
%page;
/* Encode a Message-ID from another computer system:  As we can not convert the text into a unique clock reading as we do
   for local IDs, we instead hash the text string and use the text and system name as the key for constructing the ID */

encode_foreign_id:
     entry (P_message_id_text, P_message_id_system, P_message_id);

	encoded_message_id.hashed_id = "1"b;
	encoded_message_id.pad = ""b;

	encoded_message_id.bucket_idx = mlsys_hash_$hash (P_message_id_text, dimension (message_id_hash_table.buckets, 1));
	encoded_message_id.n_steps = 0;		/* assume it's the first one in this bucket ... */

	full_system_name = mlsys_nit_interface_$get_fully_qualified_name (P_message_id_system);

	last_message_id_slot_ptr = null ();		/* needed in case we must add a new slot */
	do message_id_slot_ptr = message_id_hash_table.buckets (encoded_message_id.bucket_idx)
	     repeat (message_id_slot.next_slot_ptr) while (message_id_slot_ptr ^= null ());
	     if (message_id_slot.message_id = P_message_id_text) & (message_id_slot.system_name = full_system_name)
	     then go to HAVE_ENCODED_MESSAGE_ID;
	     encoded_message_id.n_steps = encoded_message_id.n_steps + 1;
	     last_message_id_slot_ptr = message_id_slot_ptr;
	end;

	/*** Control arrives here iff there's no matching Message-ID already in the hash table */
	message_id_slot_message_id_lth = length (P_message_id_text);
	allocate message_id_slot in (hash_tables_segment.hash_area) set (message_id_slot_ptr);
	message_id_slot.system_name = full_system_name;
	message_id_slot.local_system = mlsys_nit_interface_$is_local_system (full_system_name);
	message_id_slot.message_id = P_message_id_text;
	message_id_slot.next_slot_ptr = null ();
	if last_message_id_slot_ptr = null () then	/* first one in this bucket */
	     message_id_hash_table.buckets (encoded_message_id.bucket_idx) = message_id_slot_ptr;
	else last_message_id_slot_ptr -> message_id_slot.next_slot_ptr = message_id_slot_ptr;

	/*** Control arrives here once the field ID has been determined */
HAVE_ENCODED_MESSAGE_ID:
	unspec (P_message_id) = unspec (encoded_message_id);

	return;
%page;
/* Construct a Message-ID for a message without an explicit Message-ID field:  In this case, we contruct a text string
   from the date/time created of the message and the first author of the message */

encode_psuedo_id:
     entry (P_clock_reading, P_from_field, P_message_id_system, P_message_id);

	the_address = P_from_field -> address_list.addresses (1);
						/* the caller has guarenteed that there's an address */

	call mlsys_misc_utils_$get_best_address_name (the_address, author_name, (0));

	begin;

dcl  1 psuedo_id_text aligned,
       2 date_time_created character (19) unaligned,
       2 semicolon character (1) unaligned,
       2 author character (length (author_name)) unaligned;

	     psuedo_id_text.date_time_created = request_id_ (P_clock_reading);
	     psuedo_id_text.semicolon = ";";
	     psuedo_id_text.author = author_name;

	     call encode_foreign_id (string (psuedo_id_text), P_message_id_system, P_message_id);
	end;

	return;
%page;
/* Decode a Message-ID: return the text, system name, and local system indicator */

decode_message_id:
     entry (P_message_id, P_message_id_string, P_message_id_system, P_system_is_local, P_code);

	unspec (encoded_message_id) = unspec (P_message_id);
						/* get the ID into a useable form */


	if encoded_message_id.hashed_id then do;

/* It claims to be an ID in the hash table */

	     if (encoded_message_id.bucket_idx < lbound (message_id_hash_table.buckets, 1))
		| (encoded_message_id.bucket_idx > hbound (message_id_hash_table.buckets, 1)) then do;
UNKNOWN_MESSAGE_ID:					/* it's not an ID */
		P_code = mlsys_et_$unknown_message_id;
		return;
	     end;

	     n_real_steps = 0;
	     do message_id_slot_ptr = message_id_hash_table.buckets (encoded_message_id.bucket_idx)
		repeat (message_id_slot.next_slot_ptr) while (message_id_slot_ptr ^= null ());
		if n_real_steps = encoded_message_id.n_steps then do;
		     if message_id_slot.message_id_lth <= maxlength (P_message_id_string) then do;
			P_message_id_string = message_id_slot.message_id;
			P_message_id_system = message_id_slot.system_name;
			P_system_is_local = message_id_slot.local_system;
			P_code = 0;		/* ... success */
		     end;
		     else P_code = error_table_$smallarg;
						/* ... ID text is too large */
		     return;			/* ... that's it */
		end;
		n_real_steps = n_real_steps + 1;	/* not the right slot yet ... */
	     end;

	     go to UNKNOWN_MESSAGE_ID;		/* we get here iff there aren't enough slots in the bucket */
	end;


	else do;

/* It's a local ID which consists of just the clock reading */

	     P_message_id_string = request_id_ ((local_encoded_message_id.clock_reading));
	     P_message_id_system = mlsys_nit_interface_$get_local_system_name ();
	     P_system_is_local = "1"b;		/* by definition */
	     P_code = 0;

	     return;
	end;
%page;
%include mlsys_hash_tables_seg;
%page;
%include mlsys_internal_data;
%page;
%include mlsys_address_list;

     end mlsys_message_id_mgr_;




		    mlsys_message_mgr_.pl1          06/30/86  1410.4r w 06/30/86  1343.5      906678



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

/* format: off */

/* Message management for the Multics Mail System */

/* Created:  June 1981 by G. Palter */
/* Recoded:  July 1983 by G. Palter to convert to new mail system specification */
/* Modified: April 1984 by G. Palter to fix error #0438 -- the primitives which allow a user to replace the address list
      portions of a message (eg: mail_system_$replace_from, mail_system_$replace_user_field) should not make the user's
      copy of the address list read-only.  Instead, they should copy the user's list to allow the user to continue to
      modify the list if desired for later additional use */

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


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

	return;					/* not an entrypoint */


/* Parameters */

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

dcl  P_message_version character (8) parameter;		/* create_*_message: version of message structure requested by
						      the caller */

dcl  P_im_message_info_ptr pointer parameter;		/* create_im_message, verify_im_message: -> internal
						      description of the message */

dcl  P_message_envelope_parameter_ptr pointer parameter;	/* replace_message_envelope_*: -> the new envelope */

dcl  P_address_list_ptr pointer parameter;		/* replace_from_*, replace_reply_to_*, replace_to_*,
						      replace_cc_*, replace_bcc_*: -> the new value for the
						      field */

dcl  P_subject character (*) parameter;			/* replace_subject_*: the new subject text */

dcl  P_access_class bit (72) aligned parameter;		/* set_access_class_new: the new AIM access class for the
						      message */

dcl  P_message_body_section_parameter_ptr pointer parameter;/* add_body_section_*: -> the new section to be added;
						   replace_body_*: -> the new section to replace the body;
						   replace_body_section_*: - > the new section to replace the
						      old body section */

dcl  P_message_redistribution_parameter_ptr pointer parameter;
						/* add_redistribution_*: -> the new redistribution;
						   replace_redistribution_*: -> the new redistribution to
						      replace the old redistribution */

dcl  P_referenced_message_ptr pointer parameter;		/* add_reply_reference_new: -> the in-mailbox message for
						      which a reference is to be added to the message;
						   replace_reply_reference_new: -> the in-mailbox message
						      whose reference will replace the old reference */

dcl  P_message_reference_parameter_ptr pointer parameter;	/* add_reply_reference_*: -> the in-mailbox message for which
						      a reference is to be added to the message;
						   replace_reply_reference_*: -> the in-mailbox message
						      whose reference will replace the old reference */

dcl  P_message_user_field_parameter_ptr pointer parameter;	/* add_user_field_*: -> the new user field to be added;
						   replace_user_field_*: -> the new user field to replace the
						      old field */
dcl  P_allow_duplicates bit (1) aligned parameter;	/* add_user_field_*, replace_user_field_*: ON => allow
						      multiple fields with same ID in the header */

dcl  P_position fixed binary parameter;			/* add_*: where to add the new item; set to actual position
						      where it was added;
						   delete_*, replace_* (except replace_subject_*): identifies
						      which item in the message to delete/replace */

dcl  P_date_time_created fixed binary (71) parameter;	/* verify_message, verify_new_message: set to the date/time
						      the message was created */
/**** format: indcomtxt */


/* Local copies of parameters */

dcl  access_class bit (72) aligned;

dcl  position fixed binary;

dcl  code fixed binary (35);


/* Definition of the reserved data in the various parts of a message */

dcl  1 message_reserved_data aligned based (addr (message.reserved)),
       2 info_ptr pointer,				/* -> corresponding im_message_info or new_message_info */
       2 n_body_sections_allocated,			/* actual # of body sections available in the structure */
       2 type fixed binary;				/* type of message (in-mailbox/new/incoming) */

/* format: off */
dcl (IN_MAILBOX_MESSAGE	initial (0),		/* an in-mailbox message */
     NEW_MESSAGE		initial (1))		/* a new message created by ordinary mail_system_ gate */
/*   INCOMING_MESSAGE	initial (2))		/* an incoming message created by mail_system_daemon_ gate */
	fixed binary static options (constant);
/* format: on */

dcl  1 message_references_list_reserved_data aligned based (addr (message_references_list.reserved)),
       2 message_ptr pointer,				/* -> the message of which this is a part */
       2 n_references_allocated fixed binary;		/* # of reference slots actually present */

dcl  1 message_redistributions_list_reserved_data aligned based (addr (message_redistributions_list.reserved)),
       2 message_ptr pointer,				/* -> the message of which this is a part */
       2 n_redistributions_allocated fixed binary;	/* # of redistribution slots actually present */

dcl  1 message_user_fields_list_reserved_data aligned based (addr (message_user_fields_list.reserved)),
       2 message_ptr pointer,				/* -> the message of which this is a part */
       2 n_user_fields_allocated fixed binary;		/* # of user field slots actually present */

dcl  1 message_text_field_reserved_flags unaligned based (addr (message_text_field.flags.reserved)),
       2 free_text bit (1) unaligned,			/* ON => free the text on releasing this field */
       2 pad bit (34) unaligned;

dcl  1 message_preformatted_body_section_reserved_data aligned based (addr (message_preformatted_body_section.reserved)),
       2 free_text bit (1) unaligned,			/* ON => free the text on releasing this section */
       2 pad bit (35) unaligned;

dcl  1 message_bit_string_body_section_reserved_data aligned based (addr (message_bit_string_body_section.reserved)),
       2 free_bit_string bit (1) unaligned,		/* ON => free the bit string on releasing this section */
       2 pad bit (35) unaligned;


/* Internal description of a new message */

dcl  1 new_message_info aligned based (new_message_info_ptr),
       2 date_time_created fixed binary (71);		/* date/time message body last updated */

dcl  new_message_info_ptr pointer;


/* Remaining declarations */

dcl  1 local_mrfp aligned like message_reference_parameter;

dcl  1 user_privileges aligned,
       2 privileges unaligned like aim_template.privileges,
       2 pad bit (18) unaligned;

dcl  message_type fixed binary;

dcl  (copy_subject, copy_section_content, copy_redistribution_data, copy_reference_data, copy_user_field_content)
	bit (1) aligned;

dcl  idx fixed binary;

dcl  MAX_STACK_EXTENSION fixed binary (21) static options (constant) initial (16384);

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

/* format: off */
dcl (SPACE     initial (" "),
     HT	     initial ("	"),
     BS	     initial (""),
     NL	     initial ("
"),
     CR	     initial (""))
	character (1) static options (constant);
/* format: on */

dcl  SPACE_SPACE character (2) static options (constant) initial ("  ");

dcl  TEN_SPACES character (10) static options (constant) initial ("          ");

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

dcl  SINGLE_WIDTH_CHARACTERS character (95) static options (constant)
	initial (" !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");

/* format: off */

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl (error_table_$ai_restricted, error_table_$bad_index, error_table_$smallarg, error_table_$unimplemented_version,
     mlsys_et_$duplicate_reply_reference, mlsys_et_$duplicate_user_field, mlsys_et_$message_too_large,
     mlsys_et_$not_in_mailbox_message, mlsys_et_$not_message, mlsys_et_$not_new_message,
     mlsys_et_$unknown_body_section_type, mlsys_et_$unknown_user_field_type)
	fixed binary (35) external;
/* format: on */

dcl  aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35));
dcl  get_authorization_ entry () returns (bit (72) aligned);
dcl  get_privileges_ entry () returns (bit (36) aligned);
dcl  mlsys_address_list_mgr_$create_read_only_address_list entry (character (8), pointer, fixed binary (35));
dcl  mlsys_address_list_mgr_$copy_address_list entry (pointer, pointer, fixed binary (35));
dcl  mlsys_address_list_mgr_$decrement_reference_count entry (pointer);
dcl  mlsys_address_list_mgr_$increment_reference_count entry (pointer);
dcl  mlsys_address_list_mgr_$set_read_only entry (pointer);
dcl  mlsys_address_list_mgr_$verify_address_list entry (pointer, fixed binary (35)) returns (bit (1) aligned);
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_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_$increment_reference_count entry (pointer);
dcl  mlsys_field_id_mgr_$get_user_field_name entry (bit (36) aligned, character (*) varying, 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_storage_mgr_$get_temp_segment entry (pointer, fixed binary (35));
dcl  mlsys_storage_mgr_$release_temp_segment entry (pointer, fixed binary (35));

dcl  cleanup condition;

dcl  (addr, baseno, binary, clock, divide, index, length, ltrim, max, min, mod, null, rtrim, search, stackframeptr,
     string, substr, translate, verify) builtin;
%page;
/* Create an empty message */

create_im_message:					/* ... create an in-mailbox message */
     entry (P_message_version, P_im_message_info_ptr, P_message_ptr, P_code);

	message_type = IN_MAILBOX_MESSAGE;
	go to CREATE_MESSAGE_COMMON;


create_new_message:					/* ... create a new message: target of user-ring gate */
     entry (P_message_version, P_message_ptr, P_code);

	message_type = NEW_MESSAGE;


CREATE_MESSAGE_COMMON:
	if P_message_version ^= MESSAGE_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	message_n_body_sections = mlsys_data_$message_body_sections_allocation;
						/* allows some room for the body */

	allocate message in (mlsys_area) set (message_ptr);

	message.version = MESSAGE_VERSION_2;

	message_reserved_data.n_body_sections_allocated = message_n_body_sections;
	message.n_body_sections = 0;			/* the body is empty */

	message_reserved_data.type = message_type;

	if message_type = IN_MAILBOX_MESSAGE then message_reserved_data.info_ptr = P_im_message_info_ptr;
	else if message_type = NEW_MESSAGE then do;
	     allocate new_message_info in (mlsys_area) set (new_message_info_ptr);
	     message_reserved_data.info_ptr = new_message_info_ptr;
	     new_message_info.date_time_created = 0;	/* hidden copy so that formatting shows nothing */
	end;
	else message_reserved_data.info_ptr = null ();	/* incoming messages don't have hidden data */

	message.n_reply_references, message.n_user_fields, message.n_redistributions = 0;

	string (message.flags) = ""b;

	message.date_time_mailed, message.date_time_delivered = 0;
	message.sender, message.trace, message.delivered_by, message.acknowledge_to = null ();

	message.message_id = ""b;			/* will be set later for in-mailbox/incoming */

	message.access_class = get_authorization_ ();

	message.date_time_created = 0;

	call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, message.from, (0));
	call mlsys_address_list_mgr_$increment_reference_count (message.from);

	call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, message.reply_to, (0));
	call mlsys_address_list_mgr_$increment_reference_count (message.reply_to);

	call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, message.to, (0));
	call mlsys_address_list_mgr_$increment_reference_count (message.to);

	call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, message.cc, (0));
	call mlsys_address_list_mgr_$increment_reference_count (message.cc);

	call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, message.bcc, (0));
	call mlsys_address_list_mgr_$increment_reference_count (message.bcc);

	message.subject.text_ptr = addr (NULL_STRING);	/* avoid causing anyone faults */
	message.subject.text_lth = 0;
	string (message.subject.flags) = ""b;		/* this turns subject.multiline_text off */
	addr (message.subject.flags.reserved) -> message_text_field_reserved_flags.free_text = "0"b;

	message_references_list_n_references = mlsys_data_$message_references_list_allocation;
	allocate message_references_list in (mlsys_area) set (message_references_list_ptr);
	message_references_list.version = MESSAGE_REFERENCES_LIST_VERSION_2;
	message_references_list_reserved_data.n_references_allocated = message_references_list_n_references;
	message_references_list.n_references = 0;
	message.reply_references = message_references_list_ptr;
	message_references_list_reserved_data.message_ptr = message_ptr;

	message_n_user_fields = mlsys_data_$message_user_fields_allocation;
	allocate message_user_fields_list in (mlsys_area) set (message.user_fields_list);
	message_user_fields_list.version = MESSAGE_USER_FIELDS_LIST_VERSION_2;
	message_user_fields_list_reserved_data.n_user_fields_allocated = message_n_user_fields;
	message_user_fields_list.n_user_fields = 0;
	message_user_fields_list_reserved_data.message_ptr = message_ptr;

	if message_type = NEW_MESSAGE then		/* new messages can't have redistributions ... */
	     message.redistributions_list = null ();
	else do;					/* ... but in-mailbox and incoming messages do */
	     message_n_redistributions = mlsys_data_$message_redistributions_list_allocation;
	     allocate message_redistributions_list in (mlsys_area) set (message.redistributions_list);
	     message_redistributions_list.version = MESSAGE_REDISTRIBUTIONS_LIST_VERSION_2;
	     message_redistributions_list_reserved_data.n_redistributions_allocated = message_n_redistributions;
	     message_redistributions_list.n_redistributions = 0;
	     message_redistributions_list_reserved_data.message_ptr = message_ptr;
	end;

	message.body.total_lines = 0;			/* as said above: no body yet */

	P_message_ptr = message_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Free a message */

free_message:					/* ... any type of message */
     entry (P_message_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	go to FREE_MESSAGE_COMMON;


free_message_new:					/* ... a new message only: target of user-ring gate */
     entry (P_message_ptr, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;


FREE_MESSAGE_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	P_message_ptr = null ();			/* insure the caller doesn't use it anymore */

	do idx = message.n_body_sections to 1 by -1;	/* get rid of any body that's present */
	     call delete_body_section_internal (idx);
	end;

	do idx = message.n_redistributions to 1 by -1;	/* non-zero only if message.redistributions_list non-null */
	     call delete_redistribution_internal (idx);
	end;
	if message.redistributions_list ^= null () then free message_redistributions_list in (mlsys_area);
	message.redistributions_list = null ();		/* handles a cleanup during the free doing another free */

	do idx = message.n_user_fields to 1 by -1;
	     call delete_user_field_internal (idx);
	end;
	free message_user_fields_list in (mlsys_area);
	message.user_fields_list = null ();

	do idx = message.n_reply_references to 1 by -1;
	     call delete_reference_internal (message.n_reply_references, message.reply_references, idx);
	end;
	free message.reply_references -> message_references_list in (mlsys_area);
	message.reply_references = null ();

	if addr (message.subject.flags.reserved) -> message_text_field_reserved_flags.free_text then
	     if (message.subject.text_ptr ^= null ()) & (message.subject.text_ptr ^= addr (NULL_STRING)) then do;
		free message_subject in (mlsys_area);
		message.subject.text_ptr = null ();
	     end;

	if message.bcc ^= null () then call mlsys_address_list_mgr_$decrement_reference_count (message.bcc);
	if message.cc ^= null () then call mlsys_address_list_mgr_$decrement_reference_count (message.cc);
	if message.to ^= null () then call mlsys_address_list_mgr_$decrement_reference_count (message.to);
	if message.reply_to ^= null () then call mlsys_address_list_mgr_$decrement_reference_count (message.reply_to);
	if message.from ^= null () then call mlsys_address_list_mgr_$decrement_reference_count (message.from);

	call delete_envelope (addr (message.envelope));

	if message_reserved_data.info_ptr ^= null () then
	     if message_reserved_data.type = NEW_MESSAGE then
		free message_reserved_data.info_ptr -> new_message_info in (mlsys_area);
	message_reserved_data.info_ptr = null ();

	free message in (mlsys_area);

	P_code = 0;				/* all done */

	return;
%page;
/* Add a section to the body of a message */

add_body_section:					/* ... for any type of message */
     entry (P_message_ptr, P_message_body_section_parameter_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_section_content = "1"b;
	go to ADD_BODY_SECTION_COMMON;


add_body_section_no_copy:				/* ... for any type of message: section content in our ring */
     entry (P_message_ptr, P_message_body_section_parameter_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_section_content = "0"b;
	go to ADD_BODY_SECTION_COMMON;


add_body_section_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_message_body_section_parameter_ptr, P_position, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	copy_section_content = "1"b;


ADD_BODY_SECTION_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	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;

	message_body_section_ptr = addr (message_body_section_parameter.section);
	if ^verify_body_section (message_body_section_ptr, P_code) then return;

	call compute_position_for_add (P_position, message.n_body_sections, position);

	call add_body_section_internal ();		/* do the actual work (also used by replace_body_*) */

	if message_reserved_data.type = NEW_MESSAGE then	/* record date/time of latest change to message body */
	     message_reserved_data.info_ptr -> new_message_info.date_time_created = clock ();

	P_message_ptr = message_ptr;			/* in case we had to expand message.body_sections */
	P_position = position;			/* let caller know where we put it */
	P_code = 0;				/* success */

	return;
%page;
/* Actually adds a section to the message body (called by several entrypoints) */

add_body_section_internal:
     procedure ();

dcl  1 the_body_section aligned like message_body_section based (the_section_ptr);
dcl  1 the_preformatted_body_section aligned like message_preformatted_body_section based (the_section_ptr);
dcl  1 the_bit_string_body_section aligned like message_bit_string_body_section based (the_section_ptr);

dcl  (new_message_ptr, the_section_ptr) pointer;
dcl  idx fixed binary;

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

	on condition (cleanup)
	     begin;
		if new_message_ptr ^= null () then free new_message_ptr -> message in (mlsys_area);
		new_message_ptr = null ();
	     end;

	/*** Expand the message structure if necessary */
	if (message.n_body_sections + 1) > message_reserved_data.n_body_sections_allocated then do;
	     message_n_body_sections =
		message_reserved_data.n_body_sections_allocated + mlsys_data_$message_body_sections_allocation;
	     allocate message in (mlsys_area) set (new_message_ptr);
	     new_message_ptr -> message.version = MESSAGE_VERSION_2;
	     new_message_ptr -> message.reserved = message.reserved;
	     addr (new_message_ptr -> message.reserved) -> message_reserved_data.n_body_sections_allocated =
		message_n_body_sections;
	     new_message_ptr -> message.n_reply_references = message.n_reply_references;
	     new_message_ptr -> message.n_user_fields = message.n_user_fields;
	     new_message_ptr -> message.n_redistributions = message.n_redistributions;
	     new_message_ptr -> message.n_body_sections = message.n_body_sections;
	     string (new_message_ptr -> message.flags) = string (message.flags);
	     new_message_ptr -> message.envelope = message.envelope;
	     new_message_ptr -> message.header = message.header;
	     new_message_ptr -> message.redistributions_list = message.redistributions_list;
	     new_message_ptr -> message.body.total_lines = message.body.total_lines;
	     do idx = 1 to message.n_body_sections;
		new_message_ptr -> message.body.body_sections (idx) = message.body.body_sections (idx);
	     end;
	     free message in (mlsys_area);
	     message_ptr = new_message_ptr;
	     new_message_ptr = null ();
	end;

	/*** Make room for the new section by moving any existing sections behind it up by one */
	do idx = message.n_body_sections to position by -1;
	     message.body.body_sections (idx + 1) = message.body.body_sections (idx);
	end;

	/*** Copy in the new section and, if needed, copy the actual data */
	the_section_ptr = addr (message.body.body_sections (position));
	the_body_section.header = message_body_section.header;
	go to ADD_SECTION (message_body_section.section_type);

ADD_SECTION (1):					/* preformatted text */
	string (the_preformatted_body_section.reserved) = ""b;
	if copy_section_content then do;		/* ... always copy it */
COPY_PREFORMATTED_TEXT:
	     call normalize_multiline_field (message_preformatted_body_section_text,
		the_preformatted_body_section.text_ptr, the_preformatted_body_section.text_lth);
	     addr (the_preformatted_body_section.reserved)
		-> message_preformatted_body_section_reserved_data.free_text = "1"b;
	end;
	else					/* ... copy caller's text only if it's misformatted ... */
	     if index (message_preformatted_body_section_text, HT) ^= 0 then go to COPY_PREFORMATTED_TEXT;
	else					/* ... or not in one of our temporary segments ... */
	     if ^mlsys_data_$valid_segments (binary (baseno (message_preformatted_body_section.text_ptr), 18, 0)) then
	     go to COPY_PREFORMATTED_TEXT;
	else do;					/* ... caller's text is OK */
	     the_preformatted_body_section.text_ptr = copy_ptr (message_preformatted_body_section.text_ptr);
	     the_preformatted_body_section.text_lth = message_preformatted_body_section.text_lth;
	end;
	the_body_section.section_n_lines =
	     count_lines_in_text (the_preformatted_body_section.text_ptr -> message_preformatted_body_section_text);
	go to END_ADD_SECTION_CASE;

ADD_SECTION (2):					/* bit string */
	the_body_section.section_n_lines = -1;
	the_bit_string_body_section.bit_string_lth = message_bit_string_body_section.bit_string_lth;
	string (the_bit_string_body_section.reserved) = ""b;
						/* ... above turns off the free_bit_string flag */
	if copy_section_content then do;
COPY_BIT_STRING:
	     allocate message_bit_string_body_section_bit_string in (mlsys_area)
		set (the_bit_string_body_section.bit_string_ptr);
	     the_bit_string_body_section.bit_string_ptr -> message_bit_string_body_section_bit_string =
		message_bit_string_body_section_bit_string;
	     addr (the_bit_string_body_section.reserved)
		-> message_bit_string_body_section_reserved_data.free_bit_string = "1"b;
	end;
	else					/* copy if not in one of our temporary segments */
	     if ^mlsys_data_$valid_segments (binary (baseno (message_bit_string_body_section.bit_string_ptr), 18, 0))
	then go to COPY_BIT_STRING;
	else the_bit_string_body_section.bit_string_ptr = copy_ptr (message_bit_string_body_section.bit_string_ptr);
	go to END_ADD_SECTION_CASE;

END_ADD_SECTION_CASE:
	message.n_body_sections = message.n_body_sections + 1;

	/*** Recompute the number of lines in the body */
	message.body.total_lines = 0;
	do idx = 1 to message.n_body_sections while (message.body.total_lines ^= -1);
	     if message.body.body_sections (idx).section_n_lines = -1 then
		message.body.total_lines = -1;
	     else message.body.total_lines =
		     message.body.total_lines + message.body.body_sections (idx).section_n_lines;
	end;

	if message.body.total_lines ^= -1 then		/* take the lines in between sections into account */
	     message.body.total_lines = message.body.total_lines + message.n_body_sections - 1;

	return;

     end add_body_section_internal;
%page;
/* Add a redistribution to the list of redistributions for a given message */

add_redistribution:					/* ... for any type of message */
     entry (P_message_ptr, P_message_redistribution_parameter_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_redistribution_data = "1"b;
	go to ADD_REDISTRIBUTION_COMMON;


add_redistribution_no_copy:				/* ... for any type of message; data already in our ring */
     entry (P_message_ptr, P_message_redistribution_parameter_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_redistribution_data = "0"b;


ADD_REDISTRIBUTION_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	message_redistribution_parameter_ptr = P_message_redistribution_parameter_ptr;

	if message_redistribution_parameter.version ^= MESSAGE_REDISTRIBUTION_PARAMETER_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	message_redistribution_ptr = addr (message_redistribution_parameter.redistribution);
	if ^verify_redistribution (message_redistribution_ptr, P_code) then return;

	call compute_position_for_add (P_position, message.n_redistributions, position);

	call add_redistribution_internal ();		/* do the actual work (used by replace_redistribution_*) */

	P_position = position;			/* let caller know where we put it */
	P_code = 0;				/* success */

	return;



/* Actually adds a redistribution to the message's redistributions lists (called by several entrypoints) */

add_redistribution_internal:
     procedure ();

dcl  1 the_redistribution aligned based (the_redistribution_ptr) like message_redistribution;

dcl  (new_rl_ptr, the_redistribution_ptr) pointer;
dcl  idx fixed binary;

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

	on condition (cleanup)
	     begin;
		if new_rl_ptr ^= null () then free new_rl_ptr -> message_redistributions_list in (mlsys_area);
		new_rl_ptr = null ();
	     end;

	/*** Expand the message_redistributions_list structure if necessary */
	if (message.n_redistributions + 1) > message_redistributions_list_reserved_data.n_redistributions_allocated
	then do;
	     message_n_redistributions =
		message_redistributions_list_reserved_data.n_redistributions_allocated
		+ mlsys_data_$message_redistributions_list_allocation;
	     allocate message_redistributions_list in (mlsys_area) set (new_rl_ptr);
	     new_rl_ptr -> message_redistributions_list.version = MESSAGE_REDISTRIBUTIONS_LIST_VERSION_2;
	     new_rl_ptr -> message_redistributions_list.reserved = message_redistributions_list.reserved;
	     addr (new_rl_ptr -> message_redistributions_list.reserved)
		-> message_redistributions_list_reserved_data.n_redistributions_allocated = message_n_redistributions;
	     new_rl_ptr -> message_redistributions_list.n_redistributions =
		message_redistributions_list.n_redistributions;
	     do idx = 1 to message.n_redistributions;
		new_rl_ptr -> message_redistributions_list.redistributions (idx) =
		     message_redistributions_list.redistributions (idx);
	     end;
	     free message_redistributions_list in (mlsys_area);
	     message.redistributions_list = new_rl_ptr;
	     new_rl_ptr = null ();
	end;

	/*** Make room for the new redistribution by moving any existing redistributions behind it up by one */
	do idx = message.n_redistributions to position by -1;
	     message_redistributions_list.redistributions (idx + 1) =
		message_redistributions_list.redistributions (idx);
	end;

	/*** Copy in the new redistribution */
	the_redistribution_ptr = addr (message_redistributions_list.redistributions (position));
	call set_envelope (addr (message_redistribution.envelope), addr (the_redistribution.envelope));
	the_redistribution.header = message_redistribution.header;
	if the_redistribution.from ^= null () then do;
	     if copy_redistribution_data then
		call mlsys_address_list_mgr_$copy_address_list (the_redistribution.from, the_redistribution.from, (0))
		     ;
	     else the_redistribution.from = copy_ptr (the_redistribution.from);
	     call mlsys_address_list_mgr_$set_read_only (the_redistribution.from);
	end;
	else call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2,
		the_redistribution.from, (0));
	call mlsys_address_list_mgr_$increment_reference_count (the_redistribution.from);
	if the_redistribution.to ^= null () then do;
	     if copy_redistribution_data then
		call mlsys_address_list_mgr_$copy_address_list (the_redistribution.to, the_redistribution.to, (0));
	     else the_redistribution.to = copy_ptr (the_redistribution.to);
	     call mlsys_address_list_mgr_$set_read_only (the_redistribution.to);
	end;
	else call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, the_redistribution.to,
		(0));
	call mlsys_address_list_mgr_$increment_reference_count (the_redistribution.to);

	/*** Copy the comment (if necessary) */
	string (the_redistribution.comment.flags) = ""b;	/* turns off the "free_text" flag */
	the_redistribution.comment.multiline_text = "1"b; /* always treated as multiline */
	if (message_redistribution.comment.text_ptr = null ()) | (message_redistribution.comment.text_lth = 0) then do;
	     the_redistribution.comment.text_ptr = addr (NULL_STRING);
	     the_redistribution.comment.text_lth = 0;
	end;
	else if copy_redistribution_data then do;	/* always copy the comment */
COPY_REDISTRIBUTION_COMMENT:
	     call normalize_multiline_field (message_redistribution_comment, the_redistribution.comment.text_ptr,
		the_redistribution.comment.text_lth);
	     addr (the_redistribution.comment.flags.reserved) -> message_text_field_reserved_flags.free_text = "1"b;
	end;
	else					/* copy it only if it's misformatted ... */
	     if index (message_redistribution_comment, HT) ^= 0 then go to COPY_REDISTRIBUTION_COMMENT;
	else					/* ... or not in one of our temporary segments ... */
	     if ^mlsys_data_$valid_segments (binary (baseno (message_redistribution.comment.text_ptr), 18, 0)) then
	     go to COPY_REDISTRIBUTION_COMMENT;
	else do;					/* caller's text is OK */
	     the_redistribution.comment.text_ptr = copy_ptr (message_redistribution.comment.text_ptr);
	     the_redistribution.comment.text_lth = message_redistribution.comment.text_lth;
	end;

	message_redistributions_list.n_redistributions, message.n_redistributions = message.n_redistributions + 1;

	return;

     end add_redistribution_internal;
%page;
/* Add a reference (as given or to the given message) to the list of messages for which this message is a reply */

add_reply_reference:				/* ... for any type message */
     entry (P_message_ptr, P_message_reference_parameter_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_reference_data = "1"b;
	go to ADD_REPLY_REFERENCE_COMMON;


add_reply_reference_no_copy:				/* ... for any type message: data already in our ring */
     entry (P_message_ptr, P_message_reference_parameter_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_reference_data = "0"b;
	go to ADD_REPLY_REFERENCE_COMMON;


add_reply_reference_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_referenced_message_ptr, P_position, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	if ^verify_im_message_internal (P_referenced_message_ptr, P_code) then return;
	copy_reference_data = "0"b;			/* it's already in the right place from in-mailbox message */

	message_ptr = copy_ptr (P_referenced_message_ptr);/* need to access the original temporarily */
	message_reference_parameter_ptr = addr (local_mrfp);
	message_reference_parameter.reference.message_id = message.message_id;
	message_reference_parameter.reference.date_time_created = message.date_time_created;
	message_reference_parameter.reference.from = message.from;
	message_reference_parameter.reference.subject = message.subject;
	go to ADD_REPLY_REFERENCE_NO_RP_CHECK;


ADD_REPLY_REFERENCE_COMMON:
	message_reference_parameter_ptr = P_message_reference_parameter_ptr;
	if message_reference_parameter.version ^= MESSAGE_REFERENCE_PARAMETER_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;
	if ^verify_reference (addr (message_reference_parameter.reference), P_code) then return;

ADD_REPLY_REFERENCE_NO_RP_CHECK:
	message_ptr = copy_ptr (P_message_ptr);
	message_reference_ptr = addr (message_reference_parameter.reference);

	/*** Check for duplicate reply references */
	do idx = 1 to message.n_reply_references;
	     if message.reply_references -> message_references_list.references (idx).message_id
		= message_reference.message_id then do;
		P_position = idx;			/* let caller know where the duplicate resides */
		P_code = mlsys_et_$duplicate_reply_reference;
		return;
	     end;
	end;

	call compute_position_for_add (P_position, message.n_reply_references, position);

	call add_reference_internal (message.n_reply_references, message.reply_references);

	P_position = position;			/* let caller know where we put it */
	P_code = 0;				/* success */

	return;



/* Actually adds a reference to the message's references lists (called by several entrypoints) */

add_reference_internal:
     procedure (p_n_references, p_references_list_ptr);

dcl  p_n_references fixed binary parameter;
dcl  p_references_list_ptr pointer parameter;

dcl  1 the_reference aligned based (the_reference_ptr) like message_reference;

dcl  (new_rl_ptr, the_reference_ptr) pointer;
dcl  idx fixed binary;

	message_references_list_ptr = p_references_list_ptr;
						/* can't use like because it contains a refer extent */
	new_rl_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if new_rl_ptr ^= null () then free new_rl_ptr -> message_references_list in (mlsys_area);
		new_rl_ptr = null ();
	     end;

	/*** Expand the message_references_list structure if necessary */
	if (p_n_references + 1) > message_references_list_reserved_data.n_references_allocated then do;
	     message_references_list_n_references =
		message_references_list_reserved_data.n_references_allocated
		+ mlsys_data_$message_references_list_allocation;
	     allocate message_references_list in (mlsys_area) set (new_rl_ptr);
	     new_rl_ptr -> message_references_list.version = MESSAGE_REFERENCES_LIST_VERSION_2;
	     new_rl_ptr -> message_references_list.reserved = message_references_list.reserved;
	     addr (new_rl_ptr -> message_references_list.reserved)
		-> message_references_list_reserved_data.n_references_allocated =
		message_references_list_n_references;
	     new_rl_ptr -> message_references_list.n_references = message_references_list.n_references;
	     do idx = 1 to message.n_reply_references;
		new_rl_ptr -> message_references_list.references (idx) = message_references_list.references (idx);
	     end;
	     free message_references_list in (mlsys_area);
	     p_references_list_ptr, message_references_list_ptr = new_rl_ptr;
	     new_rl_ptr = null ();
	end;

	/*** Make room for the new reference by moving any existing references behind it up by one */
	do idx = p_n_references to position by -1;
	     message_references_list.references (idx + 1) = message_references_list.references (idx);
	end;

	/*** Copy in the new reference */
	the_reference_ptr = addr (message_references_list.references (position));
	the_reference = message_reference;		/* simple copy */
	if the_reference.from ^= null () then do;
	     if copy_reference_data then
		call mlsys_address_list_mgr_$copy_address_list (the_reference.from, the_reference.from, (0));
	     else the_reference.from = copy_ptr (the_reference.from);
	     call mlsys_address_list_mgr_$set_read_only (the_reference.from);
	     call mlsys_address_list_mgr_$increment_reference_count (the_reference.from);
	end;

	/*** Copy the subject (if necessary) */
	string (the_reference.subject.flags) = ""b;	/* turns off both multiline_text & free_text */
	if (message_reference.subject.text_ptr = null ()) | (message_reference.subject.text_lth = 0) then do;
	     the_reference.subject.text_ptr = addr (NULL_STRING);
	     the_reference.subject.text_lth = 0;
	end;
	else if copy_reference_data then do;		/* copy it no matter what */
COPY_REFERENCED_SUBJECT:
	     call normalize_single_line_field (message_reference_subject, the_reference.subject.text_ptr,
		the_reference.subject.text_lth);
	     addr (the_reference.subject.flags.reserved) -> message_text_field_reserved_flags.free_text = "1"b;
	end;
	else do;					/* copy it only if it's improperly formatted */
	     if ^mlsys_data_$valid_segments (binary (baseno (addr (message_reference_subject)), 18, 0)) then
		go to COPY_REFERENCED_SUBJECT;
	     if search (message_reference_subject, NON_SPACE_WHITESPACE) ^= 0 then go to COPY_REFERENCED_SUBJECT;
	     if verify (message_reference_subject, SPACE) ^= 1 then go to COPY_REFERENCED_SUBJECT;
	     if substr (message_reference_subject, length (message_reference_subject), 1) = SPACE then
		go to COPY_REFERENCED_SUBJECT;
	     if index (message_reference_subject, SPACE_SPACE) ^= 0 then go to COPY_REFERENCED_SUBJECT;
	     the_reference.subject.text_ptr = copy_ptr (message_reference.subject.text_ptr);
	     the_reference.subject.text_lth = message_reference.subject.text_lth;
	end;					/* ... above is executed iff caller's text is OK */

	message_references_list.n_references, p_n_references = p_n_references + 1;

	return;

     end add_reference_internal;
%page;
/* Add a user-defined field to the message */

add_user_field:					/* ... for any type of message */
     entry (P_message_ptr, P_message_user_field_parameter_ptr, P_position, P_allow_duplicates, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_user_field_content = "1"b;
	go to ADD_USER_FIELD_COMMON;


add_user_field_no_copy:				/* ... for any type of message: data already in our ring */
     entry (P_message_ptr, P_message_user_field_parameter_ptr, P_position, P_allow_duplicates, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_user_field_content = "0"b;
	go to ADD_USER_FIELD_COMMON;


add_user_field_new:					/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_message_user_field_parameter_ptr, P_position, P_allow_duplicates, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	copy_user_field_content = "1"b;


ADD_USER_FIELD_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	message_user_field_parameter_ptr = P_message_user_field_parameter_ptr;

	if message_user_field_parameter.version ^= MESSAGE_USER_FIELD_PARAMETER_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	message_user_field_ptr = addr (message_user_field_parameter.user_field);
	if ^verify_user_field (message_user_field_ptr, P_code) then return;

	/*** Check for duplicate fields if requested */
	if ^P_allow_duplicates then do;
	     do idx = 1 to message.n_user_fields;
		if message_user_fields_list.user_fields (idx).field_id = message_user_field.field_id then do;
		     P_position = idx;		/* let caller know where the first duplicate lies */
		     P_code = mlsys_et_$duplicate_user_field;
		     return;
		end;
	     end;
	end;

	call compute_position_for_add (P_position, message.n_user_fields, position);

	call add_user_field_internal ();		/* do the actual work (also used by replace_user_field_*) */

	P_position = position;			/* let caller know where we put it */
	P_code = 0;				/* success */

	return;



/* Actually adds a user-defined field to the message (called by several entrypoints) */

add_user_field_internal:
     procedure ();

dcl  1 the_user_field aligned like message_user_field based (the_user_field_ptr);
dcl  1 the_text_user_field aligned like message_text_user_field based (the_user_field_ptr);
dcl  1 the_address_list_user_field aligned like message_address_list_user_field based (the_user_field_ptr);
dcl  1 the_date_user_field aligned like message_date_user_field based (the_user_field_ptr);
dcl  1 the_integer_user_field aligned like message_integer_user_field based (the_user_field_ptr);

dcl  (new_ufl_ptr, the_user_field_ptr) pointer;
dcl  idx fixed binary;

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

	on condition (cleanup)
	     begin;
		if new_ufl_ptr ^= null () then free new_ufl_ptr -> message_user_fields_list in (mlsys_area);
		new_ufl_ptr = null ();
	     end;

	/*** Expand the message_user_fields structure if necessary */
	if (message.n_user_fields + 1) > message_user_fields_list_reserved_data.n_user_fields_allocated then do;
	     message_n_user_fields =
		message_user_fields_list_reserved_data.n_user_fields_allocated
		+ mlsys_data_$message_user_fields_allocation;
	     allocate message_user_fields_list in (mlsys_area) set (new_ufl_ptr);
	     new_ufl_ptr -> message_user_fields_list.version = MESSAGE_USER_FIELDS_LIST_VERSION_2;
	     new_ufl_ptr -> message_user_fields_list.reserved = message_user_fields_list.reserved;
	     addr (new_ufl_ptr -> message_user_fields_list.reserved)
		-> message_user_fields_list_reserved_data.n_user_fields_allocated = message_n_user_fields;
	     new_ufl_ptr -> message_user_fields_list.n_user_fields = message_user_fields_list.n_user_fields;
	     do idx = 1 to message.n_user_fields;
		new_ufl_ptr -> message_user_fields_list.user_fields (idx) =
		     message_user_fields_list.user_fields (idx);
	     end;
	     free message_user_fields_list in (mlsys_area);
	     message.user_fields_list = new_ufl_ptr;
	     new_ufl_ptr = null ();
	end;

	/*** Make room for the new user-defined field by moving any existing fields behind it up by one */
	do idx = message.n_user_fields to position by -1;
	     message_user_fields_list.user_fields (idx + 1) = message_user_fields_list.user_fields (idx);
	end;

	/*** Copy in the new user-defined field and, if needed, copy the actual data */
	the_user_field_ptr = addr (message_user_fields_list.user_fields (position));
	the_user_field.header = message_user_field.header;
	go to ADD_USER_FIELD (message_user_field.field_type);

ADD_USER_FIELD (1):					/* user-defined text field */
	the_text_user_field.multiline_text = message_text_user_field.multiline_text;
	string (the_text_user_field.flags.reserved) = ""b;/* ... turns off the "free_text" flag */
	if (message_text_user_field.text_ptr = null ()) | (message_text_user_field.text_lth = 0) then do;
	     the_text_user_field.text_ptr = addr (NULL_STRING);
	     the_text_user_field.text_lth = 0;
	end;
	else if copy_user_field_content then do;	/* copy it no matter what */
COPY_USER_FIELD_TEXT:
	     if the_text_user_field.multiline_text then	/* ... eliminate tabs from multiline text */
		call normalize_multiline_field (message_text_user_field_text, the_text_user_field.text_ptr,
		     the_text_user_field.text_lth);
	     else call normalize_single_line_field (message_text_user_field_text, the_text_user_field.text_ptr,
		     the_text_user_field.text_lth);
	     addr (the_text_user_field.flags.reserved) -> message_text_field_reserved_flags.free_text = "1"b;
	end;
	else if ^mlsys_data_$valid_segments (binary (baseno (addr (message_text_user_field_text)), 18, 0)) then
	     go to COPY_USER_FIELD_TEXT;
	else if the_text_user_field.multiline_text then	/* copy it only if it's improperly formatted */
	     if index (message_text_user_field_text, HT) ^= 0 then
		go to COPY_USER_FIELD_TEXT;		/* ... have to "canonicalize" tabs */
	     else do;				/* ... caller's text is OK */
		the_text_user_field.text_ptr = copy_ptr (message_text_user_field.text_ptr);
		the_text_user_field.text_lth = message_text_user_field.text_lth;
	     end;
	else /*** if ^the_text_user_field.multiline_text then */
	     do;					/* copy it only if it's improperly formatted */
	     if search (message_text_user_field_text, NON_SPACE_WHITESPACE) ^= 0 then go to COPY_USER_FIELD_TEXT;
	     if verify (message_text_user_field_text, SPACE) ^= 1 then go to COPY_USER_FIELD_TEXT;
	     if substr (message_text_user_field_text, length (message_text_user_field_text), 1) = SPACE then
		go to COPY_USER_FIELD_TEXT;
	     if index (message_text_user_field_text, SPACE_SPACE) ^= 0 then go to COPY_USER_FIELD_TEXT;
	     the_text_user_field.text_ptr = copy_ptr (message_text_user_field.text_ptr);
	     the_text_user_field.text_lth = message_text_user_field.text_lth;
	end;					/* ... above is executed iff caller's text is OK */
	go to END_ADD_USER_FIELD_CASE;

ADD_USER_FIELD (2):					/* user-defined address list field */
	the_address_list_user_field.address_list_ptr = copy_ptr (message_address_list_user_field.address_list_ptr);
	if the_address_list_user_field.address_list_ptr ^= null () then do;
	     if copy_user_field_content then
		call mlsys_address_list_mgr_$copy_address_list (the_address_list_user_field.address_list_ptr,
		     the_address_list_user_field.address_list_ptr, (0));
	     call mlsys_address_list_mgr_$set_read_only (the_address_list_user_field.address_list_ptr);
	     call mlsys_address_list_mgr_$increment_reference_count (the_address_list_user_field.address_list_ptr);
	end;
	go to END_ADD_USER_FIELD_CASE;

ADD_USER_FIELD (3):					/* user-defined date field */
	the_date_user_field.date_time = message_date_user_field.date_time;
	go to END_ADD_USER_FIELD_CASE;

ADD_USER_FIELD (4):					/* user-defined integer field */
	the_integer_user_field.value = message_integer_user_field.value;
	go to END_ADD_USER_FIELD_CASE;

END_ADD_USER_FIELD_CASE:
	message_user_fields_list.n_user_fields, message.n_user_fields = message.n_user_fields + 1;

	return;

     end add_user_field_internal;
%page;
/* Delete the specified section of the message body */

delete_body_section:				/* ... for any type of message */
     entry (P_message_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	go to DELETE_BODY_SECTION_COMMON;


delete_body_section_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_position, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;


DELETE_BODY_SECTION_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	position = P_position;

	if (position < 1) | (position > message.n_body_sections) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	call delete_body_section_internal (position);

	if message_reserved_data.type = NEW_MESSAGE then	/* record date/time of latest change to message body */
	     message_reserved_data.info_ptr -> new_message_info.date_time_created = clock ();

	P_code = 0;				/* success */

	return;



/* Actually deletes a message body section (called by several entrypoints) */

delete_body_section_internal:
     procedure (p_position);

dcl  p_position fixed binary parameter;
dcl  idx fixed binary;

	message_body_section_ptr = addr (message.body.body_sections (p_position));

	if message_body_section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION then
	     if message_preformatted_body_section_reserved_data.free_text then
		if (message_preformatted_body_section.text_ptr ^= null ())
		     & (message_preformatted_body_section.text_ptr ^= addr (NULL_STRING)) then do;
		     free message_preformatted_body_section_text in (mlsys_area);
		     message_preformatted_body_section.text_ptr = null ();
		end;
		else ;
	     else ;

	else if message_body_section.section_type = MESSAGE_BIT_STRING_BODY_SECTION then
	     if message_bit_string_body_section_reserved_data.free_bit_string then
		if (message_bit_string_body_section.bit_string_ptr ^= null ())
		     & (message_bit_string_body_section.bit_string_ptr ^= addr (NULL_STRING)) then do;
		     free message_bit_string_body_section_bit_string in (mlsys_area);
		     message_bit_string_body_section.bit_string_ptr = null ();
		end;

	do idx = (p_position + 1) to message.n_body_sections;
	     message.body.body_sections (idx - 1) = message.body.body_sections (idx);
	end;

	message.n_body_sections = message.n_body_sections - 1;

	/*** Recompute the number of lines in the body */
	message.body.total_lines = 0;
	do idx = 1 to message.n_body_sections while (message.body.total_lines ^= -1);
	     if message.body.body_sections (idx).section_n_lines = -1 then
		message.body.total_lines = -1;
	     else message.body.total_lines =
		     message.body.total_lines + message.body.body_sections (idx).section_n_lines;
	end;

	if message.body.total_lines ^= -1 then		/* take the lines in between sections into account */
	     message.body.total_lines = message.body.total_lines + max (message.n_body_sections, 1) - 1;

	return;

     end delete_body_section_internal;
%page;
/* Delete the specified redistribution from the message's redistributions list */

delete_redistribution:				/* ... for any type of message */
     entry (P_message_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	go to DELETE_REDISTRIBUTION_COMMON;


delete_redistribution_no_copy:			/* ... for any type of message */
     entry (P_message_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;


DELETE_REDISTRIBUTION_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	position = P_position;

	if (position < 1) | (position > message.n_redistributions) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	call delete_redistribution_internal (position);

	P_code = 0;				/* success */

	return;



/* Actually deletes a redistribution (called by several entrypoints) */

delete_redistribution_internal:
     procedure (p_position);

dcl  p_position fixed binary parameter;
dcl  idx fixed binary;

	message_redistribution_ptr = addr (message_redistributions_list.redistributions (p_position));

	call delete_envelope (addr (message_redistribution.envelope));
						/* release all possible data in the envelope */

	if message_redistribution.from ^= null () then
	     call mlsys_address_list_mgr_$decrement_reference_count (message_redistribution.from);

	if message_redistribution.to ^= null () then
	     call mlsys_address_list_mgr_$decrement_reference_count (message_redistribution.to);

	if addr (message_redistribution.comment.flags.reserved) -> message_text_field_reserved_flags.free_text then
	     if (message_redistribution.comment.text_ptr ^= null ())
		& (message_redistribution.comment.text_ptr ^= addr (NULL_STRING)) then do;
		free message_redistribution_comment in (mlsys_area);
		message_redistribution.comment.text_ptr = null ();
	     end;

	do idx = (p_position + 1) to message.n_redistributions;
	     message_redistributions_list.redistributions (idx - 1) =
		message_redistributions_list.redistributions (idx);
	end;

	message_redistributions_list.n_redistributions, message.n_redistributions = message.n_redistributions - 1;

	return;

     end delete_redistribution_internal;
%page;
/* Delete the specified message reference from the message's list of reply references */

delete_reply_reference:				/* ... for any type message */
     entry (P_message_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	go to DELETE_REPLY_REFERENCE_COMMON;


delete_reply_reference_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_position, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;


DELETE_REPLY_REFERENCE_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	position = P_position;

	if (position < 1) | (position > message.n_reply_references) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	call delete_reference_internal (message.n_reply_references, message.reply_references, position);

	P_code = 0;				/* success */

	return;



/* Actually deletes a reference (called by several entrypoints) */

delete_reference_internal:
     procedure (p_n_references, p_references_ptr, p_position);

dcl  p_n_references fixed binary parameter;
dcl  p_references_ptr pointer parameter;
dcl  p_position fixed binary parameter;
dcl  idx fixed binary;

	message_references_list_ptr = p_references_ptr;
	message_reference_ptr = addr (message_references_list.references (p_position));

	if message_reference.from ^= null () then
	     call mlsys_address_list_mgr_$decrement_reference_count (message_reference.from);

	if addr (message_reference.subject.flags.reserved) -> message_text_field_reserved_flags.free_text then
	     if (message_reference.subject.text_ptr ^= null ())
		& (message_reference.subject.text_ptr ^= addr (NULL_STRING)) then do;
		free message_reference_subject in (mlsys_area);
		message_reference.subject.text_ptr = null ();
	     end;

	do idx = (p_position + 1) to p_n_references;
	     message_references_list.references (idx - 1) = message_references_list.references (idx);
	end;

	message_references_list.n_references, p_n_references = p_n_references - 1;

	return;

     end delete_reference_internal;
%page;
/* Delete the specified user-defined field from the message */

delete_user_field:					/* ... for any type of message */
     entry (P_message_ptr, P_position, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	go to DELETE_USER_FIELD_COMMON;


delete_user_field_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_position, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;


DELETE_USER_FIELD_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	position = P_position;

	if (position < 1) | (position > message.n_user_fields) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	call delete_user_field_internal (position);

	P_code = 0;				/* success */

	return;



/* Actually deletes a user field (called from several entrypoints) */

delete_user_field_internal:
     procedure (p_position);

dcl  p_position fixed binary parameter;
dcl  idx fixed binary;

	message_user_field_ptr = addr (message_user_fields_list.user_fields (p_position));

	if message_user_field.field_type = MESSAGE_TEXT_USER_FIELD then
	     if addr (message_text_user_field.flags.reserved) -> message_text_field_reserved_flags.free_text then
		if (message_text_user_field.text_ptr ^= null ())
		     & (message_text_user_field.text_ptr ^= addr (NULL_STRING)) then do;
		     free message_text_user_field_text in (mlsys_area);
		     message_text_user_field.text_ptr = null ();
		end;
		else ;
	     else ;

	else if message_user_field.field_type = MESSAGE_ADDRESS_LIST_USER_FIELD then
	     if message_address_list_user_field.address_list_ptr ^= null () then
		call mlsys_address_list_mgr_$decrement_reference_count (message_address_list_user_field
		     .address_list_ptr);

	do idx = (p_position + 1) to message.n_user_fields;
	     message_user_fields_list.user_fields (idx - 1) = message_user_fields_list.user_fields (idx);
	end;

	message_user_fields_list.n_user_fields, message.n_user_fields = message.n_user_fields - 1;

	return;

     end delete_user_field_internal;
%page;
/* Replace the message envelope (if any) with the new, supplied envelope */

replace_message_envelope:				/* ... for any type of message */
     entry (P_message_ptr, P_message_envelope_parameter_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;

	message_ptr = copy_ptr (P_message_ptr);
	message_envelope_parameter_ptr = P_message_envelope_parameter_ptr;

	if message_envelope_parameter.version ^= MESSAGE_ENVELOPE_PARAMETER_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	message_envelope_ptr = addr (message_envelope_parameter.envelope);
	if ^verify_envelope (message_envelope_ptr, P_code) then return;

	call delete_envelope (addr (message.envelope));	/* get rid of whatever might be there now */
	call set_envelope (message_envelope_ptr, addr (message.envelope));

	P_code = 0;				/* success */

	return;



/* Copy the data from the caller's message envelope into the specified envelope */

set_envelope:
     procedure (p_source_envelope_ptr, p_target_envelope_ptr);

dcl  1 source_envelope aligned based (p_source_envelope_ptr) like message_envelope;
dcl  p_source_envelope_ptr pointer parameter;

dcl  1 target_envelope aligned based (p_target_envelope_ptr) like message_envelope;
dcl  p_target_envelope_ptr pointer parameter;

	target_envelope = source_envelope;		/* copy the data exactly as it stands */

	if target_envelope.sender ^= null () then do;
	     target_envelope.sender = copy_ptr (target_envelope.sender);
	     call mlsys_address_mgr_$increment_reference_count (target_envelope.sender);
	end;

	if source_envelope.trace ^= null () then call set_trace (source_envelope.trace, target_envelope.trace);

	if target_envelope.delivered_by ^= null () then do;
	     target_envelope.delivered_by = copy_ptr (target_envelope.delivered_by);
	     call mlsys_address_mgr_$increment_reference_count (target_envelope.delivered_by);
	end;

	if target_envelope.acknowledge_to ^= null () then do;
	     target_envelope.acknowledge_to = copy_ptr (target_envelope.acknowledge_to);
	     call mlsys_address_mgr_$increment_reference_count (target_envelope.acknowledge_to);
	end;

	return;



/* Internal to set_envelope: copy the caller's message_trace */

set_trace:
	procedure (p_source_trace_ptr, p_target_trace_ptr);

dcl  (p_source_trace_ptr, p_target_trace_ptr) pointer parameter;
dcl  idx fixed binary;

	     message_trace_n_relays = p_source_trace_ptr -> message_trace.n_relays;

	     allocate message_trace in (mlsys_area) set (p_target_trace_ptr);

	     p_target_trace_ptr -> message_trace.version = MESSAGE_TRACE_VERSION_2;
	     p_target_trace_ptr -> message_trace.reserved, p_target_trace_ptr -> message_trace.pad = ""b;

	     address_route_ptr = copy_ptr (p_source_trace_ptr -> message_trace.implicit_route);
	     if address_route_ptr ^= null () then	/* there's an implicit route */
		if mlsys_data_$valid_segments (binary (baseno (address_route_ptr), 18, 0)) then
		     p_target_trace_ptr -> message_trace.implicit_route = address_route_ptr;
		else call mlsys_address_route_mgr_$create_address_route (address_route.relays,
			p_target_trace_ptr -> message_trace.implicit_route);
	     else p_target_trace_ptr -> message_trace.implicit_route = null ();
	     if p_target_trace_ptr -> message_trace.implicit_route ^= null () then
		call mlsys_address_route_mgr_$increment_reference_count (p_target_trace_ptr
		     -> message_trace.implicit_route);

	     do idx = 1 to p_target_trace_ptr -> message_trace.n_relays;
		p_target_trace_ptr -> message_trace.relays (idx) = p_source_trace_ptr -> message_trace.relays (idx);
		if (idx = p_target_trace_ptr -> message_trace.n_relays)
		     &
		     mlsys_nit_interface_$is_local_system (p_target_trace_ptr
		     -> message_trace.relays (idx).receiving_host) then do;
		     p_target_trace_ptr -> message_trace.relays (idx).sending_host =
			mlsys_nit_interface_$get_fully_qualified_name (p_target_trace_ptr
			-> message_trace.relays (idx).sending_host);
		     p_target_trace_ptr -> message_trace.relays (idx).receiving_host =
			mlsys_nit_interface_$get_fully_qualified_name (p_target_trace_ptr
			-> message_trace.relays (idx).receiving_host);
		end;
		else do;
		     p_target_trace_ptr -> message_trace.relays (idx).sending_host =
			translate (p_target_trace_ptr -> message_trace.relays (idx).sending_host, UPPERCASE,
			LOWERCASE);
		     p_target_trace_ptr -> message_trace.relays (idx).receiving_host =
			translate (p_target_trace_ptr -> message_trace.relays (idx).receiving_host, UPPERCASE,
			LOWERCASE);
		end;
		if p_target_trace_ptr -> message_trace.relays (idx).relay_recipient ^= null () then do;
		     p_target_trace_ptr -> message_trace.relays (idx).relay_recipient =
			copy_ptr (p_target_trace_ptr -> message_trace.relays (idx).relay_recipient);
		     call mlsys_address_mgr_$increment_reference_count (p_target_trace_ptr
			-> message_trace.relays (idx).relay_recipient);
		end;
	     end;

	     return;

	end set_trace;

     end set_envelope;



/* Delete the given message envelope by freeing all data it references */

delete_envelope:
     procedure (p_envelope_ptr);

dcl  1 p_envelope aligned based (p_envelope_ptr) like message_envelope;
dcl  p_envelope_ptr pointer parameter;			/* might belong to a redistribution */

	if p_envelope.acknowledge_to ^= null () then
	     call mlsys_address_mgr_$decrement_reference_count (p_envelope.acknowledge_to);

	if p_envelope.delivered_by ^= null () then
	     call mlsys_address_mgr_$decrement_reference_count (p_envelope.delivered_by);

	if p_envelope.trace ^= null () then call delete_trace (p_envelope.trace);

	if p_envelope.sender ^= null () then call mlsys_address_mgr_$decrement_reference_count (p_envelope.sender);

	return;



/* Internal to delete_envelope: delete a message trace and all referenced substructure */

delete_trace:
	procedure (p_trace_ptr);

dcl  p_trace_ptr pointer parameter;
dcl  idx fixed binary;

	     message_trace_ptr = p_trace_ptr;		/* can't use like because of refer extent */

	     do idx = 1 to message_trace.n_relays;
		if message_trace.relays (idx).relay_recipient ^= null () then
		     call mlsys_address_mgr_$decrement_reference_count (message_trace.relays (idx).relay_recipient);
	     end;

	     if message_trace.implicit_route ^= null () then
		call mlsys_address_route_mgr_$decrement_reference_count (message_trace.implicit_route);

	     free message_trace in (mlsys_area);
	     p_trace_ptr = null ();			/* it's gone now */

	     return;

	end delete_trace;

     end delete_envelope;
%page;
/* Replace the From field of the message with the supplied address list */

replace_from_no_copy:				/* ... for any type of message */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.from, P_address_list_ptr, "0"b, P_code);
	return;


replace_from_new:					/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.from, P_address_list_ptr, "1"b, P_code);
	return;



/* Replace the Reply-To field of the message with the supplied address list */

replace_reply_to_no_copy:				/* ... for any type of message */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.reply_to, P_address_list_ptr, "0"b, P_code);
	return;


replace_reply_to_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.reply_to, P_address_list_ptr, "1"b, P_code);
	return;
%page;
/* Replace the To field of the message with the supplied address list */

replace_to_no_copy:					/* ... for any type of message */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.to, P_address_list_ptr, "0"b, P_code);
	return;


replace_to_new:					/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.to, P_address_list_ptr, "1"b, P_code);
	return;



/* Replace the cc field of the message with the supplied address list */

replace_cc_no_copy:					/* ... for any type of message */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.cc, P_address_list_ptr, "0"b, P_code);
	return;


replace_cc_new:					/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.cc, P_address_list_ptr, "1"b, P_code);
	return;
%page;
/* Replace the bcc field of the message with the supplied address list */

replace_bcc_no_copy:				/* ... for any type of message */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.bcc, P_address_list_ptr, "0"b, P_code);
	return;


replace_bcc_new:					/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_address_list_ptr, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);
	call replace_address_list_field (message.bcc, P_address_list_ptr, "1"b, P_code);
	return;



/* Actually replaces the given address list field (From, Reply-To, To, cc, bcc) in the message */

replace_address_list_field:
     procedure (p_field, p_address_list_ptr, p_copy_address_list, p_code);

dcl  (p_field, p_address_list_ptr) pointer parameter;
dcl  p_copy_address_list bit (1) aligned parameter;	/* ON => make a copy of the caller's address list */
dcl  p_code fixed binary (35) parameter;

	if p_address_list_ptr = null () then do;	/* caller wants the new value of the field to be empty */
	     call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, address_list_ptr,
		p_code);
	     if p_code ^= 0 then return;
	end;
	else do;
	     if ^mlsys_address_list_mgr_$verify_address_list (p_address_list_ptr, p_code) then return;
	     if p_copy_address_list then do;
		call mlsys_address_list_mgr_$copy_address_list (p_address_list_ptr, address_list_ptr, p_code);
		if p_code ^= 0 then return;
	     end;
	     else address_list_ptr = copy_ptr (p_address_list_ptr);
	end;

	if p_field ^= null () then			/* get rid of the old one ... */
	     call mlsys_address_list_mgr_$decrement_reference_count (p_field);

	p_field = address_list_ptr;
	call mlsys_address_list_mgr_$set_read_only (p_field);
	call mlsys_address_list_mgr_$increment_reference_count (p_field);

	p_code = 0;				/* success */

	return;

     end replace_address_list_field;
%page;
/* Replace the subject of the message with the supplied text */

replace_subject:					/* ... for any type of message */
     entry (P_message_ptr, P_subject, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_subject = "1"b;
	go to REPLACE_SUBJECT_COMMON;


replace_subject_no_copy:				/* ... for any type of message: subject text in our ring */
     entry (P_message_ptr, P_subject, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_subject = "0"b;
	go to REPLACE_SUBJECT_COMMON;


replace_subject_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_subject, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	copy_subject = "1"b;
	go to REPLACE_SUBJECT_COMMON;


REPLACE_SUBJECT_COMMON:
	message_ptr = copy_ptr (P_message_ptr);

	if addr (message.subject.flags.reserved) -> message_text_field_reserved_flags.free_text then
	     if (message.subject.text_ptr ^= null ()) & (message.subject.text_ptr ^= addr (NULL_STRING)) then do;
		free message_subject in (mlsys_area);
		message.subject.text_ptr = null ();
	     end;

	string (message.subject.flags) = ""b;		/* turns off both multiline_text & free_text */

	if length (P_subject) = 0 then do;		/* new subject is empty */
	     message.subject.text_ptr = addr (NULL_STRING);
	     message.subject.text_lth = 0;
	end;

	else if copy_subject then do;			/* copy the caller's subject */
COPY_SUBJECT_TEXT:
	     call normalize_single_line_field (P_subject, message.subject.text_ptr, message.subject.text_lth);
	     addr (message.subject.flags.reserved) -> message_text_field_reserved_flags.free_text = "1"b;
	end;

	else do;					/* copy it only if it's improperly formatted */
	     message.subject.text_ptr = addr (P_subject);
	     message.subject.text_ptr = copy_ptr (message.subject.text_ptr);
	     message.subject.text_lth = length (P_subject);
	     if ^mlsys_data_$valid_segments (binary (baseno (addr (message_subject)), 18, 0)) then
		go to COPY_SUBJECT_TEXT;
	     if search (message_subject, NON_SPACE_WHITESPACE) ^= 0 then go to COPY_SUBJECT_TEXT;
	     if verify (message_subject, SPACE) ^= 1 then go to COPY_SUBJECT_TEXT;
	     if substr (message_subject, length (message_subject), 1) = SPACE then go to COPY_SUBJECT_TEXT;
	     if index (message_subject, SPACE_SPACE) ^= 0 then go to COPY_SUBJECT_TEXT;
	end;

	P_code = 0;				/* success */

	return;
%page;
/* Set the AIM access class of the message:  If the access class is less than or isolated from the user's process
   authorization, this entrypoint will check for ring-1 privilege */

set_access_class_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_access_class, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;

	message_ptr = copy_ptr (P_message_ptr);
	access_class = P_access_class;

	P_code = 0;				/* assume success */

	if aim_check_$greater_or_equal (access_class, get_authorization_ ()) then
	     message.access_class = access_class;	/* access class is OK without privilege */

	else do;					/* user will need ring-1 privilege to send this message */
	     string (user_privileges) = get_privileges_ ();
	     if user_privileges.ring1 then
		message.access_class = access_class;
	     else P_code = error_table_$ai_restricted;
	end;

	return;
%page;
/* Replace the entire message body with the single, new, supplied section */

replace_body:					/* ... for any type of message */
     entry (P_message_ptr, P_message_body_section_parameter_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_section_content = "1"b;
	go to REPLACE_BODY_COMMON;


replace_body_no_copy:				/* ... for any type of message: section content in our ring */
     entry (P_message_ptr, P_message_body_section_parameter_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_section_content = "0"b;
	go to REPLACE_BODY_COMMON;


replace_body_new:					/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_message_body_section_parameter_ptr, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	copy_section_content = "1"b;


REPLACE_BODY_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	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 ^verify_body_section (addr (message_body_section_parameter.section), P_code) then return;

	/*** Delete the entire old body */
	do idx = message.n_body_sections to 1 by -1;
	     call delete_body_section_internal (idx);
	end;

	position = 1;				/* since there's nothing else left now */
	message_body_section_ptr = addr (message_body_section_parameter.section);
	call add_body_section_internal ();

	if message_reserved_data.type = NEW_MESSAGE then	/* record date/time of latest change to message body */
	     message_reserved_data.info_ptr -> new_message_info.date_time_created = clock ();

	P_message_ptr = message_ptr;			/* in case we had to expand message.body_sections */
	P_code = 0;				/* success */

	return;
%page;
/* Replace a section of the message body with the new, supplied section */

replace_body_section:				/* ... for any type of message */
     entry (P_message_ptr, P_position, P_message_body_section_parameter_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_section_content = "1"b;
	go to REPLACE_BODY_SECTION_COMMON;


replace_body_section_no_copy:				/* ... for any type of message: section content in our ring */
     entry (P_message_ptr, P_position, P_message_body_section_parameter_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_section_content = "0"b;
	go to REPLACE_BODY_SECTION_COMMON;


replace_body_section_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_position, P_message_body_section_parameter_ptr, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	copy_section_content = "1"b;


REPLACE_BODY_SECTION_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	position = P_position;
	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 ^verify_body_section (addr (message_body_section_parameter.section), P_code) then return;

	if (position < 1) | (position > message.n_body_sections) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	call delete_body_section_internal (position);	/* get rid of the old one ... */
	message_body_section_ptr = addr (message_body_section_parameter.section);
	call add_body_section_internal ();		/* ... and put in the new one */

	if message_reserved_data.type = NEW_MESSAGE then	/* record date/time of latest change to message body */
	     message_reserved_data.info_ptr -> new_message_info.date_time_created = clock ();

	P_message_ptr = message_ptr;			/* in case we had to expand message.body_sections */
	P_code = 0;				/* success */

	return;
%page;
/* Replace a redistribution in the message's redistributions list with the new, supplied redistribution */

replace_redistribution:				/* ... for any type of message */
     entry (P_message_ptr, P_position, P_message_redistribution_parameter_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_redistribution_data = "1"b;
	go to REPLACE_REDISTRIBUTION_COMMON;


replace_redistribution_no_copy:			/* ... for any type of message; data already in our ring */
     entry (P_message_ptr, P_position, P_message_redistribution_parameter_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_redistribution_data = "0"b;


REPLACE_REDISTRIBUTION_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	position = P_position;
	message_redistribution_parameter_ptr = P_message_redistribution_parameter_ptr;

	if message_redistribution_parameter.version ^= MESSAGE_REDISTRIBUTION_PARAMETER_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if ^verify_redistribution (addr (message_redistribution_parameter.redistribution), P_code) then return;

	if (position < 1) | (position > message.n_redistributions) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	call delete_redistribution_internal (position);	/* get rid of the old one ... */
	message_redistribution_ptr = addr (message_redistribution_parameter.redistribution);
	call add_redistribution_internal ();		/* ... and add the new one */

	P_code = 0;				/* success */

	return;
%page;
/* Replace a message reference in the message's list of reply references with the new, supplied message reference */

replace_reply_reference:				/* ... for any type message */
     entry (P_message_ptr, P_position, P_message_reference_parameter_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_reference_data = "1"b;
	go to REPLACE_REPLY_REFERENCE_COMMON;


replace_reply_reference_no_copy:			/* ... for any type message: data already in our ring */
     entry (P_message_ptr, P_position, P_message_reference_parameter_ptr, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_reference_data = "0"b;
	go to REPLACE_REPLY_REFERENCE_COMMON;


replace_reply_reference_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_position, P_referenced_message_ptr, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	if ^verify_im_message_internal (P_referenced_message_ptr, P_code) then return;
	copy_reference_data = "0"b;			/* it's already in the right place from in-mailbox message */

	message_ptr = copy_ptr (P_referenced_message_ptr);/* need to access the original message temporarily */
	message_reference_parameter_ptr = addr (local_mrfp);
	message_reference_parameter.reference.message_id = message.message_id;
	message_reference_parameter.reference.date_time_created = message.date_time_created;
	message_reference_parameter.reference.from = message.from;
	message_reference_parameter.reference.subject = message.subject;
	go to REPLACE_REPLY_REFERENCE_NO_RP_CHECK;


REPLACE_REPLY_REFERENCE_COMMON:
	message_reference_parameter_ptr = P_message_reference_parameter_ptr;
	if message_reference_parameter.version ^= MESSAGE_REFERENCE_PARAMETER_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;
	if ^verify_reference (addr (message_reference_parameter.reference), P_code) then return;

REPLACE_REPLY_REFERENCE_NO_RP_CHECK:
	message_ptr = copy_ptr (P_message_ptr);
	position = P_position;

	if (position < 1) | (position > message.n_reply_references) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	/*** Check for duplicate reply references (except, of course, for the one about to be deleted) */
	do idx = 1 to (position - 1), (position + 1) to message.n_reply_references;
	     if message.reply_references -> message_references_list.references (idx).message_id
		= message_reference_parameter.reference.message_id then do;
		P_position = idx;			/* let caller know where the duplicate resides */
		P_code = mlsys_et_$duplicate_reply_reference;
		return;
	     end;
	end;

	call delete_reference_internal (message.n_reply_references, message.reply_references, position);
	message_reference_ptr = addr (message_reference_parameter.reference);
	call add_reference_internal (message.n_reply_references, message.reply_references);

	P_code = 0;				/* success */

	return;
%page;
/* Replace a user-defined field in the message with the new, supplied user-defined field */

replace_user_field:					/* ... for any type of message */
     entry (P_message_ptr, P_position, P_message_user_field_parameter_ptr, P_allow_duplicates, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_user_field_content = "1"b;
	go to REPLACE_USER_FIELD_COMMON;


replace_user_field_no_copy:				/* ... for any type of message: data already in our ring */
     entry (P_message_ptr, P_position, P_message_user_field_parameter_ptr, P_allow_duplicates, P_code);

	if ^verify_message_internal (P_message_ptr, P_code) then return;
	copy_user_field_content = "0"b;
	go to REPLACE_USER_FIELD_COMMON;


replace_user_field_new:				/* ... for a new message: target of user-ring gate */
     entry (P_message_ptr, P_position, P_message_user_field_parameter_ptr, P_allow_duplicates, P_code);

	if ^verify_new_message_internal (P_message_ptr, P_code) then return;
	copy_user_field_content = "1"b;


REPLACE_USER_FIELD_COMMON:
	message_ptr = copy_ptr (P_message_ptr);
	position = P_position;
	message_user_field_parameter_ptr = P_message_user_field_parameter_ptr;

	if message_user_field_parameter.version ^= MESSAGE_USER_FIELD_PARAMETER_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if ^verify_user_field (addr (message_user_field_parameter.user_field), P_code) then return;

	if (position < 1) | (position > message.n_user_fields) then do;
	     P_code = error_table_$bad_index;
	     return;
	end;

	/*** Check for duplicate fields if requested */
	if ^P_allow_duplicates then do;
	     do idx = 1 to (position - 1), (position + 1) to message.n_user_fields;
		if message_user_fields_list.user_fields (idx).field_id
		     = message_user_field_parameter.user_field.field_id then do;
		     P_position = idx;		/* let caller know where the duplicate resides */
		     P_code = mlsys_et_$duplicate_user_field;
		     return;
		end;
	     end;
	end;

	call delete_user_field_internal (position);	/* delete the old one ... */
	message_user_field_ptr = addr (message_user_field_parameter.user_field);
	call add_user_field_internal ();		/* ... and add the new one */

	P_code = 0;				/* success */

	return;
%page;
/* Verify that the caller supplied a message structure */

verify_message:
     entry (P_message_ptr, P_date_time_created, P_code) returns (bit (1) aligned);

	if verify_message_internal (P_message_ptr, P_code) then do;
						/* this call will set the status code */
	     if addr (P_message_ptr -> message.reserved) -> message_reserved_data.type = NEW_MESSAGE then
		P_date_time_created =
		     addr (P_message_ptr -> message.reserved) -> message_reserved_data.info_ptr
		     -> new_message_info.date_time_created;
	     else P_date_time_created = P_message_ptr -> message.date_time_created;
	     return ("1"b);
	end;

	else return ("0"b);



/* Actually verifies a message */

verify_message_internal:
     procedure (p_message_ptr, p_code) returns (bit (1) aligned);

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

	if p_message_ptr = null () then p_code = mlsys_et_$not_message;

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

	else if p_message_ptr -> message.version ^= MESSAGE_VERSION_2 then p_code = mlsys_et_$not_message;
						/* not an message structure */

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

	return ((p_code = 0));

     end verify_message_internal;
%page;
/* Verify that the caller supplied a pointer to a properly constructed message structure which is an in-mailbox message */

verify_im_message:
     entry (P_message_ptr, P_im_message_info_ptr, P_code) returns (bit (1) aligned);

	if verify_im_message_internal (P_message_ptr, P_code) then do;
						/* above call will set the status code */
	     P_im_message_info_ptr =
		copy_ptr (addr (P_message_ptr -> message.reserved) -> message_reserved_data.info_ptr);
	     return ("1"b);
	end;

	else return ("0"b);



/* Actually verifies an in-mailbox message */

verify_im_message_internal:
     procedure (p_message_ptr, p_code) returns (bit (1) aligned);

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

	if ^verify_message_internal (p_message_ptr, p_code) then ;
						/* not a message */

	else if addr (p_message_ptr -> message.reserved) -> message_reserved_data.type ^= IN_MAILBOX_MESSAGE then
	     p_code = mlsys_et_$not_in_mailbox_message;	/* not an in-mailbox message */

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

	return ((p_code = 0));

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

verify_new_message:
     entry (P_message_ptr, P_date_time_created, P_code) returns (bit (1) aligned);

	if verify_new_message_internal (P_message_ptr, P_code) then do;
						/* above call will set the status code */
	     P_date_time_created =
		addr (P_message_ptr -> message.reserved) -> message_reserved_data.info_ptr
		-> new_message_info.date_time_created;
	     return ("1"b);
	end;

	else return ("0"b);



/* Actually verifies a new message */

verify_new_message_internal:
     procedure (p_message_ptr, p_code) returns (bit (1) aligned);

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

	if ^verify_message_internal (p_message_ptr, p_code) then ;
						/* not a message */

	else if addr (p_message_ptr -> message.reserved) -> message_reserved_data.type ^= NEW_MESSAGE then
	     p_code = mlsys_et_$not_new_message;	/* not a message which user-ring can modify */

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

	return ((p_code = 0));

     end verify_new_message_internal;
%page;
/* Verify the the supplied message trace contains valid data */

verify_trace:
     procedure (p_trace_ptr, p_code) returns (bit (1) aligned);

dcl  p_trace_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;
dcl  ignore bit (1) aligned;
dcl  idx fixed binary;

	if p_trace_ptr -> message_trace.version ^= MESSAGE_TRACE_VERSION_2 then
	     p_code = error_table_$unimplemented_version;

	else do;
	     p_code = 0;				/* assume success for now */

	     if p_trace_ptr -> message_trace.implicit_route ^= null () then
		if p_trace_ptr -> message_trace.implicit_route -> address_route.version ^= ADDRESS_ROUTE_VERSION_1
		then p_code = error_table_$unimplemented_version;

	     do idx = 1 to p_trace_ptr -> message_trace.n_relays while (p_code = 0);
		if p_trace_ptr -> message_trace.relays (idx).relay_recipient ^= null () then
		     ignore =
			mlsys_address_mgr_$verify_address (p_trace_ptr
			-> message_trace.relays (idx).relay_recipient, p_code);
	     end;
	end;

	return ((p_code = 0));

     end verify_trace;
%page;
/* Verify that the supplied message envelope contains valid data */

verify_envelope:
     procedure (p_envelope_ptr, p_code) returns (bit (1) aligned);

dcl  1 envelope aligned based (p_envelope_ptr) like message_envelope;
dcl  p_envelope_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;
dcl  ignore bit (1) aligned;

	if envelope.sender ^= null () then ignore = mlsys_address_mgr_$verify_address (envelope.sender, p_code);

	if (p_code = 0) & (envelope.trace ^= null ()) then ignore = verify_trace (envelope.trace, p_code);

	if (p_code = 0) & (envelope.delivered_by ^= null ()) then
	     ignore = mlsys_address_mgr_$verify_address (envelope.delivered_by, p_code);

	if (p_code = 0) & (envelope.acknowledge_to ^= null ()) then
	     ignore = mlsys_address_mgr_$verify_address (envelope.acknowledge_to, p_code);

	return ((p_code = 0));

     end verify_envelope;



/* Verify that the supplied message redistribution contains valid data */

verify_redistribution:
     procedure (p_redistribution_ptr, p_code) returns (bit (1) aligned);

dcl  1 redistribution aligned based (p_redistribution_ptr) like message_redistribution;
dcl  p_redistribution_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;
dcl  ignore bit (1) aligned;

	ignore = verify_envelope (addr (redistribution.envelope), p_code);

	if (p_code = 0) & (redistribution.from ^= null ()) then
	     ignore = mlsys_address_list_mgr_$verify_address_list (redistribution.from, p_code);

	if (p_code = 0) & (redistribution.to ^= null ()) then
	     ignore = mlsys_address_list_mgr_$verify_address_list (redistribution.to, p_code);

	return ((p_code = 0));

     end verify_redistribution;
%page;
/* Verify that the supplied user-defined field contains valid data */

verify_user_field:
     procedure (p_user_field_ptr, p_code) returns (bit (1) aligned);

dcl  1 user_field aligned based (p_user_field_ptr) like message_user_field;
dcl  1 address_list_user_field aligned based (p_user_field_ptr) like message_address_list_user_field;
dcl  p_user_field_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;
dcl  ignore bit (1) aligned;

	call mlsys_field_id_mgr_$get_user_field_name (user_field.field_id, (""), p_code);
	if p_code = error_table_$smallarg then p_code = 0;/* the ID is OK: we didn't supply space for the name */

	if (p_code = 0)
	     & ((user_field.field_type < MESSAGE_TEXT_USER_FIELD)
	     | (user_field.field_type > MESSAGE_INTEGER_USER_FIELD)) then
	     p_code = mlsys_et_$unknown_user_field_type;

	if (p_code = 0) & (user_field.field_type = MESSAGE_ADDRESS_LIST_USER_FIELD) then
	     if address_list_user_field.address_list_ptr ^= null () then
		ignore =
		     mlsys_address_list_mgr_$verify_address_list (address_list_user_field.address_list_ptr, p_code);

	return ((p_code = 0));

     end verify_user_field;



/* Verify that the supplied message reference contains valid data */

verify_reference:
     procedure (p_reference_ptr, p_code) returns (bit (1) aligned);

dcl  1 reference aligned based (p_reference_ptr) like message_reference;
dcl  p_reference_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;
dcl  ignore bit (1) aligned;

	if reference.from ^= null () then
	     ignore = mlsys_address_list_mgr_$verify_address_list (reference.from, p_code);

	else p_code = 0;				/* looks OK */

	return ((p_code = 0));

     end verify_reference;
%page;
/* Verify that the supplied body section contains valid data */

verify_body_section:
     procedure (p_body_section_ptr, p_code) returns (bit (1) aligned);

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

	if (p_body_section_ptr -> message_body_section.section_type < MESSAGE_PREFORMATTED_BODY_SECTION)
	     | (p_body_section_ptr -> message_body_section.section_type > MESSAGE_BIT_STRING_BODY_SECTION) then
	     p_code = mlsys_et_$unknown_body_section_type;

	else p_code = 0;				/* it passes */

	return ((p_code = 0));

     end verify_body_section;
%page;
/* Computes the position where to add a body section, redistribution, etc.:  If the input position is positive, the object
   is added at the given position (ie: if input position is 1, the object is added at the front of the list); if the input
   position is negative, it is added at the given position from the end (ie: if input position is -1, the object is made
   the last one in the list) */

compute_position_for_add:
     procedure (p_input_position, p_n_in_list, p_actual_position);

dcl  (p_input_position, p_n_in_list, p_actual_position) fixed binary parameter;

	if p_input_position = 0 then			/* a position of zero is equivalent to a value of 1 */
	     p_actual_position = 1;

	else if p_input_position > 0 then		/* add it at the given position from the beginning */
	     p_actual_position = min (p_input_position, (p_n_in_list + 1));

	else /*** if p_input_position < 0 then */
	     p_actual_position = max (1, (p_n_in_list + p_input_position + 2));
						/* add it at the given position from the end */

	return;

     end compute_position_for_add;
%page;
/* 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;
/* Convert a text field which must be a single line into its canonical form: translate all whitespace in the text to
   spaces, strip leading and trailing whitespace, and compress all multi-character sequences of whitespace into a single
   space */

normalize_single_line_field:
     procedure (p_text, p_text_ptr, p_text_lth) options (non_quick);

dcl  p_text character (*) unaligned parameter;
dcl  p_text_ptr pointer parameter;
dcl  p_text_lth fixed binary (21) parameter;

dcl  work_string character (work_string_lth) varying based (work_string_ptr);
dcl  work_string_ptr pointer;
dcl  work_string_lth fixed binary (21);

dcl  result_string character (length (work_string)) unaligned based (result_string_ptr);
dcl  result_string_ptr pointer;

dcl  idx fixed binary (21);


	work_string_lth = length (p_text);

	work_string_ptr = null ();			/* for cleanup handler */
	on condition (cleanup)
	     begin;
		if work_string_ptr ^= null () then
		     if baseno (work_string_ptr) ^= baseno (stackframeptr ()) then
			call mlsys_storage_mgr_$release_temp_segment (work_string_ptr, (0));
	     end;

	if work_string_lth > MAX_STACK_EXTENSION then do; /* too big for the stack */
	     call mlsys_storage_mgr_$get_temp_segment (work_string_ptr, code);
	     if code ^= 0 then call abort_normalize_field (code);
	end;
	else call cu_$grow_stack_frame ((divide ((work_string_lth + 3), 4, 18, 0) + 1), work_string_ptr, (0));

	work_string = ltrim (rtrim (translate (p_text, "", NON_SPACE_WHITESPACE)));
						/* strips leading/trailing whitespace leaving just spaces */

	idx = index (work_string, SPACE_SPACE);		/* need do until ... */
	do while (idx ^= 0);
	     work_string = substr (work_string, 1, idx) || substr (work_string, (idx + 2));
	     idx = index (work_string, SPACE_SPACE);
	end;

	allocate result_string in (mlsys_area) set (result_string_ptr);
	result_string = work_string;

	if baseno (work_string_ptr) ^= baseno (stackframeptr ()) then
	     call mlsys_storage_mgr_$release_temp_segment (work_string_ptr, (0));

	p_text_ptr = addr (result_string);		/* tell the caller where it is ... */
	p_text_lth = length (work_string);		/* ... and how long it is */

	return;

     end normalize_single_line_field;
%page;
/* Convert a multiline text field (or body section) to its canonical form:  The canonical form of a multiline field is
   simply the text of said field with all horizontal tabs expanded into the appropriate number of spaces */

normalize_multiline_field:
     procedure (p_text, p_text_ptr, p_text_lth) options (non_quick);

dcl  p_text character (*) parameter;
dcl  p_text_ptr pointer parameter;
dcl  p_text_lth fixed binary (21);

dcl  work_string character (work_string_lth) unaligned based (work_string_ptr);
dcl  (work_string_lth, work_string_used) fixed binary (21);
dcl  work_string_ptr pointer;

dcl  result_string character (work_string_used) unaligned based (result_string_ptr);
dcl  result_string_ptr pointer;

dcl  the_character character (1) aligned;
dcl  (text_used, column, n_spaces, idx) fixed binary (21);
dcl  stack_increment fixed binary (18);


	stack_increment = 16 * divide ((divide ((length (p_text) + 3), 4, 18, 0) + 15), 16, 18, 0);

	work_string_lth = 4 * stack_increment;		/* initial work space ... */
	work_string_used = 0;			/* ... isn't used yet */

	work_string_ptr = null ();			/* for cleanup handler */
	on condition (cleanup)
	     begin;
		if work_string_ptr ^= null () then
		     if baseno (work_string_ptr) ^= baseno (stackframeptr ()) then
			call mlsys_storage_mgr_$release_temp_segment (work_string_ptr, (0));
	     end;

	if work_string_lth > MAX_STACK_EXTENSION then do;
	     call mlsys_storage_mgr_$get_temp_segment (work_string_ptr, code);
	     if code ^= 0 then call abort_normalize_field (code);
	     work_string_lth = 4 * sys_info$max_seg_size;
	end;
	else call cu_$grow_stack_frame (stack_increment, work_string_ptr, (0));

	column = 1;				/* where we are right now */
	text_used = 0;

	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 = verify (rest_of_text, SINGLE_WIDTH_CHARACTERS);
		if idx = 0 then idx = length (rest_of_text) + 1;

		call add_to_work_string (addr (rest_of_text), (idx - 1));
		column = column + idx - 1;		/* update where we are */
		text_used = text_used + idx - 1;
	     end;

	     if text_used < length (p_text) then do;	/* we did find a special character */
		the_character = substr (p_text, (text_used + 1), 1);
		text_used = text_used + 1;

		if the_character = HT then do;	/* a tab: we must change it to spaces ... */
		     if mod (column, 10) = 0 then	/* ... at the column just before a tab stop ... */
			n_spaces = 1;		/* ... the following computation fails */
		     else n_spaces = 11 - mod (column, 10);
		     call add_to_work_string (addr (TEN_SPACES), n_spaces);
		     column = column + n_spaces;
		end;

		else do;				/* some other special char */
		     call add_to_work_string (addr (the_character), 1);
		     if the_character = BS then column = max ((column - 1), 1);
		     else if (the_character = NL) | (the_character = CR) | (the_character = VT) | (the_character = FF)
		     then column = 1;
		     else ;			/* ... all others are non-printing */
		end;
	     end;
	end;

	allocate result_string in (mlsys_area) set (result_string_ptr);
	result_string = substr (work_string, 1, work_string_used);

	if baseno (work_string_ptr) ^= baseno (stackframeptr ()) then
	     call mlsys_storage_mgr_$release_temp_segment (work_string_ptr, (0));

	p_text_ptr = addr (result_string);		/* tell caller where it is ... */
	p_text_lth = length (result_string);		/* ... and how long it is */

	return;



/* Internal to normalize_multiline_field: adds a piece of text to the work string, expanding it if necessary */

add_to_work_string:
	procedure (p_piece_ptr, p_piece_lth);

dcl  p_piece character (p_piece_lth) unaligned based (p_piece_ptr);
dcl  p_piece_ptr pointer parameter;
dcl  p_piece_lth fixed binary (21) parameter;

	     if (work_string_used + p_piece_lth) > work_string_lth then do;
		if baseno (work_string_ptr) ^= baseno (stackframeptr ()) then
		     call abort_normalize_field (mlsys_et_$message_too_large);
		else if (work_string_used + p_piece_lth) > MAX_STACK_EXTENSION then do;
		     call mlsys_storage_mgr_$get_temp_segment (work_string_ptr, code);
		     if code ^= 0 then call abort_normalize_field (code);
		     work_string_lth = 4 * sys_info$max_seg_size;
		end;
		else do;
		     do while (work_string_lth < (work_string_used + p_piece_lth));
			call cu_$grow_stack_frame (stack_increment, (null ()), (0));
			work_string_lth = work_string_lth + (4 * stack_increment);
		     end;
		end;
	     end;

	     substr (work_string, (work_string_used + 1), p_piece_lth) = p_piece;
	     work_string_used = work_string_used + p_piece_lth;

	     return;

	end add_to_work_string;

     end normalize_multiline_field;



/* Aborts a call to either normalize_single_line_field or normalize_multiline_field by aborting the entire operation */

abort_normalize_field:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	P_code = p_code;				/* set caller's status code */
	go to ABORT_THE_OPERATION;

     end abort_normalize_field;

ABORT_THE_OPERATION:
	return;
%page;
%include mlsys_copy_ptr;
%page;
%include mlsys_message;
%page;
%include mlsys_address_list;
%page;
%include mlsys_address_route;
%page;
%include mlsys_internal_data;
%page;
%include aim_template;
%page;
/* Various whitespace constants are placed here as they generate so many blank pages ... */

dcl  VT character (1) static options (constant) initial ("");
dcl  FF character (1) static options (constant) initial ("");

dcl  NON_SPACE_WHITESPACE character (4) static options (constant) initial ("	
");						/* horizontal tab, newline, vertical tab, formfeed */

     end mlsys_message_mgr_;




		    mlsys_misc_utils_.pl1           12/31/99  2057.2r w 12/31/99  2057.2      772308



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



/****^  HISTORY COMMENTS:
  1) change(85-12-19,Herbst), approve(86-03-25,MCR7367),
     audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059):
     Changed $print_message_summary to include "S" column for seen messages.
  2) change(89-03-16,Vu), approve(89-03-16,MCR8071), audit(89-03-31,Flegel),
     install(89-04-24,MR12.3-1032):
     Changed $print_message_summary to display proper line counter for a
     piece of mail containing more than 9999 lines.
  3) change(89-06-26,Lee), approve(89-07-11,MCR8119),
     audit(89-08-03,LZimmerman), install(89-10-02,MR12.3-1079):
     phx19187 (Mail 458) - modified print_message_summary/
     print_message_summary_header to drop subject and lines fields if
     necessary to properly handle short lines; it fixes out_of_bounds
     condition for line_lengths less than 15.
  4) change(99-12-31,Schroth), approve(99-12-31,MECR-Y2K):
     Correct size condition in year formating for message list.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Miscellaneous Mail System Utilities */

/* Created:  July 1983 by G. Palter */
/* Modified: March 1984 by G. Palter to fix the following mail system errors:
      #0435 -- the error message displayed by send_mail when the target address of a mail table entry is invalid only
         includes the name of the mail table entry.  The actual invalid address (eg: mailbox pathname) is not included
      #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
      #0438 -- the primitives which allow a user to replace the address list portions of a message
         (eg: mail_system_$replace_from, mail_system_$replace_user_field) should not make the user's copy of the address
         list read-only.  Instead, they should copy the user's list to allow the user to continue to modify the list if
         desired for later additional use */

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


mlsys_misc_utils_:
     procedure ();

	return;


/* Parameters */

dcl  P_code fixed binary (35) parameter;

dcl  P_message_ptr pointer parameter;			/* print_message_summary, search_message: -> the message;
						   create_reply_message: set -> the newly created message */

dcl  P_address_ptr pointer parameter;			/* get_best_address_name, summarize_address,
						   print_validate_results: -> the address */

dcl  P_address_string character (*) varying parameter;	/* get_best_address_name: set to the best possible name;
						   summarize_address: set to the address summary suitable for
						      use in sentences */

dcl  P_is_start_of_sentence bit (1) aligned parameter;	/* summarize_address: ON => format the output assuming it will
						      be at the beginning of a sentence */

dcl  P_line_length fixed binary parameter;		/* print_message_summary_*: line length used for truncation */
dcl  P_output_switch pointer parameter;			/* print_message_summary_*: the I/O switch for printing */

dcl  P_message_number fixed binary parameter;		/* print_message_summary: # to be printed for this message */
dcl  P_is_current_message bit (1) aligned parameter;	/* print_message_summary: ON => mark as the current message */

dcl  P_recipients_info_ptr pointer parameter;		/* print_delivery_results, free_delivery_recipients: -> the
						      recipients_info structure to be printed/freed */

dcl  P_sci_ptr pointer parameter;			/* print_delivery_results, print_validate_results:
						      -> description of subsystem on whose behalf we are
						      printing the results */

dcl  P_errors_only bit (1) aligned parameter;		/* print_delivery_results: ON => print only error messages */

dcl  P_original_message_ptr pointer parameter;		/* create_reply_message: -> message for which a reply message
						      is to be constructed */
dcl  P_reply_options_ptr pointer parameter;		/* create_reply_message: -> options describing how the message
						      is to be created */

dcl  P_search_string character (*) parameter;		/* search_message: the text to look for in the message */
dcl  P_search_options_ptr pointer parameter;		/* search_message: -> structure defining what/how to search */

dcl  P_author_name character (*) parameter;		/* send_message_to_recipient: optional name to be given to the
						      author of the message instead of the default (if any) */
dcl  P_recipient character (*) parameter;		/* send_message_to_recipient: printed representation of the
						      single recipient's address */
dcl  P_delivery_mode fixed binary parameter;		/* send_message_to_recipient: ordinary/interactive/express */
dcl  P_message_subject character (*) parameter;		/* send_message_to_recipient: optional subject */
dcl  P_message_body character (*) parameter;		/* send_message_to_recipient: the text of the message body */
dcl  P_message_access_class bit (72) aligned parameter;	/* send_message_to_recipient: AIM access class of message */
dcl  P_explanation character (*) varying parameter;	/* send_message_to_recipient: set to any explanation returned
						      by the mail system */
/**** format: indcomtxt */


/* Local copies of parameters */

dcl  code fixed binary (35);

dcl  address_ptr pointer;

dcl  line_length fixed binary;
dcl  output_switch pointer;

dcl  sci_ptr pointer;

dcl  original_message_ptr pointer;


/* Remaining declarations */

dcl  1 result aligned based (result_ptr) like recipients_result_list.results;
dcl  1 other_result aligned based (other_result_ptr) like recipients_result_list.results;
dcl  1 expanded_result aligned based (expanded_result_ptr) like expanded_recipients_result_list.entries;
dcl  (result_ptr, other_result_ptr, expanded_result_ptr) pointer;

dcl  original_subject character (original_subject_lth) unaligned based (original_subject_ptr);
dcl  original_subject_ptr pointer;
dcl  original_subject_lth fixed binary (21);

dcl  the_subject character (the_subject_lth) unaligned based (the_subject_ptr);
dcl  the_subject_ptr pointer;
dcl  the_subject_lth fixed binary (21);

dcl  buffer character (buffer_max_lth) unaligned based (buffer_ptr);
dcl  (buffer_ptr, stack_buffer_ptr, segment_buffer_ptr) pointer;
dcl  (buffer_max_lth, stack_buffer_max_lth, segment_buffer_max_lth, buffer_used, buffer_printed) fixed binary (21);

dcl  address_local_variable character (256) varying;
dcl  address_variable character (address_variable_max_lth) varying based (address_variable_ptr);
dcl  address_variable_ptr pointer;
dcl  address_variable_max_lth fixed binary (21);

dcl  users_area area aligned based (users_area_ptr);
dcl  users_area_ptr pointer;

dcl  message_text character (message_lth) unaligned based (message_buffer_ptr);
dcl  message_lth fixed binary (21);
dcl  message_lth_in_words fixed binary (18);
dcl  (message_buffer_ptr, message_canonical_text_ptr, stack_truncation_ptr) pointer;

dcl  search_string character (length (P_search_string)) unaligned based (search_string_ptr);
dcl  (search_string_ptr, translated_search_string_ptr) pointer;

dcl  1 reply_lists aligned,				/* local address lists used to construct the reply message */
       2 to pointer,
       2 cc pointer,
       2 bcc pointer;
dcl  reply_lists_array (3) pointer aligned based (addr (reply_lists));

dcl  1 local_fmo aligned like format_message_options;

dcl  1 local_mbsp aligned like message_body_section_parameter;
dcl  1 local_do aligned like deliver_options;

dcl  1 local_ri aligned,				/* describes one list for send_message_to_recipient */
       2 header like recipients_info.header,
       2 list like recipients_info.lists;

dcl  foreign_system_name character (256) varying;
dcl  address_pathname character (194);
dcl  address_pathname_varying character (194) varying;
dcl  address_dirname character (168);
dcl  (address_ename, address_component) character (32);
dcl  address_type fixed binary;

dcl  (include_author, include_date, include_time, include_subject, include_lines) bit (1) aligned;

dcl  (month, day_of_month, year, hour, minute) fixed binary;
dcl  ten_digits_picture picture "zzzzzzzzz9";
dcl  two_digits_picture picture "99";

dcl  (address_name_max_lth, subject_string_lth) fixed binary (21);

dcl  author_string character (17) varying;
dcl  date_string character (8);
dcl  n_lines_string character (10) varying;
dcl  time_string character (5);
dcl  (ack_flag, current_message_flag, delete_flag, forwarded_flag, seen_flag) character (1);

dcl  use_original_subject bit (1) aligned;
dcl  (list_idx, address_idx, n_duplicates, n_duplicates_processed, expanded_idx, idx) fixed binary;

dcl  compare_against_both bit (1) aligned;

dcl  translation_table character (512) aligned;
dcl  search_succeeds bit (1) aligned;

dcl  person_id character (32);
dcl  anonymous_flag fixed binary;

dcl  MAIL_SYSTEM_ character (32) static options (constant) initial ("mail_system_");

/* format: off */
dcl (SPACE	initial (" "),
     COMMA	initial (","),
     PERIOD	initial ("."),
     NL		initial ("
"))
	character (1) static options (constant);
/* format: on */

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

dcl  THREE_SPACES character (3) static options (constant) initial ("   ");
dcl  AND_SPACE character (4) static options (constant) initial ("and ");
dcl  ET_AL character (6) static options (constant) initial (" et al");

dcl  REPLY_SUBJECT_PREFIX character (4) static options (constant) initial ("Re: ");

dcl  STACK_EXTENSION fixed binary (18) static options (constant) initial (128);
dcl  BUFFER_STACK_EXTENSION fixed binary (18) static options (constant) initial (1024);

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

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl  iox_$error_output pointer external;
dcl  iox_$user_output pointer external;

/* format: off */
dcl (error_table_$area_too_small, error_table_$bad_subr_arg, error_table_$inconsistent, error_table_$nomatch,
     error_table_$null_info_ptr, error_table_$smallarg, error_table_$unimplemented_version,
     forum_error_table_$no_such_forum, forum_error_table_$not_eligible, forum_error_table_$read_only,
     mlsys_et_$duplicate_address, mlsys_et_$errors_in_list_address, mlsys_et_$invalid_address,
     mlsys_et_$list_address_is_all_duplicates, mlsys_et_$message_delivered, mlsys_et_$message_not_sent,
     mlsys_et_$message_partially_sent, mlsys_et_$message_queued, mlsys_et_$message_queued_and_delivered,
     mlsys_et_$message_too_large, mlsys_et_$mte_not_found, mlsys_et_$no_mailbox, mlsys_et_$no_mailing_list,
     mlsys_et_$no_message_canonical_form, mlsys_et_$not_in_mailbox_message, mlsys_et_$not_message,
     mlsys_et_$null_search_string, mlsys_et_$rejected_by_foreign_system)
	fixed binary (35) external;
/* format: on */

dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  assign_ entry (pointer, fixed binary, fixed binary (35), pointer, fixed binary, fixed binary (35));
dcl  convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned);
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35));
dcl  cu_$shrink_stack_frame entry (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  decode_descriptor_
	entry (pointer, fixed binary, fixed binary, bit (1) aligned, fixed binary, fixed binary, fixed binary);
dcl  find_condition_info_ entry (pointer, pointer, 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  get_system_free_area_ entry () returns (pointer);
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  ioa_$general_rs
	entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1) aligned, bit (1) aligned);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  mail_system_$add_address entry (pointer, pointer, character (8), fixed binary (35));
dcl  mail_system_$add_reply_reference entry (pointer, pointer, fixed binary, fixed binary (35));
dcl  mail_system_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mail_system_$create_mail_table_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_message entry (character (8), pointer, fixed binary (35));
dcl  mail_system_$delete_address entry (pointer, fixed binary, fixed binary (35));
dcl  mail_system_$deliver_message entry (pointer, pointer, pointer, fixed binary (35));
dcl  mail_system_$eliminate_duplicate_addresses entry ((*) pointer, fixed binary (35));
dcl  mail_system_$free_address entry (pointer, fixed binary (35));
dcl  mail_system_$free_address_list entry (pointer, fixed binary (35));
dcl  mail_system_$free_message entry (pointer, 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_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_mail_table_address entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$merge_address_lists entry (pointer, pointer, bit (1) aligned, pointer, fixed binary (35));
dcl  mail_system_$read_message_canonical_form_p entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  mail_system_$replace_bcc entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$replace_body entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$replace_cc entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$replace_from entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$replace_subject entry (pointer, character (*), fixed binary (35));
dcl  mail_system_$replace_to entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$set_access_class entry (pointer, bit (72) aligned, fixed binary (35));
dcl  mlsys_psp_$forum_not_available entry () returns (bit (1) aligned);
dcl  mlsys_utils_$format_address_field
	entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (21), fixed binary (21),
	fixed binary (35));
dcl  mlsys_utils_$format_message_canonical_form
	entry (pointer, pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  mlsys_utils_$parse_address_text entry (character (*), pointer, fixed binary (35));
dcl  mvt_ entry (pointer, pointer, fixed binary (21), character (512) aligned);
dcl  mvt_$make_translation_table entry (character (*), character (*), character (512) aligned);
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  pathname_$component entry (character (*), character (*), character (*)) returns (character (194));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  requote_string_ entry (character (*)) returns (character (*));
dcl  search_file_$silent
	entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21),
	fixed binary (21), fixed binary (21), fixed binary (35));
dcl  ssu_$print_message entry () options (variable);
dcl  sub_err_ entry () options (variable);
dcl  user_info_$login_data entry (character (*), character (*), character (*), fixed binary);

dcl  (cleanup, io_error) condition;

dcl  (addr, addwordno, after, baseno, binary, convert, copy, divide, index, length, ltrim, maxlength, min, mod, null,
     reverse, rtrim, stackframeptr, string, substr, translate, verify) builtin;
%page;
/* Obtain the address name or the best possible substitute:  If there is no address name, use the printed representation
   of the address.  If whatever is to be returned is too long for the caller's buffer, indicate this by changing the last
   three characters of the text into an ellipsis */

get_best_address_name:
     entry (P_address_ptr, P_address_string, P_code);

	address_ptr = P_address_ptr;
	address_name_max_lth = maxlength (P_address_string);

	begin;					/* need a local copy (sigh) */

dcl  local_address_name character (address_name_max_lth) varying;

dcl  address_name character (address_name_max_lth) varying based (address_name_ptr);
dcl  address_name_ptr pointer;

dcl  1 fixed_address_name aligned based (address_name_ptr),
       2 lth fixed binary (21),
       2 string character (address_name_max_lth) unaligned;

	     address_name_ptr = addr (local_address_name);

	     call mail_system_$get_address_name (address_ptr, address_name, code);
	     if (code ^= 0) & (code ^= error_table_$smallarg) then do;
		P_code = code;			/* not an address? */
		return;
	     end;

	     if code = error_table_$smallarg then do;	/* too large for the preallocated space ... */
		call cu_$grow_stack_frame (STACK_EXTENSION, address_name_ptr, (0));
		address_name_max_lth = 4 * (STACK_EXTENSION - 1);

		call mail_system_$get_address_name (address_ptr, address_name, 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));
		     address_name_max_lth = address_name_max_lth + (4 * STACK_EXTENSION);
		     call mail_system_$get_address_name (address_ptr, address_name, code);
		end;
	     end;

	     if length (address_name) = 0 then do;	/* no name: use printed representation */
		fixed_address_name.lth = 0;
		call mlsys_utils_$format_address_field ("", address_ptr, -1, addr (fixed_address_name.string),
		     address_name_max_lth, fixed_address_name.lth, code);
		if code = error_table_$smallarg then do;/* ... as much as would is actually there */
		     fixed_address_name.lth = address_name_max_lth;
		     substr (fixed_address_name.string, (address_name_max_lth - 2), 3) = "...";
		end;
	     end;

	     if length (address_name) > maxlength (P_address_string) then
		P_address_string = substr (address_name, 1, (maxlength (P_address_string) - 3)) || "...";
	     else P_address_string = address_name;
	end;

	P_code = 0;				/* success */

	return;
%page;
/**** format: ^indcomtxt */
/* Returns a description of the given address suitable for use in error messages, etc:  Examples of the output produced by
   this entrypoint include:
		Palter.Multics
		your logbox
		the mailing list >udd>m>gmp>mail_project
		the group named Mail System Maintainers */
/**** format: indcomtxt */

summarize_address:
     entry (P_address_ptr, P_is_start_of_sentence, P_address_string, P_code);

	address_ptr = P_address_ptr;

	call mail_system_$get_address_type (address_ptr, address_type, code);
	if code ^= 0 then do;			/* not an address? */
	     P_code = code;
	     return;
	end;

	begin;					/* temporary is 1 larger than caller's to detect truncation */

dcl  address_string character (maxlength (P_address_string) + 1) varying;

	     go to SUMMARIZE_ADDRESS (address_type);

SUMMARIZE_ADDRESS (0):				/* invalid address */
	     call get_address_variable (mail_system_$get_address_string);
	     if P_is_start_of_sentence then
		address_string = "The invalid address ";
	     else address_string = "the invalid address ";
	     address_string = address_string || requote_string_ ((address_variable));
	     go to END_SUMMARIZE_ADDRESS_CASE;


SUMMARIZE_ADDRESS (1):				/* user mailbox address */
	     call get_address_variable (mail_system_$get_address_string);
	     address_string = address_variable;
	     go to END_SUMMARIZE_ADDRESS_CASE;


SUMMARIZE_ADDRESS (2):				/* logbox address */
	     if mail_system_$compare_addresses (address_ptr, mlsys_data_$user_logbox_address, (0)) then do;
		if P_is_start_of_sentence then
		     address_string = "Your logbox";
		else address_string = "your logbox";
		go to END_SUMMARIZE_ADDRESS_CASE;
	     end;
	     /*** Not the user's logbox: treat it as a random savebox */


SUMMARIZE_ADDRESS (3):				/* savebox address */
	     call mail_system_$get_address_pathname (address_ptr, address_dirname, address_ename, ((32)" "), (0));
	     address_pathname = pathname_ (address_dirname, address_ename);
	     if P_is_start_of_sentence then
		address_string = "The savebox ";
	     else address_string = "the savebox ";
	     address_string = address_string || reverse (after (reverse (address_pathname), reverse (".sv.mbx")));
	     go to END_SUMMARIZE_ADDRESS_CASE;


SUMMARIZE_ADDRESS (4):				/* mailbox address */
	     call mail_system_$get_address_pathname (address_ptr, address_dirname, address_ename, ((32)" "), (0));
	     address_pathname = pathname_ (address_dirname, address_ename);
	     if P_is_start_of_sentence then
		address_string = "The mailbox ";
	     else address_string = "the mailbox ";
	     address_string = address_string || reverse (after (reverse (address_pathname), reverse (".mbx")));
	     go to END_SUMMARIZE_ADDRESS_CASE;


SUMMARIZE_ADDRESS (5):				/* forum address */
	     if P_is_start_of_sentence then
		address_string = "The forum meeting ";
	     else address_string = "the forum meeting ";
	     call mail_system_$get_address_pathname (address_ptr, address_dirname, address_ename, ((32)" "), (0));
	     if address_dirname = "" then		/* ... a meeting which couldn't be found by search list */
		address_pathname_varying = rtrim (address_ename);
	     else address_pathname_varying = rtrim (pathname_ (address_dirname, address_ename));
	     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_string = address_string || address_pathname_varying;
	     go to END_SUMMARIZE_ADDRESS_CASE;


SUMMARIZE_ADDRESS (6):				/* foreign address */
	     call get_address_variable (mail_system_$get_address_string);
	     call mail_system_$get_address_system (address_ptr, foreign_system_name, (0));
	     address_string = address_variable;
	     address_string = address_string || " at ";
	     address_string = address_string || foreign_system_name;
	     go to END_SUMMARIZE_ADDRESS_CASE;


SUMMARIZE_ADDRESS (7):				/* mail table address */
	     call get_address_variable (mail_system_$get_address_string);
	     address_string = address_variable;
	     go to END_SUMMARIZE_ADDRESS_CASE;


SUMMARIZE_ADDRESS (8):				/* mailing list address */
	     call mail_system_$get_address_pathname (address_ptr, address_dirname, address_ename, address_component,
		(0));
	     address_pathname = pathname_$component (address_dirname, address_ename, address_component);
	     if P_is_start_of_sentence then
		address_string = "The mailing list ";
	     else address_string = "the mailing list ";
	     address_string = address_string || reverse (after (reverse (address_pathname), reverse (".mls")));
	     go to END_SUMMARIZE_ADDRESS_CASE;


SUMMARIZE_ADDRESS (9):				/* named group address */
	     call get_address_variable (mail_system_$get_address_name);
	     if P_is_start_of_sentence then
		address_string = "The group named ";
	     else address_string = "the group named ";
	     address_string = address_string || address_variable;
	     go to END_SUMMARIZE_ADDRESS_CASE;


END_SUMMARIZE_ADDRESS_CASE:
	     if length (address_string) <= maxlength (P_address_string) then do;
		P_address_string = address_string;
		P_code = 0;
	     end;
	     else P_code = error_table_$smallarg;

	     return;



/* Internal to summarize_address begin block: gets one of the variables (string, name, comment) associated with an
   address; it will grow the begin block's stack frame as necessary */

get_address_variable:
     procedure (p_get_primitive) /* options (quick) */;

dcl  p_get_primitive entry (pointer, character (*) varying, fixed binary (35));
dcl  code fixed binary (35);

	address_variable_ptr = addr (address_local_variable);
	address_variable_max_lth = maxlength (address_local_variable);
						/* assume it will fit in the local copy */

	call p_get_primitive (address_ptr, address_variable, code);

	if code = error_table_$smallarg then do;	/* too large for the preallocated space ... */
	     call cu_$grow_stack_frame (STACK_EXTENSION, address_variable_ptr, (0));
	     address_variable_max_lth = 4 * (STACK_EXTENSION - 1);

	     call p_get_primitive (address_ptr, address_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));
		address_variable_max_lth = address_variable_max_lth + (4 * STACK_EXTENSION);
		call p_get_primitive (address_ptr, address_variable, code);
	     end;
	end;

	return;

     end get_address_variable;

	end;
%page;
/* Print the header line for a subsequent message summary */

print_message_summary_header:
     entry (P_line_length, P_output_switch, P_code);

	line_length = P_line_length;
	if (line_length < -1) | ((line_length > 0) & (line_length ^> 30)) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	if P_output_switch = null () then		/* default to the terminal if not specified */
	     output_switch = iox_$user_output;
	else output_switch = P_output_switch;

	if line_length = 0 then			/* default to line length of switch if not specified */
	     line_length = get_line_length_$switch (output_switch, (0));

	include_author, include_date, include_time, include_subject, include_lines = "1"b; /* assume nothing is truncated */

	if line_length > 0 then do;			/* only if we're asked to truncate if necessary */
	     if line_length < 72 then include_time = "0"b;/* not enough room to insure 22 characters of subject */
	     if line_length < 66 then include_date = "0"b;
	     if line_length < 56 then include_author = "0"b;
	     if line_length < 22 then include_subject = "0"b;
	     if line_length < 14 then include_lines = "0"b;
						/* phx19187 RL: handle line lengths < 22 as well */
	end;

	on condition (io_error)
	     begin;				/* I/O failed for some reason */
	     call get_ioa_error_code (P_code);
	     go to RETURN_FROM_PRINT_MESSAGE_SUMMARY_HEADER;
	end;

	call ioa_$ioa_switch (output_switch,
	     "^/Msg#^[^5xLines^2x^]^[^2xDate^[^3x^;^4x^]^;^s^]^[Time^3x^]^[From^15x^]^[Subject^]", include_lines, include_date, include_time,
	     include_time, include_author, include_subject);

	P_code = 0;

RETURN_FROM_PRINT_MESSAGE_SUMMARY_HEADER:
	return;
%page;
/* Print a one/two line summary of a message */

print_message_summary:
     entry (P_message_ptr, P_message_number, P_is_current_message, P_line_length, P_output_switch, P_code);

	message_ptr = P_message_ptr;
	if message.version ^= MESSAGE_VERSION_2 then do;
	     P_code = mlsys_et_$not_message;
	     return;
	end;

	line_length = P_line_length;
	if (line_length < -1) | ((line_length > 0) & (line_length ^> 30)) then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	if P_output_switch = null () then		/* default to the terminal if not specified */
	     output_switch = iox_$user_output;
	else output_switch = P_output_switch;

	if line_length = 0 then			/* default to line length of switch if not specified */
	     line_length = get_line_length_$switch (output_switch, (0));

	include_author, include_date, include_time, include_subject, include_lines = "1"b; /* until we're told otherwise */

	if line_length > 0 then do;			/* only if we're asked to truncate if necessary */
	     if line_length < 72 then include_time = "0"b;/* not enough room to insure 22 characters of subject */
	     if line_length < 66 then include_date = "0"b;
	     if line_length < 56 then include_author = "0"b;
	     if line_length < 22 then include_subject = "0"b;
	     if line_length < 14 then include_lines = "0"b;
	end;

	if P_is_current_message then current_message_flag = "*";
	else if message.marked_for_deletion then current_message_flag = "!";
	else current_message_flag = " ";

	if message.seen then
	     seen_flag = "S";
	else seen_flag = " ";

	if message.must_be_acknowledged then
	     ack_flag = "A";
	else ack_flag = " ";

	if message.can_be_deleted then		/* it can be deleted */
	     delete_flag = " ";
	else if ^aim_check_$equal (message.access_class, get_authorization_ ()) then delete_flag = "&";
						/* can't be deleted because of AIM (at least) */
	else delete_flag = " ";			/* can't be deleted but cause isn't AIM */

	if message.total_lines = -1 then		/* can't say how long this message will be when printed now */
	     n_lines_string = "   (?)";

/**** vp: phx21245, changed four_digits_picture to ten_digits_picture
      and changed n_lines_string from char(6) to char(10) ****/
	else do;
	     n_lines_string = "(" || ltrim (convert (ten_digits_picture, message.total_lines)) || ")";
	     if length (n_lines_string) < 6 then	/* padded blanks to make up six characters */
		n_lines_string = copy (SPACE, (6 - length (n_lines_string))) || n_lines_string;
	end;

	if message.n_redistributions > 0 then
	     forwarded_flag = "F";
	else forwarded_flag = " ";

	if include_date then do;			/* won't include time unless the date is also */
	     call decode_clock_value_$date_time (message.date_time_created, month, day_of_month, year, hour, minute,
		(0), (0), (0), ((3)" "), (0));
	     date_string =
		convert (two_digits_picture, month) || "/" || convert (two_digits_picture, day_of_month) || "/"
		|| convert (two_digits_picture, mod(year, 100));
	     time_string = convert (two_digits_picture, hour) || ":" || convert (two_digits_picture, minute);
	end;

	call get_best_address_name (message.from -> address_list.addresses (1), author_string, (0));
						/* guarenteed to have at least one author */

	if message.from -> address_list.n_addresses > 1 then
	     if length (author_string) < (maxlength (author_string) - length (ET_AL)) then
		author_string = author_string || ET_AL;

	the_subject_ptr = addr (SPACE);		/* assume no subject 'till proven otherwise */
	the_subject_lth = 0;

	if length (message_subject) > 0 then do;	/* there's a subject all right */
	     the_subject_ptr = message.subject.text_ptr;
	     the_subject_lth = message.subject.text_lth;
	end;

	else					/* check for interactive message */
	     if message.interactive & (message.total_lines > 0) then
	     if message.body_sections (1).section_type = MESSAGE_PREFORMATTED_BODY_SECTION then do;
		message_body_section_ptr = addr (message.body_sections (1));
		the_subject_ptr = addr (message_preformatted_body_section_text);
		the_subject_lth = index (message_preformatted_body_section_text, NL) - 1;
		if the_subject_lth = -1 then the_subject_lth = length (message_preformatted_body_section_text);
	     end;

	if line_length = -1 then			/* want the entire subject no matter what ... */
	     subject_string_lth = the_subject_lth;

	else if include_time then			/* all other fields are present */
	     subject_string_lth = min (the_subject_lth, (line_length - 51));
	else if include_date then subject_string_lth = min (the_subject_lth, (line_length - 45));
	else if include_author then subject_string_lth = min (the_subject_lth, (line_length - 35));
	else do;
	     if line_length < 17 then
		subject_string_lth = 0;
	     else
		subject_string_lth = min (the_subject_lth, (line_length - 16));
						/* phx19187 RL: no subject field if line short enough */
	end;

	begin;
dcl  subject_string character (subject_string_lth);

	     subject_string = substr (the_subject, 1, length (subject_string));
	     if subject_string_lth < the_subject_lth then /* subject was truncated ... */
		substr (subject_string, (subject_string_lth - 5), 6) = "<MORE>";

	     on condition (io_error)
		begin;				/* in case the I/O fails */
		call get_ioa_error_code (P_code);
		go to RETURN_FROM_PRINT_MESSAGE_SUMMARY;
	     end;

	     call ioa_$ioa_switch (output_switch,
		"^4d^1a^1a^1a^1a^[^a^1a^x^;^2s^]^[^a^[^x^;^2x^]^;^2s^]^[^a^2x^;^s^]^[^17a^2x^;^s^]^[^a^]",
		P_message_number, current_message_flag, seen_flag, ack_flag, delete_flag,
		include_lines, n_lines_string, forwarded_flag, include_date, date_string,
		include_time, include_time, time_string, include_author, author_string,
		include_subject, subject_string);

	end;

	P_code = 0;				/* success */

RETURN_FROM_PRINT_MESSAGE_SUMMARY:
	return;
%page;
/* Display the results of a message transmission operation as described by the data structures created by
   mail_system_$deliver_message or mail_system_$redistribute_message */

print_delivery_results:
     entry (P_sci_ptr, P_errors_only, P_recipients_info_ptr, P_code);

	sci_ptr = P_sci_ptr;

	recipients_info_ptr = P_recipients_info_ptr;
	if recipients_info.version ^= RECIPIENTS_INFO_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	call cu_$grow_stack_frame (BUFFER_STACK_EXTENSION, stack_buffer_ptr, (0));
	stack_buffer_max_lth = 4 * BUFFER_STACK_EXTENSION;

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

	on condition (cleanup) call cleanup_print_delivery_results ();


/* Print a list of all duplicated recipients and mailing lists/named groups whose entire content is duplicate addresses
   with an indication that said recipients received only a single copy of the message */

	n_duplicates = 0;

	do list_idx = 1 to recipients_info.n_lists;
	     recipients_result_list_ptr = recipients_info.lists (list_idx).recipients_result_list_ptr;
	     if recipients_result_list_ptr ^= null () then do;
		do address_idx = 1 to recipients_result_list.n_addresses;
		     result_ptr = addr (recipients_result_list.results (address_idx));
		     if result.code = mlsys_et_$duplicate_address then do;
			other_result_ptr =
			     addr (recipients_info.lists (result.list_idx).recipients_result_list_ptr
			     -> recipients_result_list.results (result.address_idx));
			if other_result.list_idx = 0 then do;
			     n_duplicates = n_duplicates + 1;
			     other_result.list_idx = recipients_info.n_lists + 1;
			end;
		     end;
		     else if result.code = mlsys_et_$list_address_is_all_duplicates then
			n_duplicates = n_duplicates + 1;
		end;
	     end;
	end;

	if n_duplicates ^= 0 then do;			/* there are duplicates ... */
	     call start_new_output ();		/* initialize the output buffer */
	     call add_to_buffer_fixed (THREE_SPACES);

	     n_duplicates_processed = 0;

	     do list_idx = 1 to recipients_info.n_lists;
		address_list_ptr = recipients_info.lists (list_idx).address_list_ptr;
		recipients_result_list_ptr = recipients_info.lists (list_idx).recipients_result_list_ptr;
		if recipients_result_list_ptr ^= null () then do;
		     do address_idx = 1 to recipients_result_list.n_addresses;
			result_ptr = addr (recipients_result_list.results (address_idx));
			if (result.list_idx = (recipients_info.n_lists + 1))
			     | (result.code = mlsys_et_$list_address_is_all_duplicates) then do;
			     n_duplicates_processed = n_duplicates_processed + 1;
			     if (n_duplicates > 2) & (n_duplicates_processed > 1) then
				call add_to_buffer_fixed (COMMA);
			     call add_to_buffer_fixed (SPACE);
			     if (n_duplicates > 1) & (n_duplicates_processed = n_duplicates) then
				call add_to_buffer_fixed (AND_SPACE);
			     call get_address_summary (address_list.addresses (address_idx), "0"b);
			     call add_to_buffer_varying (address_variable);
			end;
		     end;
		end;
	     end;
	     call add_to_buffer_fixed (PERIOD);
	     call add_to_buffer_fixed (NL);

	     call ssu_$print_message (sci_ptr, mlsys_et_$duplicate_address,
		"Only one copy of this message was sent to the following address^[es^]:", (n_duplicates > 1));
	     call print_the_buffer ();		/* print it neatly */
	end;


/* Print appropriate error messages for all recipients for which delivery failed or for which transient errors caused the
   message to be queued */

	expanded_recipients_result_list_ptr = recipients_info.expanded_recipients_result_list_ptr;

	do list_idx = 1 to recipients_info.n_lists;
	     address_list_ptr = recipients_info.lists (list_idx).address_list_ptr;
	     recipients_result_list_ptr = recipients_info (list_idx).recipients_result_list_ptr;

	     if recipients_result_list_ptr ^= null () then do;

		do address_idx = 1 to recipients_result_list.n_addresses;
		     address_ptr = address_list.addresses (address_idx);
		     result_ptr = addr (recipients_result_list.results (address_idx));

		     if (result.code = mlsys_et_$duplicate_address)
			| (result.code = mlsys_et_$list_address_is_all_duplicates) | (result.code = 0)
			| (result.code = mlsys_et_$message_delivered)
			| ((result.code = mlsys_et_$message_queued) & (length (result.explanation) = 0)
			& (result.first_entry_idx = 0))
			| ((result.code = mlsys_et_$message_queued_and_delivered) & (result.first_entry_idx = 0))
			then
			;			/* delivery was OK or already described for this recipient */

		     else if (result.code = mlsys_et_$errors_in_list_address)
			|
			(((result.code = mlsys_et_$message_queued)
			| (result.code = mlsys_et_$message_queued_and_delivered)) & (result.first_entry_idx ^= 0))
		     then do;
			/*** Mailing list/named group which experienced some form of problems */
			call get_true_address_summary (address_ptr, "0"b);
			if result.code = mlsys_et_$errors_in_list_address then
			     call ssu_$print_message (sci_ptr, 0, "Mail not delivered to all addresses in ^a:",
				address_variable);
			else call ssu_$print_message (sci_ptr, 0,
				"Mail could not be delivered immediately to some addresses in ^a:",
				address_variable);
			if address_variable_ptr ^= addr (address_local_variable) then
			     call cu_$shrink_stack_frame (address_variable_ptr, (0));
			do expanded_idx = result.first_entry_idx to (result.first_entry_idx + result.n_entries - 1);
			     expanded_result_ptr = addr (expanded_recipients_result_list.entries (expanded_idx));
			     call print_single_recipient_error (expanded_result.address_ptr, expanded_result.code,
				expanded_result.explanation, print_expansion_error);
			end;
		     end;

		     else call print_single_recipient_error (address_ptr, result.code, result.explanation,
			     ssu_$print_message);
		end;
	     end;
	end;

	if P_errors_only then go to RETURN_FROM_PRINT_DELIVERY_RESULTS;


/* Print the list of recipients to whom the mail was delivered, for whom the mail was queued on explicit request, and the
   mailing lists/named groups for whom the mail was both delivered and queued */

	if is_a_recipient_with_code (mlsys_et_$message_delivered) then
	     call print_recipient_list (mlsys_et_$message_delivered, "Mail delivered to");

	if is_a_recipient_with_code (mlsys_et_$message_queued) then
	     call print_recipient_list (mlsys_et_$message_queued, "Mail queued for");

	if is_a_recipient_with_code (mlsys_et_$message_queued_and_delivered) then
	     call print_recipient_list (mlsys_et_$message_queued_and_delivered,
		"Mail delivered to or queued for all recipients in");


/* Clean up */

	P_code = 0;				/* success */

RETURN_FROM_PRINT_DELIVERY_RESULTS:
	call cleanup_print_delivery_results ();

	return;


ERROR_RETURN_FROM_PRINT_DELIVERY_RESULTS:
	P_code = code;
	go to RETURN_FROM_PRINT_DELIVERY_RESULTS;



/* Release temporary buffers and restore the recipients_info data structures to their original state */

cleanup_print_delivery_results:
     procedure ();

dcl  (list_idx, address_idx) fixed binary;

	if segment_buffer_ptr ^= null () then call release_temp_segment_ (MAIL_SYSTEM_, segment_buffer_ptr, (0));
	segment_buffer_ptr = null ();

	do list_idx = 1 to recipients_info.n_lists;
	     recipients_result_list_ptr = recipients_info.lists (list_idx).recipients_result_list_ptr;
	     if recipients_result_list_ptr ^= null () then do;
		do address_idx = 1 to recipients_result_list.n_addresses;
		     result_ptr = addr (recipients_result_list.results (address_idx));
		     if result.list_idx = (recipients_info.n_lists + 1) then result.list_idx = 0;
		end;
	     end;
	end;

	return;

     end cleanup_print_delivery_results;
%page;
/* Free the data structures created by mail_system_$deliver_message or mail_system_$redistribute_message to describe the
   results of the transmission */

free_delivery_results:
     entry (P_recipients_info_ptr, P_code);

	recipients_info_ptr = P_recipients_info_ptr;

	if recipients_info_ptr = null () then do;	/* allow a null recipients_info for cleanup handlers */
	     P_code = 0;
	     return;
	end;

	if recipients_info.version ^= RECIPIENTS_INFO_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	users_area_ptr = recipients_info.area_ptr;

	if recipients_info.expanded_recipients_result_list_ptr ^= null () then do;
	     expanded_recipients_result_list_ptr = recipients_info.expanded_recipients_result_list_ptr;
	     do idx = 1 to expanded_recipients_result_list.n_entries;
		if expanded_recipients_result_list.entries (idx).address_ptr ^= null () then
		     call mail_system_$free_address (expanded_recipients_result_list.entries (idx).address_ptr, (0));
	     end;
	     free expanded_recipients_result_list in (users_area);
	     recipients_info.expanded_recipients_result_list_ptr = null ();
	end;

	do idx = 1 to recipients_info.n_lists;
	     if recipients_info.lists (idx).recipients_result_list_ptr ^= null () then do;
		recipients_result_list_ptr = recipients_info.lists (idx).recipients_result_list_ptr;
		free recipients_result_list in (users_area);
		recipients_info.lists (idx).recipients_result_list_ptr = null ();
	     end;
	end;

	P_code = 0;				/* success */

	return;
%page;
/* Display an appropriate error message for a failing call to mail_system_$validate_address */

print_validate_results:
     entry (P_sci_ptr, P_address_ptr, P_code);

	if P_code = 0 then return;			/* validation was OK */

	call mail_system_$get_address_type (P_address_ptr, (0), code);
	if code ^= 0 then do;			/* invalid input? */
RESIGNAL_NOT_AN_ADDRESS:
	     call sub_err_ (code, MAIL_SYSTEM_, ACTION_CANT_RESTART, null (), (0), "^p", P_address_ptr);
	     go to RESIGNAL_NOT_AN_ADDRESS;
	end;

	sci_ptr = P_sci_ptr;
	call print_single_recipient_error (P_address_ptr, P_code, "", ssu_$print_message);

	return;
%page;
/* Create a new message which is to be a reply to the supplied in-mailbox message */

create_reply_message:
     entry (P_original_message_ptr, P_reply_options_ptr, P_message_ptr, P_code);

	original_message_ptr = P_original_message_ptr;
	reply_options_ptr = P_reply_options_ptr;

	if reply_options.version ^= REPLY_OPTIONS_VERSION_2 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;
	if reply_options.mbz ^= ""b then do;		/* must-be-zero */
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;


/* Create the message and setup its reference to the original message */

	message_ptr,				/* for cleanup handler */
	     reply_lists, segment_buffer_ptr = null ();

	on condition (cleanup) call cleanup_create_reply_message ("1"b);

	call mail_system_$create_message (original_message_ptr -> message.version, message_ptr, code);
	if code ^= 0 then call abort_create_reply_message (code);

	call mail_system_$add_reply_reference (message_ptr, original_message_ptr, (1), code);
	if code ^= 0 then call abort_create_reply_message (code);


/* Create the subject for the reply by prefixing the original subject (or body for interactive messages) with the prefix
   "Re:" if it isn't already present */

	original_subject_ptr = addr (SPACE);		/* assume no original subject 'till proven otherwise */
	original_subject_lth = 0;

	if original_message_ptr -> message.subject.text_lth > 0 then do;
	     original_subject_ptr = original_message_ptr -> message.subject.text_ptr;
	     original_subject_lth = original_message_ptr -> message.subject.text_lth;
	end;					/* there's a subject */

	else					/* check for interactive message ... */
	     if original_message_ptr -> message.interactive & (original_message_ptr -> message.total_lines > 0) then
	     if original_message_ptr -> message.body_sections (1).section_type = MESSAGE_PREFORMATTED_BODY_SECTION
	     then do;				/* ... which starts with a piece of text */
		message_body_section_ptr = addr (original_message_ptr -> message.body_sections (1));
		original_subject_ptr = addr (message_preformatted_body_section_text);
		original_subject_lth = index (message_preformatted_body_section_text, NL) - 1;
		if original_subject_lth = -1 then
		     original_subject_lth = length (message_preformatted_body_section_text);
	     end;

	if original_subject_lth > 0 then do;		/* there's something from which we can construct a subject */
	     use_original_subject = "0"b;		/* ... assume we will have to add the "Re: " */
	     if (original_subject_lth > length (REPLY_SUBJECT_PREFIX)) then
		if (translate (substr (original_subject, 1, length (REPLY_SUBJECT_PREFIX)), LOWERCASE, UPPERCASE)
		     = translate (REPLY_SUBJECT_PREFIX, LOWERCASE, UPPERCASE)) then
		     use_original_subject = "1"b;	/* subject is already OK */
	     if use_original_subject then
		call mail_system_$replace_subject (message_ptr, original_subject, code);
	     else do;				/* ... necessary to add the "Re: " */
		if (original_subject_lth + length (REPLY_SUBJECT_PREFIX)) <= (4 * BUFFER_STACK_EXTENSION) then
		     begin;			/* ... it'll fit on the stack */
dcl  new_subject character (original_subject_lth + length (REPLY_SUBJECT_PREFIX));
		     new_subject = REPLY_SUBJECT_PREFIX || original_subject;
		     call mail_system_$replace_subject (message_ptr, new_subject, code);
		end;
		else if (original_subject_lth + length (REPLY_SUBJECT_PREFIX)) <= (4 * sys_info$max_seg_size) then do;
						/* ... too long: use a temporary segment */
		     call get_temp_segment_ (MAIL_SYSTEM_, segment_buffer_ptr, code);
		     if code ^= 0 then call abort_create_reply_message (code);
		     the_subject_ptr = segment_buffer_ptr;
		     the_subject_lth = original_subject_lth + length (REPLY_SUBJECT_PREFIX);
		     the_subject = REPLY_SUBJECT_PREFIX || original_subject;
		     call mail_system_$replace_subject (message_ptr, the_subject, code);
		end;
		else code = mlsys_et_$message_too_large;/* ... how'd it ever get this large? */
	     end;
	     if code ^= 0 then call abort_create_reply_message (code);
	end;


/* Include the authors and recipients of the message as recipients of the reply if requested; remove any occurences of the
   user from these lists if the user does not want to receive a copy of the reply except by explicit request in one of the
   address lists passed to this entrypoint */

	if reply_options.include_authors then do;	/* authors are to be primary recipients */
	     if ^is_empty_list (original_message_ptr -> message.reply_to) then
		call mail_system_$merge_address_lists (reply_lists.to, original_message_ptr -> message.reply_to, "0"b,
		     reply_lists.to, code);
	     else call mail_system_$merge_address_lists (reply_lists.to, original_message_ptr -> message.from, "0"b,
		     reply_lists.to, code);
	     if code ^= 0 then call abort_create_reply_message (code);
	end;

	if reply_options.include_recipients then do;	/* original message's recipients should see this */
	     if ^is_empty_list (original_message_ptr -> message.to) then do;
		call mail_system_$merge_address_lists (reply_lists.cc, original_message_ptr -> message.to, "0"b,
		     reply_lists.cc, code);
		if code ^= 0 then call abort_create_reply_message (code);
	     end;
	     if ^is_empty_list (original_message_ptr -> message.cc) then do;
		call mail_system_$merge_address_lists (reply_lists.cc, original_message_ptr -> message.cc, "0"b,
		     reply_lists.cc, code);
		if code ^= 0 then call abort_create_reply_message (code);
	     end;
	     if ^is_empty_list (original_message_ptr -> message.bcc) then do;
		call mail_system_$merge_address_lists (reply_lists.bcc, original_message_ptr -> message.bcc, "0"b,
		     reply_lists.bcc, code);
		if code ^= 0 then call abort_create_reply_message (code);
	     end;
	end;

	if ^reply_options.include_self then do;		/* remove the user from the "automatic" recipients */
	     compare_against_both =			/* ... if they're equal we only need to compare against one */
		^
		mail_system_$compare_addresses (mlsys_data_$user_default_mailbox_address,
		mlsys_data_$user_mail_table_address, (0));
	     do address_list_ptr = reply_lists.to, reply_lists.cc, reply_lists.bcc;
		if ^is_empty_list (address_list_ptr) then do;
		     /*** ... checking backwards allows us to use an indexed do-loop */
		     do address_idx = address_list.n_addresses to 1 by -1;
			code = 0;			/* ... we check the code only once so it needs to be set */
			if mail_system_$compare_addresses (address_list.addresses (address_idx),
			     mlsys_data_$user_default_mailbox_address, (0)) then
			     call mail_system_$delete_address (address_list_ptr, address_idx, code);
			else if compare_against_both then
			     if mail_system_$compare_addresses (address_list.addresses (address_idx),
				mlsys_data_$user_mail_table_address, (0)) then
				call mail_system_$delete_address (address_list_ptr, address_idx, code);
			if code ^= 0 then call abort_create_reply_message (code);
		     end;
		end;
	     end;
	end;


/* Add any recipients explicitly requested by the caller */

	if ^is_empty_list (reply_options.to) then do;
	     call mail_system_$merge_address_lists (reply_lists.to, reply_options.to, "0"b, reply_lists.to, code);
	     if code ^= 0 then call abort_create_reply_message (code);
	end;

	if ^is_empty_list (reply_options.cc) then do;
	     call mail_system_$merge_address_lists (reply_lists.cc, reply_options.cc, "0"b, reply_lists.cc, code);
	     if code ^= 0 then call abort_create_reply_message (code);
	end;

	if ^is_empty_list (reply_options.bcc) then do;
	     call mail_system_$merge_address_lists (reply_lists.bcc, reply_options.bcc, "0"b, reply_lists.bcc, code);
	     if code ^= 0 then call abort_create_reply_message (code);
	end;


/* Eliminate any duplicate addresses from the lists: when done, only one copy of each unique address will remain in the
   lists of recipients */

	call mail_system_$eliminate_duplicate_addresses (reply_lists_array, code);
	if code ^= 0 then call abort_create_reply_message (code);


/* Finally, place the just constructed lists of recipients into the message */

	if ^is_empty_list (reply_lists.to) then do;
	     call mail_system_$replace_to (message_ptr, reply_lists.to, code);
	     if code ^= 0 then call abort_create_reply_message (code);
	end;

	if ^is_empty_list (reply_lists.cc) then do;
	     call mail_system_$replace_cc (message_ptr, reply_lists.cc, code);
	     if code ^= 0 then call abort_create_reply_message (code);
	end;

	if ^is_empty_list (reply_lists.bcc) then do;
	     call mail_system_$replace_bcc (message_ptr, reply_lists.bcc, code);
	     if code ^= 0 then call abort_create_reply_message (code);
	end;


/* Control arrives here iff we have succesfully created the reply message */

	call cleanup_create_reply_message ("0"b);	/* keep the message */

	P_message_ptr = message_ptr;
	P_code = 0;

	return;



/* Aborts an invocation of the create_reply_message entrypoint after an error */

abort_create_reply_message:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	P_code = p_code;
	go to ERROR_RETURN_FROM_CREATE_REPLY_MESSAGE;

     end abort_create_reply_message;

ERROR_RETURN_FROM_CREATE_REPLY_MESSAGE:
	call cleanup_create_reply_message ("1"b);
	return;



/* Releases temporary buffers and address lists used by create_reply_message */

cleanup_create_reply_message:
     procedure (p_free_message);

dcl  p_free_message bit (1) aligned parameter;

	if reply_lists.to ^= null () then call mail_system_$free_address_list (reply_lists.to, (0));
	if reply_lists.cc ^= null () then call mail_system_$free_address_list (reply_lists.cc, (0));
	if reply_lists.bcc ^= null () then call mail_system_$free_address_list (reply_lists.bcc, (0));

	if segment_buffer_ptr ^= null () then do;
	     call release_temp_segment_ (MAIL_SYSTEM_, segment_buffer_ptr, (0));
	     segment_buffer_ptr = null ();
	end;

	if p_free_message then call mail_system_$free_message (message_ptr, (0));

	return;

     end cleanup_create_reply_message;
%page;
/* Searches the canonical form of a message for the given character string which may be a qedx regular expression:  The
   canonical form of a message is the text used by the mail system when it stores the message in a mailbox */

search_message:
     entry (P_message_ptr, P_search_string, P_search_options_ptr, P_code) returns (bit (1) aligned);

	message_ptr = P_message_ptr;
	search_options_ptr = P_search_options_ptr;

	message_canonical_text_ptr,			/* for cleanup handler */
	     message_buffer_ptr, translated_search_string_ptr = null ();

	on condition (cleanup) call cleanup_search_message ();

	if message.version ^= MESSAGE_VERSION_2 then	/* perform a simple validity check */
	     call abort_search_message (mlsys_et_$not_message);

	if search_options.version ^= SEARCH_OPTIONS_VERSION_2 then
	     call abort_search_message (error_table_$unimplemented_version);

	if ^(search_options.search_envelope | search_options.search_header
	     | search_options.search_redistributions_list | search_options.search_body) then
	     call abort_search_message (error_table_$inconsistent);
						/* asked us to not search anything */

	if search_options.mbz ^= ""b then		/* mbz => must be zero */
	     call abort_search_message (error_table_$bad_subr_arg);

	if verify (P_search_string, WHITESPACE) = 0 then	/* can't search for just whitespace */
	     call abort_search_message (mlsys_et_$null_search_string);

	if search_options.regexp_search then do;	/* check the string for syntactic validity */
	     call search_file_$silent (addr (P_search_string), 1, length (P_search_string), addr (NULL_STRING), 1, 0,
		(0), (0), code);
	     if code = error_table_$nomatch then	/* ... only happens if the string has valid syntax */
		code = 0;
	     if code ^= 0 then call abort_search_message (code);
	end;					/* ... something's wrong with the string */


/* Create the canonical form of the message */

	local_fmo.version = FORMAT_MESSAGE_OPTIONS_VERSION_1;
	local_fmo.line_length = -1;			/* no folding */

	if search_options.search_envelope then
	     local_fmo.envelope_formatting_mode = DEFAULT_FORMATTING_MODE;
	else local_fmo.envelope_formatting_mode = NONE_FORMATTING_MODE;

	if search_options.search_header then
	     local_fmo.header_formatting_mode = DEFAULT_FORMATTING_MODE;
	else local_fmo.header_formatting_mode = NONE_FORMATTING_MODE;

	if search_options.search_redistributions_list then
	     local_fmo.redistributions_list_formatting_mode = DEFAULT_FORMATTING_MODE;
	else local_fmo.redistributions_list_formatting_mode = NONE_FORMATTING_MODE;

	local_fmo.include_body = search_options.search_body;

	if ^(search_options.search_envelope & search_options.search_header
	     & search_options.search_redistributions_list & search_options.search_body) then
	     go to MUST_FORMAT_THE_MESSAGE;		/* don't search entire message: can't use ring-2's help */

	/*** First check with ring-2 to see if it already has the canonical form available */
	call mail_system_$read_message_canonical_form_p (message_ptr, message_canonical_text_ptr, message_lth, code);
	if code = 0 then				/* ... ring-2 has the canonical form already */
	     message_buffer_ptr = message_canonical_text_ptr;

	else if (code = mlsys_et_$not_in_mailbox_message) | (code = mlsys_et_$no_message_canonical_form) then do;
	     /*** Ring-2 has no canonical form so we must create it here: Try the stack first ... */
MUST_FORMAT_THE_MESSAGE:
	     call cu_$grow_stack_frame (BUFFER_STACK_EXTENSION, message_buffer_ptr, (0));
	     message_lth = 0;
	     call mlsys_utils_$format_message_canonical_form (message_ptr, addr (local_fmo), message_buffer_ptr,
		(4 * BUFFER_STACK_EXTENSION), message_lth, code);
	     if code = 0 then do;			/* ... the message fits: cleanup unused portion ... */
		message_lth_in_words = divide ((message_lth + 3), 4, 18, 0);
		stack_truncation_ptr =
		     addwordno (message_buffer_ptr, (message_lth_in_words + 16 - mod (message_lth_in_words, 16)));
		call cu_$shrink_stack_frame (stack_truncation_ptr, (0));
	     end;

	     else if code = error_table_$smallarg then do;
		/*** Won't fit on the stack: try a temporary segment */
		call cu_$shrink_stack_frame (message_buffer_ptr, (0));
		call get_temp_segment_ (MAIL_SYSTEM_, message_buffer_ptr, code);
		if code ^= 0 then call abort_search_message (code);
		message_lth = 0;			/* just to be sure */
		call mlsys_utils_$format_message_canonical_form (message_ptr, addr (local_fmo), message_buffer_ptr,
		     (4 * sys_info$max_seg_size), message_lth, code);
		if code = error_table_$smallarg then code = mlsys_et_$message_too_large;
		if code ^= 0 then call abort_search_message (code);
	     end;

	     else call abort_search_message (code);	/* fatal error from the formatter */
	end;

	else call abort_search_message (code);		/* fatal error from ring-2 */


/* Translate the message and search string to uppercase if the caller has requested a case-insensitive search:  We'll use
   mvt_ to perform the translation as the PL/I compiler may generate temporaries which could overflow the stack */

	if search_options.case_insensitive then do;
	     call mvt_$make_translation_table (UPPERCASE, LOWERCASE, translation_table);

	     if message_buffer_ptr = message_canonical_text_ptr then do;
		/*** Text is in ring-2: we'll have to copy it */
		if message_lth <= (4 * BUFFER_STACK_EXTENSION) then
		     call cu_$grow_stack_frame (divide ((message_lth + 3), 4, 18, 0), message_buffer_ptr, (0));
		else do;
		     call get_temp_segment_ (MAIL_SYSTEM_, message_buffer_ptr, code);
		     if code ^= 0 then call abort_search_message (code);
		end;
		call mvt_ (message_canonical_text_ptr, message_buffer_ptr, message_lth, translation_table);
	     end;
	     else call mvt_ (message_buffer_ptr, message_buffer_ptr, message_lth, translation_table);

	     if length (P_search_string) <= (4 * BUFFER_STACK_EXTENSION) then
		call cu_$grow_stack_frame (divide ((length (P_search_string) + 3), 4, 18, 0),
		     translated_search_string_ptr, (0));
	     else do;
		call get_temp_segment_ (MAIL_SYSTEM_, translated_search_string_ptr, code);
		if code ^= 0 then call abort_search_message (code);
	     end;
	     call mvt_ (addr (P_search_string), translated_search_string_ptr, length (P_search_string),
		translation_table);
	end;


/* Perform the search */

	if search_options.case_insensitive then
	     search_string_ptr = translated_search_string_ptr;
	else search_string_ptr = addr (P_search_string);

	if search_options.regexp_search then do;
	     call search_file_$silent (search_string_ptr, 1, length (P_search_string), message_buffer_ptr, 1,
		message_lth, (0), (0), code);
	     search_succeeds = (code = 0);
	end;

	else search_succeeds = (index (message_text, search_string) ^= 0);

	P_code = 0;				/* success */


/* Cleanup and return the result */

RETURN_FROM_SEARCH_MESSAGE:
	call cleanup_search_message ();

	return (search_succeeds);



/* Aborts the current search_message operation after a fatal error */

abort_search_message:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	P_code = p_code;				/* reflect the results to our caller */
	search_succeeds = "0"b;			/* the search fials by definition */

	go to RETURN_FROM_SEARCH_MESSAGE;

     end abort_search_message;



/* Releases temporary buffers used by the search_message entrypoint */

cleanup_search_message:
     procedure ();

	if message_buffer_ptr ^= null () then
	     if (message_buffer_ptr ^= message_canonical_text_ptr)
		& (baseno (message_buffer_ptr) ^= baseno (stackframeptr ())) then
		call release_temp_segment_ (MAIL_SYSTEM_, message_buffer_ptr, (0));
	message_buffer_ptr = null ();

	if translated_search_string_ptr ^= null () then
	     if baseno (translated_search_string_ptr) ^= baseno (stackframeptr ()) then
		call release_temp_segment_ (MAIL_SYSTEM_, translated_search_string_ptr, (0));
	translated_search_string_ptr = null ();

	return;

     end cleanup_search_message;
%page;
/* Sends the given message to the address whose printed representation is supplied by the caller */

send_message_to_recipient:
     entry (P_author_name, P_recipient, P_delivery_mode, P_message_subject, P_message_body, P_message_access_class,
	P_explanation, P_code);

	message_ptr,				/* for cleanup handler */
	     address_ptr, address_list_ptr = null ();
	local_ri.version = "";			/* invalid version will stop free_delivery_results */

	on condition (cleanup) call cleanup_send_message ();


/* Create the message: sets the subject, access class, and body to the values supplied by the caller */

	call mail_system_$create_message (MESSAGE_VERSION_2, message_ptr, code);
	if code ^= 0 then call abort_send_message (code);

	if verify (P_message_subject, WHITESPACE) ^= 0 then do;
	     call mail_system_$replace_subject (message_ptr, P_message_subject, code);
	     if code ^= 0 then call abort_send_message (code);
	end;

	if ^aim_check_$equal (P_message_access_class, get_authorization_ ()) then do;
	     call mail_system_$set_access_class (message_ptr, P_message_access_class, code);
	     if code ^= 0 then call abort_send_message (code);
	end;

	local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2;
	message_body_section_ptr = addr (local_mbsp.section);
	message_body_section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION;
	message_preformatted_body_section.text_ptr = addr (P_message_body);
	message_preformatted_body_section.text_lth = length (P_message_body);
	call mail_system_$replace_body (message_ptr, addr (local_mbsp), code);
	if code ^= 0 then call abort_send_message (code);


/* Setup a non-default From field using the supplied address name */

	if verify (P_author_name, WHITESPACE) ^= 0 then do;

	     call user_info_$login_data (person_id, ((32)" "), ((32)" "), anonymous_flag);
	     if anonymous_flag = 0 then do;		/* can only do this if not an anonymous user, however */

		call mail_system_$create_mail_table_address (rtrim (person_id), rtrim (P_author_name), "",
		     address_ptr, code);
		if code ^= 0 then call abort_send_message (code);

		address_list_ptr = null ();
		call mail_system_$add_address (address_list_ptr, address_ptr, ADDRESS_LIST_VERSION_2, code);
		if code ^= 0 then call abort_send_message (code);
		address_ptr = null ();		/* the address is now safely in the list */

		call mail_system_$replace_from (message_ptr, address_list_ptr, code);
		if code ^= 0 then call abort_send_message (code);
		call mail_system_$free_address_list (address_list_ptr, (0));
	     end;
	end;


/* Setup the To field to be the supplied recipient */

	call mlsys_utils_$parse_address_text (P_recipient, address_ptr, code);
	if code ^= 0 then call abort_send_message (code);

	address_list_ptr = null ();
	call mail_system_$add_address (address_list_ptr, address_ptr, ADDRESS_LIST_VERSION_2, code);
	if code ^= 0 then call abort_send_message (code);
	address_ptr = null ();			/* the address is now safely in the list */

	call mail_system_$replace_to (message_ptr, address_list_ptr, code);
	if code ^= 0 then call abort_send_message (code);
	call mail_system_$free_address_list (address_list_ptr, (0));


/* Deliver the message */

	local_do.version = DELIVER_OPTIONS_VERSION_2;
	local_do.delivery_mode = P_delivery_mode;
	local_do.queueing_mode = ALWAYS_QUEUE_FOREIGN;
	local_do.queued_notification_mode = NOTIFY_ON_ERROR;
	string (local_do.flags) = ""b;
	local_do.recipient_notification = "1"b;		/* notify if not interactive or express */

	local_ri.area_ptr = get_system_free_area_ ();
	local_ri.n_lists = 1;
	local_ri.list.address_list_ptr = message.to;	/* the recipient was added to the To field */
	local_ri.expanded_recipients_result_list_ptr, local_ri.list.recipients_result_list_ptr = null ();
	local_ri.version = RECIPIENTS_INFO_VERSION_2;

	call mail_system_$deliver_message (message_ptr, addr (local_ri), addr (local_do), code);


/* Determine the appropriate return code */

	P_explanation = "";				/* until proven otherwise */

	if (code = 0) | (code = mlsys_et_$message_not_sent) | (code = mlsys_et_$message_partially_sent) then do;
	     recipients_result_list_ptr = local_ri.list.recipients_result_list_ptr;
	     code = recipients_result_list.results (1).code;
	     P_explanation = recipients_result_list.results (1).explanation;
	end;

	else ;					/* anything other global code is serious */

	P_code = code;				/* set the return code */


/* Cleanup */

RETURN_FROM_SEND_MESSAGE_TO_RECIPIENT:
	call cleanup_send_message ();

	return;



/* Aborts the send_message_to_recipient operation */

abort_send_message:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	P_code = p_code;				/* reflect results to our caller */

	go to RETURN_FROM_SEND_MESSAGE_TO_RECIPIENT;

     end abort_send_message;



/* Releases all temporary data used by this entrypoint */

cleanup_send_message:
     procedure ();

	call free_delivery_results (addr (local_ri), (0));

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

	if address_ptr ^= null () then call mail_system_$free_address (address_ptr, (0));

	if message_ptr ^= null () then call mail_system_$free_message (message_ptr, (0));

	return;

     end cleanup_send_message;
%page;
/* Obtains the error code associated with a failed attempt to do I/O through ioa_ */

get_ioa_error_code:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

dcl  1 local_ci aligned like condition_info;

	local_ci.version = condition_info_version_1;

	call find_condition_info_ (null (), addr (local_ci), p_code);
	if p_code ^= 0 then return;

	if local_ci.info_ptr ^= null () then		/* there's a status code out there */
	     p_code = local_ci.info_ptr -> io_error_info.status.code;
	else p_code = error_table_$null_info_ptr;	/* have to return something ... */

	return;

     end get_ioa_error_code;
%page;
/* Gets the address summary of the specified address (see summarize_address, above); it will grow the caller's stack frame
   as necessary */

get_address_summary:
     procedure (p_address_ptr, p_is_start_of_sentence) /* options (quick) */;

dcl  p_address_ptr pointer parameter;
dcl  p_is_start_of_sentence bit (1) aligned parameter;
dcl  code fixed binary (35);

	address_variable_ptr = addr (address_local_variable);
	address_variable_max_lth = maxlength (address_local_variable);
						/* assume it will fit in the local copy */

	call summarize_address (p_address_ptr, p_is_start_of_sentence, address_variable, code);

	if code = error_table_$smallarg then do;	/* too large for the preallocated space ... */
	     call cu_$grow_stack_frame (STACK_EXTENSION, address_variable_ptr, (0));
	     address_variable_max_lth = 4 * (STACK_EXTENSION - 1);

	     call summarize_address (p_address_ptr, p_is_start_of_sentence, address_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));
		address_variable_max_lth = address_variable_max_lth + (4 * STACK_EXTENSION);
		call summarize_address (p_address_ptr, p_is_start_of_sentence, address_variable, code);
	     end;
	end;

	return;

     end get_address_summary;
%page;
/**** format: ^indcomtxt */
/* Gets the "true" description of the specified address.  The true description of all addresses expect mail table
   addresses is returned by the summarize_address entrypoint; for mail table addresses it is:
	<target-summary> for the address NAME
   where "<target-summary>" is the description of the address actually in the mail table and "NAME" is the name of the
   entry in the mail table */
/**** format: indcomtxt */

get_true_address_summary:
     procedure (p_address_ptr, p_is_start_of_sentence) /* options (quick) */;

dcl  p_address_ptr pointer parameter;
dcl  p_is_start_of_sentence bit (1) aligned parameter;

dcl  address_ptr pointer;
dcl  address_pathname character (194);
dcl  address_dirname character (168);
dcl  address_ename character (32);
dcl  mte_name character (32) varying;
dcl  code fixed binary (35);
dcl  address_type fixed binary;

	call mail_system_$get_address_type (p_address_ptr, address_type, (0));
	if address_type = MAIL_TABLE_ADDRESS then do;
	     call mail_system_$get_mail_table_address (p_address_ptr, address_ptr, code);
	     if code ^= 0 then			/* lookup failed: stick with the original address */
		address_ptr = p_address_ptr;
	end;
	else address_ptr = p_address_ptr;

	call get_address_summary (address_ptr, p_is_start_of_sentence);

	if address_ptr ^= p_address_ptr then do;	/* picked up an expansion from the mail table ... */
	     call mail_system_$get_address_string (p_address_ptr, mte_name, (0));
	     call mail_system_$get_address_type (address_ptr, address_type, (0));
	     if address_type = USER_MAILBOX_ADDRESS then do;
		call mail_system_$get_address_pathname (address_ptr, address_dirname, address_ename, ((32)" "), (0));
		address_pathname = pathname_ (address_dirname, address_ename);
		if p_is_start_of_sentence then
		     address_variable = "The mailbox ";
		else address_variable = "the mailbox ";
		address_variable = address_variable || reverse (after (reverse (address_pathname), reverse (".mbx")));
	     end;
	     if (length (address_variable) + length (mte_name) + length (" for the address "))
		> maxlength (address_variable) then
		if addr (address_variable) = addr (address_local_variable) then do;
		     call cu_$grow_stack_frame (STACK_EXTENSION, address_variable_ptr, (0));
		     address_variable_max_lth = 4 * (STACK_EXTENSION - 1);
		     address_variable = address_local_variable;
		end;
		else do;
		     call cu_$grow_stack_frame (STACK_EXTENSION, (null ()), (0));
		     address_variable_max_lth = address_variable_max_lth + (4 * STACK_EXTENSION);
		end;
	     address_variable = address_variable || " for the address ";
	     address_variable = address_variable || mte_name;
	     call mail_system_$free_address (address_ptr, (0));
	end;

	return;

     end get_true_address_summary;
%page;
/* Displays the reason why the message could not be transmitted to the given address or had to be queued instead of
   delivered immediately */

print_single_recipient_error:
     procedure (p_address_ptr, p_code, p_explanation, p_display_message);

dcl  p_address_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;
dcl  p_explanation character (128) varying parameter;
dcl  p_display_message entry () options (variable) variable parameter;

dcl  (address_pathname, address_dirname) character (168);
dcl  user_name character (64) varying;
dcl  address_ename character (32);
dcl  address_type fixed binary;

	address_variable_ptr = addr (address_local_variable);
	address_variable_max_lth = maxlength (address_local_variable);
	address_variable = "";			/* insures everything will work OK */

	call mail_system_$get_address_type (p_address_ptr, address_type, (0));

	if p_code = mlsys_et_$message_queued then do;	/* only if it was a transient error that caused queueing */
	     call get_true_address_summary (p_address_ptr, "0"b);
	     call p_display_message (sci_ptr, 0, "Mail queued for ^a because ^a.", address_variable, p_explanation);
	end;

	else if p_code = mlsys_et_$rejected_by_foreign_system then do;
	     call get_true_address_summary (p_address_ptr, "0"b);
	     call p_display_message (sci_ptr, 0, "Mail for ^a was rejected by a foreign system.  ^a", address_variable,
		p_explanation);
	end;

	else if p_code = mlsys_et_$invalid_address then do;
	     call get_true_address_summary (p_address_ptr, "0"b);
	     call p_display_message (sci_ptr, p_code, "^a", after (address_variable, "the invalid address "));
	end;

	else if p_code = mlsys_et_$no_mailbox then do;
	     call get_true_address_summary (p_address_ptr, "1"b);
	     call p_display_message (sci_ptr, 0, "^a does not exist.", address_variable);
	end;

	else if mlsys_psp_$forum_not_available () then go to FORUM_NOT_ON_SYSTEM;

	else if p_code = forum_error_table_$no_such_forum then do;
	     call get_true_address_summary (p_address_ptr, "1"b);
	     call p_display_message (sci_ptr, 0, "^a does not exist.", address_variable);
	end;

	else if p_code = forum_error_table_$not_eligible then do;
	     call get_true_address_summary (p_address_ptr, "0"b);
	     call p_display_message (sci_ptr, 0, "You are not a participant of ^a.", address_variable);
	end;

	else if p_code = forum_error_table_$read_only then do;
	     call get_true_address_summary (p_address_ptr, "0"b);
	     call p_display_message (sci_ptr, 0, "You may not enter transactions into ^a.", address_variable);
	end;

	else
FORUM_NOT_ON_SYSTEM:
	     if p_code = mlsys_et_$mte_not_found then do;
	     call get_address_summary (p_address_ptr, "1"b);
	     call p_display_message (sci_ptr, p_code, "^a", address_variable);
	end;

	else if p_code = mlsys_et_$no_mailing_list then do;
	     call get_true_address_summary (p_address_ptr, "1"b);
	     call p_display_message (sci_ptr, 0, "^a does not exist.", address_variable);
	end;

	else do;					/* everything else */
	     if address_type = USER_MAILBOX_ADDRESS then do;
		call mail_system_$get_address_string (p_address_ptr, user_name, (0));
		call mail_system_$get_address_pathname (p_address_ptr, address_dirname, address_ename, ((32)" "), (0))
		     ;
		address_pathname = pathname_ (address_dirname, address_ename);
		address_variable = "The mailbox ";
		address_variable = address_variable || reverse (after (reverse (address_pathname), reverse (".mbx")));
		address_variable = address_variable || " for the address ";
		address_variable = address_variable || user_name;
	     end;
	     else call get_true_address_summary (p_address_ptr, "1"b);
	     call p_display_message (sci_ptr, p_code, "^a", address_variable);
	end;

	if address_variable_ptr ^= addr (address_local_variable) then
	     call cu_$shrink_stack_frame (address_variable_ptr, (0));

	return;

     end print_single_recipient_error;
%page;
/* Formats and prints an error message for a recipient which is part of the expansion of a mailing list or named group */

print_expansion_error:
     procedure () options (variable) options (non_quick);

dcl  based_fb35 fixed binary (35) based;
dcl  arg_ptr pointer;

dcl  error_message character (100) aligned;
dcl  arg_packed bit (1) aligned;
dcl  (error_code, from_size, to_size) fixed binary (35);
dcl  output_message_lth fixed binary (21);
dcl  (arg_type, arg_ndims, arg_size, arg_scale) fixed binary;

	buffer_ptr = stack_buffer_ptr;		/* always use the in-stack buffer */
	buffer_max_lth = stack_buffer_max_lth;

	call cu_$arg_ptr (2, arg_ptr, (0), (0));
	call decode_descriptor_ (cu_$arg_list_ptr (), 2, arg_type, arg_packed, arg_ndims, arg_size, arg_scale);

	if (arg_type = real_fix_bin_1_dtype) & (arg_packed = "0"b) then
	     error_code = arg_ptr -> based_fb35;	/* caller's code is a single-word fixed binary value */

	else do;					/* caller's code is something else: try to convert it */
	     if (arg_type >= bit_dtype) & (arg_type <= varying_char_dtype) then
		from_size = arg_size;
	     else from_size = (262144 * arg_scale) + arg_size;
	     to_size = 35;				/* target is fixed binary (35) */
	     call assign_ (addr (error_code), (2 * real_fix_bin_1_dtype), to_size, arg_ptr,
		(2 * arg_type + binary (arg_packed, 1)), from_size);
	end;

	buffer_used = 3;				/* we indent these messages 3 space s */
	substr (buffer, 1, buffer_used) = "";

	if error_code ^= 0 then do;			/* get the error message */
	     call convert_status_code_ (error_code, (""), error_message);
	     substr (buffer, (buffer_used + 1), (length (rtrim (error_message)) + 1)) = rtrim (error_message);
	     buffer_used = buffer_used + length (rtrim (error_message)) + 1;
	end;

	begin;					/* always have more than just the code */
dcl  output_message character (buffer_max_lth - buffer_used) unaligned defined (buffer) position (buffer_used + 1);
	     call ioa_$general_rs (cu_$arg_list_ptr (), 3, 4, output_message, output_message_lth, "0"b, "1"b);
	     buffer_used = buffer_used + output_message_lth;
	end;

	call iox_$put_chars (iox_$error_output, buffer_ptr, buffer_used, (0));

	return;

     end print_expansion_error;
%page;
/* Determine if there is at least one address in the list of recipients whose result code is the specified value and which
   was not earlier reported as an error */

is_a_recipient_with_code:
     procedure (p_code) returns (bit (1) aligned);

dcl  p_code fixed binary (35) parameter;
dcl  (list_idx, address_idx) fixed binary;

	do list_idx = 1 to recipients_info.n_lists;
	     recipients_result_list_ptr = recipients_info.lists (list_idx).recipients_result_list_ptr;

	     if recipients_result_list_ptr ^= null () then do;

		do address_idx = 1 to recipients_result_list.n_addresses;
		     result_ptr = addr (recipients_result_list.results (address_idx));

		     if (result.code = p_code) & (length (result.explanation) = 0) & (result.first_entry_idx = 0) then
			return ("1"b);
		end;
	     end;
	end;

	/*** Control arrives here iff there are no recipients with the indicated result code */
	return ("0"b);

     end is_a_recipient_with_code;
%page;
/* Print the list of recipients with the indicated result code */

print_recipient_list:
     procedure (p_code, p_prefix);

dcl  p_code fixed binary (35) parameter;
dcl  p_prefix character (*) parameter;

dcl  (n_recipients, n_recipients_processed, list_idx, address_idx) fixed binary;

	call start_new_output ();			/* initialize the output buffer */
	call add_to_buffer_fixed (p_prefix);

	n_recipients = 0;				/* count the number of interesting recipients first */

	do list_idx = 1 to recipients_info.n_lists;
	     recipients_result_list_ptr = recipients_info.lists (list_idx).recipients_result_list_ptr;
	     if recipients_result_list_ptr ^= null () then do;
		do address_idx = 1 to recipients_result_list.n_addresses;
		     result_ptr = addr (recipients_result_list.results (address_idx));
		     if (result.code = p_code) & (length (result.explanation) = 0) & (result.first_entry_idx = 0) then
			n_recipients = n_recipients + 1;
		end;
	     end;
	end;

	n_recipients_processed = 0;

	do list_idx = 1 to recipients_info.n_lists;
	     address_list_ptr = recipients_info.lists (list_idx).address_list_ptr;
	     recipients_result_list_ptr = recipients_info.lists (list_idx).recipients_result_list_ptr;
	     if recipients_result_list_ptr ^= null () then do;
		do address_idx = 1 to recipients_result_list.n_addresses;
		     result_ptr = addr (recipients_result_list.results (address_idx));
		     if (result.code = p_code) & (length (result.explanation) = 0) & (result.first_entry_idx = 0)
		     then do;
			n_recipients_processed = n_recipients_processed + 1;
			if (n_recipients > 2) & (n_recipients_processed > 1) then call add_to_buffer_fixed (COMMA);
			call add_to_buffer_fixed (SPACE);
			if (n_recipients > 1) & (n_recipients_processed = n_recipients) then
			     call add_to_buffer_fixed (AND_SPACE);
			call get_address_summary (address_list.addresses (address_idx), "0"b);
			call add_to_buffer_varying (address_variable);
		     end;
		end;
	     end;
	end;

	call add_to_buffer_fixed (PERIOD);
	call add_to_buffer_fixed (NL);

	call print_the_buffer ();			/* print it neatly */

	return;

     end print_recipient_list;
%page;
/* Prepare to format a new recipient list in the output buffer */

start_new_output:
     procedure ();

	buffer_ptr = stack_buffer_ptr;		/* start over in the stack */
	buffer_max_lth = stack_buffer_max_lth;
	buffer_used = 0;

	return;

     end start_new_output;



/* Prints the recipient list previously constructed:  The list is folded to the line length of the terminal whenever
   possible */

print_the_buffer:
     procedure ();

dcl  (last_comma, next_comma) fixed binary (21);
dcl  offset fixed binary;

	line_length = get_line_length_$switch (iox_$user_output, (0));

	buffer_printed = 0;
	offset = 0;

	do while (buffer_printed < buffer_used);	/* while there's something left to print */
	     begin;
dcl  rest_of_buffer character (buffer_used - buffer_printed) unaligned defined (buffer) position (buffer_printed + 1);

		last_comma = 0;
		next_comma = index (rest_of_buffer, COMMA);
		if next_comma = 0 then next_comma = length (rest_of_buffer);

		do while (((next_comma + offset) < line_length) & (next_comma < length (rest_of_buffer)));
		     last_comma = next_comma;
		     begin;
dcl  rest_of_rest_of_buffer character (buffer_used - buffer_printed - last_comma) unaligned defined (buffer)
	position (buffer_printed + last_comma + 1);
			next_comma = index (rest_of_rest_of_buffer, COMMA);
			if next_comma = 0 then next_comma = length (rest_of_rest_of_buffer);
			next_comma = last_comma + next_comma;
		     end;
		end;

		if (last_comma ^= 0) & ((next_comma + offset) > line_length) then next_comma = last_comma;

		begin;
dcl  section_to_print character (next_comma) unaligned defined (buffer) position (buffer_printed + 1);
		     call iox_$put_chars (iox_$user_output, addr (section_to_print), length (section_to_print), (0));
		end;

		if next_comma < length (rest_of_buffer) then do;
		     call iox_$put_chars (iox_$user_output, addr (NL), length (NL), (0));
		     call iox_$put_chars (iox_$user_output, addr (THREE_SPACES), length (THREE_SPACES), (0));
		     offset = 3;
		end;

		buffer_printed = buffer_printed + next_comma + 1;
	     end;					/* past the comma and the space after it */
	end;

	return;

     end print_the_buffer;
%page;
/* Add a string to the output buffer: switches to a temporary segment if necessary */

add_to_buffer:
     procedure ();

dcl  p_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 fixed binary (21);

dcl  buffer_in_use character (buffer_used) unaligned based;


add_to_buffer_fixed:				/* ... from a fixed length string */
     entry (p_text);

	text_ptr = addr (p_text);
	text_lth = length (p_text);
	go to ADD_TO_BUFFER_COMMON;


add_to_buffer_varying:				/* ... from a varying string */
     entry (p_varying_text);

	text_ptr = addwordno (addr (p_varying_text), 1);
	text_lth = length (p_varying_text);


ADD_TO_BUFFER_COMMON:
	if (buffer_used + text_lth) > buffer_max_lth then
	     if buffer_ptr = stack_buffer_ptr then do;	/* switch to a temporary segment */
		if segment_buffer_ptr = null () then do;/* ... haven't gotten one already */
		     call get_temp_segment_ (MAIL_SYSTEM_, segment_buffer_ptr, code);
		     if code ^= 0 then go to ERROR_RETURN_FROM_PRINT_DELIVERY_RESULTS;
		     segment_buffer_max_lth = 4 * sys_info$max_seg_size;
		end;
		segment_buffer_ptr -> buffer_in_use = stack_buffer_ptr -> buffer_in_use;
		buffer_ptr = segment_buffer_ptr;
		buffer_max_lth = segment_buffer_max_lth;
	     end;
	     else do;				/* overflowed the temporary segment */
		code = error_table_$area_too_small;
		go to ERROR_RETURN_FROM_PRINT_DELIVERY_RESULTS;
	     end;

	begin;
dcl  new_part character (text_lth) unaligned defined (buffer) position (buffer_used + 1);
	     new_part = text;
	end;

	buffer_used = buffer_used + text_lth;

	return;

     end add_to_buffer;
%page;
/* Tests if an address list is empty */

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

dcl  p_address_list_ptr pointer parameter;

	if p_address_list_ptr = null () then		/* nothing there at all */
	     return ("1"b);

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

     end is_empty_list;
%page;
%include mlsys_data;
%page;
%include mlsys_message;
%page;
%include mlsys_address_types;
%page;
%include mlsys_address_list;
%page;
%include mlsys_deliver_info;
%page;
%include mlsys_reply_options;
%page;
%include mlsys_search_options;
%page;
%include mlsys_format_options;
%page;
%include condition_info;
%page;
%include condition_info_header;

%include io_error_info;
%page;
%include std_descriptor_types;
%page;
%include sub_err_flags;
%page;
/* Definition of whitespace is given here as it generates several blank pages in the listing */

dcl  WHITESPACE character (5) static options (constant) initial ("	
 ");						/* HT NL VT FF SP */

     end mlsys_misc_utils_;




		    mlsys_nit_interface_.pl1        10/02/89  0857.3rew 10/02/89  0819.7       85626



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



/****^  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):
     This changes three entry points to call host_name_ entries instead of
     host_table_ entries if all the domain software is installed.
  2) change(89-07-13,Lee), approve(89-08-01,MCR8125),
     audit(89-08-29,LZimmerman), install(89-10-02,MR12.3-1079):
     Modified the local procedure "canonicalize" to not drop any domains if
     dropping domains causes the name to become ambiguous to the host table.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Interface between the Multics Mail System and the Network Information Table (NIT):  In this release, the NIT does not
   actually exist and this module serves as an interface to the MRDS/CDS host table and nit_data_ CDS segment furnished as
   part of the Hyperchannel TCP/IP RPQ */

/* Created:  July 1983 by G. Palter */
/* Modified: 6 March 1984 by G. Palter to fix error #0425 -- attempting to create an address whose foreign system name is
      actually the name of one of the containing domains of the local system (eg: ARPA for MIT-MULTICS.ARPA) will cause a
      fatal process error */

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

mlsys_nit_interface_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_system_name character (256) varying parameter;

dcl  P_system_name_1 character (256) varying parameter;	/* compare_system_names: the names to be compared */
dcl  P_system_name_2 character (256) varying parameter;	/* ... */

dcl  P_relay_system character (256) varying parameter;	/* is_mail_supported: set to forwarding system if any */
dcl  P_code fixed binary (35) parameter;		/* is_mail_supported */


/* Local copies of parameters */

dcl  system_name character (256) varying;
dcl  relay_system character (256) varying;

/* Remaining declarations */

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

dcl  nit_data_$local_host character (40) varying external;

/* format: off */
dcl (mlsys_et_$ism_not_available, mlsys_et_$no_mail_service, mlsys_et_$unknown_system)
          fixed binary (35) external;

/* format: on */

dcl  host_name_$local_compare entry (character (256), character (256), fixed bin (35)) returns (bit (1) aligned);
dcl  host_name_$qualify_local entry (character (256), fixed bin (35)) returns (character (256));
dcl  host_name_$local_valid_destination entry (char (256), fixed bin (35)) returns (bit (1) aligned);
dcl  mlsys_psp_$ism_not_available entry () returns (bit (1) aligned);
dcl  mlsys_psp_$domains_available entry () returns (bit (1) aligned);

dcl  sub_error_ condition;

dcl  (after, before, length, null, reverse, rtrim, substr, translate) builtin;
%page;
/* Return the host name of the local system */

get_local_system_name:
     entry () returns (character (256) varying);

	if mlsys_psp_$ism_not_available () then		/* no NIT on this system */
	     return ("");

	else return (translate (nit_data_$local_host, UPPERCASE, LOWERCASE));



/* Return the fully qualified host name of the given system */

get_fully_qualified_name:
     entry (P_system_name) returns (character (256) varying);

	on condition (sub_error_) go to RETURN_INPUT_NAME;/* in case the database is damaged */

	if mlsys_psp_$ism_not_available () then		/* no NIT on this system */
RETURN_INPUT_NAME:
	     return (translate (P_system_name, UPPERCASE, LOWERCASE));

	else if canonicalize (P_system_name) = canonicalize ((nit_data_$local_host)) then
	     return (translate (nit_data_$local_host, UPPERCASE, LOWERCASE));
						/* avoid accessing the database when possible */

	else if mlsys_psp_$domains_available () then return (rtrim (host_name_$qualify_local ((P_system_name), (0))));
	else return (translate (host_table_mgr_$primary_name (P_system_name), UPPERCASE, LOWERCASE));
%page;
/* Compare two system names to see if they identify the same system */

compare_system_names:
     entry (P_system_name_1, P_system_name_2) returns (bit (1) aligned);

	on condition (sub_error_) go to COMPARE_LITERAL_SYSTEM_NAMES;

	if mlsys_psp_$ism_not_available () then		/* not NIT on this system */
COMPARE_LITERAL_SYSTEM_NAMES:
	     return (translate (P_system_name_1, UPPERCASE, LOWERCASE)
		= translate (P_system_name_2, UPPERCASE, LOWERCASE));

	else if translate (P_system_name_1, UPPERCASE, LOWERCASE) = translate (P_system_name_2, UPPERCASE, LOWERCASE)
	     then
	     return ("1"b);				/* avoid accessing the database when possible */

	else if mlsys_psp_$domains_available () then
	     return (host_name_$local_compare ((P_system_name_1), (P_system_name_2), (0)));

	else return (host_table_mgr_$primary_name (P_system_name_1) = host_table_mgr_$primary_name (P_system_name_2));


/* Determine if the supplied system name identifies the local system */

is_local_system:
     entry (P_system_name) returns (bit (1) aligned);

	if mlsys_psp_$ism_not_available () then		/* no NIT here: if it's not null, it's foreign */
	     return (P_system_name = "");

	else return (compare_system_names (P_system_name, (nit_data_$local_host)));
%page;
/* Return the canonical form of a system name:  The canonicalized form of a system name is said name translated to
   uppercase with all domains in common to the local system name removed */

canonicalize_system_name:
     entry (P_system_name) returns (character (256) varying);

	return (canonicalize (P_system_name));



/* Actually canonicalizes the name (called by several entrypoints) */

canonicalize:
     procedure (p_system_name) returns (character (256) varying);

dcl  p_system_name character (*) varying parameter;	/* because host_table_mgr_ returns the wrong size */

dcl  canonical_name character (256) varying;
dcl  reversed_name character (256) varying;
dcl  reversed_local_name character (256) varying;
dcl  next_component character (256) varying;
dcl  canonicalized_form character (256) varying;
dcl  end_point fixed binary;
dcl  continue bit (1) aligned;

	canonical_name = translate (p_system_name, UPPERCASE, LOWERCASE);
	end_point = length (p_system_name);

	if mlsys_psp_$ism_not_available () then		/* no NIT on the system */
	     go to RETURN_FROM_CANONICALIZE;

	reversed_name = reverse (canonical_name);
	reversed_local_name = reverse (translate (nit_data_$local_host, UPPERCASE, LOWERCASE));
	continue = "1"b;

	do while (continue);
	     if after (reversed_local_name, ".") = "" then go to RETURN_FROM_CANONICALIZE;
	     next_component = before (reversed_local_name, ".");
	     if before (reversed_name, ".") = next_component then do;
		end_point = end_point - length (next_component) - 1;
		if end_point <= 0 then do;		/* system name is that of a containing domain */
		     end_point = length (p_system_name);
		     go to RETURN_FROM_CANONICALIZE;
		end;
		reversed_name = after (reversed_name, ".");
		reversed_local_name = after (reversed_local_name, ".");
	     end;
	     else continue = "0"b;
	end;

RETURN_FROM_CANONICALIZE:
	canonicalized_form = substr (canonical_name, 1, end_point);

	if end_point < length (p_system_name) then	/* RL: make sure removal of domains still makes name identifiable */
	     if canonicalized_form = host_table_mgr_$primary_name (canonicalized_form) then
						/* couldn't find in host table, return original name */
		return (canonical_name);
	return (canonicalized_form);

     end canonicalize;
%page;
/* Determines if mail can be sent to the given system by checking the NIT */

is_mail_supported:
     entry (P_system_name, P_relay_system, P_code);

dcl  junk bit (1) auto aligned;

	if mlsys_psp_$domains_available () then do;
	     P_relay_system = "";
	     junk = host_name_$local_valid_destination ((P_system_name), P_code);
	     return;
	end;

	on condition (sub_error_) go to RETURN_ISM_NOT_AVAILABLE;

	if mlsys_psp_$ism_not_available () then do;	/* no NIT and/or mailer on this system */
RETURN_ISM_NOT_AVAILABLE:
	     P_code = mlsys_et_$ism_not_available;
	     return;
	end;

	system_name = host_table_mgr_$primary_name (P_system_name);

	relay_system = nit_$get_forwarding_host ("mail", system_name);
	if relay_system ^= "" then
	     service_list_ptr = nit_$get_service_list ("mail", relay_system);
	else service_list_ptr = nit_$get_service_list ("mail", system_name);

	if service_list_ptr ^= null () then do;		/* we can send it mail */
	     free service_list;
	     P_relay_system = relay_system;
	     P_code = 0;				/* success */
	end;

	else if system_name = P_system_name then	/* failure: host_table_mgr_ needs a code argument ... */
	     P_code = mlsys_et_$unknown_system;		/* ... so assume if the name hasn't changed, it's invalid */

	else P_code = mlsys_et_$no_mail_service;	/* failure: no way to send mail to the given system */

	return;
%page;
%include host_table_dcls;

     end mlsys_nit_interface_;




		    mlsys_parse_control_args_.pl1   10/02/89  0857.3rew 10/02/89  0820.1      547038



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



/****^  HISTORY COMMENTS:
  1) change(88-01-13,Blair), approve(88-03-22,MCR7842),
     audit(88-07-08,Lippard), install(88-07-26,MR12.2-1069):
     Make the parse use the mlsys search list to resolve pathnames for
     saveboxes, mailboxes and mailing lists (free standing).  SCP 6349.
  2) change(89-05-11,Lee), approve(89-05-30,MCR8111),
     audit(89-07-12,LZimmerman), install(89-10-02,MR12.3-1079):
     phx21283 (Mail 534) - Modified internal procedure get_mailbox_pathname to
     fix a problem when the entry parse_mailbox_control_args is called; it was
     aborting when the -mbx arg contains a .mbx suffix.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Mail System Utilities which parse the control argument representations of addresses, address lists, and mailboxes */

/* Created:  June 1983 by G. Palter */
/* Modified: March 1984 by G. Palter to fix the following mail system errors:
      #0415 -- read_mail, print_mail, and have_mail do not reject starnames as invalid mailbox specifications
      #0430 -- when parsing command/request line control arguments, use of "-log", "-save", or "-mailbox" followed by
         "-at" should create a foreign address whose address string is "{mbx PATH}".  Otherwise, when the message reaches
         the foreign Multics, the address could be incorrectly interpreted as a savebox belonging to the mailer daemon
      #0433 -- the send_mail command and all send_mail/read_mail requests which accept multiple addresses as arguments do
         not properly parse "-log -at HOST"
      #0435 -- the error message displayed by send_mail when the target address of a mail table entry is invalid only
         includes the name of the mail table entry.  The actual invalid address (eg: mailbox pathname) is not included
      #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 */

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


mlsys_parse_control_args_:
     procedure ();

	return;					/* not an entrypoint */


/* Common parameters */

dcl  P_sci_ptr pointer parameter;			/* -> definition of subsystem for whom we are parsing */
dcl  P_argument_idx fixed binary parameter;		/* identifies first command/request argument to be parsed;
						   set to identify first argument we didn't use in parsing */
dcl  P_parse_ca_options_ptr pointer parameter;		/* -> options describing how to parse */
dcl  P_code fixed binary (35) parameter;


/* parse_address_control_args Parameters */

dcl  P_address_ptr pointer parameter;			/* set -> the address parsed from the command/request line */


/* parse_address_list_control_args Parameters */

dcl  P_address_list_version character (8) parameter;	/* version of address_list structures desired */
dcl  P_normal_address_list_ptr pointer parameter;		/* -> list where all but logbox/savebox addresses are added */
dcl  P_logsave_address_list_ptr pointer parameter;	/* -> list where logbox/savebox addresses are added */


/* parse_mailbox_control_args and parse_mailbox_text Parameters */

dcl  P_mailbox_dirname character (*) parameter;		/* set to the mailbox pathname found on the command line */
dcl  P_mailbox_ename character (*) parameter;		/* ... */


/* parse_mailbox_text Parameters */

dcl  P_mailbox_text character (*) parameter;		/* the text to be converted to a pathname */


/* Local copies of parameters */

dcl  sci_ptr pointer;
dcl  argument_idx fixed binary;
dcl  code fixed binary (35);

dcl  creation_mode fixed binary;			/* extracted from parse_ca_options ... */

dcl  address_ptr pointer;

dcl  mbx_dirname character (168);
dcl  mbx_ename character (32);


/* Remaining declarations */

dcl  argument character (argument_lth) unaligned based (argument_ptr);
dcl  argument_ptr pointer;
dcl  argument_lth fixed binary (21);
dcl  n_arguments fixed binary;

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  abort_the_parse label variable;			/* used by abort_parse internal procedure */

dcl  address_type fixed binary;

dcl  (mailbox_type, mailbox_idx) fixed binary;

dcl  (person_id, project_id) character (32) varying;
dcl  (mte_address_ptr, target_address_ptr) pointer;
dcl  (errors_detected, is_mte_name) bit (1) aligned;
dcl  try_to_create bit (1) unaligned;

dcl  forum_search_list_ptr pointer;

dcl  STACK_EXTENSION fixed binary (18) static options (constant) initial (128);

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

/* format: off */
dcl (USER_OR_MTE_ADDRESS	initial (-1),		/* either a User_id or a mail-table entry name */
     MBX_USER_OR_MTE_ADDRESS	initial (-2))		/* either a mailbox pathname, User_id, or mail-table name */
	fixed binary static options (constant);

dcl (OTHER_MAILBOX		initial (1),		/* not a logbox or savebox */
     USER_LOGBOX		initial (2),
     SAVEBOX		initial (3))
	fixed binary static options (constant);

dcl (error_table_$bad_subr_arg, error_table_$badopt, error_table_$entlong, error_table_$moderr, error_table_$noarg,
     error_table_$noentry, error_table_$nostars, error_table_$no_dir, error_table_$unimplemented_version,
     error_table_$smallarg, mlsys_et_$ca_parse_failed, mlsys_et_$mailbox_exists, mlsys_et_$mte_not_found,
     mlsys_et_$mte_not_mailbox, mlsys_et_$no_mailbox)
	fixed binary (35) external;
/* format: on */

dcl  check_star_name_$entry entry (character (*), fixed binary (35));
dcl  command_query_$yes_no entry () options (variable);
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$generate_call entry (entry, pointer);
dcl  cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35));
dcl  cu_$shrink_stack_frame entry (pointer, fixed binary (35));
dcl  expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
dcl  expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  expand_pathname_$component_add_suffix
	entry (character (*), character (*), character (*), character (*), character (*), fixed binary (35));
dcl  forum_$get_forum_path entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  mail_system_$add_address entry (pointer, pointer, character (8), fixed binary (35));
dcl  mail_system_$create_foreign_address
	entry (character (*) varying, character (256) varying, pointer, character (*) varying, character (*) varying,
	pointer, fixed binary (35));
dcl  mail_system_$create_forum_address
	entry (character (*), character (*), character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_logbox_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_mail_table_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_mailbox_address
	entry (character (*), character (*), character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_mailing_list_address
	entry (character (*), character (*), character (*), character (*) varying, character (*) varying, pointer,
	fixed binary (35));
dcl  mail_system_$create_savebox_address
	entry (character (*) varying, character (*), character (*), character (*) varying, character (*) varying,
	pointer, fixed binary (35));
dcl  mail_system_$create_user_mailbox_address
	entry (character (*) varying, 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_address_type entry (pointer, fixed binary, fixed binary (35));
dcl  mail_system_$get_mail_table_address entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$validate_address entry (pointer, bit (1) aligned, fixed binary (35));
dcl  mailbox_$close entry (fixed binary, fixed binary (35));
dcl  mailbox_$open entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  mlsys_psp_$forum_not_available entry () returns (bit (1) aligned);
dcl  mlsys_user_mte_syntax_$classify_and_validate
	entry (character (*) varying, bit (1) aligned, character (*) varying, character (*) varying, fixed binary (35));
dcl  mlsys_utils_$create_logbox entry (fixed binary (35));
dcl  mlsys_utils_$create_savebox entry (character (*), character (*), fixed binary (35));
dcl  mlsys_utils_$format_address_field
	entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (21), fixed binary (21),
	fixed binary (35));
dcl  mlsys_utils_$print_validate_results entry (pointer, pointer, fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  pathname_$component entry (character (*), character (*), character (*)) returns (character (194));
dcl  search_paths_$find_dir 
	entry (char(*), ptr, char(*), char(*), char(*), fixed bin(35));
dcl  search_paths_$get
	entry (character (*), bit (36), character (*), pointer, pointer, fixed binary, pointer, fixed binary (35));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21));
dcl  ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) var);
dcl  ssu_$print_message entry () options (variable);
dcl  ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21));
dcl  suffixed_name_$make entry (char(*), char(*), char(32), fixed bin(35));
	

dcl  (addr, index, length, min, null, reverse, rtrim, search) builtin;

dcl  cleanup condition;
%page;
/* Converts the control argument representation of an address into its internal form */

parse_address_control_args:
     entry (P_sci_ptr, P_argument_idx, P_parse_ca_options_ptr, P_address_ptr, P_code);

	sci_ptr = P_sci_ptr;
	argument_idx = P_argument_idx;

	parse_ca_options_ptr = P_parse_ca_options_ptr;
	if parse_ca_options.version ^= PARSE_CA_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if (parse_ca_options.logbox_creation_mode < DONT_CREATE_MAILBOX)
	     | (parse_ca_options.logbox_creation_mode > SILENTLY_CREATE_MAILBOX)
	     | (parse_ca_options.savebox_creation_mode < DONT_CREATE_MAILBOX)
	     | (parse_ca_options.savebox_creation_mode > SILENTLY_CREATE_MAILBOX) | (parse_ca_options.mbz ^= ""b)
	then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	address_ptr, forum_search_list_ptr = null ();	/* for cleanup handler */
	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call mail_system_$free_address (address_ptr, (0));
		if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area);
		forum_search_list_ptr = null ();
	     end;

	abort_the_parse = RETURN_FROM_PARSE_ADDRESS_CONTROL_ARGS_WITH_ERRORS;

	call ssu_$return_arg (sci_ptr, n_arguments, ("0"b), (null ()), (0));

	begin;					/* need a list of possible address modifiers */

dcl  host_indeces (n_arguments) fixed binary;

	     call parse_single_address (addr (host_indeces), RETURN_BADOPT_FROM_PARSE_ADDRESS_CONTROL_ARGS);
	end;

	code = 0;					/* success */


RETURN_FROM_PARSE_ADDRESS_CONTROL_ARGS:
	if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area);
	forum_search_list_ptr = null ();

	P_address_ptr = address_ptr;			/* might have an address even after error (^abort&validate) */
	P_argument_idx = argument_idx + 1;		/* to whatever's after the address (or error) */
	P_code = code;

	return;


/* Control arrives here after printing error messages when unable to parse an address control argument representation */

RETURN_FROM_PARSE_ADDRESS_CONTROL_ARGS_WITH_ERRORS:
	code = mlsys_et_$ca_parse_failed;
	go to RETURN_FROM_PARSE_ADDRESS_CONTROL_ARGS;


/* Control arrives here if an unrecognized control argument is encountered while parsing the address representation */

RETURN_BADOPT_FROM_PARSE_ADDRESS_CONTROL_ARGS:
	call abort_parse (sci_ptr, error_table_$badopt, """^a""", argument);
%page;
/* Converts the control argument representation of an address list into its internal form */

parse_address_list_control_args:
     entry (P_sci_ptr, P_argument_idx, P_parse_ca_options_ptr, P_address_list_version, P_normal_address_list_ptr,
	P_logsave_address_list_ptr, P_code);

	sci_ptr = P_sci_ptr;
	argument_idx = P_argument_idx;

	parse_ca_options_ptr = P_parse_ca_options_ptr;
	if parse_ca_options.version ^= PARSE_CA_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if (parse_ca_options.logbox_creation_mode < DONT_CREATE_MAILBOX)
	     | (parse_ca_options.logbox_creation_mode > SILENTLY_CREATE_MAILBOX)
	     | (parse_ca_options.savebox_creation_mode < DONT_CREATE_MAILBOX)
	     | (parse_ca_options.savebox_creation_mode > SILENTLY_CREATE_MAILBOX) | (parse_ca_options.mbz ^= ""b)
	then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	if addr (P_normal_address_list_ptr) ^= addr (P_logsave_address_list_ptr) then
	     if (P_normal_address_list_ptr = P_logsave_address_list_ptr) & (P_normal_address_list_ptr ^= null ())
	     then do;
		/*** The two lists can't be the same list unless the actual parameters are identical; otherwise, when
		     the list is expanded, only one of the two parameters will be properly updated */
		P_code = error_table_$bad_subr_arg;
		return;
	     end;

	address_ptr, forum_search_list_ptr = null ();	/* for cleanup handler */
	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup)
	     begin;
		if address_ptr ^= null () then call mail_system_$free_address (address_ptr, (0));
		if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area);
		forum_search_list_ptr = null ();
	     end;

	abort_the_parse = RETURN_FROM_PARSE_ADDRESS_LIST_CONTROL_ARGS_WITH_ERRORS;

	errors_detected = "0"b;			/* everything's OK so far */
	code = 0;

	call ssu_$return_arg (sci_ptr, n_arguments, ("0"b), (null ()), (0));

CONTINUE_ADDRESS_LIST_PARSE:
	begin;

dcl  host_indeces (n_arguments) fixed binary;

	     do while (argument_idx <= n_arguments);	/* while there's something left on the command/request line */
		call parse_single_address (addr (host_indeces), RETURN_FROM_PARSE_ADDRESS_LIST_CONTROL_ARGS);
		argument_idx = argument_idx + 1;	/* ... to first argument after the address */

		call mail_system_$get_address_type (address_ptr, address_type, (0));
		if (address_type = LOGBOX_ADDRESS) | (address_type = SAVEBOX_ADDRESS) then
		     call mail_system_$add_address (P_logsave_address_list_ptr, address_ptr, P_address_list_version,
			code);
		else call mail_system_$add_address (P_normal_address_list_ptr, address_ptr, P_address_list_version,
			code);
		if code ^= 0 then do;		/* ... can't add the address */
		     call mail_system_$free_address (address_ptr, (0));
		     go to RETURN_FROM_PARSE_ADDRESS_LIST_CONTROL_ARGS;
		end;
	     end;
	end;


RETURN_FROM_PARSE_ADDRESS_LIST_CONTROL_ARGS:
	if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area);
	forum_search_list_ptr = null ();

	P_argument_idx = argument_idx;		/* to whatever's after the address (or error) */

	if code ^= 0 then				/* some fatal error that the caller should hear about */
	     P_code = code;
	else if errors_detected then			/* let the caller know something wasn't quite right ... */
	     P_code = mlsys_et_$ca_parse_failed;
	else P_code = 0;				/* success */

	return;


/* Control arrives here after printing error messages when unable to parse an address control argument representation */

RETURN_FROM_PARSE_ADDRESS_LIST_CONTROL_ARGS_WITH_ERRORS:
	errors_detected = "1"b;			/* remember to set appropriate error code on return ... */
	code = 0;					/* ... and don't return this one if its the last address */

	argument_idx = argument_idx + 1;		/* to first argument after the error */

	if parse_ca_options.abort_on_errors then	/* give up right now (shouldn't ever actually get here) */
	     go to RETURN_FROM_PARSE_ADDRESS_LIST_CONTROL_ARGS;

	else do;					/* otherwise, keep looking */
	     if address_ptr ^= null () then do;
		call mail_system_$get_address_type (address_ptr, address_type, (0));
		if (address_type = LOGBOX_ADDRESS) | (address_type = SAVEBOX_ADDRESS) then
		     call mail_system_$add_address (P_logsave_address_list_ptr, address_ptr, P_address_list_version,
			(0));
		else call mail_system_$add_address (P_normal_address_list_ptr, address_ptr, P_address_list_version,
			(0));
		call mail_system_$free_address (address_ptr, (0));
	     end;					/* ... above free is a no-op if the add_address succeeds */
	     go to CONTINUE_ADDRESS_LIST_PARSE;
	end;
%page;
/* Actually converts the control argument representation of a single address into its internal representation */

parse_single_address:
     procedure (p_host_indeces_ptr, p_badopt_handler);

dcl  p_host_indeces_ptr pointer parameter;
dcl  p_badopt_handler label variable parameter;

dcl  host_indeces (n_arguments) fixed binary based (p_host_indeces_ptr);
dcl  n_hosts fixed binary;

dcl  address_string character (address_string_lth) unaligned based (address_string_ptr);
dcl  address_name character (address_name_lth) unaligned based (address_name_ptr);
dcl  address_comment character (address_comment_lth) unaligned based (address_comment_ptr);
dcl  (address_string_ptr, address_name_ptr, address_comment_ptr) pointer;
dcl  (address_string_lth, address_name_lth, address_comment_lth) fixed binary (21);

dcl  address_buffer_ptr pointer;
dcl  (address_buffer_lth, address_buffer_used) fixed binary (21);

dcl  foreign_system_name character (256) varying;
dcl  address_dirname character (168);
dcl  (address_ename, address_component) character (32);
dcl  trimmed_address_ename character (32) varying;

dcl  (continue_to_peek, include_name_and_comment) bit (1) aligned;
dcl  try_to_create bit (1) unaligned;

dcl  (preliminary_type, address_type, idx) fixed binary;


/**** format: ^indcomtxt */
/* Determine the probable type of address:  The true type can not be determined until after a check is made for host name
   qualification.  By first determining the probably type, sequences such as
	-save PATH -at HOST
   are permitted */
/**** format: indcomtxt */

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

	if index (argument, "-") = 1 then		/* control argument representations ... */
	     if argument = "-user" then do;
		call get_next_argument ("A user name");
		preliminary_type = USER_OR_MTE_ADDRESS;
		address_string_ptr = argument_ptr;
		address_string_lth = argument_lth;
	     end;

	     else if argument = "-log" then do;
		preliminary_type = LOGBOX_ADDRESS;
		address_string_ptr = null ();		/* no explicit string associated with this type of address */
		address_string_lth = 0;
	     end;

	     else if (argument = "-save") | (argument = "-sv") then do;
		call get_next_argument ("A savebox pathname");
		preliminary_type = SAVEBOX_ADDRESS;
		address_string_ptr = argument_ptr;
		address_string_lth = argument_lth;
	     end;

	     else if (argument = "-mailbox") | (argument = "-mbx") then do;
		call get_next_argument ("A mailbox pathname");
		preliminary_type = MAILBOX_ADDRESS;
		address_string_ptr = argument_ptr;
		address_string_lth = argument_lth;
	     end;

	     else if (argument = "-meeting") | (argument = "-mtg") then do;
		call get_next_argument ("A forum meeting pathname");
		preliminary_type = FORUM_ADDRESS;
		address_string_ptr = argument_ptr;
		address_string_lth = argument_lth;
	     end;

	     else if (argument = "-mailing_list") | (argument = "-mls") then do;
		call get_next_argument ("A mailing list pathname");
		preliminary_type = MAILING_LIST_ADDRESS;
		address_string_ptr = argument_ptr;
		address_string_lth = argument_lth;
	     end;

	     else go to p_badopt_handler;		/* no other control arguments are legal at this point */

	else do;					/* non-control argument */
	     preliminary_type = MBX_USER_OR_MTE_ADDRESS;
	     address_string_ptr = argument_ptr;
	     address_string_lth = argument_lth;
	end;


/* Preliminary address type has been determined: check for qualifiers such as host names, address names, and address
   comments.  If multiple names or comments appear after an address, the last one provided will be used */

	n_hosts = 0;				/* no host names yet */

	address_name_ptr,				/* no address name or comment yet */
	     address_comment_ptr = addr (NULL_STRING);
	address_comment_lth, address_name_lth = 0;

	continue_to_peek = (argument_idx < n_arguments);	/* don't bother if there's nothing after the address */

	do while (continue_to_peek);

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

	     if (argument = "-at") | (argument = "-via") | (argument = "-name") | (argument = "-nm")
		| (argument = "-comment") | (argument = "-com") then do;

		/*** A recognized qualifier */
		argument_idx = argument_idx + 1;	/* we hereby claim this argument */

		if (argument = "-at") | (argument = "-via") then do;
		     call get_next_argument ("A host name");
		     n_hosts = n_hosts + 1;
		     host_indeces (n_hosts) = argument_idx;
		end;

		else if (argument = "-name") | (argument = "-nm") then do;
		     call get_next_argument ("A character string");
		     address_name_ptr = argument_ptr;
		     address_name_lth = argument_lth;
		end;

		else if (argument = "-comment") | (argument = "-com") then do;
		     call get_next_argument ("A character string");
		     address_comment_ptr = argument_ptr;
		     address_comment_lth = argument_lth;
		end;

		continue_to_peek = (argument_idx < n_arguments);
	     end;

	     else continue_to_peek = "0"b;		/* either the next address or something ... */
	end;


/* Have all address qualifiers: determine the actual address type assuming that the address were local ... */

	if n_hosts = 0 then				/* truly local */
	     if preliminary_type = USER_OR_MTE_ADDRESS then do;
		call mlsys_user_mte_syntax_$classify_and_validate ((address_string), is_mte_name, (""), (""), code);
		if code ^= 0 then			/* ... bad syntax */
		     call abort_parse (sci_ptr, code, "-user ^a", address_string);
		if is_mte_name then
		     preliminary_type = MAIL_TABLE_ADDRESS;
		else preliminary_type = USER_MAILBOX_ADDRESS;
	     end;

	     else if preliminary_type = MBX_USER_OR_MTE_ADDRESS then
		if search (address_string, "<>") ^= 0 then
		     preliminary_type = MAILBOX_ADDRESS;
		else do;
		     call mlsys_user_mte_syntax_$classify_and_validate ((address_string), is_mte_name, (""), (""),
			code);
		     if code ^= 0 then		/* ... bad syntax */
			call abort_parse (sci_ptr, code, "^a", address_string);
		     if is_mte_name then
			preliminary_type = MAIL_TABLE_ADDRESS;
		     else preliminary_type = USER_MAILBOX_ADDRESS;
		end;

	     else ;				/* a known type of local address */

	else /*** if n_hosts > 0 then */
	     if (preliminary_type = USER_OR_MTE_ADDRESS) | (preliminary_type = MBX_USER_OR_MTE_ADDRESS) then
	     preliminary_type = FOREIGN_ADDRESS;


/* Construct the address assuming that it's local:  If it's actually foreign, the address name and comment will be
   ommitted as they'll be included later in the actual foreign address */

	if (preliminary_type ^= FOREIGN_ADDRESS) then do;

	     include_name_and_comment = (n_hosts = 0);	/* don't include these unless this is the real address */

	     if preliminary_type = USER_MAILBOX_ADDRESS then do;
		if include_name_and_comment then
		     call mail_system_$create_user_mailbox_address ((address_string), (address_name),
			(address_comment), address_ptr, code);
		else call mail_system_$create_user_mailbox_address ((address_string), "", "", address_ptr, code);
		if code ^= 0 then call abort_parse (sci_ptr, code, "-user ^a", address_string);
	     end;

	     else if preliminary_type = LOGBOX_ADDRESS then do;
		if include_name_and_comment then
		     call mail_system_$create_logbox_address (mlsys_data_$user_id, (address_name), (address_comment),
			address_ptr, code);
		else call mail_system_$create_logbox_address (mlsys_data_$user_id, "", "", address_ptr, code);
		if code ^= 0 then call abort_parse (sci_ptr, code, "-log");
	     end;

	     else if preliminary_type = SAVEBOX_ADDRESS then do;
		if has_suffix (address_string, ".sv") then address_string_lth = address_string_lth - length (".sv");
		if search (address_string, "<>") = 0 then do;
		     call suffixed_name_$make (address_string, "sv.mbx", address_ename, code);
		     call search_paths_$find_dir ("mlsys", null(), address_ename, "", address_dirname, code);
		     if code = error_table_$noentry then
			call expand_pathname_$add_suffix (address_string, "sv.mbx", address_dirname, address_ename, code);
		     if code ^= 0 then call abort_parse (sci_ptr, code, "Searching the ""mlsys"" search list for ^a", address_ename);
		     end;
		else do;
		     call expand_pathname_$add_suffix (address_string, "sv.mbx", address_dirname, address_ename, code);
		     if code ^= 0 then call abort_parse (sci_ptr, code, "-save ^a", address_string);
		     end;

		call reject_starnames ("-save", address_dirname, address_ename, "");
		if include_name_and_comment then
		     call mail_system_$create_savebox_address (mlsys_data_$user_id, address_dirname, address_ename,
			(address_name), (address_comment), address_ptr, code);
		else call mail_system_$create_savebox_address (mlsys_data_$user_id, address_dirname, address_ename,
			"", "", address_ptr, code);
		if code ^= 0 then
		     call abort_parse (sci_ptr, code, "-save ^a", pathname_ (address_dirname, address_ename));
	     end;

	     else if preliminary_type = MAILBOX_ADDRESS then do;
		if search (address_string, "<>") = 0 then do;
		     call suffixed_name_$make (address_string, "mbx", address_ename, code);
		     if code ^= 0 then call abort_parse (sci_ptr, code, "^a", address_string);
		     call search_paths_$find_dir ("mlsys", null(), address_ename, "", address_dirname, code);
		     if code = error_table_$noentry then
			call expand_pathname_$add_suffix (address_string, "mbx", address_dirname, address_ename, code);
		     if code ^= 0 then call abort_parse (sci_ptr, code, "Searching the ""mlsys"" search list for ^a", address_ename);
		     end;
		else do;
		     call expand_pathname_$add_suffix (address_string, "mbx", address_dirname, address_ename, code);
		     if code ^= 0 then call abort_parse (sci_ptr, code, "-mailbox ^a", address_string);
		     end;
		call reject_starnames ("-mailbox", address_dirname, address_ename, "");
		if include_name_and_comment then
		     call mail_system_$create_mailbox_address (address_dirname, address_ename, (address_name),
			(address_comment), address_ptr, code);
		else call mail_system_$create_mailbox_address (address_dirname, address_ename, "", "", address_ptr,
			code);
		if code ^= 0 then
		     call abort_parse (sci_ptr, code, "-mailbox ^a", pathname_ (address_dirname, address_ename));
	     end;

	     else if preliminary_type = FORUM_ADDRESS then do;
		if search (address_string, "<>") = 0 then do;
		     /*** ... not a pathname: must find the meeting by search list */
		     if length (rtrim (address_string)) > length (address_ename) then
			call abort_parse (sci_ptr, error_table_$entlong, "-meeting ^a", address_string);
		     address_ename = address_string;
		     if ^(has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control")) then
			if length (rtrim (address_ename)) > (length (address_ename) - length (".forum")) then
			     call abort_parse (sci_ptr, error_table_$entlong, "-meeting ^a", address_ename);
		     call reject_starnames ("-meeting", "", address_ename, "");
		     if mlsys_psp_$forum_not_available () then
			/*** ... Forum PSP not here: we've done all we can; mlsys_transmit_ will do the rest */
			address_dirname = "";
		     else do;
			/*** ... time to scan the search list */
			if forum_search_list_ptr = null () then do;
			     call search_paths_$get ("forum", sl_control_default, "", null (), system_area_ptr,
				sl_info_version_1, forum_search_list_ptr, code);
			     if code ^= 0 then
				call abort_parse (sci_ptr, code, "Listing the ""forum"" search list.");
			end;
			if has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control") then
			     call search_forum_list (address_ename, address_dirname, code);
			else do;			/* ... try version 2 then version 1 meetings ... */
			     trimmed_address_ename = rtrim (address_ename);
			     call search_forum_list ((trimmed_address_ename || ".forum"), address_dirname, code);
			     if code = 0 then
				address_ename = trimmed_address_ename || ".forum";
			     else do;
				call search_forum_list ((trimmed_address_ename || ".control"), address_dirname,
				     code);
				if code = 0 then address_ename = trimmed_address_ename || ".control";
			     end;
			end;
			if code ^= 0 then		/* ... couldn't be found */
			     address_dirname = "";
		     end;
		end;
		else do;
		     /*** ... user has supplied a pathname */
		     call expand_pathname_ (address_string, address_dirname, address_ename, code);
		     if code ^= 0 then call abort_parse (sci_ptr, code, "-meeting ^a", address_string);
		     if ^(has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control")) then
			if length (rtrim (address_ename)) > (length (address_ename) - length (".forum")) then
			     call abort_parse (sci_ptr, error_table_$entlong, "-meeting ^a",
				pathname_ (address_dirname, address_ename));
		     call reject_starnames ("-meeting", address_dirname, address_ename, "");
		     if mlsys_psp_$forum_not_available () then
			;			/* ... no Forum PSP: we've done all we can */
		     else do;
			if ^(has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control")) then do;
			     /*** ... must determine the meeting version */
			     trimmed_address_ename = rtrim (address_ename);
			     address_ename = trimmed_address_ename || ".forum";
			     call forum_$get_forum_path (address_dirname, address_ename, ((168)" "), ((32)" "),
				code);
			     if code ^= 0 then	/* ... not version 2 */
				if (length (trimmed_address_ename) + length (".control"))
				     <= length (address_ename) then
				     address_ename = trimmed_address_ename || ".control";
			end;
		     end;
		end;
		if include_name_and_comment then
		     call mail_system_$create_forum_address (address_dirname, address_ename, (address_name),
			(address_comment), address_ptr, code);
		else call mail_system_$create_forum_address (address_dirname, address_ename, "", "", address_ptr,
			code);
		if code ^= 0 then
		     call abort_parse (sci_ptr, code, "-meeting ^[^a^s^;^s^a^]", (address_dirname = ""),
			address_ename, pathname_ (address_dirname, address_ename));
	     end;

	     else if preliminary_type = MAIL_TABLE_ADDRESS then do;
		if include_name_and_comment then
		     call mail_system_$create_mail_table_address ((address_string), (address_name), (address_comment),
			address_ptr, code);
		else call mail_system_$create_mail_table_address ((address_string), "", "", address_ptr, code);
		if code ^= 0 then call abort_parse (sci_ptr, code, "-user ^a", address_string);
	     end;

	     else /*** if preliminary_type = MAILING_LIST_ADDRESS then */
		do;
		call expand_pathname_$component_add_suffix (address_string, "mls", address_dirname, address_ename,
		     address_component, code);
		if code ^= 0 then call abort_parse (sci_ptr, code, "-mailing_list ^a", address_string);
		if search (address_string, "<>") = 0 then do;
		     address_dirname = "";
		     call search_paths_$find_dir ("mlsys", null(), address_ename, "", address_dirname, code);
		     if code = error_table_$noentry then
		         call expand_pathname_$component_add_suffix (address_string, "mls", address_dirname, address_ename,
		         address_component, code);
		     if code ^= 0 then call abort_parse (sci_ptr, code, "Searching the ""mlsys"" search list for ^a", address_ename);
		     end;
		call reject_starnames ("-mailing_list", address_dirname, address_ename, address_component);
		if include_name_and_comment then
		     call mail_system_$create_mailing_list_address (address_dirname, address_ename, address_component,
			(address_name), (address_comment), address_ptr, code);
		else call mail_system_$create_mailing_list_address (address_dirname, address_ename, address_component,
			"", "", address_ptr, code);
		if code ^= 0 then
		     call abort_parse (sci_ptr, code, "-mailing_list ^a",
			pathname_$component (address_dirname, address_ename, address_component));
	     end;
	end;


/* Construct the foreign "mailbox" name of the address from the printed representation of the above local address ... */

	address_buffer_ptr = null ();

	if n_hosts > 0 then do;			/* only if it's foreign ... */
	     if (preliminary_type = LOGBOX_ADDRESS) | (preliminary_type = SAVEBOX_ADDRESS) then do;
		call mail_system_$get_address_pathname (address_ptr, address_dirname, address_ename, ((32)" "), (0));
		call mail_system_$free_address (address_ptr, (0));
		call mail_system_$create_mailbox_address (address_dirname, address_ename, "", "", address_ptr, code);
		if code ^= 0 then
		     call abort_parse (sci_ptr, code, "Converting ^[-log^s^;-save ^a^] into a mailbox address.",
			(preliminary_type = LOGBOX_ADDRESS), pathname_ (address_dirname, address_ename));
	     end;

	     if preliminary_type ^= FOREIGN_ADDRESS then do;
		call cu_$grow_stack_frame (STACK_EXTENSION, address_buffer_ptr, (0));
		address_buffer_lth = 4 * STACK_EXTENSION;
						/* get an initial buffer */
		code = error_table_$smallarg;		/* need do until ... */
		do while (code = error_table_$smallarg);/* ... until the buffer's large enough to hold it */
		     address_buffer_used = 0;
		     call mlsys_utils_$format_address_field ("", address_ptr, -1, address_buffer_ptr,
			address_buffer_lth, address_buffer_used, code);
		     if code = error_table_$smallarg then do;
						/* ... not large enough yet */
			call cu_$grow_stack_frame (STACK_EXTENSION, (null ()), (0));
			address_buffer_lth = address_buffer_lth + (4 * STACK_EXTENSION);
		     end;
		end;
		address_string_ptr = address_buffer_ptr;/* have the "real" mailbox name now */
		address_string_lth = address_buffer_used;
		call mail_system_$free_address (address_ptr, (0));
	     end;					/* ... no longer need the local address */
	end;


/* Construct the true address if it's a foreign address */

	if (preliminary_type = FOREIGN_ADDRESS) | (n_hosts > 0) then do;

	     call ssu_$arg_ptr (sci_ptr, host_indeces (1), argument_ptr, argument_lth);
	     foreign_system_name = argument;		/* first host name is where the address resides */

	     begin;				/* build the explicit route (if any) */

dcl  1 local_address_route aligned,
       2 header like address_route.header,
       2 relays (min (1, (n_hosts - 1))) character (256) varying;

		local_address_route.version = ADDRESS_ROUTE_VERSION_1;
		local_address_route.n_relays = n_hosts - 1;
		do idx = 1 to local_address_route.n_relays;
		     call ssu_$arg_ptr (sci_ptr, host_indeces (idx + 1), argument_ptr, argument_lth);
		     local_address_route.relays (idx) = argument;
		end;

		if n_hosts > 1 then
		     call mail_system_$create_foreign_address ((address_string), foreign_system_name,
			addr (local_address_route), (address_name), (address_comment), address_ptr, code);
		else call mail_system_$create_foreign_address ((address_string), foreign_system_name, null (),
			(address_name), (address_comment), address_ptr, code);
	     end;

	     if code ^= 0 then call abort_parse (sci_ptr, code, "^a -at ^a", address_string, foreign_system_name);
	end;

	if address_buffer_ptr ^= null () then call cu_$shrink_stack_frame (address_buffer_ptr, (0));


/* Finally, if requested, verify that mail can be sent to the given address */

	if parse_ca_options.validate_addresses then do;

	     call mail_system_$validate_address (address_ptr, "0"b, code);

	     if code = mlsys_et_$no_mailbox then do;
		/*** Mailbox not found: check if logbox/savebox and create if necessary */
		call mail_system_$get_address_type (address_ptr, address_type, (0));
		if address_type = LOGBOX_ADDRESS then creation_mode = parse_ca_options.logbox_creation_mode;
		else if address_type = SAVEBOX_ADDRESS then creation_mode = parse_ca_options.savebox_creation_mode;
		else creation_mode = DONT_CREATE_MAILBOX;
		if creation_mode ^= DONT_CREATE_MAILBOX then do;
		     call mail_system_$get_address_pathname (address_ptr, address_dirname, address_ename, ((32)" "),
			(0));
		     if creation_mode = QUERY_TO_CREATE_MAILBOX then do;
			call command_query_$yes_no (try_to_create, 0, ssu_$get_subsystem_and_request_name (sci_ptr),
			     "", "Do you wish to create ^[your logbox^;the savebox ^a^]?",
			     (address_type = LOGBOX_ADDRESS), pathname_ (address_dirname, address_ename));
			if ^try_to_create then call abort_parse (sci_ptr, 0);
		     end;
		     if address_type = LOGBOX_ADDRESS then
			call mlsys_utils_$create_logbox (code);
		     else /*** if address_type = SAVEBOX_ADDRESS then */
			call mlsys_utils_$create_savebox (address_dirname, address_ename, code);
		     if code = 0 then
			if creation_mode = CREATE_AND_ANNOUNCE_MAILBOX then
			     call ssu_$print_message (sci_ptr, 0, "Created ^a.",
				pathname_ (address_dirname, address_ename));
		     if code = mlsys_et_$mailbox_exists then code = 0;
		end;
	     end;

	     if code ^= 0 then do;			/* the address is invalid ... */
		call mlsys_utils_$print_validate_results (sci_ptr, address_ptr, code);
		call abort_parse (sci_ptr, 0);
	     end;
	end;

	return;



/* Internal to parse_single_address: rejects pathnames containing starnames */

reject_starnames:
	procedure (p_control_argument, p_dirname, p_ename, p_component);

dcl  p_control_argument character (*) parameter;
dcl  p_dirname character (168);
dcl  (p_ename, p_component) character (32) parameter;
dcl  code fixed binary (35);

	     call check_star_name_$entry (p_ename, code); /* first check the entryname */
	     if code = 0 then			/* ... entryname OK: check the component name (if present) */
		if p_component ^= "" then call check_star_name_$entry (p_component, code);

	     if (code = 1) | (code = 2) then code = error_table_$nostars;

	     if code ^= 0 then			/* either a starname or invalid syntax */
		if p_dirname = "" then		/* ... no directory: pathname_ does the wrong thing here */
		     call abort_parse (sci_ptr, code, "^a ^a", p_control_argument, p_ename);
		else call abort_parse (sci_ptr, code, "^a ^a", p_control_argument,
			pathname_$component (p_dirname, p_ename, p_component));

	     return;

	end reject_starnames;



/* Internal to parse_single_address: scans the forum search list (already obtained above) for the given entryname */

search_forum_list:
	procedure (p_ename, p_dirname, p_code);

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

dcl  ename character (32) initial ("");
dcl  idx fixed binary;

	     if length (rtrim (p_ename)) > length (ename) then do;
		p_code = error_table_$entlong;	/* ... constructed entry name is too long */
		return;
	     end;

	     p_code = 1;				/* need do until ... */

	     do idx = 1 to forum_search_list_ptr -> sl_info.num_paths while (p_code ^= 0);
		if forum_search_list_ptr -> sl_info.paths (idx).code = 0 then
		     call forum_$get_forum_path (forum_search_list_ptr -> sl_info.paths (idx).pathname, p_ename,
			((168)" "), ((32)" "), p_code);
		if p_code = 0 then p_dirname = forum_search_list_ptr -> sl_info.paths (idx).pathname;
	     end;

	     return;

	end search_forum_list;

     end parse_single_address;
%page;
/* Converts the control argument representation of a mailbox into the pathname of the mailbox */

parse_mailbox_control_args:
     entry (P_sci_ptr, P_argument_idx, P_parse_ca_options_ptr, P_mailbox_dirname, P_mailbox_ename, P_code);

	sci_ptr = P_sci_ptr;
	argument_idx = P_argument_idx;

	parse_ca_options_ptr = P_parse_ca_options_ptr;
	if parse_ca_options.version ^= PARSE_CA_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if (parse_ca_options.logbox_creation_mode < DONT_CREATE_MAILBOX)
	     | (parse_ca_options.logbox_creation_mode > SILENTLY_CREATE_MAILBOX)
	     | (parse_ca_options.savebox_creation_mode < DONT_CREATE_MAILBOX)
	     | (parse_ca_options.savebox_creation_mode > SILENTLY_CREATE_MAILBOX) | (parse_ca_options.mbz ^= ""b)
	then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	mte_address_ptr, target_address_ptr = null ();	/* for cleanup handler */
	mailbox_idx = 0;

	mbx_ename = "";				/* indicates that we have no pathname */

	on condition (cleanup)
	     begin;
		if mte_address_ptr ^= null () then call mail_system_$free_address (mte_address_ptr, (0));
		if target_address_ptr ^= null () then call mail_system_$free_address (target_address_ptr, (0));
		if mailbox_idx ^= 0 then call mailbox_$close (mailbox_idx, (0));
		mailbox_idx = 0;
	     end;

	abort_the_parse = RETURN_FROM_PARSE_MAILBOX_CONTROL_ARGS_WITH_ERRORS;

	call ssu_$return_arg (sci_ptr, n_arguments, ("0"b), (null ()), (0));

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


	if index (argument, "-") = 1 then		/* control argument representations ... */
	     if (argument = "-mailbox") | (argument = "-mbx") then do;
		call get_next_argument ("A mailbox pathname");
		call get_mailbox_pathname (argument);
	     end;

	     else if argument = "-user" then do;
		call get_next_argument ("A user name");
		call get_user_mailbox_pathname (argument, "0"b, ("0"b));
	     end;					/* ... non-null sci_ptr causes above to not return on error */

	     else if argument = "-log" then do;
		mailbox_type = USER_LOGBOX;
		/*** following call must work as the "constant" address is always correct */
		call mail_system_$get_address_pathname (mlsys_data_$user_logbox_address, mbx_dirname, mbx_ename,
		     ((32)" "), (0));
	     end;

	     else if (argument = "-save") | (argument = "-sv") then do;
		call get_next_argument ("A savebox pathname");
		call get_savebox_pathname (argument);
	     end;					/* ... non-null sci_ptr causes above to not return on error */

	     else call abort_parse (sci_ptr, error_table_$badopt, """^a""", argument);
						/* unrecognized control argument */

	else call parse_mailbox_text_internal (argument); /* not a control argument: specifies pathname somehow */


/* Here iff we have a mailbox pathname: verify its existence if requested by the caller */

	if mailbox_type = OTHER_MAILBOX then creation_mode = DONT_CREATE_MAILBOX;
	else if mailbox_type = USER_LOGBOX then creation_mode = parse_ca_options.logbox_creation_mode;
	else /*** if mailbox_type = SAVEBOX then */
	     creation_mode = parse_ca_options.savebox_creation_mode;

	if parse_ca_options.validate_addresses then do;
	     call mailbox_$open (mbx_dirname, mbx_ename, mailbox_idx, code);
	     if code = error_table_$moderr then code = 0; /* ... it's there although we can't access it */

	     if (code = error_table_$noentry) & (creation_mode ^= DONT_CREATE_MAILBOX) then do;
		if creation_mode = QUERY_TO_CREATE_MAILBOX then do;
		     call command_query_$yes_no (try_to_create, 0, ssu_$get_subsystem_and_request_name (sci_ptr), "",
			"Do you wish to create ^[your logbox^;the savebox ^a^]?", (mailbox_type = USER_LOGBOX),
			pathname_ (mbx_dirname, mbx_ename));
		     if ^try_to_create then call abort_parse (sci_ptr, 0);
		end;
		if mailbox_type = USER_LOGBOX then
		     call mlsys_utils_$create_logbox (code);
		else /*** if mailbox_type = SAVEBOX then */
		     call mlsys_utils_$create_savebox (mbx_dirname, mbx_ename, code);
		if code = 0 then			/* ... just created it ... */
		     if creation_mode = CREATE_AND_ANNOUNCE_MAILBOX then
			call ssu_$print_message (sci_ptr, 0, "Created ^a.", pathname_ (mbx_dirname, mbx_ename));
		if code = mlsys_et_$mailbox_exists then code = 0;
	     end;

	     if code ^= 0 then			/* ... can't find or create it */
		call abort_parse (sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename));
	end;

	code = 0;					/* success! */


RETURN_FROM_PARSE_MAILBOX_CONTROL_ARGS:			/* ... error case will transfer here */
	if mte_address_ptr ^= null () then call mail_system_$free_address (mte_address_ptr, (0));
	if target_address_ptr ^= null () then call mail_system_$free_address (target_address_ptr, (0));
	if mailbox_idx ^= 0 then call mailbox_$close (mailbox_idx, (0));
	mailbox_idx = 0;

	if mbx_ename ^= "" then do;			/* got a pathname (even after an error (^abort&validate)) */
	     P_mailbox_dirname = mbx_dirname;
	     P_mailbox_ename = mbx_ename;
	end;

	P_argument_idx = argument_idx + 1;		/* to first argument after the mailbox argument(s) */
	P_code = code;

	return;


/* Control arrives here after printing error messages when unable to parse a mailbox control argument representation */

RETURN_FROM_PARSE_MAILBOX_CONTROL_ARGS_WITH_ERRORS:
	code = mlsys_et_$ca_parse_failed;
	go to RETURN_FROM_PARSE_MAILBOX_CONTROL_ARGS;
%page;
/* Converts the printed representation of a mailbox pathname into the actual pathname:  This printed representation is
   equivalent to the non-control argument case of the control argument representation.  If the text contains either a "<"
   or ">", it is interpreted as a pathname.  If it ends in either ".sv.mbx" or ".mbx", it is interpreted as a savebox or
   mailbox pathname, respectively.  Otherwise, the text is an entryname, and a check is made for a mailbox in the working
   directory with that name; if no mailbox is found, a check is made for a savebox; if no savebox is found, the text is
   interpreted as a user name and the corresponding default mailbox or mail table entry is used */

parse_mailbox_text:
     entry (P_mailbox_text, P_mailbox_dirname, P_mailbox_ename, P_code);

	sci_ptr = null ();				/* don't print anything: just return a code */

	mte_address_ptr, target_address_ptr = null ();	/* for cleanup handler */
	mailbox_idx = 0;

	on condition (cleanup)
	     begin;
		if mte_address_ptr ^= null () then call mail_system_$free_address (mte_address_ptr, (0));
		if target_address_ptr ^= null () then call mail_system_$free_address (target_address_ptr, (0));
		if mailbox_idx ^= 0 then call mailbox_$close (mailbox_idx, (0));
		mailbox_idx = 0;
	     end;

	abort_the_parse = RETURN_FROM_PARSE_MAILBOX_TEXT;

	call parse_mailbox_text_internal (P_mailbox_text);/* do it */

	P_mailbox_dirname = mbx_dirname;		/* here iff all was OK */
	P_mailbox_ename = mbx_ename;
	P_code = 0;

RETURN_FROM_PARSE_MAILBOX_TEXT:
	if mte_address_ptr ^= null () then call mail_system_$free_address (mte_address_ptr, (0));
	if target_address_ptr ^= null () then call mail_system_$free_address (target_address_ptr, (0));
	if mailbox_idx ^= 0 then call mailbox_$close (mailbox_idx, (0));
	mailbox_idx = 0;

	return;



/* Actually parses the printed representation of a mailbox pathname: called by several entrypoints */

parse_mailbox_text_internal:
     procedure (p_text);

dcl  p_text character (*) parameter;

dcl  saved_mbx_dirname character (168);
dcl  saved_mbx_ename character (32);
dcl  saved_code fixed binary (35);

dcl  trimmed_ename character (32) varying;
dcl  not_user_name bit (1) aligned;
dcl  use_search_paths bit (1) aligned;
dcl  search_paths_$get entry (char(*), bit(36), char(*), ptr, ptr, fixed bin, ptr, fixed bin(35));
dcl  loop_idx fixed bin;
dcl  idx fixed bin;
dcl  mlsys_search_list_ptr ptr;

          use_search_paths = "0"b;
	system_area_ptr = get_system_free_area_ ();
          if search (p_text, "<>") = 0 then do;
	     call search_paths_$get ("mlsys", sl_control_default, "", null(), system_area_ptr, sl_info_version_1, mlsys_search_list_ptr, code);
	     loop_idx = mlsys_search_list_ptr -> sl_info.num_paths;
	     use_search_paths = "1"b;
	     mbx_ename = p_text;
	end;
          else do;
	     loop_idx = 1;
	     call expand_pathname_ (p_text, mbx_dirname, mbx_ename, code);
	     if code ^= 0 then do;			/* bad pathname ... */
		saved_code = code;
		call get_user_mailbox_pathname (p_text, "1"b, not_user_name);
		if not_user_name then call abort_parse (sci_ptr, saved_code, "^a", p_text);
		else if mailbox_exists () then return;	/* ... but it was a valid User_id/MTE name */
		else if ^is_mte_name & (code = error_table_$no_dir) then
		     call abort_parse (sci_ptr, saved_code, "^a", p_text);
		else call abort_parse (sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename));
		end;
	     end;                                         /* looked like a pathname */
	saved_mbx_ename = mbx_ename;
	if code = 0 then do;
	     code =1;
	     do idx = 1 to loop_idx while (code ^= 0);
		if use_search_paths then mbx_dirname = mlsys_search_list_ptr -> sl_info.paths(idx).pathname;
		
		     

	saved_mbx_dirname = mbx_dirname;		/* needed in case nothing works */
	saved_code = 0;				/* this will be set later to describe first failure */

	trimmed_ename = rtrim (mbx_ename);		/* needed for suffix checking */

	call check_star_name_$entry (mbx_ename, code);
	if (code = 1) | (code = 2) then code = error_table_$nostars;
	if code ^= 0 then do;			/* bad entry name ... */
	     saved_code = code;
	     go to TRY_USER_NAME_OR_MTE_HUERISTIC;	/* ... is OK for now: might be an MTE name */
	end;

	if has_suffix (trimmed_ename, ".sv.mbx") | has_suffix (trimmed_ename, ".sv") then go to TRY_SAVEBOX_HUERISTIC;
						/* ends with ".sv" or ".sv.mbx": try first as a savebox */


/* Try it as an ordinary mailbox */

	mailbox_type = OTHER_MAILBOX;

	if ^has_suffix (trimmed_ename, ".mbx") then do;	/* need to add "mbx" suffix */
	     if (length (trimmed_ename) + length (".mbx")) > length (mbx_ename) then do;
		saved_code = error_table_$entlong;
		go to TRY_USER_NAME_OR_MTE_HUERISTIC;
	     end;
	     else mbx_ename = trimmed_ename || ".mbx";
	end;

	if mailbox_exists () then
	     return;				/* found it! */
	else do;					/* something went wrong */
	     saved_code = code;
	     if trimmed_ename = mbx_ename then		/* ... ends with ".mbx": don't try as a savebox */
		go to TRY_USER_NAME_OR_MTE_HUERISTIC;
	end;


/* Try it as a savebox */

TRY_SAVEBOX_HUERISTIC:
	mailbox_type = SAVEBOX;

	if has_suffix (trimmed_ename, ".sv.mbx") then ;
	else if has_suffix (trimmed_ename, ".sv") then do;/* need to add just ".mbx" suffix */
	     if (length (trimmed_ename) + length (".mbx")) > length (mbx_ename) then do;
		saved_code = error_table_$entlong;
		go to TRY_USER_NAME_OR_MTE_HUERISTIC;
	     end;
	     else mbx_ename = trimmed_ename || ".mbx";
	end;
	else do;					/* no suffix: have already tried it as a mailbox */
	     if (length (trimmed_ename) + length (".sv.mbx")) > length (mbx_ename) then
		go to TRY_USER_NAME_OR_MTE_HUERISTIC;
	     mbx_ename = trimmed_ename || ".sv.mbx";
	end;

	if mailbox_exists () then
	     return;				/* found it! */
	else do;					/* something went wrong */
	     if saved_code = 0 then saved_code = code;
	end;


/* Try it as a User_id or mail table entry (MTE) name */

TRY_USER_NAME_OR_MTE_HUERISTIC:
	call get_user_mailbox_pathname (p_text, "1"b, not_user_name);
	if not_user_name & (idx = loop_idx) then do;	/* doesn't look like a User_id or MTE name */
	     if use_search_paths then
		call abort_parse (sci_ptr, saved_code, "Looking in mlsys search paths for ^a^[.mbx^]",
		saved_mbx_ename, ^has_suffix (saved_mbx_ename, ".mbx"));		
	     else call abort_parse (sci_ptr, saved_code, "^a^[.mbx^]", pathname_ (saved_mbx_dirname, saved_mbx_ename),
		^has_suffix (saved_mbx_ename, ".mbx"));
	     end;
	

	if mailbox_exists () then return;		/* found it! */
	else if idx = loop_idx then
	     if ^is_mte_name & (code = error_table_$no_dir) then
	     call abort_parse (sci_ptr, saved_code, "^a^[.mbx^]", pathname_ (saved_mbx_dirname, saved_mbx_ename),
		^has_suffix (saved_mbx_ename, ".mbx"));
	     else call abort_parse (sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename));
	mbx_ename = saved_mbx_ename;             /* In case we go round again */
	end;
     end;


/* Internal to parse_mailbox_text_internal: checks if a given mailbox exists */

mailbox_exists:
	procedure () returns (bit (1) aligned);

	     call mailbox_$open (mbx_dirname, mbx_ename, mailbox_idx, code);
	     if code = error_table_$moderr then code = 0;

	     if mailbox_idx ^= 0 then call mailbox_$close (mailbox_idx, (0));

	     return ((code = 0));

	end mailbox_exists;

     end parse_mailbox_text_internal;
%page;
/* Get the pathname of an ordinary mailbox */

get_mailbox_pathname:
     procedure (p_text);

dcl  p_text character (*) parameter;

     if search (p_text, "<>") > 0 then do;
	call expand_pathname_$add_suffix (p_text, "mbx", mbx_dirname, mbx_ename, code);
	if code ^= 0 then call abort_parse (sci_ptr, code, "^a", p_text);
	end;
     else do;
	/* phx21283, RL - modified following if/else statement to handle .mbx suffix correctly */
	if ^has_suffix (p_text, ".mbx") then do;
	     call suffixed_name_$make (p_text, "mbx", mbx_ename, code);
	     if code ^= 0 then call abort_parse (sci_ptr, code, "^a", p_text);
          end;
	else
	     mbx_ename = p_text;
          call search_paths_$find_dir ("mlsys", null(), mbx_ename, "", mbx_dirname, code);
	if code = error_table_$noentry then
	     call expand_pathname_$add_suffix (p_text, "mbx", mbx_dirname, mbx_ename, code);
	if code ^= 0 then call abort_parse (sci_ptr, code, "Searching the ""mlsys"" searchlist for ^a.", mbx_ename);
	     end;
	call check_star_name_$entry (mbx_ename, code);
	if code ^= 0 then
	     if (code = 1) | (code = 2) then
		call abort_parse (sci_ptr, error_table_$nostars, "^a", pathname_ (mbx_dirname, mbx_ename));
	     else call abort_parse (sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename));	

	mailbox_type = OTHER_MAILBOX;			/* success */

	return;

     end get_mailbox_pathname;




/* Get the pathname of a savebox */

get_savebox_pathname:
     procedure (p_text);

dcl  p_text character (*) parameter;
     
	if has_suffix (p_text, ".sv") then
	     call expand_pathname_$add_suffix (p_text, "mbx", mbx_dirname, mbx_ename, code);
	else call expand_pathname_$add_suffix (p_text, "sv.mbx", mbx_dirname, mbx_ename, code);
	if code ^= 0 then call abort_parse (sci_ptr, code, "^a", p_text);

          if search (p_text, "<>") = 0 then do;             /* ... we were given a pathname */
	     mbx_dirname = "";
	     call search_paths_$find_dir ("mlsys", null(), mbx_ename, "", mbx_dirname, code);
	     if code = error_table_$noentry then
		if has_suffix (p_text, ".sv") then
		     call expand_pathname_$add_suffix (p_text, "mbx", mbx_dirname, mbx_ename, code);
		else call expand_pathname_$add_suffix (p_text, "sv.mbx", mbx_dirname, mbx_ename, code);
	     if code ^= 0 then call abort_parse (sci_ptr, code, "Searching the ""mlsys"" searchlist for ^a.", mbx_ename);
	     end;

	 call check_star_name_$entry (mbx_ename, code);
	 if code ^= 0 then
	      if (code = 1) | (code = 2) then
		call abort_parse (sci_ptr, error_table_$nostars, "^a", pathname_ (mbx_dirname, mbx_ename));
	      else call abort_parse (sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename));

	mailbox_type = SAVEBOX;			/* success */

	return;

     end get_savebox_pathname;
%page;
/* Get the pathname of the mailbox for the given user name which might be a mail table entry (MTE) name */

get_user_mailbox_pathname:
     procedure (p_name, p_ok_if_not_user_name, p_not_user_name);

dcl  p_name character (*) parameter;
dcl  p_ok_if_not_user_name bit (1) aligned parameter;	/* ON => don't abort if given name isn't a User_id/MTE name */
dcl  p_not_user_name bit (1) aligned parameter;		/* set ON => supplied name isn't User_id/MTE name */

	call mlsys_user_mte_syntax_$classify_and_validate ((p_name), is_mte_name, person_id, project_id, code);
	if code ^= 0 then				/* bad syntax ... */
	     if p_ok_if_not_user_name then do;		/* ... is OK when doing pathname hueristic */
		p_not_user_name = "1"b;
		return;
	     end;
	     else call abort_parse (sci_ptr, code, "^a", p_name);

	if is_mte_name then do;			/* a mail table entry */
	     /*** following call won't fail because the syntax has already been verified */
	     call mail_system_$create_mail_table_address ((p_name), "", "", mte_address_ptr, (0));
	     call mail_system_$get_mail_table_address (mte_address_ptr, target_address_ptr, code);
	     if code = mlsys_et_$mte_not_found then	/* ... no entry in the mail table ... */
		if p_ok_if_not_user_name then do;	/* ... is OK when doing pathname hueristic */
		     p_not_user_name = "1"b;
		     return;
		end;
	     if code ^= 0 then call abort_parse (sci_ptr, code, "^a", p_name);
	     call mail_system_$get_address_type (target_address_ptr, address_type, (0));
	     if (address_type ^= USER_MAILBOX_ADDRESS) & (address_type ^= LOGBOX_ADDRESS)
		& (address_type ^= SAVEBOX_ADDRESS) & (address_type ^= MAILBOX_ADDRESS) then
		call abort_parse (sci_ptr, mlsys_et_$mte_not_mailbox, "^a", p_name);
	     call mail_system_$get_address_pathname (target_address_ptr, mbx_dirname, mbx_ename, ((32)" "), (0));
	     if (address_type = USER_MAILBOX_ADDRESS) | (address_type = MAILBOX_ADDRESS) then
		mailbox_type = OTHER_MAILBOX;
	     else if address_type = LOGBOX_ADDRESS then mailbox_type = USER_LOGBOX;
	     else /*** if address_type = SAVEBOX_ADDRESS then */
		mailbox_type = SAVEBOX;
	end;

	else do;					/* a User_id (Person_id.Project_id) */
	     mailbox_type = OTHER_MAILBOX;		/* ... don't try to create it */
	     mbx_dirname = ">udd>" || rtrim (project_id) || ">" || person_id;
	     mbx_ename = rtrim (person_id) || ".mbx";
	end;

	p_not_user_name = "0"b;			/* get here iff all is OK */

	return;

     end get_user_mailbox_pathname;
%page;
/* Aborts the parse:  For the parse_mailbox_text entrypoint, it sets the return code; for all other entrpyoints, it prints
   the given message */

abort_parse:
     procedure () options (variable);

dcl  code fixed binary (35) based (code_ptr);
dcl  code_ptr pointer;

	if sci_ptr = null () then do;			/* return the error code to the caller */
	     call cu_$arg_ptr (2, code_ptr, (0), (0));
	     P_code = code;
	end;

	else do;					/* print the error message */
	     if parse_ca_options.abort_on_errors then
		call cu_$generate_call (ssu_$abort_line, cu_$arg_list_ptr ());
	     else call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr ());
	end;

	go to abort_the_parse;			/* go perform appropriate cleanup */

     end abort_parse;



/* Fetch the next argument */

get_next_argument:
     procedure (p_string);

dcl  p_string character (*) parameter;			/* for error messages if not present */

	if (argument_idx = n_arguments) then
	     call abort_parse (sci_ptr, error_table_$noarg, "^a must be given after ""^a"".", p_string, argument);

	argument_idx = argument_idx + 1;

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

	return;

     end get_next_argument;
%page;
/* Returns "1"b if the given suffix is present on the supplied name */

dcl  has_suffix
	generic (has_suffix_varying when (character (*) varying, character (*)),
	has_suffix_nonvarying when (character (*), character (*)));


has_suffix_nonvarying:
     procedure (p_name, p_suffix) returns (bit (1) aligned);

dcl  (p_name, p_suffix) character (*) parameter;

	return ((index (reverse (rtrim (p_name)), reverse (p_suffix)) = 1));

     end has_suffix_nonvarying;


has_suffix_varying:
     procedure (p_name, p_suffix) returns (bit (1) aligned);

dcl  p_name character (*) varying parameter;
dcl  p_suffix character (*) parameter;

	return ((index (reverse (p_name), reverse (p_suffix)) = 1));

     end has_suffix_varying;
%page;
%include mlsys_parse_ca_options;
%page;
%include mlsys_address_list;
%page;
%include mlsys_address_types;
%page;
%include mlsys_address_route;
%page;
%include mlsys_data;
%page;
%include mlsys_internal_data;
%page;
%include sl_info;

%include sl_control_s;

     end mlsys_parse_control_args_;




		    mlsys_parse_text_.pl1           07/26/88  1017.7rew 07/26/88  1011.7     1939599



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * 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 from mlsys_cv_old_r1_msg_ and mlsys_parse_
     Modified: March 1984 by G. Palter to fix the following mail system errors:
           #0415 -- read_mail, print_mail, and have_mail do not reject starnames as invalid mailbox specifications
           #0417 -- the offset within the message text of an invalid field as returned by mlsys_utils_$parse_message_text does
              not take into account the blank lines which the parser allows to appear before the message header.  As a result,
              error messages produced by send_mail, etc. will appear to truncate the contents of the invalid field
           #0432 -- when converting a forwarded message from its canonical representation, the mail system incorrectly parses
              the Delivery-By field using the sender's system as the default system for the Delivery-By address.  The local
              system should always be used as the default for the Delivery-By field
           #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
           #0437 -- if a message contains an empty multi-line field (eg: Redistributed-Comment), the parser will either take a
              fault or cause a fatal process error
           #0438 -- the primitives which allow a user to replace the address list portions of a message
              (eg: mail_system_$replace_from, mail_system_$replace_user_field) should not make the user's copy of the address
              list read-only.  Instead, they should copy the user's list to allow the user to continue to modify the list if
              desired for later additional use
  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.
  3) change(88-05-16,Blair), approve(88-05-16,MCR7842),
     audit(88-06-30,Lippard), install(88-07-26,MR12.2-1069):
     Update parse_address to use the new search path mechanism so that
     unexpanded mailbox pathnames of the form {keyword PATH} can be located.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Mail System Utilities which convert the printed representation of various mail system objects (messages, addresses,
   etc.) into their internal form */

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


mlsys_parse_text_:
     procedure ();

	return;					/* not an entrypoint */


/* Common Parameters */

dcl  P_code fixed binary (35) parameter;

dcl  P_representation character (*) parameter;		/* the text to be parsed */
dcl  P_parse_text_options_ptr pointer parameter;		/* -> user's parsing options */
dcl  P_parse_text_error_list_ptr pointer parameter;	/* set -> list of errors detected during parse */


/* parse_im_message_text and parse_new_message_text Parameters */

dcl  P_message_version character (8) parameter;		/* version of message structure desired by caller */
dcl  P_message_ptr pointer parameter;			/* set -> the message */


/* parse_im_message_text Parameters */

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_multics_format bit (1) aligned parameter;		/* ON => message is in standard Multics format */


/* parse_mailing_list_text and parse_address_list_text Parameters */

dcl  P_address_list_version character (8) parameter;	/* version of address_list structure desired by caller */
dcl  P_address_list_ptr pointer parameter;		/* set -> the address_list */


/* parse_address_text Parameters */

dcl  P_address_ptr pointer parameter;			/* set -> the address */


/* Local copies of parameters */

dcl  code fixed binary (35);

dcl  representation character (representation_lth) unaligned based (representation_ptr);
dcl  representation_ptr pointer;
dcl  (representation_lth, representation_used) fixed binary (21);

dcl  1 local_pto aligned like parse_text_options;

dcl  address_ptr pointer;


/* Remaining declarations */

dcl  new_message bit (1) aligned;			/* ON => creating a new message; OFF => in-mailbox/incoming */
dcl  message_parse_fails bit (1) aligned;

dcl  1 message_type_specific_operations aligned,		/* in-mailbox/new/incoming messages use different entries */
       2 add_address entry (pointer, pointer, character (8), fixed binary (35)) variable,
       2 add_body_section entry (pointer, pointer, fixed binary, fixed binary (35)) variable,
       2 add_redistribution entry (pointer, pointer, fixed binary, fixed binary (35)) variable,
       2 add_reply_reference entry (pointer, pointer, fixed binary, fixed binary (35)) variable,
       2 add_user_field entry (pointer, pointer, fixed binary, bit (1) aligned, fixed binary (35)) variable,
       2 create_address_list entry (character (8), pointer, fixed binary (35)) variable,
       2 delete_address entry (pointer, fixed binary, fixed binary (35)) variable,
       2 encode_foreign_id entry (character (*), character (256) varying, bit (72) aligned) variable,
       2 encode_local_id entry (fixed binary (71), bit (72) aligned) variable,
       2 encode_psuedo_id entry (fixed binary (71), pointer, character (256) varying, bit (72) aligned) variable,
       2 free_address_list entry (pointer, fixed binary (35)) variable,
       2 free_message entry (pointer, fixed binary (35)) variable,
       2 replace_bcc entry (pointer, pointer, fixed binary (35)) variable,
       2 replace_cc entry (pointer, pointer, fixed binary (35)) variable,
       2 replace_from entry (pointer, pointer, fixed binary (35)) variable,
       2 replace_message_envelope entry (pointer, pointer, fixed binary (35)) variable,
       2 replace_reply_to entry (pointer, pointer, fixed binary (35)) variable,
       2 replace_subject entry (pointer, character (*), fixed binary (35)) variable,
       2 replace_to entry (pointer, pointer, fixed binary (35)) variable,
       2 set_address_implicit_route entry (pointer, pointer, fixed binary (35)) variable,
       2 set_date_time_created entry (pointer, fixed binary (71), fixed binary (35)) variable,
       2 set_message_id entry (pointer, bit (72) aligned, fixed binary (35)) variable;

dcl  1 internal_parse_options aligned,
       2 default_system_name character (256) varying,	/* system name for addresses without explicit name/route */
       2 last_delivered_by pointer,			/* -> address of process that actually delivered message */
       2 last_date_time_delivered fixed binary (71),	/* date/time it was delivered */
       2 flags,
         3 default_system_is_local bit (1) unaligned,	/* ON => the default system is this system */
         3 multics_format bit (1) unaligned,		/* ON => use standard Multics formatting */
         3 no_copy bit (1) unaligned,			/* ON => do not copy text where possible */
         3 requests_acknowledgement bit (1) unaligned,	/* ON => put an Acknowledge-To field into last mailing */
         3 pad bit (14) unaligned,
       2 delimiters,				/* valid delimiters for this parse ... */
         3 eos bit (1) unaligned,			/* ... end of the string */
         3 comma bit (1) unaligned,			/* ... comma */
         3 angle_bracket bit (1) unaligned,		/* ... angle bracket (>) */
         3 semicolon bit (1) unaligned,			/* ... semi-colon */
         3 pad bit (14) unaligned;

dcl  1 mrps (forwarding_info_list.n_forwarding_infos) aligned based (mrps_ptr) like message_redistribution_parameter;
dcl  1 the_mrp aligned based (the_mrp_ptr) like message_redistribution_parameter;
dcl  (mrps_ptr, the_mrp_ptr) pointer;

dcl  mr_sort (forwarding_info_list.n_forwarding_infos) fixed binary based (mr_sort_ptr);
dcl  mr_sort_ptr pointer;

dcl  1 local_mep aligned like message_envelope_parameter;
dcl  1 local_mrp aligned like message_reference_parameter;
dcl  1 local_mufp aligned like message_user_field_parameter;
dcl  1 local_mbsp aligned like message_body_section_parameter;

dcl  1 local_mtf aligned like message_text_field;

dcl  system_area area aligned based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  user_area area aligned based (user_area_ptr);
dcl  user_area_ptr pointer;

dcl  forum_search_list_ptr pointer;

dcl  (stack_extension_ptr, stack_truncation_ptr) pointer;
dcl  stack_extension_used fixed binary (18);

dcl  full_fieldname character (256) varying;
dcl  (address_list_field, trace_address, comment_sender, redistribution_sender, acknowledge_to, implicit_route) pointer;

dcl  (date_time_created, comment_date_time_created, date_time_last_relayed) fixed binary (71);
dcl  message_id bit (72) aligned;

dcl  (eol_idx, next_eol_idx, amount_good, line_start, line_end, used) fixed binary (21);
dcl  (current_field_list_idx, first_field_idx) fixed binary;
dcl  (n_sorted, sort_idx, idx, position) fixed binary;

dcl  STACK_EXTENSION fixed binary (18) static options (constant) initial (1024);

dcl  HTSP_COMMA character (3) static options (constant) initial ("	 ,");

dcl  LINE_DELIMITERS character (4) static options (constant) initial ("
");

/* format: off */
dcl  MULTIPLE_FIELDS_PER_REDISTRIBUTION (18) bit (1) aligned static options (constant) initial (
	"0"b,	"0"b,	"0"b,	"1"b,	"0"b,	"0"b,	"0"b,	"0"b,	"1"b,
	"0"b,	"0"b,	"1"b,	"0"b,	"0"b,	"0"b,	"0"b,	"1"b,	"0"b);

dcl  MULTIPLE_FIELDS_PER_COMMENT (18) bit (1) aligned static options (constant) initial (
	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,
	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"0"b,	"1"b,	"0"b);

dcl (UPPERCASE	initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
     LOWERCASE	initial ("abcdefghijklmnopqrstuvwxyz"))
	character (26) static options (constant);

dcl (error_table_$bad_subr_arg, error_table_$entlong, error_table_$nostars, error_table_$smallarg,
     error_table_$unimplemented_version, mlsys_et_$address_pathname_expected, mlsys_et_$cant_determine_dtc,
     mlsys_et_$cant_determine_msgid, mlsys_et_$cant_determine_sender, mlsys_et_$cant_parse_irt_field,
     mlsys_et_$comment_ignored, mlsys_et_$empty_address_text, mlsys_et_$extra_restricted_field,
     mlsys_et_$in_mailbox_only_field, mlsys_et_$incomplete_address_list_text, mlsys_et_$incomplete_address_text,
     mlsys_et_$incomplete_comment, mlsys_et_$incomplete_named_group_text, mlsys_et_$invalid_address_list_syntax,
     mlsys_et_$invalid_address_syntax, mlsys_et_$invalid_named_group_text, mlsys_et_$invalid_relayed_field_syntax,
     mlsys_et_$invalid_route_field_syntax, mlsys_et_$missing_host_name, mlsys_et_$multiple_address_routes,
     mlsys_et_$no_comment_redistribution, mlsys_et_$no_message_header, mlsys_et_$obsolete_address_syntax,
     mlsys_et_$only_address_route_allowed, mlsys_et_$recursive_named_addresses, mlsys_et_$text_follows_address,
     mlsys_et_$text_follows_route, mlsys_et_$text_parse_failed, mlsys_et_$unbalanced_braces,
     mlsys_et_$unbalanced_parentheses, mlsys_et_$unbalanced_quotes, mlsys_et_$unknown_structured_address_type)
	fixed binary (35) external;
/* format: on */

dcl  check_star_name_$entry entry (character (*), fixed binary (35));
dcl  convert_date_to_binary_ entry (character (*), fixed binary (71), fixed binary (35));
dcl  cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35));
dcl  cu_$shrink_stack_frame entry (pointer, fixed binary (35));
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  encode_clock_value_
	entry (fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary (71),
	fixed binary, character (3), fixed binary (71), fixed binary (35));
dcl  expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
dcl  expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  expand_pathname_$component_add_suffix
	entry (character (*), character (*), character (*), character (*), character (*), fixed binary (35));
dcl  forum_$get_forum_path entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  mail_system_$add_address entry (pointer, pointer, character (8), fixed binary (35));
dcl  mail_system_$add_body_section entry (pointer, pointer, fixed binary, fixed binary (35));
dcl  mail_system_$add_user_field entry (pointer, pointer, fixed binary, bit (1) aligned, fixed binary (35));
dcl  mail_system_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mail_system_$create_address_list entry (character (8), pointer, fixed binary (35));
dcl  mail_system_$create_foreign_address
	entry (character (*) varying, character (256) varying, pointer, character (*) varying, character (*) varying,
	pointer, fixed binary (35));
dcl  mail_system_$create_forum_address
	entry (character (*), character (*), character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_invalid_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_logbox_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_mail_table_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_mailbox_address
	entry (character (*), character (*), character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_mailing_list_address
	entry (character (*), character (*), character (*), character (*) varying, character (*) varying, pointer,
	fixed binary (35));
dcl  mail_system_$create_message entry (character (8), pointer, fixed binary (35));
dcl  mail_system_$create_named_group_address
	entry (character (*) varying, pointer, bit (1) aligned, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$create_savebox_address
	entry (character (*) varying, character (*), character (*), character (*) varying, character (*) varying,
	pointer, fixed binary (35));
dcl  mail_system_$create_user_mailbox_address
	entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35));
dcl  mail_system_$delete_address entry (pointer, fixed binary, fixed binary (35));
dcl  mail_system_$free_address entry (pointer, fixed binary (35));
dcl  mail_system_$free_address_list entry (pointer, fixed binary (35));
dcl  mail_system_$free_message entry (pointer, fixed binary (35));
dcl  mail_system_$get_address_route entry (pointer, character (8), pointer, 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_user_field_id entry (character (*), bit (36) aligned, character (*) varying, fixed binary (35));
dcl  mail_system_$get_user_field_name entry (bit (36) aligned, character (*) varying, fixed binary (35));
dcl  mail_system_$replace_bcc entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$replace_cc entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$replace_from entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$replace_reply_to entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$replace_subject entry (pointer, character (*), fixed binary (35));
dcl  mail_system_$replace_to entry (pointer, pointer, fixed binary (35));
dcl  mail_system_$validate_address entry (pointer, bit (1) aligned, fixed binary (35));
dcl  mlsys_address_list_mgr_$add_address entry (pointer, pointer, character (8), fixed binary (35));
dcl  mlsys_address_list_mgr_$create_read_only_address_list entry (character (8), pointer, 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_$delete_address entry (pointer, fixed binary, fixed binary (35));
dcl  mlsys_address_list_mgr_$free_address_list entry (pointer, fixed binary (35));
dcl  mlsys_address_mgr_$set_address_implicit_route entry (pointer, pointer, fixed binary (35));
dcl  mlsys_field_id_mgr_$get_system_field_type entry (character (*), fixed binary, fixed binary (35));
dcl  mlsys_message_id_mgr_$encode_foreign_id entry (character (*), character (256) varying, bit (72) aligned);
dcl  mlsys_message_id_mgr_$encode_local_id entry (fixed binary (71), bit (72) aligned);
dcl  mlsys_message_id_mgr_$encode_psuedo_id entry (fixed binary (71), pointer, character (256) varying, bit (72) aligned);
dcl  mlsys_message_mgr_$add_body_section_no_copy entry (pointer, pointer, fixed binary, fixed binary (35));
dcl  mlsys_message_mgr_$add_redistribution_no_copy entry (pointer, pointer, fixed binary, fixed binary (35));
dcl  mlsys_message_mgr_$add_reply_reference entry (pointer, pointer, fixed binary, fixed binary (35));
dcl  mlsys_message_mgr_$add_user_field_no_copy entry (pointer, pointer, fixed binary, bit (1) aligned, fixed binary (35));
dcl  mlsys_message_mgr_$create_im_message entry (character (8), pointer, pointer, fixed binary (35));
dcl  mlsys_message_mgr_$free_message entry (pointer, fixed binary (35));
dcl  mlsys_message_mgr_$replace_bcc_no_copy entry (pointer, pointer, fixed binary (35));
dcl  mlsys_message_mgr_$replace_cc_no_copy entry (pointer, pointer, fixed binary (35));
dcl  mlsys_message_mgr_$replace_from_no_copy entry (pointer, pointer, fixed binary (35));
dcl  mlsys_message_mgr_$replace_message_envelope entry (pointer, pointer, fixed binary (35));
dcl  mlsys_message_mgr_$replace_reply_to_no_copy entry (pointer, pointer, fixed binary (35));
dcl  mlsys_message_mgr_$replace_subject_no_copy entry (pointer, character (*), fixed binary (35));
dcl  mlsys_message_mgr_$replace_to_no_copy entry (pointer, pointer, fixed binary (35));
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  mlsys_psp_$forum_not_available entry () returns (bit (1) aligned);
dcl  mlsys_user_mte_syntax_$classify_and_validate
	entry (character (*) varying, bit (1) aligned, character (*) varying, character (*) varying, fixed binary (35));
dcl  search_paths_$get
	entry (character (*), bit (36), character (*), pointer, pointer, fixed binary, pointer, fixed binary (35));

dcl  cleanup condition;

dcl  (abs, addr, addcharno, addwordno, baseno, before, charno, hbound, index, lbound, length, max, min, mod, null,
     reverse, rtrim, search, size, stackframeptr, string, substr, translate, verify) builtin;
%page;
/* Results of scanning the text of a message for header fields */

dcl  1 message_scan aligned,
       2 header_offset fixed binary (21),		/* offset of header in message ignoring leading NLs */
       2 body,					/* the message body  */
         3 body_ptr pointer,
         3 body_lth fixed binary (21),
       2 n_header_fields_allocated fixed binary,		/* size of several arrays below */
       2 array_pointers,				/* makes setup simpler */
         3 header_field_list_ptr pointer,		/* -> the list defining the actual header fields */
         3 field_by_type_lists_ptr pointer,		/* -> the list breaking the fields down by type */
         3 forwarding_info_list_ptr pointer,		/* -> the list of forwarding fields */
         3 comment_info_list_ptr pointer,		/* -> the list of comment fields */
         3 user_field_list_ptr pointer;			/* -> the list of user-defined fields */


dcl  1 header_field_list aligned based (message_scan.header_field_list_ptr),
       2 n_fields fixed binary,			/* # of fields actually found */
       2 fields (message_scan.n_header_fields_allocated),	/* the actual fields */
         3 field_value_ptr pointer,			/* -> start of textual content of the field */
         3 field_value_lth fixed binary (21),		/* length of the field in characters */
         3 complete_field_start fixed binary (21),	/* offset/length of the entire field (including header) ... */
         3 complete_field_lth fixed binary (21);		/* ... for use in error reporting */

dcl  header_field_value character (header_field_list.fields (field_idx).field_value_lth) unaligned
	based (header_field_list.fields (field_idx).field_value_ptr);
dcl  field_idx fixed binary;				/* index of field whose value is above declaration */


dcl  1 field_by_type_lists aligned based (message_scan.field_by_type_lists_ptr),
       2 types (N_ORDINARY_FIELDS),			/* one array element for each type */
         3 n_fields fixed binary,			/* # of fields of this type found */
         3 field_idxs (message_scan.n_header_fields_allocated) fixed binary;
						/* index into header_field_list.fields of each field found */


dcl  1 forwarding_info_list aligned based (message_scan.forwarding_info_list_ptr),
       2 n_forwarding_infos fixed binary,		/* # of separate forwarding infos actually found */
       2 forwarding_info_ptrs (message_scan.n_header_fields_allocated) pointer;
						/* -> field_by_type_lists for each forwarding */

dcl  1 forwarding_info aligned based (forwarding_info_ptr) like field_by_type_lists;
dcl  forwarding_info_ptr pointer;


dcl  1 comment_info_list aligned based (message_scan.comment_info_list_ptr),
       2 n_comment_infos fixed binary,			/* # of separate comment infos actually found */
       2 comment_info_ptrs (message_scan.n_header_fields_allocated) pointer;
						/* -> field_by_type_lists for each comment */

dcl  1 comment_info aligned based (comment_info_ptr) like field_by_type_lists;
dcl  comment_info_ptr pointer;

dcl  1 user_field_list aligned based (message_scan.user_field_list_ptr),
       2 n_user_fields fixed binary,			/* # of user fields found */
       2 user_fields (message_scan.n_header_fields_allocated),
         3 field_id bit (36) aligned,			/* ID assigned to group all similar user fields */
         3 field_value_idx fixed binary;		/* index into header_field_list of this field */
%page;
/* Declarations used to convert the input text into a series of tokens */

dcl  original_text character (original_text_lth) unaligned based (original_text_ptr);
dcl  original_text_lth fixed binary (21);
dcl  original_text_ptr pointer;

dcl  1 lex_and_parse_pointers aligned,			/* allows easy setting of all these pointers */
       2 all_but_sel_ptr,
         3 token_list_ptr pointer,
         3 unquoted_text_ptr pointer,
         3 host_indeces_ptr pointer,
         3 address_string_ptr pointer,
         3 address_name_ptr pointer,
         3 address_comment_ptr pointer,
       2 sel_ptr pointer;

dcl  unquoted_text character (original_text_lth) unaligned based (lex_and_parse_pointers.unquoted_text_ptr);
						/* used by lex when processing quoted strings */

dcl  1 token aligned based (token_ptr),			/* a single token from the string */
       2 token_ptr pointer,				/* -> the text */
       2 token_lth fixed binary (21),			/* length of text in characters */
       2 original_start fixed binary (21),		/* index in caller's text of start of token */
       2 original_lth fixed binary (21),		/* length of the original (maybe quoted) version of token */
       2 type fixed binary,				/* type of token (see below) */
       2 flags,
         3 in_unquoted bit (1) unaligned,		/* ON => text was reconstructed (quoted or something) */
         3 pad bit (35) unaligned;
dcl  token_ptr pointer;

dcl  1 current aligned like token based (current_token_ptr);/* the token under examination */
dcl  current_token_ptr pointer;
dcl  token_idx fixed binary (21);			/* index of current token in the token list */

dcl  current_token character (current.token_lth) unaligned based (current.token_ptr);
						/* the actual text of the token */

dcl  1 token_list aligned based (lex_and_parse_pointers.token_list_ptr),
       2 n_tokens_allocated fixed binary (21),		/* # of tokens below */
       2 n_tokens_used fixed binary (21),		/* # of tokens in use */
       2 tokens (0:(original_text_lth + 1) refer (token_list.n_tokens_allocated)) like token;

/* format: off */

/* Token types common to all forms of lexical analysis */

dcl (START_OF_TEXT_TOKEN	initial (-3),		/* start of text: always the first token in the list */
     END_OF_TEXT_TOKEN	initial (-2),		/* end of the text: always the last token in the list */
     WORD_TOKEN		initial (-1),		/* a piece of text (it might have been quoted) */
     COMMENT_TOKEN		initial (0),		/* the text of a comment */

     COMMA_TOKEN	initial (1),			/* comma and colon delimiters are common to both lex's */
     COLON_TOKEN	initial (2),


/* Token types for parsing address, address-list, and message-id fields */

     SEMICOLON_TOKEN	initial (3),	     LEFTBRACE_TOKEN	initial (4),
     RIGHTBRACE_TOKEN	initial (5),	     LEFTBRACKET_TOKEN	initial (6),
     RIGHTBRACKET_TOKEN	initial (7),	     AT_TOKEN		initial (8),


/* Token types for parsing date/time fields */

     PLUS_TOKEN		initial (3),	     HYPHEN_TOKEN		initial (4))
	fixed binary static options (constant);
/* format: on */


/* Declarations used for parsing addresses and address lists */

dcl  1 sel (original_text_lth) aligned based (lex_and_parse_pointers.sel_ptr),
       2 text_start fixed binary (21),			/* index in original text of substring in error */
       2 text_lth fixed binary (21),			/* ... and the length of said substring */
       2 code fixed binary (35);			/* error code describing problem */
dcl  n_syntax_errors fixed binary (21);			/* # of errors detected by the parse */

dcl  host_indeces (original_text_lth) fixed binary (21) based (lex_and_parse_pointers.host_indeces_ptr);
dcl  n_hosts fixed binary;				/* # of host names in the address */
dcl  n_reversed_hosts fixed binary;			/* # of host names in RFC822 style route */

dcl  address_string character (original_text_lth + 1) varying based (lex_and_parse_pointers.address_string_ptr);
dcl  address_name character (original_text_lth + 1) varying based (lex_and_parse_pointers.address_name_ptr);
dcl  address_comment character (original_text_lth + 1) varying based (lex_and_parse_pointers.address_comment_ptr);


/* Declarations used for parsing date/times */

dcl  ONE_MINUTE fixed binary (71) static options (constant) initial (60000000);

/* format: off */
dcl  DAY_OF_WEEKS (14) character (32) static options (constant) initial (
	"SUNDAY",	     "SUN",	"MONDAY",	     "MON",	"TUESDAY",     "TUE",	"WEDNESDAY",   "WED",
	"THURSDAY",    "THU",	"FRIDAY",	     "FRI",	"SATURDAY",    "SAT");
dcl  DAY_OF_WEEK_VALUES (14) fixed binary static options (constant) initial (
	(2) 7,			(2) 1,			(2) 2,			(2) 3,
	(2) 4,			(2) 5,			(2) 6);

dcl  MONTHS (23) character (32) static options (constant) initial (
	"JANUARY",     "JAN",	"FEBRUARY",    "FEB",	"MARCH",	     "MAR",	"APRIL",	     "APR",
	"MAY",			"JUNE",	     "JUN",	"JULY",	     "JUL",	"AUGUST",	     "AUG",
	"SEPTEMBER",   "SEP",	"OCTOBER",     "OCT",	"NOVEMBER",    "NOV",	"DECEMBER",    "DEC");
dcl  MONTH_VALUES (23) fixed binary static options (constant) initial (
	(2) 1,			(2) 2,			(2) 3,			(2) 4,
	5,			(2) 6,			(2) 7,			(2) 8,
	(2) 9,			(2) 10,			(2) 11,			(2) 12);

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 */
%page;
/* Convert the printed representation of an in-mailbox message into its internal representation */

parse_im_message_text:
     entry (P_representation, P_message_version, P_im_message_info_ptr, P_last_delivered_by, P_last_date_time_delivered,
	P_requests_acknowledgement, P_multics_format, P_message_ptr, P_code);

	new_message = "0"b;				/* building an in-mailbox message */

	local_pto.version = PARSE_TEXT_OPTIONS_VERSION_1; /* setup common parse options */
	local_pto.area_ptr = null ();
	string (local_pto.flags) = ""b;		/* ... don't list errors or validate addresses */
	local_pto.include_invalid_addresses = "1"b;	/* ... but include everything possible in the message */
	parse_text_options_ptr = addr (local_pto);

	string (internal_parse_options.flags) = ""b;	/* ... will determine the default system later */
	internal_parse_options.multics_format = P_multics_format;
						/* ... use new-style formatting if necessary */
	internal_parse_options.no_copy = "1"b;		/* ... use the actual message text when possible */

	internal_parse_options.last_delivered_by = P_last_delivered_by;
	internal_parse_options.last_date_time_delivered = P_last_date_time_delivered;
	internal_parse_options.requests_acknowledgement = P_requests_acknowledgement;

	add_address = mlsys_address_list_mgr_$add_address;
	add_body_section = mlsys_message_mgr_$add_body_section_no_copy;
	add_redistribution = mlsys_message_mgr_$add_redistribution_no_copy;
	add_reply_reference = mlsys_message_mgr_$add_reply_reference;
	add_user_field = mlsys_message_mgr_$add_user_field_no_copy;
	create_address_list = mlsys_address_list_mgr_$create_read_only_address_list;
	delete_address = mlsys_address_list_mgr_$delete_address;
	encode_foreign_id = mlsys_message_id_mgr_$encode_foreign_id;
	encode_local_id = mlsys_message_id_mgr_$encode_local_id;
	encode_psuedo_id = mlsys_message_id_mgr_$encode_psuedo_id;
	free_address_list = mlsys_address_list_mgr_$free_address_list;
	free_message = mlsys_message_mgr_$free_message;
	replace_bcc = mlsys_message_mgr_$replace_bcc_no_copy;
	replace_cc = mlsys_message_mgr_$replace_cc_no_copy;
	replace_from = mlsys_message_mgr_$replace_from_no_copy;
	replace_message_envelope = mlsys_message_mgr_$replace_message_envelope;
	replace_reply_to = mlsys_message_mgr_$replace_reply_to_no_copy;
	replace_subject = mlsys_message_mgr_$replace_subject_no_copy;
	replace_to = mlsys_message_mgr_$replace_to_no_copy;
	set_address_implicit_route = mlsys_address_mgr_$set_address_implicit_route;
	set_date_time_created = set_date_time_created_directly;
	set_message_id = set_message_id_directly;

	call mlsys_message_mgr_$create_im_message (P_message_version, P_im_message_info_ptr, message_ptr, code);
	if code ^= 0 then do;			/* wrong version? */
	     P_code = code;
	     return;
	end;

	go to PARSE_MESSAGE_TEXT_COMMON;
%page;
/* Convert the printed representation of a new message into its internal representation */

parse_new_message_text:
     entry (P_representation, P_parse_text_options_ptr, P_message_version, P_message_ptr, P_parse_text_error_list_ptr,
	P_code);

	new_message = "1"b;				/* building a new message */

	parse_text_options_ptr = P_parse_text_options_ptr;
	if parse_text_options.version ^= PARSE_TEXT_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;
	if parse_text_options.mbz ^= ""b then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	if parse_text_options.area_ptr = null () then
	     user_area_ptr = get_system_free_area_ ();
	else user_area_ptr = parse_text_options.area_ptr;

	string (internal_parse_options.flags) = ""b;
	internal_parse_options.multics_format = "1"b;	/* use standard Multics formatting conventions */
	internal_parse_options.no_copy = "0"b;		/* can't use supplied text directly */

	internal_parse_options.default_system_is_local = "1"b;
	internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name ();

	internal_parse_options.last_delivered_by = null ();
	internal_parse_options.last_date_time_delivered = 0;
	internal_parse_options.requests_acknowledgement = "0"b;
						/* message has never been sent anywhere */

	add_address = mail_system_$add_address;
	add_body_section = mail_system_$add_body_section;
	add_user_field = mail_system_$add_user_field;
	create_address_list = mail_system_$create_address_list;
	delete_address = mail_system_$delete_address;
	free_address_list = mail_system_$free_address_list;
	free_message = mail_system_$free_message;
	replace_bcc = mail_system_$replace_bcc;
	replace_cc = mail_system_$replace_cc;
	replace_from = mail_system_$replace_from;
	replace_reply_to = mail_system_$replace_reply_to;
	replace_subject = mail_system_$replace_subject;
	replace_to = mail_system_$replace_to;

	call mail_system_$create_message (P_message_version, message_ptr, code);
	if code ^= 0 then do;			/* wrong version? */
	     P_code = code;
	     return;
	end;

	go to PARSE_MESSAGE_TEXT_COMMON;
%page;
/* The Message Parser */

PARSE_MESSAGE_TEXT_COMMON:
	representation_ptr = addr (P_representation);
	representation_lth = length (P_representation);

	string (internal_parse_options.delimiters) = ""b; /* end of string is only address/address list delimiter */
	internal_parse_options.delimiters.eos = "1"b;

	message_parse_fails = "0"b;			/* assume no errors are detected */

	system_area_ptr = get_system_free_area_ ();

	call initialize_message_parse_data ();		/* for cleanup handler */

	on condition (cleanup)
	     begin;
	     call cleanup_message_parse_data ();
	     if message_ptr ^= null () then call free_message (message_ptr, (0));
	end;


/* Find and classify all header fields */

	call scan_message_text (parse_text_options, internal_parse_options);


/* Add the body to the message: whatever body is present is treated as a single, preformatted section */

	local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2;

	message_body_section_ptr = addr (local_mbsp.section);
	message_preformatted_body_section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION;
	message_preformatted_body_section.text_ptr = message_scan.body_ptr;
	message_preformatted_body_section.text_lth = message_scan.body_lth;

	call add_body_section (message_ptr, addr (local_mbsp), (-1), code);
	if code ^= 0 then call message_parse_error_fatal (code);


	if new_message then do;

/* New Message -- Parse the From field and mark all "restricted" header fields and all field in the envelope as errors */

	     call parse_address_list_field (parse_text_options, internal_parse_options, FROM_FIELDNAME,
		addr (field_by_type_lists.types (FROM_FIELD)), address_list_field);
	     if address_list_field ^= null () then do;	/* ... there's something in the From field */
		call replace_from (message_ptr, address_list_field, code);
		if code ^= 0 then call message_parse_error_fatal (code);
		if address_list_field = message.from then
		     address_list_field = null ();
		else call free_address_list (address_list_field, (0));
	     end;

	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (ACCESS_CLASS_FIELD)));
	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (ACKNOWLEDGE_TO_FIELD)));
	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (DATE_FIELD)));
	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (DELIVERY_BY_FIELD)));
	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (DELIVERY_DATE_FIELD)));
	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (MESSAGE_ID_FIELD)));
	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (POSTED_DATE_FIELD)));
	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (RELAYED_FIELD)));
	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (ROUTE_FIELD)));
	     call mark_as_in_mailbox_field (addr (field_by_type_lists.types (SENDER_FIELD)));
	end;

	else do;

/* In-mailbox/Incoming Message -- Parse the message envelope:  However, the envelope is not added to the message at this
   time as it is possible that either the message trace or Acknowledge-To field or both which appear to be part of the
   envelope are actually part of one of the message redistributions.  As part of parsing the envelope, we also parse the
   Date and From fields in the header as we may need their values to complete the envelope parse; we may also need their
   values to construct a unique ID for the message if there's no Message-ID field */

	     first_field_idx = 1;			/* message starts at the beginning ... */

	     local_mep.version = MESSAGE_ENVELOPE_PARAMETER_VERSION_2;

	     call parse_envelope (parse_text_options, internal_parse_options, "0"b,
		message_scan.field_by_type_lists_ptr, addr (local_mep.envelope), date_time_created,
		address_list_field);		/* takes care of both Date and From fields also */

	     call set_date_time_created (message_ptr, date_time_created, code);
	     if code ^= 0 then call message_parse_error_fatal (code);

	     if address_list_field ^= null () then do;	/* ... there's something in the From field */
		call replace_from (message_ptr, address_list_field, code);
		if code ^= 0 then call message_parse_error_fatal (code);
		if address_list_field = message.from then
		     address_list_field = null ();
		else call free_address_list (address_list_field, (0));
	     end;


/* In-mailbox/Incoming Message -- Determine the unique ID of the message:  If there is exactly one Message-ID field,
   convert it into the ID; if there is no Message-ID field, construct a psuedo-ID from the Date and From fields; if there
   is more than one Message-ID field, flag them all as errors */

	     message_id = ""b;			/* assume we don't get one */

	     if field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields = 1 then do;
		field_idx = field_by_type_lists.types (MESSAGE_ID_FIELD).field_idxs (1);
		call parse_message_id_text (parse_text_options, internal_parse_options, header_field_value,
		     message_id);			/* text can always be converted to a message ID */
	     end;

	     else if field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields > 1 then do;
		do idx = 1 to field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields;
		     field_idx = field_by_type_lists.types (MESSAGE_ID_FIELD).field_idxs (idx);
		     call message_parse_error (parse_text_options, mlsys_et_$extra_restricted_field,
			header_field_list.fields (field_idx).complete_field_start,
			header_field_list.fields (field_idx).complete_field_lth, "");
		end;
	     end;

	     else do;				/* must construct a psudeo ID */
		if (message.date_time_created ^= 0) & (message.from -> address_list.n_addresses > 0) then
		     call encode_psuedo_id (message.date_time_created, message.from,
			internal_parse_options.default_system_name, message_id);
		else call message_parse_error (parse_text_options, mlsys_et_$cant_determine_msgid,
			header_field_list.fields (1).complete_field_start,
			header_field_list.fields (1).complete_field_lth, "The message which starts with:");
	     end;

	     if message_id ^= ""b then do;		/* found an ID ... */
		call set_message_id (message_ptr, message_id, code);
		if code ^= 0 then call message_parse_error_fatal (code);
	     end;
	end;


/* Parse the Reply-To, To, cc, and bcc fields */

	if field_by_type_lists.types (REPLY_TO_FIELD).n_fields > 0 then do;
	     call parse_address_list_field (parse_text_options, internal_parse_options, REPLY_TO_FIELDNAME,
		addr (field_by_type_lists.types (REPLY_TO_FIELD)), address_list_field);
	     if address_list_field ^= null () then do;	/* ... there's something in the Reply-To field */
		call replace_reply_to (message_ptr, address_list_field, code);
		if code ^= 0 then call message_parse_error_fatal (code);
		if address_list_field = message.reply_to then
		     address_list_field = null ();
		else call free_address_list (address_list_field, (0));
	     end;
	end;

	if field_by_type_lists.types (TO_FIELD).n_fields > 0 then do;
	     call parse_address_list_field (parse_text_options, internal_parse_options, TO_FIELDNAME,
		addr (field_by_type_lists.types (TO_FIELD)), address_list_field);
	     if address_list_field ^= null () then do;	/* ... there's something in the To field */
		call replace_to (message_ptr, address_list_field, code);
		if code ^= 0 then call message_parse_error_fatal (code);
		if address_list_field = message.to then
		     address_list_field = null ();
		else call free_address_list (address_list_field, (0));
	     end;
	end;

	if field_by_type_lists.types (CC_FIELD).n_fields > 0 then do;
	     call parse_address_list_field (parse_text_options, internal_parse_options, CC_FIELDNAME,
		addr (field_by_type_lists.types (CC_FIELD)), address_list_field);
	     if address_list_field ^= null () then do;	/* ... there's something in the cc field */
		call replace_cc (message_ptr, address_list_field, code);
		if code ^= 0 then call message_parse_error_fatal (code);
		if address_list_field = message.cc then
		     address_list_field = null ();
		else call free_address_list (address_list_field, (0));
	     end;
	end;

	if field_by_type_lists.types (BCC_FIELD).n_fields > 0 then do;
	     call parse_address_list_field (parse_text_options, internal_parse_options, BCC_FIELDNAME,
		addr (field_by_type_lists.types (BCC_FIELD)), address_list_field);
	     if address_list_field ^= null () then do;	/* ... there's something in the bcc field */
		call replace_bcc (message_ptr, address_list_field, code);
		if code ^= 0 then call message_parse_error_fatal (code);
		if address_list_field = message.bcc then
		     address_list_field = null ();
		else call free_address_list (address_list_field, (0));
	     end;
	end;


/* Parse the Subject field: if there are several Subject fields in the message, merge them into a single field */

	if field_by_type_lists.types (SUBJECT_FIELD).n_fields > 0 then do;
	     call prepare_single_line_field (local_mtf, addr (field_by_type_lists.types (SUBJECT_FIELD)));
	     begin;
dcl  message_subject character (local_mtf.text_lth) unaligned based (local_mtf.text_ptr);
		call replace_subject (message_ptr, message_subject, code);
		if field_by_type_lists.types (SUBJECT_FIELD).n_fields > 1 then
		     if message.subject.text_ptr ^= addr (message_subject) then free message_subject in (system_area);
		if code ^= 0 then call message_parse_error_fatal (code);
	     end;
	end;


	if field_by_type_lists.types (IN_REPLY_TO_FIELD).n_fields > 0 then
	     if new_message then do;

/* New Message -- Mark all In-Reply-To fields as errors:  Privileged operations are required to convert the printed
   representation of a message reference into its internal form */

		do idx = 1 to field_by_type_lists.types (IN_REPLY_TO_FIELD).n_fields;
		     field_idx = field_by_type_lists.types (IN_REPLY_TO_FIELD).field_idxs (idx);
		     call message_parse_error (parse_text_options, mlsys_et_$cant_parse_irt_field,
			header_field_list.fields (field_idx).complete_field_start,
			header_field_list.fields (field_idx).complete_field_lth, "");
		end;
	     end;

	     else do;

/* In-mailbox/Incoming Message -- Parse the In-Reply-To fields:  We can not actually parse the In-Reply-To field as the
   format of the printed representation is not complete enough for parsing.  Therefore, we take each separate line of the
   In-Reply-To fields and treat it as a separate reference; a message ID is generated for each line based on its text so
   that there will be something available to convert back into the printed form */

		local_mrp.version = MESSAGE_REFERENCE_PARAMETER_VERSION_2;
		local_mrp.date_time_created = 0;	/* there's never any date/time, authors, or subject */
		local_mrp.from, local_mrp.subject.text_ptr = null ();
		local_mrp.subject.text_lth = 0;

		do idx = 1 to field_by_type_lists.types (IN_REPLY_TO_FIELD).n_fields;
		     field_idx = field_by_type_lists.types (IN_REPLY_TO_FIELD).field_idxs (idx);

		     used = 0;
		     do while (used < length (header_field_value));
			begin;
dcl  rest_of_field char (length (header_field_value) - used) unaligned defined (header_field_value) position (used + 1);
			     eol_idx = index (rest_of_field, NL);
			     if eol_idx = 0 then eol_idx = length (rest_of_field) + 1;
			end;
			begin;			/* have the next line to convert ... */
dcl  next_line character (eol_idx - 1) unaligned defined (header_field_value) position (used + 1);
			     line_start = verify (next_line, HTSP_COMMA);
			     if line_start ^= 0 then do;
						/* ... something on the line */
				line_end = length (rtrim (next_line, HTSP_COMMA));
				begin;
dcl  the_line character (line_end - line_start + 1) unaligned defined (header_field_value) position (used + line_start);
				     call encode_foreign_id (the_line,
					mlsys_nit_interface_$get_local_system_name (), local_mrp.message_id);
				     call add_reply_reference (message_ptr, addr (local_mrp), (-1), code);
				     if code ^= 0 then call message_parse_error_fatal (code);
				end;
			     end;
			end;
			used = used + eol_idx;	/* on to the next line */
		     end;
		end;
	     end;


/* Convert the user-defined fields:  Until messages are stored in binary, we must assume that all user-defined fields are
   text fields */

	local_mufp.version = MESSAGE_USER_FIELD_PARAMETER_VERSION_2;
	message_user_field_ptr = addr (local_mufp.user_field);
	message_user_field.field_type = MESSAGE_TEXT_USER_FIELD;

	do idx = 1 to user_field_list.n_user_fields;
	     field_idx = user_field_list.user_fields (idx).field_value_idx;
	     message_user_field.field_id = user_field_list.user_fields (idx).field_id;

	     message_text_user_field.multiline_text = (search (header_field_value, LINE_DELIMITERS) ^= 0);
	     if message_text_user_field.multiline_text then do;
		call mail_system_$get_user_field_name (message_text_user_field.field_id, full_fieldname, (0));
		message_text_user_field.text_ptr = null ();
		message_text_user_field.text_lth = 0;
		call prepare_multiline_field_from_text (length (full_fieldname), message_text_user_field.text,
		     header_field_value);
	     end;
	     else do;
		message_text_user_field.text_ptr = addr (header_field_value);
		message_text_user_field.text_lth = length (header_field_value);
	     end;

	     position = -1;				/* add it to the end, please */
	     call add_user_field (message_ptr, addr (local_mufp), position, "1"b, code);
	     if code ^= 0 then do;
		if message_text_user_field.multiline_text then free message_text_user_field_text in (system_area);
		call message_parse_error_fatal (code);
	     end;

	     if message_text_user_field.multiline_text then
		if message_text_user_field.text_ptr
		     ^= addr (message_user_fields_list.user_fields (position)) -> message_text_user_field.text_ptr
		     then
		     free message_text_user_field_text in (system_area);
	end;


/* Convert all free-standing comment fields into user-defined fields:  A free-standing comment is any Comment text field
   in the message for which the scanner didn't find matching Comment-Date and Comment-By fields */

	local_mufp.version = MESSAGE_USER_FIELD_PARAMETER_VERSION_2;
	message_user_field_ptr = addr (local_mufp.user_field);

	call mail_system_$get_user_field_id ("X-Comments", message_user_field.field_id, (""), code);
	if (code ^= 0) & (code ^= error_table_$smallarg) then call message_parse_error_fatal (code);
						/* must use above name to avoid conflicts */

	message_user_field.field_type = MESSAGE_TEXT_USER_FIELD;
	message_text_user_field.multiline_text = "1"b;
	message_text_user_field.text_ptr = null ();	/* no previous text */
	message_text_user_field.text_lth = 0;

	current_field_list_idx = 1;

	do while (current_field_list_idx <= comment_info_list.n_comment_infos);

	     comment_info_ptr = comment_info_list.comment_info_ptrs (current_field_list_idx);

	     if (comment_info.types (DATE_FIELD).n_fields = 0) & (comment_info.types (SENDER_FIELD).n_fields = 0)
	     then do;				/* this "commenting" should be a user field */
		call prepare_multiline_field_from_list (length ("X-Comments"), message_text_user_field.text,
		     addr (comment_info.types (COMMENT_FIELD)));
		free comment_info in (system_area);	/* we don't need it anymore */
		do idx = (current_field_list_idx + 1) to comment_info_list.n_comment_infos;
		     comment_info_list.comment_info_ptrs (idx - 1) = comment_info_list.comment_info_ptrs (idx);
		end;
		comment_info_list.n_comment_infos = comment_info_list.n_comment_infos - 1;
	     end;

	     else current_field_list_idx = current_field_list_idx + 1;
	end;					/* a real commenting operation */

	if message_text_user_field.text_ptr ^= null () then do;
	     position = -1;				/* found some: add them to the message */
	     call add_user_field (message_ptr, addr (local_mufp), position, "1"b, code);
	     if code ^= 0 then do;
		free message_text_user_field_text in (system_area);
		call message_parse_error_fatal (code);
	     end;
	     if message_text_user_field.text_ptr
		^= addr (message_user_fields_list.user_fields (position)) -> message_text_user_field.text_ptr then
		free message_text_user_field_text in (system_area);
	end;


	if new_message then do;

/* New Message -- Mark any redistributions and any remaining comments as errors */

	     do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos;
		forwarding_info_ptr = forwarding_info_list.forwarding_info_ptrs (current_field_list_idx);
		do idx = 1 to N_ORDINARY_FIELDS;
		     call mark_as_in_mailbox_field (addr (forwarding_info.types (idx)));
		end;
	     end;

	     do current_field_list_idx = 1 to comment_info_list.n_comment_infos;
		comment_info_ptr = comment_info_list.comment_info_ptrs (current_field_list_idx);
		do idx = 1 to N_ORDINARY_FIELDS;
		     call mark_as_in_mailbox_field (addr (comment_info.types (idx)));
		end;
	     end;
	end;


	else do;					/* in-mailbox/incoming */
	     if (forwarding_info_list.n_forwarding_infos = 0) & (comment_info_list.n_comment_infos > 0) then do;
		do current_field_list_idx = 1 to comment_info_list.n_comment_infos;
		     comment_info_ptr = comment_info_list.comment_info_ptrs (current_field_list_idx);
		     call find_first_field_in_list (comment_info_ptr, field_idx);
		     call message_parse_error (parse_text_options, mlsys_et_$no_comment_redistribution,
			header_field_list.fields (field_idx).complete_field_start,
			header_field_list.fields (field_idx).complete_field_lth, "The comment which starts with:");
		end;
	     end;


/* In-mailbox/Incoming Message -- Parse the redistributions list */

	     if forwarding_info_list.n_forwarding_infos > 0 then do;

		allocate mr_sort in (system_area) set (mr_sort_ptr);
		allocate mrps in (system_area) set (mrps_ptr);

		mrps (*).version = MESSAGE_REDISTRIBUTION_PARAMETER_VERSION_2;
		mrps (*).sender, mrps (*).trace, mrps (*).delivered_by, mrps (*).acknowledge_to, mrps (*).from,
		     mrps (*).to, mrps (*).comment.text_ptr = null ();

		do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos;
		     the_mrp_ptr = addr (mrps (current_field_list_idx));

		     forwarding_info_ptr = forwarding_info_list.forwarding_info_ptrs (current_field_list_idx);
		     call find_first_field_in_list (forwarding_info_ptr, first_field_idx);

		     call parse_envelope (parse_text_options, internal_parse_options, "1"b, forwarding_info_ptr,
			addr (the_mrp.envelope), the_mrp.date_time_created, the_mrp.from);

		     if field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields = 1 then do;
			field_idx = field_by_type_lists.types (MESSAGE_ID_FIELD).field_idxs (1);
			call parse_message_id_text (parse_text_options, internal_parse_options, header_field_value,
			     the_mrp.message_id);
		     end;
		     else if field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields > 1 then do;
			do idx = 1 to field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields;
			     field_idx = field_by_type_lists.types (MESSAGE_ID_FIELD).field_idxs (idx);
			     call message_parse_error (parse_text_options, mlsys_et_$extra_restricted_field,
				header_field_list.fields (field_idx).complete_field_start,
				header_field_list.fields (field_idx).complete_field_lth, "");
			end;
		     end;
		     else do;			/* must construct a psudeo ID */
			if (the_mrp.date_time_created ^= 0) & (the_mrp.from -> address_list.n_addresses > 0) then
			     call encode_psuedo_id (the_mrp.date_time_created, the_mrp.from,
				internal_parse_options.default_system_name, the_mrp.message_id);
			else call message_parse_error (parse_text_options, mlsys_et_$cant_determine_msgid,
				header_field_list.fields (first_field_idx).complete_field_start,
				header_field_list.fields (first_field_idx).complete_field_lth,
				"The redistribution which starts with:");
		     end;

		     full_fieldname = REDISTRIBUTED_PREFIX || TO_FIELDNAME;
		     if forwarding_info.types (TO_FIELD).n_fields > 0 then
			call parse_address_list_field (parse_text_options, internal_parse_options, full_fieldname,
			     addr (forwarding_info.types (TO_FIELD)), the_mrp.to);

		     if forwarding_info.types (COMMENT_FIELD).n_fields > 0 then
			call prepare_multiline_field_from_list (length (REDISTRIBUTED_COMMENT_FIELDNAME),
			     the_mrp.comment, addr (forwarding_info.types (COMMENT_FIELD)));
		end;


/* In-mailbox/Incoming message -- Find any old-style redistribution comments (Comment-Date/Comment-By/Comment) and place
   their text into the appropriate redistribution */

		internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name ();
		internal_parse_options.default_system_is_local = "1"b;

		do current_field_list_idx = 1 to comment_info_list.n_comment_infos;
		     comment_info_ptr = comment_info_list.comment_info_ptrs (current_field_list_idx);
		     call find_first_field_in_list (comment_info_ptr, first_field_idx);

		     if (comment_info.types (DATE_FIELD).n_fields = 0)
			| (comment_info.types (SENDER_FIELD).n_fields = 0) then
			call message_parse_error (parse_text_options, mlsys_et_$incomplete_comment,
			     header_field_list.fields (first_field_idx).complete_field_start,
			     header_field_list.fields (first_field_idx).complete_field_lth,
			     "The comment which starts with:");

		     else do;
			/*** Message scanner guarentees at most one Comment-Date and Comment-By */
			field_idx = comment_info.types (DATE_FIELD).field_idxs (1);
			call parse_date_time_text (parse_text_options, internal_parse_options, header_field_value,
			     comment_date_time_created, code);
			if code ^= 0 then do;
			     call message_parse_error (parse_text_options, code,
				header_field_list.fields (field_idx).complete_field_start,
				header_field_list.fields (field_idx).complete_field_lth, "");
			     call message_parse_error (parse_text_options, mlsys_et_$comment_ignored,
				header_field_list.fields (first_field_idx).complete_field_start,
				header_field_list.fields (first_field_idx).complete_field_lth,
				"The comment which starts with:");
			     go to TRY_NEXT_COMMENT_OPERATION;
			end;

			field_idx = comment_info.types (SENDER_FIELD).field_idxs (1);
			call parse_address_text_internal (parse_text_options, internal_parse_options,
			     header_field_value, comment_sender, code);
			if code ^= 0 then do;
			     call message_parse_error (parse_text_options, code,
				header_field_list.fields (field_idx).complete_field_start,
				header_field_list.fields (field_idx).complete_field_lth, "");
			     call message_parse_error (parse_text_options, mlsys_et_$comment_ignored,
				header_field_list.fields (first_field_idx).complete_field_start,
				header_field_list.fields (first_field_idx).complete_field_lth,
				"The comment which starts with:");
			     go to TRY_NEXT_COMMENT_OPERATION;
			end;

			do idx = 1 to forwarding_info_list.n_forwarding_infos;
			     if mrps (idx).sender = null () then
				redistribution_sender = mrps (idx).from -> address_list.addresses (1);
			     else redistribution_sender = mrps (idx).sender;
			     if date_time_equal (comment_date_time_created, mrps (idx).date_time_created)
				& mail_system_$compare_addresses (comment_sender, redistribution_sender, (0))
			     then do;
				if comment_info.types (COMMENT_FIELD).n_fields > 0 then
				     call prepare_multiline_field_from_list (length ("Comment"),
					mrps (idx).comment, addr (comment_info.types (COMMENT_FIELD)));
				call mail_system_$free_address (comment_sender, (0));
				go to TRY_NEXT_COMMENT_OPERATION;
			     end;
			end;

			/*** Control arrives here iff we couldn't find the matching redistribution */
			call message_parse_error (parse_text_options, mlsys_et_$no_comment_redistribution,
			     header_field_list.fields (first_field_idx).complete_field_start,
			     header_field_list.fields (first_field_idx).complete_field_lth,
			     "The comment which starts with:");
		     end;

TRY_NEXT_COMMENT_OPERATION:
		end;


/* In-mailbox/Incoming Message -- Sort the redistributions into chronological order; redistributions whose date/time
   created is unkown will be placed at the beginning of the list */

		n_sorted = 0;			/* nothing's sorted yet */

		do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos;
		     the_mrp_ptr = addr (mrps (current_field_list_idx));

		     sort_idx = 0;
		     do idx = 1 to n_sorted while (sort_idx = 0);
			if date_time_before (the_mrp.date_time_created, mrps (mr_sort (idx)).date_time_created) then
			     sort_idx = idx;
		     end;
		     if sort_idx = 0 then		/* this is the oldest one now */
			sort_idx = n_sorted + 1;

		     do idx = n_sorted to sort_idx by -1;
			mr_sort (idx + 1) = mr_sort (idx);
		     end;				/* move older fields up */

		     mr_sort (sort_idx) = current_field_list_idx;
		     n_sorted = n_sorted + 1;
		end;
	     end;


/* In-mailbox/Incoming Message -- Determine where the "original" message trace belongs as only Multics uses the
   "Redistributed-" forms of the message trace fields */

	     if (local_mep.trace ^= null ()) & (forwarding_info_list.n_forwarding_infos > 0) then
		if local_mep.trace -> message_trace.n_relays > 0 then do;
		     message_trace_ptr = local_mep.trace;
		     date_time_last_relayed = message_trace.relays (message_trace.n_relays).date_time_relayed;

		     do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos;
			idx = mr_sort (current_field_list_idx);
			if date_time_before (date_time_last_relayed, mrps (idx).date_time_created) then do;
			     if idx = 1 then go to ORIGINAL_TRACE_PROPERLY_PLACED;
			     if mrps (idx - 1).date_time_created = 0 then go to ORIGINAL_TRACE_PROPERLY_PLACED;
			     if mrps (idx - 1).trace ^= null () then go to ORIGINAL_TRACE_PROPERLY_PLACED;
			     mrps (idx - 1).trace = local_mep.trace;
			     local_mep.trace = null ();
			     go to ORIGINAL_TRACE_PROPERLY_PLACED;
			end;
		     end;

		     /*** Control arrives here iff the trace should be attached to the last redistribution */
		     if (mrps (forwarding_info_list.n_forwarding_infos).date_time_created ^= 0)
			& (mrps (forwarding_info_list.n_forwarding_infos).trace = null ()) then do;
			mrps (forwarding_info_list.n_forwarding_infos).trace = local_mep.trace;
			local_mep.trace = null ();
		     end;

ORIGINAL_TRACE_PROPERLY_PLACED:
		end;


/* In-mailbox/Incoming Message -- Set the Acknowledge-To fields */

	     acknowledge_to = null ();

	     if internal_parse_options.requests_acknowledgement then do;
		do current_field_list_idx = forwarding_info_list.n_forwarding_infos to 1 by -1
		     while (acknowledge_to = null ());
		     idx = mr_sort (current_field_list_idx);
		     if mrps (idx).acknowledge_to ^= null () then acknowledge_to = mrps (idx).acknowledge_to;
		end;

		if acknowledge_to = null () then acknowledge_to = local_mep.acknowledge_to;
		if acknowledge_to = null () then acknowledge_to = internal_parse_options.last_delivered_by;
	     end;

	     if forwarding_info_list.n_forwarding_infos = 0 then do;
		if (local_mep.acknowledge_to ^= null ()) & (local_mep.acknowledge_to ^= acknowledge_to) then
		     call mail_system_$free_address (local_mep.acknowledge_to, (0));
		local_mep.acknowledge_to = acknowledge_to;
	     end;

	     else do;				/* put it in the last redistribution */
		idx = mr_sort (forwarding_info_list.n_forwarding_infos);
		if (mrps (idx).acknowledge_to ^= null ()) & (mrps (idx).acknowledge_to ^= acknowledge_to) then
		     call mail_system_$free_address (mrps (idx).acknowledge_to, (0));

		mrps (idx).acknowledge_to = acknowledge_to;

		do current_field_list_idx = 1 to (forwarding_info_list.n_forwarding_infos - 1);
		     idx = mr_sort (current_field_list_idx);
		     if (mrps (idx).acknowledge_to ^= null ()) & (mrps (idx).acknowledge_to ^= acknowledge_to) then
			call mail_system_$free_address (mrps (idx).acknowledge_to, (0));
		     else mrps (idx).acknowledge_to = null ();
		end;

		if (local_mep.acknowledge_to ^= null ()) & (local_mep.acknowledge_to ^= acknowledge_to) then
		     call mail_system_$free_address (local_mep.acknowledge_to, (0));
		else local_mep.acknowledge_to = null ();/* message should hve only one Acknowledge-To field */
	     end;


/* In-mailbox/Incoming Message -- If supplied, set the last delivery date and address to the values from ring-1 and then
   place the envelope and redistributions list into the message */

	     if internal_parse_options.last_delivered_by ^= null () then
		if forwarding_info_list.n_forwarding_infos = 0 then do;
		     local_mep.date_time_delivered = internal_parse_options.last_date_time_delivered;
		     if local_mep.delivered_by ^= null () then
			call mail_system_$free_address (local_mep.delivered_by, (0));
		     if local_mep.sender ^= null () then
			if mail_system_$compare_addresses (local_mep.sender,
			     internal_parse_options.last_delivered_by, (0)) then
			     ;
			else local_mep.delivered_by = internal_parse_options.last_delivered_by;
		     else /*** if local_mep.sender = null () then */
			if
			mail_system_$compare_addresses (message.from -> address_list.addresses (1),
			internal_parse_options.last_delivered_by, (0)) then
			;
		     else local_mep.delivered_by = internal_parse_options.last_delivered_by;
		end;

		else do;
		     the_mrp_ptr = addr (mrps (mr_sort (forwarding_info_list.n_forwarding_infos)));
		     the_mrp.date_time_delivered = internal_parse_options.last_date_time_delivered;
		     if the_mrp.delivered_by ^= null () then
			call mail_system_$free_address (the_mrp.delivered_by, (0));
		     if the_mrp.sender ^= null () then
			if mail_system_$compare_addresses (the_mrp.sender, internal_parse_options.last_delivered_by,
			     (0)) then
			     ;
			else the_mrp.delivered_by = internal_parse_options.last_delivered_by;
		     else /*** if the_mrp.sender = null () then */
			if
			mail_system_$compare_addresses (the_mrp.from -> address_list.addresses (1),
			internal_parse_options.last_delivered_by, (0)) then
			;
		     else the_mrp.delivered_by = internal_parse_options.last_delivered_by;
		end;

	     call replace_message_envelope (message_ptr, addr (local_mep), code);
	     if code ^= 0 then call message_parse_error_fatal (code);
	     local_mep.sender, local_mep.delivered_by, local_mep.acknowledge_to = null ();

	     do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos;
		idx = mr_sort (current_field_list_idx);
		the_mrp_ptr = addr (mrps (idx));
		position = -1;			/* add it to the end please */
		call add_redistribution (message_ptr, the_mrp_ptr, position, code);
		if code ^= 0 then call message_parse_error_fatal (code);
		the_mrp.sender, the_mrp.delivered_by, the_mrp.acknowledge_to = null ();
		message_redistribution_ptr = addr (message_redistributions_list.redistributions (position));
		if the_mrp.from = message_redistribution.from then the_mrp.from = null ();
		if the_mrp.to = message_redistribution.to then the_mrp.to = null ();
		if the_mrp.comment.text_ptr = message_redistribution.comment.text_ptr then
		     the_mrp.comment.text_ptr = null ();/* don't leave it to be freed if it's used directly */
	     end;


/* In-mailbox/Incoming Message -- Set the implicit route for all addresses as appropriate */

	     if message.envelope.trace ^= null () then
		if message.envelope.trace -> message_trace.implicit_route ^= null () then do;
		     implicit_route = message.envelope.trace -> message_trace.implicit_route;
		     call set_implicit_route (message.from, implicit_route);
		     call set_implicit_route (message.reply_to, implicit_route);
		     call set_implicit_route (message.to, implicit_route);
		     call set_implicit_route (message.cc, implicit_route);
		     call set_implicit_route (message.bcc, implicit_route);
		     do idx = 1 to message.n_user_fields;
			message_user_field_ptr = addr (message_user_fields_list.user_fields (idx));
			if message_user_field.field_type = MESSAGE_ADDRESS_LIST_USER_FIELD then
			     call set_implicit_route (message_address_list_user_field.address_list_ptr,
				implicit_route);
		     end;
		end;

	     do idx = 1 to message.n_redistributions;
		message_redistribution_ptr = addr (message_redistributions_list.redistributions (idx));
		if message_redistribution.envelope.trace ^= null () then
		     if message_redistribution.envelope.trace -> message_trace.implicit_route ^= null () then do;
			implicit_route = message_redistribution.envelope.trace -> message_trace.implicit_route;
			call set_implicit_route (message_redistribution.from, implicit_route);
			call set_implicit_route (message_redistribution.to, implicit_route);
		     end;
	     end;
	end;


/* Control arrives here iff the message parse succeeded */

	call cleanup_message_parse_data ();		/* get rid of all temporaries */

	P_message_ptr = message_ptr;			/* pass the message back to our caller */

	if parse_text_options.list_errors then		/* will never be set by entries without this parameter */
	     P_parse_text_error_list_ptr = parse_text_error_list_ptr;

	if message_parse_fails then			/* some types of errors were detected ... */
	     P_code = mlsys_et_$text_parse_failed;	/* ... even though we might return a message structure */
	else P_code = 0;

	return;
%page;
/* Convert the external form of a mailing list (an ASCII segment/archive component containing the printed representation
   of addresses) into its internal representation:  This operation is identical to parse_address_list_text except that
   each line in a mailing list is considered a separate list unless, of course, a single address spans multiple lines; in
   addition, the lines in a mailing list may contain an optional trailing comma */

parse_mailing_list_text:
     entry (P_representation, P_address_list_version, P_address_list_ptr, P_code);

	local_pto.area_ptr = null ();			/* setup standard parse options */
	string (local_pto.flags) = ""b;
	local_pto.list_errors = "1"b;			/* see below */
	local_pto.include_invalid_addresses = "1"b;
	parse_text_options_ptr = addr (local_pto);

	string (internal_parse_options.flags) = ""b;
	internal_parse_options.multics_format = "1"b;	/* use standard Multics formatting conventions */
	internal_parse_options.no_copy = "0"b;		/* can't use supplied text directly (sigh) */

	internal_parse_options.default_system_is_local = "1"b;
	internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name ();

	string (internal_parse_options.delimiters) = ""b; /* terminate corectly only at the end of the string */
	internal_parse_options.delimiters.eos = "1"b;

	system_area_ptr = get_system_free_area_ ();

	add_address = mlsys_address_list_mgr_$add_address;
	create_address_list = mlsys_address_list_mgr_$create_user_freeable_address_list;
	delete_address = mlsys_address_list_mgr_$delete_address;
	free_address_list = mlsys_address_list_mgr_$free_address_list;

	address_list_ptr,				/* for cleanup handler */
	     lex_and_parse_pointers, forum_search_list_ptr = null ();

	on condition (cleanup)
	     begin;
	     if address_list_ptr ^= null () then call mlsys_address_list_mgr_$free_address_list (address_list_ptr, (0));
	     call lex_and_parse_epilogue ("1"b);
	     if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area);
	     forum_search_list_ptr = null ();
	end;

	call mlsys_address_list_mgr_$create_user_freeable_address_list (P_address_list_version, address_list_ptr, code);
	if code ^= 0 then do;			/* probably asked for the wrong version */
	     P_code = code;
	     return;
	end;

	representation_ptr = addr (P_representation);
	representation_lth = length (P_representation);
	representation_used = 0;			/* haven't parsed any of it yet */

	eol_idx = index (representation, NL);		/* start with first line in the mailing list */
	if eol_idx = 0 then eol_idx = length (representation) + 1;

	do while (representation_used < representation_lth);

	     begin;				/* try to parse the next section (usually a line) */

dcl  text_to_parse character (eol_idx - 1) unaligned defined (representation) position (representation_used + 1);

		if verify (text_to_parse, WHITESPACE) = 0 then
		     n_syntax_errors = 0;		/* ingore blank lines */
		else call parse_address_list_text_internal (parse_text_options, internal_parse_options, text_to_parse,
			address_list_ptr, code);

		if (n_syntax_errors > 0) & ((representation_used + eol_idx) < representation_lth) then do;

		     /*** Check for errors which can be generated if the last address in this section is incomplete */
		     if (sel (1).code = mlsys_et_$unbalanced_braces) | (sel (1).code = mlsys_et_$unbalanced_quotes)
			| (sel (1).code = mlsys_et_$unbalanced_parentheses) then do;
			call mlsys_address_list_mgr_$delete_address (address_list_ptr, address_list.n_addresses,
			     (0));
			amount_good = 0;		/* try entire section again with next line */
		     end;

		     else if sel (n_syntax_errors).code = mlsys_et_$invalid_named_group_text then
			if (sel (n_syntax_errors).text_start + sel (n_syntax_errors).text_lth)
			     >= length (text_to_parse) then do;
			     call mlsys_address_list_mgr_$delete_address (address_list_ptr,
				address_list.n_addresses, (0));
			     amount_good = sel (n_syntax_errors).text_start - 1;
			end;			/* try bad named group again with next line */
			else amount_good = length (text_to_parse);

		     else if sel (n_syntax_errors).code = mlsys_et_$empty_address_text then do;
			if (sel (n_syntax_errors).text_start + sel (n_syntax_errors).text_lth)
			     >= length (text_to_parse) then do;
			     begin;
dcl  empty_text character (sel (n_syntax_errors).text_lth) unaligned defined (representation)
	position (representation_used + sel (n_syntax_errors).text_start);
				if verify (empty_text, WHITESPACE) = 0 then
				     call mlsys_address_list_mgr_$delete_address (address_list_ptr,
					address_list.n_addresses, (0));
			     end;
			     amount_good = length (text_to_parse);
			end;

			else amount_good = length (text_to_parse);
		     end;

		     else amount_good = length (text_to_parse);
		end;

		else amount_good = length (text_to_parse);
	     end;

	     if (representation_used + amount_good) < representation_lth then do;
		begin;				/* find end of next line beyond current section */
dcl  rest_of_representation character (representation_lth - representation_used - eol_idx) unaligned
	defined (representation) position (representation_used + eol_idx);
		     next_eol_idx = index (rest_of_representation, NL);
		     if next_eol_idx = 0 then next_eol_idx = length (rest_of_representation) + 1;
		end;
		eol_idx = eol_idx - amount_good + next_eol_idx;
		representation_used = representation_used + amount_good;
	     end;
	     else representation_used = representation_lth;

	     call lex_and_parse_epilogue ("1"b);	/* get rid of syntax error list */
	end;

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

	return;
%page;
/* Convert the printed representation of an address list into its internal representation */

parse_address_list_text:
     entry (P_representation, P_parse_text_options_ptr, P_address_list_version, P_address_list_ptr,
	P_parse_text_error_list_ptr, P_code);

	parse_text_options_ptr = P_parse_text_options_ptr;
	if parse_text_options.version ^= PARSE_TEXT_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;
	if parse_text_options.mbz ^= ""b then do;
	     P_code = error_table_$bad_subr_arg;
	     return;
	end;

	add_address = mail_system_$add_address;
	create_address_list = mail_system_$create_address_list;
	delete_address = mail_system_$delete_address;
	free_address_list = mail_system_$free_address_list;

	system_area_ptr = get_system_free_area_ ();

	if parse_text_options.area_ptr = null () then
	     user_area_ptr = get_system_free_area_ ();
	else user_area_ptr = parse_text_options.area_ptr;

	string (internal_parse_options.flags) = ""b;
	internal_parse_options.multics_format = "1"b;	/* use standard Multics formatting conventions */
	internal_parse_options.no_copy = "0"b;		/* can't use supplied text directly */

	internal_parse_options.default_system_is_local = "1"b;
	internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name ();

	string (internal_parse_options.delimiters) = ""b; /* terminate corectly only at the end of the string */
	internal_parse_options.delimiters.eos = "1"b;

	address_list_ptr,				/* for cleanup handler */
	     lex_and_parse_pointers, forum_search_list_ptr = null ();

	on condition (cleanup)
	     begin;
	     if address_list_ptr ^= null () then call mail_system_$free_address_list (address_list_ptr, (0));
	     call lex_and_parse_epilogue ("1"b);
	     if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area);
	     forum_search_list_ptr = null ();
	end;

	call mail_system_$create_address_list (P_address_list_version, address_list_ptr, code);
	if code ^= 0 then do;			/* probably asked for the wrong version */
	     P_code = code;
	     return;
	end;

	call parse_address_list_text_internal (parse_text_options, internal_parse_options, P_representation,
	     address_list_ptr, code);

	if code ^= 0 then				/* iff caller requested an error free list */
	     call mail_system_$free_address_list (address_list_ptr, (0));

	if parse_text_options.list_errors & (n_syntax_errors > 0) then do;
	     parse_text_error_list_n_errors = n_syntax_errors;
	     allocate parse_text_error_list in (system_area) set (parse_text_error_list_ptr);
	     do idx = 1 to parse_text_error_list.n_errors;
		parse_text_error_list.errors (idx).text_start = sel (idx).text_start;
		parse_text_error_list.errors (idx).text_lth = sel (idx).text_lth;
		parse_text_error_list.errors (idx).code = sel (idx).code;
		parse_text_error_list.errors (idx).additional_info = "";
	     end;
	end;
	else parse_text_error_list_ptr = null ();

	call lex_and_parse_epilogue ("1"b);		/* get rid of syntax error list now */

	P_address_list_ptr = address_list_ptr;
	P_parse_text_error_list_ptr = parse_text_error_list_ptr;

	if n_syntax_errors > 0 then			/* something went wrong: let caller know ... */
	     P_code = mlsys_et_$text_parse_failed;	/* ... even though they might still be getting a list back */
	else P_code = 0;

	return;



/* Actually lexically analyze and parse the address list text (called from several different entrypoints) */

parse_address_list_text_internal:
     procedure (p_pto, p_ipo, p_representation, p_address_list_ptr, p_code) /* options (quick) */;

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;
dcl  p_representation character (*) parameter;
dcl  p_address_list_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;

dcl  bad_address pointer;

	call lex_and_parse_prologue (p_representation, "1"b, "1"b);
						/* lex of an address with syntax list */

	call lex_address (p_pto, p_ipo, p_code);	/* convert it into a token list */

	if p_code = 0 then				/* lex worked: try parsing it */
	     call parse_address_list (p_pto, p_ipo, 0, p_address_list_ptr, p_code);
	else do;					/* lex failed: record one error */
	     n_syntax_errors = 1;
	     if p_pto.list_errors then do;
		sel (1).text_start = 1;
		sel (1).text_lth = length (p_representation);
		sel (1).code = p_code;
	     end;
	     if p_pto.include_invalid_addresses then do;
		call mail_system_$create_invalid_address ((p_representation), "", "", bad_address, (0));
		call add_address (p_address_list_ptr, bad_address, ADDRESS_LIST_VERSION_2, (0));
		p_code = 0;			/* claim success */
	     end;
	end;

	call lex_and_parse_epilogue ("0"b);		/* cleanup */

	return;

     end parse_address_list_text_internal;
%page;
/* Convert the printed representation of an address into its internal representation */

parse_address_text:
     entry (P_representation, P_address_ptr, P_code);

	add_address = mail_system_$add_address;
	create_address_list = mail_system_$create_address_list;
	delete_address = mail_system_$delete_address;
	free_address_list = mail_system_$free_address_list;

	system_area_ptr = get_system_free_area_ ();

	parse_text_options_ptr = addr (local_pto);	/* caller doesn't supply this structure */
	string (local_pto.flags) = ""b;		/* ... don't list, validate, or create invalid addresses */

	internal_parse_options.multics_format = "1"b;	/* use standard Multics formatting conventions */
	internal_parse_options.no_copy = "0"b;		/* can't use supplied text directly */

	internal_parse_options.default_system_is_local = "1"b;
	internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name ();

	string (internal_parse_options.delimiters) = ""b; /* terminate corectly only at the end of the string */
	internal_parse_options.delimiters.eos = "1"b;

	lex_and_parse_pointers,			/* for cleanup handler */
	     forum_search_list_ptr = null ();

	on condition (cleanup)
	     begin;
	     call lex_and_parse_epilogue ("1"b);
	     if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area);
	     forum_search_list_ptr = null ();
	end;

	call parse_address_text_internal (parse_text_options, internal_parse_options, P_representation, address_ptr,
	     code);

	if code = 0 then				/* successfully parsed an address from the string */
	     P_address_ptr = address_ptr;

	P_code = code;

	return;



/* Actually lexically analyze and parse the address text (called from several different entrypoints) */

parse_address_text_internal:
     procedure (p_pto, p_ipo, p_representation, p_address_ptr, p_code) /* options (quick) */;

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;
dcl  p_representation character (*) parameter;
dcl  p_address_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;

	call lex_and_parse_prologue (p_representation, "1"b, "0"b);
						/* lex of an address without syntax list */

	call lex_address (p_pto, p_ipo, p_code);	/* convert it into a token list */

	if p_code = 0 then				/* lex worked: try parsing it */
	     call parse_address (p_pto, p_ipo, 0, p_address_ptr, p_code);

	call lex_and_parse_epilogue ("1"b);		/* cleanup */
	call cu_$shrink_stack_frame (stack_extension_ptr, (0));

	return;

     end parse_address_text_internal;
%page;
/* Initialize data structures used during parsing of a message */

initialize_message_parse_data:
     procedure ();

	message_scan.array_pointers, lex_and_parse_pointers, parse_text_error_list_ptr, mrps_ptr, mr_sort_ptr,
	     trace_address, comment_sender, local_mep.sender, local_mep.trace, local_mep.delivered_by,
	     local_mep.acknowledge_to, address_list_field, forum_search_list_ptr = null ();

	return;

     end initialize_message_parse_data;



/* Release interim data structures created during parsing of a message */

cleanup_message_parse_data:
     procedure ();

dcl  (idx, jdx) fixed binary;

	if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area);
	forum_search_list_ptr = null ();

	if address_list_field ^= null () then call free_address_list (address_list_field, (0));

	if local_mep.sender ^= null () then call mail_system_$free_address (local_mep.sender, (0));
	if local_mep.trace ^= null () then do;
	     if local_mep.trace -> message_trace.implicit_route ^= null () then
		free local_mep.trace -> message_trace.implicit_route -> address_route in (system_area);
	     do idx = 1 to local_mep.trace -> message_trace.n_relays;
		if local_mep.trace -> message_trace.relays (idx).relay_recipient ^= null () then
		     call mail_system_$free_address (local_mep.trace -> message_trace.relays (idx).relay_recipient,
			(0));
	     end;
	     free local_mep.trace -> message_trace in (system_area);
	     local_mep.trace = null ();
	end;
	if local_mep.delivered_by ^= null () then call mail_system_$free_address (local_mep.delivered_by, (0));
	if local_mep.acknowledge_to ^= null () then call mail_system_$free_address (local_mep.acknowledge_to, (0));

	if mrps_ptr ^= null () then do;
	     do idx = 1 to forwarding_info_list.n_forwarding_infos;
		if mrps (idx).sender ^= null () then call mail_system_$free_address (mrps (idx).sender, (0));
		if mrps (idx).trace ^= null () then do;
		     if mrps (idx).trace -> message_trace.implicit_route ^= null () then
			free mrps (idx).trace -> message_trace.implicit_route -> address_route in (system_area);
		     do jdx = 1 to mrps (idx).trace -> message_trace.n_relays;
			if mrps (idx).trace -> message_trace.relays (jdx).relay_recipient ^= null () then
			     call mail_system_$free_address (mrps (idx).trace
				-> message_trace.relays (jdx).relay_recipient, (0));
		     end;
		     free mrps (idx).trace -> message_trace in (system_area);
		     mrps (idx).trace = null ();
		end;
		if mrps (idx).delivered_by ^= null () then
		     call mail_system_$free_address (mrps (idx).delivered_by, (0));
		if mrps (idx).acknowledge_to ^= null () then
		     call mail_system_$free_address (mrps (idx).acknowledge_to, (0));
		if mrps (idx).from ^= null () then call free_address_list (mrps (idx).from, (0));
		if mrps (idx).to ^= null () then call free_address_list (mrps (idx).to, (0));
		if mrps (idx).comment.text_ptr ^= null () then
						/* there's some text ... */
		     begin;
dcl  the_comment character (mrps (idx).comment.text_lth) unaligned based (mrps (idx).comment.text_ptr);
		     free the_comment in (system_area);
		     mrps (idx).comment.text_ptr = null ();
		end;
	     end;
	     free mrps in (system_area);
	     mrps_ptr = null ();
	end;

	if mr_sort_ptr ^= null () then do;
	     free mr_sort in (system_area);
	     mr_sort_ptr = null ();
	end;

	if trace_address ^= null () then call mail_system_$free_address (trace_address, (0));

	if comment_sender ^= null () then call mail_system_$free_address (comment_sender, (0));

	call cleanup_message_scan ();			/* cleanup straight-forward data */
	call lex_and_parse_epilogue ("1"b);

	return;

     end cleanup_message_parse_data;
%page;
/* Scan the complete text of a message: isolate the message header and body; locate and classify each header field in the
   message */

scan_message_text:
     procedure (p_pto, p_ipo);

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;

dcl  message_header character (message_header_lth) unaligned based (message_header_ptr);
dcl  message_header_lth fixed binary (21);
dcl  message_header_ptr pointer;

dcl  message_body character (message_body_lth) unaligned based (message_body_ptr);
dcl  message_body_lth fixed binary (21);
dcl  message_body_ptr pointer;

dcl  field_name character (field_name_lth) unaligned based (field_name_ptr);
dcl  field_name_lth fixed binary (21);			/* current header field being examined */
dcl  field_name_ptr pointer;

dcl  (continuation_found, in_forwarding_info, in_comment_info) bit (1) aligned;

dcl  (start, eol_idx, idx, idx2, field_name_start, field_value_start) fixed binary (21);

dcl  (total_field_count, field_type) fixed binary;


	message_body_ptr,				/* examine entire message initially */
	     message_header_ptr = representation_ptr;
	message_body_lth, message_header_lth = representation_lth;
	message_scan.header_offset = 0;

	idx = verify (message_header, NL);		/* strip leading newlines added by defective FTP mailers */
	if idx ^= 0 then
	     if idx ^= 1 then do;
		message_body_ptr, message_header_ptr = addcharno (message_body_ptr, (idx - 1));
		message_body_lth, message_header_lth = message_header_lth - (idx - 1);
	     end;
	     else ;				/* no leading newlines */
	else go to NO_HEADER_FOUND_IN_MESSAGE;		/* all newlines: no header */

	message_scan.header_offset = charno (message_header_ptr) - charno (representation_ptr);

	idx = index (message_header, NLNL);		/* search for header delimiter (double newline) */
	if idx ^= 0 then				/* seems to have a header: adjust length ... */
	     message_header_lth = idx;		/* ... if <NL><NL> is missing, assume messageless header */

	idx = index (message_header, NL);		/* the header must have at least one newline in it */
	if idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE;

	idx = index (substr (message_header, 1, idx), COLON);
						/* header must have colon on first line */
	if idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE;


/* The message appears to have a header: tentatively set the location and size of the message body */

	message_body_ptr = addcharno (message_body_ptr, message_header_lth);
	message_body_lth = message_body_lth - message_header_lth;

	if message_body_lth <= 0 then do;		/* appears to be no body in the message, just a header */
	     message_scan.body_ptr = addr (NL);
	     message_scan.body_lth = 0;
	end;

	else do;					/* something there: strip leading newlines */
	     idx = verify (message_body, NL);
	     if (idx = 0) then message_body_lth = 0;	/* nothing but blank lines */
	     else if (idx ^= 1) then do;		/* some leading blank lines */
		message_body_ptr = addcharno (message_body_ptr, (idx - 1));
		message_body_lth = message_body_lth - (idx - 1);
	     end;
	     if (message_body_lth = 0) then do;		/* bodyless message */
		message_scan.body_ptr = addr (NL);
		message_scan.body_lth = 0;
	     end;
	     else do;				/* really do have body */
		message_scan.body_ptr = message_body_ptr;
		message_scan.body_lth = message_body_lth;
	     end;
	end;


/* Setup structures used to indicate results of the scan */

	message_scan.n_header_fields_allocated =	/* can't be more fields than lines in the header */
	     count_lines_in_text (message_header_ptr, message_header_lth);

	allocate header_field_list in (system_area) set (message_scan.header_field_list_ptr);
	header_field_list.n_fields = 0;		/* nothing examined yet */

	allocate field_by_type_lists in (system_area) set (message_scan.field_by_type_lists_ptr);
	field_by_type_lists.types (*).n_fields = 0;

	allocate forwarding_info_list in (system_area) set (message_scan.forwarding_info_list_ptr);
	forwarding_info_list.n_forwarding_infos = 0;

	allocate comment_info_list in (system_area) set (message_scan.comment_info_list_ptr);
	comment_info_list.n_comment_infos = 0;

	allocate user_field_list in (system_area) set (message_scan.user_field_list_ptr);
	user_field_list.n_user_fields = 0;


/* Now examine the purported header: find each field and classify it */

	start = 1;

	total_field_count = 0;			/* no fields yet */

	in_forwarding_info = "0"b;			/* not in the middle of a forwarding description */
	in_comment_info = "0"b;			/* ... ditto for comments */


	do while (start < message_header_lth);

	     eol_idx = index (substr (message_header, start), NL);
						/* find the end of this line */
	     if eol_idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE;
						/* fields must end in newline */

	     idx = index (substr (message_header, start, eol_idx), COLON);
	     if idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE;
						/* field name MUST be on first line */

	     field_name_ptr = addcharno (message_header_ptr, (start - 1));
	     field_name_start = start;		/* record where the field starts (for error messages) */
	     field_name_lth = idx - 1;		/* initially everything up to the colon */

	     idx2 = verify (field_name, HTSP);		/* field name must start at left margin */
	     if idx2 ^= 1 then go to NO_HEADER_FOUND_IN_MESSAGE;

	     field_name_lth = length (rtrim (field_name, HTSP));
						/* strip trailing whitespace from name */

	     start = start + idx;			/* skip to first character after the colon */

	     idx = verify (substr (message_header, start), HTSP);
	     if idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE;
						/* nothing after the colon (even a newline) */

	     start = start + idx - 1;			/* skip over the intervening whitespace */
	     field_value_start = start;		/* and remember where it is */

	     continuation_found = "1"b;		/* look for continuation lines */
	     do while (continuation_found);
		eol_idx = index (substr (message_header, start), NL);
		if eol_idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE;
		start = start + eol_idx;		/* skip to the next line */
		if index (HTSP, substr (message_header, start, 1)) ^= 0 then
		     continuation_found = "1"b;	/* this line is a continuation of the current field */
		else continuation_found = "0"b;	/* a new field */
	     end;

	     header_field_list.n_fields,		/* here's a new field */
		field_idx = header_field_list.n_fields + 1;

	     header_field_list.fields (field_idx).field_value_ptr =
		addcharno (message_header_ptr, (field_value_start - 1));
						/* where it starts ... */
	     header_field_list.fields (field_idx).field_value_lth = start - (field_value_start + 1);
						/* ... and how long excluding the trailing newline ... */
	     header_field_list.fields (field_idx).field_value_lth = length (rtrim (header_field_value, HTSP));
						/* ... and trailing whitespace */

	     header_field_list.fields (field_idx).complete_field_start = field_name_start;
	     header_field_list.fields (field_idx).complete_field_lth =
		field_value_start - field_name_start + header_field_list.fields (field_idx).field_value_lth;
						/* record location/size of entire field for error reporting */

	     call mlsys_field_id_mgr_$get_system_field_type (field_name, field_type, code);
	     if code ^= 0 then do;			/* field name is reserved for future expansion ... */
		call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
		header_field_list.n_fields, field_idx = header_field_list.n_fields - 1;
		go to PROCESS_NEXT_FIELD;
	     end;


	     if field_type = USER_DEFINED_FIELD then do;	/* unrecognized field name */
TREAT_AS_USER_DEFINED_FIELD:
		in_forwarding_info, in_comment_info = "0"b;
						/* force a new grouping */
		user_field_list.n_user_fields,	/* another one */
		     idx = user_field_list.n_user_fields + 1;
		user_field_list.user_fields (idx).field_value_idx = header_field_list.n_fields;
		call mail_system_$get_user_field_id ((field_name), user_field_list.user_fields (idx).field_id, (""),
		     code);
		if (code ^= 0) & (code ^= error_table_$smallarg) then call message_parse_error_fatal (code);
	     end;					/* ... get_user_field_id shouldn't fail */

	     else if (field_type > ORDINARY_FIELDS_BASE) & (field_type <= N_ORDINARY_FIELDS) then do;
						/* an ordinary field */
		in_forwarding_info, in_comment_info = "0"b;
		field_by_type_lists.types (field_type).n_fields, idx =
		     field_by_type_lists.types (field_type).n_fields + 1;
		field_by_type_lists.types (field_type).field_idxs (idx) = header_field_list.n_fields;
	     end;

	     else if (field_type > REDISTRIBUTED_FIELDS_BASE)
		& (field_type <= (REDISTRIBUTED_FIELDS_BASE + N_ORDINARY_FIELDS)) then do;
						/* part of a forwarding description */
		field_type = field_type - REDISTRIBUTED_FIELDS_BASE;
		if ^in_forwarding_info then call create_forwarding_info ();
		else if (forwarding_info.types (field_type).n_fields > 0)
		     & ^MULTIPLE_FIELDS_PER_REDISTRIBUTION (field_type) then
		     call create_forwarding_info ();
		else if forwarding_info.types (MESSAGE_ID_FIELD).n_fields > 0 then call create_forwarding_info ();
		in_forwarding_info = "1"b;		/* ... in the middle of one now */
		in_comment_info = "0"b;		/* ... can't be doing this anymore */
		forwarding_info.types (field_type).n_fields, idx = forwarding_info.types (field_type).n_fields + 1;
		forwarding_info.types (field_type).field_idxs (idx) = header_field_list.n_fields;
	     end;					/* ... set index of this field */

	     else if (field_type > COMMENT_FIELDS_BASE) & (field_type <= (COMMENT_FIELDS_BASE + N_ORDINARY_FIELDS))
	     then do;				/* part of a comment description */
		field_type = field_type - COMMENT_FIELDS_BASE;
		if ^in_comment_info then call create_comment_info ();
		else if (comment_info.types (field_type).n_fields > 0) & ^MULTIPLE_FIELDS_PER_COMMENT (field_type)
		     then
		     call create_comment_info ();
		in_comment_info = "1"b;		/* ... in the middle of one now */
		in_forwarding_info = "0"b;		/* ... can't be doing this anymore */
		comment_info.types (field_type).n_fields, idx = comment_info.types (field_type).n_fields + 1;
		comment_info.types (field_type).field_idxs (idx) = header_field_list.n_fields;
	     end;					/* ... set index of this field */

	     else go to TREAT_AS_USER_DEFINED_FIELD;	/* shouldn't get here, of course */

	     total_field_count = total_field_count + 1;	/* another field taken care of */

PROCESS_NEXT_FIELD:
	end;					/* of scan loop */

	return;


/* Control arives here if and only if a valid header is not found in the message */

NO_HEADER_FOUND_IN_MESSAGE:
	call message_parse_error_fatal (mlsys_et_$no_message_header);

	return;					/* will never get here, but ... */



/* Internal to scan_message_text: count the lines in a piece of text */

count_lines_in_text:
	procedure (p_text_ptr, p_text_lth) returns (fixed binary (21));

dcl  the_text character (p_text_lth) unaligned based (p_text_ptr);
dcl  p_text_ptr pointer parameter;
dcl  p_text_lth fixed binary (21) parameter;

dcl  (n_lines, used, idx) fixed binary (21);

	     n_lines, used = 0;

	     do while (used < p_text_lth);

		begin;

dcl  rest_of_text character (p_text_lth - used) unaligned defined (the_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;



/* Internal to scan_message_text: start the description of a new forwarding operation */

create_forwarding_info:
	procedure ();

	     forwarding_info_list.n_forwarding_infos = forwarding_info_list.n_forwarding_infos + 1;

	     allocate forwarding_info in (system_area) set (forwarding_info_ptr);
	     forwarding_info_list.forwarding_info_ptrs (forwarding_info_list.n_forwarding_infos) = forwarding_info_ptr;

	     forwarding_info.types (*).n_fields = 0;

	     return;

	end create_forwarding_info;



/* Internal to scan_message_text: start the description of a new commenting operation */

create_comment_info:
	procedure ();

	     comment_info_list.n_comment_infos = comment_info_list.n_comment_infos + 1;

	     allocate comment_info in (system_area) set (comment_info_ptr);
	     comment_info_list.comment_info_ptrs (comment_info_list.n_comment_infos) = comment_info_ptr;

	     comment_info.types (*).n_fields = 0;

	     return;

	end create_comment_info;

     end scan_message_text;
%page;
/* Cleanup the results of a message scan */

cleanup_message_scan:
     procedure ();

dcl  idx fixed binary;

	if message_scan.header_field_list_ptr ^= null () then free header_field_list in (system_area);

	if message_scan.field_by_type_lists_ptr ^= null () then free field_by_type_lists in (system_area);

	if message_scan.forwarding_info_list_ptr ^= null () then do;
	     do idx = 1 to forwarding_info_list.n_forwarding_infos;
		forwarding_info_ptr = forwarding_info_list.forwarding_info_ptrs (idx);
		free forwarding_info in (system_area);
	     end;
	     free forwarding_info_list in (system_area);
	end;

	if message_scan.comment_info_list_ptr ^= null () then do;
	     do idx = 1 to comment_info_list.n_comment_infos;
		comment_info_ptr = comment_info_list.comment_info_ptrs (idx);
		free comment_info in (system_area);
	     end;
	     free comment_info_list in (system_area);
	end;

	if message_scan.user_field_list_ptr ^= null () then free user_field_list in (system_area);

	message_scan.array_pointers = null ();		/* don't try to free them again */

	return;

     end cleanup_message_scan;
%page;
/* Report an error in the message parse: aborts the parse if required */

message_parse_error:
     procedure (p_pto, p_code, p_text_start, p_text_lth, p_additional_info);

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  p_code fixed binary (35) parameter;
dcl  (p_text_start, p_text_lth) fixed binary (21) parameter;
dcl  p_additional_info character (*) varying parameter;

dcl  new_ptel_ptr pointer;
dcl  idx fixed binary;

	if ^p_pto.list_errors then			/* any error is fatal if caller doesn't want list or errors */
	     call message_parse_error_fatal (p_code);

	message_parse_fails = "1"b;			/* set global flag to force correct returned status code */

	if parse_text_error_list_ptr = null () then
	     parse_text_error_list_n_errors = 1;
	else parse_text_error_list_n_errors = parse_text_error_list.n_errors + 1;

	allocate parse_text_error_list in (user_area) set (new_ptel_ptr);

	do idx = 1 to (parse_text_error_list_n_errors - 1);
	     new_ptel_ptr -> parse_text_error_list.errors (idx) = parse_text_error_list.errors (idx);
	end;

	if parse_text_error_list_ptr ^= null () then free parse_text_error_list in (user_area);
	parse_text_error_list_ptr = new_ptel_ptr;

	idx = parse_text_error_list_n_errors;		/* it's a shorter name ... */

	parse_text_error_list.errors (idx).text_start = p_text_start + message_scan.header_offset;
	parse_text_error_list.errors (idx).text_lth = p_text_lth;
	parse_text_error_list.errors (idx).code = p_code;
	parse_text_error_list.errors (idx).additional_info = p_additional_info;

	return;

     end message_parse_error;
%page;
/* Handler for fatal errors during the parsing of a message */

message_parse_error_fatal:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;

	call cleanup_message_parse_data ();		/* get rid of everything we've created */

	if message_ptr ^= null () then call free_message (message_ptr, (0));

	if parse_text_error_list_ptr ^= null () then	/* release the error description we setup */
	     free parse_text_error_list in (user_area);

	if parse_text_options.list_errors then do;	/* caller wants to see the actual reason */
	     parse_text_error_list_n_errors = 1;
	     allocate parse_text_error_list in (user_area) set (parse_text_error_list_ptr);
	     parse_text_error_list.errors (1).text_start = 1;
	     parse_text_error_list.errors (1).text_lth = 0;
	     parse_text_error_list.errors (1).code = p_code;
	     parse_text_error_list.errors (1).additional_info = "";
	     P_parse_text_error_list_ptr = parse_text_error_list_ptr;
	end;

	P_message_ptr = null ();			/* informs the caller that error too severe to bypass */
	P_code = mlsys_et_$text_parse_failed;		/* use standard global error code */

	go to RETURN_FROM_MESSAGE_PARSE_AFTER_FAILURE;

     end message_parse_error_fatal;


RETURN_FROM_MESSAGE_PARSE_AFTER_FAILURE:
	return;
%page;
/* Mark all fields of a given type as being reserved for in-mailbox messages only (only called from main procedure) */

mark_as_in_mailbox_field:
     procedure (p_field_list_ptr);

dcl  p_field_list_ptr pointer parameter;

dcl  1 field_list aligned based (p_field_list_ptr) like field_by_type_lists.types;
dcl  idx fixed binary;

	do idx = 1 to field_list.n_fields;
	     field_idx = field_list.field_idxs (idx);
	     call message_parse_error (parse_text_options, mlsys_et_$in_mailbox_only_field,
		header_field_list.fields (field_idx).complete_field_start,
		header_field_list.fields (field_idx).complete_field_lth, "");
	end;

	return;

     end mark_as_in_mailbox_field;



/* Find the index of the first field in a given set of fields (redistributions/comments) for possible error reporting */

find_first_field_in_list:
     procedure (p_field_lists_ptr, p_first_field_idx);

dcl  p_field_lists_ptr pointer parameter;
dcl  p_first_field_idx fixed binary parameter;

dcl  1 field_lists aligned based (p_field_lists_ptr) like field_by_type_lists;
dcl  (idx, jdx) fixed binary;

	p_first_field_idx = message_scan.n_header_fields_allocated + 1;

	do idx = 1 to N_ORDINARY_FIELDS;
	     do jdx = 1 to field_lists.types (idx).n_fields;
		p_first_field_idx = min (p_first_field_idx, field_lists.types (idx).field_idxs (jdx));
	     end;
	end;

	return;

     end find_first_field_in_list;
%page;
/* Set the implicit route for all the addresses in the given list */

set_implicit_route:
     procedure (p_address_list_ptr, p_implicit_route);

dcl  p_address_list_ptr pointer parameter;
dcl  p_implicit_route pointer parameter;

dcl  idx fixed binary;

	do idx = 1 to p_address_list_ptr -> address_list.n_addresses;
	     call set_address_implicit_route (p_address_list_ptr -> address_list.addresses (idx), p_implicit_route, (0))
		;
	end;

	return;

     end set_implicit_route;



/* Set the message date/time created and Message-ID directly as we are in the mail system ring: used only by the
   parse_im_message_text entrypoint (as the appropriate "primitives") */

set_date_time_created_directly:
     procedure (p_message_ptr, p_date_time_created, p_code);

dcl  p_message_ptr pointer parameter;
dcl  p_date_time_created fixed binary (71) parameter;
dcl  p_code fixed binary (35) parameter;

	message.date_time_created = p_date_time_created;
	p_code = 0;

	return;

     end set_date_time_created_directly;


set_message_id_directly:
     procedure (p_message_ptr, p_message_id, p_code);

dcl  p_message_ptr pointer parameter;
dcl  p_message_id bit (72) aligned parameter;
dcl  p_code fixed binary (35) parameter;

	message.message_id = p_message_id;
	p_code = 0;

	return;

     end set_message_id_directly;
%page;
/* Prepare a group of text fields for inclusion into the message as a single line field */

prepare_single_line_field:
     procedure (p_tf, p_field_list_ptr);

dcl  1 p_tf aligned parameter like message_text_field;
dcl  p_field_list_ptr pointer parameter;

dcl  1 field_list aligned based (p_field_list_ptr) like field_by_type_lists.types;

dcl  total_text character (total_text_lth) unaligned based (total_text_ptr);
dcl  total_text_ptr pointer;
dcl  (total_text_lth, total_text_used) fixed binary (21);

dcl  idx fixed binary;


	p_tf.multiline_text = "0"b;			/* just to be sure */

	if field_list.n_fields = 0 then do;		/* nothing there */
	     p_tf.text_ptr = null ();
	     p_tf.text_lth = 0;
	end;

	else if field_list.n_fields = 1 then do;	/* one field: return it directly */
	     field_idx = field_list.field_idxs (1);
	     p_tf.text_ptr = addr (header_field_value);
	     p_tf.text_lth = length (header_field_value);
	end;

	else do;					/* multiple fields: merge them */
	     total_text_lth = -1;			/* ... following loop computes a value that's one off */
	     do idx = 1 to field_list.n_fields;
		field_idx = field_list.field_idxs (idx);
		total_text_lth = total_text_lth + length (header_field_value) + 1;
	     end;
	     allocate total_text in (system_area) set (total_text_ptr);
	     total_text_used = 0;
	     do idx = 1 to field_list.n_fields;
		if idx > 1 then do;			/* ... separate them by a single space */
		     substr (total_text, (total_text_used + 1), 1) = SP;
		     total_text_used = total_text_used + 1;
		end;
		field_idx = field_list.field_idxs (idx);
		substr (total_text, (total_text_used + 1), length (header_field_value)) = header_field_value;
		total_text_used = total_text_used + length (header_field_value);
	     end;
	     p_tf.text_ptr = total_text_ptr;
	     p_tf.text_lth = total_text_lth;
	end;

	return;

     end prepare_single_line_field;
%page;
/* Prepare one or more text fields for inclusion in the message as a multiline field */

prepare_multiline_field:
     procedure () options (non_quick);

	return;					/* not an entrypoint */

dcl  p_fieldname_lth fixed binary parameter;
dcl  1 p_tf aligned parameter like message_text_field;
dcl  p_field_value character (*) parameter;
dcl  p_field_list_ptr pointer parameter;

dcl  1 field_list aligned based (p_field_list_ptr) like field_by_type_lists.types;

dcl  total_text character (total_text_lth) unaligned based (total_text_ptr);
dcl  total_text_ptr pointer;
dcl  (total_text_lth, total_text_used) fixed binary (21);

dcl  work_string character (work_string_lth) unaligned based (work_string_ptr);
dcl  work_string_ptr pointer;
dcl  (work_string_lth, work_string_used) fixed binary (21);

dcl  previous_text character (p_tf.text_lth) unaligned based (p_tf.text_ptr);

dcl  idx fixed binary;

dcl  STACK_EXTENSION fixed binary (18) static options (constant) initial (128);

dcl  FIELDNAME_SUFFIX character (3) static options (constant) initial (":  ");
dcl  STANDARD_MULTILINE_INDENTATION fixed binary static options (constant) initial (10);
dcl  CONTINUATION_INDICATOR character (2) static options (constant) initial ("--");


prepare_multiline_field_from_text:			/* prepare a single field */
     entry (p_fieldname_lth, p_tf, p_field_value);

	call cu_$grow_stack_frame (STACK_EXTENSION, work_string_ptr, (0));
	work_string_lth = 4 * STACK_EXTENSION;
	work_string_used = 0;

	call prepare_single_field_for_multiline (p_field_value);

	go to PREPARE_MULTILINE_FIELD_COMMON;


prepare_multiline_field_from_list:			/* prepare a list of fields */
     entry (p_fieldname_lth, p_tf, p_field_list_ptr);

	call cu_$grow_stack_frame (STACK_EXTENSION, work_string_ptr, (0));
	work_string_lth = 4 * STACK_EXTENSION;
	work_string_used = 0;

	do idx = 1 to field_list.n_fields;
	     field_idx = field_list.field_idxs (idx);
	     call prepare_single_field_for_multiline (header_field_value);
	end;

	go to PREPARE_MULTILINE_FIELD_COMMON;


/* Input fields have been properly prepared: combine them with any prior text and return the new text */

PREPARE_MULTILINE_FIELD_COMMON:
	p_tf.multiline_text = "1"b;			/* just in case */
	if p_tf.text_ptr = null () then p_tf.text_lth = 0;

	if work_string_used = 0 then return;		/* the input fields are empty */

	total_text_lth = p_tf.text_lth + work_string_used - 1;
	if p_tf.text_lth > 0 then total_text_lth = total_text_lth + 1;

	allocate total_text in (system_area) set (total_text_ptr);

	if p_tf.text_lth > 0 then do;			/* copy prior text */
	     substr (total_text, 1, length (previous_text)) = previous_text;
	     substr (total_text, (length (previous_text) + 1), 1) = NL;
	     total_text_used = length (previous_text) + 1;
	     free previous_text in (system_area);
	end;
	else total_text_used = 0;

	substr (total_text, (total_text_used + 1), (work_string_used - 1)) =
	     substr (work_string, 1, (work_string_used - 1));
						/* all except the trailing new line */

	p_tf.text_ptr = addr (total_text);
	p_tf.text_lth = length (total_text);

	return;



/* Internal to prepare_multiline_field: processes a single field.  All leading whitespace before the indent column is
   removed; any line which has "--" in the last two columns before the indent column is made a blank line */

prepare_single_field_for_multiline:
	procedure (p_text) /* options (quick) */;

dcl  p_text character (*) parameter;
dcl  (text_column, text_used, line_lth, start_of_text, column, used) fixed binary (21);

	     if verify (before (p_text, NL), HTSP) = 0 then do;
		text_column = STANDARD_MULTILINE_INDENTATION + 1;
		text_used = index (p_text, NL);	/* special case if first line blank: it's indented 10 */
	     end;
	     else do;
		text_column = p_fieldname_lth + length (FIELDNAME_SUFFIX) + 1;
		text_used = 0;
	     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);
		     line_lth = index (rest_of_text, NL) - 1;
		     if line_lth = -1 then		/* last line */
			line_lth = length (rest_of_text);
		end;

		if line_lth > 0 then
		     begin;
dcl  line character (line_lth) unaligned defined (p_text) position (text_used + 1);
		     start_of_text = verify (line, HTSP);
		     if start_of_text = 0 then	/* it's blank? */
			start_of_text = line_lth + 1;

		     begin;
dcl  whitespace character (start_of_text - 1) unaligned defined (p_text) position (text_used + 1);
			column = 1;
			used = 0;
			do while ((used < length (whitespace)) & (column < text_column));
			     used = used + 1;
			     if substr (whitespace, used, 1) = SP then column = column + 1;
			     else if mod (column, 10) = 0 then column = column + 1;
			     else column = column + 11 - mod (column, 10);
			end;
			if (column < (text_column - 1)) & (start_of_text < line_lth) then
			     if substr (line, start_of_text, 2) = CONTINUATION_INDICATOR then
				if verify (substr (line, (start_of_text + 2)), HTSP) = 0 then
				     go to LINE_IS_ACTUALLY_BLANK;
			if used < length (whitespace) then
			     start_of_text = start_of_text - (length (whitespace) - used);
		     end;

		     begin;
dcl  text character (line_lth - start_of_text + 1) unaligned defined (p_text) position (text_used + start_of_text);
			call add_to_work_string (addr (text), length (text));
		     end;
		end;

LINE_IS_ACTUALLY_BLANK:
		call add_to_work_string (addr (NL), 1);

		text_used = text_used + line_lth + 1;
	     end;

	     return;



/* Internal to prepare_single_field_for_multiline: adds a piece of text to the output buffer */

add_to_work_string:
	     procedure (p_text_ptr, p_text_lth) /* options (quick) */;

dcl  p_text_ptr pointer parameter;
dcl  p_text_lth fixed binary (21) parameter;

dcl  p_text character (p_text_lth) unaligned based (p_text_ptr);

		do while (work_string_lth < (work_string_used + p_text_lth));
		     call cu_$grow_stack_frame (STACK_EXTENSION, (null ()), (0));
		     work_string_lth = work_string_lth + 4 * STACK_EXTENSION;
		end;

		substr (work_string, (work_string_used + 1), p_text_lth) = p_text;

		work_string_used = work_string_used + p_text_lth;

		return;

	     end add_to_work_string;

	end prepare_single_field_for_multiline;

     end prepare_multiline_field;
%page;
/* Parse a message/redistribution envelope:  This entrypoint also parses the Date and From fields of the
   message/redistribution as they may be needed to supply defaults for the envelope and the message/redistribution ID */

parse_envelope:
     procedure (p_pto, p_ipo, p_is_redistribution, p_field_lists_ptr, p_envelope_ptr, p_date_time_created, p_from)
	/* options (quick) */;

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;
dcl  p_is_redistribution bit (1) aligned parameter;
dcl  (p_field_lists_ptr, p_envelope_ptr, p_from) pointer parameter;
dcl  p_date_time_created fixed binary (71) parameter;

dcl  1 field_lists aligned like field_by_type_lists based (p_field_lists_ptr);
dcl  1 envelope aligned like message_envelope based (p_envelope_ptr);

dcl  1 local_pto aligned like parse_text_options;
dcl  additional_info character (128) varying;
dcl  saved_default_system character (256) varying;
dcl  saved_default_system_is_local bit (1) aligned;
dcl  address_type fixed binary;
dcl  idx fixed binary;


	p_date_time_created, envelope.date_time_mailed, envelope.date_time_delivered = 0;
	envelope.sender, envelope.trace, envelope.delivered_by, envelope.acknowledge_to = null ();

	if p_is_redistribution then
	     additional_info = "The redistribution which starts with:";
	else additional_info = "The message which starts with:";


/* First parse the Date, Posted-Date, and Delivery-Date fields: there can be at most one of each of these fields and all
   of them must parse.  If the Posted-Date field is missing, it is set to the value of the Date field; if the
   Delivery-Date field is missing, it is set to the value of the Posted-Date field */

	if (field_lists.types (DATE_FIELD).n_fields = 0) & (field_lists.types (POSTED_DATE_FIELD).n_fields = 0)
	     & (field_lists.types (DELIVERY_DATE_FIELD).n_fields = 0) then
	     call message_parse_error (p_pto, mlsys_et_$cant_determine_dtc,
		header_field_list.fields (first_field_idx).complete_field_start,
		header_field_list.fields (first_field_idx).complete_field_lth, additional_info);

	if field_lists.types (DATE_FIELD).n_fields = 1 then do;
	     field_idx = field_lists.types (DATE_FIELD).field_idxs (1);
	     call parse_date_time_text (p_pto, p_ipo, header_field_value, p_date_time_created, code);
	     if code ^= 0 then
		call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	end;
	else if field_lists.types (DATE_FIELD).n_fields > 1 then do;
	     do idx = 1 to field_lists.types (DATE_FIELD).n_fields;
		field_idx = field_lists.types (DATE_FIELD).field_idxs (idx);
		call message_parse_error (p_pto, mlsys_et_$extra_restricted_field,
		     header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	     end;
	end;

	if field_lists.types (POSTED_DATE_FIELD).n_fields = 1 then do;
	     field_idx = field_lists.types (POSTED_DATE_FIELD).field_idxs (1);
	     call parse_date_time_text (p_pto, p_ipo, header_field_value, envelope.date_time_mailed, code);
	     if code ^= 0 then
		call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	end;
	else if field_lists.types (POSTED_DATE_FIELD).n_fields > 1 then do;
	     do idx = 1 to field_lists.types (POSTED_DATE_FIELD).n_fields;
		field_idx = field_lists.types (POSTED_DATE_FIELD).field_idxs (idx);
		call message_parse_error (p_pto, mlsys_et_$extra_restricted_field,
		     header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	     end;
	end;

	if field_lists.types (DELIVERY_DATE_FIELD).n_fields = 1 then do;
	     field_idx = field_lists.types (DELIVERY_DATE_FIELD).field_idxs (1);
	     call parse_date_time_text (p_pto, p_ipo, header_field_value, envelope.date_time_delivered, code);
	     if code ^= 0 then
		call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	end;
	else if field_lists.types (DELIVERY_DATE_FIELD).n_fields > 1 then do;
	     do idx = 1 to field_lists.types (DELIVERY_DATE_FIELD).n_fields;
		field_idx = field_lists.types (DELIVERY_DATE_FIELD).field_idxs (idx);
		call message_parse_error (p_pto, mlsys_et_$extra_restricted_field,
		     header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	     end;
	end;

	if p_date_time_created = 0 then		/* Date really should be there but ... */
	     if envelope.date_time_mailed ^= 0 then	/* ... so supply one */
		p_date_time_created = envelope.date_time_mailed;
	     else p_date_time_created = envelope.date_time_delivered;

	if envelope.date_time_mailed = 0 then		/* Posted-Date defaults to Date */
	     envelope.date_time_mailed = p_date_time_created;

	if envelope.date_time_delivered = 0 then	/* Delivery-Date defaults to Posted-Date */
	     envelope.date_time_delivered = envelope.date_time_mailed;


/* Parse the From and Sender fields: both must contain only valid addresses; in addition, there may only be one Sender
   field and it is allowed to contain only a single address.  After parsing, determine the default system to be used to
   parse other addresses in the header or redistribution */

	p_ipo.default_system_name = mlsys_nit_interface_$get_local_system_name ();
	p_ipo.default_system_is_local = "1"b;		/* local system is the default default system */

	string (local_pto.flags) = ""b;		/* requires it to parse properly */

	if field_lists.types (SENDER_FIELD).n_fields = 1 then do;
	     field_idx = field_lists.types (SENDER_FIELD).field_idxs (1);
	     call parse_address_text_internal (local_pto, p_ipo, header_field_value, envelope.sender, code);
	     if code ^= 0 then
		call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	end;
	else if field_lists.types (SENDER_FIELD).n_fields > 1 then do;
	     do idx = 1 to field_lists.types (SENDER_FIELD).n_fields;
		field_idx = field_lists.types (SENDER_FIELD).field_idxs (idx);
		call message_parse_error (p_pto, mlsys_et_$extra_restricted_field,
		     header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	     end;
	end;

	if envelope.sender ^= null () then do;		/* we have a Sender: extract the default system */
	     call mail_system_$get_address_type (envelope.sender, address_type, (0));
	     if address_type = FOREIGN_ADDRESS then do;	/* ... only if it's foreign, however */
		call mail_system_$get_address_system (envelope.sender, p_ipo.default_system_name, (0));
		p_ipo.default_system_is_local = mlsys_nit_interface_$is_local_system (p_ipo.default_system_name);
	     end;
	end;

	if p_is_redistribution then
	     full_fieldname = REDISTRIBUTED_PREFIX || FROM_FIELDNAME;
	else full_fieldname = FROM_FIELDNAME;

	call parse_address_list_field (p_pto, p_ipo, full_fieldname, addr (field_lists.types (FROM_FIELD)), p_from);

	if envelope.sender = null () then		/* no Sender: use From field to get default system */
	     if p_from -> address_list.n_addresses = 1 then do;
		call mail_system_$get_address_type (p_from -> address_list.addresses (1), address_type, (0));
		if address_type = FOREIGN_ADDRESS then do;
		     call mail_system_$get_address_system (p_from -> address_list.addresses (1),
			p_ipo.default_system_name, (0));
		     p_ipo.default_system_is_local = mlsys_nit_interface_$is_local_system (p_ipo.default_system_name);
		end;
	     end;

	     else do;				/* no Sender and the From field has multiple addresses */
		call message_parse_error (p_pto, mlsys_et_$cant_determine_sender,
		     header_field_list.fields (first_field_idx).complete_field_start,
		     header_field_list.fields (first_field_idx).complete_field_lth, additional_info);
	     end;					/* ... so continue to claim local system is the default */


/* Parse the Delivery-By and Acknowledge-To fields (if present): each must appear only once and contain exactly one valid
   address */

	saved_default_system = p_ipo.default_system_name;
	saved_default_system_is_local = p_ipo.default_system_is_local;
	p_ipo.default_system_name = mlsys_nit_interface_$get_local_system_name ();
	p_ipo.default_system_is_local = "1"b;		/* Delivery-By must be an absolute address */

	if field_lists.types (DELIVERY_BY_FIELD).n_fields = 1 then do;
	     field_idx = field_lists.types (DELIVERY_BY_FIELD).field_idxs (1);
	     call parse_address_text_internal (local_pto, p_ipo, header_field_value, envelope.delivered_by, code);
	     if code ^= 0 then
		call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	end;
	else if field_lists.types (DELIVERY_BY_FIELD).n_fields > 1 then do;
	     do idx = 1 to field_lists.types (DELIVERY_BY_FIELD).n_fields;
		field_idx = field_lists.types (DELIVERY_BY_FIELD).field_idxs (idx);
		call message_parse_error (p_pto, mlsys_et_$extra_restricted_field,
		     header_field_list.fields (field_idx).complete_field_start,
		     header_field_list.fields (field_idx).complete_field_lth, "");
	     end;
	end;

	p_ipo.default_system_name = saved_default_system;
	p_ipo.default_system_is_local = saved_default_system_is_local;

	if p_ipo.requests_acknowledgement then		/* don't both to look unless it's going to be acknowledged */
	     if field_lists.types (ACKNOWLEDGE_TO_FIELD).n_fields = 1 then do;
		field_idx = field_lists.types (ACKNOWLEDGE_TO_FIELD).field_idxs (1);
		call parse_address_text_internal (local_pto, p_ipo, header_field_value, envelope.acknowledge_to, code)
		     ;
		if code ^= 0 then
		     call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start,
			header_field_list.fields (field_idx).complete_field_lth, "");
	     end;
	     else if field_lists.types (ACKNOWLEDGE_TO_FIELD).n_fields > 1 then do;
		do idx = 1 to field_lists.types (ACKNOWLEDGE_TO_FIELD).n_fields;
		     field_idx = field_lists.types (ACKNOWLEDGE_TO_FIELD).field_idxs (idx);
		     call message_parse_error (p_pto, mlsys_et_$extra_restricted_field,
			header_field_list.fields (field_idx).complete_field_start,
			header_field_list.fields (field_idx).complete_field_lth, "");
		end;
	     end;


/* Supply a default From field (equal to the Sender) and eliminate redundant Sender and/or Delivery-By addresses */

	if p_from -> address_list.n_addresses = 0 then do;/* no From field supplied */
	     call add_address (p_from, envelope.sender, ADDRESS_LIST_VERSION_2, code);
	     if code ^= 0 then call message_parse_error_fatal (code);
	     envelope.sender = null ();		/* ... let's not be redundant */
	end;

	if p_from -> address_list.n_addresses = 1 then do;/* try to eliminate redundant Sender/Delivery-By */
	     if envelope.sender ^= null () then
		if mail_system_$compare_addresses (p_from -> address_list.addresses (1), envelope.sender, (0)) then
		     call mail_system_$free_address (envelope.sender, (0));
	     if envelope.delivered_by ^= null () then
		if mail_system_$compare_addresses (p_from -> address_list.addresses (1), envelope.delivered_by, (0))
		     then
		     call mail_system_$free_address (envelope.delivered_by, (0));
	end;					/* ... OK to free as parser never reuses addresses */

	if envelope.sender ^= null () then		/* check for redundant Delivery-By */
	     if envelope.delivered_by ^= null () then
		if mail_system_$compare_addresses (envelope.sender, envelope.delivered_by, (0)) then
		     call mail_system_$free_address (envelope.delivered_by, (0));


/* Finally, parse the message trace if present */

	if (field_lists.types (ROUTE_FIELD).n_fields > 0) | (field_lists.types (RELAYED_FIELD).n_fields > 0) then
	     call parse_trace ();

	return;
%page;
/* Internal to parse_envelope: parses the fields in a message trace; any errors in a message trace are considered
   non-fatal and the information in the trace is thrown away */

parse_trace:
	procedure () /* options (quick) */;

dcl  1 current_relay aligned based (current_relay_ptr) like message_trace.relays;
dcl  current_relay_ptr pointer;

dcl  1 local_ipo aligned like internal_parse_options;

dcl  the_route_ptr pointer;
dcl  address_system character (256) varying;
dcl  (start_of_id_string, end_of_id_string, bracket_level, message_id_string_lth, date_time_string_start) fixed
	binary (21);
dcl  (relay_idx, idx) fixed binary;


	     message_trace_n_relays = max (field_lists.types (RELAYED_FIELD).n_fields, 1);
						/* PL/I abhors a vacuum */

	     allocate message_trace in (system_area) set (message_trace_ptr);

	     message_trace.version = MESSAGE_TRACE_VERSION_2;
	     message_trace.implicit_route = null ();
	     message_trace.relays (*).date_time_relayed = 0;
	     message_trace.relays (*).sending_host = "";
	     message_trace.relays (*).receiving_host = "";
	     message_trace.relays (*).communications_media = "";
	     message_trace.relays (*).communications_protocol = "";
	     message_trace.relays (*).mail_protocol = "";
	     message_trace.relays (*).relay_id = ""b;
	     message_trace.relays (*).relay_recipient = null ();

	     envelope.trace = message_trace_ptr;	/* cleanup handler will now work OK */


/* Find the route by which this message/redistribution arrived at this system by parsing the Route field:  If there are
   multiple Route fields, all but the first are ignored as many systems add extraneous Route fields during transmission */

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

	     if field_lists.types (ROUTE_FIELD).n_fields ^= 0 then do;

		field_idx = field_lists.types (ROUTE_FIELD).field_idxs (1);

		call lex_and_parse_prologue (header_field_value, "1"b, "0"b);
						/* no cleanup handler here: caller's set one up already */

		call lex_address (p_pto, p_ipo, code);	/* convert into tokens */
		if code ^= 0 then call bypass_implicit_route (code, "1"b);

		token_idx = 0;			/* start at the first non-comment token */
		call next_real_token ();

		if current.type = LEFTBRACKET_TOKEN then do;
		     /*** RFC822 style route -- Return-Path: <@HOST,@HOST,...:STRING@HOST> */
		     call parse_address (p_pto, p_ipo, (token_idx - 1), trace_address, code);
		     call lex_and_parse_epilogue ("1"b);/* ... won't need the token list any longer ... */
		     call cu_$shrink_stack_frame (stack_extension_ptr, (0));
		     if code ^= 0 then call bypass_implicit_route (code, "1"b);
		     call mail_system_$get_address_route (trace_address, ADDRESS_ROUTE_VERSION_1, the_route_ptr, code)
			;
		     if code ^= 0 then call bypass_implicit_route (code, "0"b);
		     call mail_system_$get_address_system (trace_address, address_system, code);
		     if code ^= 0 then call bypass_implicit_route (code, "0"b);
		     address_route_n_relays = the_route_ptr -> address_route.n_relays + 1;
		     allocate address_route in (system_area) set (address_route_ptr);
		     message_trace.implicit_route = address_route_ptr;
		     address_route.version = ADDRESS_ROUTE_VERSION_1;
		     do idx = 1 to address_route.n_relays - 1;
			address_route.relays (idx) = the_route_ptr -> address_route.relays (idx);
		     end;
		     address_route.relays (address_route.n_relays) = address_system;
		     call mail_system_$free_address (trace_address, (0));
		end;

		else if current.type = AT_TOKEN then do;
		     /*** Multics style route:  [via RelayN ...] via Relay1 */
		     address_route_n_relays = 0;
		     do while (current.type = AT_TOKEN);
			address_route_n_relays = address_route_n_relays + 1;
			call next_real_token ();	/* ... to the system name */
			if current.type ^= WORD_TOKEN then
			     call bypass_implicit_route (mlsys_et_$missing_host_name, "1"b);
			host_indeces (address_route_n_relays) = token_idx;
			call next_real_token ();	/* ... to the next "via" or the end of the string */
		     end;
		     if current.type ^= END_OF_TEXT_TOKEN then
			call bypass_implicit_route (mlsys_et_$text_follows_route, "1"b);
		     allocate address_route in (system_area) set (address_route_ptr);
		     message_trace.implicit_route = address_route_ptr;
		     address_route.version = ADDRESS_ROUTE_VERSION_1;
		     do idx = 1 to address_route_n_relays;
			call make_token_current (host_indeces (idx));
			address_route.relays (address_route_n_relays - idx + 1) = current_token;
		     end;				/* ... the printed representation is backward */
		     call lex_and_parse_epilogue ("1"b);
		     call cu_$shrink_stack_frame (stack_extension_ptr, (0));
		end;

		else call bypass_implicit_route (mlsys_et_$invalid_route_field_syntax, "1"b);
	     end;


/* Determine the set of relay operations which took place to get the message here by parsing the Relayed fields */

BYPASS_IMPLICIT_ROUTE:
	     relay_idx = 1;				/* in case we have to bypass some fields */

	     do idx = 1 to field_lists.types (RELAYED_FIELD).n_fields;

		field_idx = field_lists.types (RELAYED_FIELD).field_idxs (idx);
		current_relay_ptr = addr (message_trace.relays (relay_idx));

		call lex_and_parse_prologue (header_field_value, "1"b, "0"b);
		call lex_address (p_pto, p_ipo, code);
		if code ^= 0 then call bypass_relay_operation (code, "1"b);

		token_idx = 0;			/* start at the beginning */
		call next_real_token ();

		do while (current.type ^= SEMICOLON_TOKEN);
		     if current.type = WORD_TOKEN then
			if translate (current_token, UPPERCASE, LOWERCASE) = "FROM" then do;
			     call next_real_token ();
			     if current.type = WORD_TOKEN then
				current_relay.sending_host = current_token;
			     else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b);
			end;
			else if (translate (current_token, UPPERCASE, LOWERCASE) = "BY")
			     | (translate (current_token, UPPERCASE, LOWERCASE) = "TO") then do;
			     call next_real_token ();
			     if current.type = WORD_TOKEN then
				current_relay.receiving_host = current_token;
			     else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b);
			end;
			else if translate (current_token, UPPERCASE, LOWERCASE) = "USING" then do;
			     call next_real_token ();
			     if current.type = WORD_TOKEN then
				current_relay.mail_protocol = current_token;
			     else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b);
			end;
			else if translate (current_token, UPPERCASE, LOWERCASE) = "WITH" then do;
			     call next_real_token ();
			     if current.type = WORD_TOKEN then
				current_relay.communications_protocol = current_token;
			     else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b);
			end;
			else if translate (current_token, UPPERCASE, LOWERCASE) = "VIA" then do;
			     call next_real_token ();
			     if current.type = WORD_TOKEN then
				current_relay.communications_media = current_token;
			     else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b);
			end;
			else if translate (current_token, UPPERCASE, LOWERCASE) = "ID" then do;
			     /*** ID <message-id> */
			     if current_relay.receiving_host = "" then
				call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b);
			     call next_real_token ();
			     start_of_id_string = token_idx;
			     if current.type = WORD_TOKEN then end_of_id_string = token_idx;
			     else if current.type = LEFTBRACKET_TOKEN then do;
				bracket_level = 1;
				do while (bracket_level > 1);
				     call next_real_token ();
				     if current.type = LEFTBRACKET_TOKEN then bracket_level = bracket_level + 1;
				     else if current.type = RIGHTBRACKET_TOKEN then
					bracket_level = bracket_level - 1;
				end;
				end_of_id_string = token_idx;
			     end;
			     else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b);
			     message_id_string_lth =
				token_list.tokens (end_of_id_string).original_start
				- token_list.tokens (start_of_id_string).original_start
				+ token_list.tokens (end_of_id_string).original_lth;
			     begin;
dcl  message_id_string character (message_id_string_lth) unaligned defined (header_field_value)
	position (token_list.tokens (start_of_id_string).original_start);
				call encode_foreign_id (message_id_string, current_relay.receiving_host,
				     current_relay.relay_id);
			     end;
			end;
			else if translate (current_token, UPPERCASE, LOWERCASE) = "FOR" then do;
			     /*** FOR <address>: must be last thing before semicolon */
			     local_ipo = p_ipo;
			     string (local_ipo.delimiters) = ""b;
			     call parse_address (p_pto, local_ipo, (token_idx + 1), current_relay.relay_recipient,
				code);
			     if code ^= 0 then call bypass_relay_operation (code, "1"b);
			     go to HAVE_FOUND_DATE_TIME_RELAYED;
			end;
			else do;			/* kludge: assume other word is proceeded by WITH */
			     current_relay.communications_protocol = current_token;
			end;
		     else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b);
		     call next_real_token ();
		end;

HAVE_FOUND_DATE_TIME_RELAYED:
		if (current_relay.sending_host = "") | (current_relay.receiving_host = "") then
		     call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b);

		/*** Have everything now but the date/time relayed which uses a different lex/parse */
		date_time_string_start = current.original_start + 1;

		call lex_and_parse_epilogue ("1"b);	/* get rid of the old token list */
		call cu_$shrink_stack_frame (stack_extension_ptr, (0));

		begin;
dcl  date_time_string character (length (header_field_value) - date_time_string_start + 1) unaligned
	defined (header_field_value) position (date_time_string_start);
		     call parse_date_time_text (p_pto, p_ipo, date_time_string, current_relay.date_time_relayed, code)
			;
		     if code ^= 0 then call bypass_relay_operation (code, "1"b);
		end;

		relay_idx = relay_idx + 1;		/* success */

BYPASS_RELAY_OPERATION:
	     end;

	     relay_idx = relay_idx - 1;		/* above loop sets this value one too high */


/* Insure that the trace isn't empty */

	     if (message_trace.implicit_route = null ()) & (relay_idx = 0) then do;
		free message_trace in (system_area);
		envelope.trace = null ();		/* nothing in it */
	     end;

	     else message_trace.n_relays = relay_idx;	/* insure it claims the right # of relays */

	     return;


/* Internal to parse_trace: aborts the parse of the Route field and continues to the parse of the Relayed fields */

bypass_implicit_route:
	     procedure (p_code, p_list_error) /* options (quick) */;

dcl  p_code fixed binary (35) parameter;
dcl  p_list_error bit (1) aligned;

		call lex_and_parse_epilogue ("1"b);	/* most likely we interrupted something */
		call cu_$shrink_stack_frame (stack_extension_ptr, (0));

		if trace_address ^= null () then call mail_system_$free_address (trace_address, (0));

		if message_trace.implicit_route ^= null () then
		     free message_trace.implicit_route -> address_route in (system_area);

		if p_list_error & p_pto.list_errors then
		     call message_parse_error (p_pto, p_code,
			header_field_list.fields (field_idx).complete_field_start,
			header_field_list.fields (field_idx).complete_field_lth, "");

		go to BYPASS_IMPLICIT_ROUTE;

	     end bypass_implicit_route;



/* Internal to parse_trace: aborts the parse of the current Relayed field and proceeds to the next one */

bypass_relay_operation:
	     procedure (p_code, p_list_error) /* options (quick) */;

dcl  p_code fixed binary (35);
dcl  p_list_error bit (1) aligned parameter;

		call lex_and_parse_epilogue ("1"b);	/* most likely we interrupted something */
		call cu_$shrink_stack_frame (stack_extension_ptr, (0));

		if trace_address ^= null () then call mail_system_$free_address (trace_address, (0));

		if current_relay.relay_recipient ^= null () then
		     call mail_system_$free_address (current_relay.relay_recipient, (0));

		if p_list_error & p_pto.list_errors then
		     call message_parse_error (p_pto, p_code,
			header_field_list.fields (field_idx).complete_field_start,
			header_field_list.fields (field_idx).complete_field_lth, "");

		go to BYPASS_RELAY_OPERATION;

	     end bypass_relay_operation;

	end parse_trace;

     end parse_envelope;
%page;
/* Parse the address lists in the header corresponding to the given field */

parse_address_list_field:
     procedure (p_pto, p_ipo, p_fieldname, p_field_list_ptr, p_address_list_ptr);

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;
dcl  p_fieldname character (*) varying parameter;
dcl  p_field_list_ptr pointer parameter;
dcl  p_address_list_ptr pointer parameter;

dcl  1 field_list aligned based (p_field_list_ptr) like field_by_type_lists.types;
dcl  idx fixed binary;


	call create_address_list (ADDRESS_LIST_VERSION_2, p_address_list_ptr, code);
	if code ^= 0 then call message_parse_error_fatal (code);
						/* all our software assumes address lists are never null */

	do idx = 1 to field_list.n_fields;
	     field_idx = field_list.field_idxs (idx);
	     call parse_address_list_text_internal (p_pto, p_ipo, header_field_value, p_address_list_ptr, code);
	     if code ^= 0 then call message_parse_error_fatal (code);
						/* only happens if caller asked not to continue on error */
	     call merge_error_lists (p_fieldname);	/* if listing errors: add any errors we find to the list */
	end;

	return;



/* Internal to parse_address_list_field: merge the results of an address list parse into the running results for the
   message parse */

merge_error_lists:
	procedure (p_fieldname);

dcl  p_fieldname character (*) varying parameter;

dcl  new_ptel_ptr pointer;
dcl  (n_previous_errors, text_offset, idx, offset_idx) fixed binary;

	     if parse_text_options.list_errors & (lex_and_parse_pointers.sel_ptr ^= null ()) & (n_syntax_errors > 0)
	     then do;				/* something did go wrong */
		message_parse_fails = "1"b;		/* ... be sure global code will be set properly */

		if parse_text_error_list_ptr = null () then
		     parse_text_error_list_n_errors = n_syntax_errors;
		else parse_text_error_list_n_errors = parse_text_error_list.n_errors + n_syntax_errors;
		n_previous_errors = parse_text_error_list_n_errors - n_syntax_errors;

		allocate parse_text_error_list in (user_area) set (new_ptel_ptr);

		do idx = 1 to n_previous_errors;
		     new_ptel_ptr -> parse_text_error_list.errors (idx) = parse_text_error_list.errors (idx);
		end;

		if parse_text_error_list_ptr ^= null () then free parse_text_error_list in (user_area);
		parse_text_error_list_ptr = new_ptel_ptr;

		text_offset = charno (addr (header_field_value)) - charno (representation_ptr);

		do idx = 1 to n_syntax_errors;
		     offset_idx = idx + n_previous_errors;
						/* ... get right place in the complete list */
		     parse_text_error_list.errors (offset_idx).text_start = sel (idx).text_start + text_offset;
		     parse_text_error_list.errors (offset_idx).text_lth = sel (idx).text_lth;
		     parse_text_error_list.errors (offset_idx).code = sel (idx).code;
		     if length (p_fieldname) > 0 then
			parse_text_error_list.errors (offset_idx).additional_info =
			     "In the " || p_fieldname || " field:";
		     else parse_text_error_list.errors (offset_idx).additional_info = "";
		end;
	     end;

	     call lex_and_parse_epilogue ("1"b);	/* get rid of syntax error list */

	     return;

	end merge_error_lists;

     end parse_address_list_field;
%page;
/* Parse a single address */

parse_address:
     procedure (p_pto, p_ipo, p_token_idx, p_address_ptr, p_code);

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;
dcl  p_token_idx fixed binary (21) parameter;		/* where the address starts/stops */
dcl  p_address_ptr pointer parameter;			/* set -> the address generated (if any) */
dcl  p_code fixed binary (35) parameter;

dcl  1 saved_p_ipo aligned like internal_parse_options;

dcl  foreign_system_name character (256) varying;
dcl  address_pathname character (200);
dcl  address_dirname character (168);
dcl  (address_ename, address_component) character (32);
dcl  trimmed_address_ename character (32) varying;
dcl  new_host_indeces_ptr pointer;
dcl  (first_token_in_address, last_token_in_address, delimiting_token, address_name_start, address_name_end, idx)
	fixed binary (21);
dcl  (in_named_address, seen_route, address_is_local, is_mte, done) bit (1) aligned;
dcl  error_table_$noentry fixed bin(35) ext static;
dcl  search_paths_$find_dir entry (char(*), ptr, char(*), char(*), char(*), fixed bin(35));
dcl  suffixed_name_$make entry (char(*), char(*), char(32), fixed bin(35));
          

	p_address_ptr = null ();			/* in case it fails */

	saved_p_ipo = p_ipo;			/* for cleanup handler */
	new_host_indeces_ptr, address_route_ptr = null ();

	on condition (cleanup)
	     begin;
	     p_ipo = saved_p_ipo;
	     if new_host_indeces_ptr ^= null () then free new_host_indeces_ptr -> host_indeces in (system_area);
	     if address_route_ptr ^= null () then free address_route in (system_area);
	end;

	call make_token_current (p_token_idx);
	delimiting_token = 0;			/* haven't gotten that far yet */

	address_name_start, address_name_end = 0;	/* no address name as yet */
	in_named_address = "0"b;

	seen_route = "0"b;				/* no RFC822 address route */


START_ADDRESS_PARSE:
	n_hosts, n_reversed_hosts = 0;		/* haven't seen any routing information */

	first_token_in_address = token_idx + 1;

	call next_real_token ();			/* move to the first token */

START_ADDRESS_PARSE_WITH_ROUTE:
	if ^in_named_address & end_of_address () then
	     /*** No non-comment tokens in the address (sigh) */
	     call bad_address_syntax (mlsys_et_$empty_address_text);

	else if current.type = COLON_TOKEN then
	     /*** an RFC733 structured address: no one understands them anymore */
	     call bad_address_syntax (mlsys_et_$obsolete_address_syntax);

	else if in_named_address & (current.type = AT_TOKEN) then
	     /*** RFC822-style explicit route (@HOST,@HOST,...:ADDR) */
	     if seen_route then
		call bad_address_syntax (mlsys_et_$multiple_address_routes);
	     else do;
		seen_route = "1"b;			/* don't let this happen again */
		done = "0"b;
		do while (^done);
		     n_hosts, n_reversed_hosts = n_hosts + 1;
		     host_indeces (n_hosts) = token_idx;
		     call next_real_token ();
		     if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$missing_host_name);
		     call next_real_token ();		/* skip past the host name */
		     if current.type = COLON_TOKEN then done = "1"b;
		     else if current.type = COMMA_TOKEN then do;
						/* more of the route follows */
			call next_real_token ();
			if current.type ^= AT_TOKEN then
			     call bad_address_syntax (mlsys_et_$only_address_route_allowed);
		     end;
		     else call bad_address_syntax (mlsys_et_$only_address_route_allowed);
		end;
		first_token_in_address = token_idx + 1; /* address starts after the colon */
		call next_real_token ();		/* skip over the colon to the address itself */
		go to START_ADDRESS_PARSE_WITH_ROUTE;
	     end;

	else if current.type = LEFTBRACE_TOKEN then do;
	     /*** A structured address */
	     do while (current.type ^= RIGHTBRACE_TOKEN); /* lex has guarenteed that the braces balance */
		call next_real_token ();		/* move to the end of the structured part */
	     end;
	     call next_real_token ();			/* move past the } */
	     do while (^end_of_address ());		/* may be followed by routing information only */
		if current.type ^= AT_TOKEN then call bad_address_syntax (mlsys_et_$only_address_route_allowed);
		n_hosts = n_hosts + 1;
		host_indeces (n_hosts) = token_idx;
		call next_real_token ();		/* past the AT ... */
		if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$missing_host_name);
		call next_real_token ();		/* ... and the host name following it */
	     end;
	end;

	else do;

	     /*** Simple address, named address, or a named group address */
	     do while (^end_of_address ());

		if current.type = LEFTBRACKET_TOKEN then
		     /*** A named address */
		     if in_named_address then
			call bad_address_syntax (mlsys_et_$recursive_named_addresses);
		     else do;			/* ... looks OK: start parse over terminating at ">" */
			address_name_start = first_token_in_address;
			address_name_end = token_idx - 1;
			in_named_address = "1"b;
			string (p_ipo.delimiters) = ""b;
			p_ipo.delimiters.angle_bracket = "1"b;
			go to START_ADDRESS_PARSE;
		     end;

		else if current.type = COLON_TOKEN then
		     /*** A named group */
		     if in_named_address then
			call bad_address_syntax (mlsys_et_$recursive_named_addresses);
		     else do;
			call parse_named_group ();
			go to RETURN_FROM_PARSE_ADDRESS;
		     end;				/* ... the internal procedure does all the necessary work */

		else if current.type = AT_TOKEN then do;
		     /*** A possible host name: remember it for later */
		     n_hosts = n_hosts + 1;
		     host_indeces (n_hosts) = token_idx;
		     call next_real_token ();
		     if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$missing_host_name);
		end;

		else if current.type = WORD_TOKEN
		/*** Part of the address proper */
		     then
		     ;

		else call bad_address_syntax (mlsys_et_$invalid_address_syntax);

		call next_real_token ();		/* move right along */
	     end;
	end;

	if in_named_address then do;
	     /*** End of named address processing: insure that proper delimiter follows the ">" */
	     last_token_in_address = token_idx - 1;	/* ... don't include the ">" as part of the address */
	     in_named_address = "0"b;
	     p_ipo = saved_p_ipo;
	     call next_real_token ();
	     if ^end_of_address () then call bad_address_syntax (mlsys_et_$text_follows_address);
	end;
	else last_token_in_address = 0;		/* don't know where it ends yet */


/* Determine the system of residence and construct the address route */

	delimiting_token = token_idx;

	if n_hosts = 0 then do;			/* no system/route given: use the default */
	     if last_token_in_address = 0 then		/* ... haven't seen the end because of a named address ... */
		last_token_in_address = token_idx - 1;	/* ... so it's all address */
	     address_is_local = p_ipo.default_system_is_local;
	     foreign_system_name = p_ipo.default_system_name;
	end;

	else do;					/* have system and/or route */
	     address_is_local = "0"b;			/* ... can't be sure until we try to validate it */
	     if n_reversed_hosts > 0 then do;		/* ... need to put host names into proper order */
		allocate host_indeces in (system_area) set (new_host_indeces_ptr);
		do idx = 1 to n_reversed_hosts;
		     new_host_indeces_ptr -> host_indeces (n_hosts - idx + 1) = host_indeces (idx);
		end;
		do idx = (n_reversed_hosts + 1) to n_hosts;
		     new_host_indeces_ptr -> host_indeces (idx - n_reversed_hosts) = host_indeces (idx);
		end;
		if baseno (lex_and_parse_pointers.host_indeces_ptr) ^= baseno (stackframeptr ()) then
		     free host_indeces in (system_area);
		lex_and_parse_pointers.host_indeces_ptr = new_host_indeces_ptr;
		new_host_indeces_ptr = null ();
	     end;
	     last_token_in_address = host_indeces (1) - 1;
	     call make_token_current (host_indeces (1));
	     call next_real_token ();			/* ... first host name is the foreign system */
	     foreign_system_name = current_token;	/* ... above code insured this is the right kind of token */
	     do idx = 2 to n_hosts;			/* ... move the remaining hosts (the route) down by 1 */
		host_indeces (idx - 1) = host_indeces (idx);
	     end;
	     n_hosts = n_hosts - 1;
	end;

	if n_hosts = 0 then				/* no explicit route */
	     address_route_ptr = null ();
	else do;
	     address_route_n_relays = n_hosts;
	     allocate address_route in (system_area) set (address_route_ptr);
	     address_route.version = ADDRESS_ROUTE_VERSION_1;
	     do idx = 1 to n_hosts;
		call make_token_current (host_indeces (idx));
		call next_real_token ();
		address_route.relays (n_hosts - idx + 1) = current_token;
	     end;					/* ... the printed representation is backward */
	end;


/* Get the address name and comment */

	if address_name_start = 0 then
	     address_name = "";			/* no address name */
	else call build_string (address_name_start, address_name_end, "1"b, "0"b, "1"b, address_name);

	call build_string ((p_token_idx + 1), (delimiting_token - 1), "0"b, "1"b, "1"b, address_comment);


/* Construct the actual address */

	if address_is_local then do;			/* a local address */
	     call make_token_current (first_token_in_address);
						/* back to the beginning */

	     if current.type = COMMENT_TOKEN then	/* skip past comment to the first real token */
		call next_real_token ();

	     if token_idx > last_token_in_address then	/* a null address */
		call bad_address_syntax (mlsys_et_$empty_address_text);

	     else if current.type = LEFTBRACE_TOKEN then do;
		/*** A structued address: validate it ... */
		call next_real_token ();		/* should be followed by the type of address */
		if current.type ^= WORD_TOKEN then
		     call bad_address_syntax (mlsys_et_$unknown_structured_address_type);

		if translate (current_token, UPPERCASE, LOWERCASE) = "LOGBOX" then do;
		     /*** The user's logbox ... */
		     call next_real_token ();		/* should be the close brace */
		     if current.type ^= RIGHTBRACE_TOKEN then
			call bad_address_syntax (mlsys_et_$text_follows_address);
		     call mail_system_$create_logbox_address (mlsys_data_$user_id, address_name, address_comment,
			p_address_ptr, code);
		     if code ^= 0 then call bad_address_syntax (code);
		end;

		else if translate (current_token, UPPERCASE, LOWERCASE) = "SAVE" then do;
		     /*** One of the user's saveboxes ... */
		     call next_real_token ();		/* should be the savebox pathname */
		     if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$address_pathname_expected);
		     if has_suffix (current_token, ".sv") then
			address_pathname = substr (current_token, 1, (length (current_token) - length (".sv")));
		     else address_pathname = current_token;
		     call next_real_token ();		/* should be the closing brace */
		     if current.type ^= RIGHTBRACE_TOKEN then
			call bad_address_syntax (mlsys_et_$text_follows_address);
		     if search (address_pathname, "<>") = 0 then do;
			call suffixed_name_$make (address_pathname, "sv.mbx", address_ename, code);
			if code ^= 0 then call bad_address_syntax (code);
			call search_paths_$find_dir ("mlsys", null(), address_ename, "", address_dirname, code);
			if code = error_table_$noentry then 
			     call expand_pathname_$add_suffix (address_pathname, "sv.mbx", address_dirname, address_ename, code);
			if code ^= 0 then address_dirname = "";
			end;
		     else
			call expand_pathname_$add_suffix (address_pathname, "sv.mbx", address_dirname, address_ename,
			code);
		     if code ^= 0 then call bad_address_syntax (code);
		     call reject_starnames (address_ename, "");
		     call mail_system_$create_savebox_address (mlsys_data_$user_id, address_dirname, address_ename,
			address_name, address_comment, p_address_ptr, code);
		     if code ^= 0 then call bad_address_syntax (code);
		end;

		else if translate (current_token, UPPERCASE, LOWERCASE) = "MBX" then do;
		     /*** A random mailbox ... */
		     call next_real_token ();		/* should be the mailbox pathname */
		     if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$address_pathname_expected);
		     address_pathname = current_token;
		     call next_real_token ();		/* should be the closing brace */
		     if current.type ^= RIGHTBRACE_TOKEN then
			call bad_address_syntax (mlsys_et_$text_follows_address);
     		     if search (address_pathname, "<>") = 0 then do;
			call suffixed_name_$make (address_pathname, "mbx", address_ename, code);
			if code ^= 0 then call bad_address_syntax (code);
			call search_paths_$find_dir ("mlsys", null(), address_ename, "", address_dirname, code);
			if code = error_table_$noentry then 
			     call expand_pathname_$add_suffix (address_pathname, "mbx", address_dirname, address_ename, code);
			if code ^= 0 then address_dirname = "";
			end;
		     else
			call expand_pathname_$add_suffix (address_pathname, "mbx", address_dirname, address_ename, code);
		     if code ^= 0 then call bad_address_syntax (code);
		     call reject_starnames (address_ename, "");
		     call mail_system_$create_mailbox_address (address_dirname, address_ename, address_name,
			address_comment, p_address_ptr, code);
		     if code ^= 0 then call bad_address_syntax (code);
		end;

		else if translate (current_token, UPPERCASE, LOWERCASE) = "FORUM" then do;
		     /*** A forum meeting ... */
		     call next_real_token ();		/* should be the meeting pathname */
		     if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$address_pathname_expected);
		     address_pathname = current_token;
		     call next_real_token ();		/* should be the closing brace */
		     if current.type ^= RIGHTBRACE_TOKEN then
			call bad_address_syntax (mlsys_et_$text_follows_address);
		     if search (address_pathname, "<>") = 0 then do;
			/*** ... not a pathname: must find the meeting by search list */
			if length (rtrim (address_pathname)) > length (address_ename) then
			     call bad_address_syntax (error_table_$entlong);
			address_ename = substr (address_pathname, 1, length (address_ename));
			if ^(has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control")) then
			     if length (rtrim (address_ename)) > (length (address_ename) - length (".forum")) then
				call bad_address_syntax (error_table_$entlong);
			call reject_starnames (address_ename, "");
			if mlsys_psp_$forum_not_available () then
			     /*** ... Forum PSP not here: we've done all we can; mlsys_transmit_ will do the rest */
			     address_dirname = "";
			else do;
			     /*** ... time to scan the search list */
			     if forum_search_list_ptr = null () then do;
				call search_paths_$get ("forum", sl_control_default, "", null (), system_area_ptr,
				     sl_info_version_1, forum_search_list_ptr, code);
				if code ^= 0 then call bad_address_syntax (code);
			     end;
			     if has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control") then
				call search_forum_list (address_ename, address_dirname, code);
			     else do;		/* ... try version 2 then version 1 meeting ... */
				trimmed_address_ename = rtrim (address_ename);
				call search_forum_list ((trimmed_address_ename || ".forum"), address_dirname,
				     code);
				if code = 0 then
				     address_ename = trimmed_address_ename || ".forum";
				else do;
				     call search_forum_list ((trimmed_address_ename || ".control"),
					address_dirname, code);
				     if code = 0 then address_ename = trimmed_address_ename || ".control";
				end;
			     end;
			     if code ^= 0 then	/* ... couldn't be found */
				address_dirname = "";
			end;
		     end;
		     else do;
			/*** .... a pathname */
			call expand_pathname_ (address_pathname, address_dirname, address_ename, code);
			if code ^= 0 then call bad_address_syntax (code);
			if ^(has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control")) then
			     if length (rtrim (address_ename)) > (length (address_ename) - length (".forum")) then
				call bad_address_syntax (error_table_$entlong);
			call reject_starnames (address_ename, "");
			if mlsys_psp_$forum_not_available () then
			     ;			/* ... no Forum PSP: we've done all we can */
			else do;
			     if ^(has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control"))
			     then do;
				/*** ... must determine the meeting version */
				trimmed_address_ename = rtrim (address_ename);
				address_ename = trimmed_address_ename || ".forum";
				call forum_$get_forum_path (address_dirname, address_ename, ((168)" "), ((32)" "),
				     code);
				if code ^= 0 then	/* ... not version 2 */
				     if (length (trimmed_address_ename) + length (".control"))
					<= length (address_ename) then
					address_ename = trimmed_address_ename || ".control";
			     end;
			end;
		     end;
		     call mail_system_$create_forum_address (address_dirname, address_ename, address_name,
			address_comment, p_address_ptr, code);
		     if code ^= 0 then call bad_address_syntax (code);
		end;

		else if translate (current_token, UPPERCASE, LOWERCASE) = "LIST" then do;
		     /*** A mailing list ... */
		     call next_real_token ();		/* should be the mailing list pathname */
		     if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$address_pathname_expected);
		     address_pathname = current_token;
		     call next_real_token ();		/* should be the closing brace */
		     if current.type ^= RIGHTBRACE_TOKEN then
			call bad_address_syntax (mlsys_et_$text_follows_address);
		     call expand_pathname_$component_add_suffix (address_pathname, "mls", address_dirname,
			address_ename, address_component, code);
		     if code ^= 0 then call bad_address_syntax (code);
     		     if search (address_pathname, "<>") = 0 then do;
			address_dirname = "";
			call search_paths_$find_dir ("mlsys", null(), address_ename, "", address_dirname, code);
			if code = error_table_$noentry then 
			     call expand_pathname_$component_add_suffix (address_pathname, "mls", address_dirname,
			     address_ename, address_component, code);
			if code ^= 0 then address_dirname = "";
			end;
		     if code ^= 0 then call bad_address_syntax (code);
		     call reject_starnames (address_ename, address_component);
		     call mail_system_$create_mailing_list_address (address_dirname, address_ename, address_component,
			address_name, address_comment, p_address_ptr, code);
		     if code ^= 0 then call bad_address_syntax (code);
		end;

		else call bad_address_syntax (mlsys_et_$unknown_structured_address_type);
	     end;

	     else do;				/* all text: user or mail table */
		call build_string (first_token_in_address, last_token_in_address, "1"b, "0"b, "1"b, address_string);
		call mlsys_user_mte_syntax_$classify_and_validate (address_string, is_mte, ((32)" "), ((32)" "), code)
		     ;
		if code ^= 0 then call bad_address_syntax (code);
		if is_mte then
		     call mail_system_$create_mail_table_address (address_string, address_name, address_comment,
			p_address_ptr, code);
		else call mail_system_$create_user_mailbox_address (address_string, address_name, address_comment,
			p_address_ptr, code);
		if code ^= 0 then call bad_address_syntax (code);
	     end;
	end;

	else do;					/* a foreign address */
	     call build_string (first_token_in_address, last_token_in_address, "1"b, "0"b, "1"b, address_string);
	     call mail_system_$create_foreign_address (address_string, foreign_system_name, address_route_ptr,
		address_name, address_comment, p_address_ptr, code);
	     if code ^= 0 then call bad_address_syntax (code);
	end;

	if p_pto.validate_addresses then do;		/* caller wants to be sure we can send it mail */
	     call mail_system_$validate_address (p_address_ptr, "1"b, code);
	     if code ^= 0 then do;			/* ... invalid */
		if ^p_pto.include_invalid_addresses then call mail_system_$free_address (p_address_ptr, (0));
		call bad_address_syntax (code);
	     end;
	end;

	code = 0;					/* success */


/* Parse completed */

RETURN_FROM_PARSE_ADDRESS:
	p_ipo = saved_p_ipo;			/* cleanup */
	if new_host_indeces_ptr ^= null () then free new_host_indeces_ptr -> host_indeces in (system_area);
	if address_route_ptr ^= null () then free address_route in (system_area);

	call make_token_current (delimiting_token);	/* show the delimiter to our caller */
	p_token_idx = delimiting_token;

	p_code = code;

	return;



/* Internal to parse_address: reports syntax errors in the address */

bad_address_syntax:
	procedure (p_code);

dcl  p_code fixed binary (35) parameter;

dcl  (brace_level, bracket_level, group_level) fixed binary (21);
dcl  string_lth fixed binary (21);

	     if delimiting_token = 0 then do;		/* must determine last token now */
		brace_level, bracket_level, group_level = 0;
		call make_token_current (first_token_in_address);
		if current.type = COMMENT_TOKEN then	/* skip to the first real token */
		     call next_real_token ();
		if (current.type = COLON_TOKEN) then do;/* an RFC733 structured address */
		     call next_real_token ();
		     call next_real_token ();		/* past the structure type ... */
		     call next_real_token ();		/* ... and the other colon */
		end;
		do while ((current.type ^= END_OF_TEXT_TOKEN) & (delimiting_token = 0));
		     if (brace_level <= 0) & (bracket_level <= 0) & (group_level <= 0) then
			if end_of_address () then	/* found the end of the address */
			     delimiting_token = token_idx;
		     if (current.type = LEFTBRACE_TOKEN) then
						/* keep track of nesting in order to find proper terminator */
			brace_level = brace_level + 1;
		     else if (current.type = RIGHTBRACE_TOKEN) then brace_level = brace_level - 1;
		     else if (current.type = LEFTBRACKET_TOKEN) then bracket_level = bracket_level + 1;
		     else if (current.type = RIGHTBRACKET_TOKEN) then bracket_level = bracket_level - 1;
		     else if (current.type = COLON_TOKEN) then group_level = group_level + 1;
		     else if (current.type = SEMICOLON_TOKEN) then group_level = group_level - 1;
		     call next_real_token ();		/* keep looking */
		end;
		if delimiting_token = 0 then		/* hit the end */
		     delimiting_token = token_idx;
	     end;

	     string_lth =				/* may use this value in several places ... */
		token_list.tokens (delimiting_token - 1).original_start
		- token_list.tokens (p_token_idx + 1).original_start
		+ token_list.tokens (delimiting_token - 1).original_lth;
	     string_lth = max (string_lth, 0);		/* ... above is negative if original_text is a null string */

	     n_syntax_errors = n_syntax_errors + 1;
	     if p_pto.list_errors then do;		/* caller wants to see the bad text */
		sel (n_syntax_errors).text_start = token_list.tokens (p_token_idx + 1).original_start;
		sel (n_syntax_errors).text_lth = string_lth;
		sel (n_syntax_errors).code = p_code;
	     end;

	     if p_pto.include_invalid_addresses & (p_address_ptr = null ()) then do;
		begin;				/* caller wants it in the address list and it isn't already */
dcl  the_string char (string_lth) defined (original_text) position (token_list.tokens (p_token_idx + 1).original_start);
		     call mail_system_$create_invalid_address ((the_string), "", "", p_address_ptr, (0));
		end;
	     end;

	     code = p_code;				/* set parse_address's output value */

	     go to RETURN_FROM_PARSE_ADDRESS;

	end bad_address_syntax;



/* Internal to parse_address: determines if the end of the address has been reached */

end_of_address:
	procedure () returns (bit (1) aligned);

	     if p_ipo.delimiters.eos & (current.type = END_OF_TEXT_TOKEN) then return ("1"b);

	     else if (current.type = END_OF_TEXT_TOKEN) then do;
						/* shouldn't have reached the end: syntax error */
		delimiting_token = token_idx;		/* clearly the address stops here */
		call bad_address_syntax (mlsys_et_$incomplete_address_text);
	     end;

	     else if p_ipo.delimiters.comma & (current.type = COMMA_TOKEN) then return ("1"b);

	     else if p_ipo.delimiters.angle_bracket & (current.type = RIGHTBRACKET_TOKEN) then return ("1"b);

	     else if p_ipo.delimiters.semicolon & (current.type = SEMICOLON_TOKEN) then return ("1"b);

	     else return ("0"b);

	end end_of_address;



/* Internal to parse_address: parses a named group */

parse_named_group:
	procedure ();

dcl  1 local_pto aligned like parse_text_options;
dcl  1 local_ipo aligned like internal_parse_options;

dcl  an_address_list_ptr pointer;
dcl  (saved_n_syntax_errors, second_half_comment_start) fixed binary (21);

	     address_name_start = first_token_in_address;
	     address_name_end = token_idx - 1;		/* up to but not including the ":" */

	     an_address_list_ptr = null ();		/* parse_address_list will set it up */

	     string (local_pto.flags) = ""b;		/* don't list errors, etc. */

	     local_ipo = p_ipo;			/* copy most internal options */
	     string (local_ipo.delimiters) = ""b;	/* ... except only stop on a semi-colon */
	     local_ipo.delimiters.semicolon = "1"b;

	     saved_n_syntax_errors = n_syntax_errors;	/* we'll convert all errors into a single error */
	     call parse_address_list (local_pto, local_ipo, token_idx, an_address_list_ptr, code);
	     n_syntax_errors = saved_n_syntax_errors;

	     if code ^= 0 then			/* named group is bad: report a single, global error */
		if code = mlsys_et_$incomplete_address_list_text then
		     call bad_address_syntax (mlsys_et_$incomplete_named_group_text);
		else call bad_address_syntax (mlsys_et_$invalid_named_group_text);

	     second_half_comment_start = token_idx + 1;	/* any comment after the semicolon is global */

	     call next_real_token ();			/* must be at the end now */
	     if ^end_of_address () then do;
		call free_address_list (an_address_list_ptr, (0));
		call bad_address_syntax (mlsys_et_$text_follows_address);
	     end;

	     delimiting_token = token_idx;		/* for cleanup */

	     call build_string (address_name_start, address_name_end, "1"b, "0"b, "1"b, address_name);
	     call build_string (address_name_start, address_name_end, "0"b, "1"b, "1"b, address_comment);
	     call build_string (second_half_comment_start, (delimiting_token - 1), "0"b, "1"b, "0"b, address_comment);
						/* pick up any remaining comment text */

	     call mail_system_$create_named_group_address (address_name, an_address_list_ptr, "1"b, address_comment,
		p_address_ptr, code);
	     if code ^= 0 then call bad_address_syntax (code);

	     return;

	end parse_named_group;



/* Internal to parse_address: construct the text string consisting of all the tokens within the specified range */

build_string:
	procedure (p_first_token, p_last_token, p_include_non_comments, p_include_comments, p_initialize_string,
	     p_string);

dcl  (p_first_token, p_last_token) fixed binary (21) parameter;
dcl  (p_include_non_comments, p_include_comments, p_initialize_string) bit (1) aligned parameter;
dcl  p_string character (*) varying parameter;
dcl  saved_current_token fixed binary (21);

	     if p_initialize_string then p_string = "";

	     saved_current_token = token_idx;		/* want to get back here when done */
	     call make_token_current (p_first_token);	/* start here please */

	     do while (token_idx <= p_last_token);	/* for all tokens in the string */
		if current.type = COMMENT_TOKEN then
		     if p_include_comments then do;
			p_string = p_string || current_token;
			p_string = p_string || " ";
		     end;
		     else ;
		else do;
		     if p_include_non_comments then do;
			p_string = p_string || current_token;
			p_string = p_string || " ";
		     end;
		     else ;
		end;
		call next_token ();			/* next, please */
	     end;

	     if length (p_string) > 0 then		/* it's one larger than it should be */
		p_string = substr (p_string, 1, (length (p_string) - 1));

	     call make_token_current (saved_current_token);
						/* back to where we were */

	     return;

	end build_string;



/* Internal to parse_address: rejects pathnames containing starnames */

reject_starnames:
	procedure (p_ename, p_component);

dcl  (p_ename, p_component) character (32) parameter;
dcl  code fixed binary (35);

	     call check_star_name_$entry (p_ename, code); /* first check the entryname */
	     if code = 0 then			/* ... entryname OK: check the component name (if present) */
		if p_component ^= "" then call check_star_name_$entry (p_component, code);

	     if (code = 1) | (code = 2) then code = error_table_$nostars;

	     if code ^= 0 then			/* either a starname or invalid syntax */
		call bad_address_syntax (code);

	     return;

	end reject_starnames;



/* Internal to parse_address: returns "1"b if the given suffix is present on the supplied name */

has_suffix:
	procedure (p_name, p_suffix) returns (bit (1) aligned);

dcl  (p_name, p_suffix) character (*) parameter;

	     return ((index (reverse (rtrim (p_name)), reverse (p_suffix)) = 1));

	end has_suffix;



/* Internal to parse_address: scans the forum search list (already obtained above) for the given entryname */

search_forum_list:
	procedure (p_ename, p_dirname, p_code);

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

dcl  ename character (32) initial ("");
dcl  idx fixed binary;

	     if length (rtrim (p_ename)) > length (ename) then do;
		p_code = error_table_$entlong;	/* ... constructed entry name is too long */
		return;
	     end;

	     p_code = 1;				/* need do until ... */

	     do idx = 1 to forum_search_list_ptr -> sl_info.num_paths while (p_code ^= 0);
		if forum_search_list_ptr -> sl_info.paths (idx).code = 0 then
		     call forum_$get_forum_path (forum_search_list_ptr -> sl_info.paths (idx).pathname, p_ename,
			((168)" "), ((32)" "), p_code);
		if p_code = 0 then p_dirname = forum_search_list_ptr -> sl_info.paths (idx).pathname;
	     end;

	     return;

	end search_forum_list;

     end parse_address;
%page;
/* Parse an address list */

parse_address_list:
     procedure (p_pto, p_ipo, p_token_idx, p_address_list_ptr, p_code);

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;
dcl  p_token_idx fixed binary (21) parameter;
dcl  p_address_list_ptr pointer;
dcl  p_code fixed binary (35) parameter;

dcl  1 local_ipo aligned like internal_parse_options;

dcl  an_address pointer;
dcl  (first_token_in_address_list, last_token_in_address_list) fixed binary (21);
dcl  (previous_n_addresses) fixed binary;
dcl  (created_address_list, done) bit (1) aligned;


	local_ipo = p_ipo;				/* use caller's options ... */
	local_ipo.delimiters.comma = "1"b;		/* ... but also allow a comma delimter */

	if p_address_list_ptr = null () then do;	/* must create the list */
	     call create_address_list (ADDRESS_LIST_VERSION_2, p_address_list_ptr, code);
	     if code ^= 0 then do;
		p_code = code;
		return;
	     end;
	     created_address_list = "1"b;
	end;
	else do;					/* already something in the list ... */
	     created_address_list = "0"b;
	     previous_n_addresses = p_address_list_ptr -> address_list.n_addresses;
	end;					/* ... in case we have to flush what we add */

	call make_token_current (p_token_idx);		/* peek ahead to the first token of the list ... */
	call next_token ();				/* ... to see if it's an empty list: only if at end-of-list */

	first_token_in_address_list = token_idx;	/* here's where the list starts ... */
	last_token_in_address_list = token_idx;		/* ... and for now: it also ends here */

	done = end_of_address_list ();		/* check for end-of-list before the first address */

	do while (^done);

	     call parse_address (p_pto, local_ipo, p_token_idx, an_address, code);
	     last_token_in_address_list = token_idx - 1;	/* ... the list now goes at least this far */

	     if an_address ^= null () then do;		/* have an address */
		call add_address (p_address_list_ptr, an_address, ADDRESS_LIST_VERSION_2, code);
		if code ^= 0 then call bad_address_list_syntax (code);
	     end;

	     else if ^p_pto.list_errors & ^p_pto.include_invalid_addresses then
		if code = 0 then			/* caller hasn't asked us to continue */
		     call bad_address_list_syntax (mlsys_et_$invalid_address_list_syntax);
		else if code = mlsys_et_$incomplete_address_text then
		     call bad_address_list_syntax (mlsys_et_$incomplete_address_list_text);
		else call bad_address_list_syntax (code);

	     done = end_of_address_list ();		/* check if we're done yet */
	end;

	code = 0;					/* success: caller will really set the code */

RETURN_FROM_PARSE_ADDRESS_LIST:
	p_code = code;
	return;


/* Internal to parse_address_list: reports syntax errors in the address list */

bad_address_list_syntax:
	procedure (p_code);

dcl  p_code fixed binary (35) parameter;

dcl  string_lth fixed binary (21);
dcl  idx fixed binary;

	     if created_address_list then		/* we created it; we destroy it */
		call free_address_list (p_address_list_ptr, (0));
	     else do;				/* we didn't create it: delete what we added */
		do idx = p_address_list_ptr -> address_list.n_addresses to (previous_n_addresses + 1) by -1;
		     call delete_address (p_address_list_ptr, idx, (0));
		end;
	     end;

	     string_lth =				/* may use this value in several places ... */
		token_list.tokens (last_token_in_address_list).original_start
		- token_list.tokens (first_token_in_address_list).original_start
		+ token_list.tokens (last_token_in_address_list).original_lth;
	     string_lth = max (string_lth, 0);		/* ... above is negative if original_text is a null string */

	     n_syntax_errors = n_syntax_errors + 1;
	     if p_pto.list_errors then do;		/* caller wants to see the bad text */
		sel (n_syntax_errors).text_start = token_list.tokens (first_token_in_address_list).original_start;
		sel (n_syntax_errors).text_lth = string_lth;
		sel (n_syntax_errors).code = p_code;
	     end;

	     code = p_code;				/* set parse_address_list's output value */

	     go to RETURN_FROM_PARSE_ADDRESS_LIST;

	end bad_address_list_syntax;



/* Internal to parse_address_list: determines if the end of the address list has been reached */

end_of_address_list:
	procedure () returns (bit (1) aligned);

	     if p_ipo.delimiters.eos & (current.type = END_OF_TEXT_TOKEN) then return ("1"b);

	     else if current.type = END_OF_TEXT_TOKEN then do;
		last_token_in_address_list = token_idx - 1;
		call bad_address_list_syntax (mlsys_et_$incomplete_address_list_text);
	     end;

	     else if p_ipo.delimiters.comma & (current.type = COMMA_TOKEN) then return ("1"b);

	     else if p_ipo.delimiters.angle_bracket & (current.type = RIGHTBRACKET_TOKEN) then return ("1"b);

	     else if p_ipo.delimiters.semicolon & (current.type = SEMICOLON_TOKEN) then return ("1"b);

	     else return ("0"b);

	end end_of_address_list;

     end parse_address_list;
%page;
/* Convert the printed representation of a date/time into its internal form */

parse_date_time_text:
     procedure (p_pto, p_ipo, p_date_time_text, p_date_time, p_code) /* options (quick) */;

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;
dcl  p_date_time_text character (*) parameter;
dcl  p_date_time fixed binary (71) parameter;
dcl  p_code fixed binary (35) parameter;

dcl  date_time fixed binary (71);

dcl  zone_name character (3);
dcl  zone_offset fixed binary (71);
dcl  (recognized_zone, standard_multics_zone, negative_offset) bit (1) aligned;

dcl  code fixed binary (35);
dcl  start fixed binary (21);
dcl  (day_of_week, day_of_month, month, year, hour, minute, second, hour_offset, minute_offset, idx) fixed binary;


	call lex_and_parse_prologue (p_date_time_text, "0"b, "0"b);
						/* no cleanup handler here: caller's set one up already */

	call lex_date_time (p_pto, p_ipo, code);	/* "-", "+", ":", and whitespace are delimiters */
	if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY;


/* Syntax of a date is:  [ <day-of-week> [ "," ] ] <date> [ "," ] <time> */

	token_idx = 0;				/* start at beginning */
	call next_token ();

	if current.type ^= WORD_TOKEN then go to TRY_CONVERT_DATE_TO_BINARY;

	day_of_week = 0;				/* assume not a day of week */
	do idx = lbound (DAY_OF_WEEKS, 1) to hbound (DAY_OF_WEEKS, 1) while (day_of_week = 0);
	     if translate (current_token, UPPERCASE, LOWERCASE) = DAY_OF_WEEKS (idx) then
		day_of_week = DAY_OF_WEEK_VALUES (idx);
	end;

	if day_of_week ^= 0 then do;			/* a day of week is present */
	     call next_token ();			/* ... next token may be a comma */
	     if current.type = COMMA_TOKEN then call next_token ();
	end;


/* Syntax of <date> is:  1*2<digits> [ "-" ] <month> [ "-" ] { 2<digits> | 4<digits> } */

	if current.type ^= WORD_TOKEN then go to TRY_CONVERT_DATE_TO_BINARY;
	if (current.token_lth < 1) | (current.token_lth > 2) then go to TRY_CONVERT_DATE_TO_BINARY;
						/* digits will appear as a 2 or 4 character word */
	day_of_month = cv_dec_check_ (current_token, code);
	if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY;

	call next_token ();				/* may be followed by an optional hyphen ... */
	if current.type = HYPHEN_TOKEN then call next_token ();

	if current.type ^= WORD_TOKEN then go to TRY_CONVERT_DATE_TO_BINARY;
	month = 0;				/* must be a month name */
	do idx = lbound (MONTHS, 1) to hbound (MONTHS, 1) while (month = 0);
	     if translate (current_token, UPPERCASE, LOWERCASE) = MONTHS (idx) then month = MONTH_VALUES (idx);
	end;
	if month = 0 then go to TRY_CONVERT_DATE_TO_BINARY;

	call next_token ();				/* may be followed by an optional hyphen ... */
	if current.type = HYPHEN_TOKEN then call next_token ();

	if current.type ^= WORD_TOKEN then go to TRY_CONVERT_DATE_TO_BINARY;
	if (current.token_lth ^= 2) & (current.token_lth ^= 4) then go to TRY_CONVERT_DATE_TO_BINARY;
						/* year must be two or four digits ... */
	if current.token_lth = 2 then			/* ... assume 20th century if 2 digits */
	     year = cv_dec_check_ (current_token, code) + 1900;
	else year = cv_dec_check_ (current_token, code);
	if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY;

	call next_token ();				/* an optional comma may appear here */
	if current.type = COMMA_TOKEN then call next_token ();


/* Syntax of <time> is:  <hour> <zone> */

/* Syntax of <hour> is:  <1*2digits> [ ":" ] <1*2digits> [ ":" <1*2digits> ] */

	if current.type ^= WORD_TOKEN then go to TRY_CONVERT_DATE_TO_BINARY;
	if current.token_lth <= 2 then do;		/* hour is separate */
	     hour = cv_dec_check_ (current_token, code);
	     if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY;
	     call next_token ();			/* ... skip to the minute/second and/or ":" */
	     if current.type = COLON_TOKEN then call next_token ();
	     start = 1;				/* ... minute starts at the beginning of the word */
	end;
	else if (current.token_lth >= 3) & (current.token_lth <= 6) then do;
						/* hour, minute, and seconds all in one word */
	     if mod (current.token_lth, 2) = 1 then do;	/* a single digit hour ... */
		hour = cv_dec_check_ ((substr (current_token, 1, 1)), code);
		start = 2;			/* ... minute starts in the middle of the word */
	     end;
	     else do;
		hour = cv_dec_check_ ((substr (current_token, 1, 2)), code);
		start = 3;			/* ... minute starts in the middle of the word */
	     end;
	     if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY;
	end;
	else go to TRY_CONVERT_DATE_TO_BINARY;		/* can't be part of the time */

	if current.type ^= WORD_TOKEN then go to TRY_CONVERT_DATE_TO_BINARY;
	if (current.token_lth - start + 1) <= 2 then do;	/* minute ends this token */
	     minute = cv_dec_check_ ((substr (current_token, start)), code);
	     if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY;
	     call next_token ();			/* ... skip to the seconds (maybe) */
	     if current.type = COLON_TOKEN then call next_token ();
	     start = 1;				/* ... try it as seconds */
	end;
	else if (current.token_lth - start + 1) <= 4 then do;
						/* minutes and seconds together */
	     if mod ((current.token_lth - start + 1), 2) = 1 then do;
		minute = cv_dec_check_ ((substr (current_token, start, 1)), code);
		start = start + 1;			/* ... skip to the seconds */
	     end;
	     else do;				/* two digit minutes */
		minute = cv_dec_check_ ((substr (current_token, start, 2)), code);
		start = start + 2;			/* ... skip to the seconds */
	     end;
	     if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY;
	end;
	else go to TRY_CONVERT_DATE_TO_BINARY;		/* can't be a time */

	if current.type = WORD_TOKEN then		/* there may be seconds here */
	     if (current.token_lth - start + 1) <= 2 then do;
						/* ... it's the right length */
		second = cv_dec_check_ ((substr (current_token, start)), code);
		if code = 0 then call next_token ();	/* ... it worked */
		else if start ^= 1 then		/* ... middle of a word: bad syntax */
		     go to TRY_CONVERT_DATE_TO_BINARY;
		else second = 0;			/* ... probably a time zone */
	     end;
	     else if start ^= 1 then			/* ... wrong length for seconds in the middle of a word */
		go to TRY_CONVERT_DATE_TO_BINARY;
	     else second = 0;			/* ... probably a time zone */
	else second = 0;				/* ... hopefully a time zone */


/* Syntax of <zone> is:  { [ "-" ] <zone-name> } | { { "+" | "-" } 4<digits> } */

	if current.type = WORD_TOKEN then do;		/* must be a time zone */
TRY_AS_TIME_ZONE_NAME:
	     if current.token_lth > 3 then		/* ... too long to be a time zone name */
		go to TRY_CONVERT_DATE_TO_BINARY;
	     zone_name = translate (current_token, UPPERCASE, LOWERCASE);
	     recognized_zone, standard_multics_zone = "0"b;
	     if p_ipo.multics_format then do;		/* ... try the Multics time zones first */
		call lookup_multics_zone_name ();
		if ^recognized_zone then call lookup_rfc822_zone_name ();
	     end;
	     else do;				/* ... try the RFC822 zone names first */
		call lookup_rfc822_zone_name ();
		if ^recognized_zone then call lookup_multics_zone_name ();
	     end;
	     if ^recognized_zone then go to TRY_CONVERT_DATE_TO_BINARY;
	end;

	else if (current.type = PLUS_TOKEN) | (current.type = HYPHEN_TOKEN) then do;
	     negative_offset = (current.type = HYPHEN_TOKEN);
	     call next_token ();			/* ... could be an explicit offset or a zone name */
	     if current.type ^= WORD_TOKEN then		/* ... sorry: must be digits or a zone name */
		go to TRY_CONVERT_DATE_TO_BINARY;
	     if current.token_lth ^= 4 then		/* ... an offset is exactly four digits ... */
		if negative_offset then
		     go to TRY_AS_TIME_ZONE_NAME;	/* ... preceeded by a "-": assume it's a time zone name */
		else go to TRY_CONVERT_DATE_TO_BINARY;	/* ... preceeded by a "+": can't be a zone name either */
	     hour_offset = cv_dec_check_ ((substr (current_token, 1, 2)), code);
	     if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY;
	     minute_offset = cv_dec_check_ ((substr (current_token, 3, 2)), code);
	     if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY;
	     if ((hour_offset < 12) & (minute_offset > 59)) | ((hour_offset = 12) & (minute_offset ^= 0)) then
		go to TRY_CONVERT_DATE_TO_BINARY;	/* ... offset isn't valid */
	     standard_multics_zone = "0"b;		/* ... might be a standard zone but don't bother to check */
	     zone_offset = ((60 * hour_offset) + minute_offset) * ONE_MINUTE;
	     if negative_offset then zone_offset = -zone_offset;
	end;					/* ... west of GMT */

	else go to TRY_CONVERT_DATE_TO_BINARY;		/* bad zone */

	call next_token ();				/* shouldn't be anything else left ... */
	if current.type ^= END_OF_TEXT_TOKEN then go to TRY_CONVERT_DATE_TO_BINARY;

	call lex_and_parse_epilogue ("1"b);
	call cu_$shrink_stack_frame (stack_extension_ptr, (0));


/* Control arrives here if the date string parsed properly: try to convert the results into an actual clock reading */

	if ^standard_multics_zone then		/* will add offset later...  */
	     zone_name = "GMT";			/* ... so act like it's universal time */

	call encode_clock_value_ (month, day_of_month, year, hour, minute, second, 0, day_of_week, zone_name, date_time,
	     code);

	if code = 0 then				/* it converted ... */
	     if standard_multics_zone then		/* ... and it's a recognized time zone */
		p_date_time = date_time;
	     else p_date_time = date_time - zone_offset;	/* ... zone known only to us: offset alreay applied once */

	p_code = code;				/* reflect success or failure */

	return;


/* Control arrives here if and only if the date/time string wasn't parseable: try the Multics standard encoding routine
   just to be certain */

TRY_CONVERT_DATE_TO_BINARY:
	call lex_and_parse_epilogue ("1"b);
	call cu_$shrink_stack_frame (stack_extension_ptr, (0));

	call convert_date_to_binary_ (p_date_time_text, p_date_time, p_code);

	return;



/* Internal to parse_date_time_text: determines if the given zone name is a Multics standard time zone */

lookup_multics_zone_name:
	procedure ();

dcl  (idx, jdx) fixed binary;

	     standard_multics_zone = "0"b;		/* need do until */

	     do idx = 1 to ti_zone.number_lang while (^standard_multics_zone);
		do jdx = 1 to ti_zone.number_zone while (^standard_multics_zone);
		     if zone_name = translate (ti_zone.short (idx, jdx), UPPERCASE, LOWERCASE) then
			recognized_zone, standard_multics_zone = "1"b;
		end;
	     end;

	     return;

	end lookup_multics_zone_name;



/* Internal to parse_date_time_text: determines if the given zone name is an RFC822 standard time zone */

lookup_rfc822_zone_name:
	procedure ();

dcl  (zone_idx, idx) fixed binary;

	     zone_idx = 0;

	     do idx = lbound (RFC822_ZONES, 1) to hbound (RFC822_ZONES, 1) while (zone_idx = 0);
		if zone_name = RFC822_ZONES (idx) then zone_idx = idx;
	     end;

	     if zone_idx ^= 0 then do;		/* found it */
		recognized_zone = "1"b;
		zone_offset = RFC822_ZONE_OFFSETS (zone_idx) * ONE_MINUTE;
	     end;

	     return;

	end lookup_rfc822_zone_name;

     end parse_date_time_text;
%page;
/* Convert the printed representation of a Message-ID into its internal form */

parse_message_id_text:
     procedure (p_pto, p_ipo, p_message_id_text, p_message_id) /* options (quick) */;

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;
dcl  p_message_id_text character (*) parameter;
dcl  p_message_id bit (72) aligned;

dcl  1 request_id aligned,				/* a request ID broken into its component parts */
       2 year character (2) unaligned,
       2 month character (2) unaligned,
       2 day_of_month character (2) unaligned,
       2 hour character (2) unaligned,
       2 minute character (2) unaligned,
       2 second character (2) unaligned,
       2 period character (1) unaligned,		/* a "." must be in here */
       2 microsecond character (6) unaligned;

dcl  system_name character (256) varying;
dcl  (system_is_local, continue) bit (1) aligned;
dcl  (date_time, microsecond) fixed binary (71);
dcl  (start_of_string, end_of_string) fixed binary (21);
dcl  (day_of_month, month, year, hour, minute, second) fixed binary;


	call lex_and_parse_prologue (p_message_id_text, "1"b, "0"b);
						/* no cleanup handler here: caller's set one up already */

	call lex_message_id (p_pto, p_ipo, code);	/* standard address breaks without preserving comments */

	if code ^= 0 then do;			/* unable to lexically analyze the string */
CANT_INTERPRET_MESSAGE_ID:				/* ... most errors during the parse will come here */
	     call encode_foreign_id (p_message_id_text, p_ipo.default_system_name, p_message_id);
	     call lex_and_parse_epilogue ("1"b);
	     call cu_$shrink_stack_frame (stack_extension_ptr, (0));
	     return;
	end;


/* format: off */
/* The general syntax of a message identifier is

		< STRING at HOST >

   If the HOST is the local system or is ommitted and the default host is the local system, the STRING is expected to be a
   standard Multics request identifier (ie: YYMMDDHHMMSS.FFFFFF) */
/* format: on */

	token_idx = 0;				/* start at the beginning */
	call next_token ();

	if current.type ^= LEFTBRACKET_TOKEN then go to CANT_INTERPRET_MESSAGE_ID;
	call next_token ();

	start_of_string = token_idx;			/* the string portion starts here if all goes well */

	continue = "1"b;
	do while (continue);
	     if current.type = END_OF_TEXT_TOKEN then go to CANT_INTERPRET_MESSAGE_ID;
	     else if current.type = RIGHTBRACKET_TOKEN then continue = "0"b;
	     else if current.type = AT_TOKEN then continue = "0"b;
	     else call next_token ();			/* part of the string ... */
	end;

	end_of_string = token_idx - 1;		/* string part is everything up to here ... */

	if current.type = AT_TOKEN then do;		/* a host name should follow */
	     call next_token ();
	     if current.type ^= WORD_TOKEN then go to CANT_INTERPRET_MESSAGE_ID;
	     system_name = current_token;
	     call next_token ();
	end;
	else system_name = "";			/* we'll use the default system here */

	if current.type ^= RIGHTBRACKET_TOKEN then go to CANT_INTERPRET_MESSAGE_ID;

	call next_token ();
	if current.type ^= END_OF_TEXT_TOKEN then go to CANT_INTERPRET_MESSAGE_ID;


/* Have the text portion of the ID and its system name */

	address_string = "";			/* build the actual text portion of the ID */
	call make_token_current (start_of_string);
	do while (token_idx <= end_of_string);
	     if token_idx > start_of_string then	/* ... 1 space between tokens */
		address_string = address_string || " ";
	     address_string = address_string || current_token;
	     call next_token ();
	end;

	if system_name = "" then do;			/* no explicit system name: use the default */
	     system_name = p_ipo.default_system_name;
	     system_is_local = p_ipo.default_system_is_local;
	end;
	else system_is_local = mlsys_nit_interface_$is_local_system (system_name);

	if system_is_local & (length (address_string) = length (string (request_id))) then do;
	     string (request_id) = address_string;	/* should be a Multics request ID */
	     if request_id.period ^= PERIOD then go to ENCODE_FOREIGN_ID;
	     year = cv_dec_check_ (request_id.year, code) + 1900;
	     if code = 0 then month = cv_dec_check_ (request_id.month, code);
	     if code = 0 then day_of_month = cv_dec_check_ (request_id.day_of_month, code);
	     if code = 0 then hour = cv_dec_check_ (request_id.hour, code);
	     if code = 0 then minute = cv_dec_check_ (request_id.minute, code);
	     if code = 0 then second = cv_dec_check_ (request_id.second, code);
	     if code = 0 then microsecond = cv_dec_check_ (request_id.microsecond, code);
	     if code = 0 then
		call encode_clock_value_ (month, day_of_month, year, hour, minute, second, microsecond, 0, "GMT",
		     date_time, code);
	     if code ^= 0 then			/* wasn't really a request ID */
		go to ENCODE_FOREIGN_ID;
	     call encode_local_id (date_time, p_message_id);
	end;

	else					/* either not a request ID or not local */
ENCODE_FOREIGN_ID:
	     call encode_foreign_id ((address_string), system_name, p_message_id);

	call lex_and_parse_epilogue ("1"b);
	call cu_$shrink_stack_frame (stack_extension_ptr, (0));

	return;

     end parse_message_id_text;
%page;
/* Initialize data required to lex/parse a given string */

lex_and_parse_prologue:
     procedure (p_original_text, p_address_parse, p_address_list_parse);

dcl  p_original_text character (*) parameter;
dcl  p_address_parse bit (1) aligned parameter;		/* ON => create data necessary to parse an address */
dcl  p_address_list_parse bit (1) aligned parameter;	/* ON => create data necessary to parse an address list */

	original_text_ptr = addr (p_original_text);
	original_text_lth = length (p_original_text);

	lex_and_parse_pointers = null ();		/* be sure the ones we don't set here are null */

	call cu_$grow_stack_frame (STACK_EXTENSION, stack_extension_ptr, (0));
	stack_extension_used = 0;

	call get_space (size (token_list), lex_and_parse_pointers.token_list_ptr);

	call get_space (size (unquoted_text), lex_and_parse_pointers.unquoted_text_ptr);

	if p_address_parse then do;			/* need host name list and a work string */
	     call get_space (size (host_indeces), lex_and_parse_pointers.host_indeces_ptr);
	     call get_space (size (address_string), lex_and_parse_pointers.address_string_ptr);
	     call get_space (size (address_name), lex_and_parse_pointers.address_name_ptr);
	     call get_space (size (address_comment), lex_and_parse_pointers.address_comment_ptr);
	end;

	if p_address_list_parse then			/* need list of syntax errors for caller */
	     call get_space (size (sel), lex_and_parse_pointers.sel_ptr);

	stack_truncation_ptr =
	     addwordno (stack_extension_ptr, (stack_extension_used + 16 - mod (stack_extension_used, 16)));
	call cu_$shrink_stack_frame (stack_truncation_ptr, (0));

	n_syntax_errors = 0;			/* count errors in the string no matter what */

	return;



/* Internal to lex_and_parse_prologue: gets the requested amount of space on the stack or in the system free area */

get_space:
	procedure (p_n_words, p_pointer);

dcl  p_n_words fixed binary (18) parameter;
dcl  p_pointer pointer parameter;
dcl  words (p_n_words) bit (36) aligned based (p_pointer);

	     if (p_n_words + stack_extension_used) <= STACK_EXTENSION then do;
		p_pointer = addwordno (stack_extension_ptr, stack_extension_used);
		stack_extension_used = stack_extension_used + p_n_words + mod (p_n_words, 2);
	     end;

	     else allocate words in (system_area) set (p_pointer);

	     return;

	end get_space;

     end lex_and_parse_prologue;
%page;
/* Cleanup after a lex/parse operation */

lex_and_parse_epilogue:
     procedure (p_release_sel);

dcl  p_release_sel bit (1) aligned;

	if lex_and_parse_pointers.token_list_ptr ^= null () then
	     if baseno (lex_and_parse_pointers.token_list_ptr) ^= baseno (stackframeptr ()) then
		free token_list in (system_area);

	if lex_and_parse_pointers.unquoted_text_ptr ^= null () then
	     if baseno (lex_and_parse_pointers.unquoted_text_ptr) ^= baseno (stackframeptr ()) then
		free unquoted_text in (system_area);

	if lex_and_parse_pointers.host_indeces_ptr ^= null () then
	     if baseno (lex_and_parse_pointers.host_indeces_ptr) ^= baseno (stackframeptr ()) then
		free host_indeces in (system_area);

	if lex_and_parse_pointers.address_string_ptr ^= null () then
	     if baseno (lex_and_parse_pointers.address_string_ptr) ^= baseno (stackframeptr ()) then
		free address_string in (system_area);
	if lex_and_parse_pointers.address_name_ptr ^= null () then
	     if baseno (lex_and_parse_pointers.address_name_ptr) ^= baseno (stackframeptr ()) then
		free address_name in (system_area);
	if lex_and_parse_pointers.address_comment_ptr ^= null () then
	     if baseno (lex_and_parse_pointers.address_comment_ptr) ^= baseno (stackframeptr ()) then
		free address_comment in (system_area);

	lex_and_parse_pointers.all_but_sel_ptr = null (); /* don't free the above more than once */

	if p_release_sel & (lex_and_parse_pointers.sel_ptr ^= null ()) then do;
	     if baseno (lex_and_parse_pointers.sel_ptr) ^= baseno (stackframeptr ()) then free sel in (system_area);
	     lex_and_parse_pointers.sel_ptr = null ();	/* caller doesn't want to use the list */
	end;

	return;

     end lex_and_parse_epilogue;
%page;
/* Lexical analysis */

lex_string:
     procedure (p_pto, p_ipo, p_code);

	return;					/* not an entrypoint */

dcl  1 p_pto aligned like parse_text_options parameter;
dcl  1 p_ipo aligned like internal_parse_options parameter;
dcl  p_code fixed binary (35) parameter;

dcl  remaining_text character (original_text_lth - text_used) unaligned based (addcharno (original_text_ptr, text_used));
dcl  text_used fixed binary (21);			/* amount of text already lex'ed */

dcl  unquoted_used fixed binary (21);			/* amount of workspace occupied by unquoting quoted strings */

dcl  use_date_time_breaks bit (1) aligned;		/* ON => use special breaks for date/time sequences */
dcl  save_comments bit (1) aligned;			/* ON => make tokens for any comments */
dcl  braces_special bit (1) aligned;			/* ON => treat braces as structured delimiters */

dcl  (original_start, unquoted_start, parenthesis_level, brace_level, idx) fixed binary (21);


/* Lexical analysis for address and address-list strings: the accepted delimiters are whitespace, comments, and the
   address break characters (",", ":", ";", "{", "}", "<", ">". and "@"); quoted strings are also recognized; braces are
   treated as balanced delimiters which may be nested; comments are placed in the token list to aid in the construction of
   the address's printed representation */

lex_address:
     entry (p_pto, p_ipo, p_code);

	use_date_time_breaks = "0"b;
	save_comments = "1"b;			/* comments are preserved for printed representations */
	braces_special = "1"b;			/* braces nest */
	go to LEXICAL_ANALYSIS_SETUP;


/* Lexical analysis for date/time strings: the accepted delimiters are whitespace, comments, ",", "-", "+", and ":";
   quoted strings are also recognized; comments are not placed in the token list, however */

lex_date_time:
     entry (p_pto, p_ipo, p_code);

	use_date_time_breaks = "1"b;			/* use special break characters */
	save_comments = "0"b;
	braces_special = "0"b;
	go to LEXICAL_ANALYSIS_SETUP;


/* Lexical analysis for message-id strings: the accepted delimiters are whitespace, comments, and the address breaks (see
   above); quoted strings are also recognized; comments are not placed in the token list, however */

lex_message_id:
     entry (p_pto, p_ipo, p_code);

	use_date_time_breaks = "0"b;			/* use the normal address break characters */
	save_comments = "0"b;
	braces_special = "0"b;
	go to LEXICAL_ANALYSIS_SETUP;


LEXICAL_ANALYSIS_SETUP:
	token_list.n_tokens_used = -1;		/* haven't found anything yet */

	call make_token (0, 0);			/* the start of text marker */
	token.type = START_OF_TEXT_TOKEN;
	token.token_ptr = addr (NL);
	token.token_lth = 0;

	unquoted_used = 0;
	text_used = 0;

	brace_level = 0;				/* at top level of the parse */

	do while (text_used < original_text_lth);	/* while there's something left */

	     idx = verify (remaining_text, WHITESPACE);	/* skip leading whitespace */

	     if idx = 0 then			/* end of the meaningfull text */
		text_used = original_text_lth;

	     else do;				/* something still there */

		text_used = text_used + idx - 1;	/* pass the whitespace, please */

		if substr (remaining_text, 1, 1) = OPEN_PAREN then call collect_comment ();
						/* start of a comment */

		else if substr (remaining_text, 1, 1) = CLOSE_PAREN then go to UNBALANCED_COMMENT_DELIMITERS;
						/* end of comment without a beginning */

		else if braces_special & (substr (remaining_text, 1, 1) = LEFT_BRACE) then do;
						/* another level of structured addresses */
		     brace_level = brace_level + 1;
		     call make_token ((text_used + 1), 1);
						/* make a token for it */
		     token.token_ptr = addr (substr (remaining_text, 1, 1));
		     token.token_lth = 1;
		     token.type = LEFTBRACE_TOKEN;
		     text_used = text_used + 1;	/* skip the open brace */
		end;

		else if braces_special & (substr (remaining_text, 1, 1) = RIGHT_BRACE) then
		     if brace_level = 0 then		/* end of structured address without a beginning */
			go to UNBALANCED_BRACES;
		     else do;			/* end of a level of structuring */
			brace_level = brace_level - 1;
			call make_token ((text_used + 1), 1);
			token.token_ptr = addr (substr (remaining_text, 1, 1));
			token.token_lth = 1;
			token.type = RIGHTBRACE_TOKEN;
			text_used = text_used + 1;
		     end;

		else if substr (remaining_text, 1, 1) = QUOTE then call collect_word ();
						/* a word starting with a quote */

		else				/* a word or a delimiter clearly follows ... */
		     if use_date_time_breaks then	/* date/time strings have strange break characters */
		     if index (DATE_TIME_BREAKS, substr (remaining_text, 1, 1)) ^= 0 then do;
						/* a date/time string delimiter: make a token */
			call make_token ((text_used + 1), 1);
			token.token_ptr = addr (substr (remaining_text, 1, 1));
			token.token_lth = 1;	/* by definition */
			token.type = index (DATE_TIME_BREAKS, substr (remaining_text, 1, 1));
			text_used = text_used + 1;	/* skip over it */
		     end;
		     else call collect_word ();	/* simple token */

		else				/* non-date/time string */
		     if (brace_level = 0) & (index (NORMAL_BREAKS, substr (remaining_text, 1, 1)) ^= 0) then do;
						/* a normal delimiter: make a token for it */
		     call make_token ((text_used + 1), 1);
		     token.token_ptr = addr (substr (remaining_text, 1, 1));
		     token.token_lth = 1;		/* by definition */
		     token.type = index (NORMAL_BREAKS, substr (remaining_text, 1, 1));
		     text_used = text_used + 1;	/* skip over it */
		end;

		else call collect_word ();		/* simple token */
	     end;
	end;

	if brace_level > 0 then			/* started a structured address and never finished it */
	     go to UNBALANCED_BRACES;


/* Lex is complete: add a final token to represent the end of the string */

	call make_token ((original_text_lth + 1), 0);	/* this token isn't really in the string at all */
	token.token_ptr = addr (NL);			/* need to point somewhere ... */
	token.token_lth = 0;			/* ... even though it doesn't comprise anything */
	token.type = END_OF_TEXT_TOKEN;		/* obviously */

	p_code = 0;				/* it parsed */

	return;


/* Control arrives at one of the following labels when some form of unbalanced delimiter is found in the string */

UNBALANCED_BRACES:
	p_code = mlsys_et_$unbalanced_braces;
	return;

UNBALANCED_COMMENT_DELIMITERS:
	p_code = mlsys_et_$unbalanced_parentheses;
	return;

UNBALANCED_QUOTES:
	p_code = mlsys_et_$unbalanced_quotes;
	return;
%page;
/* Internal to lex_string: add a new token to the token list */

make_token:
	procedure (p_original_start, p_original_lth);

dcl  p_original_start fixed binary (21) parameter;	/* where it starts in the input string */
dcl  p_original_lth fixed binary (21) parameter;		/* and how long it is */

	     token_list.n_tokens_used = token_list.n_tokens_used + 1;

	     token_ptr = addr (token_list.tokens (token_list.n_tokens_used));

	     token.original_start = p_original_start;
	     token.original_lth = p_original_lth;
	     string (token.flags) = ""b;		/* be nice to caller */

	     return;

	end make_token;



/* Internal to lex_string: collect the text which comprises a comment; ie: any text between balanced parentheses */

collect_comment:
	procedure ();

	     original_start = text_used + 1;		/* the supplied form starts at the ( */
	     unquoted_start = unquoted_used + 1;

	     parenthesis_level = 1;			/* in first level of parens */
	     text_used = text_used + 1;		/* and move past the starting ( */

	     do while ((parenthesis_level > 0) & (text_used < original_text_lth));

		if p_ipo.multics_format then
		     idx = search (remaining_text, QUOTE_PARENS_NL);
		else idx = search (remaining_text, BACKSLASH_PARENS_NL);
						/* find next delimiter */

		if idx = 0 then			/* doesn't terminate properly: punt */
		     go to UNBALANCED_COMMENT_DELIMITERS;

		if idx > 1 then do;			/* something to put into the comment */
		     substr (unquoted_text, (unquoted_used + 1), (idx - 1)) = substr (remaining_text, 1, (idx - 1));
		     unquoted_used = unquoted_used + idx - 1;
		     text_used = text_used + idx - 1;	/* skip to the "delimiter" */
		end;

		if substr (remaining_text, 1, 1) = OPEN_PAREN then do;
						/* nested parens (sigh) */
		     substr (unquoted_text, (unquoted_used + 1), 1) = OPEN_PAREN;
						/* include it */
		     unquoted_used = unquoted_used + 1;
		     text_used = text_used + 1;
		     parenthesis_level = parenthesis_level + 1;
						/* need another ) now */
		end;

		else if substr (remaining_text, 1, 1) = CLOSE_PAREN then do;
						/* end of comment (or a nesting) */
		     if parenthesis_level > 1 then do;	/* nested ): put it into comment text */
			substr (unquoted_text, (unquoted_used + 1), 1) = CLOSE_PAREN;
			unquoted_used = unquoted_used + 1;
		     end;
		     text_used = text_used + 1;	/* move on by */
		     parenthesis_level = parenthesis_level - 1;
		end;

		else if substr (remaining_text, 1, 1) = NL then do;
						/* newline: must be followed by whitespace (folding) */
NEWLINE_EMBEDDED_IN_COMMENT_TEXT:
		     substr (unquoted_text, (unquoted_used + 1), 1) = NL;
						/* add the newline */
		     unquoted_used = unquoted_used + 1;
		     text_used = text_used + 1;	/* skip past the newline */
		     if text_used = original_text_lth then go to UNBALANCED_COMMENT_DELIMITERS;
		     idx = verify (remaining_text, HTSP);
						/* try to skip past whitespace */
		     if (idx = 0) | (idx = 1) then	/* all whitespace (no close paren) or no ... */
			go to UNBALANCED_COMMENT_DELIMITERS;
						/* ... whitespace after newline */
		     text_used = text_used + idx - 1;	/* move over the whitespace */
		end;

		else if substr (remaining_text, 1, 1) = BACKSLASH then do;
						/* one character is quoted */
		     text_used = text_used + 1;	/* past the \ */
		     if text_used = original_text_lth then go to UNBALANCED_COMMENT_DELIMITERS;
		     if substr (remaining_text, 1, 1) = NL then
						/* special case newlines */
			go to NEWLINE_EMBEDDED_IN_COMMENT_TEXT;
		     substr (unquoted_text, (unquoted_used + 1), 1) = substr (remaining_text, 1, 1);
		     unquoted_used = unquoted_used + 1;
		     text_used = text_used + 1;	/* past the quoted character */
		end;

		else call collect_quoted_piece ();	/* must be a quote: start of a quoted string in the comment */
	     end;

	     if parenthesis_level > 0 then		/* comment never ended */
		go to UNBALANCED_COMMENT_DELIMITERS;

	     if save_comments then do;		/* caller wants comments made into tokens */
		call make_token (original_start, (text_used - original_start + 1));
		token.token_ptr = addr (substr (unquoted_text, unquoted_start, 1));
		token.token_lth = unquoted_used - unquoted_start + 1;
		token.type = COMMENT_TOKEN;
		if p_ipo.no_copy then
		     begin;			/* try to use original if possible */
dcl  the_original_text character (token.original_lth) unaligned defined (original_text) position (token.original_start);
dcl  the_unquoted_text character (token.token_lth) unaligned based (token.token_ptr);
		     if the_unquoted_text = the_original_text then do;
			unquoted_used = unquoted_start - 1;
			token.token_ptr = addr (the_original_text);
			token.token_lth = length (the_original_text);
			token.in_unquoted = "0"b;
		     end;
		     else token.in_unquoted = "1"b;
		end;
		else token.in_unquoted = "1"b;	/* not the original text */
	     end;

	     else unquoted_used = unquoted_start - 1;	/* don't save the comment anywhere */

	     return;

	end collect_comment;



/* format: off */
/* Internal to lex_string: collect the text which comprises a single word; a word is composed of one or more pieces of
   juxtaposed text, some of which may be quoted strings.  EG:
		foo"bar bar"mumble
   is a single word */
/* format: on */

collect_word:
	procedure ();

dcl  (in_unquoted, done) bit (1) aligned;

	     unquoted_start = unquoted_used + 1;	/* might need this */
	     in_unquoted = "0"b;			/* but it starts out using caller's text */

	     original_start = text_used + 1;		/* starts at the first character */

	     done = "0"b;				/* have some work to do */

	     do while (^done & (text_used < original_text_lth));

		if use_date_time_breaks then		/* find the end of this piece */
		     if p_ipo.multics_format then
			idx = search (remaining_text, DATE_TIME_DELIMITERS);
		     else idx = search (remaining_text, DATE_TIME_RFC822_DELIMITERS);
		else if brace_level = 0 then		/* parsing at top level */
		     if p_ipo.multics_format then
			idx = search (remaining_text, NORMAL_DELIMITERS);
		     else idx = search (remaining_text, NORMAL_RFC822_DELIMITERS);
		else				/* in the middle of a structred address */
		     if p_ipo.multics_format then idx = search (remaining_text, STRUCTURED_DELIMITERS);
		else idx = search (remaining_text, STRUCTURED_RFC822_DELIMITERS);
		if idx = 0 then			/* rest of the input is this word ... */
		     idx = original_text_lth - text_used + 1;
						/* ... so it's delimited by something over the edge */

		if idx > 1 then do;			/* something before the delimiter */
		     if in_unquoted then do;		/* must copy it over */
			substr (unquoted_text, (unquoted_used + 1), (idx - 1)) =
			     substr (remaining_text, 1, (idx - 1));
			unquoted_used = unquoted_used + idx - 1;
		     end;
		     text_used = text_used + idx - 1;
		end;

		if text_used = original_text_lth then done = "1"b;
						/* used up the remainder of the string */

		else if ^p_ipo.multics_format & (substr (remaining_text, 1, 1) = BACKSLASH) then do;
						/* RFC822 escapes the next character */
		     if ^in_unquoted then call make_unquoted ();
						/* must copy the original now */
		     text_used = text_used + 1;	/* skip the escape character */
		     if text_used = original_text_lth then go to UNBALANCED_QUOTES;
		     substr (unquoted_text, (unquoted_used + 1), 1) = substr (remaining_text, 1, 1);
		     unquoted_used = unquoted_used + 1;
		     if substr (remaining_text, 1, 1) = NL then do;
						/* quoted char is a newline: insure proper folding */
			text_used = text_used + 1;	/* ... go past it */
			idx = verify (remaining_text, HTSP);
						/* skip leading whitespace: it doesn't count */
			if (idx = 0) | (idx = 1) then /* no whitespace or all whitespace */
			     go to UNBALANCED_QUOTES;
			text_used = text_used + idx - 1;
		     end;
		end;

		else if substr (remaining_text, 1, 1) = QUOTE then do;
						/* a piece of quoted text in the middle */
		     if ^in_unquoted then call make_unquoted ();
		     call collect_quoted_piece ();
		end;

		else done = "1"b;			/* something which terminates the word */
	     end;

	     if text_used > original_text_lth then	/* normalize me please */
		text_used = original_text_lth;

	     call make_token (original_start, (text_used - original_start + 1));

	     if in_unquoted then do;			/* had to copy the text */
		token.token_ptr = addr (substr (unquoted_text, unquoted_start, 1));
		token.token_lth = unquoted_used - unquoted_start + 1;
	     end;
	     else do;				/* text stayed in the original */
		token.token_ptr = addcharno (original_text_ptr, (original_start - 1));
		token.token_lth = text_used - original_start + 1;
	     end;

	     token.type = WORD_TOKEN;
	     token.in_unquoted = in_unquoted;

	     if ^token.in_unquoted & (token.token_lth = 2) & ^use_date_time_breaks then
		if translate (substr (original_text, token.original_start, 2), UPPERCASE, LOWERCASE) = "AT" then do;
						/* special case "host" delimiter */
		     token.type = AT_TOKEN;
		     token.in_unquoted = "1"b;	/* flags it as ordinary text for later */
		end;

	     if ^token.in_unquoted & (token.token_lth = 3) & ^use_date_time_breaks then
		if translate (substr (original_text, token.original_start, 3), UPPERCASE, LOWERCASE) = "VIA" then do;
		     token.type = AT_TOKEN;
		     token.in_unquoted = "1"b;
		end;

	     return;



/* Internal to collect_word: place what exists so far into the unquoted area */

make_unquoted:
	     procedure ();

		in_unquoted = "1"b;

		substr (unquoted_text, (unquoted_used + 1), (text_used - original_start + 1)) =
		     substr (original_text, original_start, (text_used - original_start + 1));

		unquoted_used = unquoted_used + text_used - original_start + 1;

		return;

	     end make_unquoted;

	end collect_word;



/* Internal to lex_string: gather a piece of quoted text and add it to the current token */

collect_quoted_piece:
	procedure ();

dcl  done bit (1) aligned;

	     done = "0"b;				/* haven't reached the end of the string */

	     text_used = text_used + 1;		/* skip the leading quote */

	     do while (^done & (text_used < original_text_lth));

		if p_ipo.multics_format then
		     idx = search (remaining_text, QUOTE_NL);
		else idx = search (remaining_text, BACKSLASH_QUOTE_NL);
						/* find the end or a quoted character */

		if idx = 0 then			/* quoted string never terminates */
		     go to UNBALANCED_QUOTES;

		if idx > 1 then do;			/* some ordinary text to gather in */
		     substr (unquoted_text, (unquoted_used + 1), (idx - 1)) = substr (remaining_text, 1, (idx - 1));
		     unquoted_used = unquoted_used + idx - 1;
		     text_used = text_used + idx - 1;	/* past the good stuff */
		end;

		if substr (remaining_text, 1, 1) = NL then do;
						/* newline: must ensure proper folding */
NEWLINE_EMBEDDED_IN_QUOTED_STRING:
		     substr (unquoted_text, (unquoted_used + 1), 1) = NL;
						/* add it to the string */
		     unquoted_used = unquoted_used + 1;
		     text_used = text_used + 1;	/* past the newline */
		     if text_used = original_text_lth then go to UNBALANCED_QUOTES;
		     idx = verify (remaining_text, HTSP);
						/* leading space on next line is ignored */
		     if (idx = 0) | (idx = 1) then	/* no whitespace or all whitespace ... */
			go to UNBALANCED_QUOTES;
		     text_used = text_used + idx - 1;
		end;

		else if substr (remaining_text, 1, 1) = BACKSLASH then do;
						/* RFC822 convention for an escaped character */
		     text_used = text_used + 1;
		     if text_used = original_text_lth then go to UNBALANCED_QUOTES;
		     if substr (remaining_text, 1, 1) = NL then
						/* newline is special cased */
			go to NEWLINE_EMBEDDED_IN_QUOTED_STRING;
		     substr (unquoted_text, (unquoted_used + 1), 1) = substr (remaining_text, 1, 1);
		     unquoted_used = unquoted_used + 1;
		     text_used = text_used + 1;
		end;

		else if ^p_ipo.multics_format then do;	/* end of an RFC822 quoted string */
		     text_used = text_used + 1;	/* ... past the last quote in the string */
		     done = "1"b;
		end;

		else do;				/* normal quoted string */
		     text_used = text_used + 1;	/* past the quote */
		     if text_used = original_text_lth then done = "1"b;
						/* end of the input: quoted string terminated OK */
		     else if substr (remaining_text, 1, 1) = QUOTE then do;
						/* a literal quote is part of the string */
			substr (unquoted_text, (unquoted_used + 1), 1) = QUOTE;
			unquoted_used = unquoted_used + 1;
			text_used = text_used + 1;	/* past the second quote */
		     end;
		     else done = "1"b;		/* end of the quoted piece */
		end;
	     end;

	     if ^done then				/* ran off the end */
		go to UNBALANCED_QUOTES;

	     return;

	end collect_quoted_piece;

     end lex_string;
%page;
/* Move to the next token (including comments) in the string: do not move past the end-of-text token, however */

next_token:
     procedure ();

	if token_idx = token_list.n_tokens_used then return;
						/* at the last token */

	token_idx = token_idx + 1;			/* to the next one please */

	current_token_ptr = addr (token_list.tokens (token_idx));

	return;

     end next_token;



/* Move to the next token in the string: do not move past the end-of-text token and ignore comment tokens */

next_real_token:
     procedure ();

	if token_idx = token_list.n_tokens_used then return;
						/* at the last token */

	token_idx = token_idx + 1;			/* to the next one please */
	current_token_ptr = addr (token_list.tokens (token_idx));

	do while (current.type = COMMENT_TOKEN);	/* ignore comments */
	     token_idx = token_idx + 1;
	     current_token_ptr = addr (token_list.tokens (token_idx));
	end;

	return;

     end next_real_token;



/* Make the specified token be the current token */

make_token_current:
     procedure (p_token_idx);

dcl  p_token_idx fixed binary (21) parameter;

	token_idx = min (token_list.n_tokens_used, max (p_token_idx, lbound (token_list.tokens, 1)));
						/* make it a valid index */

	current_token_ptr = addr (token_list.tokens (token_idx));

	return;

     end make_token_current;
%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;



/* Compare two date/times to see if the first occurred before the second */

date_time_before:
     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 ((p_date_time_1 < p_date_time_2) & ^date_time_equal (p_date_time_1, p_date_time_2));

     end date_time_before;
%page;
%include mlsys_parse_txt_options;
%page;
%include mlsys_data;
%page;
%include mlsys_internal_data;
%page;
%include mlsys_address_types;
%page;
%include mlsys_field_types;
%page;
%include mlsys_field_names;
%page;
%include mlsys_message;
%page;
%include mlsys_address_route;
%page;
%include mlsys_address_list;
%page;
%include sl_info;

%include sl_control_s;
%page;
%include time_names;
%page;
%include mlsys_special_chars;

     end mlsys_parse_text_;




		    mlsys_psp_.pl1                  06/30/86  1410.4rew 06/30/86  1341.9       70416



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



/****^  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):
     This adds the entry point mlsys_psp_$domains_available.  This returns a
     "1"b is they are, ""b if not.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Determines which PSPs/RPQs used by the mail system are available at the site */

/* Created:  December 1983 by G. Palter */
/* Modified: March 1984 by G. Palter to fix mail system error #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_psp_:
     procedure () returns (bit (1) aligned);

          return ("0"b);                                    /* not an entrypoint */


/* Declarations */

dcl  psp_entry entry () options (variable) variable;

dcl  local_host character (40) varying;
dcl  forum_gate_brackets (3) fixed binary (3);

dcl  code fixed binary (35);

dcl  MAIL_SYSTEM_ character (32) static options (constant) initial ("mail_system_");

dcl  nit_data_$local_host character (40) varying external;

/* format: off */
dcl (forum_error_table_$meeting_bloat, forum_error_table_$no_such_forum, forum_error_table_$not_eligible,
     forum_error_table_$not_in_search_list, forum_error_table_$read_only, forum_error_table_$rqo)
          fixed binary (35) external;
/* format: on */

dcl  forum_$close_forum entry (fixed binary, fixed binary (35));
dcl  forum_$enter_trans
          entry (fixed binary, character (*), fixed binary, character (*), bit (1) aligned, fixed binary,
          fixed binary (35));
dcl  forum_$get_forum_path entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  forum_$open_forum entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  forum_$real_forum_limits
          entry (fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, bit (36) aligned,
          fixed binary (35));
dcl  get_ring_ entry () returns (fixed binary (3));
dcl  hcs_$fs_get_brackets entry (pointer, fixed binary (5), (3) fixed binary (3), fixed binary (35));
dcl  host_name_$local_compare entry (char (256), char (256), fixed bin (35)) returns (bit (1));
dcl  host_name_$qualify_local entry (char (256), fixed bin (35)) returns (char (256));
dcl  host_name_$local_valid_destination entry (char (256), fixed bin (35)) returns (bit (1));
dcl  mlsys_mailer_ entry (pointer, pointer, fixed binary (21));
dcl  sub_err_ entry () options (variable);

dcl  linkage_error condition;

dcl  (codeptr, null) builtin;
%page;
/* Determine if the site has purchased the TCP/IP and/or Hyperchannel RPQs which provide a prototype Network Information
   Table (NIT) and an interim Inter-System Mailer */

ism_not_available:
     entry () returns (bit (1) aligned);

          if mlsys_data_$ism_not_available = 0 then do;

               /*** First time in this process and ring: actually check for the mailer's existence */

               mlsys_data_$ism_not_available = -1;          /* until proven otherwise ... */

               on condition (linkage_error)
                    begin;                                  /* ... where otherwise is when this handler is invoked */
                         mlsys_data_$ism_not_available = 1;
                         go to RETURN_FROM_ISM_NOT_AVAILABLE;
                    end;

               psp_entry = host_table_mgr_$primary_name;    /* try to snap the links to all entrypoints we use ... */
               psp_entry = mlsys_mailer_;
               psp_entry = nit_$get_forwarding_host;
               psp_entry = nit_$get_service_list;

               local_host = nit_data_$local_host;           /* ... and the single external constant */
          end;

RETURN_FROM_ISM_NOT_AVAILABLE:
          return (mlsys_data_$ism_not_available = 1);
%page;
/* Determine if the site has the domain name system software installed. */

domains_available:
     entry () returns (bit (1) aligned);

          if mlsys_data_$domains_available = 0 then do;

               /*** First time in this process and ring: actually check for the domain system's existence */

               mlsys_data_$domains_available = 1;           /* until proven otherwise... */

               on condition (linkage_error)
                    begin;
                         mlsys_data_$domains_available = -1;
                         go to RETURN_FROM_DOMAINS_AVAILABLE;
                    end;

               psp_entry = host_name_$local_compare;        /* try to snap the links to all entrypoints we use ... */
               psp_entry = host_name_$qualify_local;
               psp_entry = host_name_$local_valid_destination;
          end;

RETURN_FROM_DOMAINS_AVAILABLE:
          return (mlsys_data_$domains_available = 1);
%page;
/* Determine if the site has purchased forum and, if available, the lowest ring in which it may be used */

forum_not_available:
     entry () returns (bit (1) aligned);

          if mlsys_data_$forum_not_available = 0 then do;

               /*** First time in this process and ring: actually check for Forum's existence */

               mlsys_data_$forum_not_available = -1;        /* until proven otherwise ... */

               on condition (linkage_error)
                    begin;                                  /* ... where otherwise is when this handler is invoked */
                         mlsys_data_$forum_not_available = 1;
                         go to RETURN_FROM_FORUM_NOT_AVAILABLE;
                    end;

               do psp_entry =                               /* snap the links to all forum entrypoints ... */
                    forum_$close_forum, forum_$enter_trans, forum_$get_forum_path, forum_$open_forum,
                    forum_$real_forum_limits;
               end;

               do code =                                    /* ... and all forum error codes */
                    forum_error_table_$meeting_bloat, forum_error_table_$no_such_forum, forum_error_table_$not_eligible,
                    forum_error_table_$not_in_search_list, forum_error_table_$read_only, forum_error_table_$rqo;
               end;

               revert condition (linkage_error);            /* here iff the site has forum */

               call hcs_$fs_get_brackets (codeptr (forum_$open_forum), (0), forum_gate_brackets, code);
               if code ^= 0 then do;
RESIGNAL_GET_RING_BRACKETS_FAILURE:
                    call sub_err_ (code, MAIL_SYSTEM_, ACTION_CANT_RESTART, null (), (0),
                         "Unable to determine the ring brackets on the forum_ gate.^/Contact your system programming staff."
                         );
                    go to RESIGNAL_GET_RING_BRACKETS_FAILURE;
               end;

               mlsys_data_$lowest_forum_ring = forum_gate_brackets (1);

               if get_ring_ () < mlsys_data_$lowest_forum_ring then mlsys_data_$forum_not_available = 1;
                                                            /* can't use forum in this ring: act like it's not present */
          end;

RETURN_FROM_FORUM_NOT_AVAILABLE:
          return (mlsys_data_$forum_not_available = 1);
%page;
%include mlsys_internal_data;
%page;
%include host_table_dcls;
%page;
%include sub_err_flags;

     end mlsys_psp_;




		    mlsys_search_list_default_.cds  07/26/88  1017.7rew 07/26/88  1013.4       27531



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



/* HISTORY COMMENTS:
  1) change(88-04-13,Blair), approve(88-04-13,MCR7842),
     audit(88-06-29,Lippard), install(88-07-26,MR12.2-1069):
     Add -hd to the mlsys search list after -wd for SCP 6349.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Creates the default search list for the Multics mail system:  This data segment is intended to be bound into
   bound_mail_system_ and, therefore, does not add the search list names to itself */

/* Created:  April 1982 by G. Palter from search_list_defaults_ */

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


mlsys_search_list_default_:
     procedure () options (variable);


dcl  1 cdsa aligned like cds_args;

dcl  1 list aligned,
       2 mlsys bit (0) unaligned,			/* the mail_system search list */
       2 mail_system,
         3 name_count fixed binary,
         3 path_count fixed binary,
         3 names (2) character (32),
         3 paths (3) like search_path;

dcl  1 search_path based,				/* a single search path */
       2 type fixed binary,
       2 pathname character (168);

dcl  code fixed binary (35);

dcl  MLSYS_SEARCH_LIST_DEFAULT_ character (32) static options (constant) initial ("mlsys_search_list_default_");

dcl  com_err_ entry () options (variable);
dcl  create_data_segment_ entry (pointer, fixed binary (35));

dcl  (addr, currentsize, hbound, null, unspec) builtin;
%page;
/* Setup the definition of the search list */

	list.mail_system.name_count = hbound (list.mail_system.names, 1);
	list.mail_system.path_count = hbound (list.mail_system.paths, 1);
	list.mail_system.names (1) = "mail_system";
	list.mail_system.names (2) = "mlsys";
	list.mail_system.paths (1).type = WORKING_DIR;
	list.mail_system.paths (1).pathname = "-working_dir";
	list.mail_system.paths (2).type = HOME_DIR;
          list.mail_system.paths (2).pathname = "-home_dir";
	list.mail_system.paths (3).type = UNEXPANDED_PATH;
	list.mail_system.paths (3).pathname = ">udd>[user project]>[user name]>[user name].mlsys";


/* Create the data segment */

	unspec (cdsa) = ""b;
	cdsa.sections (1).p = addr (list);
	cdsa.sections (1).len = currentsize (list);
	cdsa.sections (1).struct_name = "list";
	cdsa.sections (2).p = null ();
	cdsa.sections (2).struct_name = "";
	cdsa.seg_name = MLSYS_SEARCH_LIST_DEFAULT_;
	cdsa.exclude_array_ptr = null ();
	cdsa.switches.have_text = "1"b;

	call create_data_segment_ (addr (cdsa), code);
	if code ^= 0 then call com_err_ (code, MLSYS_SEARCH_LIST_DEFAULT_);

	return;
%page;
%include sl_info;
%page;
%include cds_args;

     end mlsys_search_list_default_;




		    mlsys_storage_mgr_.pl1          03/15/89  0849.4rew 03/15/89  0759.4       99450



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



/****^  HISTORY COMMENTS:
  1) change(89-03-07,TLNguyen), approve(89-03-07,MCR8049),
     audit(89-03-07,Parisek), install(89-03-15,MR12.3-1025):
     Initialize local_cbi structure using the unspec builtin function.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Area and temporary segment manager for the inner-ring portion of the Multics Mail System */

/* Created:  July 1983 by G. Palter */
/* Modified: December 1984 by Keith Loepere for version 2 create_branch_info. */
/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


mlsys_storage_mgr_:
     procedure ();

	return;					/* not an entrypoint */


/* Control arrives here when errors are detected in code which has lowered the validation level */

RESTORE_LEVEL_AND_RETURN_WITH_ERROR:
	call cu_$level_set (old_validation_level);
	P_code = code;
	return;


/* allocate Parameters */

dcl  P_n_words fixed binary (18) parameter;		/* # of words in the block to be allocated */
dcl  P_area_ptr pointer parameter;			/* -> area in which to allocate the block */
dcl  P_allocation_ptr pointer parameter;		/* set -> the block allocated */


/* get_temp_segment/release_temp_segment Parameters */

dcl  P_segment_ptr pointer parameter;			/* get_temp_segment: set -> the segment just created;
						   release_temp_segment: -> the segment to be released */
dcl  P_code fixed binary (35) parameter;


/* Local copies of parameters */

dcl  requested_space (P_n_words) bit (36) aligned based (P_allocation_ptr);
dcl  callers_area area based (P_area_ptr);

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


/* List of temporary segments created by the mail system:  Only the UID of each segment is maintained as it is all that is
   needed to vaildate that a segment to be released was, indeed, created by this manager */

dcl  1 temp_segment_list aligned based (mlsys_data_$temp_segment_list_ptr),
       2 n_uids fixed binary,				/* # of UID slots */
       2 uids (temp_segment_list_n_uids refer (temp_segment_list.n_uids)) bit (36) aligned;
						/* the actual UIDs: a value of ""b indicates an unused slot */

dcl  temp_segment_list_n_uids fixed binary;		/* for allocating the above */


/* Remaining declarations */

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  1 local_ai aligned like area_info;

dcl  1 local_cbi aligned like create_branch_info;

dcl  old_validation_level fixed binary (3);

dcl  dirname character (168);
dcl  ename character (32);
dcl  segment_uid bit (36) aligned;
dcl  found bit (1) aligned;
dcl  list_idx fixed binary;

dcl  MAIL_SYSTEM_ character (32) static options (constant) initial ("mail_system_");

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl  mlsys_et_$not_temporary_segment fixed binary (35) 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_group_id_$tag_star entry () returns (character (32));
dcl  get_pdir_ entry () returns (character (168));
dcl  get_ring_ entry () returns (fixed binary (3));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$create_branch_ entry (character (*), character (*), pointer, fixed binary (35));
dcl  hcs_$get_uid_seg entry (pointer, bit (36) aligned, fixed binary (35));
dcl  initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl  sub_err_ entry () options (variable);
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl  unique_chars_ entry (bit (*)) returns (character (15));

dcl  cleanup condition;

dcl  (addr, baseno, binary, null, string, unspec) builtin;
%page;
/* Per-process initialization: creates the mail system's extensible area with appropriate ring brackets */

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_ ());

	system_area_ptr = get_system_free_area_ ();

	temp_segment_list_n_uids = 32;		/* probably will never have this many at a time, but ... */
	allocate temp_segment_list in (system_area) set (mlsys_data_$temp_segment_list_ptr);
	unspec (temp_segment_list.uids) = ""b;

	string (mlsys_data_$valid_segments) = ""b;	/* nothing has been allocated anywhere yet */

	call get_temp_segment (mlsys_data_$subsystem_area_ptr, code);
	if code ^= 0 then do;			/* grumble: impossible to initialize the mail system ... */
RESIGNAL_INITIALIZATION_FAILURE:
	     call sub_err_ (code, MAIL_SYSTEM_, ACTION_CANT_RESTART, null (), (0),
		"Unable to initialize the mail system storage manager.^/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 ... */
	local_ai.zero_on_free = "1"b;			/* ... which is "reset" on each freeing operation ... */
	local_ai.system = "1"b;			/* ... and should be extended with ring bracket copying */
	local_ai.owner = MAIL_SYSTEM_;
	local_ai.size = sys_info$max_seg_size;
	local_ai.areap = mlsys_data_$subsystem_area_ptr;

	call define_area_ (addr (local_ai), code);
	if code ^= 0 then go to RESIGNAL_INITIALIZATION_FAILURE;

	call cu_$level_set (old_validation_level);

	return;
%page;
/* Allocates a block of storage: replaces the standard PL/I allocate operator for all mail system inner-ring code through
   use of the "options (rename ((alloc_, mlsys_storage_mgr_$allocate)))" clause.  In order to bypass a "bug" in the
   treatment of extensible areas, this entrypoint will set the proper validation level before actually allocating the
   requested storage.  In addition, this entrypoint remembers maintains a list of the segments in which it has performed
   an allocation; this list is used by the remainder of the mail system to verify that a pointer supplied by the user-ring
   is "valid" */

allocate:
     entry (P_n_words, P_area_ptr, P_allocation_ptr);

	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_ ());

	allocate requested_space in (callers_area) set (P_allocation_ptr);

	mlsys_data_$valid_segments (binary (baseno (P_allocation_ptr), 18, 0)) = "1"b;

	call cu_$level_set (old_validation_level);

	return;
%page;
/* Fetches a temporary segment and insures that its contents are accesible from the user-ring */

get_temp_segment:
     entry (P_segment_ptr, P_code);

          unspec (local_cbi) = ""b;

	local_cbi.version = create_branch_version_2;
	local_cbi.parent_ac_sw = "1"b;
	local_cbi.mode = RW_ACCESS;
	local_cbi.rings (1) = get_ring_ ();		/* writable only to the mail system ... */
	local_cbi.rings (2),			/* ... but readable in appropriate outer rings */
	     local_cbi.rings (3) = mlsys_data_$highest_usable_ring;
	local_cbi.userid = get_group_id_$tag_star ();

	dirname = get_pdir_ ();
	ename = unique_chars_ (""b) || ".temp.mail_system";

	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 hcs_$create_branch_ (dirname, ename, addr (local_cbi), code);
	if code ^= 0 then go to RESTORE_LEVEL_AND_RETURN_WITH_ERROR;

	call initiate_file_ (dirname, ename, RW_ACCESS, segment_ptr, (0), code);
	if code ^= 0 then go to RESTORE_LEVEL_AND_RETURN_WITH_ERROR;

	call hcs_$get_uid_seg (segment_ptr, segment_uid, code);
	if code ^= 0 then go to RESTORE_LEVEL_AND_RETURN_WITH_ERROR;

	list_idx = find_empty_temp_segment_list_slot ();	/* will grow the list if necessary */

	temp_segment_list.uids (list_idx) = segment_uid;	/* needed to validate subsequent attempts to release it */

	call cu_$level_set (old_validation_level);

	mlsys_data_$valid_segments (binary (baseno (segment_ptr), 18, 0)) = "1"b;

	P_segment_ptr = segment_ptr;			/* success */
	P_code = 0;

	return;
%page;
/* Releases a temporary segment obtained by a call to the above get_temp_segment entrypoint */

release_temp_segment:
     entry (P_segment_ptr, P_code);

	segment_ptr = P_segment_ptr;			/* copy parameters */
	P_segment_ptr = null ();			/* so the caller won't try twice */

	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 hcs_$get_uid_seg (segment_ptr, segment_uid, code);
	if code ^= 0 then go to RESTORE_LEVEL_AND_RETURN_WITH_ERROR;

	found = "0"b;				/* check that we created this segment */
	do list_idx = 1 to temp_segment_list.n_uids while (^found);
	     if segment_uid = temp_segment_list.uids (list_idx) then do;
		temp_segment_list.uids (list_idx) = ""b;/* ... we did create it: remove it from our list now */
		found = "1"b;
	     end;
	end;

	if ^found then do;				/* not one of our temporary segments */
	     code = mlsys_et_$not_temporary_segment;
	     go to RESTORE_LEVEL_AND_RETURN_WITH_ERROR;
	end;

	call terminate_file_ (segment_ptr, 0, TERM_FILE_DELETE, code);
	if code ^= 0 then go to RESTORE_LEVEL_AND_RETURN_WITH_ERROR;

	call cu_$level_set (old_validation_level);

	P_code = 0;				/* success */

	return;
%page;
/* Finds an unused slot in the list of temporary segments managed by the mail system */

find_empty_temp_segment_list_slot:
     procedure () returns (fixed binary);

dcl  (new_temp_segment_list_ptr, old_temp_segment_list_ptr) pointer;
dcl  idx fixed binary;

	do idx = 1 to temp_segment_list.n_uids;
	     if temp_segment_list.uids (idx) = ""b then return (idx);
	end;

	/*** here iff there are no free slots: grow the list */

	system_area_ptr = get_system_free_area_ ();

	temp_segment_list_n_uids = 2 * temp_segment_list.n_uids;
	allocate temp_segment_list in (system_area) set (new_temp_segment_list_ptr);

	unspec (new_temp_segment_list_ptr -> temp_segment_list.uids) = ""b;

	do idx = 1 to temp_segment_list.n_uids;		/* copy in the old values */
	     new_temp_segment_list_ptr -> temp_segment_list.uids (idx) = temp_segment_list.uids (idx);
	end;
	idx = temp_segment_list.n_uids + 1;		/* first free slot */

	old_temp_segment_list_ptr = mlsys_data_$temp_segment_list_ptr;
	mlsys_data_$temp_segment_list_ptr = new_temp_segment_list_ptr;

	free old_temp_segment_list_ptr -> temp_segment_list;

	return (idx);

     end find_empty_temp_segment_list_slot;
%page;
%include mlsys_internal_data;
%page;
%include create_branch_info;
%page;
%include access_mode_values;

%include terminate_file;
%page;
%include area_info;
%page;
%include sub_err_flags;

     end mlsys_storage_mgr_;




		    mlsys_transmit_.pl1             09/24/92  2252.5r w 09/24/92  2236.6     1270557



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



/****^  HISTORY COMMENTS:
  1) change(86-06-03,Herbst), approve(86-06-03,MCR7432), audit(86-06-30,Wong),
     install(86-06-30,MR12.0-1080):
     Fixed to zero unused fields of mail_format structures.
  2) change(89-08-11,Lee), approve(89-08-29,MCR8130),
     audit(89-09-25,LZimmerman), install(89-10-02,MR12.3-1079):
     phx18036 (Mail 450) - modified the deliver_message/redistribute_message
     entries to set mailing list delivery codes to indicate non-delivery
     rather than successful delivery if the delivery got aborted; reformatting.
  3) change(91-10-25,Schroth), approve(91-11-28,MECR0015),
     audit(91-11-25,WAAnderson), install(91-11-28,MR12.5-1001):
     Correct MR12.4 source code corruption.
  4) change(92-05-14,Schroth), approve(91-11-25,MCR8251),
     audit(92-09-22,WAAnderson), install(92-09-24,MR12.5-1016):
     Replace MECR0015: Correct MR12.4 source code corruption.
                                                   END HISTORY COMMENTS */


/* format: off */

/* Mail System Primitives which transmit a message to one or more recipients */

/* Created:  July 1981 by G. Palter */
/* Modified: 7 September 1982 by G. Palter to correctly reference error_table_$rqover and to fix the bug which causes
      validate_address to return mlsys_et_$no_mailbox rather than mlsys_et_$no_a_permission if you have null access on a
      mailbox */
/* Recoded:  August 1983 by G. Palter to convert to new specification which includes adding separate entrypoints for each
      of the transmission primitives (deliver, redistribute, copy, log, and save) */
/* Modified: September 1983 by G. Palter to use the interim inter-system mailer (mlsys_mailer_) */
/* Modified: March 1984 by G. Palter to fix the following mail system errors:
      #0419 -- when the queue_mailing_lists delivery option is used, the mail system will ignore any mailing lists
         specified rather than queuing the message for later delivery to said lists
      #0420 -- when processing mailing lists, the mail system does not translate error_table_$no_component into
         mlsys_et_$no_mailing_list
      #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
      #0438 -- the primitives which allow a user to replace the address list portions of a message
         (eg: mail_system_$replace_from, mail_system_$replace_user_field) should not make the user's copy of the address
         list read-only.  Instead, they should copy the user's list to allow the user to continue to modify the list if
         desired for later additional use */

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


mlsys_transmit_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_code fixed binary (35) parameter;

dcl  P_message_ptr pointer parameter;			/* deliver_message: -> the new message to be delivered;
						   redistribute_message: -> the in-mailbox message to be
						      redistributed (with optional comment);
						   copy_message, log_message, save_message: -> the
						      new/in-mailbox message to be copied/logged/saved */

dcl  P_recipients_info_ptr pointer parameter;		/* deliver_message, redistribute_message: -> the structure
						         containing the lists of recipients for this
						         operation; the results of the operation are also
						         conveyed through this structure */
dcl  P_deliver_options_ptr pointer parameter;		/* deliver_message, redistribute_message: -> the structure
						      defining the options which control this operation (eg:
						      delivery mode, queueing mode, etc.) */

dcl  P_redistribution_comment character (*) parameter;	/* redistribute_message: an optional comment to be added to
						      the message as it is redistributed */

dcl  P_address_lists (*) pointer parameter;		/* eliminate_duplicate_addrs_*: -> the address lists from
						      which all duplicate addresses are to be removed */

dcl  P_mailbox_dirname character (*) parameter;		/* copy_message, save_message: absolute pathname of directory
						      containing the target mailbox/savebox */
dcl  P_mailbox_ename character (*) parameter;		/* copy_message, save_message: entryname of the
						      mailbox/savebox; the caller need not supply the
						      appropriate suffix */

dcl  P_create_if_not_found bit (1) aligned parameter;	/* log_message, save_message: ON => try to create the
						      logbox/savebox if it doesn't exist */

dcl  P_address_ptr pointer parameter;			/* validate_address: -> the address to be validated */
dcl  P_validate_mls_contents bit (1) aligned parameter;	/* validate_address: ON => cvalidate the contents of any
						      mailing lists; OFF => simply validate the existence of
						      the mailing list */
/**** format: indcomtxt */


/* Local copies of parameters */

dcl  code fixed binary (35);

dcl  users_area area based (users_area_ptr);
dcl  users_area_ptr pointer;

dcl  mailbox_dirname character (168);
dcl  mailbox_ename character (32);
dcl  create_if_not_found bit (1) aligned;

/* Mail notification, allocated once */

dcl  notification_initialized_sw bit (1) int static init ("0"b);
dcl  1 NOTIFICATION_MAIL_FORMAT aligned like mail_format based (NOTIFICATION_MAIL_FORMAT_PTR);
dcl  NOTIFICATION_MAIL_FORMAT_PTR ptr int static init (null);
dcl  based_area area based (get_system_free_area_ ());
dcl  NOTIFICATION_TEXT char (14) int static options (constant) init ("You have mail.");

/* Definition of the saved message state */

dcl  added_from_field bit (1) aligned;			/* ON => we added an address to an empty From field */
dcl  added_reply_to_field bit (1) aligned;		/* ON => we added an address to an empty Reply-To field */
dcl  added_envelope bit (1) aligned;			/* ON => we added a envelope to the message */
dcl  added_redistribution bit (1) aligned;		/* ON => we added a redistribution to the message */

dcl  deleted_last_delivery_fields bit (1) aligned;	/* ON => we deleted the last Delivery-Date and ... */
dcl  last_date_time_delivered fixed binary (71);		/* ... Delivery-By fields from the message */
dcl  last_delivered_by pointer;

dcl  1 saved_message_data aligned,			/* data saved/restored directly from the message structure */
       2 flags like message.flags,
       2 header,
         3 message_id bit (72),
         3 access_class bit (72),
         3 date_time_created fixed binary (71),
         3 bcc pointer;


/* Definition of a single recipient of a message */

dcl  1 recipient aligned based (recipient_ptr),
       2 address_ptr pointer,				/* -> the actual address */
       2 type fixed binary,				/* type of recipient (mailbox/forum/network) */
       2 flags,
         3 top_level bit (1) unaligned,			/* ... ON => only recipient corresponding to an input addr */
         3 duplicate bit (1) unaligned,			/* ... ON => this recipient duplicates a previous entry */
         3 free_address bit (1) unaligned,		/* ... ON => free above address on cleanup */
         3 to_queue bit (1) unaligned,			/* ... ON => queue the message for this recipient */
         3 no_acknowledge bit (1) unaligned,		/* ... ON => don't ask this recipient for acknowledgement */
         3 use_copy_without_bcc bit (1) unaligned,	/* ... ON => ommit bcc field when sending to this recipient */
         3 fatal_error bit (1) unaligned,		/* ... ON => a fatal error was detected for this recipient */
         3 transient_error bit (1) unaligned,		/* ... ON => a transient error was detected */
         3 warning bit (1) unaligned,			/* ... ON => a warning is associated with this recipient */
         3 pad bit (27) unaligned,
       2 code fixed binary (35),			/* results of validation or transmission */
       2 explanation character (128) varying,		/* reason why message had to be queued */
       2 top_level_info,				/* identifies the input address that generated this ... */
         3 list_idx fixed binary,			/* ... recipient */
         3 address_idx fixed binary,
       2 duplicate_idx fixed binary,			/* identifies the recipient for which this is a duplicate */
       2 local_info,				/* used if the recipient is local */
         3 mailbox_idx fixed binary,			/* ... identifies the mailbox (if a mailbox recipient) */
         3 forum_idx fixed binary,			/* ... identifies the forum (if a forum recipient) */
       2 foreign_info,				/* used if the recipient is on another computer */
	/*** ... lengths of the following strings are the maximum accepted by the interim inter-system mailer */
         3 foreign_address character (128) varying,	/* ... actual foreign address to be given to mlsys_mailer_ */
         3 foreign_system character (40) varying;		/* ... actual foreign system to be given to mlsys_mailer_ */

dcl  recipient_ptr pointer;


/* Definition of the types of recipients */

/* format: off */
dcl (UNKNOWN_RECIPIENT	initial (0),		/* ... used for recipients with fatal errors */
     MAILBOX_RECIPIENT	initial (1),		/* ... to a mailbox */
     FORUM_RECIPIENT	initial (2),		/* ... to a forum meeting */
     NETWORK_RECIPIENT	initial (3))		/* ... to a recipient somewhere on the network */
	fixed binary static options (constant);
/* format: on */


/* List of all recipients for a delivery/redistribution operation */

dcl  1 recipients_list aligned based (recipients_list_ptr),
       2 recipients (n_recipients) like recipient;

dcl  ism_recipient_idxs (n_recipients) fixed binary based (ism_recipient_idxs_ptr);

dcl  (recipients_list_ptr, ism_recipient_idxs_ptr, initial_stack_extension, stack_truncation_ptr) pointer;
dcl  (n_recipients_allocated, n_recipients, n_unique_recipients, n_failed_recipients, recipient_idx) fixed binary;
dcl  recipient_size fixed binary;			/* size of a single recipient structure */


/* List of mailing lists currently being expanded */

dcl  1 mailing_list_data aligned based (mailing_list_data_ptr),
       2 mls_ptr pointer,				/* -> the actual mailing list */
       2 previous_data_ptr pointer;			/* -> the previous entry in the list */

dcl  (current_mailing_list_data_ptr, mailing_list_data_ptr) pointer;


/* Mailbox cache:  In order to improve the performance of callers of the log_message, save_message, and copy_message
   entrypoints, these entrypoints never actually close their target mailboxes.  Instead, they maintain a cache of the most
   recently used mailboxes in order to avoid the expense of opening/closing a mailbox.  Mailboxes are only closed by these
   entrypoints when the cache is full and a mailbox not in the cache is referenced */

dcl  1 transmit_cache aligned based (mlsys_data_$transmit_cache_ptr),
       2 entries (0:15),
         3 uid bit (36) aligned,			/* UID of the mailbox in this slot of the cache */
         3 index fixed binary,			/* ring-1 identifier of the mailbox */
         3 usage fixed binary,			/* used to find the least recently used entry in the cache */
         3 pad bit (36);


/* Remaining declarations */

dcl  1 local_mep aligned like message_envelope_parameter;
dcl  1 local_mrp aligned like message_redistribution_parameter;

dcl  1 result aligned based (result_ptr) like recipients_result_list.results;
dcl  result_ptr pointer;

dcl  1 user_privileges aligned,
       2 privileges unaligned like aim_template.privileges,
       2 pad bit (18) unaligned;

dcl  date_time_message_created fixed binary (71);

dcl  (suppress_bcc_field_when_necessary, make_copies_with_bcc, make_copies_without_bcc) bit (1) aligned;
dcl  (need_mailbox_message, need_forum_message, need_network_message) bit (1) aligned;

dcl  (never_transmitted, have_result_code, part_of_this_address, partially_delivered, partially_queued) bit (1) aligned;
dcl  delivery_aborted bit (1) aligned;			/* phx18036 RL: flag aborted deliveries */

dcl  message_buffers (6) pointer;			/* -> the possible local encodings of the message */
dcl  n_message_buffers_used fixed binary;

dcl  last_temp_segment_ptr pointer;			/* -> last temporary segment grabbed by this module */
dcl  last_temp_segment_used fixed binary (18);		/* # of words occupied in that segment */

dcl  (mailbox_message_with_bcc_ptr, mailbox_message_without_bcc_ptr, forum_message_with_bcc_ptr,
     forum_message_without_bcc_ptr, network_message_with_bcc_ptr, network_message_without_bcc_ptr) pointer;
dcl  (mailbox_message_with_bcc_lth, mailbox_message_without_bcc_lth) fixed binary (24);
dcl  (forum_message_with_bcc_lth, forum_message_without_bcc_lth, network_message_with_bcc_lth,
     network_message_without_bcc_lth) fixed binary (21);

dcl  (the_list_idx, the_address_idx, idx) fixed binary;

dcl  1 other_recipient aligned based (other_recipient_ptr) like recipient;
dcl  other_recipient_ptr pointer;
dcl  (delete_this_address, continue) bit (1) aligned;
dcl  (first_recipient_idx, other_recipient_idx) fixed binary;

dcl  (mailbox_idx, target_mailbox_idx, forum_idx) fixed binary;
dcl  mailbox_mode bit (36) aligned;
dcl  address_pathname character (200);
dcl  address_dirname character (168);
dcl  (address_ename, address_component) character (32);
dcl  address_route_ptr pointer;

dcl  1 local_do aligned like deliver_options;		/* for copy/log/save ... */
dcl  create_the_mailbox entry (character (*), character (*), fixed binary (35)) variable;
dcl  (preserve_message_type, preserve_access_class, created) bit (1) aligned;
dcl  (no_mailbox_code, mailbox_created_code) fixed binary (35);

/* format: off */
dcl (FULL_FORMATTING	     initial (1),		/* use the standard formatting procedure */
     COPY_FORMATTING	     initial (2),		/* copy the in-mailbox canoncial text directly */
     REDISTRIBUTION_FORMATTING     initial (3))		/* just format the redistribution */
	fixed binary static options (constant);
/* format: on */

dcl  STACK_EXTENSION fixed binary (18) static options (constant) initial (1024);

dcl  sys_info$max_seg_size fixed binary (19) external;

/* format: off */
dcl (error_table_$action_not_performed, error_table_$ai_restricted, error_table_$bad_subr_arg, error_table_$bigarg,
     error_table_$entlong, error_table_$lock_wait_time_exceeded, error_table_$logical_volume_not_connected,
     error_table_$logical_volume_not_defined, error_table_$messages_deferred, error_table_$messages_off,
     error_table_$moderr, error_table_$no_append, error_table_$no_component, error_table_$no_info, error_table_$noentry,
     error_table_$notalloc, error_table_$rqover, error_table_$smallarg, error_table_$unimplemented_version,
     error_table_$wakeup_denied, forum_error_table_$meeting_bloat, forum_error_table_$not_in_search_list,
     forum_error_table_$read_only, forum_error_table_$rqo, mlsys_et_$address_pathname_too_long_to_q,
     mlsys_et_$cant_compute_route, mlsys_et_$cant_queue_mls_in_archive, mlsys_et_$duplicate_address,
     mlsys_et_$empty_mailing_list, mlsys_et_$empty_message, mlsys_et_$errors_in_list_address,
     mlsys_et_$foreign_address_too_long, mlsys_et_$forum_not_available, mlsys_et_$invalid_address,
     mlsys_et_$ism_not_available, mlsys_et_$list_address_is_all_duplicates, mlsys_et_$logbox_created,
     mlsys_et_$mailbox_full, mlsys_et_$message_delivered, mlsys_et_$message_not_sent, mlsys_et_$message_partially_sent,
     mlsys_et_$message_queued, mlsys_et_$message_queued_and_delivered, mlsys_et_$message_too_large,
     mlsys_et_$no_a_permission, mlsys_et_$no_forum_this_ring, mlsys_et_$no_logbox, mlsys_et_$no_mailbox,
     mlsys_et_$no_mailing_list, mlsys_et_$no_recipients, mlsys_et_$no_savebox, mlsys_et_$rejected_by_foreign_system,
     mlsys_et_$route_out_of_service, mlsys_et_$savebox_created, mlsys_et_$too_many_recipients,
     mlsys_et_$unable_to_queue_mail, mlsys_et_$unknown_delivery_mode, mlsys_et_$unknown_queued_notify_mode,
     mlsys_et_$unknown_queueing_mode)
	fixed binary (35) external;
/* format: on */

dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35));
dcl  cu_$shrink_stack_frame entry (pointer, fixed binary (35));
dcl  forum_$close_forum entry (fixed binary, fixed binary (35));
dcl  forum_$enter_trans
	entry (fixed binary, character (*), fixed binary, character (*), bit (1) aligned, fixed binary,
	fixed binary (35));
dcl  forum_$open_forum entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  forum_$real_forum_limits
	entry (fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, bit (36) aligned,
	fixed binary (35));
dcl  get_authorization_ entry () returns (bit (72) aligned);
dcl  get_privileges_ entry () returns (bit (36) aligned);
dcl  get_ring_ entry () returns (fixed binary (3));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  initiate_file_$component
	entry (character (*), character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl  mailbox_$close entry (fixed binary, fixed binary (35));
dcl  mailbox_$get_mode_file entry (character (*), character (*), bit (36) aligned, fixed binary (35));
dcl  mailbox_$get_mode_index entry (fixed binary, bit (36) aligned, fixed binary (35));
dcl  mailbox_$get_uid_file entry (character (*), character (*), bit (36) aligned, fixed binary (35));
dcl  mailbox_$get_uid_index entry (fixed binary, bit (36) aligned, fixed binary (35));
dcl  mailbox_$open entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  mailbox_$wakeup_aim_add_index
	entry (fixed binary, pointer, fixed binary (24), bit (36) aligned, bit (72) aligned, bit (72) aligned,
	fixed binary (35));
dcl  mlsys_address_list_mgr_$add_address entry (pointer, pointer, character (8), fixed binary (35));
dcl  mlsys_address_list_mgr_$create_read_only_address_list entry (character (8), pointer, fixed binary (35));
dcl  mlsys_address_list_mgr_$delete_address entry (pointer, fixed binary, fixed binary (35));
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_$merge_address_lists entry (pointer, pointer, bit (1) aligned, pointer, fixed binary (35));
dcl  mlsys_address_list_mgr_$verify_address_list entry (pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mlsys_address_list_mgr_$verify_writeable_address_list entry (pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mlsys_address_mgr_$check_if_actually_local entry (pointer);
dcl  mlsys_address_mgr_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mlsys_address_mgr_$decrement_reference_count entry (pointer);
dcl  mlsys_address_mgr_$decrement_reference_count_no_free entry (pointer);
dcl  mlsys_address_mgr_$expand_list_address entry (pointer, character (8), pointer, fixed binary (35));
dcl  mlsys_address_mgr_$free_address entry (pointer, fixed binary (35));
dcl  mlsys_address_mgr_$get_address_pathname
	entry (pointer, character (*), character (*), character (*), fixed binary (35));
dcl  mlsys_address_mgr_$get_address_string entry (pointer, character (*) varying, fixed binary (35));
dcl  mlsys_address_mgr_$get_address_type entry (pointer, fixed binary, fixed binary (35));
dcl  mlsys_address_mgr_$get_mail_table_address entry (pointer, pointer, fixed binary (35));
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_address_route_mgr_$compute_route entry (pointer, pointer, fixed binary (35));
dcl  mlsys_address_route_mgr_$free_address_route entry (pointer);
dcl  mlsys_format_$format_address_for_ism
	entry (character (*) varying, pointer, character (*) varying, character (*) varying, fixed binary (35));
dcl  mlsys_format_$format_canon_redistributed_msg
	entry (pointer, pointer, pointer, pointer, fixed binary (19), fixed binary (19), fixed binary (35));
dcl  mlsys_format_$format_message_for_forum
	entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  mlsys_format_$format_message_for_mailbox
	entry (pointer, pointer, fixed binary (19), fixed binary (19), fixed binary (35));
dcl  mlsys_format_$format_message_for_rfc822_network
	entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  mlsys_mailbox_mgr_$get_message_mf_if_canonical entry (pointer, pointer, pointer, fixed binary (35));
dcl  mlsys_mailbox_utils_$create_logbox entry (fixed binary (35));
dcl  mlsys_mailbox_utils_$create_savebox entry (character (*), character (*), fixed binary (35));
dcl  mlsys_mailer_ entry (pointer, pointer, fixed binary (21));
dcl  mlsys_message_id_mgr_$encode_local_id entry (fixed binary (71), bit (72) aligned);
dcl  mlsys_message_mgr_$add_redistribution entry (pointer, pointer, fixed binary, fixed binary (35));
dcl  mlsys_message_mgr_$delete_redistribution entry (pointer, fixed binary, fixed binary (35));
dcl  mlsys_message_mgr_$replace_message_envelope entry (pointer, pointer, fixed binary (35));
dcl  mlsys_message_mgr_$verify_im_message entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned);
dcl  mlsys_message_mgr_$verify_message entry (pointer, fixed binary (71), fixed binary (35)) returns (bit (1) aligned);
dcl  mlsys_message_mgr_$verify_new_message entry (pointer, fixed binary (71), fixed binary (35))
	returns (bit (1) aligned);
dcl  mlsys_misc_utils_$free_delivery_results entry (pointer, fixed binary (35));
dcl  mlsys_psp_$forum_not_available entry () returns (bit (1) aligned);
dcl  mlsys_psp_$ism_not_available entry () returns (bit (1) aligned);
dcl  mlsys_storage_mgr_$get_temp_segment entry (pointer, fixed binary (35));
dcl  mlsys_storage_mgr_$release_temp_segment entry (pointer, fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));

dcl  (area, cleanup, record_quota_overflow) condition;

dcl  (addr, addwordno, baseno, clock, currentsize, dimension, divide, hbound, index, lbound, length, mod, null, reverse,
     rtrim, size, stackframeptr, string, substr, verify, wordno, unspec) builtin;
%page;
/* Transmits a new message to the specified list of recipients */

deliver_message:
     entry (P_message_ptr, P_recipients_info_ptr, P_deliver_options_ptr, P_code);

	if ^mlsys_message_mgr_$verify_new_message (P_message_ptr, date_time_message_created, P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);

	call verify_recipients_info_and_deliver_options (P_code);
	if P_code ^= 0 then return;

	call initialize_message_delivery ("1"b);	/* for cleanup handler ... */

	on condition (cleanup)
	     begin;
	     call cleanup_message_delivery ();
	     call mlsys_misc_utils_$free_delivery_results (recipients_info_ptr, (0));
	end;

	call complete_new_message ();			/* supply values for all necessary fields */

	suppress_bcc_field_when_necessary = ^is_empty_list (saved_message_data.bcc);
						/* no bcc field in copy to primary/secondary recipients */

	go to TRANSMIT_MESSAGE;			/* get the work done */


/* Redistributes an in-mailbox message to the specified list of recipients while optionally adding a comment */

redistribute_message:
     entry (P_message_ptr, P_redistribution_comment, P_recipients_info_ptr, P_deliver_options_ptr, P_code);

	if ^mlsys_message_mgr_$verify_im_message (P_message_ptr, (null ()), P_code) then return;
	message_ptr = copy_ptr (P_message_ptr);

	call verify_recipients_info_and_deliver_options (P_code);
	if P_code ^= 0 then return;

	call initialize_message_delivery ("1"b);	/* for cleanup handler ... */

	on condition (cleanup)
	     begin;
	     call cleanup_message_delivery ();
	     call mlsys_misc_utils_$free_delivery_results (recipients_info_ptr, (0));
	end;

	message.access_class = get_authorization_ ();	/* redistribution changes the access class */

	call add_redistribution ();			/* add a redistribution to the message */

	suppress_bcc_field_when_necessary = "0"b;	/* always include the message's bcc field */
%page;
/* Common code for the deliver and redistribute operations */

TRANSMIT_MESSAGE:
	if ^aim_check_$greater_or_equal (message.access_class, get_authorization_ ()) then do;
	     /*** Need ring-1 system privilege to send messages "down" */
	     string (user_privileges) = get_privileges_ ();
	     if ^user_privileges.ring1 then do;		/* ... all deliveries would fail so make it a global error */
		P_code = error_table_$ai_restricted;
		go to RETURN_FROM_TRANSMIT_WITH_FATAL_ERROR;
	     end;
	end;


/* Build the list of recipients for this message and verify that mail can be delivered/queued for each recipient */

	delivery_aborted = "1"b;			/* until proven otherwise */
	never_transmitted = "1"b;			/* until proven otherwise */

	need_mailbox_message,			/* haven't spotted any of these type of recipients yet */
	     need_forum_message, need_network_message = "0"b;
	make_copies_with_bcc,			/* haven't seen blind recipients yet */
	     make_copies_without_bcc = "0"b;		/* also have't seen primary/secondary recipients yet */

	do the_list_idx = 1 to recipients_info.n_lists;
	     if ^is_empty_list (recipients_info.lists (the_list_idx).address_list_ptr) then do;
		address_list_ptr = recipients_info.lists (the_list_idx).address_list_ptr;
		do the_address_idx = 1 to address_list.n_addresses;
		     call validate_or_expand_address (address_list.addresses (the_address_idx), "1"b, "0"b, "1"b,
			"0"b);
		end;
	     end;
	end;

	if n_recipients = 0 then do;			/* all lists were empty or nothing but circular lists */
	     P_code = mlsys_et_$no_recipients;
	     go to RETURN_FROM_TRANSMIT_WITH_FATAL_ERROR;
	end;

	if baseno (recipients_list_ptr) = baseno (stackframeptr ()) then do;
	     stack_truncation_ptr =			/* ... release the unused part of the stack extension */
		addwordno (initial_stack_extension,
		((n_recipients * recipient_size) + 16 - mod ((n_recipients * recipient_size), 16)));
	     call cu_$shrink_stack_frame (stack_truncation_ptr, (0));
	end;
	else call cu_$shrink_stack_frame (initial_stack_extension, (0));
						/* not enough room on the stack: free up the space */


/* Mark duplicate recipients and then count the number of unique and/or failing recipients:  The number of failing
   recipients may be increased later by transient errors which are transformed into fatal errors */

	call mark_duplicate_recipients ();

	n_unique_recipients, n_failed_recipients = 0;

	do recipient_idx = 1 to n_recipients;
	     recipient_ptr = addr (recipients_list.recipients (recipient_idx));
	     if ^recipient.duplicate then do;		/* a unique recipient ... */
		n_unique_recipients = n_unique_recipients + 1;
		if recipient.fatal_error then n_failed_recipients = n_failed_recipients + 1;
	     end;					/* ... don't count fatal errors more than once */
	end;

	if deliver_options.abort & (n_failed_recipients > 0) then go to SETUP_RESULTS_LISTS;
						/* "stop" here if caller wants to abort on fatal errors */

/* Prepare whatever copies of the message will be needed for delivery */

	if need_mailbox_message & make_copies_with_bcc then do;
	     /*** Need a copy for transmision to mailboxes */
	     call prepare_message_for_mailbox ("1"b, mailbox_message_with_bcc_ptr, mailbox_message_with_bcc_lth, code);
	     if code ^= 0 then do;
		/*** Couldn't construct the message: mark this as a fatal error for all appropriate recipients */
		do recipient_idx = 1 to n_recipients;
		     recipient_ptr = addr (recipients_list.recipients (recipient_idx));
		     if ^recipient.duplicate & ^recipient.fatal_error & (recipient.type = MAILBOX_RECIPIENT)
			& ^recipient.use_copy_without_bcc then do;
			n_failed_recipients = n_failed_recipients + 1;
			recipient.fatal_error = "1"b;
			recipient.code = code;
			if recipient.mailbox_idx ^= 0 then do;
			     call mailbox_$close (recipient.mailbox_idx, (0));
			     recipient.mailbox_idx = 0;
			end;
		     end;
		end;
	     end;
	end;

	if need_mailbox_message & make_copies_without_bcc then
	     if is_empty_list (saved_message_data.bcc) & make_copies_with_bcc then do;
		/*** No bcc field: both copies are identical */
		mailbox_message_without_bcc_ptr = mailbox_message_with_bcc_ptr;
		mailbox_message_without_bcc_lth = mailbox_message_with_bcc_lth;
	     end;
	     else do;
		/*** Need a copy without the bcc field for transmission to primary and secondary recipients */
		call prepare_message_for_mailbox ("0"b, mailbox_message_without_bcc_ptr,
		     mailbox_message_without_bcc_lth, code);
		if code ^= 0 then do;
		     do recipient_idx = 1 to n_recipients;
			recipient_ptr = addr (recipients_list.recipients (recipient_idx));
			if ^recipient.duplicate & ^recipient.fatal_error & (recipient.type = MAILBOX_RECIPIENT)
			     & recipient.use_copy_without_bcc then do;
			     n_failed_recipients = n_failed_recipients + 1;
			     recipient.fatal_error = "1"b;
			     recipient.code = code;
			     if recipient.mailbox_idx ^= 0 then do;
				call mailbox_$close (recipient.mailbox_idx, (0));
				recipient.mailbox_idx = 0;
			     end;
			end;
		     end;
		end;
	     end;

	if need_forum_message & make_copies_with_bcc then do;
	     /*** Need a copy for transmission to forum meetings */
	     call prepare_message_for_forum ("1"b, forum_message_with_bcc_ptr, forum_message_with_bcc_lth, code);
	     if code ^= 0 then do;
		do recipient_idx = 1 to n_recipients;
		     recipient_ptr = addr (recipients_list.recipients (recipient_idx));
		     if ^recipient.duplicate & ^recipient.fatal_error & (recipient.type = FORUM_RECIPIENT)
			& ^recipient.use_copy_without_bcc then do;
			n_failed_recipients = n_failed_recipients + 1;
			recipient.fatal_error = "1"b;
			recipient.code = code;
			if recipient.forum_idx ^= 0 then do;
			     call forum_$close_forum (recipient.forum_idx, (0));
			     recipient.forum_idx = 0;
			end;
		     end;
		end;
	     end;
	end;

	if need_forum_message & make_copies_without_bcc then
	     if is_empty_list (saved_message_data.bcc) & make_copies_with_bcc then do;
		/*** No bcc field: both copies are identical */
		forum_message_without_bcc_ptr = forum_message_with_bcc_ptr;
		forum_message_without_bcc_lth = forum_message_with_bcc_lth;
	     end;
	     else do;
		/*** Need a copy without the bcc field for transmission to primary and secondary recipients */
		call prepare_message_for_forum ("0"b, forum_message_without_bcc_ptr, forum_message_without_bcc_lth,
		     code);
		if code ^= 0 then do;
		     do recipient_idx = 1 to n_recipients;
			recipient_ptr = addr (recipients_list.recipients (recipient_idx));
			if ^recipient.duplicate & ^recipient.fatal_error & (recipient.type = FORUM_RECIPIENT)
			     & recipient.use_copy_without_bcc then do;
			     n_failed_recipients = n_failed_recipients + 1;
			     recipient.fatal_error = "1"b;
			     recipient.code = code;
			     if recipient.forum_idx ^= 0 then do;
				call forum_$close_forum (recipient.forum_idx, (0));
				recipient.forum_idx = 0;
			     end;
			end;
		     end;
		end;
	     end;

	if need_network_message & make_copies_with_bcc then do;
	     /*** Need a copy for transmission to one or more networks */
	     call prepare_message_for_network ("1"b, network_message_with_bcc_ptr, network_message_with_bcc_lth, code);
	     if code ^= 0 then do;
		do recipient_idx = 1 to n_recipients;
		     recipient_ptr = addr (recipients_list.recipients (recipient_idx));
		     if ^recipient.duplicate & ^recipient.fatal_error & (recipient.type = NETWORK_RECIPIENT)
			& ^recipient.use_copy_without_bcc then do;
			n_failed_recipients = n_failed_recipients + 1;
			recipient.fatal_error = "1"b;
			recipient.code = code;
		     end;
		end;
	     end;
	end;

	if need_network_message & make_copies_without_bcc then
	     if is_empty_list (saved_message_data.bcc) & make_copies_with_bcc then do;
		/*** No bcc field: both copies are identical */
		network_message_without_bcc_ptr = network_message_with_bcc_ptr;
		network_message_without_bcc_lth = network_message_with_bcc_lth;
	     end;
	     else do;
		/*** Need a copy without the bcc field for transmission to primary and secondary recipients */
		call prepare_message_for_network ("0"b, network_message_without_bcc_ptr,
		     network_message_without_bcc_lth, code);
		if code ^= 0 then do;
		     do recipient_idx = 1 to n_recipients;
			recipient_ptr = addr (recipients_list.recipients (recipient_idx));
			if ^recipient.duplicate & ^recipient.fatal_error & (recipient.type = NETWORK_RECIPIENT)
			     & recipient.use_copy_without_bcc then do;
			     n_failed_recipients = n_failed_recipients + 1;
			     recipient.fatal_error = "1"b;
			     recipient.code = code;
			end;
		     end;
		end;
	     end;

	if deliver_options.abort & (n_failed_recipients > 0) then go to SETUP_RESULTS_LISTS;
						/* "stop" here if caller wants to abort on fatal errors */

	delivery_aborted = "0"b;			/* wasn't aborted, attempting delivery now */

/* All pre-delivery checks have been made: attempt local deliveries and convert transient errors into queuing requests if
   appropriate */

	do recipient_idx = 1 to n_recipients;
	     recipient_ptr = addr (recipients_list.recipients (recipient_idx));

	     if ^recipient.duplicate & ^recipient.fatal_error & ^recipient.to_queue then do;

		if recipient.mailbox_idx ^= 0 then do;
		     /*** Recipient goes to a mailbox */
		     if recipient.use_copy_without_bcc then
			call add_message_to_mailbox (recipient.mailbox_idx, mailbox_message_without_bcc_ptr,
			     mailbox_message_without_bcc_lth, recipient.no_acknowledge, recipient.code);
		     else call add_message_to_mailbox (recipient.mailbox_idx, mailbox_message_with_bcc_ptr,
			     mailbox_message_with_bcc_lth, recipient.no_acknowledge, recipient.code);
		     if recipient.code = 0 then	/* success */
			recipient.code = mlsys_et_$message_delivered;
		     else do;			/* some form of failure */
			recipient.fatal_error, recipient.transient_error, recipient.warning = "0"b;
			if (recipient.code = error_table_$lock_wait_time_exceeded)
			     | (recipient.code = error_table_$rqover) | (recipient.code = mlsys_et_$mailbox_full)
			     | (recipient.code = error_table_$logical_volume_not_defined)
			     | (recipient.code = error_table_$logical_volume_not_connected) then
			     recipient.transient_error = "1"b;
			else if (deliver_options.delivery_mode = INTERACTIVE_DELIVERY)
			     & ((recipient.code = error_table_$messages_off)
			     | (recipient.code = error_table_$messages_deferred)
			     | (recipient.code = error_table_$wakeup_denied)
			     | (recipient.code = error_table_$no_info)) then
			     recipient.warning = "1"b;
			else do;
			     recipient.fatal_error = "1"b;
			     n_failed_recipients = n_failed_recipients + 1;
			end;
		     end;
		end;

		else if recipient.forum_idx ^= 0 then do;
		     /*** Recipient goes to a forum meeting */
		     if recipient.use_copy_without_bcc then
			call add_message_to_forum (recipient.forum_idx, forum_message_without_bcc_ptr,
			     forum_message_without_bcc_lth, recipient.code);
		     else call add_message_to_forum (recipient.forum_idx, forum_message_with_bcc_ptr,
			     forum_message_with_bcc_lth, recipient.code);
		     if recipient.code = 0 then	/* success */
			recipient.code = mlsys_et_$message_delivered;
		     else do;			/* some form of failure */
			recipient.fatal_error, recipient.transient_error, recipient.warning = "0"b;
			if (recipient.code = error_table_$rqover)
			     | (recipient.code = error_table_$logical_volume_not_defined)
			     | (recipient.code = error_table_$logical_volume_not_connected)
			     | (recipient.code = forum_error_table_$meeting_bloat) then
			     recipient.transient_error = "1"b;
			else do;
			     recipient.fatal_error = "1"b;
			     n_failed_recipients = n_failed_recipients + 1;
			end;
		     end;
		end;

		if recipient.transient_error then do;
		     /*** A transient error occured ... */
		     recipient.transient_error = "0"b;
		     if mlsys_psp_$ism_not_available () then go to TREAT_TRANSIENT_LOCAL_ERROR_AS_FATAL;
						/* no inter-system mailer to queue it: it's fatal, period */

		     else if deliver_options.queueing_mode >= QUEUE_WHEN_NEEDED then do;
			/*** ... and caller requests that they be queued instead of failing */
			call mlsys_address_mgr_$get_address_pathname (recipient.address_ptr, address_dirname,
			     address_ename, address_component, (0));
			if address_component ^= "" then go to TREAT_TRANSIENT_LOCAL_ERROR_AS_FATAL;
			address_pathname = pathname_ (address_dirname, address_ename);
			recipient.foreign_address = rtrim (address_pathname);
			if recipient.foreign_address ^= address_pathname then
			     go to TREAT_TRANSIENT_LOCAL_ERROR_AS_FATAL;
			recipient.to_queue = "1"b;
			if recipient.code = error_table_$lock_wait_time_exceeded then
			     recipient.explanation = "the mailbox is temporarily locked";
			else if recipient.code = mlsys_et_$mailbox_full then
			     recipient.explanation = "the mailbox is temporarily full";
			else if recipient.code = error_table_$rqover then
			     recipient.explanation = "of record quota overflow";
			else if recipient.code = error_table_$logical_volume_not_defined then
			     recipient.explanation = "its logical volume is not mounted";
			else if recipient.code = error_table_$logical_volume_not_connected then
			     recipient.explanation = "its logical volume is not attached";
			else /*** if recipient.code = forum_error_table_$meeting_bloat then */
			     recipient.explanation = "the meeting is temporarily full";
			recipient.code = 0;		/* ... will be trying again shortly */
		     end;

		     else do;
			/*** ... and caller requests that they be considered fatal */
TREAT_TRANSIENT_LOCAL_ERROR_AS_FATAL:
			recipient.fatal_error = "1"b;
			n_failed_recipients = n_failed_recipients + 1;
		     end;
		end;

		if ^recipient.fatal_error & (length (recipient.explanation) = 0) then never_transmitted = "0"b;
	     end;					/* record if it's been sent */
	end;


/* Setup data required for use of the interim inter-system mailer */

	mlsys_mailer_data_n_recipients = n_recipients;
	if size (mlsys_mailer_data) <= STACK_EXTENSION then
	     call cu_$grow_stack_frame (STACK_EXTENSION, mlsys_mailer_data_ptr, (0));
	else do;					/* need a temporary segment */
	     call mlsys_storage_mgr_$get_temp_segment (mlsys_mailer_data_ptr, code);
	     if code ^= 0 then do;
UNABLE_TO_GET_ISM_TEMP_SPACE:
		do recipient_idx = 1 to n_recipients;
		     recipient_ptr = addr (recipients_list.recipients (recipient_idx));
		     if ^recipient.duplicate then	/* ... don't count it twice ... */
			if recipient.code = 0 then do;/* ... not processed yet => it needed the mailer */
			     recipient.fatal_error = "1"b;
			     recipient.code = code;
			     n_failed_recipients = n_failed_recipients + 1;
			end;
		end;
		go to SETUP_RESULTS_LISTS;
	     end;
	end;

	if size (ism_recipient_idxs) <= STACK_EXTENSION then
	     call cu_$grow_stack_frame (STACK_EXTENSION, ism_recipient_idxs_ptr, (0));
	else do;					/* need a temporary segment */
	     call mlsys_storage_mgr_$get_temp_segment (ism_recipient_idxs_ptr, code);
	     if code ^= 0 then go to UNABLE_TO_GET_ISM_TEMP_SPACE;
	end;


/* Attempt immediate foreign deliveries and convert transient errors into queueing requests if appropriate */

	if need_network_message then do;		/* ... only if there are some foreign addresses */
	     if make_copies_with_bcc then
		call deliver_by_ism ("0"b, network_message_with_bcc_ptr, network_message_with_bcc_lth);
	     if make_copies_without_bcc then
		call deliver_by_ism ("1"b, network_message_without_bcc_ptr, network_message_without_bcc_lth);
	end;


/* Queue all appropriate recipients */

	if need_mailbox_message then do;		/* mailbox recipients ... */
	     if make_copies_with_bcc then
		call queue_via_ism (MAILBOX_RECIPIENT, "0"b, addr (mailbox_message_with_bcc_ptr -> mail_format.text),
		     length (mailbox_message_with_bcc_ptr -> mail_format.text));
	     if make_copies_without_bcc then
		call queue_via_ism (MAILBOX_RECIPIENT, "1"b,
		     addr (mailbox_message_without_bcc_ptr -> mail_format.text),
		     length (mailbox_message_without_bcc_ptr -> mail_format.text));
	end;

	if need_forum_message then do;		/* forum recipients ... */
	     if make_copies_with_bcc then
		call queue_via_ism (FORUM_RECIPIENT, "0"b, forum_message_with_bcc_ptr, forum_message_with_bcc_lth);
	     if make_copies_without_bcc then
		call queue_via_ism (FORUM_RECIPIENT, "1"b, forum_message_without_bcc_ptr,
		     forum_message_without_bcc_lth);
	end;

	if need_network_message then do;		/* foreign recipients ... */
	     if make_copies_with_bcc then
		call queue_via_ism (NETWORK_RECIPIENT, "0"b, network_message_with_bcc_ptr,
		     network_message_with_bcc_lth);
	     if make_copies_without_bcc then
		call queue_via_ism (NETWORK_RECIPIENT, "1"b, network_message_without_bcc_ptr,
		     network_message_without_bcc_lth);
	end;


/* All deliveries and queueings have been completed: create the lists of results and fill them in */

SETUP_RESULTS_LISTS:
	recipients_info.n_recipients = n_recipients;	/* return global information */
	recipients_info.n_unique_recipients = n_unique_recipients;
	recipients_info.n_failed_recipients = n_failed_recipients;

	on condition (area)
	     begin;				/* can't allocate all the result lists: non-fatal error */
	     go to RETURN_FROM_TRANSMIT;
	end;


	expanded_recipients_result_list_n_entries = 0;	/* no need to create this list yet */

	do the_list_idx = 1 to recipients_info.n_lists;

	     if ^is_empty_list (recipients_info.lists (the_list_idx).address_list_ptr) then do;
		address_list_ptr = recipients_info.lists (the_list_idx).address_list_ptr;

		recipients_result_list_n_addresses = address_list.n_addresses;
		allocate recipients_result_list in (users_area) set (recipients_result_list_ptr);
		recipients_info.lists (the_list_idx).recipients_result_list_ptr = recipients_result_list_ptr;

		do the_address_idx = 1 to address_list.n_addresses;

		     result_ptr = addr (recipients_result_list.results (the_address_idx));
		     result.code, result.expanded_list_info, result.duplicate_info = 0;
		     result.explanation = "";
		     have_result_code = "0"b;

		     /*** Check out all recipients until we've determined the result for this address */
		     do recipient_idx = 1 to n_recipients while (^have_result_code);
			recipient_ptr = addr (recipients_list.recipients (recipient_idx));

			if (recipient.list_idx = the_list_idx) & (recipient.address_idx = the_address_idx) then do;
			     have_result_code = "1"b; /* ... stop the outer loop */

			     if recipient.top_level then
				/*** Address corresponds directly to this recipient: copy the result */
				if recipient.duplicate then do;
				     /*** ... it's a duplicate of a prior recipient */
				     result.code = mlsys_et_$duplicate_address;
				     result.list_idx =
					recipients_list.recipients (recipient.duplicate_idx).list_idx;
				     result.address_idx =
					recipients_list.recipients (recipient.duplicate_idx).address_idx;
				end;
				else do;
				     /*** ... not a duplicate: get the actual result data */
				     result.code = recipient.code;
				     result.explanation = recipient.explanation;
				end;

			     else do;
				/*** Address corresponds to several recipients */
				if recipient.duplicate then
				     result.code = mlsys_et_$list_address_is_all_duplicates;
				part_of_this_address = "1"b;
				partially_delivered, partially_queued = "0"b;
				do while (part_of_this_address & (recipient_idx <= n_recipients));
				     if ^recipient.duplicate then do;
					if result.code = mlsys_et_$list_address_is_all_duplicates then
					     result.code = 0;
					if recipient.fatal_error then
					     result.code = mlsys_et_$errors_in_list_address;
					else if recipient.code = mlsys_et_$message_queued then
					     partially_queued = "1"b;
					else partially_delivered = "1"b;
					if recipient.fatal_error | recipient.warning
					     | (length (recipient.explanation) > 0) then do;
					     expanded_recipients_result_list_n_entries =
						expanded_recipients_result_list_n_entries + 1;
					     if result.first_entry_idx = 0 then
						result.first_entry_idx =
						     expanded_recipients_result_list_n_entries;
					     result.n_entries = result.n_entries + 1;
					end;
				     end;
				     recipient_idx = recipient_idx + 1;
				     if recipient_idx <= n_recipients then do;
					recipient_ptr = addr (recipients_list.recipients (recipient_idx));
					part_of_this_address =
					     (recipient.list_idx = the_list_idx)
					     & (recipient.address_idx = the_address_idx);
				     end;
				end;

				if result.code = 0 then
				     if delivery_aborted then result.code = mlsys_et_$message_not_sent;
						/* phx18036 RL: indicate delivery aborted */
				     else if partially_delivered & partially_queued then
					result.code = mlsys_et_$message_queued_and_delivered;
				     else if partially_delivered then result.code = mlsys_et_$message_delivered;
				     else /*** if partially_queued then */
					result.code = mlsys_et_$message_queued;
			     end;
			end;
		     end;
		end;
	     end;
	end;


/* Construct the expanded recipients result list to contain details on any warning, fatal errors, or transient errors
   resulting in queueing for all recipients which are the expansion of supplied list addresses */

	if expanded_recipients_result_list_n_entries > 0 then do;

	     allocate expanded_recipients_result_list in (users_area) set (expanded_recipients_result_list_ptr);
	     recipients_info.expanded_recipients_result_list_ptr = expanded_recipients_result_list_ptr;

	     idx = 0;				/* haven't put anything in the list yet */

	     do recipient_idx = 1 to n_recipients;
		recipient_ptr = addr (recipients_list.recipients (recipient_idx));

		if ^recipient.top_level then		/* a candidate */
		     if recipient.warning | recipient.fatal_error | (length (recipient.explanation) > 0) then do;
			idx = idx + 1;
			expanded_recipients_result_list.entries (idx).address_ptr = recipient.address_ptr;
			expanded_recipients_result_list.entries (idx).code = recipient.code;
			expanded_recipients_result_list.entries (idx).list_idx = recipient.list_idx;
			expanded_recipients_result_list.entries (idx).address_idx = recipient.address_idx;
			expanded_recipients_result_list.entries (idx).explanation = recipient.explanation;
			call mlsys_address_mgr_$decrement_reference_count_no_free (recipient.address_ptr);
		     end;				/* ... prevent the address from being freed prematurely */
	     end;
	end;


/* Control arrives here after successfull (or almost successfull) transmission */

RETURN_FROM_TRANSMIT:
	call cleanup_message_delivery ();		/* flush temporaries and restore original message state */

	if recipients_info.n_failed_recipients = 0 then	/* complete success */
	     P_code = 0;

	else if never_transmitted then		/* never attempted a transmission */
	     P_code = mlsys_et_$message_not_sent;

	else P_code = mlsys_et_$message_partially_sent;

	return;


/* Control arrives here iff an error fatal to the entire transmission process is detected while validating/expanding
   addresses:  The validate_or_expand_address internal procedure has already set P_code */

RETURN_FROM_TRANSMIT_WITH_FATAL_ERROR:
	call cleanup_message_delivery ();
	if recipients_info_ptr ^= null () then call mlsys_misc_utils_$free_delivery_results (recipients_info_ptr, (0));

	return;
%page;
/* Eliminates all duplicate addresses from the given address lists:  This function is implemented here rather than in
   mlsys_address_list_mgr_ as this module is designed to open all mailboxes/forums in a given set of address lists only
   once.  Thus, while it is still necessary to do O(N^2) comparisons (where N is the total number of addresses in the
   lists), only O(N) mailbox/forum openings and closings are done; as the open/close operations are the majority of the
   expense of address comparison, this reduction from O(N^2) to O(N) openings/closing represents a substantial performance
   improvement over the previous version of this function in the mail system */

eliminate_duplicate_addrs:				/* ... any types of address lists */
     entry (P_address_lists, P_code);

	do the_list_idx = lbound (P_address_lists, 1) to hbound (P_address_lists, 1);
	     if P_address_lists (the_list_idx) ^= null () then
		if ^mlsys_address_list_mgr_$verify_address_list (P_address_lists (the_list_idx), P_code) then return;
	end;

	go to ELIMINATE_DUPLICATE_ADDRS_COMMON;


eliminate_duplicate_addrs_write:			/* ... writeable by the user: target of the user-ring gate */
     entry (P_address_lists, P_code);

	do the_list_idx = lbound (P_address_lists, 1) to hbound (P_address_lists, 1);
	     if P_address_lists (the_list_idx) ^= null () then
		if ^mlsys_address_list_mgr_$verify_writeable_address_list (P_address_lists (the_list_idx), P_code)
		     then
		     return;
	end;


ELIMINATE_DUPLICATE_ADDRS_COMMON:
	message_ptr = null ();			/* no message here */

	call initialize_message_delivery ("1"b);	/* for cleanup handler ... */
	recipients_info_ptr = null ();		/* ... in case validate_or_expand_address gets fatal errors */

	on condition (cleanup) call cleanup_message_delivery ();

	deliver_options_ptr = addr (local_do);		/* for validate_or_expand_address */
	local_do.delivery_mode = ORDINARY_DELIVERY;	/* ... don't want to check if we can send wakeups */
	local_do.queueing_mode = NEVER_QUEUE;		/* ... insures we determine address routes immediately */
	string (local_do.flags) = ""b;

	suppress_bcc_field_when_necessary = "0"b;	/* no need to go to that extra overhead */


/* Build the list of all addresses in the input address lists, open all referenced mailboxes/forums, and mark the
   duplicate addresses for deletion */

	do the_list_idx = lbound (P_address_lists, 1) to hbound (P_address_lists, 1);
	     if ^is_empty_list (P_address_lists (the_list_idx)) then do;
		address_list_ptr = P_address_lists (the_list_idx);
		do the_address_idx = 1 to address_list.n_addresses;
		     call validate_or_expand_address (address_list.addresses (the_address_idx), "1"b, "0"b, "0"b,
			"0"b);
		end;				/* don't need expansion of mailing lists ... */
	     end;					/* ... in order to eliminate duplicates */
	end;

	if baseno (recipients_list_ptr) = baseno (stackframeptr ()) then do;
	     stack_truncation_ptr =			/* ... release the unused part of the stack extension */
		addwordno (initial_stack_extension,
		((n_recipients * recipient_size) + 16 - mod ((n_recipients * recipient_size), 16)));
	     call cu_$shrink_stack_frame (stack_truncation_ptr, (0));
	end;
	else call cu_$shrink_stack_frame (initial_stack_extension, (0));
						/* not enough room on the stack: free up the space */

	call mark_duplicate_recipients ();


/* Eliminate the duplicate addresses from the input lists:  This operation is done while scanning the recipients_list
   structure backwards because said structure contains the indeces of the addresses within the original lists.  If scanned
   forward, as addresses were deleted, the subsequent indeces for that list would become invalid; by scanning backwards,
   addresses are deleted from the end first and no indeces are invalidated */

	do recipient_idx = n_recipients to 1 by -1;

	     recipient_ptr = addr (recipients_list.recipients (recipient_idx));

	     if recipient.duplicate then
		if recipient.top_level then		/* input address is a duplicate */
		     call mlsys_address_list_mgr_$delete_address (P_address_lists (recipient.list_idx),
			recipient.address_idx, (0));

		else do;
		     /*** Input address is a named group with at least one duplicate ... */
		     first_recipient_idx = 0;		/* find the first recipient in this list ... */
		     do other_recipient_idx = (recipient_idx - 1) to 1 by -1 while (first_recipient_idx = 0);
			other_recipient_ptr = addr (recipients_list.recipients (other_recipient_idx));
			if (other_recipient.list_idx ^= recipient.list_idx)
			     | (other_recipient.address_idx ^= recipient.address_idx) then
			     first_recipient_idx = other_recipient_idx + 1;
		     end;
		     if first_recipient_idx = 0 then	/* ... the named group is the very first address */
			first_recipient_idx = 1;
		     delete_this_address = "1"b;	/* assume it's OK to delete it ... */
		     continue = "1"b;		/* need do until ... */
		     do other_recipient_idx = first_recipient_idx to n_recipients
			while (delete_this_address & continue);
			other_recipient_ptr = addr (recipients_list.recipients (other_recipient_idx));
			if (other_recipient.list_idx = recipient.list_idx)
			     & (other_recipient.address_idx = recipient.address_idx) then
			     delete_this_address = other_recipient.duplicate;
			else continue = "0"b;	/* ... reached first recipient not from this address */
		     end;
		     if delete_this_address then
			call mlsys_address_list_mgr_$delete_address (P_address_lists (recipient.list_idx),
			     recipient.address_idx, (0));
		     recipient_idx = first_recipient_idx + 1;
		end;				/* continue with first recipient before this list */
	end;


/* Cleanup */

	call cleanup_message_delivery ();

	P_code = 0;				/* success */

	return;
%page;
/* Places a copy of the supplied message into the specified mailbox */

copy_message:
     entry (P_message_ptr, P_mailbox_dirname, P_mailbox_ename, P_code);

	mailbox_dirname = P_mailbox_dirname;
	call add_suffix (P_mailbox_ename, "mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;

	preserve_message_type = "1"b;			/* don't convert interactive messages into ordinary mail */
	preserve_access_class = "1"b;			/* don't change the access class if possible */

	create_if_not_found = "0"b;			/* the mailbox must exist */
	no_mailbox_code = mlsys_et_$no_mailbox;

	go to COPY_LOG_OR_SAVE_MESSAGE;


/* Places a copy of the supplied message into the user's logbox which may optionally be created */

log_message:
     entry (P_message_ptr, P_create_if_not_found, P_code);

	call mlsys_address_mgr_$get_address_pathname (mlsys_data_$user_logbox_address, mailbox_dirname, mailbox_ename,
	     ((32)" "), (0));

	preserve_message_type = "0"b;			/* no interactive messages in the logbox, please */
	preserve_access_class = "0"b;			/* always change the message's access class */

	create_if_not_found = P_create_if_not_found;
	create_the_mailbox = mlsys_mailbox_utils_$create_logbox;
	no_mailbox_code = mlsys_et_$no_logbox;
	mailbox_created_code = mlsys_et_$logbox_created;

	go to COPY_LOG_OR_SAVE_MESSAGE;


/* Places a copy of the supplied message into the specified savebox which may optionally be created */

save_message:
     entry (P_message_ptr, P_mailbox_dirname, P_mailbox_ename, P_create_if_not_found, P_code);

	mailbox_dirname = P_mailbox_dirname;
	if index (reverse (rtrim (P_mailbox_ename)), reverse (".sv")) = 1 then
	     mailbox_ename = substr (P_mailbox_ename, 1, (length (rtrim (P_mailbox_ename)) - length (".sv")));
	else mailbox_ename = P_mailbox_ename;		/* already has right suffix or will be added shortly */
	call add_suffix (mailbox_ename, "sv.mbx", mailbox_ename, P_code);
	if P_code ^= 0 then return;			/* can't create proper pathname */

	preserve_message_type = "0"b;			/* no interactive messages in the savebox, please */
	preserve_access_class = "0"b;			/* always change the message's access class */

	create_if_not_found = P_create_if_not_found;
	create_the_mailbox = mlsys_mailbox_utils_$create_savebox;
	no_mailbox_code = mlsys_et_$no_savebox;
	mailbox_created_code = mlsys_et_$savebox_created;
%page;
/* Common code for the copy, log, and save operations */

COPY_LOG_OR_SAVE_MESSAGE:
	if ^mlsys_message_mgr_$verify_message (P_message_ptr, date_time_message_created, P_code) then return;

	message_ptr = copy_ptr (P_message_ptr);

	deliver_options_ptr = addr (local_do);		/* for add_message_to_mailbox ... */
	local_do.recipient_notification = "0"b;
	local_do.acknowledge = "0"b;

	call initialize_message_delivery ("0"b);	/* for cleanup handler ... */

	on condition (cleanup) call cleanup_message_delivery ();

	if preserve_access_class then			/* don't change the message's access class if possible */
	     if aim_check_$greater_or_equal (message.access_class, get_authorization_ ()) then
		;				/* ... we can preserve it without privilege */
	     else do;				/* ... check for ring-1 privilege */
		string (user_privileges) = get_privileges_ ();
		if user_privileges.ring1 then
		     ;				/* ... we can preserve it because of ring-1 privilege */
		else message.access_class = get_authorization_ ();
	     end;
	else message.access_class = get_authorization_ ();

	if message.date_time_created = 0 then		/* a new message must be complete ... */
	     call complete_new_message ();
	else call delete_last_delivery_fields ();	/* an in-mailbox message is about to be redelivered */

	if preserve_message_type then			/* don't convert interactive to ordinary ... */
	     if message.interactive then		/* ... so be sure prepare_message sets the correct flags */
		local_do.delivery_mode = INTERACTIVE_DELIVERY;
	     else local_do.delivery_mode = ORDINARY_DELIVERY;
	else local_do.delivery_mode = ORDINARY_DELIVERY;

	call prepare_message_for_mailbox ("1"b, mailbox_message_with_bcc_ptr, mailbox_message_with_bcc_lth, code);
	if code ^= 0 then go to RETURN_FROM_COPY_LOG_OR_SAVE_MESSAGE;

	local_do.delivery_mode = ORDINARY_DELIVERY;	/* don't accidently send a wakeup if it's interactive */

	created = "0"b;				/* until proven otherwise */

	call lookup_or_open_mailbox (mailbox_dirname, mailbox_ename, target_mailbox_idx, code);

	if code = error_table_$noentry then		/* not there: try to create it if requested ... */
	     if create_if_not_found then do;
		if create_the_mailbox = mlsys_mailbox_utils_$create_logbox then
		     call mlsys_mailbox_utils_$create_logbox (code);
		else call create_the_mailbox (mailbox_dirname, mailbox_ename, code);
		if code = 0 then do;		/* ... success */
		     created = "1"b;
		     call lookup_or_open_mailbox (mailbox_dirname, mailbox_ename, target_mailbox_idx, code);
		end;				/* ... this open shouldn't fail, but you never know */
	     end;

	if code ^= 0 then do;			/* couldn't open it ... */
	     if code = error_table_$noentry then	/* ... map this code into one from mlsys_et_ */
		code = no_mailbox_code;
	     go to RETURN_FROM_COPY_LOG_OR_SAVE_MESSAGE;
	end;

	call mailbox_$get_mode_index (target_mailbox_idx, mailbox_mode, code);
	if code ^= 0 then go to RETURN_FROM_COPY_LOG_OR_SAVE_MESSAGE;
						/* shouldn't happen if we were able to open it */

	if (mailbox_mode & A_MBX_ACCESS) ^= A_MBX_ACCESS then do;
	     code = mlsys_et_$no_a_permission;		/* don't have access to add messsages */
	     go to RETURN_FROM_COPY_LOG_OR_SAVE_MESSAGE;
	end;

	call add_message_to_mailbox (target_mailbox_idx, mailbox_message_with_bcc_ptr, mailbox_message_with_bcc_lth,
	     "1"b, code);				/* internal procedure handles locking problems, etc. */


RETURN_FROM_COPY_LOG_OR_SAVE_MESSAGE:
	call cleanup_message_delivery ();		/* release temporaries and put message back as we found it */

	if code = 0 then				/* check if we should inform use of message creation */
	     if created then code = mailbox_created_code;

	P_code = code;				/* let caller know what happened */

	return;
%page;
/* Determines if mail can be successfully delivered to the supplied address */

validate_address:
     entry (P_address_ptr, P_validate_mls_contents, P_code);

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

	message_ptr = null ();			/* no message here */

	call initialize_message_delivery ("1"b);	/* for cleanup handler ... */
	recipients_info_ptr = null ();		/* ... in case validate_or_expand_address gets fatal errors */

	on condition (cleanup) call cleanup_message_delivery ();

	deliver_options_ptr = addr (local_do);		/* for validate_or_expand_address */
	local_do.delivery_mode = ORDINARY_DELIVERY;	/* ... don't want to check if we can send wakeups */
	local_do.queueing_mode = NEVER_QUEUE;		/* ... insures we determine address routes immediately */
	string (local_do.flags) = ""b;

	suppress_bcc_field_when_necessary = "0"b;	/* always include the message's bcc field */

	call validate_or_expand_address (P_address_ptr, "1"b, "0"b, P_validate_mls_contents, "1"b);

	if n_recipients = 0 then			/* no corresponding recipients */
	     P_code = mlsys_et_$no_recipients;
	else if n_recipients = 1 then do;		/* single recipient */
	     recipient_ptr = addr (recipients_list.recipients (1));
	     if recipient.fatal_error then
		P_code = recipient.code;
	     else P_code = 0;			/* ... ignore warnings */
	end;
	else do;					/* multiple recipients: check for at least one fatal error */
	     P_code = 0;
	     do recipient_idx = 1 to n_recipients while (P_code = 0);
		recipient_ptr = addr (recipients_list.recipients (recipient_idx));
		if recipient.fatal_error then P_code = mlsys_et_$errors_in_list_address;
	     end;
	end;

	call cleanup_message_delivery ();

	return;
%page;
/* Initialize the cache of recently used mailboxes */

initialize_cache:
     entry ();

	allocate transmit_cache in (mlsys_area) set (mlsys_data_$transmit_cache_ptr);
	unspec (transmit_cache) = ""b;

	return;



/* Searches the cache to see if the given mailbox is already open and, if not, opens it and places it in the cache */

lookup_or_open_mailbox:
     procedure (p_mailbox_dirname, p_mailbox_ename, p_mailbox_idx, p_code);

dcl  (p_mailbox_dirname, p_mailbox_ename) character (*) parameter;
dcl  p_mailbox_idx fixed binary parameter;
dcl  p_code fixed binary (35) parameter;

dcl  (mailbox_uid, cached_uid) bit (36) aligned;
dcl  code fixed binary (35);
dcl  (mailbox_idx, lru_usage, lru_idx, other_cache_idx, idx) fixed binary;


	call mailbox_$get_uid_file (p_mailbox_dirname, p_mailbox_ename, mailbox_uid, code);
	if code ^= 0 then call return_from_lookup (code); /* we won't be able to open it if we can't get the UID */


/* Search the cache of recently used mailboxes for a match */

	lru_usage = hbound (transmit_cache.entries, 1) + 1;

	do idx = lbound (transmit_cache.entries, 1) to hbound (transmit_cache.entries, 1);

	     if transmit_cache.entries (idx).uid = mailbox_uid then do;
		/*** UIDs match: if the cache entry is still valid, we've found it */
		call mailbox_$get_uid_index (transmit_cache.entries (idx).index, cached_uid, code);
		if code ^= 0 then do;		/* ... cache slot is no longer valid */
INVALIDATE_CACHE_ENTRY_AND_REOPEN:
		     unspec (transmit_cache.entries (idx)) = ""b;
		     lru_idx = idx;			/* ... we'll use this slot */
		     go to OPEN_THE_MAILBOX;
		end;
		if cached_uid ^= transmit_cache.entries (idx).uid then go to INVALIDATE_CACHE_ENTRY_AND_REOPEN;
		/*** Control arrives here iff we have a good match */
		transmit_cache.entries (idx).usage = dimension (transmit_cache.entries, 1);
		do other_cache_idx = (idx + 1) to hbound (transmit_cache.entries, 1);
		     transmit_cache.entries (other_cache_idx).usage =
			transmit_cache.entries (other_cache_idx).usage - 1;
		end;
		p_mailbox_idx = transmit_cache.entries (idx).index;
		call return_from_lookup (0);		/* success */
	     end;

	     transmit_cache.entries (idx).usage = transmit_cache.entries (idx).usage - 1;
						/* doesn't match: decrement the usage */

	     if transmit_cache.entries (idx).usage < lru_usage then do;
		lru_idx = idx;			/* least recently used that's been seen so far */
		lru_usage = transmit_cache.entries (idx).usage;
	     end;
	end;


/* Control arrives here iff we didn't find the mailbox in the cache:  open it and add it to the cache */

OPEN_THE_MAILBOX:
	call mailbox_$open (p_mailbox_dirname, p_mailbox_ename, mailbox_idx, code);
	if code = error_table_$moderr then code = mlsys_et_$no_a_permission;
	if code ^= 0 then call return_from_lookup (code); /* failure */

	if transmit_cache.entries (lru_idx).uid ^= ""b then do;
	     /*** Close the mailbox that was in this slot */
	     call mailbox_$get_uid_index (transmit_cache.entries (lru_idx).index, cached_uid, code);
	     if code = 0 then			/* ... but only if it's still the mailbox we think it is */
		if cached_uid = transmit_cache.entries (lru_idx).uid then
		     call mailbox_$close (transmit_cache.entries (lru_idx).index, (0));
	end;

	transmit_cache.entries (lru_idx).uid = mailbox_uid;
	transmit_cache.entries (lru_idx).index = mailbox_idx;
	transmit_cache.entries (lru_idx).usage = dimension (transmit_cache.entries, 1);

	do other_cache_idx = (idx + 1) to hbound (transmit_cache.entries, 1);
	     transmit_cache.entries (other_cache_idx).usage = transmit_cache.entries (other_cache_idx).usage - 1;
	end;					/* decrement any reference counts missed above */

	p_mailbox_idx = mailbox_idx;
	p_code = 0;				/* success */

RETURN_FROM_LOOKUP_OR_OPEN_MAILBOX:
	return;



/* Internal to lookup_or_open_mailbox: returns with the given error code */

return_from_lookup:
	procedure (p_return_code);

dcl  p_return_code fixed binary (35) parameter;

	     p_code = p_return_code;			/* set the output of lookup... */
	     go to RETURN_FROM_LOOKUP_OR_OPEN_MAILBOX;

	end return_from_lookup;

     end lookup_or_open_mailbox;
%page;
/* Verify that the supplied recipients_info_list and deliver_options structures are valid */

verify_recipients_info_and_deliver_options:
     procedure (p_code);

dcl  p_code fixed binary (35) parameter;
dcl  (ignore, is_empty_message) bit (1) aligned;
dcl  idx fixed binary;

	recipients_info_ptr = P_recipients_info_ptr;
	deliver_options_ptr = P_deliver_options_ptr;

	if (recipients_info.version ^= RECIPIENTS_INFO_VERSION_2)
	     | (deliver_options.version ^= DELIVER_OPTIONS_VERSION_2) then do;
	     p_code = error_table_$unimplemented_version;
	     return;
	end;

	if recipients_info.area_ptr = null () then do;	/* can't get system_free_area pointer of caller's ring */
	     p_code = error_table_$bad_subr_arg;
	     return;
	end;

	users_area_ptr = recipients_info.area_ptr;

	if recipients_info.n_lists = 0 then do;		/* there have to be some recipients */
	     p_code = error_table_$bad_subr_arg;
	     return;
	end;

	p_code = 0;
	do idx = 1 to recipients_info.n_lists while (p_code = 0);
	     if recipients_info.lists (idx).address_list_ptr ^= null () then
		ignore =
		     mlsys_address_list_mgr_$verify_address_list (recipients_info.lists (idx).address_list_ptr,
		     p_code);
	end;
	if p_code ^= 0 then return;			/* one of the lists of recipients is bad */

	if (deliver_options.delivery_mode < ORDINARY_DELIVERY) | (deliver_options.delivery_mode > EXPRESS_DELIVERY)
	then do;
	     p_code = mlsys_et_$unknown_delivery_mode;
	     return;
	end;

	if (deliver_options.queueing_mode < NEVER_QUEUE) | (deliver_options.queueing_mode > ALWAYS_QUEUE) then do;
	     p_code = mlsys_et_$unknown_queueing_mode;
	     return;
	end;

	if (deliver_options.queued_notification_mode < NEVER_NOTIFY)
	     | (deliver_options.queued_notification_mode > ALWAYS_NOTIFY) then do;
	     p_code = mlsys_et_$unknown_queued_notify_mode;
	     return;
	end;

	if deliver_options.mbz ^= ""b then do;
	     p_code = error_table_$bad_subr_arg;
	     return;
	end;

	if ^deliver_options.send_if_empty then do;	/* check that there's a body */
	     is_empty_message = "1"b;			/* ... assume it's empty 'till proven otherwise */
	     do idx = 1 to message.n_body_sections while (is_empty_message);
		message_body_section_ptr = addr (message.body.body_sections (idx));
		if message_body_section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION then
		     is_empty_message = (verify (message_preformatted_body_section_text, WHITESPACE) = 0);
		else /*** if message_body_section.section_type = MESSAGE_BIT_STRING_BODY_SECTION then */
		     is_empty_message = (message_bit_string_body_section.bit_string_lth = 0);
	     end;
	     if is_empty_message then do;		/* the body is emtpy */
		p_code = mlsys_et_$empty_message;
		return;
	     end;
	end;

	if mlsys_psp_$ism_not_available () then		/* no inter-system mailer ... */
	     if deliver_options.queueing_mode = ALWAYS_QUEUE then do;
		p_code = mlsys_et_$ism_not_available;	/* caller only wants queueing which isn't possible */
		return;
	     end;
	     else do;				/* caller only wants queueing if needed: so never queue */
		local_do = deliver_options;		/* ... caller's options are considered read-only */
		local_do.queueing_mode = NEVER_QUEUE;
		local_do.queue_mailing_lists = "0"b;
		deliver_options_ptr = addr (local_do);	/* ... switch to our modified options */
	     end;

	recipients_info.n_recipients, recipients_info.n_unique_recipients, recipients_info.n_failed_recipients = 0;

	recipients_info.expanded_recipients_result_list_ptr, recipients_info.lists (*).recipients_result_list_ptr =
	     null ();

	p_code = 0;				/* everything's OK */

	return;

     end verify_recipients_info_and_deliver_options;
%page;
/* Initializes the various data structures used to deliver a message */

initialize_message_delivery:
     procedure (p_start_recipients_list);

dcl  p_start_recipients_list bit (1) aligned parameter;

	call save_message_state ();			/* so that we can restore the message later */

	if p_start_recipients_list then do;		/* caller needs a list of recipients: try using the stack */
	     call cu_$grow_stack_frame (STACK_EXTENSION, initial_stack_extension, (0));
	     recipients_list_ptr = initial_stack_extension;
	     recipient_size = size (recipient) + mod (size (recipient), 2);
	     n_recipients_allocated = divide (STACK_EXTENSION, recipient_size, 17, 0);
	     n_recipients = 0;
	end;
	else recipients_list_ptr = null ();

	current_mailing_list_data_ptr = null ();	/* not in the process of expanding a mailing list */

	mlsys_mailer_data_ptr,			/* not processing inter-system mail yet */
	     ism_recipient_idxs_ptr = null ();

	n_message_buffers_used = 0;			/* no copies of the message yet */
	last_temp_segment_ptr, message_buffers (*) = null ();

	mailbox_idx = 0;				/* no mailbox open at this time */
	forum_idx = 0;				/* no forum meeting either */

	address_route_ptr = null ();			/* no address route from checking a foreign address */

	return;

     end initialize_message_delivery;
%page;
/* Releases interim data structures created during message delivery */

cleanup_message_delivery:
     procedure ();

dcl  idx fixed binary;

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

	if forum_idx ^= 0 then			/* close whatever's opened */
	     call forum_$close_forum (forum_idx, (0));
	forum_idx = 0;

	if mailbox_idx ^= 0 then call mailbox_$close (mailbox_idx, (0));
	mailbox_idx = 0;

	if n_message_buffers_used > 0 then do;		/* get rid of any temporary segments */
	     do idx = 1 to n_message_buffers_used;
		if message_buffers (idx) ^= null () then
		     if baseno (message_buffers (idx)) ^= baseno (stackframeptr ()) then
			if wordno (message_buffers (idx)) = 0 then
			     call mlsys_storage_mgr_$release_temp_segment (message_buffers (idx), (0));
		message_buffers (idx) = null ();
	     end;
	end;
	n_message_buffers_used = 0;

	if mlsys_mailer_data_ptr ^= null () then
	     if baseno (mlsys_mailer_data_ptr) ^= baseno (stackframeptr ()) then
		call mlsys_storage_mgr_$release_temp_segment (mlsys_mailer_data_ptr, (0));
	mlsys_mailer_data_ptr = null ();

	if ism_recipient_idxs_ptr ^= null () then
	     if baseno (ism_recipient_idxs_ptr) ^= baseno (stackframeptr ()) then
		call mlsys_storage_mgr_$release_temp_segment (ism_recipient_idxs_ptr, (0));
	ism_recipient_idxs_ptr = null ();

	if current_mailing_list_data_ptr ^= null () then do;
	     do mailing_list_data_ptr = current_mailing_list_data_ptr repeat (mailing_list_data.previous_data_ptr)
		while (mailing_list_data_ptr ^= null ());
		if mailing_list_data.mls_ptr ^= null () then
		     call terminate_file_ (mailing_list_data.mls_ptr, 0, TERM_FILE_TERM, (0));
	     end;
	end;
	current_mailing_list_data_ptr = null ();

	if recipients_list_ptr ^= null () then do;
	     do idx = 1 to n_recipients;		/* close any mailboxes/forums ... */
		recipient_ptr = addr (recipients_list.recipients (idx));
		if (recipient.address_ptr ^= null ()) & recipient.free_address then
		     call mlsys_address_mgr_$decrement_reference_count (recipient.address_ptr);
		if recipient.local_info.forum_idx ^= 0 then
		     call forum_$close_forum (recipient.local_info.forum_idx, (0));
		if recipient.local_info.mailbox_idx ^= 0 then
		     call mailbox_$close (recipient.local_info.mailbox_idx, (0));
		recipient.local_info.mailbox_idx, recipient.local_info.forum_idx = 0;
	     end;
	     if baseno (recipients_list_ptr) ^= baseno (stackframeptr ()) then
		call mlsys_storage_mgr_$release_temp_segment (recipients_list_ptr, (0));
	end;					/* ... flush the list of recipients itself if needed */
	recipients_list_ptr = null ();

	call restore_message_state ();		/* restore the message to its state on entry to this module */

     end cleanup_message_delivery;
%page;
/* Saves the state of the message on entry to this module so that it can be restored on exit or cleanup */

save_message_state:
     procedure ();

	if message_ptr = null () then return;

	saved_message_data = message, by name;		/* copy data which we might have to change */

	added_from_field,				/* we haven't added anything yet */
	     added_reply_to_field, added_envelope, added_redistribution = "0"b;
	deleted_last_delivery_fields = "0"b;		/* we haven't deleted anything either */

	return;

     end save_message_state;



/* Restores the state of the message to what it was on entry to this module */

restore_message_state:
     procedure ();

	if message_ptr = null () then return;

	message = saved_message_data, by name;		/* restore the data added by a simple copy */

	if added_from_field then			/* From field was empty: we added a single address ... */
	     call mlsys_address_list_mgr_$delete_address (message.from, 1, (0));
	added_from_field = "0"b;			/* don't do it again */

	if added_reply_to_field then			/* From field was empty and we added a single address ... */
	     call mlsys_address_list_mgr_$delete_address (message.reply_to, 1, (0));
	added_reply_to_field = "0"b;

	if added_envelope then do;			/* we had to add an envelope (new message only) ... */
	     local_mep.version = MESSAGE_ENVELOPE_PARAMETER_VERSION_2;
	     local_mep.date_time_mailed, local_mep.date_time_delivered = 0;
	     local_mep.sender, local_mep.trace, local_mep.delivered_by, local_mep.acknowledge_to = null ();
	     call mlsys_message_mgr_$replace_message_envelope (message_ptr, addr (local_mep), (0));
	end;
	added_envelope = "0"b;

	if added_redistribution then			/* we added the last redistribution to the message */
	     call mlsys_message_mgr_$delete_redistribution (message_ptr, message.n_redistributions, (0));
	added_redistribution = "0"b;

	if deleted_last_delivery_fields then		/* we deleted the last Delivery-Date and Delivery-By fields */
	     call add_last_delivery_fields ();

	return;

     end restore_message_state;
%page;
/* Supplies appropriate values for those fields of a new message which may not have been set by the user (or which cannot
   be set by the user (eg: Date)) */

complete_new_message:
     procedure ();

dcl  users_address pointer;
dcl  all_invalid bit (1) aligned;
dcl  code fixed binary (35);
dcl  (address_type, idx) fixed binary;

	call mlsys_address_mgr_$get_address_type (mlsys_data_$user_mail_table_address, address_type, (0));
	if address_type ^= MAIL_TABLE_ADDRESS then	/* ... mail table address isn't usable: anonymous user(?) */
	     users_address = mlsys_data_$user_default_mailbox_address;
	else do;					/* ... make sure mail table address can receive mail */
	     call validate_address (mlsys_data_$user_mail_table_address, "0"b, code);
	     if code = 0 then			/* ... and it can */
		users_address = mlsys_data_$user_mail_table_address;
	     else users_address = mlsys_data_$user_default_mailbox_address;
	end;

	message.date_time_created = date_time_message_created;
						/* set date/time created to time the body was last updated */

	call mlsys_message_id_mgr_$encode_local_id (message.date_time_created, message.message_id);

	if is_empty_list (message.from) then do;	/* no From field: default to the user ... */
	     if message.from = null () then do;
		call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, message.from, (0))
		     ;
		call mlsys_address_list_mgr_$increment_reference_count (message.from);
	     end;
	     call mlsys_address_list_mgr_$add_address (message.from, users_address, ADDRESS_LIST_VERSION_2, (0));
	     added_from_field = "1"b;
	end;

	else					/* From field supplied by the user ... */
	     if is_empty_list (message.reply_to) then do; /* ... but no Reply-To field ... */
	     all_invalid = "1"b;			/* ... so add one if all From addresses are invalid */
	     do idx = 1 to message.from -> address_list.n_addresses while (all_invalid);
		call validate_address (message.from -> address_list.addresses (idx), "0"b, code);
		all_invalid = (code ^= 0);		/* ... stops at first valid address */
	     end;
	     if all_invalid then do;
		if message.reply_to = null () then do;
		     call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2,
			message.reply_to, (0));
		     call mlsys_address_list_mgr_$increment_reference_count (message.reply_to);
		end;
		call mlsys_address_list_mgr_$add_address (message.reply_to, users_address, ADDRESS_LIST_VERSION_2,
		     (0));
		added_reply_to_field = "1"b;
	     end;
	end;

	local_mep.version = MESSAGE_ENVELOPE_PARAMETER_VERSION_2;
	local_mep.date_time_mailed = clock ();		/* Posted-Date is now */
	local_mep.sender = users_address;		/* Sender is this user (formatting eliminates redundancies) */
	local_mep.trace = null ();			/* local origin: no trace */
	local_mep.date_time_delivered = 0;		/* Delivery-Date is set by receiving system ... */
	local_mep.delivered_by = null ();		/* ... and the same goes for Delivery-By */
	if deliver_options.acknowledge then		/* caller wants an acknowledgment ... */
	     local_mep.acknowledge_to = users_address;	/* ... but can not yet specify to whom */
	else local_mep.acknowledge_to = null ();
	call mlsys_message_mgr_$replace_message_envelope (message_ptr, addr (local_mep), (0));
	added_envelope = "1"b;			/* don't forget to get rid of it when we're done */

	return;

     end complete_new_message;
%page;
/* Adds the description of this redistribution to the message */

add_redistribution:
     procedure ();

dcl  users_address pointer;
dcl  (address_type, idx) fixed binary;

	call mlsys_address_mgr_$get_address_type (mlsys_data_$user_mail_table_address, address_type, (0));
	if address_type ^= MAIL_TABLE_ADDRESS then	/* ... mail table address isn't usable: anonymous user(?) */
	     users_address = mlsys_data_$user_default_mailbox_address;
	else do;					/* ... make sure mail table address can receive mail */
	     call validate_address (mlsys_data_$user_mail_table_address, "0"b, code);
	     if code = 0 then			/* ... and it can */
		users_address = mlsys_data_$user_mail_table_address;
	     else users_address = mlsys_data_$user_default_mailbox_address;
	end;

	local_mrp.version = MESSAGE_REDISTRIBUTION_PARAMETER_VERSION_2;

	local_mrp.date_time_created = clock ();		/* Redistributed-Date is now */
	call mlsys_message_id_mgr_$encode_local_id (local_mrp.date_time_created, local_mrp.message_id);

	call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, local_mrp.from, (0));
	call mlsys_address_list_mgr_$add_address (local_mrp.from, users_address, ADDRESS_LIST_VERSION_2, (0));
						/* Redistributed-From is this user */

	call mlsys_address_list_mgr_$create_read_only_address_list (ADDRESS_LIST_VERSION_2, local_mrp.to, (0));
	do idx = 1 to recipients_info.n_lists;
	     call mlsys_address_list_mgr_$merge_address_lists (recipients_info.lists (idx).address_list_ptr,
		local_mrp.to, "1"b, local_mrp.to, (0));
	end;

	local_mrp.envelope.date_time_mailed = local_mrp.date_time_created;
						/* Redistributed-Posted-Date is the same as above */
	local_mrp.envelope.sender = null ();		/* Redistributed-Sender is the same as Redistributed-From */

	local_mrp.envelope.trace = null ();		/* local origin: no trace */

	local_mrp.date_time_delivered = 0;		/* Redistributed-Delivery-Date is set by receiving system */
	local_mrp.delivered_by = null ();		/* ... and the same goes for Redistributed-Delivery-By */

	if deliver_options.acknowledge then		/* caller wants an acknowledgment ... */
	     local_mrp.acknowledge_to = users_address;	/* ... but can not yet specify to whom */
	else local_mrp.acknowledge_to = null ();

	if P_redistribution_comment ^= "" then do;	/* caller supplied a Redistributed-Comment field */
	     local_mrp.comment.text_ptr = addr (P_redistribution_comment);
	     local_mrp.comment.text_lth = length (P_redistribution_comment);
	end;
	else do;					/* no comment */
	     local_mrp.comment.text_ptr = null ();
	     local_mrp.comment.text_lth = 0;
	end;
	local_mrp.comment.multiline_text = "1"b;	/* don't really need to set this ... */

	call mlsys_message_mgr_$add_redistribution (message_ptr, addr (local_mrp), (-1), (0));
	call mlsys_address_list_mgr_$free_address_list (local_mrp.from, (0));
	call mlsys_address_list_mgr_$free_address_list (local_mrp.to, (0));

	added_redistribution = "1"b;			/* get rid of it when we're done */

	return;

     end add_redistribution;
%page;
/* Deletes the last Delivery-Date and Delivery-By fields from an in-mailbox message which is about to be logged, saved, or
   copied:  These fields must be deleted as they will be overidden by the values obtained from the ring-1 mailbox
   primitives after the message is retransmitted */

delete_last_delivery_fields:
     procedure ();

	if message.n_redistributions = 0 then		/* last fields are in the envelope */
	     message_envelope_ptr = addr (message.envelope);
	else do;					/* last fields are in the last redistribution */
	     message_redistribution_ptr =
		addr (message_redistributions_list.redistributions (message.n_redistributions));
	     message_envelope_ptr = addr (message_redistribution.envelope);
	end;

	last_delivered_by = message_envelope.delivered_by;/* save the current values ... */
	last_date_time_delivered = message_envelope.date_time_delivered;

	deleted_last_delivery_fields = "1"b;		/* now OK to restore in the cleanup handler */

	message_envelope.delivered_by = null ();	/* delete the fields ... */
	message_envelope.date_time_delivered = 0;

	return;

     end delete_last_delivery_fields;



/* Adds the last Delivery-Date and Delivery-By fields back into the message */

add_last_delivery_fields:
     procedure ();

	if message.n_redistributions = 0 then		/* last fields are in the envelope */
	     message_envelope_ptr = addr (message.envelope);
	else do;					/* last fields are in the last redistribution */
	     message_redistribution_ptr =
		addr (message_redistributions_list.redistributions (message.n_redistributions));
	     message_envelope_ptr = addr (message_redistribution.envelope);
	end;

	message_envelope.delivered_by = last_delivered_by;/* restore the saved values ... */
	message_envelope.date_time_delivered = last_date_time_delivered;

	deleted_last_delivery_fields = "0"b;		/* no need to do it twice */

	return;

     end add_last_delivery_fields;
%page;
/* Validates that mail can be sent to the given address:  If the address is a mailing list or named group, the list will
   be expanded and each address in the list will be validated/expanded */

validate_or_expand_address:
     procedure (p_address_ptr, p_top_level_address, p_exclude_bcc_field, p_expand_mailing_lists, p_validate_only);

dcl  p_address_ptr pointer parameter;
dcl  p_top_level_address bit (1) aligned parameter;
dcl  p_exclude_bcc_field bit (1) aligned parameter;
dcl  p_expand_mailing_lists bit (1) aligned parameter;
dcl  p_validate_only bit (1) aligned parameter;

dcl  1 local_mld aligned like mailing_list_data;

dcl  (address_ptr, list_expansion_ptr, new_recipients_list_ptr) pointer;
dcl  address_pathname character (200);
dcl  address_dirname character (168);
dcl  address_string character (128) varying;
dcl  (address_ename, address_component) character (32);
dcl  (mail_table_expansion, use_copy_without_bcc) bit (1) aligned;
dcl  code fixed binary (35);
dcl  (address_type, n_recipients_before_expansion, idx) fixed binary;


	use_copy_without_bcc = "0"b;			/* only gets used before actual setting if invalid address */
	mail_table_expansion = "0"b;			/* until proven otherwise */


/* Get the type of address: insures that all local addresses are properly recognized and resolves mail table addresses to
   the actual value in the mail table */

	call mlsys_address_mgr_$check_if_actually_local (p_address_ptr);

	call mlsys_address_mgr_$get_address_type (p_address_ptr, address_type, (0));

	if address_type = MAIL_TABLE_ADDRESS then do;	/* look it up in the mail table right now */
	     call mlsys_address_mgr_$get_mail_table_address (p_address_ptr, address_ptr, code);
	     if code = 0 then do;			/* ... found it: get the actual address type */
		call mlsys_address_mgr_$get_address_type (address_ptr, address_type, (0));
		mail_table_expansion = "1"b;		/* ... and be sure the address gets freed on cleanup */
	     end;
	     else do;				/* ... couldn't find it */
		call add_recipient (p_address_ptr, UNKNOWN_RECIPIENT);
		recipient.fatal_error = "1"b;		/* ... record the exact problem (mte_not_found) */
		recipient.code = code;
		return;
	     end;
	end;

	else address_ptr = p_address_ptr;

	on condition (cleanup)
	     begin;
	     if mail_table_expansion & (address_ptr ^= null ()) then
		call mlsys_address_mgr_$free_address (address_ptr, (0));
	end;
%page;
/* If this is one of the addresses supplied by the caller and the bcc field should be suppressed for primary/secondary
   recipients, determine whether this address or its expansion should have the bcc field suppressed */

	if p_top_level_address & suppress_bcc_field_when_necessary then do;
	     if ^is_empty_list (message.to) then do;
		do idx = 1 to message.to -> address_list.n_addresses while (^use_copy_without_bcc);
		     if mlsys_address_mgr_$compare_addresses (address_ptr, message.to -> address_list.addresses (idx),
			(0)) then
			use_copy_without_bcc = "1"b;
		end;
	     end;
	     if ^use_copy_without_bcc & ^is_empty_list (message.cc) then do;
		do idx = 1 to message.cc -> address_list.n_addresses while (^use_copy_without_bcc);
		     if mlsys_address_mgr_$compare_addresses (address_ptr, message.cc -> address_list.addresses (idx),
			(0)) then
			use_copy_without_bcc = "1"b;
		end;
	     end;
	     make_copies_with_bcc = make_copies_with_bcc | ^use_copy_without_bcc;
	     make_copies_without_bcc = make_copies_without_bcc | use_copy_without_bcc;
	end;

	else if p_top_level_address then		/* always include the bcc field */
	     make_copies_with_bcc = "1"b;

	else use_copy_without_bcc = p_exclude_bcc_field;


/* Now validate or expand the address as appropriate */

	go to VALIDATE_OR_EXPAND_ADDRESS (address_type);



/* Invalid address */

VALIDATE_OR_EXPAND_ADDRESS (0):
	call add_recipient (address_ptr, UNKNOWN_RECIPIENT);
	recipient.fatal_error = "1"b;
	recipient.code = mlsys_et_$invalid_address;
	return;
%page;
/* Addresses which resolve to a mailbox */

VALIDATE_OR_EXPAND_ADDRESS (1):			/* user mailbox address */
VALIDATE_OR_EXPAND_ADDRESS (2):			/* logbox address */
VALIDATE_OR_EXPAND_ADDRESS (3):			/* savebox address */
VALIDATE_OR_EXPAND_ADDRESS (4):			/* mailbox address */
	call add_recipient (address_ptr, MAILBOX_RECIPIENT);

	if deliver_options.acknowledge then		/* never ask for an ACK is sending to ourself */
	     if (address_type = LOGBOX_ADDRESS) | (address_type = SAVEBOX_ADDRESS) then
		recipient.no_acknowledge = "1"b;
	     else do;
		recipient.no_acknowledge =
		     mlsys_address_mgr_$compare_addresses (address_ptr, mlsys_data_$user_default_mailbox_address, (0))
		     ;
		if ^recipient.no_acknowledge then
		     recipient.no_acknowledge =
			mlsys_address_mgr_$compare_addresses (address_ptr, mlsys_data_$user_mail_table_address, (0))
			;
	     end;

	call mlsys_address_mgr_$get_address_pathname (address_ptr, address_dirname, address_ename, ((32)" "), (0));
						/* this call has to work */

	if p_validate_only then do;
	     /*** validate_address: Don't bother opening the mailbox; just check the user's access */
	     call mailbox_$get_mode_file (address_dirname, address_ename, mailbox_mode, code);
	     if code = error_table_$noentry then code = mlsys_et_$no_mailbox;
	     if code = 0 then			/* ... got the access */
		if (mailbox_mode & A_MBX_ACCESS) = A_MBX_ACCESS then
		     ;				/* ... and it's OK */
		else do;				/* ... can't append messages */
		     recipient.fatal_error = "1"b;
		     recipient.code = mlsys_et_$no_a_permission;
		end;
	     else if (code = error_table_$logical_volume_not_defined)
		| (code = error_table_$logical_volume_not_connected) then
		;				/* ... mailbox temporarily unavailable: assume it's OK */
	     else do;				/* ... can't get the user's access */
		recipient.fatal_error = "1"b;
		recipient.code = code;
	     end;
	     return;
	end;

	call mailbox_$open (address_dirname, address_ename, mailbox_idx, code);
	if code = error_table_$moderr then code = mlsys_et_$no_a_permission;
	if code = error_table_$noentry then code = mlsys_et_$no_mailbox;

	if code = 0 then do;
	     /*** Mailbox exists and we have non-null access */
	     call mailbox_$get_mode_index (mailbox_idx, mailbox_mode, (0));

	     if (mailbox_mode & A_MBX_ACCESS) ^= A_MBX_ACCESS then do;
		/*** ... but we don't have append permission */
		recipient.fatal_error = "1"b;
		recipient.code = mlsys_et_$no_a_permission;
		call mailbox_$close (mailbox_idx, (0));
		mailbox_idx = 0;
	     end;

	     else if deliver_options.delivery_mode = ORDINARY_DELIVERY then
		/*** ... all we need for ordinary delivery is append permission */
		recipient.local_info.mailbox_idx = mailbox_idx;

	     else do;
		/*** ... interactive/express delivery: check for appropriate access */
		call send_test_message (mailbox_idx, code);
		if code = 0 then			/* ... we can send the interactive message */
		     recipient.local_info.mailbox_idx = mailbox_idx;
		else do;				/* ... either fatal or a warning */
		     recipient.code = code;
		     if code = error_table_$ai_restricted then do;
			/*** Only happens for writing "down" without privileges: fatal to entire operation */
			P_code = error_table_$ai_restricted;
			go to RETURN_FROM_TRANSMIT_WITH_FATAL_ERROR;
		     end;				/* ... we should have got this sooner, but ... */
		     if deliver_options.delivery_mode = INTERACTIVE_DELIVERY then
			if (code = error_table_$messages_off) | (code = error_table_$messages_deferred)
			     | (code = error_table_$wakeup_denied) then
			     recipient.warning = "1"b;
			else recipient.fatal_error = "1"b;
		     else /*** if deliver_options.delivery_mode = EXPRESS_DELIVERY then */
			recipient.fatal_error = "1"b;
		     if recipient.fatal_error then do;	/* ... it was fatal: close the mailbox */
			call mailbox_$close (mailbox_idx, (0));
			mailbox_idx = 0;
		     end;
		     else recipient.local_info.mailbox_idx = mailbox_idx;
		end;
	     end;
	end;

	else if (code = error_table_$logical_volume_not_defined) | (code = error_table_$logical_volume_not_connected)
	then do;
	     /*** Mailbox is on a logical volume which isn't available right now: a transient error */
	     if deliver_options.queueing_mode = ALWAYS_QUEUE then go to QUEUE_THE_MAILBOX;
	     recipient.transient_error = "1"b;
	     recipient.code = code;
	end;

	else do;
	     /*** Mailbox doesn't exist or we have only null access */
	     recipient.fatal_error = "1"b;
	     recipient.code = code;
	end;

	mailbox_idx = 0;				/* don't let cleanup handler near it */

	if (deliver_options.queueing_mode = ALWAYS_QUEUE) & (recipient.local_info.mailbox_idx ^= 0) then do;
	     call mailbox_$close (recipient.local_info.mailbox_idx, (0));
	     recipient.local_info.mailbox_idx = 0;	/* don't keep the mailbox open if we're going to queue it */
QUEUE_THE_MAILBOX:					/* ... control arrives here from LV not being available */
	     address_pathname = pathname_ (address_dirname, address_ename);
	     recipient.foreign_address = rtrim (address_pathname);
	     if recipient.foreign_address = address_pathname then
		recipient.to_queue = "1"b;		/* ... pathname isn't too long for mlsys_mailer_ */
	     else do;				/* ... sigh */
		recipient.fatal_error = "1"b;
		recipient.code = mlsys_et_$address_pathname_too_long_to_q;
	     end;
	end;

	need_mailbox_message = need_mailbox_message | ^recipient.fatal_error;

	return;
%page;
/* Forum meeting address */

VALIDATE_OR_EXPAND_ADDRESS (5):
	call add_recipient (address_ptr, FORUM_RECIPIENT);
	recipient.no_acknowledge = "1"b;		/* ... not that we'll even try */

	if mlsys_psp_$forum_not_available () then do;	/* Forum (a PSP) wasn't purchased by this site */
	     recipient.fatal_error = "1"b;
	     if get_ring_ () < mlsys_data_$lowest_forum_ring then
		recipient.code = mlsys_et_$no_forum_this_ring;
	     else recipient.code = mlsys_et_$forum_not_available;
	     return;
	end;

	call mlsys_address_mgr_$get_address_pathname (address_ptr, address_dirname, address_ename, ((32)" "), (0));
						/* this call has to work */
	if address_dirname = "" then do;		/* a forum meeting which couldn't be found by search list */
	     recipient.fatal_error = "1"b;
	     recipient.code = forum_error_table_$not_in_search_list;
	     return;
	end;

	call forum_$open_forum (address_dirname, address_ename, forum_idx, code);

	if code = 0 then do;
	     /*** Forum meeting exists and we are a participant */
	     call forum_$real_forum_limits (forum_idx, ONLY_UNDELETED, (0), (0), (0), (0), forum_flags_word, (0));

	     if forum_flags.read_only then do;
		/*** ... but the user can't enter transactions */
		recipient.fatal_error = "1"b;
		recipient.code = forum_error_table_$read_only;
		call forum_$close_forum (forum_idx, (0));
		forum_idx = 0;
	     end;

	     else /*** ... user can enter the transaction: address is OK */
		recipient.local_info.forum_idx = forum_idx;
	end;

	else if (code = error_table_$logical_volume_not_defined) | (code = error_table_$logical_volume_not_connected)
	then do;
	     /*** Forum is on a logical volume which isn't available right now: a transient error */
	     if deliver_options.queueing_mode = ALWAYS_QUEUE then go to QUEUE_THE_FORUM;
	     recipient.transient_error = "1"b;
	     recipient.code = code;
	end;

	else do;
	     /*** Forum doesn't exist or we aren't a participant */
	     recipient.fatal_error = "1"b;
	     recipient.code = code;
	end;

	forum_idx = 0;				/* don't let cleanup handler near it */

	if (deliver_options.queueing_mode = ALWAYS_QUEUE) & (recipient.local_info.forum_idx ^= 0) then do;
	     call forum_$close_forum (recipient.local_info.forum_idx, (0));
	     recipient.local_info.forum_idx = 0;	/* don't keep the mailbox open if we're going to queue it */
QUEUE_THE_FORUM:					/* ... control arrives here from LV not being available */
	     address_pathname = pathname_ (address_dirname, address_ename);
	     recipient.foreign_address = rtrim (address_pathname);
	     if recipient.foreign_address = address_pathname then
		recipient.to_queue = "1"b;		/* ... pathname isn't too long for mlsys_mailer_ */
	     else do;				/* ... sigh */
		recipient.fatal_error = "1"b;
		recipient.code = mlsys_et_$address_pathname_too_long_to_q;
	     end;
	end;

	need_forum_message = need_forum_message | ^recipient.fatal_error;

	return;
%page;
/* Foreign address:  Computes the route to be used to deliver the message and then constructs the foreign "user name" and
   the system name to be used when calling the interim inter-system mailer (mlsys_mailer_).  Unfortunately, mlsys_mailer_
   imposes an arbitrary limit of 128 characters on the "user name" and 40 characters on the system name; these limits are
   enforced here as mlsys_mailer_ doesn't even bother to check for truncated names */

VALIDATE_OR_EXPAND_ADDRESS (6):
	call add_recipient (address_ptr, NETWORK_RECIPIENT);
	recipient.no_acknowledge = "1"b;		/* ... acknowledgements aren't supported across networks */

	if mlsys_psp_$ism_not_available () then do;	/* no inter-system mailer on this site */
	     recipient.fatal_error = "1"b;
	     recipient.code = mlsys_et_$ism_not_available;
	     return;
	end;

	address_route_ptr = null ();			/* for cleaning up */

	call mlsys_address_route_mgr_$compute_route (address_ptr, address_route_ptr, code);

	if code = 0 then do;
	     /*** A possible route for sending mail to the foreign system has been determined ... */
	     call mlsys_address_mgr_$get_address_string (address_ptr, address_string, code);

	     if code = 0 then do;
		/*** ... and the unquoted user name isn't too long: construct proper user and system names */
		call mlsys_format_$format_address_for_ism (address_string, address_route_ptr,
		     recipient.foreign_address, recipient.foreign_system, code);
		if code ^= 0 then do;		/* ... user/system name is too long if properly formatted */
		     recipient.fatal_error = "1"b;
		     recipient.code = code;
		end;
	     end;

	     else do;
		/*** ... but the unquoted user name is too long */
		recipient.fatal_error = "1"b;
		recipient.code = mlsys_et_$foreign_address_too_long;
	     end;
	end;

	else do;
	     /*** Can't get there from here: the local system may not have the interim inter-system mailer */
	     recipient.fatal_error = "1"b;
	     recipient.code = code;
	end;

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

	recipient.to_queue = (deliver_options.queueing_mode >= ALWAYS_QUEUE_FOREIGN);
	need_network_message = need_network_message | ^recipient.fatal_error;

	return;


/* Mail table address */

VALIDATE_OR_EXPAND_ADDRESS (7):
	return;					/* ... won't ever get here */
%page;
/* Mailing list address: check for recursive mailing lists before actually expanding the list */

VALIDATE_OR_EXPAND_ADDRESS (8):
	call add_recipient (address_ptr, NETWORK_RECIPIENT);
	recipient.no_acknowledge = "1"b;		/* it won't really make any difference */
	address_ptr = null ();			/* prevents cleanup handler from freeing this address */

	list_expansion_ptr = null ();			/* for common exit code */

	/*** Add another entry to the stack of mailing lists presently under expansion */
	local_mld.previous_data_ptr = current_mailing_list_data_ptr;
	local_mld.mls_ptr = null ();
	current_mailing_list_data_ptr = addr (local_mld);

	on condition (cleanup)
	     begin;
	     if local_mld.mls_ptr ^= null () then call terminate_file_ (local_mld.mls_ptr, 0, TERM_FILE_TERM, (0));
	     if mail_table_expansion & (address_ptr ^= null ()) then
		call mlsys_address_mgr_$free_address (address_ptr, (0));
	end;

	/*** Determine whether or not the mailing list actually exists */
	call mlsys_address_mgr_$get_address_pathname (recipient.address_ptr, address_dirname, address_ename,
	     address_component, (0));			/* this call has to work */

	call initiate_file_$component (address_dirname, address_ename, address_component, R_ACCESS, local_mld.mls_ptr,
	     (0), code);
	if (code = error_table_$noentry) | (code = error_table_$no_component) then code = mlsys_et_$no_mailing_list;

	if code = 0 then do;
	     /*** Mailing list exists and user can access it: check for recursion */
	     do mailing_list_data_ptr = local_mld.previous_data_ptr repeat (mailing_list_data.previous_data_ptr)
		while (mailing_list_data_ptr ^= null ());
		if local_mld.mls_ptr = mailing_list_data.mls_ptr then do;
		     n_recipients = n_recipients - 1;	/* not to be expanded: be sure it's not counted */
		     address_ptr = recipient.address_ptr;
		     go to RETURN_FROM_EXPAND_LIST_ADDRESS;
		end;
	     end;
	end;

	else if (code = error_table_$logical_volume_not_defined) | (code = error_table_$logical_volume_not_connected)
	then do;
	     /*** Mailing list is on a logical volume which isn't available right now: a transient error */
	     if deliver_options.queue_mailing_lists | (deliver_options.queueing_mode = ALWAYS_QUEUE) then
		go to QUEUE_THE_MAILING_LIST;
	     recipient.transient_error = "1"b;
	     recipient.code = code;
	     go to RETURN_FROM_EXPAND_LIST_ADDRESS;
	end;

	else do;
	     /*** Mailing list doesn't exist or user can't access it */
	     recipient.fatal_error = "1"b;		/* ... record the exact problem */
	     recipient.code = code;
	     go to RETURN_FROM_EXPAND_LIST_ADDRESS;
	end;

	/*** Control arrives here iff the mailing list exists and isn't part of a circular list */

	if ^p_expand_mailing_lists then		/* just checking for its existence */
	     go to RETURN_FROM_EXPAND_LIST_ADDRESS;

	if deliver_options.queue_mailing_lists | (deliver_options.queueing_mode = ALWAYS_QUEUE) then do;
	     /*** Mail will be queued for this list: won't bother to expand it */
QUEUE_THE_MAILING_LIST:
	     if mlsys_psp_$ism_not_available () then do;	/* no inter-system mailer to handle the queueing */
		recipient.fatal_error = "1"b;
		recipient.code = mlsys_et_$ism_not_available;
	     end;
	     else if address_component = "" then do;	/* the list is in a segment ... */
		address_pathname = pathname_ (address_dirname, address_ename);
		recipient.foreign_address = rtrim (address_pathname);
		if recipient.foreign_address = address_pathname then do;
		     need_network_message = "1"b;	/* ... so use the copy formatted for network transmission */
		     recipient.to_queue = "1"b;
		end;
		else do;				/* ... but the pathname is too long for mlsys_mailer_ */
		     recipient.fatal_error = "1"b;
		     recipient.code = mlsys_et_$address_pathname_too_long_to_q;
		end;
	     end;
	     else do;				/* the list is an archive component ... */
		recipient.fatal_error = "1"b;		/* ... mlsys_mailer_ doesn't understand them yet */
		recipient.code = mlsys_et_$cant_queue_mls_in_archive;
	     end;
	     go to RETURN_FROM_EXPAND_LIST_ADDRESS;
	end;

	go to EXPAND_LIST_ADDRESS;			/* expand the list */
%page;
/* Named group address */

VALIDATE_OR_EXPAND_ADDRESS (9):
	call add_recipient (address_ptr, NETWORK_RECIPIENT);
	recipient.no_acknowledge = "1"b;		/* it won't really make any difference */
	address_ptr = null ();			/* prevents cleanup handler from freeing this address */

	local_mld.previous_data_ptr = current_mailing_list_data_ptr;
	local_mld.mls_ptr = null ();			/* makes code shared with mailing lists work properly */


/* Expand the contents of a mailing list of named group */

EXPAND_LIST_ADDRESS:
	list_expansion_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
	     if local_mld.mls_ptr ^= null () then call terminate_file_ (local_mld.mls_ptr, 0, TERM_FILE_TERM, (0));
	     if list_expansion_ptr ^= null () then
		call mlsys_address_list_mgr_$free_address_list (list_expansion_ptr, (0));
	     if mail_table_expansion & (address_ptr ^= null ()) then
		call mlsys_address_mgr_$free_address (address_ptr, (0));
	end;

	call mlsys_address_mgr_$expand_list_address (recipient.address_ptr, ADDRESS_LIST_VERSION_2, list_expansion_ptr,
	     code);
	if code ^= 0 then do;			/* ... won't expand properly */
	     recipient.fatal_error = "1"b;		/* ... record the exact problem */
	     recipient.code = code;
	     go to RETURN_FROM_EXPAND_LIST_ADDRESS;
	end;

	n_recipients = n_recipients - 1;		/* won't need the recipient for the list address itself */
	address_ptr = recipient.address_ptr;		/* be sure that cleanup gets rid of this address now */

	n_recipients_before_expansion = n_recipients;	/* in order to check for empty lists */

	if ^is_empty_list (list_expansion_ptr) then do;
	     do idx = 1 to list_expansion_ptr -> address_list.n_addresses;
		call validate_or_expand_address (list_expansion_ptr -> address_list.addresses (idx), "0"b,
		     use_copy_without_bcc, p_expand_mailing_lists, p_validate_only);
	     end;
	end;

	if n_recipients = n_recipients_before_expansion then
	     /*** Empty mailing list or named group: complain about empty top level mailing lists only */
	     if (address_type = MAILING_LIST_ADDRESS) & p_top_level_address then do;
		code = mlsys_et_$empty_mailing_list;
		call add_recipient (address_ptr, NETWORK_RECIPIENT);
		address_ptr = null ();		/* ... prevents cleanup from freeing this address */
		recipient.fatal_error = "1"b;		/* ... record the exact problem */
		recipient.code = code;
	     end;

RETURN_FROM_EXPAND_LIST_ADDRESS:
	if list_expansion_ptr ^= null () then call mlsys_address_list_mgr_$free_address_list (list_expansion_ptr, (0));
	if mail_table_expansion & (address_ptr ^= null ()) then call mlsys_address_mgr_$free_address (address_ptr, (0));

	if local_mld.mls_ptr ^= null () then call terminate_file_ (local_mld.mls_ptr, 0, TERM_FILE_TERM, (0));
	current_mailing_list_data_ptr = local_mld.previous_data_ptr;

	return;
%page;
/* Internal to validate_or_expand_address: adds another address to the list of recipients */

add_recipient:
	procedure (p_address_ptr, p_recipient_type);

dcl  p_address_ptr pointer parameter;
dcl  p_recipient_type fixed binary parameter;

	     if n_recipients = n_recipients_allocated then
		/*** ... not enough room left in present list: switch to temporary segment if possible */
		if baseno (recipients_list_ptr) = baseno (stackframeptr ()) then do;
		     call mlsys_storage_mgr_$get_temp_segment (new_recipients_list_ptr, code);
		     if code ^= 0 then do;		/* ... can't get a temporary segment for the list */
			P_code = code;
			go to RETURN_FROM_TRANSMIT_WITH_FATAL_ERROR;
		     end;
		     do idx = 1 to n_recipients;
			new_recipients_list_ptr -> recipients_list.recipients (idx) =
			     recipients_list.recipients (idx);
		     end;
		     recipients_list_ptr = new_recipients_list_ptr;
		     n_recipients_allocated = divide (sys_info$max_seg_size, recipient_size, 18, 0);
		end;
		else do;				/* ... ran out of room in the temporary segment */
		     P_code = mlsys_et_$too_many_recipients;
		     go to RETURN_FROM_TRANSMIT_WITH_FATAL_ERROR;
		end;

	     n_recipients = n_recipients + 1;		/* must always count so mailing list validation will work */
	     recipient_ptr = addr (recipients_list.recipients (n_recipients));

	     recipient.address_ptr = p_address_ptr;
	     if ^p_top_level_address then		/* need to hold on to it after its containing list is freed */
		call mlsys_address_mgr_$increment_reference_count (recipient.address_ptr);

	     string (recipient.flags) = ""b;
	     recipient.top_level = p_top_level_address;
	     recipient.free_address = ^p_top_level_address | mail_table_expansion;
	     recipient.use_copy_without_bcc = use_copy_without_bcc;
	     recipient.type = p_recipient_type;
	     recipient.top_level_info.list_idx = the_list_idx;
	     recipient.top_level_info.address_idx = the_address_idx;
	     recipient.duplicate_idx = 0;
	     recipient.local_info.mailbox_idx, recipient.local_info.forum_idx = 0;
	     recipient.foreign_info.foreign_address, recipient.foreign_info.foreign_system = "";
	     recipient.code = 0;			/* haven't actually tried to validate it yet */
	     recipient.explanation = "";

	     return;

	end add_recipient;

     end validate_or_expand_address;
%page;
/* Marks all duplicate recipients:  Care must be taken that a top-level recipient is never marked as the duplicate of an
   expanded recipient; instead, the expanded recipient must be marked as the duplicate */

mark_duplicate_recipients:
     procedure ();

dcl  1 other_recipient aligned based (other_recipient_ptr) like recipient;
dcl  other_recipient_ptr pointer;
dcl  (recipient_idx, other_recipient_idx, idx) fixed binary;


	do recipient_idx = 1 to n_recipients;

	     recipient_ptr = addr (recipients_list.recipients (recipient_idx));

	     do other_recipient_idx = 1 to (recipient_idx - 1) while (^recipient.duplicate);
		other_recipient_ptr = addr (recipients_list.recipients (other_recipient_idx));
		if (other_recipient.mailbox_idx ^= 0) & (other_recipient.mailbox_idx = recipient.mailbox_idx) then do;
MARK_RECIPIENT_AS_A_DUPLICATE:
		     if recipient.top_level & ^other_recipient.top_level then do;
			/*** Other recipient is part of a list expansion and we aren't: mark it as our duplicate */
			do idx = 1 to (recipient_idx - 1);
			     /*** ... change all duplicates of the other recipient to be our duplicates */
			     if recipients_list.recipients (idx).duplicate_idx = other_recipient_idx then
				recipients_list.recipients (idx).duplicate_idx = recipient_idx;
			end;
			other_recipient.duplicate = "1"b;
			other_recipient.duplicate_idx = recipient_idx;
		     end;
		     else do;
			/*** Either both recipients are top level, both are expansions, or we are an expansion and
			     the other is top level:  We are marked as the duplicate */
			recipient.duplicate = "1"b;
			recipient.duplicate_idx = other_recipient_idx;
		     end;
		end;

		else if (other_recipient.forum_idx ^= 0) & (other_recipient.forum_idx = recipient.forum_idx) then
		     go to MARK_RECIPIENT_AS_A_DUPLICATE;

		else if ((recipient.mailbox_idx = 0) & (other_recipient.mailbox_idx = 0))
		     & ((recipient.forum_idx = 0) & (other_recipient.forum_idx = 0)) then
		     if mlsys_address_mgr_$compare_addresses (other_recipient.address_ptr, recipient.address_ptr, (0))
			then
			go to MARK_RECIPIENT_AS_A_DUPLICATE;
	     end;
	end;

	return;

     end mark_duplicate_recipients;
%page;
/* Prepares a version of the message which is suitable for placement in a mailbox:  This edition always creates a
   mail_format structure followed immediately by its corresponding mf_extension structure */

prepare_message_for_mailbox:
     procedure (p_include_bcc_field, p_mailbox_message_ptr, p_mailbox_message_lth, p_code);

dcl  p_include_bcc_field bit (1) aligned parameter;
dcl  p_mailbox_message_ptr pointer parameter;
dcl  p_mailbox_message_lth fixed binary (24) parameter;
dcl  p_code fixed binary (35) parameter;

dcl  (original_mf_ptr, original_mf_extension_ptr, stack_truncation_ptr) pointer;
dcl  code fixed binary (35);
dcl  mailbox_message_lth fixed binary (19);
dcl  (buffer_idx, formatting_mode) fixed binary;


	if p_include_bcc_field then			/* insure that the original bcc is in the message ... */
	     message.bcc = saved_message_data.bcc;
	else message.bcc = null ();			/* bcc field not required */

	n_message_buffers_used, buffer_idx = n_message_buffers_used + 1;
	message_buffers (buffer_idx) = null ();

	if message.bcc = saved_message_data.bcc then do;	/* check if we can bypass formatting ... */
	     call mlsys_mailbox_mgr_$get_message_mf_if_canonical (message_ptr, original_mf_ptr,
		original_mf_extension_ptr, code);
	     if code = 0 then			/* ... a canonical in-mailbox message */
		if added_redistribution then
		     formatting_mode = REDISTRIBUTION_FORMATTING;
		else formatting_mode = COPY_FORMATTING;
	     else formatting_mode = FULL_FORMATTING;	/* ... non-canonical in-mailbox or a new message */
	end;
	else formatting_mode = FULL_FORMATTING;


/* Try to create the message on the stack first */

	call cu_$grow_stack_frame (STACK_EXTENSION, message_buffers (buffer_idx), (0));

	mail_format_ptr = message_buffers (buffer_idx);

	call format_the_message ((STACK_EXTENSION));

	if code = 0 then do;			/* it fits */
	     stack_truncation_ptr =
		addwordno (message_buffers (buffer_idx), (mailbox_message_lth + 16 - mod (mailbox_message_lth, 16)));
	     call cu_$shrink_stack_frame (stack_truncation_ptr, (0));
	end;


	else if code = error_table_$smallarg then do;

	     call cu_$shrink_stack_frame (message_buffers (buffer_idx), (0));

/* Message won't fit on the stack: try a temporary segment.  Try to use the remainder of any previously obtained temporary
   segment first */

	     if last_temp_segment_ptr ^= null () then	/* we already have a temporary segment ... */
		if (last_temp_segment_used + STACK_EXTENSION) < sys_info$max_seg_size then do;
		     message_buffers (buffer_idx) = addwordno (last_temp_segment_ptr, last_temp_segment_used);
		     call format_the_message ((sys_info$max_seg_size - last_temp_segment_used));
		     if code ^= 0 then
			if code = error_table_$smallarg then
			     go to USE_VIRGIN_TEMP_SEGMENT;
			else call abort_prepare_message_for_mailbox (code);
		end;

		else go to USE_VIRGIN_TEMP_SEGMENT;	/* not enough room in last segment: get another one */

	     else do;				/* first time we had to try a temporary segment */
USE_VIRGIN_TEMP_SEGMENT:
		call mlsys_storage_mgr_$get_temp_segment (last_temp_segment_ptr, code);
		if code ^= 0 then call abort_prepare_message_for_mailbox (code);
		last_temp_segment_used = 0;		/* ... the temporary segment is emtpy */
		message_buffers (buffer_idx) = last_temp_segment_ptr;
		call format_the_message (sys_info$max_seg_size);
		if code ^= 0 then			/* ... any type of error is fatal here */
		     if code = error_table_$smallarg then
			call abort_prepare_message_for_mailbox (mlsys_et_$message_too_large);
		     else call abort_prepare_message_for_mailbox (code);
	     end;

	     last_temp_segment_used = last_temp_segment_used + mailbox_message_lth + 16 - mod (mailbox_message_lth, 16);
	end;

	else call abort_prepare_message_for_mailbox (code);


/* Complete construction of the mail_format structure and return it and return it and the mf_extension to the caller */

	mail_format_ptr = message_buffers (buffer_idx);
	mail_format.version = MAIL_FORMAT_VERSION_4;
	mail_format.sent_from = "";
	unspec (mail_format.switches) = "0"b;
	if deliver_options.delivery_mode ^= ORDINARY_DELIVERY then mail_format.wakeup = "1"b;
	mail_format.acknowledge = deliver_options.acknowledge;
	mail_format.canonical = "1"b;

	p_mailbox_message_ptr = message_buffers (buffer_idx);
	p_mailbox_message_lth = 36 * mailbox_message_lth;
	p_code = 0;				/* success */

RETURN_FROM_PREPARE_MESSAGE_FOR_MAILBOX:
	return;



/* Internal to prepare_message_for_mailbox: aborts after a fatal error */

abort_prepare_message_for_mailbox:
	procedure (p_return_code);

dcl  p_return_code fixed binary (35) parameter;

	     p_code = p_return_code;
	     go to RETURN_FROM_PREPARE_MESSAGE_FOR_MAILBOX;

	end abort_prepare_message_for_mailbox;



/* Internal to prepare_message_for_mailbox: actually formats the message */

format_the_message:
	procedure (p_buffer_size);

dcl  p_buffer_size fixed binary (19) parameter;

	     if formatting_mode = FULL_FORMATTING then
		call mlsys_format_$format_message_for_mailbox (message_ptr, message_buffers (buffer_idx),
		     p_buffer_size, mailbox_message_lth, code);

	     else if formatting_mode = COPY_FORMATTING then do;
		mailbox_message_lth =
		     currentsize (original_mf_ptr -> mail_format)
		     + currentsize (original_mf_extension_ptr -> mf_extension);
		if mailbox_message_lth <= p_buffer_size then do;
		     mail_format_ptr = message_buffers (buffer_idx);
		     mf_extension_ptr = addwordno (mail_format_ptr, currentsize (original_mf_ptr -> mail_format));
		     mail_format.header = original_mf_ptr -> mail_format.header;
		     mail_format.text = original_mf_ptr -> mail_format.text;
		     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;
		     code = 0;
		end;
		else code = error_table_$smallarg;
	     end;

	     else /*** if formatting_mode = REDISTRIBUTION_FORMATTING then */
		call mlsys_format_$format_canon_redistributed_msg (message_ptr, original_mf_ptr,
		     original_mf_extension_ptr, message_buffers (buffer_idx), p_buffer_size, mailbox_message_lth,
		     code);

	     return;

	end format_the_message;

     end prepare_message_for_mailbox;
%page;
/* Adds the supplied message to the specified mailbox */

add_message_to_mailbox:
     procedure (p_mailbox_idx, p_mailbox_message_ptr, p_mailbox_message_lth, p_force_no_acknowledge, p_code);

dcl  p_mailbox_idx fixed binary parameter;
dcl  p_mailbox_message_ptr pointer parameter;
dcl  p_mailbox_message_lth fixed binary (24) parameter;
dcl  p_force_no_acknowledge bit (1) unaligned parameter;
dcl  p_code fixed binary (35) parameter;

dcl  1 mbx_add_options aligned,			/* control options to mailbox_$wakeup_aim_add_index */
       2 normal_wakeup bit (1) unaligned,		/* ... ON => send a normal wakeup (needs "w" access) */
       2 urgent_wakeup bit (1) unaligned,		/* ... ON => send an urgent wakeup (unused) */
       2 always_add bit (1) unaligned,			/* ... ON => add message even if wakeup not sent */
       2 never_add bit (1) unaligned,			/* ... ON => never add the message; just send a wakeup */
       2 mbz bit (32) unaligned;

dcl  code fixed binary (35);
dcl  retry_count fixed binary;
dcl  try_to_mail bit (1) aligned;

	string (mbx_add_options) = ""b;
	if deliver_options.delivery_mode = ORDINARY_DELIVERY then mbx_add_options.always_add = "1"b;
	else if deliver_options.delivery_mode = INTERACTIVE_DELIVERY then
	     mbx_add_options.normal_wakeup, mbx_add_options.always_add = "1"b;
	else /*** if deliver_options.delivery_mode = EXPRESS_DELIVERY then */
	     mbx_add_options.normal_wakeup = "1"b;

	on condition (record_quota_overflow)
	     begin;				/* no room in mailbox (sigh) */
	     code = error_table_$rqover;
	     go to MAILBOX_ADD_CALL_COMPLETED;
	end;

	retry_count = 0;
	try_to_mail = "1"b;

	p_mailbox_message_ptr -> mail_format.acknowledge =
	     p_mailbox_message_ptr -> mail_format.acknowledge & ^p_force_no_acknowledge;

	do while (try_to_mail);
	     call mailbox_$wakeup_aim_add_index (p_mailbox_idx, p_mailbox_message_ptr, p_mailbox_message_lth,
		string (mbx_add_options), message.access_class, ((72)"0"b), code);
	     if code = error_table_$lock_wait_time_exceeded then do;
		retry_count = retry_count + 1;
		try_to_mail = (retry_count < mlsys_data_$max_lock_wait_retries);
	     end;
	     else try_to_mail = "0"b;			/* have our result */
	end;

MAILBOX_ADD_CALL_COMPLETED:
	revert condition (record_quota_overflow);

	p_mailbox_message_ptr -> mail_format.acknowledge = deliver_options.acknowledge;

	if code = error_table_$no_append then code = mlsys_et_$no_a_permission;
	if code = error_table_$bigarg then code = mlsys_et_$message_too_large;
	if code = error_table_$notalloc then code = mlsys_et_$mailbox_full;
	p_code = code;				/* save the code associated with the actual message */

	if deliver_options.recipient_notification & (deliver_options.delivery_mode = ORDINARY_DELIVERY) & (code = 0)
	then do;					/* send a notification if the mail was sent OK */
	     if ^notification_initialized_sw then call initialize_notification ();
	     on condition (record_quota_overflow) go to IGNORE_NOTIFICATION;
	     string (mbx_add_options) = ""b;
	     mbx_add_options.normal_wakeup = "1"b;	/* ... express message */
	     call mailbox_$wakeup_aim_add_index (p_mailbox_idx, addr (NOTIFICATION_MAIL_FORMAT),
		(36 * currentsize (NOTIFICATION_MAIL_FORMAT)), string (mbx_add_options), message.access_class,
		((72)"0"b), (0));
IGNORE_NOTIFICATION:
	     revert condition (record_quota_overflow);
	end;

	return;

     end add_message_to_mailbox;



/* Sends a test message to the currently open mailbox:  A test message is used to determine whether an interactive can be
   properly delivered to the given mailbox */

send_test_message:
     procedure (p_mailbox_idx, p_code);

dcl  p_mailbox_idx fixed binary parameter;
dcl  p_code fixed binary (35) parameter;

dcl  1 mbx_add_options aligned,			/* control options to mailbox_$wakeup_aim_add_index */
       2 normal_wakeup bit (1) unaligned,		/* ... ON => send a normal wakeup (needs "w" access) */
       2 urgent_wakeup bit (1) unaligned,		/* ... ON => send an urgent wakeup (unused) */
       2 always_add bit (1) unaligned,			/* ... ON => add message even if wakeup not sent */
       2 never_add bit (1) unaligned,			/* ... ON => never add the message; just send a wakeup */
       2 mbz bit (32) unaligned;

	if ^notification_initialized_sw then call initialize_notification ();

	string (mbx_add_options) = ""b;
	mbx_add_options.normal_wakeup = "1"b;
	mbx_add_options.never_add = "1"b;		/* just see if we can do it */

	if deliver_options.delivery_mode = INTERACTIVE_DELIVERY then mbx_add_options.always_add = "1"b;

	call mailbox_$wakeup_aim_add_index (p_mailbox_idx, addr (NOTIFICATION_MAIL_FORMAT), 0, string (mbx_add_options),
	     message.access_class, ((72)"0"b), p_code);

	if p_code = error_table_$no_append then p_code = mlsys_et_$no_a_permission;

	return;

     end send_test_message;
%page;
/* Prepares a version of the message which is suitable for placement in a forum meeting */

prepare_message_for_forum:
     procedure (p_include_bcc_field, p_forum_message_ptr, p_forum_message_lth, p_code);

dcl  p_include_bcc_field bit (1) aligned parameter;
dcl  p_forum_message_ptr pointer parameter;
dcl  p_forum_message_lth fixed binary (21) parameter;
dcl  p_code fixed binary (35) parameter;

dcl  (forum_message_ptr, stack_truncation_ptr) pointer;
dcl  code fixed binary (35);
dcl  forum_message_lth fixed binary (21);
dcl  forum_message_n_words fixed binary (18);
dcl  buffer_idx fixed binary;


	if p_include_bcc_field then			/* insure that the original bcc is in the message ... */
	     message.bcc = saved_message_data.bcc;
	else message.bcc = null ();			/* bcc field not required */

	n_message_buffers_used, buffer_idx = n_message_buffers_used + 1;
	message_buffers (buffer_idx) = null ();


/* Try to create the message on the stack first */

	call cu_$grow_stack_frame (STACK_EXTENSION, message_buffers (buffer_idx), (0));

	forum_message_ptr = message_buffers (buffer_idx);

	call mlsys_format_$format_message_for_forum (message_ptr, forum_message_ptr, (4 * STACK_EXTENSION),
	     forum_message_lth, code);

	if code = 0 then do;			/* it fits ... */
	     forum_message_n_words = divide ((forum_message_lth + 3), 4, 18, 0);
	     stack_truncation_ptr =
		addwordno (message_buffers (buffer_idx),
		(forum_message_n_words + 16 - mod (forum_message_n_words, 16)));
	     call cu_$shrink_stack_frame (stack_truncation_ptr, (0));
	end;


	else if code = error_table_$smallarg then do;

	     call cu_$shrink_stack_frame (message_buffers (buffer_idx), (0));

/* Message won't fit on the stack: try a temporary segment.  Try to use the remainder of any previously obtained temporary
   segment first */

	     if last_temp_segment_ptr ^= null () then	/* we already have a temporary segment ... */
		if (last_temp_segment_used + STACK_EXTENSION) < sys_info$max_seg_size then do;
		     message_buffers (buffer_idx), forum_message_ptr =
			addwordno (last_temp_segment_ptr, last_temp_segment_used);
		     call mlsys_format_$format_message_for_forum (message_ptr, forum_message_ptr,
			(4 * (sys_info$max_seg_size - last_temp_segment_used)), forum_message_lth, code);
		     if code ^= 0 then
			if code = error_table_$smallarg then
			     go to USE_VIRGIN_TEMP_SEGMENT;
			else call abort_prepare_message_for_forum (code);
		end;

		else go to USE_VIRGIN_TEMP_SEGMENT;	/* not enough room in last segment: get another one */

	     else do;				/* first time we had to try a temporary segment */
USE_VIRGIN_TEMP_SEGMENT:
		call mlsys_storage_mgr_$get_temp_segment (last_temp_segment_ptr, code);
		if code ^= 0 then call abort_prepare_message_for_forum (code);
		last_temp_segment_used = 0;		/* ... the temporary segment is emtpy */
		message_buffers (buffer_idx), forum_message_ptr = last_temp_segment_ptr;
		call mlsys_format_$format_message_for_forum (message_ptr, forum_message_ptr,
		     (4 * sys_info$max_seg_size), forum_message_lth, code);
		if code ^= 0 then			/* ... any error here is fatal */
		     if code = error_table_$smallarg then
			call abort_prepare_message_for_forum (mlsys_et_$message_too_large);
		     else call abort_prepare_message_for_forum (code);
	     end;

	     forum_message_n_words = divide ((forum_message_lth + 3), 4, 18, 0);
	     last_temp_segment_used =
		last_temp_segment_used + forum_message_n_words + 16 - mod (forum_message_n_words, 16);
	end;

	else call abort_prepare_message_for_forum (code);

	p_forum_message_ptr = forum_message_ptr;
	p_forum_message_lth = forum_message_lth;
	p_code = 0;				/* success */

RETURN_FROM_PREPARE_MESSAGE_FOR_FORUM:
	return;



/* Intneral to prepare_message_for_forum: aborts after a fatal error */

abort_prepare_message_for_forum:
	procedure (p_return_code);

dcl  p_return_code fixed binary (35) parameter;

	     p_code = p_return_code;
	     go to RETURN_FROM_PREPARE_MESSAGE_FOR_FORUM;

	end abort_prepare_message_for_forum;

     end prepare_message_for_forum;
%page;
/* Adds the supplied message to the specified forum meeting */

add_message_to_forum:
     procedure (p_forum_idx, p_forum_message_ptr, p_forum_message_lth, p_code);

dcl  p_forum_idx fixed binary parameter;
dcl  p_forum_message_ptr pointer parameter;
dcl  p_forum_message_lth fixed binary (21) parameter;
dcl  p_code fixed binary (35) parameter;

dcl  forum_message character (p_forum_message_lth) unaligned based (p_forum_message_ptr);
dcl  code fixed binary (35);

	on condition (record_quota_overflow)
	     begin;				/* no room in forum (sigh) */
	     code = error_table_$rqover;
	     go to FORUM_ENTER_CALL_COMPLETED;
	end;

	call forum_$enter_trans (p_forum_idx, forum_message, 0, message_subject, "1"b, (0), code);

FORUM_ENTER_CALL_COMPLETED:
	if code = forum_error_table_$rqo then code = error_table_$rqover;

	p_code = code;

	return;

     end add_message_to_forum;
%page;
/* Prepares a version of the message which is suitable for transmission across a network using DOD-standard RFC822 format:
   In this release, only networks using this format are supported */

prepare_message_for_network:
     procedure (p_include_bcc_field, p_network_message_ptr, p_network_message_lth, p_code);

dcl  p_include_bcc_field bit (1) aligned parameter;
dcl  p_network_message_ptr pointer parameter;
dcl  p_network_message_lth fixed binary (21) parameter;
dcl  p_code fixed binary (35) parameter;

dcl  (network_message_ptr, stack_truncation_ptr) pointer;
dcl  code fixed binary (35);
dcl  network_message_lth fixed binary (21);
dcl  network_message_n_words fixed binary (18);
dcl  buffer_idx fixed binary;


	if p_include_bcc_field then			/* insure that the original bcc is in the message ... */
	     message.bcc = saved_message_data.bcc;
	else message.bcc = null ();			/* bcc field not required */

	n_message_buffers_used, buffer_idx = n_message_buffers_used + 1;
	message_buffers (buffer_idx) = null ();


/* Try to create the message on the stack first */

	call cu_$grow_stack_frame (STACK_EXTENSION, message_buffers (buffer_idx), (0));

	network_message_ptr = message_buffers (buffer_idx);

	call mlsys_format_$format_message_for_rfc822_network (message_ptr, network_message_ptr, (4 * STACK_EXTENSION),
	     network_message_lth, code);

	if code = 0 then do;			/* it fits ... */
	     network_message_n_words = divide ((network_message_lth + 3), 4, 18, 0);
	     stack_truncation_ptr =
		addwordno (message_buffers (buffer_idx),
		(network_message_n_words + 16 - mod (network_message_n_words, 16)));
	     call cu_$shrink_stack_frame (stack_truncation_ptr, (0));
	end;


	else if code = error_table_$smallarg then do;

	     call cu_$shrink_stack_frame (message_buffers (buffer_idx), (0));

/* Message won't fit on the stack: try a temporary segment.  Try to use the remainder of any previously obtained temporary
   segment first */

	     if last_temp_segment_ptr ^= null () then	/* we already have a temporary segment ... */
		if (last_temp_segment_used + STACK_EXTENSION) < sys_info$max_seg_size then do;
		     message_buffers (buffer_idx), network_message_ptr =
			addwordno (last_temp_segment_ptr, last_temp_segment_used);
		     call mlsys_format_$format_message_for_rfc822_network (message_ptr, network_message_ptr,
			(4 * (sys_info$max_seg_size - last_temp_segment_used)), network_message_lth, code);
		     if code ^= 0 then
			if code = error_table_$smallarg then
			     go to USE_VIRGIN_TEMP_SEGMENT;
			else call abort_prepare_message_for_network (code);
		end;

		else go to USE_VIRGIN_TEMP_SEGMENT;	/* not enough room in last segment: get another one */

	     else do;				/* first time we had to try a temporary segment */
USE_VIRGIN_TEMP_SEGMENT:
		call mlsys_storage_mgr_$get_temp_segment (last_temp_segment_ptr, code);
		if code ^= 0 then do;		/* ... can't get a temporary segment, sorry */
		     p_code = code;
		     return;
		end;
		last_temp_segment_used = 0;		/* ... the temporary segment is emtpy */
		message_buffers (buffer_idx), network_message_ptr = last_temp_segment_ptr;
		call mlsys_format_$format_message_for_rfc822_network (message_ptr, network_message_ptr,
		     (4 * sys_info$max_seg_size), network_message_lth, code);
		if code ^= 0 then			/* ... any error here is fatal */
		     if code = error_table_$smallarg then
			call abort_prepare_message_for_network (mlsys_et_$message_too_large);
		     else call abort_prepare_message_for_network (code);
	     end;

	     network_message_n_words = divide ((network_message_lth + 3), 4, 18, 0);
	     last_temp_segment_used =
		last_temp_segment_used + network_message_n_words + 16 - mod (network_message_n_words, 16);
	end;

	else call abort_prepare_message_for_network (code);

	p_network_message_ptr = network_message_ptr;
	p_network_message_lth = network_message_lth;
	p_code = 0;				/* success */

RETURN_FROM_PREPARE_MESSAGE_FOR_NETWORK:
	return;



/* Intneral to prepare_message_for_network: aborts after a fatal error */

abort_prepare_message_for_network:
	procedure (p_return_code);

dcl  p_return_code fixed binary (35) parameter;

	     p_code = p_return_code;
	     go to RETURN_FROM_PREPARE_MESSAGE_FOR_NETWORK;

	end abort_prepare_message_for_network;

     end prepare_message_for_network;
%page;
/* Attempts to deliver or queue mail using the interim inter-system mailer (mlsys_mailer_) */

invoke_ism:
     procedure ();

	return;					/* not an entrypoint */

dcl  p_recipient_type fixed binary parameter;
dcl  p_use_copy_without_bcc bit (1) unaligned parameter;
dcl  p_message_ptr pointer parameter;
dcl  p_message_lth fixed binary (21) parameter;

dcl  1 ism_recipient aligned based (ism_recipient_ptr) like mlsys_mailer_recipient;
dcl  ism_recipient_ptr pointer;

dcl  queued_only bit (1) aligned;
dcl  saved_code fixed binary (35);
dcl  (recipient_type, ism_recipient_idx, recipient_idx) fixed binary;


deliver_by_ism:					/* immediate delivery: queue transient errors if requested */
     entry (p_use_copy_without_bcc, p_message_ptr, p_message_lth);

	recipient_type = NETWORK_RECIPIENT;		/* ... select only those foreign recipients ... */
	queued_only = "0"b;				/* ... which aren't already marked as to be queued */
	go to INVOKE_ISM_COMMON;


queue_via_ism:					/* queue for later delivery */
     entry (p_recipient_type, p_use_copy_without_bcc, p_message_ptr, p_message_lth);

	recipient_type = p_recipient_type;		/* ... select only those appropriate recipients ... */
	queued_only = "1"b;				/* ... which need to be queued */


INVOKE_ISM_COMMON:
	mlsys_mailer_data.version = MLSYS_MAILER_DATA_VERSION_1;
	mlsys_mailer_data.source = mlsys_data_$user_id;
	string (mlsys_mailer_data.header.flags) = ""b;
	mlsys_mailer_data.send = (deliver_options.delivery_mode ^= ORDINARY_DELIVERY);
	mlsys_mailer_data.mail = (deliver_options.delivery_mode = ORDINARY_DELIVERY);
	mlsys_mailer_data.dont_queue = ^queued_only;	/* don't queue if trying to mail immediately */
	mlsys_mailer_data.queue_only = queued_only;


/* Build the list of recipients which match the selection criteria */

	mlsys_mailer_data.total_recipients = 0;		/* no one yet */

	do recipient_idx = 1 to n_recipients;

	     recipient_ptr = addr (recipients_list.recipients (recipient_idx));

	     if ^recipient.duplicate & ^recipient.fatal_error then
		if (recipient.type = recipient_type) & (recipient.use_copy_without_bcc = p_use_copy_without_bcc)
		     & (recipient.to_queue = queued_only) then do;
		     mlsys_mailer_data.total_recipients = mlsys_mailer_data.total_recipients + 1;
		     ism_recipient_idxs (mlsys_mailer_data.total_recipients) = recipient_idx;
		     ism_recipient_ptr = addr (mlsys_mailer_data.recipients (mlsys_mailer_data.total_recipients));
		     ism_recipient.user_name = recipient.foreign_address;
		     ism_recipient.host_name = recipient.foreign_system;
		     string (ism_recipient.flags) = ""b;/* ... might as well initialize everything */
		     ism_recipient.code = 0;
		     ism_recipient.result = "";
		end;
	end;

	if mlsys_mailer_data.total_recipients = 0 then	/* nothing of interest for this particular call */
	     return;


/* Invoke mlsys_mailer_ while enforcing the temporary restriction that the acceess class of the mail must be equal to the
   process authorization */

	if aim_check_$equal (get_authorization_ (), message.access_class) then
	     call mlsys_mailer_ (mlsys_mailer_data_ptr, p_message_ptr, p_message_lth);

	else do;					/* can't send up, down, or sideways with mlsys_mailer_ */
	     do ism_recipient_idx = 1 to mlsys_mailer_data.total_recipients;
		ism_recipient_ptr = addr (mlsys_mailer_data.recipients (ism_recipient_idx));
		ism_recipient.processed, ism_recipient.fatal_error = "1"b;
		ism_recipient.code = error_table_$ai_restricted;
	     end;
	end;


/* Analyze the results:  For immediate delivery, convert transient errors into queueing requests if appropriate */

	do ism_recipient_idx = 1 to mlsys_mailer_data.total_recipients;

	     ism_recipient_ptr = addr (mlsys_mailer_data.recipients (ism_recipient_idx));
	     recipient_ptr = addr (recipients_list.recipients (ism_recipient_idxs (ism_recipient_idx)));

	     if ism_recipient.delivered then recipient.code = mlsys_et_$message_delivered;

	     else if ism_recipient.queued then recipient.code = mlsys_et_$message_queued;

	     else if ism_recipient.expanded then recipient.code = mlsys_et_$message_queued_and_delivered;

	     else if ism_recipient.fatal_error then do;
		/*** Unable to deliver/queue the message ... */
		recipient.fatal_error = "1"b;
		n_failed_recipients = n_failed_recipients + 1;
		if ism_recipient.code = error_table_$action_not_performed then
		     /*** ... mlsys_mailer_ gave no specific reason: check the result text */
		     if ism_recipient.result = "No known path" then code = mlsys_et_$cant_compute_route;
		     else if ism_recipient.result = "Unable to deliver mail." then do;
			recipient.fatal_error = "0"b; /* ... unknown failure: treat as transient */
			n_failed_recipients = n_failed_recipients - 1;
			recipient.transient_error = "1"b;
			recipient.code = mlsys_et_$route_out_of_service;
		     end;				/* ... as queueing just might work */
		     else if (ism_recipient.result = "Unable to queue mail.")
			| (ism_recipient.result = "Queueing message.") then
			recipient.code = mlsys_et_$unable_to_queue_mail;
		     else do;			/* ... anything else is from the foreign system */
			recipient.code = mlsys_et_$rejected_by_foreign_system;
			recipient.explanation = ism_recipient.result;
		     end;
		else /*** if ism_recipient.code ^= error_table_$action_not_performed then */
		     recipient.code = ism_recipient.code;
	     end;

	     else do;
		/*** Non-fatal error detected during immediate delivery */
		recipient.transient_error = "1"b;	/* ... can only be that the route is temporarily blocked */
		recipient.code = mlsys_et_$route_out_of_service;
	     end;

	     if recipient.transient_error then do;
		/*** Transient error: either make it fatal or try to queue the message as requested by the caller */
		recipient.transient_error = "0"b;
		if queued_only then			/* ... but we already tried queueing it */
		     recipient.fatal_error = "1"b;
		else /*** if ^queued_only then */
		     do;
		     if deliver_options.queueing_mode >= QUEUE_FOREIGN_WHEN_NEEDED then do;
			recipient.to_queue = "1"b;	/* ... queue it for delivery on the next pass */
			recipient.code = 0;
			recipient.explanation = "the route to the foreign system is temporarily out of service";
		     end;
		     else recipient.fatal_error = "1"b;
		end;
		if recipient.fatal_error then n_failed_recipients = n_failed_recipients + 1;
	     end;

	     if recipient.fatal_error & (length (recipient.explanation) > 0) then do;
		/*** A fatal error while queuing after a transient error: make the transient fatal */
		saved_code = recipient.code;		/* ... will need to know if we change it */
		if recipient.explanation = "the route to the foreign system is temporarily out of service" then
		     recipient.code = mlsys_et_$route_out_of_service;
		else if recipient.explanation = "the mailbox is temporarily locked" then
		     recipient.code = error_table_$lock_wait_time_exceeded;
		else if recipient.explanation = "the mailbox is temporarily full" then
		     recipient.code = mlsys_et_$mailbox_full;
		else if recipient.explanation = "of record quota overflow" then recipient.code = error_table_$rqover;
		else if recipient.explanation = "its logical volume is not mounted" then
		     recipient.code = error_table_$logical_volume_not_defined;
		else if recipient.explanation = "its logical volume is not attached" then
		     recipient.code = error_table_$logical_volume_not_connected;
		else /*** if recipient.explanation = "the meeting is temporarily full" then */
		     recipient.code = forum_error_table_$meeting_bloat;
		if recipient.code ^= saved_code then	/* ... we were able to get the old error back */
		     recipient.explanation = "";
	     end;

	     if ^recipient.fatal_error & (length (recipient.explanation) = 0) then never_transmitted = "0"b;
	end;

	return;

     end invoke_ism;
%page;
/* Adds the specified suffix to an entryname if possible */

add_suffix:
     procedure (p_ename, p_suffix, p_new_ename, p_code);

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

dcl  (trimmed_ename, trimmed_suffix) character (33) varying;

	if length (rtrim (p_ename)) > length (p_new_ename) then do;
	     p_code = error_table_$entlong;
	     return;
	end;

	trimmed_ename = rtrim (p_ename);
	trimmed_suffix = "." || rtrim (p_suffix);

	if length (trimmed_ename) > length (trimmed_suffix) then
						/* original name has room for the suffix */
	     if substr (trimmed_ename, (length (trimmed_ename) - length (trimmed_suffix) + 1)) = trimmed_suffix then
		;				/* proper suffix is already present */
	     else trimmed_ename = trimmed_ename || trimmed_suffix;
	else trimmed_ename = trimmed_ename || trimmed_suffix;

	p_new_ename = trimmed_ename;			/* return it */

	if length (trimmed_ename) <= length (p_new_ename) then
	     p_code = 0;				/* it fit */
	else p_code = error_table_$entlong;		/* sorry */

	return;

     end add_suffix;



/* Returns "1"b if the given address list is empty */

is_empty_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 is_empty_list;
%page;
initialize_notification:
     procedure ();

	text_length = length (NOTIFICATION_TEXT);
	allocate NOTIFICATION_MAIL_FORMAT in (based_area) set (NOTIFICATION_MAIL_FORMAT_PTR);
	unspec (NOTIFICATION_MAIL_FORMAT.header) = "0"b;
	NOTIFICATION_MAIL_FORMAT.version = MAIL_FORMAT_VERSION_4;
	NOTIFICATION_MAIL_FORMAT.sent_from = "";
	NOTIFICATION_MAIL_FORMAT.lines = 1;
	NOTIFICATION_MAIL_FORMAT.text_len = length (NOTIFICATION_TEXT);
	NOTIFICATION_MAIL_FORMAT.wakeup = "1"b;
	NOTIFICATION_MAIL_FORMAT.notify = "1"b;
	NOTIFICATION_MAIL_FORMAT.text = NOTIFICATION_TEXT;

	notification_initialized_sw = "1"b;

     end initialize_notification;
%page;
%include mlsys_copy_ptr;
%page;
%include mlsys_data;
%page;
%include mlsys_internal_data;
%page;
%include mlsys_deliver_info;
%page;
%include mlsys_message;
%page;
%include mlsys_address_types;
%page;
%include mlsys_address_list;
%page;
%include mlsys_mailbox_modes;
%page;
%include mail_format;
%page;
%include mlsys_mf_extension;
%page;
%include forum_user_trans;
%page;
%include forum_flags;
%page;
%include mlsys_mailer_data;
%page;
%include aim_template;
%page;
%include access_mode_values;
%page;
%include terminate_file;
%page;
/* Various whitespace constants are placed here as they generate so many blank pages ... */

dcl  WHITESPACE character (5) static options (constant) initial (" 	
");						/* space, horizontal tab, newline, vertical tab, formfeed */

     end mlsys_transmit_;




		    mlsys_trap_.alm                 10/27/83  1607.4rew 10/27/83  1439.1        5157



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

" Provides a first-reference trap procedure for bound_mail_system_

"  Created:  June 1983 by G. Palter


	name	mlsys_trap_

	segdef	initialize_caller

initialize_caller:
	getlp
	tra	mlsys_initialize_$mlsys_initialize_

	firstref	<*text>|initialize_caller

	end




		    mlsys_user_mte_syntax_.pl1      06/18/84  1310.1r w 06/18/84  1224.5       52173



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

/* format: off */

/* Validates the syntax of User_ids and mail table entry (MTE) names */

/* Created:  June 1983 by G. Palter */
/* Modified: March 1984 by G. Palter to fix mail system error #0415 -- read_mail, print_mail, and have_mail/have_messages
      do not reject starnames as invalid mailbox specifications */

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


mlsys_user_mte_syntax_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_name character (*) varying parameter;		/* the name to be validated as a User_id or MTE name */

dcl  P_is_mte_name bit (1) aligned parameter;		/* classify_and_validate: set ON => MTEname; OFF => User_id */

dcl  P_person_id character (*) varying parameter;		/* classify_and_validate, validate_user_id: set to ... */
dcl  P_project_id character (*) varying parameter;	/* ... Person_id and Project_id of the User_id respectively */

dcl  P_code fixed binary (35) parameter;


/* Local copies of parameters */

dcl  person_id character (64) varying;
dcl  project_id character (64) varying;


/* Remaining declarations */

dcl  LONGEST_PERSON_ID character (28) static options (constant) initial ("");
dcl  LONGEST_PROJECT_ID character (32) static options (constant) initial ("");
dcl  LONGEST_MTE_NAME character (32) static options (constant) initial ("");

dcl  INVALID_MTE_CHARACTERS character (12) static options (constant) initial (",:;\()<>{}""@");

dcl  WHITESPACE character (5) static options (constant) initial (" 	
");						/* SP HT VT FF NL */

dcl  WHITESPACE_OTHER_THAN_SPACE character (4) static options (constant) initial ("	
");						/* HT VT FF NL */

/* format: off */
dcl (mlsys_et_$invalid_mte_syntax, mlsys_et_$invalid_person_id_syntax, mlsys_et_$invalid_user_id_syntax)
	fixed binary (35) external;
/* format: on */

dcl  check_star_name_$entry entry (character (*), fixed binary (35));

dcl  (after, before, index, length, search) builtin;
%page;
/* Determines if the given name is a User_id or MTE name and then validates its syntax */

classify_and_validate:
     entry (P_name, P_is_mte_name, P_person_id, P_project_id, P_code);

	if search (P_name, WHITESPACE) = 0 then		/* a User_id contains no whitespace ... */
	     if (index (P_name, ".") ^= 0) & (index (after (P_name, "."), ".") = 0) then
		P_is_mte_name = "0"b;		/* ... and exactly one period */
	     else P_is_mte_name = "1"b;
	else P_is_mte_name = "1"b;

	if P_is_mte_name then			/* perform appropriate syntax checks */
	     call validate_mte_name (P_name, P_code);
	else do;
	     call validate_user_id (P_name, P_person_id, P_project_id, P_code);
	     if P_code = 0 then do;			/* ... reject starnames in User_ids when parsing only */
		call check_star_name_$entry ((P_name), P_code);
		if P_code ^= 0 then P_code = mlsys_et_$invalid_user_id_syntax;
	     end;
	end;

	return;
%page;
/* Validates the syntax of a User_id and returns its component Person_id and Project_id */

validate_user_id:
     entry (P_name, P_person_id, P_project_id, P_code);

	if search (P_name, WHITESPACE) ^= 0 then do;	/* no embedded whitespace is allowed */
BAD_USER_ID_SYNTAX:					/* invalid User_id syntax */
	     P_code = mlsys_et_$invalid_user_id_syntax;
	     return;
	end;

	if index (P_name, ".") = 0 then go to BAD_USER_ID_SYNTAX;
	if index (after (P_name, "."), ".") ^= 0 then go to BAD_USER_ID_SYNTAX;
						/* not exactly one period */

	if search (P_name, "<>") ^= 0 then go to BAD_USER_ID_SYNTAX;
						/* only other unacceptable characters in a User_id */

	person_id = before (P_name, ".");		/* isolate the components */
	project_id = after (P_name, ".");

	if (length (person_id) > length (LONGEST_PERSON_ID)) | (length (project_id) > length (LONGEST_PROJECT_ID)) then
	     go to BAD_USER_ID_SYNTAX;		/* either Person_id is over 28 or Project_id is over 32 */

	if (person_id = "") | (project_id = "") then	/* neither part can be null */
	     go to BAD_USER_ID_SYNTAX;

	P_person_id = person_id;			/* validate User_id */
	P_project_id = project_id;
	P_code = 0;

	return;
%page;
/* Validates the syntax of a Person_id */

validate_person_id:
     entry (P_person_id, P_code);

	if search (P_person_id, WHITESPACE) ^= 0 then do; /* no embedded whitespace is allowed */
BAD_PERSON_ID_SYNTAX:				/* invalid Person_id syntax */
	     P_code = mlsys_et_$invalid_person_id_syntax;
	     return;
	end;

	if index (P_name, ".") ^= 0 then go to BAD_PERSON_ID_SYNTAX;
						/* can not have any periods */

	if search (P_name, "<>") ^= 0 then go to BAD_PERSON_ID_SYNTAX;
						/* only other unacceptable characters in a Person_id */

	if length (P_person_id) > length (LONGEST_PERSON_ID) then go to BAD_PERSON_ID_SYNTAX;
						/* Person_id can not exceed 28 characters */

	if P_person_id = "" then go to BAD_PERSON_ID_SYNTAX;
						/* can't be a null string */

	P_code = 0;

	return;
%page;
/* Validates the syntax of a mail table entry (MTE) name */

validate_mte_name:
     entry (P_name, P_code);

	if length (P_name) > length (LONGEST_MTE_NAME) then do;
INVALID_MTE_NAME_SYNTAX:				/* invalid MTE name syntax */
	     P_code = mlsys_et_$invalid_mte_syntax;
	     return;
	end;

	if search (P_name, WHITESPACE_OTHER_THAN_SPACE) ^= 0 then go to INVALID_MTE_NAME_SYNTAX;

	if search (P_name, INVALID_MTE_CHARACTERS) ^= 0 then go to INVALID_MTE_NAME_SYNTAX;

	if P_name = "" then go to INVALID_MTE_NAME_SYNTAX;/* can't be a null string */

	P_code = 0;				/* success */

	return;

     end mlsys_user_mte_syntax_;




		    mlsys_utils_.alm                06/18/84  1310.1r w 06/18/84  1224.7       40401



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

" Utility functions provided by the Multics Mail System

" Created:  June 1983 by G. Palter
" Modified: March 1984 by G. Palter to add print_validate_results


	name	mlsys_utils_


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


	transfer	add_mailbox_acl_entries,mlsys_mailbox_utils_$add_mailbox_acl_entries
	transfer	classify_mailbox_address,mlsys_mailbox_utils_$classify_mailbox_address
	transfer	create_default_mailbox,mlsys_mailbox_utils_$create_default_mailbox
	transfer	create_logbox,mlsys_mailbox_utils_$create_logbox
	transfer	create_mailbox,mlsys_mailbox_utils_$create_mailbox

	transfer	create_reply_message,mlsys_misc_utils_$create_reply_message
	transfer	create_savebox,mlsys_mailbox_utils_$create_savebox
	transfer	delete_mailbox,mlsys_mailbox_utils_$delete_mailbox
	transfer	delete_mailbox_acl_entries,mlsys_mailbox_utils_$delete_mailbox_acl_entries
	transfer	format_access_class_field,mlsys_format_$format_access_class_field

	transfer	format_address_field,mlsys_format_$format_address_field
	transfer	format_address_list_field,mlsys_format_$format_address_list_field
	transfer	format_body_section,mlsys_format_$format_body_section
	transfer	format_date_time_field,mlsys_format_$format_date_time_field
	transfer	format_message,mlsys_format_$format_message

	transfer	format_message_body,mlsys_format_$format_message_body
	transfer	format_message_canonical_form,mlsys_format_$format_message_canonical_form
	transfer	format_message_envelope,mlsys_format_$format_message_envelope
	transfer	format_message_header,mlsys_format_$format_message_header
	transfer	format_message_id_field,mlsys_format_$format_message_id_field

	transfer	format_redistributions_list,mlsys_format_$format_redistributions_list
	transfer	format_references_list_field,mlsys_format_$format_references_list_field
	transfer	format_message_trace,mlsys_format_$format_message_trace
	transfer	format_text_field,mlsys_format_$format_text_field
	transfer	free_delivery_results,mlsys_misc_utils_$free_delivery_results

	transfer	list_mailbox_acl,mlsys_mailbox_utils_$list_mailbox_acl
	transfer	parse_address_control_args,mlsys_parse_control_args_$parse_address_control_args
	transfer	parse_address_list_control_args,mlsys_parse_control_args_$parse_address_list_control_args
	transfer	parse_address_list_text,mlsys_parse_text_$parse_address_list_text
	transfer	parse_address_text,mlsys_parse_text_$parse_address_text

	transfer	parse_mailbox_control_args,mlsys_parse_control_args_$parse_mailbox_control_args
	transfer	parse_mailbox_text,mlsys_parse_control_args_$parse_mailbox_text
	transfer	parse_message_text,mlsys_parse_text_$parse_new_message_text
	transfer	print_access_class_field,mlsys_format_$print_access_class_field
	transfer	print_address_field,mlsys_format_$print_address_field

	transfer	print_address_list_field,mlsys_format_$print_address_list_field
	transfer	print_body_section,mlsys_format_$print_body_section
	transfer	print_date_time_field,mlsys_format_$print_date_time_field
	transfer	print_delivery_results,mlsys_misc_utils_$print_delivery_results
	transfer	print_message,mlsys_format_$print_message

	transfer	print_message_body,mlsys_format_$print_message_body
	transfer	print_message_envelope,mlsys_format_$print_message_envelope
	transfer	print_message_header,mlsys_format_$print_message_header
	transfer	print_message_id_field,mlsys_format_$print_message_id_field
	transfer	print_redistributions_list,mlsys_format_$print_redistributions_list

	transfer	print_message_summary,mlsys_misc_utils_$print_message_summary
	transfer	print_message_summary_header,mlsys_misc_utils_$print_message_summary_header
	transfer	print_references_list_field,mlsys_format_$print_references_list_field
	transfer	print_message_trace,mlsys_format_$print_message_trace
	transfer	print_text_field,mlsys_format_$print_text_field

	transfer	print_validate_results,mlsys_misc_utils_$print_validate_results
	transfer	replace_mailbox_acl_entries,mlsys_mailbox_utils_$replace_mailbox_acl_entries
	transfer	search_message,mlsys_misc_utils_$search_message
	transfer	send_message_to_recipient,mlsys_misc_utils_$send_message_to_recipient
	transfer	summarize_address,mlsys_misc_utils_$summarize_address

	end




		    set_mailing_address.pl1         06/26/90  0928.7rew 06/26/90  0924.4      176796



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



/****^  HISTORY COMMENTS:
  1) change(88-12-05,Parisek), approve(89-01-11,MCR8044),
     audit(89-01-16,Farley), install(89-01-19,MR12.3-1006):
     A. Return aliases for the specified name supplied to dsmla.
     B. Accept starnames as input to the dsmla command using case
        insensitivity.
  2) change(90-03-26,Kallstrom), approve(90-03-26,MCR8168),
     audit(90-04-16,Zimmerman), install(90-04-25,MR12.4-1008):
     A.  Add a check for self-referencing addresses
     B.  Fix the infinite loop which occurs when a control argument
         directly follows the -entry control arg.
  3) change(90-06-14,Zimmerman), approve(90-06-14,MCR8168),
     audit(90-06-18,WAAnderson), install(90-06-26,MR12.4-1017):
     PBF: Fix path thru code that tests improperly set variable.
     (validate_mte_path)
                                                   END HISTORY COMMENTS */


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

/* (set display)_mailing_address: These commands are used by
   ordinary users to manipulate their own Mail Table addresses, to
   manipulate Mail Table addresses for which tey have been granted
   access by an administrator, and to display any user's mailing
   address. */

/* Written: July 1983 by B. Margolin */
/* Modified: February 1984 by B. Margolin to suppress "No ACS path" in
   display_mailing_address and to compare the input entry name length against
   maxlength of the internal variable, not length */

set_mailing_address:
smla:
     proc options (variable);

	dcl     check_star_name_	entry (char (*), bit (36), fixed bin (2), fixed bin (35));
	dcl     com_err_		entry () options (variable);
	dcl     ioa_		entry () options (variable);
	dcl     mail_system_$free_address
				entry (ptr, fixed bin (35));
	dcl     mail_table_$get	entry (char (*) varying, ptr, char (*), fixed bin (35));
	dcl     mail_table_$get_aliases
				entry (char (*) var, char (*), ptr, ptr, fixed bin (35));
	dcl     mail_table_$get_name_by_index
				entry (fixed bin, char (*), char (*) var, fixed bin (35));
	dcl     mail_table_$set	entry (char (*) var, ptr, fixed bin (35));
	dcl     match_star_name_	entry (char (*), char (*), 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     ssu_$abort_line	entry () options (variable);
	dcl     ssu_$get_area	entry (ptr, ptr, char (*), ptr);
	dcl     ssu_$arg_count	entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	entry (ptr, fixed bin, ptr, fixed bin (21));
	dcl     ssu_$destroy_invocation
				entry (ptr);
	dcl     ssu_$print_message	entry () options (variable);
	dcl     ssu_$release_area	entry (ptr, ptr);
	dcl     ssu_$standalone_invocation
				entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

	dcl     address_ptr		ptr;
	dcl     alias_area_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     ca_address_ptr	ptr;
	dcl     cleanup		condition;
	dcl     code		fixed bin (35);
	dcl     default_project	bit (1);
	dcl     ignore_code		fixed bin (35);
	dcl     match_stars		bit (1);
	dcl     1 pcao		aligned like parse_ca_options;
	dcl     person_id		char (32) varying;
	dcl     person_id_specified	bit (1);
	dcl     sci_ptr		ptr;
	dcl     star_name		bit (1);
	dcl     star_type		fixed bin (2);
	dcl     WHOAMI		char (23);
	dcl     VERSION		char (3) init ("1.0") int static options (constant);
	dcl     (
	        error_table_$action_not_performed,
	        error_table_$bad_arg,
	        error_table_$bad_index,
	        error_table_$bad_subr_arg,
	        error_table_$badopt,
	        error_table_$bigarg,
	        error_table_$id_not_found,
	        error_table_$inconsistent,
	        error_table_$insufficient_access,
	        error_table_$lock_wait_time_exceeded,
	        error_table_$no_record,
	        error_table_$no_w_permission,
	        error_table_$noarg,
	        error_table_$too_many_args,
                  mlsys_et_$circular_mtes
	        )			fixed bin (35) ext static;
	dcl     (addr, index, length, maxlength, null, rtrim, substr)
				builtin;
%page;
%include check_star_name;
%page;
%include mlsys_parse_ca_options;
%page;
%include mail_table_entry;
%page;
%include mlsys_address_types;
%page;

	WHOAMI = "set_mailing_address";
	sci_ptr = null ();
	code = 0;
	address_ptr = null ();
	on cleanup call cleanup_smla ();
	call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_smla, 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 = 0 then call ssu_$abort_line (sci_ptr, 0, "Usage: ^a {address} {-control_args}", WHOAMI);
	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.validate_addresses = "1"b;
	pcao.flags.mbz = ""b;
	person_id = "";
	person_id_specified = "0"b;
	default_project = "0"b;
	do arg_idx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
	     if arg = "-entry" | arg = "-et" then do;
		if person_id_specified then
		     call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "-entry may only be specified once.");
		person_id_specified = "1"b;

/*** NO_NAME used to be immediately after 'arg_idx = arg_idx +1;' . ***/
/*** This caused an infinite loop when '-entry' was followed by     ***/
/*** a hyphen, as 'arg_idx' was never incremented to get by the     ***/
/*** argument preceded by the hyphen. For example,                  ***/
/***                smla -entry -bad                                ***/

NO_NAME:
		arg_idx = arg_idx + 1;
		if arg_idx > arg_count then
		     call ssu_$abort_line (sci_ptr, error_table_$noarg,
			"-entry must be followed by a Mail Table entry name.");
		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,
			"A blank name is not permitted after -entry.");
		if substr (arg, 1, 1) = "-" then go to NO_NAME;
						/* Control arg is not name */
		if arg_len > maxlength (person_id) then
		     call ssu_$abort_line (sci_ptr, error_table_$bigarg, "The Mail Table entry name ""^va"".",
			arg_len, arg);		/* Pad it the way it was given */
		person_id = arg;
	     end;
	     else if arg = "-default_project" | arg = "-dp" then default_project = "1"b;
	     else do;
		/*** Unrecognized by me, must be an address ***/
		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 control arguments.");
		if address_ptr ^= null () then do;	/* Already have one */
		     call mail_system_$free_address (ca_address_ptr, ignore_code);
		     call ssu_$abort_line (sci_ptr, error_table_$too_many_args,
			"^/Only one address may be specified.");
		end;
		arg_idx = arg_idx - 1;		/* will be incremented by do loop */
		address_ptr = ca_address_ptr;
		
	     end;

	end;
	if default_project & address_ptr ^= null () then
	     call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		"^/Both an address and -default_project may not be specified.");
	if ^default_project & address_ptr = null () then
	     call ssu_$abort_line (sci_ptr, error_table_$noarg,
		"Either an address or -default_project must be specified.");
          call validate_mte_path (person_id, address_ptr, code);
          if code ^= 0 then do;
  	     call ssu_$abort_line (sci_ptr, code, "");
               call cleanup_smla();
               return; 
	   end;

	call mail_table_$set (person_id, address_ptr, code);
	if code ^= 0 then do;
	     if code = error_table_$action_not_performed then
		call ssu_$abort_line (sci_ptr, code, "^/Anonymous users have no Mail Table entries.");
	     else if code = error_table_$bigarg then	/* We have already checked the size of the name */
		call ssu_$abort_line (sci_ptr, 0, "The address is too large to be stored in the Mail Table.");
	     else if code = error_table_$insufficient_access then
		call ssu_$abort_line (sci_ptr, code,
		     "^/You do not have access to modify ^[^a'^[s^]^;your^] mailing address.", person_id_specified,
		     person_id, ^ends_in_s (person_id));
	     else if code = error_table_$no_w_permission then
		call ssu_$abort_line (sci_ptr, code,
		     "^/You do not have access to modify the Mail Table; this may only be performed^/at an AIM authorization of system_low."
		     );
	     else if code = error_table_$bad_subr_arg then
		call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		     "^/-default_project may not be specified^[ for ^a^;^s^], as ^[it is^;you are^] not a registered user.",
		     person_id_specified, person_id, person_id_specified);
	     else if code = error_table_$id_not_found then
		call ssu_$abort_line (sci_ptr, code, "^/There is no Mail Table entry for ^[^a^;you^].",
		     person_id_specified, person_id);
	     else if code = error_table_$lock_wait_time_exceeded then
		call ssu_$abort_line (sci_ptr, code, "^/The Mail Table is being updated; try again in a few minutes.")
		     ;
	     else call ssu_$abort_line (sci_ptr, code, "^/Storing the new Mail Table entry for ^[^a^;you^].",
		     person_id_specified, person_id);
	end;
	call cleanup_smla ();
RETURN_FROM_SMLA:
	return;

validate_mte_path:
	procedure (P_name, P_address_ptr, P_code);

/*** parameters ***/
	
dcl P_name        parameter char (*) var;
dcl P_address_ptr parameter pointer;
dcl P_code        parameter fixed bin (35);
	
/*** automatics ***/

dcl src_person_id              char (32) varying;
dcl tgt_person_id              char (32) varying;
dcl last_mte_name              char (32) varying;
dcl code                       fixed bin (35);
dcl mail_table_address_ptr     pointer;

/*** based values ***/

dcl 01 address_header aligned based (mail_table_address_ptr),
       02 version         char (8) unaligned,
       02 type            fixed bin,
       02 reference_count fixed bin,
       02 name,
          03 name_ptr     ptr,
          03 name_lth     fixed bin (21),
       02 comment,
          03 comment_ptr  ptr,
          03 comment_lth  fixed bin (21),
       02 flags,
          03 never_free   bit (1) unaligned,
          03 free_name    bit (1) unaligned,
          03 free_comment bit (1) unaligned,
          03 pad          bit (33) unaligned;

dcl 01 mail_table_address aligned based (mail_table_address_ptr),
       02 header          aligned like address_header,
       02 mte_name        char (32) var;


/*** internal procedure ***/

expand_mail_table_entry:
	proc (mail_table_name, expanded_name, code);
	
/* parameters */

dcl mail_table_name parameter char (*) varying;
dcl expanded_name   parameter char (*) varying;
dcl code            parameter fixed bin (35);

/* automatics */

dcl next_mte_name              char (32) varying;
	
/* begin code */ 

code = 0;

call mail_table_$get (mail_table_name, mail_table_address_ptr, ((168) " "), code);
if (code ^= 0) then do;
    expanded_name = "";
    return;
  end;
  
if (address_header.type ^= MAIL_TABLE_ADDRESS) then do;
    if address_header.type = FOREIGN_ADDRESS then expanded_name = "..Foreign Address..";
    else expanded_name = mail_table_address.mte_name;
    call mail_system_$free_address (mail_table_address_ptr, code);
    return;
  end;

if (last_mte_name = mail_table_address.mte_name) then do;
    expanded_name = "";
    call mail_system_$free_address (mail_table_address_ptr, code);
    return;
  end;

last_mte_name, next_mte_name = mail_table_address.mte_name;

call mail_system_$free_address (mail_table_address_ptr, code);

call expand_mail_table_entry (next_mte_name, expanded_name, code);

end expand_mail_table_entry;


/*** BEGIN MAIN ROUTINE ***/

code = 0;

/* Only set when a potential self reference is encountered */

P_code = 0;

mail_table_address_ptr = null;

call expand_mail_table_entry (P_name, src_person_id, code);

if (code = 0 & P_address_ptr ^= null) then do;
    if (P_address_ptr->address_header.type = MAIL_TABLE_ADDRESS) then do;
        call expand_mail_table_entry (P_address_ptr->mail_table_address.mte_name, tgt_person_id, code);
        if (code ^= 0) then return;

        if (src_person_id = tgt_person_id | tgt_person_id = "") then
	   P_code = mlsys_et_$circular_mtes;
   end;
           
  end;

end validate_mte_path;

cleanup_smla:
     proc ();

	if address_ptr ^= null () then call mail_system_$free_address (address_ptr, ignore_code);
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	return;

     end cleanup_smla;

abort_smla:
     proc ();

	call cleanup_smla ();
	go to RETURN_FROM_SMLA;

     end abort_smla;

ends_in_s:
     proc (P_string) returns (bit (1)) reducible;

	dcl     P_string		char (*) varying;
	dcl     length		builtin;
	dcl     last_char		char (1);

	last_char = substr (P_string, length (P_string), 1);
	return (last_char = "s" | last_char = "S");
     end ends_in_s;


display_mailing_address:
dsmla:
     entry options (variable);

	WHOAMI = "display_mailing_address";
	sci_ptr = null ();
	address_ptr, alias_area_ptr = null ();
	code = 0;
	on cleanup call cleanup_dsmla ();

	call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_dsmla, 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 = 0 then
	     call display_one_address ("");		/* Default to self */
	else do;
	     match_stars = "1"b;			/* set */
	     do arg_idx = 1 to arg_count;		/* Now process them */
		call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
		if index (arg, "-") = 1 then do;
		     if arg = "-name" | arg = "-nm" then do;
			call ssu_$arg_ptr (sci_ptr, arg_idx + 1, 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.");
			else do;
			     match_stars = "0"b;	/* name may literally contains star characters, don't match */
			     arg_idx = arg_idx + 1;	/* now increment it */
			end;
		     end;
		     else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
		end;
		person_id = arg;
		call display_one_address (person_id);
	     end;
	end;
	call cleanup_dsmla ();
RETURN_FROM_DSMLA:
	return;

display_one_address:
     proc (P_name);

	dcl     P_name		char (*) varying;

	dcl     acs_path		char (201);
	dcl     alias_names		char (256) varying;
	dcl     code		fixed bin (35);
	dcl     buffer		char (256);
	dcl     buffer_used		char (buffer_used_len) based (addr (buffer));
	dcl     buffer_used_len	fixed bin (21);
	dcl     s_name_lower	char (32);
	dcl     r_name		char (32) varying;
	dcl     r_name_lower	char (32);
	dcl     mta_idx		fixed bin;
	dcl     mte_idx		fixed bin;
	dcl     1 mta		aligned like mail_table_aliases based (mtap);
	dcl     mtap		ptr;
	dcl     translate		builtin;
	dcl     lowercase		char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
	dcl     UPPERCASE		char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

	star_name = "0"b;
	mte_idx = 0;
	call check_star_name_ (rtrim (P_name), CHECK_STAR_IGNORE_ALL, star_type, code);
	if code ^= 0 then call ssu_$print_message (sci_ptr, code, "Unable to check starname type.");
	if star_type = STAR_TYPE_USE_PL1_COMPARE | ^match_stars then go to get_primary_name;
	s_name_lower = translate (P_name, lowercase, UPPERCASE);
						/* lowercase version of starname */

get_indexed_name:
	mte_idx = mte_idx + 1;
	call mail_table_$get_name_by_index (mte_idx, MAIL_TABLE_RAW_ENTRY_VERSION_1, r_name, code);
	if code = error_table_$bad_index then return;	/* end of table */
	else if code = error_table_$no_record then go to get_indexed_name;
	else if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "");
	r_name_lower = translate (r_name, lowercase, UPPERCASE);
						/* lowercase version of matchname */
	if star_type = STAR_TYPE_USE_MATCH_PROCEDURE then do;
	     star_name = "1"b;
	     call match_star_name_ (r_name_lower, s_name_lower, code);
	     if code = 0 then do;
		P_name = r_name;
		go to get_primary_name;
	     end;
	     else go to get_indexed_name;
	end;
	else if star_type = STAR_TYPE_MATCHES_EVERYTHING then do;
	     star_name = "1"b;
	     P_name = r_name;
	     go to get_primary_name;
	end;

get_primary_name:
	call mail_table_$get (P_name, address_ptr, acs_path, code);
	if code ^= 0 then
	     if code = error_table_$id_not_found then
		call ssu_$print_message (sci_ptr, code, "There is no Mail Table entry for ^[you^;^a^].",
		     (length (P_name) = 0), P_name);
	     else call ssu_$print_message (sci_ptr, code, "Getting ^[your^;^a'^[s^]^] mailing address.",
		     (length (P_name) = 0), P_name, ^ends_in_s (P_name));
	else do;
	     buffer_used_len = 0;
	     call mlsys_utils_$format_address_field ("", address_ptr, -1, addr (buffer), length (buffer),
		buffer_used_len, code);
	     if code ^= 0 then			/* Shouldn't happen */
		call ssu_$print_message (sci_ptr, code,
		     "Internal error while formatting ^[your^;^a'^[s^] mailing address.", (P_name = ""), P_name,
		     ^ends_in_s (P_name));

	     if P_name ^= "" then do;
		call ssu_$get_area (sci_ptr, null (), "Get aliases", alias_area_ptr);
		call mail_table_$get_aliases (P_name, MAIL_TABLE_ALIASES_VERSION_1, alias_area_ptr, mtap, code);
		if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting aliases for ^a", P_name);
		alias_names = "";
		do mta_idx = 1 to mta.n_names;
		     if mta.names (mta_idx) ^= P_name then alias_names = alias_names || mta.names (mta_idx) || ", ";
		end;
check_aliases:
		if alias_names ^= "" then do;
		     alias_names = substr (alias_names, 1, length (alias_names) - 2);
						/* remove the trailing comma and space */
		end;
		else alias_names = "No aliases";
	     end;
display:
	     if P_name = "" then
		call ioa_ ("Your Mail Table entry:");
	     else do;
		call ioa_ ("Mail Table entry: ^a", P_name);
		call ioa_ ("  Aliases: ^a", alias_names);
		if acs_path ^= "" then call ioa_ ("  ACS pathname: ^a", acs_path);
	     end;
	     call ioa_ ("  Mailing address: ^a", buffer_used);
	end;
	if star_name then go to get_indexed_name;
     end display_one_address;

cleanup_dsmla:
     proc ();

	if address_ptr ^= null () then call mail_system_$free_address (address_ptr, ignore_code);
	if alias_area_ptr ^= null () then call ssu_$release_area (sci_ptr, alias_area_ptr);
	if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
	return;

     end cleanup_dsmla;

abort_dsmla:
     proc ();

	call cleanup_dsmla ();
	go to RETURN_FROM_DSMLA;

     end abort_dsmla;


     end set_mailing_address;

*/
                                          -----------------------------------------------------------


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

*/
