



		    mseg_.alm                       05/10/85  0907.3r w 05/06/85  1617.7       15462



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

" The Message Segment Primitives

" Created:  April 1985 by G. Palter


	name	mseg_


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

	transfer	add_acl_entries_seg,mseg_fs_interface_

	transfer	add_message,mseg_message_

	transfer	chname_seg,mseg_fs_interface_

	transfer	close_seg,mseg_index_

	transfer	compact_seg,mseg_segment_

	transfer	copy_seg,mseg_segment_

	transfer	count_messages,mseg_message_

	transfer	create_seg,mseg_fs_interface_

	transfer	delete_acl_entries_seg,mseg_fs_interface_

	transfer	delete_message,mseg_message_

	transfer	delete_seg,mseg_fs_interface_

	transfer	get_salvaged_flag_seg,mseg_segment_

	transfer	get_wakeup_state_seg,mseg_segment_

	transfer	initiate_seg,mseg_index_

	transfer	list_acl_seg,mseg_fs_interface_

	transfer	list_acl_entries_seg,mseg_fs_interface_

	transfer	open_seg,mseg_index_

	transfer	read_message,mseg_message_

	transfer	replace_acl_seg,mseg_fs_interface_

	transfer	reset_salvaged_flag_seg,mseg_segment_

	transfer	reset_wakeup_state_seg,mseg_segment_

	transfer	set_max_length_seg,mseg_segment_

	transfer	set_safety_switch_seg,mseg_fs_interface_

	transfer	set_wakeup_state_seg,mseg_segment_

	transfer	update_message,mseg_message_


" A first reference trap to insure that mseg_data_ is properly initialized

	segdef	initialize_caller

initialize_caller:
	getlp
	tra	mseg_utils_$initialize

	firstref	<*text>|initialize_caller

	end




		    mseg_access_operations_.cds     08/05/87  0812.1r   08/04/87  1539.1       84897



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

/* format: style3,idind30,linecom */

mseg_access_operations_:
     procedure ();

/****
   this data segment defines a named constant for each message segment
   operation that can be called from the outer rings.  constants are
   used to identify the operation and define the type of access required
   for each operation.

    written January 1985 by M. Pandolf
    modified March 1985 by M. Pandolf to eliminate check_name and add audit_this_operation
                                     to leave caller validation intact when getting UID
   modified April 1985 by M. Pandolf to eliminate restore_caller_validation
   Modified 1985-04-16, BIM: group ms/mbx parallel operations.
             audit get_count.
*/

/**** NOTE: If you modify any of the access_operations_ referenced by this
      program, you must recompile this program with the new version of
      access_operations_ to actually make the changes take effect. */

/**** This segment would work better if it wrote its own program
      which called cds, and compiled and executed it. However,
      there is no time. So the structure below must match the
      suboutine calls below it. */

/**** Note that we assume that some gate entries will have to make 
      two calls to mseg_check_access_ to audit both sides of an
      hybrid operation. That's life in MR11 */

declare	1 mops			aligned,
	  2 data			aligned,
	    3 (d_create_seg, d_delete_seg, d_acl_modify_seg, d_acl_list_seg, d_open_seg, d_close_seg, d_compact_seg,
	         d_get_count_seg, d_read_message, d_read_own_message, d_read_delete_message, d_delete_message,
	         d_update_message, d_add_message, d_accept_wakeups_seg, d_send_normal_wakeup, d_send_urgent_wakeup,
	         d_read_attr_seg, d_modify_attr_seg, d_read_fs_attr_seg, d_modify_fs_attr_seg, d_copy_seg,
	         d_admin_add_message, d_read_delete_own_message, d_reset_salvage_bit_seg)
				aligned like mseg_access_operation,
	  2 (
	  create_seg		init (1),
	  delete_seg		init (2),
	  acl_modify_seg		init (3),
	  acl_list_seg		init (4),
	  open_seg		init (5),
	  close_seg		init (6),
	  compact_seg		init (7),
	  get_count_seg		init (8),
	  read_message		init (9),
	  read_own_message		init (10),
	  read_delete_message	init (11),
	  delete_message		init (12),
	  update_message		init (13),
	  add_message		init (14),
	  accept_wakeups_seg	init (15),
	  send_normal_wakeup	init (16),
	  send_urgent_wakeup	init (17),
	  read_attr_seg		init (18),
	  modify_attr_seg		init (19),
	  read_fs_attr_seg		init (20),
	  modify_fs_attr_seg	init (21),
	  copy_seg		init (22),
	  admin_add_message		init (23),
	  read_delete_own_message	init (24),
	  reset_salvage_bit_seg	init (25)
	  )			fixed bin;

%include mseg_access_operation;

declare	(
	DONT_AUDIT		init ("1"b),
	DONT_AUDIT_SUCCESS		init ("01"b),
	NON_NULL_MODES		init ("001"b),
	NO_MODES			init ("0001"b),
	O_FOR_R			init ("00001"b),
	O_FOR_D			init ("000001"b),
	ADMIN			init ("0000001"b),
	DIR_MODES			init ("00000001"b),
	DIR_MODES_OR_EX_MODES	init ("000000001"b)
	)			bit (36) aligned int static options (constant);


op:
     procedure (op_ptr, a_op, flags, modes, index, dir_modes);

declare	op_ptr			pointer;
declare	a_op			bit (36) aligned;
declare	modes			bit (36) aligned;
declare	flags			bit (36) aligned;
declare	index			fixed bin (9);
declare	dir_modes			bit (3);

declare	1 maop			aligned like mseg_access_operation based (op_ptr);

	unspec (maop) = ""b;
	maop.access_operation = a_op;
	maop.required_modes = modes;
	string (maop.flags) = flags;
	maop.mseg_access_op_index = index;
	maop.required_dir_modes = dir_modes;
	return;
     end op;

	call op (addr (mops.d_create_seg), access_operations_$mseg_create, NO_MODES | DIR_MODES, ""b, MSEG_CREATE_SEG,
	     M_ACCESS | A_ACCESS);
	call op (addr (mops.d_delete_seg), access_operations_$mseg_delete, NO_MODES | DIR_MODES, ""b,
	     MSEG_MODIFY_SEG_ATTR, M_ACCESS);
	call op (addr (mops.d_acl_modify_seg), access_operations_$mseg_access_mod, NO_MODES | DIR_MODES, ""b,
	     MSEG_MODIFY_SEG_ATTR, M_ACCESS);
	call op (addr (mops.d_acl_list_seg), access_operations_$mseg_access_read, NO_MODES | DIR_MODES, ""b,
	     MSEG_READ_SEG_ATTR, S_ACCESS);
	call op (addr (mops.d_open_seg), access_operations_$mseg_open, NON_NULL_MODES, ""b, MSEG_READ_SEG_ATTR, ""b);
	call op (addr (mops.d_close_seg), access_operations_$mseg_close, NO_MODES, ""b, 0, ""b);
	call op (addr (mops.d_compact_seg), access_operations_$mseg_compact, ""b, MSEG_D_ACCESS, MSEG_MODIFY_SEG_ATTR,
	     ""b);
	call op (addr (mops.d_get_count_seg), access_operations_$mseg_get_count, ""b, MSEG_S_ACCESS, MSEG_READ_SEG_ATTR,
	     ""b);
	call op (addr (mops.d_read_message), access_operations_$mseg_read_message, DONT_AUDIT_SUCCESS, MSEG_R_ACCESS,
	     MSEG_READ_MESSAGE, ""b);
	call op (addr (mops.d_read_own_message), access_operations_$mseg_read_message, O_FOR_R | DONT_AUDIT_SUCCESS,
	     MSEG_R_ACCESS, MSEG_READ_MESSAGE, ""b);
	call op (addr (mops.d_read_delete_message), access_operations_$mseg_read_delete_message, DONT_AUDIT_SUCCESS,
	     MSEG_R_ACCESS | MSEG_D_ACCESS, MSEG_MODIFY_MESSAGE, ""b);
	call op (addr (mops.d_delete_message), access_operations_$mseg_delete_message, DONT_AUDIT_SUCCESS | O_FOR_D,
	     MSEG_D_ACCESS, MSEG_MODIFY_MESSAGE, ""b);
	call op (addr (mops.d_update_message), access_operations_$mseg_update_message, DONT_AUDIT_SUCCESS,
	     MSEG_D_ACCESS, MSEG_MODIFY_MESSAGE, ""b);
	call op (addr (mops.d_add_message), access_operations_$mseg_add_message, ""b, MSEG_A_ACCESS, MSEG_ADD_MESSAGE,
	     ""b);
	call op (addr (mops.d_admin_add_message), access_operations_$mseg_add_message, ADMIN, MSEG_A_ACCESS,
	     MSEG_ADD_MESSAGE, ""b);
	call op (addr (mops.d_accept_wakeups_seg), access_operations_$mseg_accept_wakeups, ""b, MSEG_D_ACCESS,
	     MSEG_ACCEPT_WAKEUPS, ""b);
	call op (addr (mops.d_send_normal_wakeup), access_operations_$mseg_wakeup_send, ""b, MSEG_W_ACCESS, 0, ""b);
	call op (addr (mops.d_send_urgent_wakeup), access_operations_$mseg_wakeup_send, ""b, MSEG_U_ACCESS, 0, ""b);
	call op (addr (mops.d_read_attr_seg), access_operations_$mseg_attr_read, ""b, MSEG_S_ACCESS, MSEG_READ_SEG_ATTR,
	     ""b);
	call op (addr (mops.d_modify_attr_seg), access_operations_$mseg_attr_mod, ""b, MSEG_D_ACCESS,
	     MSEG_MODIFY_SEG_ATTR, ""b);
	call op (addr (mops.d_read_fs_attr_seg), access_operations_$mseg_attr_read,
	     NON_NULL_MODES | DIR_MODES_OR_EX_MODES, ""b, MSEG_READ_SEG_ATTR, S_ACCESS);
	call op (addr (mops.d_modify_fs_attr_seg), access_operations_$mseg_attr_mod, NO_MODES | DIR_MODES, ""b,
	     MSEG_MODIFY_SEG_ATTR, M_ACCESS);
	call op (addr (mops.d_copy_seg), access_operations_$mseg_read_message, ""b, MSEG_R_ACCESS, MSEG_COPY_SEG, ""b);
	call op (addr (mops.d_read_delete_own_message), access_operations_$mseg_read_delete_message,
	     O_FOR_R | O_FOR_D | DONT_AUDIT_SUCCESS, MSEG_R_ACCESS | MSEG_D_ACCESS, MSEG_MODIFY_MESSAGE, ""b);

/**** The next one, reset_salv_bit_seg, is strange.  Since the salvage bit
      is set automatically, resetting it is not strictly a write-down.
      We permit it to be reset by any process with D access that is 
      greater_or_equal to the segment parent access class.  Thus
      "READ_SEG_ATTR", since the AIM check is the same for reading the salvage 
      bit.  The covert channel here is covered by explicit code in
      mseg_$reset_salvaged_flag_seg. */

	call op (addr (mops.d_reset_salvage_bit_seg), access_operations_$mseg_attr_mod, ""b, MSEG_D_ACCESS,
	     MSEG_READ_SEG_ATTR, ""b);

dcl	code			fixed bin (35);
dcl	1 local_cds_args		aligned like cds_args;
dcl	exclude_array		(1) char (32) init ("pad*");

dcl	create_data_segment_	entry (ptr, fixed bin (35));
dcl	com_err_			entry () options (variable);

						/** begin generation of data segment */

	unspec (local_cds_args) = ""b;

	local_cds_args.sections (1).p = addr (mops);
	local_cds_args.sections (1).len = size (mops);
	local_cds_args.sections (1).struct_name = "mops";
	local_cds_args.seg_name = "mseg_access_operations_";
	local_cds_args.exclude_array_ptr = addr (exclude_array);
	local_cds_args.num_exclude_names = hbound (exclude_array, 1);
	local_cds_args.switches.have_text = "1"b;

	call create_data_segment_ (addr (local_cds_args), code);
	if code ^= 0
	then call com_err_ (code, "mseg_access_operations_");

	return;


declare	(
	access_operations_$mseg_add_message,
	access_operations_$mseg_create,
	access_operations_$mseg_delete,
	access_operations_$mseg_open,
	access_operations_$mseg_close,
	access_operations_$mseg_attr_read,
	access_operations_$mseg_attr_mod,
	access_operations_$mseg_access_read,
	access_operations_$mseg_access_mod,
	access_operations_$mseg_compact,
	access_operations_$mseg_copy,
	access_operations_$mseg_get_count,
	access_operations_$mseg_read_message,
	access_operations_$mseg_delete_message,
	access_operations_$mseg_read_delete_message,
	access_operations_$mseg_update_message,
	access_operations_$mseg_accept_wakeups,
	access_operations_$mseg_wakeup_send
	)			bit (36) aligned ext static;

%page;
%include cds_args;
%include mseg_access_mode_values;
%include access_mode_values;
     end mseg_access_operations_;




		    mseg_check_access_.pl1          08/09/88  1517.4rew 08/09/88  1516.1      345105



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


/****^  HISTORY COMMENTS:
  1) change(85-07-19,Palter), approve(86-02-20,MCR7345),
     audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092):
     Changed to not turn error_table_$noentry into error_table_$no_info if the
     directory name given to the file entrypoint is a link to a directory to
     which the user has status permission.
  2) change(85-07-24,Palter), approve(86-02-20,MCR7345),
     audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092):
     Return the new error code error_table_$not_own_message when asked to read
     or read&delete a message through an own gate which is not an own message
     and the user has sufficient access to perform the operation if a non-own
     gate were used.
  3) change(86-06-11,Lippard), approve(86-07-10,MCR7441),
     audit(86-08-05,GDixon), install(86-08-06,MR12.0-1118):
     Modified by Jim Lippard to allow courtesy upgrades of messages to
     recipient's access class.
  4) change(86-10-29,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 and to
     call access_audit_r1_$(check log)_general when there is no valid mseg ptr.
  5) change(88-08-08,Lippard), approve(88-05-02,PBF7881),
     audit(88-08-09,Farley), install(88-09-88,MR12.2-1084):
     Corrected fix for when to call (check log)_general entrypoints.
     (phx20094)  Also changed to generate audit messages when an
     entry's audit switch is on.
                                                   END HISTORY COMMENTS */

/*
   mseg_check_access_ - procedure to calculate validity of access to
   a given message segment and to log the query appropriately.

   written February 1985 by M. Pandolf
   modified March 1985 by M. Pandolf to remove name checking
                                     to use seg ptrs as a rule
			       to save access_info per ring 1 call
   modified April 1985 by M. Pandolf for misc bug fixes
   Modified 1985-04-16, BIM: restructure.
   Modified: 6 May 1985 by G Palter to censor error codes properly
*/

/* format: style3,idind30 */

mseg_check_access_:
     procedure (p_mseg_operation_ptr, p_status);

	return;					/* not an entrypoint */


/* Parameters */

dcl	p_mseg_operation_ptr	pointer parameter;
dcl	p_status			fixed bin (35) parameter;


/* Automatic */

dcl	initiate_failure		bit (1) aligned;

dcl	1 parent_access_info	aligned like entry_access_info;
dcl	parent_access_info_valid	bit (1) aligned;

dcl	link_dir_name		character (168);
dcl	link_entryname		character (32);

dcl	entry_type		fixed bin;
dcl	status			fixed bin (35);
dcl	used_privilege		bit (1) aligned;
dcl	use_ai_restricted		bit (1) aligned;


/* Constants */

declare	(
	SEGMENT			init (1),
	MESSAGE			init (2),
	CHECK			init (3)
	)			fixed bin int static options (constant);

declare	(
	DONT_CHASE		initial (0),
	CHASE			initial (1)
	)			fixed binary (1) static options (constant);


/* Static, External */

dcl	(
	error_table_$ai_restricted,
	error_table_$bad_file_name,
	error_table_$incorrect_access,
	error_table_$invalid_lock_reset,
	error_table_$moderr,
	error_table_$no_info,
	error_table_$no_message,
	error_table_$noentry,
	error_table_$not_own_message,
	error_table_$not_seg_type,
	error_table_$oosw
	)			fixed binary (35) external;

dcl	(
	sys_info$dir_privilege,
	sys_info$ring1_privilege
	)			bit (36) aligned external;


/* Entries */
dcl	access_audit_r1_$check_general
				entry () options (variable) returns (bit (1) aligned);
dcl	access_audit_r1_$check_obj_class
				entry () options (variable) returns (bit (1) aligned);
dcl	access_audit_r1_$check_obj_path
				entry () options (variable) returns (bit (1) aligned);
dcl	access_audit_r1_$check_obj_ptr
				entry () options (variable) returns (bit (1) aligned);
dcl	access_audit_r1_$log_general	entry () options (variable);
dcl	access_audit_r1_$log_obj_class
				entry () options (variable);
dcl	access_audit_r1_$log_obj_path	entry () options (variable);
dcl	access_audit_r1_$log_obj_ptr	entry () options (variable);
dcl	admin_gate_$admin_level_no_fs_audit
				entry (fixed binary (3));
dcl	aim_check_$greater		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
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	hcs_$fs_get_path_name	entry (pointer, character (*), fixed binary, character (*), fixed binary (35));
dcl	hcs_$get_access_info	entry (char (*), char (*), fixed bin (1), ptr, fixed bin (35));
dcl	hcs_$get_access_info_seg	entry (ptr, ptr, fixed bin (35));
dcl	hcs_$get_link_target	entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl	hcs_$level_set		entry (fixed bin (3));
dcl	pathname_			entry (char (*), char (*)) returns (char (168));
dcl	read_allowed_		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	read_write_allowed_		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	write_allowed_		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	set_lock_$lock		entry (bit (36) aligned, fixed binary, fixed binary (35));
dcl	sub_err_			entry () options (variable);


/* Builtins */

dcl	(addr, after, before, index, length, null, reverse, size, string, substr)
				builtin;
%page;
/**** This entrypoint is called when we have an actual message
      that we propose to delete, read, or update */

message:
     entry (p_mseg_operation_ptr, p_status);


	entry_type = MESSAGE;
	initiate_failure = "0"b;

/**** We do this work in-line here since it has little or nothing
      to do with the segment/check entrypoints. */

	status = 0;

	mseg_operation_ptr = p_mseg_operation_ptr;
	mseg_access_operation_ptr = addr (mseg_access_operations_$data (mseg_operation.access_operation));

	used_privilege = "0"b;
	use_ai_restricted = "0"b;			/* ON => audit as AIM restricted but return no_message */

	call check_message_access ();

	if mseg_operation.suppress_access_checks = "0"b	/* only audit if we actually made access checks ... */
	then if use_ai_restricted
	     then call audit_operation (error_table_$ai_restricted);
	     else call audit_operation (status);

	go to exit;


check_message_access:
     procedure ();

declare	aim_code			fixed bin (35);
declare	owner_code		fixed bin (35);

	aim_code, owner_code = 0;
	md_ptr = mseg_operation.md_ptr;

	if (mseg_operation.access_operation = mseg_access_operations_$read_own_message)
	     | (mseg_operation.access_operation = mseg_access_operations_$read_delete_own_message)
	then /*** The user has asked to only operate on his own messages */
	     if owner_matches ()
	     then owner_code = 0;
	     else if mseg_operation.access_info_valid
		& ((mseg_operation.access_info.extended_access_modes & MSEG_R_ACCESS) ^= ""b)
	     then /*** The user has read access and, therefore, is allowed
		     to find out the he did specify a real message. */
		owner_code = error_table_$not_own_message;
	     else owner_code = error_table_$no_message;

	else if mseg_operation.only_own_access
	then /*** We had to substitute own access for read and/or delete
		access in order to allow this operation to get this far. */
	     if owner_matches ()
	     then owner_code = 0;
	     else if mseg_operation.access_info_valid
		& ((mseg_operation.access_info.extended_access_modes & MSEG_R_ACCESS) ^= ""b)
	     then /*** We substituted own for delete as the user has read
		     access -- Therefore we can tell the user that he lacks
		     the appropriate access to modify the message as he
		     does have enough access to find out it exists. */
		owner_code = error_table_$moderr;
	     else owner_code = error_table_$no_message;

	else owner_code = 0;

	if mseg_operation.suppress_access_checks	/* all we are doing is checking owner-ness */
	then do;
		if owner_code ^= 0
		then status = error_table_$no_message;
		return;
	     end;

	if mseg_access_operation.mseg_access_op_index = MSEG_READ_MESSAGE
	then do;
		if ^aim_check_$greater_or_equal (mseg_operation.caller.authorization,
		     message_descriptor.ms_access_class)
		then if ((mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b)
		     then used_privilege = "1"b;
		     else do;
			     aim_code = error_table_$no_message;
			     use_ai_restricted = "1"b;
			end;
		else ;				/* authorization is OK */
	     end;

	else if mseg_access_operation.mseg_access_op_index = MSEG_MODIFY_MESSAGE
	then do;
		if ^aim_check_$equal (mseg_operation.caller.authorization, message_descriptor.ms_access_class)
		then if ((mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b)
		     then used_privilege = "1"b;
		     else if
			aim_check_$greater (mseg_operation.caller.authorization, message_descriptor.ms_access_class)
		     then aim_code = error_table_$ai_restricted;
		     else do;
			     aim_code = error_table_$no_message;
			     use_ai_restricted = "1"b;
			end;
	     end;


/**** Now invent the correct status code. If we were willing to
      return ai_restricted, then we are willing to inform the user
      that the message exists, and so we return the owner code (if any).
      If the aim code was no_message, meaning that we are not willing
      to reveal the existence of the message, then we must return that. */

	if aim_code = error_table_$ai_restricted & owner_code ^= 0
	then status = owner_code;
	else if aim_code ^= 0
	then status = aim_code;
	else status = owner_code;

	return;


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

declare	name			char (32) varying;
declare	message_name		char (32) varying;

	name = before (mseg_operation.caller.group_id, ".");
						/* assume user name is relevant to begin with */
	message_name = before (message_descriptor.sender_id, ".");

	if message_name = "anonymous"
	then if name ^= "anonymous"
	     then return ("0"b);			/* only anon can own anon */

	if name = "anonymous"			/* nope, project is important */
	then do;
		name = before (after (mseg_operation.caller.group_id, "."), ".");
						/* PROJECT */
		message_name = before (after (message_descriptor.sender_id, "."), ".");
						/* PROJECT */
	     end;

	return (name = message_name);

     end owner_matches;

     end check_message_access;
%page;
/**** This entrypoint is called for segment-level access checks.
      It respects mseg_access_operation.dont_audit_success.
      Those operations are audited when the $message entrypoint is called */

segment:
     entry (p_mseg_operation_ptr, p_status);

	entry_type = SEGMENT;
	initiate_failure = "0"b;
	go to COMMON;


/**** This entrypoint is called for a few cases where the situation
      is so intricate that the caller takes responsibility for
      the audit situation. */

check:
     entry (p_mseg_operation_ptr, p_status);

	entry_type = CHECK;
	initiate_failure = "0"b;

COMMON:
	p_status = 0;

	mseg_operation_ptr = p_mseg_operation_ptr;
	if mseg_operation.suppress_access_checks
	then return;

	if ^mseg_operation.mseg_ptr_valid & ^mseg_operation.mseg_pathname_valid
	then call sub_err_ (0, "mseg_check_access_", ACTION_CANT_RESTART, null (), (0),
		"Neither a pathname nor a segment pointer was supplied.");

	used_privilege = "0"b;
	mseg_access_operation_ptr = addr (mseg_access_operations_$data (mseg_operation.access_operation));


/**** Obtain access information needed to validate the user's access.  As our
      validation level is now lower than the user's, we can learn things about
      the segment that the user isn't allowed to know.  We must be sure to
      translate any error codes obtain through this knowlege into
      error_table_$no_info. */

	parent_access_info_valid = "0"b;

	if mseg_access_operation.mseg_access_op_index = MSEG_CREATE_SEG
	then do;

/**** Creation is different from the other operations in that we expect that
      the segment doesn't exist.  Therefore, we must find the true pathname
      of the segment by chasing the link ourself and, as the segment is assumed
      to not exist, we need only check that it will have a proper name.  We
      chase the link using the user's validation rather than our own to insure
      that get_link_target returns the status code that the user would see. */

		call hcs_$level_set (mseg_operation.caller.validation_level);
		call hcs_$get_link_target (mseg_operation.dir_name, mseg_operation.entryname, link_dir_name,
		     link_entryname, status);
		if mseg_operation.call_admin_gate
		then call admin_gate_$admin_level_no_fs_audit ((0));
		else call hcs_$level_set (mseg_data_$execution_ring);

		if (status ^= 0) & (status ^= error_table_$noentry)
		then go to audit_and_exit;		/* it's already the proper code */

		mseg_operation.dir_name = link_dir_name;/* be sure to use the "chased" pathname */
		mseg_operation.entryname = link_entryname;
		mseg_operation.access_info.extended_access_modes = MSEG_NULL_ACCESS;
						/* above will force censor_if_neeed into action */

		if ^valid_name (mseg_operation.entryname)
		then do;
			status = censor_if_needed (error_table_$bad_file_name);
			go to audit_and_exit;
		     end;
	     end;


	else if mseg_operation.access_info_valid = "0"b
	then do;
		if mseg_operation.mseg_ptr_valid
		then call hcs_$get_access_info_seg (mseg_operation.mseg_ptr, addr (mseg_operation.access_info),
			status);
		else call hcs_$get_access_info (mseg_operation.dir_name, mseg_operation.entryname, 1 /* chase */,
			addr (mseg_operation.access_info), status);
		if status ^= 0
		then do;
			status = censor_if_needed (status);
			go to audit_and_exit;
		     end;
		mseg_operation.access_info_valid = "1"b;
		if ^valid_segment ()
		then do;
			status = censor_if_needed (error_table_$not_seg_type);
			go to audit_and_exit;
		     end;
	     end;


/**** Check access based upon discretionary and mandatory controls.  As message
      segments do not yet have extended ring brackets, the only ring bracket
      check that must be made is when the user does not have the proper
      discretionary access (i.e., extended modes).  In this case, while we may
      be able to tell the exact error in our ring, the branch's parent's ring
      brackets may prohibit us from telling the user and we must then return
      error_table_$no_info. */

	status = 0;

	if acl_ok_for_operation (status)
	then if aim_ok_for_operation ()
	     then ;
	     else status = error_table_$ai_restricted;
	/*** acl_ok_for_operation will set status to proper value */


/**** Audit the success/failure of the operation if appropriate */

audit_and_exit:
	call audit_operation (status);

exit:
	p_status = status;

	return;
%page;
/**** This entrypoint is called by mseg_mbx_ms_gate_target_ if its call to
      mseg_$initiate_seg fails.  The purpose of this entrypoint is to audit
      the failure of the operation being attempted by the gate target.
      Further, this entrypoint is responsible for censoring the error code
      returned to the user of the gate because, as we are normally at a
      lower validation level than the user, we can determine more about the
      failure to initiate the segment than the user should be allowed
      to know. */

audit_initiate_failure:
     entry (p_mseg_operation_ptr, p_status);

	entry_type = SEGMENT;			/* we want the audit */
	initiate_failure = "1"b;

	mseg_operation_ptr = p_mseg_operation_ptr;
	mseg_access_operation_ptr = addr (mseg_access_operations_$data (mseg_operation.access_operation));

	parent_access_info_valid = "0"b;		/* censor_if_needed must find the parent's access */
	mseg_operation.access_info.extended_access_modes = MSEG_NULL_ACCESS;
	status = censor_if_needed (p_status);

	used_privilege = ((mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b);
	call audit_operation (status);

	p_status = status;				/* be sure the gate returns the right code */

	return;
%page;
valid_segment:
     procedure () returns (bit (1) aligned);

dcl	bracket			fixed bin;

	if mseg_operation.access_info.type ^= 1		/* seg */
	then return ("0"b);

	do bracket = 1 to 3;
	     if mseg_operation.access_info.ring_brackets (bracket) ^= mseg_data_$execution_ring
	     then return ("0"b);
	end;

	return (valid_name (mseg_operation.access_info.entryname));

     end valid_segment;


valid_name:
     procedure (p_entryname) returns (bit (1) aligned);

dcl	p_entryname		character (32) parameter;
dcl	xiffus_index		fixed bin;
dcl	name_length		fixed bin;

	name_length = length (p_entryname);

	xiffus_index = index (reverse (p_entryname), ".");/* suffix backwards, silly */

	if xiffus_index = 0
	then return ("0"b);

	if mseg_operation.type = MSEG_TYPE_MBX
	then if substr (p_entryname, name_length - xiffus_index + 2) ^= "mbx"
	     then return ("0"b);

	if mseg_operation.type = MSEG_TYPE_MS
	then if substr (p_entryname, name_length - xiffus_index + 2) ^= "ms"
	     then return ("0"b);

	return ("1"b);

     end valid_name;
%page;
/**** Censor the status code we want to return to the user if appropriate --
      As we are usually running with a lower validation level than the user,
      we can often determine certain things about the segment that the user
      can not determine on his own.  In particular, if the user were to make
      one of the calls which we made from his validation level, where his real
      effective access to the segment would be null, ring 0 will return
      error_table_$no_info unless the user has non-null effective access to
      the segment's parent.  Therefore, we must do the same.  We do this by
      changing any code to be returned into error_table_$no_info if the user
      has both null extended access to the segment and null effective access
      to the parent.  We use the extended access to the segment rather than
      the real access to decide when we should censor as the extended access
      is what the user considers to be his real access to the segment. */

censor_if_needed:
     procedure (p_return_status) returns (fixed binary (35));

dcl	p_return_status		fixed binary (35);

dcl	parent_dir_name		character (168);
dcl	chase_the_parent		fixed binary (1);
dcl	code			fixed binary (35);


	if (p_return_status ^= error_table_$bad_file_name) & (p_return_status ^= error_table_$incorrect_access)
	     & (p_return_status ^= error_table_$moderr) & (p_return_status ^= error_table_$noentry)
	     & (p_return_status ^= error_table_$not_seg_type)
	then return (p_return_status);		/* only censor codes that user may not be able to determine */

	if parent_access_info_valid = "0"b
	then do;

/**** We need to determine the parent's effective access.  First we must get
      the pathname.  As this procedure can be called before the access_info of
      the segment has been determined, we may have to look in several places to
      find the parent's name. */

		if mseg_operation.access_info_valid
		then do;
			parent_dir_name = mseg_operation.access_info.dir_name;
			chase_the_parent = DONT_CHASE;
		     end;

		else if mseg_operation.mseg_pathname_valid
		then do;
			parent_dir_name = mseg_operation.dir_name;
			chase_the_parent = CHASE;
		     end;

		else /*** if mseg_operation.mseg_ptr_valid then */
		     do;
			call hcs_$fs_get_path_name (mseg_operation.mseg_ptr, parent_dir_name, (0), ((32)" "), code);
			if code ^= 0		/* only fails if parent and segment access both null */
			then return (error_table_$no_info);
			chase_the_parent = DONT_CHASE;
		     end;

		parent_access_info.version = ENTRY_ACCESS_INFO_VERSION_1;

		call hcs_$get_access_info (parent_dir_name, "", chase_the_parent, addr (parent_access_info), code);
		if code ^= 0			/* failure implies no access on the parent */
		then return (error_table_$no_info);

/**** As our execution ring is always lower (or equal) to our caller's
      validation level, we must factor the directory ring brackets into our
      effective access on the parent ourselves. */

		if mseg_operation.caller.validation_level > parent_access_info.ring_brackets (1)
		then /*** outside of modify bracket -- remove M and A access */
		     parent_access_info.effective_access_modes =
			parent_access_info.effective_access_modes & ^(A_ACCESS | M_ACCESS);

		if mseg_operation.caller.validation_level > parent_access_info.ring_brackets (2)
		then /*** outside of status bracket -- remove S access */
		     parent_access_info.effective_access_modes =
			parent_access_info.effective_access_modes & ^(S_ACCESS);

		parent_access_info_valid = "1"b;
	     end;

/**** Now that we have the parent's effective access based on the user's
      validation, we can properly censor the status code we want to return. */

	if ((mseg_operation.access_info.extended_access_modes & MSEG_FULL_ACCESS) = ""b)
	     & ((parent_access_info.effective_access_modes & SMA_ACCESS) = ""b)
	then return (error_table_$no_info);
	else return (p_return_status);

     end censor_if_needed;
%page;
acl_ok_for_operation:
     procedure (return_status) returns (bit (1) aligned);

declare	return_status		fixed bin (35);
declare	grant_on_ex_access		bit (1) aligned;

	grant_on_ex_access = ex_acl_ok ();		/* check if extended access is OK */

	if mseg_access_operation.flags.dir_modes_or_ex_modes
	then if grant_on_ex_access
	     then return ("1"b);
	     else return (parent_access_ok ());

	if ^grant_on_ex_access
	then do;
		return_status = censor_if_needed (error_table_$moderr);
		return ("0"b);
	     end;

	if mseg_access_operation.flags.dir_modes
	then return (parent_access_ok ());

	else return ("1"b);


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

declare	test_mode			bit (36) aligned;

	if mseg_access_operation.flags.no_modes
	then return ("1"b);

	if mseg_access_operation.flags.non_null_modes
	then return ((mseg_operation.access_info.extended_access_modes & MSEG_FULL_ACCESS) ^= ""b);

/**** O mode is handled as follows: if all the requested x modes are present,
      then we are fine. Otherwise, check the O substitution flags. */

	if (mseg_operation.access_info.extended_access_modes & mseg_access_operation.required_modes)
	     = mseg_access_operation.required_modes
	then return ("1"b);

	if (mseg_operation.access_info.extended_access_modes & MSEG_O_ACCESS) = ""b
	then return ("0"b);				/* if no own mode, then give up */

	if ^(mseg_access_operation.flags.o_for_r | mseg_access_operation.flags.o_for_d)
	then return ("0"b);

	test_mode = mseg_access_operation.required_modes; /* start with the full set */
	if mseg_access_operation.flags.o_for_r
	then test_mode = (test_mode & ^MSEG_R_ACCESS);	/* remove R from the st */
	if mseg_access_operation.flags.o_for_d
	then test_mode = (test_mode & ^MSEG_D_ACCESS);	/* Remove D from the set */

	if (test_mode & mseg_operation.access_info.extended_access_modes) = test_mode
	then do;					/* Do we have enough ? */
		mseg_operation.only_own_access = "1"b;	/* yes, but note that we used O */
		return ("1"b);
	     end;

	else return ("0"b);

     end ex_acl_ok;


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

declare	code			fixed bin (35);

	parent_access_info.version = ENTRY_ACCESS_INFO_VERSION_1;

	if mseg_operation.access_info_valid		/* access_info isn't valid for create operation */
	then call hcs_$get_access_info (mseg_operation.access_info.dir_name, "", (0), addr (parent_access_info), code);
	else call hcs_$get_access_info (mseg_operation.dir_name, "", (0), addr (parent_access_info), code);

	if code ^= 0
	then do;
		return_status = error_table_$no_info;
		return ("0"b);
	     end;

/**** As our execution ring is always lower (or equal) to our caller's
      validation level, we must factor the directory ring brackets into our
      effective access on the parent ourselves. */

	if mseg_operation.caller.validation_level > parent_access_info.ring_brackets (1)
	then /*** outside of modify bracket -- remove M and A access */
	     parent_access_info.effective_access_modes =
		parent_access_info.effective_access_modes & ^(A_ACCESS | M_ACCESS);

	if mseg_operation.caller.validation_level > parent_access_info.ring_brackets (2)
	then /*** outside of status bracket -- remove S access */
	     parent_access_info.effective_access_modes = parent_access_info.effective_access_modes & ^(S_ACCESS);

	parent_access_info_valid = "1"b;		/* stop censor_if_needed from making the call twice */

/**** The directory ring brackets are now properly factored into our access.
      We can now check if we have the access we need. */

	if (mseg_access_operation.required_dir_modes & parent_access_info.effective_access_modes)
	     = mseg_access_operation.required_dir_modes
	then return ("1"b);				/* enough access */

/**** We don't have the required access to the branch's parent -- We want
      to return error_table_$incorrect_access unless the user isn't allowed
      to determine that from his validation level.  Therefore, we'll simply
      allow censor_if_needed to make the decision on which code to return. */

	return_status = censor_if_needed (error_table_$incorrect_access);

	return ("0"b);

     end parent_access_ok;

     end acl_ok_for_operation;
%page;
aim_ok_for_operation:
     procedure returns (bit (1) aligned);

dcl	code			fixed bin (35);

/****^ There are some standard AIM tests, and some peculiar ones.
       the standard ones are keyed off of the READ/APPEND/MODIFY
       classification.
   
       The per-segment checks are these:

       READ-SEGMENT-INFO -- auth >= segment-min-auth 
       MODIFY-SEGMENT-INFO -- auth = segment-min-auth
       COPY-SEGMENT -- max-auth >= segment-max-auth (insures new container will hold all messages)
		   auth = segment-min-auth		   

       Special checks:

       ADD-MESSAGE -- segment-min <= message-acc <= segment-max
		  auth <= message-acc OR ring1 priv
       
       ACCEPT-MESSAGES  -- MODIFY-SEGMENT-INFO + various
		    additional checks below.
*/

	if mseg_access_operation.mseg_access_op_index = MSEG_READ_SEG_ATTR
	then return (read_attr_ok ());

	else if mseg_access_operation.mseg_access_op_index = MSEG_MODIFY_SEG_ATTR
	then return (modify_attr_ok ());

	else if mseg_access_operation.mseg_access_op_index = MSEG_COPY_SEG
	then return (copy_ok ());

	else if mseg_access_operation.mseg_access_op_index = MSEG_ADD_MESSAGE
	then return (add_message_ok ());

	else if mseg_access_operation.mseg_access_op_index = MSEG_MODIFY_MESSAGE
	then return (modify_message_ok ());

	else if mseg_access_operation.mseg_access_op_index = MSEG_ACCEPT_WAKEUPS
	then return (accept_wakeups_ok ());

	else if mseg_access_operation.mseg_access_op_index = MSEG_READ_MESSAGE
	then return (read_message_ok ());

	else return ("1"b);				/* no check defined */


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

	if read_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class)
	then return ("1"b);
	else return (priv_ok ());

     end read_attr_ok;


modify_attr_ok:
     procedure returns (bit (1) aligned);
	if read_write_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class)
	then return ("1"b);
	else return (priv_ok ());

     end modify_attr_ok;


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

	if aim_check_$greater_or_equal (mseg_operation.caller.max_authorization,
	     mseg_operation.access_info.access_class)
	     & read_write_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class)
	then return ("1"b);
	return (priv_ok () & ((mseg_operation.caller.privileges & sys_info$dir_privilege) ^= ""b));
						/* the caller cannot append the new message segment with the appropriate characteristics without dir priv */

     end copy_ok;


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

	if ^(aim_check_$greater_or_equal (mseg_operation.message_info.ms_access_class,
	     mseg_operation.access_info.parent_access_class)
	     &
	     aim_check_$greater_or_equal (mseg_operation.access_info.access_class,
	     mseg_operation.message_info.ms_access_class))
	then return ("0"b);				/* Message not permitted in segment, no-how */

	if priv_ok ()
	then return ("1"b);				/* no need for user checks */

	if ^aim_check_$greater_or_equal (mseg_operation.caller.authorization,
	     mseg_operation.access_info.parent_access_class)
	then return ("0"b);				/* not allowed to write in here */

	if ^aim_check_$greater_or_equal (mseg_operation.message_info.ms_access_class,
	     mseg_operation.caller.authorization)
	then return ("0"b);				/* must mark information >= to self */

/* Reject if message access class is greater than the sender's maximum
   authorization except in the case of courtesy upgrades, when the message
   access class is the same as the authorization of the recipient. */
	if ^aim_check_$greater_or_equal (mseg_operation.caller.max_authorization,
	     mseg_operation.message_info.ms_access_class)
	then if mseg_operation.wakeup_state_valid
	     then if ^aim_check_$equal (mseg_operation.message_info.ms_access_class,
		     mseg_operation.wakeup_state.access_class)
		then return ("0"b);
		else;
	     else return ("0"b);			/* must mark information <= to max */

	return ("1"b);

/**** If message>=user, and message<=segment_max, then user <=segment_max,
      so no seperate check is needed for that. */

     end add_message_ok;


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

/**** This is just the initial segment check */
/**** Can we possibly modify anything in this segment? */

	if read_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class)
	     & write_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.access_class)
	then return ("1"b);
	else return (priv_ok ());

     end modify_message_ok;


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

/**** This is just the initial segment check */

	if read_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class)
	then return ("1"b);
	else return (priv_ok ());

     end read_message_ok;


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

	if (mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b
	then do;
		used_privilege = "1"b;
		return ("1"b);
	     end;
	else return ("0"b);

     end priv_ok;


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

declare	test_lock_id		bit (36) aligned;

	if ^basic_accept_ok ()
	then return ("0"b);

/**** Now check for the covert channel ... */

	if ^mseg_operation.wakeup_state_valid
	then return ("1"b);				/* no message implies that all is fine */

	if aim_check_$greater_or_equal (mseg_operation.caller.authorization, mseg_operation.wakeup_state.access_class)
	then return ("1"b);

	test_lock_id = mseg_operation.wakeup_state.lock_id;
	call set_lock_$lock (test_lock_id, 0, code);

	if (code = 0) | (code = error_table_$invalid_lock_reset)
	then return ("1"b);
	else return ("0"b);


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

	return (modify_message_ok ());		/* Same check */

     end basic_accept_ok;

     end accept_wakeups_ok;

     end aim_ok_for_operation;
%page;
audit_operation:
     procedure (code);

dcl	code			fixed bin (35) parameter;

declare	1 event_flags		unaligned like audit_event_flags;
declare	do_audit			bit (1) aligned;
declare	1 a_audit_mseg_msg		aligned like audit_mseg_msg_info;

	if entry_type = CHECK
	then return;

	if mseg_access_operation.dont_audit
	then return;
	if ^mseg_operation.call_admin_gate
	then return;

	if code = 0 & entry_type = SEGMENT & mseg_access_operation.flags.dont_audit_success
	then return;				/* This will be audited on the second pass */

	if (code ^= 0) & (code ^= error_table_$ai_restricted) & (code ^= error_table_$incorrect_access)
	     & (code ^= error_table_$moderr) & (code ^= error_table_$no_info) & (code ^= error_table_$oosw)
	then return;				/* only audit success or access violations */

	string (event_flags) = ""b;
	if code = 0
	then event_flags.grant = "1"b;
	if mseg_access_operation.admin
	then event_flags.admin_op = "1"b;
	if used_privilege
	then event_flags.priv_op = "1"b;

/**** Now for a puzzle. Audit the message, or audit the segment? 
      We check based on the message, if any, and then log the 
      segment. */

/* Checks for the case where the audit switch is on.  These need to be
   reached before such checks as the one below for the case where
   mseg_access_operation.access_info_valid is on, as that doesn't
   reference the mailbox entry itself. */

	if mseg_operation.mseg_ptr_valid
	then do_audit =
		access_audit_r1_$check_obj_ptr (string (event_flags), mseg_access_operation.access_operation,
		mseg_operation.mseg_ptr);

	else if mseg_operation.mseg_pathname_valid
	then do_audit =
		access_audit_r1_$check_obj_path (string (event_flags), mseg_access_operation.access_operation,
		pathname_ (mseg_operation.dir_name, mseg_operation.entryname));

	if do_audit then goto DO_THE_AUDIT;

/* Now check for the other conditions. */

	if mseg_operation.md_ptr_valid = "1"b
	then do_audit =
		access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation,
		mseg_operation.md_ptr -> message_descriptor.ms_access_class);

	else if mseg_access_operation.mseg_access_op_index = MSEG_ADD_MESSAGE
	then do_audit =
		access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation,
		mseg_operation.message_info.ms_access_class);

	else if mseg_access_operation.mseg_access_op_index = MSEG_CREATE_SEG
	then do_audit =
		access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation,
		mseg_operation.caller.max_authorization);

	else if mseg_operation.access_info_valid
	then if mseg_access_operation.mseg_access_op_index = MSEG_COPY_SEG
	     then do_audit =
		     access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation,
		     mseg_operation.access_info.access_class);
						/* we are copying all of those message, possibly up to the max */
	     else do_audit =
		     access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation,
		     mseg_operation.access_info.parent_access_class);
						/* The mseg information is controlled at the base access class, not the MAX */

	else if mseg_operation.mseg_ptr_valid
	then do_audit =
		access_audit_r1_$check_obj_ptr (string (event_flags), mseg_access_operation.access_operation,
		mseg_operation.mseg_ptr);

	else if initiate_failure
	then do_audit =
		access_audit_r1_$check_general (string (event_flags), mseg_access_operation.access_operation);

	else if mseg_operation.mseg_pathname_valid
	then do_audit =
		access_audit_r1_$check_obj_path (string (event_flags), mseg_access_operation.access_operation,
		pathname_ (mseg_operation.dir_name, mseg_operation.entryname));

	else call sub_err_ (0, "mseg_check_access_", ACTION_CANT_RESTART, null (), (0),
		"Attempt to audit an mseg operation without a valid mseg_operation.");

	if ^do_audit
	then return;

DO_THE_AUDIT:
	audit_mseg_msg_ptr = null ();
	if mseg_operation.md_ptr_valid
	then do;
		audit_mseg_msg_ptr = addr (a_audit_mseg_msg);
		audit_mseg_msg_info.info_type = AAB_mseg_msg;
		audit_mseg_msg_info.version = AUDIT_MSEG_MSG_INFO_VERSION_5;
		audit_mseg_msg_info.descriptor = mseg_operation.md_ptr -> message_descriptor, by name;
	     end;

	if mseg_access_operation.mseg_access_op_index = MSEG_CREATE_SEG
	then call access_audit_r1_$log_obj_class ("mseg_check_access_", mseg_operation.caller.validation_level,
		string (event_flags), mseg_access_operation.access_operation, mseg_operation.caller.max_authorization,
		pathname_ (mseg_operation.dir_name, mseg_operation.entryname), code, audit_mseg_msg_ptr,
		size (audit_mseg_msg_info));


	else if mseg_operation.mseg_ptr_valid
	then call access_audit_r1_$log_obj_ptr ("mseg_check_access_", mseg_operation.caller.validation_level,
		string (event_flags), mseg_access_operation.access_operation, mseg_operation.mseg_ptr, code,
		audit_mseg_msg_ptr, size (audit_mseg_msg_info));

	else if initiate_failure
	then call access_audit_r1_$log_general ("mseg_check_access_", mseg_operation.caller.validation_level,
		string (event_flags), mseg_access_operation.access_operation,
		pathname_ (mseg_operation.dir_name, mseg_operation.entryname), code,
		audit_mseg_msg_ptr, size (audit_mseg_msg_info));

	else call access_audit_r1_$log_obj_path ("mseg_check_access_", mseg_operation.caller.validation_level,
		string (event_flags), mseg_access_operation.access_operation,
		pathname_ (mseg_operation.dir_name, mseg_operation.entryname), code,
		audit_mseg_msg_ptr, size (audit_mseg_msg_info));

	return;

     end audit_operation;

/* format: off */
%page; %include access_audit_binary_def;
%page; %include access_audit_mseg_info;
%page; %include mseg_access_mode_values;
%page; %include mseg_access_operation;
%page; %include mseg_data_;
%page; %include mseg_message_info;
%page; %include mseg_operation;
%page; %include mseg_segment;
%page; %include mseg_message;
%page; %include access_mode_values;
%page; %include access_audit_eventflags;
%page; %include entry_access_info;
%page; %include mseg_wakeup_state;
%page; %include sub_err_flags;
%page; %include mseg_access_operations_;
%page;

/* BEGIN MESSAGE DOCUMENTATION


   Message:
   Audit (mseg_check_access_): [GRANTED | DENIED] OPERATION_DESCRIPTION ADDED_INFO

   S:  $access_audit

   T:  $run

   M:  An access control decision has been made by the mseg_ primitives.
   The OPERATION_DESCRIPTION specifies the operation requested by the user.
   GRANTED or DENIED indicates whether access was granted or not. 
   the ADDED_INFO describes the user and the message segment or mailbox.
   The associated binary info describes the message in the segment if
   a specific message was involved.

   A:  $notify_ssa

   
   END MESSAGE DOCUMENTATION */

/* format: on */

     end mseg_check_access_;




		    mseg_data_.cds                  05/13/85  1556.3r w 05/13/85  1541.1       24525



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

/* mseg_data_.cds -- static and text data for the message segment 
   primitives */

/* format: style3,idind30 */

mseg_data_:
     procedure;

declare	1 mseg_text		aligned,
	  2 template_operation	aligned like mseg_operation,
	  2 max_message_size	fixed bin (35) init (262110),
	  2 block_size		fixed bin (35) init (32),
	  2 admin_ring		fixed binary (3) initial (1);

declare	1 mseg_static		aligned,
	  2 lock_id		bit (36) aligned init (""b),
	  2 process_max_authorization bit (72) aligned init (""b),
	  2 group_id		char (32) unaligned,
	  2 execution_ring		fixed bin (3) aligned;

declare	1 cdsa			aligned like cds_args;

declare	create_data_segment_	entry (pointer, fixed binary (35));
declare	com_err_			entry () options (variable);
declare	code			fixed bin (35);


	mseg_operation_ptr = addr (mseg_text.template_operation);
	unspec (mseg_operation) = ""b;
	mseg_operation.version = MSEG_OPERATION_VERSION_1;
	mseg_operation.operation = ""b;
	mseg_operation.access_operation = 0;
	mseg_operation.caller.validation_level = -1;
	mseg_operation.caller.authorization = ""b;
	mseg_operation.caller.max_authorization = ""b;
	mseg_operation.caller.group_id = "";
	string (mseg_operation.flags) = ""b;
	mseg_operation.dir_name = "";
	mseg_operation.entryname = "";
	mseg_operation.mseg_ptr = null ();
	mseg_operation.md_ptr = null ();
	mseg_operation.access_info.version = ENTRY_ACCESS_INFO_VERSION_1;
	mseg_operation.access_info.type = 0;
	mseg_operation.access_info.dir_name = "";
	mseg_operation.access_info.entryname = "";
	mseg_operation.message_info.version = MSEG_MESSAGE_INFO_V1;
	mseg_operation.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1;

	unspec (cdsa) = ""b;
	cdsa.sections (1) /* text */ .p = addr (mseg_text);
	cdsa.sections (1).len = currentsize (mseg_text);
	cdsa.sections (1).struct_name = "mseg_text";

	cdsa.sections (2) /* static */ .p = addr (mseg_static);
	cdsa.sections (2).len = currentsize (mseg_static);
	cdsa.sections (2).struct_name = "mseg_static";

	cdsa.seg_name = "mseg_data_";
	cdsa.num_exclude_names = 0;
	cdsa.exclude_array_ptr = null ();
	cdsa.switches.have_text, cdsa.switches.have_static = "1"b;

	call create_data_segment_ (addr (cdsa), code);
	if code ^= 0
	then call com_err_ (code, "mseg_data_");
	return;

%include cds_args;
%include mseg_operation;
%include entry_access_info;
%include mseg_message_info;
%include mseg_wakeup_state;
     end mseg_data_;




		    mseg_format_errors_.alm         11/05/86  1242.0r w 11/04/86  1038.1       20115



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

" Standard system status codes corresponding to the possible errors which the message
"    segment primitives may detect in the format of a message segment

" Created:  April 1985 by G. Palter


	name	mseg_format_errors_

	include	et_macros
	
	et	mseg_format_errors_


ec   bad_descriptor_sentinel,none,
	(Message contains a descriptor of unknown format.)

ec   bad_mseg_sentinel,none,
	(Message segment has an unknown format.)

ec   bad_mseg_version,none,
	(Message segment has an unsupported format.)

ec   circular_hash_chain,none,
	(Circular hash chain found in segment.)

ec   circular_message_blocks,none,
	(Circular block chain found in a message.)

ec   circular_message_chain,none,
	(Circular chronological message chain found in segment.)

ec   descriptor_in_other_block,none,
	(Descriptor found in the middle of a message.)

ec   inconsistent_backward_chain,none,
	(Segment reverse chronological message chain inconsistent.)

ec   inconsistent_block_map,none,
	(Free block count and block map do not agree.)

ec   inconsistent_forward_chain,none,
	(Segment chronological message chain inconsistent.)

ec   inconsistent_hash_chain,none,
	(Segment contains one or more inconsistent hash chains.)

ec   inconsistent_message_count,none,
	(Message count is inconsistent with chronological message chains.)

ec   inconsistent_message_length,none,
	(Message size in descriptor does not agree with actual data.)

ec   invalid_message_block_offset,none,
	(Offset of message is outside segment bounds or not on a block boundary.)

ec   modification_in_progress,none,
	(Previous operation was abnormally terminated.)

ec   negative_message_count,none,
	(Message count is negative.)

ec   no_descriptor_in_first_block,none,
	(Message does not contain a descriptor.)

ec   salvage_in_progress,none,
	(Previous salvage was abnormally terminated.)

ec   unused_block_in_message,none,
	(Free block found in message chain.)

	end




		    mseg_fs_interface_.pl1          03/15/89  0844.0r w 03/15/89  0800.0      282951



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



/****^  HISTORY COMMENTS:
  1) change(85-05-28,Palter), approve(86-02-20,MCR7345),
     audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092):
     Fix delete_acl_entries_seg to not always return error_table_$argerr.
  2) change(85-06-12,Palter), approve(86-02-20,MCR7345),
     audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092):
     Fix list_acl_seg to not return error_table_$noalloc for an empty ring 0
     ACL.
  3) change(86-10-29,Lippard), approve(86-11-24,MCR7578),
     audit(87-07-13,Dickson), install(87-08-06,MR12.1-1067):
     Modified to enforce restrictions on extended ACLs.
  4) change(88-03-09,Lippard), approve(88-03-28,MCR7869),
     audit(88-04-26,Parisek), install(88-05-03,MR12.2-1044):
     Modified to return specific error codes for inconsistent ACL modes.
                                                   END HISTORY COMMENTS */


/* Message segment primitive operations (mseg_) which interface with the ring-0 file system */

/* Created:  April 1985 by G. Palter based upon mseg_, mseg_create_, mseg_access_, and mseg_chname_ */

/* format: style3,linecom */

mseg_fs_interface_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

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

dcl	P_acl_ptr		pointer parameter;		/* add_acl_entries_seg: -> ACL entries to add/update (I);
						   create_seg: -> initial ACL for the segment (if any) (I);
						   delete_acl_entries_seg: -> ACL entries to be deleted (I);
						   list_acl_seg: set -> the segment's ACL (O);
						   list_acl_entries_seg: -> ACL entries to be listed (I);
						   replace_acl_seg: -> the segment's new ACL (I) */

dcl	P_old_name	character (*) parameter;	/* chname_seg: old name to be removed (I) */
dcl	P_new_name	character (*) parameter;	/* chname_seg: new name to be added (I) */

dcl	P_mseg_index_table_ptr			/* delete_seg: -> caller's table of user ring indeces (I) */
			pointer parameter;

dcl	P_safety_switch	bit (1) aligned parameter;	/* set_safety_switch_seg: the new value of the switch (I) */


/* Local copies of parameters */

dcl	code		fixed binary (35);


/* Remaining declarations */

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

dcl	1 ring0_acl	aligned based (ring0_acl_ptr),
	  2 entries	(ring0_acl_count) aligned like segment_acl_entry;
dcl	1 ring0_delete_acl	aligned based (ring0_acl_ptr),
	  2 entries	(ring0_acl_count) aligned like delete_acl_entry;
dcl	ring0_acl_ptr	pointer;
dcl	ring0_acl_count	fixed binary;

dcl	1 default_initial_acl			/* general_extended_acl can not be used with like */
			aligned,
	  2 version	character (8) aligned,
	  2 count		fixed binary,
	  2 entries	(3) like general_extended_acl_entry;

dcl	1 cbi		aligned like create_branch_info;

dcl	1 delete_all_others_acl
			aligned like delete_acl_entry;
dcl	delete_all_others_access
			bit (1) aligned;
dcl	delete_all_others_code
			fixed binary (35);

dcl	ext_mode		bit (36) aligned;

dcl	operation_specific_return
			entry (fixed binary (35)) variable;
dcl	operation_specific_abort
			entry () variable;
dcl	operation_name	character (64);

dcl	mseg_dir_name	character (168);
dcl	mseg_entryname	character (32);

dcl	rqo_detected	bit (1) aligned;

dcl	lock_code		fixed binary (35);

dcl	acl_idx		fixed binary;

dcl	1 EMPTY_ACL	aligned static options (constant),
	  2 version	character (8) initial ("gxacl001"),
	  2 count		fixed binary initial (0);

dcl	(
	SYSDAEMONS	initial ("*.SysDaemon.*"),
	ALL_OTHERS	initial ("*.*.*")
	)		character (32) static options (constant);

dcl	DONT_ADD_SYSDAEMONS bit (1) static options (constant) initial ("1"b);

dcl	(
	error_table_$action_not_performed,
	error_table_$argerr,
	error_table_$bad_acl_mode,
	error_table_$bad_mbx_acl_rs,
	error_table_$bad_mbx_acl_awu,
	error_table_$bad_subr_arg,
	error_table_$invalid_lock_reset,
	error_table_$locked_by_this_process,
	error_table_$lock_wait_time_exceeded,
	error_table_$noalloc,
	error_table_$null_info_ptr,
	error_table_$unimplemented_version,
	error_table_$user_not_found
	)		fixed binary (35) external;

dcl	get_system_free_area_
			entry () returns (pointer);
dcl	hcs_$add_acl_entries
			entry (character (*), character (*), pointer, fixed binary, fixed binary (35));
dcl	hcs_$chname_file	entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl	hcs_$chname_seg	entry (pointer, character (*), character (*), fixed binary (35));
dcl	hcs_$create_branch_ entry (character (*), character (*), pointer, fixed binary (35));
dcl	hcs_$delentry_seg	entry (pointer, fixed binary (35));
dcl	hcs_$delete_acl_entries
			entry (character (*), character (*), pointer, fixed binary, fixed binary (35));
dcl	hcs_$list_acl	entry (character (*), character (*), pointer, pointer, pointer, fixed binary,
			fixed binary (35));
dcl	hcs_$replace_acl	entry (character (*), character (*), pointer, fixed binary, bit (1), fixed binary (35));
dcl	hcs_$set_safety_sw	entry (character (*), character (*), bit (1), fixed binary (35));
dcl	hcs_$set_safety_sw_seg
			entry (pointer, bit (1), fixed binary (35));
dcl	mseg_index_$delete	entry (pointer, pointer);
dcl	mseg_utils_$abort_operation
			entry (pointer);
dcl	mseg_utils_$begin_operation
			entry (bit (36) aligned, pointer, character (*), character (*), character (*), pointer,
			bit (1) aligned, fixed binary (35));
dcl	mseg_utils_$finish_operation
			entry (pointer);
dcl	mseg_utils_$request_unlock_on_finish
			entry (pointer);
dcl	mseg_utils_$salvage_for_cause
			entry (pointer, fixed binary (35)) options (variable);
dcl	pathname_		entry (character (*), character (*)) returns (character (168));
dcl	sub_err_		entry () options (variable);

dcl	(addr, after, before, bool, dimension, null, reverse, string)
			builtin;

dcl	(area, cleanup)	condition;
%page;
/* Add (or update) ACL entries */

mseg_fs_interface_$add_acl_entries_seg:
     entry (P_mseg_operation_ptr, P_acl_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$add_acl_entries_seg);
	if code ^= 0
	then call return_from_operation (code);

	call validate_acl ();

	call hcs_$add_acl_entries (mseg_dir_name, mseg_entryname, addr (general_extended_acl.entries),
	     general_extended_acl.count, code);

	call return_from_operation (code);
%page;
/* Change the names -- This entrypoint assumes that the caller has validated the suffix on the new name if necessary. */

mseg_fs_interface_$chname_seg:
     entry (P_mseg_operation_ptr, P_old_name, P_new_name, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$chname_seg);
	if code ^= 0
	then call return_from_operation (code);

	if mseg_ptr ^= null ()			/* use the pointer interface whenever possible */
	then call hcs_$chname_seg (mseg_ptr, P_old_name, P_new_name, code);
	else call hcs_$chname_file (mseg_dir_name, mseg_entryname, P_old_name, P_new_name, code);

	call return_from_operation (code);
%page;
/* Create the segment -- This entrypoint assumes that our caller has already chased any links in order to validate the
   user has access to create the branch and that it will have the proper suffix.  If we are called with the pathname of a
   link, we will fail with error_table_$namedup. */

mseg_fs_interface_$create_seg:
     entry (P_mseg_operation_ptr, P_acl_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$create_seg);
	if code ^= 0
	then call return_from_operation (code);


	/*** Validate the initial ACL for the new segment -- If we are creating a mailbox or queue message segment, we
	     will supply a standard initial ACL if the caller doesn't provide one.  If we are creating any other type of
	     message segment, the caller must supply the initial ACL as we have no idea what would be proper for that
	     type of segment. */

	if P_acl_ptr = null ()			/* we are to provide the default initial ACL */
	then if (mseg_operation.type = MSEG_TYPE_MBX) | (mseg_operation.type = MSEG_TYPE_MS)
	     then do;
		     acl_ptr = addr (default_initial_acl);
		     default_initial_acl.version = GENERAL_EXTENDED_ACL_VERSION_1;
		     default_initial_acl.count = dimension (default_initial_acl.entries, 1);
		     if before (mseg_operation.caller.group_id, ".") = "anonymous"
		     then default_initial_acl.entries (1).access_name =
			     reverse (after (reverse (mseg_operation.caller.group_id), ".")) || ".*";
		     else default_initial_acl.entries (1).access_name =
			     before (mseg_operation.caller.group_id, ".") || ".*.*";
		     default_initial_acl.entries (2).access_name = SYSDAEMONS;
		     default_initial_acl.entries (3).access_name = ALL_OTHERS;
		     default_initial_acl.entries (*).mode = RW_ACCESS;
		     if mseg_operation.type = MSEG_TYPE_MBX
		     then default_initial_acl.entries (*).extended_mode = MSEG_MBX_INITIAL_ACL (*);
		     else /*** if mseg_operation.type = MSEG_TYPE_MS then */
			default_initial_acl.entries (*).extended_mode = MSEG_QUEUE_INITIAL_ACL (*);
		end;

	     else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, 0, null (),
		     "No initial ACL supplied for ^a which is not a mailbox or queue message segment.",
		     pathname_ (mseg_dir_name, mseg_entryname));

	else call validate_acl ();			/* caller has supplied the initial ACL */


	/*** Create the segment */

	cbi.version = create_branch_version_2;
	string (cbi.switches) = ""b;
	cbi.mbz2 = ""b;
	cbi.bitcnt, cbi.quota, cbi.dir_quota = 0;

	cbi.userid = "*.*.*";			/* give everyone real read/write access ... */
	cbi.mode = RW_ACCESS;
	cbi.rings (*) = mseg_data_$execution_ring;	/* ... but only in the current ring or below */

	if mseg_operation.call_admin_gate
	then do;					/* only make it a multiclass segment if running in ring 1 */
		cbi.priv_upgrade_sw = "1"b;
		cbi.access_class = mseg_operation.caller.max_authorization;
	     end;

	else do;					/* create an ordinary segment if outside ring 1 */
		cbi.parent_ac_sw = "1"b;
		cbi.access_class = ""b;		/* ... this is ignored if parent_ac_sw is set */
	     end;

	call hcs_$create_branch_ (mseg_dir_name, mseg_entryname, addr (cbi), code);
	if code ^= 0
	then call return_from_operation (code);


	/*** We have succesfully created the segment -- Set its initial ACL.  We must use our replace_acl_seg primitive
	     rather than calling hcs_$replace_acl directly in case the caller has supplied an initial ACL without a
	     "*.*.*" term.  Proper operation of the primitives require that all users have read/write real access to any
	     message segment. */

	on area call return_noalloc_from_operation ();

	call replace_acl_seg ();			/* it does the return_from_operation for us */
%page;
/* Delete ACL entries */

mseg_fs_interface_$delete_acl_entries_seg:
     entry (P_mseg_operation_ptr, P_acl_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	ring0_acl_ptr = null ();
	operation_specific_return = return_from_delete_acl_entries_seg;
	operation_specific_abort = abort_delete_acl_entries_seg;

	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$delete_acl_entries_seg);

	acl_ptr = P_acl_ptr;

	if acl_ptr = null ()
	then do;	/*** An empty general_delete_acl is translated into a request to delete the entire ACL. */
		acl_ptr = addr (EMPTY_ACL);
		on area call return_noalloc_from_operation ();
		call replace_acl_seg ();		/* it does return_from_operation for us */
	     end;

	if general_delete_acl.version ^= GENERAL_DELETE_ACL_VERSION_1
	then /*** Our caller, as opposed to the user's application, is responsible for creating the ACL structure.
		Therefore, an incorrect version indicates a programming error in our caller. */
	     call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0,
		"general_delete_acl.version = ""^a"".", general_delete_acl.version);


	/*** Examine the ACL entries to be deleted -- If the caller asks to delete the ACL term for "*.*.*", we will
	     actually not delete it.  Instead, we will change its extended access to null as we must insure that all
	     users always have read/write real access to all message segments. */

	system_area_ptr = get_system_free_area_ ();
	ring0_acl_count = general_delete_acl.count;

	on area call return_noalloc_from_operation ();
	allocate ring0_delete_acl in (system_area) set (ring0_acl_ptr);
	revert area;

	ring0_acl_count = 0;			/* no entries in the ACL yet */
	delete_all_others_access = "0"b;

	do acl_idx = 1 to general_delete_acl.count;
	     if general_delete_acl.entries (acl_idx).access_name = ALL_OTHERS
	     then delete_all_others_access = "1"b;
	     else do;
		     ring0_acl_count = ring0_acl_count + 1;
		     ring0_delete_acl.entries (ring0_acl_count).access_name =
			general_delete_acl.entries (acl_idx).access_name;
		end;
	end;


	/*** Delete the requested non "*.*.*" ACL entries */

	if ring0_acl_count ^= 0
	then call hcs_$delete_acl_entries (mseg_dir_name, mseg_entryname, addr (ring0_delete_acl), ring0_acl_count,
		code);

	else code = 0;				/* no non "*.*.*" terms to delete */


	/*** Remove the extended access for "*.*.*" if requested */

	if delete_all_others_access & ((code = 0) | (code = error_table_$argerr))
	then do;					/* don't bother if ring 0 will complain */
		delete_all_others_acl.access_name = ALL_OTHERS;
		call hcs_$delete_acl_entries (mseg_dir_name, mseg_entryname, addr (delete_all_others_acl), 1,
		     delete_all_others_code);
		if delete_all_others_code = error_table_$argerr
		then delete_all_others_code = delete_all_others_acl.status_code;
	     end;

	else delete_all_others_code = error_table_$action_not_performed;


	/*** Return the results of the above actions to our caller */

	ring0_acl_count = 0;

	do acl_idx = 1 to general_delete_acl.count;
	     if general_delete_acl.entries (acl_idx).access_name = ALL_OTHERS
	     then general_delete_acl.entries (acl_idx).status_code = delete_all_others_code;
	     else do;
		     ring0_acl_count = ring0_acl_count + 1;
		     general_delete_acl.entries (acl_idx).status_code =
			ring0_delete_acl.entries (ring0_acl_count).status_code;
		end;
	end;

	if code = 0				/* all non "*.*.*" terms were deleted ... */
	then if delete_all_others_access & (delete_all_others_code ^= 0)
	     then code = error_table_$argerr;		/* ... but the "*.*.*" deletion failed: let the caller know */

	call return_from_operation (code);



/* Special processing required upon the completion of a delete_acl_entries_seg operation */

return_from_delete_acl_entries_seg:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	if ring0_acl_ptr ^= null ()
	then do;
		free ring0_delete_acl in (system_area);
		ring0_acl_ptr = null ();
	     end;

	return;

     end return_from_delete_acl_entries_seg;



/* Special processing required upon abnormal termination of a delete_acl_entries_seg operation */

abort_delete_acl_entries_seg:
     procedure ();

	if ring0_acl_ptr ^= null ()
	then do;
		free ring0_delete_acl in (system_area);
		ring0_acl_ptr = null ();
	     end;

	return;

     end abort_delete_acl_entries_seg;
%page;
/* Delete the segment -- We must try to delete even if we can't lock the segment due to RQO or connection failures.
   Therefore, we only request mseg_utils_ to try to lock the segment but not to check the results.  If, however, we do
   lock the segment but can't delete it, we must be certain to unlock the segment before returning to our caller. */

mseg_fs_interface_$delete_seg:
     entry (P_mseg_operation_ptr, P_mseg_index_table_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$delete_seg);

	if code = error_table_$lock_wait_time_exceeded	/* someone's still using it */
	then call return_from_operation (code);

	lock_code = code;				/* we'll need this later in case we can't delete it */

	call hcs_$delentry_seg (mseg_ptr, code);

	if code = 0				/* it's deleted: flush it from the caller's index table */
	then call mseg_index_$delete (mseg_operation_ptr, P_mseg_index_table_ptr);

	else if ^rqo_detected			/* couldn't delete it but we might have locked it */
	then do;
		if lock_code = 0			/* ... we did lock it: be sure it get's unlocked */
		then call mseg_utils_$request_unlock_on_finish (mseg_operation_ptr);
		else if (lock_code = error_table_$invalid_lock_reset)
		     | (lock_code = error_table_$locked_by_this_process)
		then do;				/* ... we locked it but it should have been salvaged */
			call mseg_utils_$salvage_for_cause (mseg_operation_ptr, lock_code);
			call mseg_utils_$request_unlock_on_finish (mseg_operation_ptr);
		     end;
	     end;

	call return_from_operation (code);
%page;
/* List the entire ACL */

mseg_fs_interface_$list_acl_seg:
     entry (P_mseg_operation_ptr, P_acl_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	acl_ptr, ring0_acl_ptr = null ();
	operation_specific_return = return_from_list_acl_seg;
	operation_specific_abort = abort_list_acl_seg;

	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$list_acl_seg);

	system_area_ptr = get_system_free_area_ ();

	call hcs_$list_acl (mseg_dir_name, mseg_entryname, system_area_ptr, ring0_acl_ptr, null (), ring0_acl_count,
	     code);
	if code ^= 0
	then call return_from_operation (code);


	/*** If the ACL term for "*.*.*" has null extended access, we will not return that term to our caller. */

	acl_count = ring0_acl_count;			/* we'll usually return the entire ACL */

	if ring0_acl_count > 0
	then if (ring0_acl.entries (ring0_acl_count).access_name = ALL_OTHERS)
		& (ring0_acl.entries (ring0_acl_count).extended_mode = MSEG_NULL_ACCESS)
	     then acl_count = ring0_acl_count - 1;


	/*** Copy the ring0 ACL into a general_extended_acl structure as expected by our caller */

	on area call return_noalloc_from_operation ();
	allocate general_extended_acl in (system_area) set (acl_ptr);
	revert area;

	general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1;

	do acl_idx = 1 to acl_count;
	     general_extended_acl.entries (acl_idx) = ring0_acl.entries (acl_idx);
	end;

	P_acl_ptr = acl_ptr;			/* ... and give it to our caller */

	call return_from_operation (0);



/* Special processing required upon the completion of a list_acl_seg operation */

return_from_list_acl_seg:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	if ring0_acl_ptr ^= null ()
	then do;
		free ring0_acl in (system_area);
		ring0_acl_ptr = null ();
	     end;

	if (acl_ptr ^= null ()) & (p_code ^= 0)
	then do;					/* we aren't going to return this ACL because of errors */
		free general_extended_acl in (system_area);
		acl_ptr = null ();
	     end;

	return;

     end return_from_list_acl_seg;



/* Special processing required upon abnormal termination of a list_acl_seg operation */

abort_list_acl_seg:
     procedure ();

	if ring0_acl_ptr ^= null ()
	then do;
		free ring0_acl in (system_area);
		ring0_acl_ptr = null ();
	     end;

	if acl_ptr ^= null ()
	then do;
		free general_extended_acl in (system_area);
		acl_ptr = null ();
	     end;

	return;

     end abort_list_acl_seg;
%page;
/* List individual ACL entries */

mseg_fs_interface_$list_acl_entries_seg:
     entry (P_mseg_operation_ptr, P_acl_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$list_acl_entries_seg);


	/*** Our caller, as opposed to the user's application, is responsible for creating the ACL structure supplied
	      to all mseg_ entrypoints.  Therefore, a missing structure or an incorrect version indicates a programming
	      error in our caller. */

	acl_ptr = P_acl_ptr;

	if acl_ptr = null ()
	then call sub_err_ (error_table_$null_info_ptr, operation_name, ACTION_CANT_RESTART, null (), 0,
		"general_extended_acl_ptr");

	if general_extended_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1
	then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0,
		"general_extended_acl.version = ""^a"".", general_extended_acl.version);


	/*** List the individual ACL entries -- If the caller asks to list the ACL term for "*.*.*" and its extended
	     mode is null, we will claim that "*.*.*" has no ACL term.  We do this to hide from our caller the fact that
	     we must always insure that all users have read/write real access to all message segments. */

	call hcs_$list_acl (mseg_dir_name, mseg_entryname, null (), (null ()), addr (general_extended_acl.entries),
	     general_extended_acl.count, code);

	if (code = 0) | (code = error_table_$argerr)
	then do;					/* only if ring 0 actually returned something */
		do acl_idx = 1 to general_extended_acl.count;
		     if (general_extended_acl.entries (acl_idx).access_name = ALL_OTHERS)
			& (general_extended_acl.entries (acl_idx).extended_mode = MSEG_NULL_ACCESS)
		     then do;
			     general_extended_acl.entries (acl_idx).status_code = error_table_$user_not_found;
			     code = error_table_$argerr;
			end;
		end;
	     end;

	call return_from_operation (code);
%page;
/* Replace the ACL */

mseg_fs_interface_$replace_acl_seg:
     entry (P_mseg_operation_ptr, P_acl_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$replace_acl_seg);

	if P_acl_ptr = null ()
	then acl_ptr = addr (EMPTY_ACL);		/* we must have an ACL structure for proper operation */
	else call validate_acl ();			/* insure the caller's ACL is OK */

	on area call return_noalloc_from_operation ();

	call replace_acl_seg ();			/* it does the return_from_operation for us */



/* Actually replace the ACL -- This internal procedure is also used by create_seg and delete_acl_entries_seg. */

replace_acl_seg:
     procedure ();

dcl	original_acl_ptr	pointer;
dcl	add_all_others_acl	bit (1) aligned;


	/*** Examine the new ACL -- If the new ACL does not contain an entry for "*.*.*", we will supply one with null
	     extended access.  We do this to insure that we always have read/write access to all message segments. */

	add_all_others_acl = "1"b;			/* until proven otherwise */

	do acl_idx = 1 to general_extended_acl.count while (add_all_others_acl);
	     if general_extended_acl.entries (acl_idx).access_name = ALL_OTHERS
	     then add_all_others_acl = "0"b;
	end;

	if add_all_others_acl
	then do;
		system_area_ptr = get_system_free_area_ ();
		original_acl_ptr = acl_ptr;		/* remember where our caller's ACL resides */

		acl_ptr = null ();			/* for cleanup handler */
		operation_specific_return = return_from_replace_acl_seg;
		operation_specific_abort = abort_replace_acl_seg;

		acl_count = original_acl_ptr -> general_extended_acl.count + 1;
		allocate general_extended_acl in (system_area) set (acl_ptr);

		do acl_idx = 1 to original_acl_ptr -> general_extended_acl.count;
		     general_extended_acl.entries (acl_idx) =
			original_acl_ptr -> general_extended_acl.entries (acl_idx);
		end;

		general_extended_acl.entries (acl_count).access_name = ALL_OTHERS;
		general_extended_acl.entries (acl_count).mode = RW_ACCESS;
		general_extended_acl.entries (acl_count).extended_mode = MSEG_NULL_ACCESS;
	     end;


	/*** Replace the ACL */

	call hcs_$replace_acl (mseg_dir_name, mseg_entryname, addr (general_extended_acl.entries),
	     general_extended_acl.count, DONT_ADD_SYSDAEMONS, code);

	call return_from_operation (code);



/* Special processing required upon the completion of a replace_acl_seg operation -- This entrypoint will only be invoked
   if we created a copy of the caller's ACL with an extra entry for "*.*.*".  This entrypoint will copy the per-ACL status
   codes back into the caller's structure and free the copy. */

return_from_replace_acl_seg:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	do acl_idx = 1 to original_acl_ptr -> general_extended_acl.count;
	     original_acl_ptr -> general_extended_acl.entries (acl_idx).status_code =
		general_extended_acl.entries (acl_idx).status_code;
	end;

	free general_extended_acl in (system_area);
	acl_ptr = null ();

	return;

     end return_from_replace_acl_seg;



/* Special processing required upon abnormal termination of a replace_acl_seg operation -- This entrypoint will only be
   invoked if we created a copy of the caller's ACL which we must now free. */

abort_replace_acl_seg:
     procedure ();

	if acl_ptr ^= null ()
	then do;
		free general_extended_acl in (system_area);
		acl_ptr = null ();
	     end;

	return;

     end abort_replace_acl_seg;

     end replace_acl_seg;
%page;
/* Set the safety switch */

mseg_fs_interface_$set_safety_switch_seg:
     entry (P_mseg_operation_ptr, P_safety_switch, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$set_safety_switch_seg);
	if code ^= 0
	then call return_from_operation (code);

	if mseg_ptr ^= null ()			/* use the pointer interface whenever possible */
	then call hcs_$set_safety_sw_seg (mseg_ptr, (P_safety_switch), code);
	else call hcs_$set_safety_sw (mseg_dir_name, mseg_entryname, (P_safety_switch), code);

	call return_from_operation (code);
%page;
/* Common initialization for all operations */

setup_operation:
     procedure ();

	code = 0;

	operation_specific_abort = nulle;		/* nothing special when we abort or return (yet) */
	operation_specific_return = nulle;

	mseg_operation_ptr = null ();

	return;

     end setup_operation;



/* Begin the operation -- This procedure isn't part of setup_operation so that we can be certain to have a cleanup handler
   available at all times that the message segment may be in use. */

begin_operation:
     procedure (p_mseg_operation_id);

dcl	p_mseg_operation_id bit (36) aligned parameter;

	mseg_operation_ptr = P_mseg_operation_ptr;

	call mseg_utils_$begin_operation (p_mseg_operation_id, mseg_operation_ptr, operation_name, mseg_dir_name,
	     mseg_entryname, mseg_ptr, rqo_detected, code);

	return;

     end begin_operation;



/* The "null" entry which indicates that there's no special abort/return processing for an operation */

nulle:
     procedure ();

	return;

     end nulle;
%page;
/* Return after completion of an operation */

return_from_operation:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	if operation_specific_return ^= nulle		/* let the operation do anything special */
	then call operation_specific_return (p_code);

	if mseg_operation_ptr ^= null ()		/* may be invoked before we've called begin_operation */
	then call mseg_utils_$finish_operation (mseg_operation_ptr);

	P_code = p_code;				/* set our caller's status code */
	go to RETURN_FROM_OPERATION;

     end return_from_operation;

RETURN_FROM_OPERATION:
	return;



/* Return error_table$_noalloc to our caller after an allocation failure */

return_noalloc_from_operation:
     procedure ();

	if operation_specific_return ^= nulle		/* let the operation do anything special */
	then call operation_specific_return (error_table_$noalloc);

	call mseg_utils_$finish_operation (mseg_operation_ptr);

	P_code = error_table_$noalloc;		/* set our caller's status code */
	go to RETURN_FROM_OPERATION;

     end return_noalloc_from_operation;



/* Abort an operation */

operation_was_aborted:
     procedure ();

	if operation_specific_abort ^= nulle		/* let the operation do anything special */
	then call operation_specific_abort ();

	call mseg_utils_$abort_operation (mseg_operation_ptr);

	return;

     end operation_was_aborted;
%page;
/* Validate the ACL structure -- We force the real modes in the structure to RW_ACCESS as that access is required for
   proper operation of the primitives.  We also verify that the extended modes do not request any unused modes. */

validate_acl:
     procedure ();

dcl	found_invalid_mode	bit (1) aligned;

	acl_ptr = P_acl_ptr;

	/*** Our caller, as opposed to the user's application, is responsible for creating the ACL structure supplied
	      to all mseg_ entrypoints.  Therefore, a missing structure or an incorrect version indicates a programming
	      error in our caller. */

	if acl_ptr = null ()
	then call sub_err_ (error_table_$null_info_ptr, operation_name, ACTION_CANT_RESTART, null (), 0,
		"general_extended_acl_ptr");

	if general_extended_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1
	then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0,
		"general_extended_acl.version = ""^a"".", general_extended_acl.version);

/* Check for invalid extended modes.  The following requirements are enforced:
   1. No bits outside of MSEG_FULL_ACCESS may be on.
   2. If r permission is given, s permission must be given.
   3. If w permission is given, a permission must be given.
   4. If u permission is given, a permission must be given. */
	found_invalid_mode = "0"b;

	do acl_idx = 1 to general_extended_acl.count;
	     general_extended_acl.entries (acl_idx).mode = RW_ACCESS;
	     ext_mode = general_extended_acl.entries (acl_idx).extended_mode;
	     if bool (ext_mode, MSEG_FULL_ACCESS, "0010"b) = ""b
		& ^(((ext_mode & MSEG_R_ACCESS) ^= ""b) & ^((ext_mode & MSEG_S_ACCESS) ^= ""b))
		& ^(((ext_mode & MSEG_W_ACCESS) ^= ""b) & ^((ext_mode & MSEG_A_ACCESS) ^= ""b))
		& ^(((ext_mode & MSEG_U_ACCESS) ^= ""b) & ^((ext_mode & MSEG_A_ACCESS) ^= ""b))
	     then general_extended_acl.entries (acl_idx).status_code = 0;
	     else do;
		     if (((ext_mode & MSEG_R_ACCESS) ^= ""b) & ^((ext_mode & MSEG_S_ACCESS) ^= ""b))
		     then general_extended_acl.entries (acl_idx).status_code = error_table_$bad_mbx_acl_rs;
		     else if (((ext_mode & MSEG_W_ACCESS) ^= ""b) & ^((ext_mode & MSEG_A_ACCESS) ^= ""b))
		     | (((ext_mode & MSEG_U_ACCESS) ^= ""b) & ^((ext_mode & MSEG_A_ACCESS) ^= ""b))
		     then general_extended_acl.entries (acl_idx).status_code = error_table_$bad_mbx_acl_awu;
		     else general_extended_acl.entries (acl_idx).status_code = error_table_$bad_acl_mode;
		     found_invalid_mode = "1"b;
		end;
	end;

	if found_invalid_mode			/* error_table_$argerr => check the individual status_codes */
	then call return_from_operation (error_table_$argerr);

	return;

     end validate_acl;

/* format: off */
%page; %include mseg_data_;
%page; %include mseg_operation;
%page; %include mseg_message_info;
%page; %include mseg_wakeup_state;
%page; %include entry_access_info;
%page; %include mseg_operations_;
%page; %include acl_structures;
%page; %include access_mode_values;
%page; %include mseg_access_mode_values;
%page; %include create_branch_info;
%page; %include sub_err_flags;
/* format: on */

     end mseg_fs_interface_;




		    mseg_index_.pl1                 07/11/86  0926.0rew 07/11/86  0914.1      123021



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




/****^  HISTORY COMMENTS:
  1) change(85-05-30,Palter), approve(86-02-20,MCR7345),
     audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092):
     Verify proper real access to the segment as this particular check can`t be
     postponed to the access kernel.  Without this check, a process whose
     authorization is greater than the access class of a message segment would
     take a no_write_permission fault when trying to perform most any operation
     on the segment.
     Also set mseg_operation.mseg_(index ptr)_valid to ""b inside
     mseg_index_$close_seg upon removing the entry from the mseg_table and
     termination of the segment.
                                                   END HISTORY COMMENTS */


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

mseg_index_:
     procedure;

/*
   Module of the primitive message segment facility which  initiates
   and  terminates  a  message  segment  in the administrative ring,
   matching the pointer to the message segment with a  unique  index
   which is passed to and from the user ring.
*/


/* Modified for version 3 message segments by J. Stern, 10/29/74 */
/* Modified by Benson Margulies for conversion to unaligned character strings */
/* Modified 1984-10-11 BIM to stop calling the admin gate. */
/* Modified February 1985 by M. Pandolf to move access checking to kernel. */
/* Modified 1985-04-17, BIM: return pointer for speed. */

/* DECLARATIONS */
/* ------------ */


/* fixed bin */

dcl  (
     i,
     mseg_index,					/* index to a given message segment (internal) */
     a_mseg_index					/* used by close */
     ) fixed bin aligned;

dcl  (
     a_code,					/* error code (argument) */
     code init (0),					/* error code (internal) */
     code2,					/* another error code */
     error_table_$ai_restricted external,
     error_table_$bad_subr_arg external,
     error_table_$dirseg external,
     error_table_$not_seg_type external,
     error_table_$notalloc ext,
     error_table_$segknown ext,
     error_table_$seg_unknown ext
     ) fixed bin (35) aligned;


/* pointers */

dcl  (
     a_table_ptr,					/* ptr to mseg_ptr array (argument) */
     new_table_ptr,					/* ptr for re-allocating table */
     temp_mseg_ptr,					/* pointer to specific message segment */
     a_op_ptr
     ) ptr aligned;

dcl  area_ptr ptr int static init (null);

dcl  linker_area area based (area_ptr);


/* character strings */

dcl  dn char (168);
dcl  en char (32);

/* bit strings */

dcl  effective_access bit (36) aligned;
dcl  sys_info$ring1_privilege ext bit (36) aligned;

/* built in functions */

dcl  (addr, bit, null) builtin;

/* external entries */

dcl  admin_gate_$syserr entry (/* fixed binary, character (*) */) options (variable);
dcl  get_user_free_area_ entry returns (ptr);
dcl  hcs_$get_access_info_seg entry (ptr, ptr, fixed bin (35));
dcl  hcs_$get_user_access_modes_seg
	entry (ptr, char (*), fixed bin (3), bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname ext entry (ptr aligned, fixed bin (35) aligned);
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  sub_err_ entry () options (variable);
dcl  system_privilege_$initiate ext
	entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));

/* conditions */

dcl  area condition;
%page;
/**** This entrypoint is called to get a pointer, but not to record
      in the table of open segments. That recording only happens
      if the user has access. */

mseg_index_$initiate_seg:
     entry (a_op_ptr, a_code);

	mseg_operation_ptr = a_op_ptr;
	if ^mseg_operation.mseg_pathname_valid then
	     call sub_err_ (error_table_$bad_subr_arg, "mseg_$initiate_seg", ACTION_CANT_RESTART, null (), (0),
		"The mseg_operation does not include a valid pathname.");

	dn = mseg_operation.dir_name;
	en = mseg_operation.entryname;

	if mseg_operation.caller.privileges & sys_info$ring1_privilege then
	     call system_privilege_$initiate (dn, en, "", 0, 1, temp_mseg_ptr, code2);
	else call hcs_$initiate (dn, en, "", 0, 1, temp_mseg_ptr, code2);
						/* initiate message segment */
	if temp_mseg_ptr = null then do;		/* did not get back a pointer */
	     if code2 = error_table_$dirseg then
		code = error_table_$not_seg_type;
	     else code = code2;
	     go to RETURN;
	end;

	mseg_operation.mseg_ptr = temp_mseg_ptr;
	mseg_operation.mseg_ptr_valid = "1"b;

	if mseg_operation.suppress_access_checks then go to RETURN;

/**** We must fetch the segment's access_info here in order to validate
      that we have RW real effective access to the segment.  We can't delay
      this check to the mseg_check_access_ kernal as there is at least
      one gate target (mailbox_$accept_wakeups_index) which performs an
      mseg_ operation before calling mseg_check_access_.  Since the mseg_
      operation has to lock the segment, if we don't have the proper real
      access, we would take a fault in ring 1 which isn't very nice.

      If the user doesn't have RW effective access, we must determine the
      appropriate error code to return.  If the segment's ring brackets
      are incorrect, we'll return error_table_$not_seg_type.  If we lack
      the needed access due to AIM, we'll return error_table_$ai_restricted.
      If, however, we lack the access due to an incorrect real mode in the ACL,
      we enter a SYSERR message and stop the user dead by calling sub_err_.
      In truth, we would prefer to invoke an ACL salvager in this case but,
      as one does not exist, we stop our caller as any error code we might
      return would be misleading. */

	call hcs_$get_access_info_seg (temp_mseg_ptr, addr (mseg_operation.access_info), code);
	if code ^= 0 then do;
ACCESS_CHECK_FAILED:
	     call hcs_$terminate_noname (temp_mseg_ptr, (0));
	     mseg_operation.mseg_ptr_valid = "0"b;	/* the pointer's not usefull if the access isn't right */
	     go to RETURN;
	end;

	mseg_operation.access_info_valid = "1"b;

	if (mseg_operation.access_info.effective_access_modes & RW_ACCESS) ^= RW_ACCESS then do;

	     do i = 1 to 3;				/* check that the ring brackets are OK */
		if mseg_operation.access_info.ring_brackets (i) ^= mseg_data_$execution_ring then do;
		     code = error_table_$not_seg_type;
		     go to ACCESS_CHECK_FAILED;
		end;
	     end;

	     call hcs_$get_user_access_modes_seg (temp_mseg_ptr, "" /* ourself */, -1 /* this ring */, effective_access,
		((36)"0"b), code);
	     if code ^= 0 then go to ACCESS_CHECK_FAILED;

	     if (effective_access & RW_ACCESS) ^= RW_ACCESS then do;
		/*** The ACL term by which the user received his access to
		     the segment does not grant RW access. */
		if mseg_operation.call_admin_gate then
		     call admin_gate_$syserr ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR),
			"mseg_$initiate_seg: The ACL for ^a is inconsistent -- ^a does not have ""rw"" access.",
			pathname_ (mseg_operation.access_info.dir_name, mseg_operation.access_info.entryname),
			mseg_operation.caller.group_id);
		call sub_err_ (0, "mseg_$initiate_seg", ACTION_CANT_RESTART, null (), 0,
		     "The ACL for ^a is inconsistent -- you do not have ""rw"" access.",
		     pathname_ (mseg_operation.access_info.dir_name, mseg_operation.access_info.entryname));
	     end;

	     /*** Control arrives here only when the reason we lack proper
		access is due to AIM as, when AIM was ignored, we had
		the necessary access. */

	     code = error_table_$ai_restricted;
	     go to ACCESS_CHECK_FAILED;
	end;

	code = 0;					/* success */

	go to RETURN;
%page;
/**** This is called only for the real gate open entrypoint
      to insert the segment in the table. */

mseg_index_$open_seg:
     entry (a_op_ptr, a_table_ptr, a_code);

	mseg_operation_ptr = a_op_ptr;
	table_ptr = a_table_ptr;

	if ^mseg_operation.mseg_ptr_valid then
	     call sub_err_ (error_table_$bad_subr_arg, "mseg_$open_seg", ACTION_CANT_RESTART, null (), (0),
		"The mseg_operation does not include a valid mseg_ptr.");

	on condition (area)
	     begin;
	     code = error_table_$notalloc;
	     go to RETURN;
	end;

	if table_ptr = null then do;
	     call allocate_table;
	     a_table_ptr = table_ptr;
	end;

	temp_mseg_ptr = mseg_operation.mseg_ptr;

/* See if already open */

	do mseg_index = 1 to mseg_table.table_length while (mseg_table.mseg_ptr (mseg_index) ^= temp_mseg_ptr);
	end;

	if mseg_index <= mseg_table.table_length then go to FOUND_INDEX;

/* Find an unused slot in the table */

	do mseg_index = 1 to mseg_table.table_length while (mseg_table.mseg_ptr (mseg_index) ^= null);
	end;

	if mseg_index > mseg_table.table_length then do;	/* table full */
	     call grow_table;
	     a_table_ptr = table_ptr;
	end;

FOUND_INDEX:
	mseg_table.mseg_ptr (mseg_index) = temp_mseg_ptr; /* remember pointer */
	mseg_table.ref_count (mseg_index) = mseg_table.ref_count (mseg_index) + 1;
						/* increment reference count */
	mseg_operation.mseg_index = mseg_index;
	mseg_operation.mseg_index_valid = "1"b;
	go to RETURN;
%page;
/**** This entrypoint both removes the index from the table
      and terminates the segment. Since there is a null ref name
      added per index ref count, we always terminate off a name.

      For convienience, this will also operate correctly when
      the index is invalid, indicating that the segment just
      needs terminating */

mseg_index_$close_seg:
     entry (a_op_ptr, a_table_ptr, a_code);

	mseg_operation_ptr = a_op_ptr;

	code = 0;

	if mseg_operation.mseg_index_valid then do;
	     mseg_index = mseg_operation.mseg_index;
	     table_ptr = a_table_ptr;

	     if table_ptr = null then do;
UNKNOWN:
		code = error_table_$seg_unknown;
		go to RETURN;
	     end;

	     if mseg_index < 1 | mseg_index > mseg_table.table_length then go to UNKNOWN;

	     if mseg_table.mseg_ptr (mseg_index) = null then go to UNKNOWN;

	     mseg_table.ref_count (mseg_index) = mseg_table.ref_count (mseg_index) - 1;
						/* decrement reference count */
	     if mseg_table.ref_count (mseg_index) = 0 then mseg_table.mseg_ptr (mseg_index) = null;
						/* remove ptr from table */

	     mseg_operation.mseg_index_valid = "0"b;
	end;

	if mseg_operation.mseg_ptr_valid then do;
	     temp_mseg_ptr = mseg_operation.mseg_ptr;
	     call hcs_$terminate_noname (temp_mseg_ptr, code2);
						/* terminate the message segment */
	     mseg_operation.mseg_ptr_valid = "0"b;
	end;

RETURN:
	a_code = code;				/* return error code */
	return;
%page;
mseg_index_$delete:
     entry (a_op_ptr, a_table_ptr);


	mseg_operation_ptr = a_op_ptr;

	if mseg_operation.mseg_ptr_valid then do;
	     temp_mseg_ptr = mseg_operation.mseg_ptr;
	     table_ptr = a_table_ptr;

	     if table_ptr = null then return;

	     do mseg_index = 1 to mseg_table.table_length;
		if mseg_table.mseg_ptr (mseg_index) = temp_mseg_ptr then do;
		     mseg_table.mseg_ptr (mseg_index) = null ();
		     mseg_table.ref_count (mseg_index) = 0;
		     return;
		end;
	     end;
	end;

	return;
%page;
allocate_table:
     proc;

/* This internal procedure allocates mseg_table in the ring 1 linker area segment. */

	if area_ptr = null () then area_ptr = get_user_free_area_ ();

	tlength = 100;

	allocate mseg_table in (linker_area) set (table_ptr);

	do i = 1 to tlength;
	     mseg_table.mseg_ptr (i) = null;
	     mseg_table.ref_count (i) = 0;
	end;

     end allocate_table;


grow_table:
     procedure;

/* This internal procedure doubles mseg_table's size, changing table_ptr and
   setting mseg_index to the next available slot. */

	mseg_index = mseg_table.table_length + 1;
	tlength = mseg_table.table_length * 2;
	allocate mseg_table in (linker_area) set (new_table_ptr);

	do i = 1 to mseg_index - 1;
	     new_table_ptr -> mseg_table.mseg_ptr (i) = table_ptr -> mseg_table.mseg_ptr (i);
	     new_table_ptr -> mseg_table.ref_count (i) = table_ptr -> mseg_table.ref_count (i);
	end;

	free table_ptr -> mseg_table in (linker_area);
	table_ptr = new_table_ptr;

	do i = mseg_index to mseg_table.table_length;
	     mseg_table.mseg_ptr (i) = null;
	     mseg_table.ref_count (i) = 0;
	end;

     end grow_table;

/* format: off */
%page; %include mseg_index_table;
%page; %include mseg_operation;
%page; %include mseg_message_info;
%page; %include entry_access_info;
%page; %include sub_err_flags;
%page; %include mseg_wakeup_state;
%page; %include syserr_constants;
%page; %include access_mode_values;
%page; %include mseg_data_;
%page;

/* BEGIN MESSAGE DOCUMENTATION


   Message:
   mseg_$initiate_seg: The ACL for PATH is inconsistent -- USER_ID does not
	have "rw" access.

   S:	$log

   T:	$run

   M:	$err
	For proper operation of the message segment primitives, all ACL terms
	of a message segment or mailbox must specify "rw" access to the
	segment when running in ring 1.  One or more ACL terms for the
	segment PATH do not provide the required access.  USER_ID identifies
	one of the user whose access to the segment is incorrect.

   A:	$inform


   END MESSAGE DOCUMENTATION */

/* format: on */

     end mseg_index_;




		    mseg_mbx_ms_gate_target_.pl1    08/06/87  1022.8rew 08/06/87  1020.1      490959



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


/****^  HISTORY COMMENTS:
  1) change(85-05-29,Palter), approve(86-02-20,MCR7345),
     audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092):
     Changed to not call mseg_$delete_seg after calling mseg_$close_seg on the
     target of the copy operation.  Said call would cause fatal process errors
     if the copy operation failed because the user did not have sufficient
     access to create the target.
  2) change(85-06-12,Palter), approve(86-02-20,MCR7345),
     audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092):
     Fix the bug in ex_acl_list which would trash the user's area when the
     mseg's ACL is empty and the user asks to list the entire ACL.
  3) change(85-07-19,Palter), approve(86-02-20,MCR7345),
     audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092):
     Fix wakeup_add_index and wakeup_aim_add_index to properly censor the
     results of sending the wakeup and to return the message ID whenever the
     message is added regardless of the success/failure of sending the wakeup.
  4) change(85-07-24,Palter), approve(86-02-20,MCR7345),
     audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092):
     Fix the old style read entrypoints to not change the caller's
     mseg_return_args structure if an appropriate message is not found.
  5) change(86-03-21,MSharpe), approve(86-05-12,MCR7403),
     audit(86-08-04,Lippard), install(86-08-06,MR12.0-1118):
     Fixed ms_acl_list entry to return the acl terms for caller-specified
     user_ids (when area_ptr = null).  If the caller has specified a null
     user_acl_ptr or a user_acl_count < 1, error_table_$argerr is returned.
  6) change(86-09-10,Dickson), approve(86-09-10,MCR7480),
     audit(86-09-12,Lippard), install(86-09-15,MR12.0-1156):
     Moved some initialization lines to before the clean_up handler is set in
     the $copy entrypoint so that the variable error_on_target gets set upon an
     early exit.
  7) change(86-09-30,Lippard), approve(86-11-24,MCR7578),
     audit(87-07-13,Dickson), install(87-08-06,MR12.1-1067):
     Changed to correctly diagnose entry names without valid suffixes and to
     use error_table_$bad_file_name instead of $badstar.
                                                   END HISTORY COMMENTS */

/* format: style3,idind30,linecom */
mseg_mbx_ms_gate_target_:
     procedure;

/* Modified for version 3 message segments by J. Stern, 11/01/74 */
/* Modified to add mbx_wakeup_add_index and mbx_accept_wakeups_index
   and mbx_set_max_length entries by Steve Herbst on 2/16/76 */
/* Modified 5/77 for the installation of version 4 message segments */
/* MCR 4171 Change default access on new mailboxes 12/14/79 S. Herbst */
/* Modified by Benson Margulies for conversion to unaligned character strings */
/* Modified 4/82 by E. N. Kittlitz to not delete through links */
/* Modified: February 1983 by G. Palter to add validation, copy and compaction entrypoints */
/* Modified: October 1983 by G. Palter to add get_uid_file and get_uid_index entrypoints */
/* Modified: November 1983 by G. Palter to make get_mode_file use hcs_$get_user_access_modes */
/* Modified: 84-05-07 BIM for get_process_access_class_ versus authorization */
/* Modified: August 1984 by G. Palter to fix the following errors from the message segment error list:
   #0001 -- mailbox_$create and message_segment_$create will add the ring-1 IACL to the ACL of the newly created
   mailbox/message segment.  The entries from the IACL will have null extended access.  These gates should ignore
   the ring-1 IACL;
   #0003 -- mailbox_$get_uid_file, mailbox_$get_mode_file, mailbox_$set_safety_switch, and
   mesage_segment_$set_safety_switch do not validate that their target is a mailbox or message segment as
   appropriate;
   #0005 -- When given a new ACL count of -1 or zero, mailbox_$mbx_acl_replace and message_segment_$ms_acl_replace will
   incorrectly attempt to allocate a local copy of the input ACL array using the new ACL count as the size for the
   array.  This attempted allocation causes an area condition and, eventually, a fatal process error; and
   #0006 -- mailbox_$copy and message_segment_$copy will create the target mailbox/message segment before validating
   that the user has sufficient access to copy the segment */
/* Modified 1984-10-11 BIM for new entrypoints, V5 */
/* Modified February 1985 by M. Pandolf to add calls to mseg_check_access_ */
/* Modified March 1985 by M. Pandolf to get mseg_ptr as soon as possible due to undependability of pathnames */
/* Modified April 1985 by M. Pandolf to get and hold access information */
/* Modified 1985-04-16, BIM: simplify get_mode,
   reduce use of validation level setting.
   MERGE MBX_MSEG_ with QUEUE_MSEG_ */

/****^ Gate target procedure for the mailbox_ and message_segment_ gates.
      This procedure is responsible for:

      argument copying
      access checking except for per-message AIM checks
      validation level management (for now)


      BASIC STRATEGY

      One procedure, "entry_common", is responsible for:

      copying standard arguments.
      calling mseg_check_access_ to check access for the operation.
      setting the validation level down (and suppressing audit).


      A single entrypoint serves both gates. The callerptr builtin
      is used to distinguish the calling gate and select accordingly.

      The entrypoints are classed into four groups:

      INDEX_ENTRY        called with an opening index
      FILE_ENTRY         called with a pathname which is initiated
      FILE_BRIEF_ENTRY   called with a pathname which is passed
		     to mseg_check_access_ and then to mseg_.
		     All neccessary data is returned in
		     the access_info substructure of the
		     mseg_operation structure.
      FILE_TEMP_ENTRY    called with a pathname, only because
		     there is no underlying ring 0 primitive
		     that will accept a pointer. These entries
		     all have windows that allow benign
		     hoaxing.


      entry_common is called as follows:

      call entry_common (entry_type, base_operation);

      entry_common set up the mseg_operation structure
      and calls mseg_check_access_. After that, the
      individual entrypoint is on its own.

*/

declare	(
	INDEX_ENTRY		init (1),
	FILE_ENTRY		init (2),
	FILE_BRIEF_ENTRY		init (3),
	FILE_TEMP_ENTRY		init (4)
	)			int static fixed bin options (constant);

declare	SUFFIX			(2) char (8) aligned varying init (".mbx", ".ms") int static options (constant);

dcl	(
	a_user_acl_count,				/* acl count */
	user_acl_count,
	a_ms_count,				/* message count */
	ms_count,
	a_mseg_index,				/* message segment index */
	i,
	read_entry_type
	)			fixed bin;

dcl	(a_max_length, max_length)	fixed bin (19);

dcl	a_ms_len			fixed bin (24);	/* bit length of message */

dcl	(
	a_code,					/* error code (argument) */
	code,					/* error code (internal) */
	error_table_$argerr		ext,
	error_table_$noalloc	ext,
	error_table_$no_append	ext,
	error_table_$null_info_ptr	ext,
	error_table_$unimplemented_version
				ext,
	error_table_$ai_restricted	ext,
	error_table_$action_not_performed
				ext,
	error_table_$bad_file_name	ext,
	error_table_$dirseg		ext,
	error_table_$inconsistent	ext,
	error_table_$invalid_lock_reset
				ext,
	error_table_$messages_deferred
				ext,
	error_table_$messages_off	ext,
	error_table_$moderr		ext,
	error_table_$no_info	ext,
	error_table_$not_seg_type	ext,
	error_table_$wakeup_denied	ext,
	error_table_$seg_unknown	ext
	)			fixed bin (35);

dcl	(a_event_channel, user_event_channel, event_message)
				fixed bin (71);

/* float bin */

dcl	a_compact_ratio		float bin;	/* % of garbage in mailbox to force compaction */

/* pointers */

dcl	(
	a_area_ptr,				/* pointer to user area */
	area_ptr,
	a_arg_ptr,				/* pointer to argument structure */
	arg_ptr,
	a_user_acl_ptr,				/* pointer to acl structures */
	user_acl_ptr,
	a_ms_ptr,					/* pointer to message */
	internal_acl_ptr,
	static_table_ptr		(2) int static init ((2) null ())
						/* ptr to mseg_table */
	)			ptr;

/* bit strings */

dcl	(
	error_on_target,
	copy_entry,				/* ON if mailbox copying entrypoint */
	a_error_on_target,				/* set ON/OFF depending on where copy failed */
	file_sw,					/* ON if file entry called */
	a_ms_wanted,				/* which incremental message wanted */
	ms_wanted,
	a_salv_bit,				/* salvaged bit */
	salv_bit,
	a_safety_switch,
	safety_switch,
	a_turn_off,				/* ON if to turn off, salvaged bit */
	turn_off,
	return_count,
	validation_set
	)			bit (1) aligned;

dcl	(
	a_dir,					/* direction of incremental read */
	dir
	)			bit (2) aligned;

dcl	(
	a_mode			aligned,		/* extended access mode */
	a_sw,					/* wakeup control arg */
	test_lock_id		aligned,		/* to test for valid lock id */
	sys_info$ring1_privilege	aligned external,
	sys_info$ipc_privilege	aligned external
	)			bit (36);

dcl	a_uid					/* mailbox UID */
				bit (36) aligned;

dcl	(
	a_access_class,
	a_ms_id,					/* message uid */
	ms_id
	)			bit (72) aligned;


/* character strings */

dcl	(
	a_dn,					/* directory name */
	a_en,					/* message segment name */
	a_target_dn,				/* for copying */
	a_target_en,				/* for copying */
	a_new_en,					/* for renaming */
	a_old_en					/* for renaming */
	)			char (*);

dcl	(new_en, old_en)		char (32);

/* structures */

dcl	1 operation		aligned like mseg_operation;
dcl	1 target_operation		aligned like mseg_operation;
						/* spare for copy */


declare	1 old_read_flags		unaligned,
	  2 incremental		bit (1),
	  2 incremental_direction	bit (2),		/* valid if incremental = "1"b */
	  2 first_or_last		bit (1),		/* valid if incremental is "0"b */
	  2 own			bit (1),
	  2 delete		bit (1),
	  2 pad			bit (30);

/* builtins */

dcl      (addr, index, length, null, reverse, rtrim, setwordno, string, substr, unspec)
				builtin;

/* conditions */

dcl	area			condition;
dcl	cleanup			condition;

/* area */

dcl	system_area		area based (get_system_free_area_ ());
dcl	user_area			area based (area_ptr);


/* external entries */

dcl	admin_gate_$admin_level_no_fs_audit
				entry (fixed bin (3) aligned);
dcl	aim_util_$get_access_class	entry (bit (72) aligned) returns (bit (72) aligned);
dcl	aim_util_$get_privileges	entry (bit (72) aligned) returns (bit (36) aligned);
dcl	aim_check_$greater_or_equal	entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	aim_check_$greater		entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	cu_$caller_ptr		entry returns (ptr);
dcl	get_process_authorization_	entry () returns (bit (72) aligned);
dcl	get_system_free_area_	ext entry returns (ptr);
dcl	hcs_$level_get		entry returns (fixed binary (3));
dcl	hcs_$level_set		entry (fixed binary (3));
dcl	hcs_$wakeup		ext entry (bit (36), fixed bin (71), fixed bin (71), fixed bin (35));


dcl	mseg_check_access_$audit_initiate_failure
				entry (pointer, fixed binary (35));
dcl	mseg_check_access_$check	ext entry (ptr, fixed bin (35));
dcl	mseg_check_access_$segment	ext entry (ptr, fixed bin (35));

dcl	set_lock_$lock		ext entry (bit (36) aligned, fixed bin (17), fixed bin (35));
dcl	sub_err_			entry () options (variable);


mseg_mbx_ms_gate_target_$validate:
     entry (a_dn, a_en, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_BRIEF_ENTRY, mseg_access_operations_$read_fs_attr_seg);
	call RETURN (code);


mseg_mbx_ms_gate_target_$create:
     entry (a_dn, a_en, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_BRIEF_ENTRY, mseg_access_operations_$create_seg);

	call mseg_$create_seg (addr (operation), null (), code);

	call RETURN (code);

mseg_mbx_ms_gate_target_$delete_mseg:
     entry (a_dn, a_en, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$delete_seg);

	file_sw = "0"b;				/* no need to clean this up */

	call mseg_$delete_seg (addr (operation), static_table_ptr (operation.type), code);
						/* it removes from the table, etc. */

	call RETURN (code);

mseg_mbx_ms_gate_target_$copy:
     entry (a_dn, a_en, a_target_dn, a_target_en, a_error_on_target, a_code);

	call entry_setup;

	target_operation = addr (mseg_data_$template_operation) -> mseg_operation;
	copy_entry = "1"b;				/* Set so that when general_clean_up */
						/* gets called, error_on_target gets copied */
	error_on_target = "0"b;

	on cleanup call general_clean_up;

	call entry_common (FILE_ENTRY, mseg_access_operations_$copy_seg);

	error_on_target = "1"b;			/* any problem now is with the target */

	target_operation.caller = operation.caller;	/* copy all fields that apply ... the caller */
	target_operation.call_admin_gate = operation.call_admin_gate;
						/* whether to use multi-class */
	target_operation.type = operation.type;		/* The type of segment */
	target_operation.dir_name = a_target_dn;
	target_operation.entryname = a_target_en;
	target_operation.mseg_pathname_valid = "1"b;
	target_operation.access_operation = mseg_access_operations_$create_seg;
	call mseg_check_access_$segment (addr (target_operation), code);
						/* Test those target dir RB's ! */
						/* and chase those links */
	if code ^= 0
	then call RETURN (code);

	call mseg_$create_seg (addr (target_operation), null (), code);
	if code ^= 0
	then call RETURN (code);

	call mseg_$initiate_seg (addr (target_operation), code);
						/* mseg_create_ does not initiate since an empty mseg is EMPTY */
	if code ^= 0
	then call RETURN (code);

	call mseg_$copy_seg (addr (operation), addr (target_operation), a_error_on_target, code);

	call RETURN (code);
%page;
mseg_mbx_ms_gate_target_$chname:
     entry (a_dn, a_en, a_old_en, a_new_en, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$modify_fs_attr_seg);

	old_en = a_old_en;
	new_en = a_new_en;

	if old_en ^= ""
	then do;
		call check_name (old_en, code);
		if code ^= 0
		then call RETURN (code);
	     end;
	if new_en ^= ""
	then do;
		call check_name (new_en, code);
		if code ^= 0
		then call RETURN (code);
	     end;

	call mseg_$chname_seg (addr (operation), old_en, new_en, code);
	call RETURN (code);


mseg_mbx_ms_gate_target_$get_uid_file:
     entry (a_dn, a_en, a_uid, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_BRIEF_ENTRY, mseg_access_operations_$read_fs_attr_seg);

	a_uid = operation.access_info.uid;		/* got the UID */
	call RETURN (code);


mseg_mbx_ms_gate_target_$get_uid_index:
     entry (a_mseg_index, a_uid, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$read_fs_attr_seg);

	a_uid = operation.access_info.uid;		/* got the UID */
	call RETURN (code);

mseg_mbx_ms_gate_target_$set_max_length_file:
     entry (a_dn, a_en, a_max_length, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$modify_fs_attr_seg);

	max_length = a_max_length;
	call mseg_$set_max_length_seg (addr (operation), max_length, code);
	a_max_length = max_length;
	call RETURN (code);


mseg_mbx_ms_gate_target_$set_safety_switch:
     entry (a_dn, a_en, a_safety_switch, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$modify_fs_attr_seg);

	safety_switch = a_safety_switch;

	call mseg_$set_safety_switch_seg (addr (operation), safety_switch, code);
	call RETURN (code);


mseg_mbx_ms_gate_target_$compact_file:
     entry (a_dn, a_en, a_compact_ratio, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$compact_seg);
compact:
	call mseg_$compact_seg (addr (operation), a_compact_ratio, code);
	call RETURN (code);


mseg_mbx_ms_gate_target_$compact_index:
     entry (a_mseg_index, a_compact_ratio, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$compact_seg);
	go to compact;

mseg_mbx_ms_gate_target_$open_if_full:
     entry (a_dn, a_en, a_salv_bit, a_ms_count, a_mseg_index, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common$$return_error (FILE_ENTRY, mseg_access_operations_$get_count_seg);
						/* error codes analyzed here .... */

/**** NOTE
      If the code is zero, we can return the count and the salv bit
      and only open if there is a non-zero count.
      If the code is moderr then we open the mseg
      and return 0 for the count and salv bit, and error_table_$moderr
      for the code.
      If the code is anything else we punt. */

	if code ^= 0 & code ^= error_table_$moderr
	then call RETURN (code);

	return_count = (code = 0);
	salv_bit = "0"b;
	ms_count = 0;

	if return_count
	then do;
		call mseg_$get_salvaged_flag_seg (addr (operation), salv_bit, (0));
		a_salv_bit = salv_bit;
		call mseg_$count_messages (addr (operation), ms_count, (0));
		a_ms_count = ms_count;
		if ms_count = 0
		then call RETURN (code);		/* which will terminate the mseg */
	     end;

	if ^return_count				/* we haven't seen any access yet */
	then do;
		operation.access_operation = mseg_access_operations_$open_seg;
		call mseg_check_access_$segment (addr (operation), code);
		if code ^= 0
		then call RETURN (code);
	     end;

	call mseg_$open_seg (addr (operation), static_table_ptr (operation.type), code);
	if code ^= 0
	then call RETURN (code);			/* no room at the inn, probably */
	file_sw = "0"b;				/* don't terminate that pointer! */

	a_mseg_index = operation.mseg_index;
	if ^return_count
	then code = error_table_$moderr;		/* no report if the salv bit fails */

	call RETURN (code);

mseg_mbx_ms_gate_target_$open:
     entry (a_dn, a_en, a_mseg_index, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$open_seg);
	call mseg_$open_seg (addr (operation), static_table_ptr (operation.type), code);
	if code ^= 0
	then call RETURN (code);
	file_sw = "0"b;				/* don't terminate that pointer */

	a_mseg_index = operation.mseg_index;
	call RETURN (code);

mseg_mbx_ms_gate_target_$close:
     entry (a_mseg_index, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$close_seg);

	if (operation.access_info.extended_access_modes & D_MBX_ACCESS) ^= ""b
	then call mseg_$compact_seg (addr (operation), 0.25e0, (0));
	call mseg_$close_seg (addr (operation), static_table_ptr (operation.type), code);
	call RETURN (code);


mseg_mbx_ms_gate_target_$ex_acl_add:
     entry (a_dn, a_en, a_user_acl_ptr, a_user_acl_count, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_TEMP_ENTRY, mseg_access_operations_$acl_modify_seg);

	user_acl_ptr = a_user_acl_ptr;
	user_acl_count = a_user_acl_count;

	call copy_acl (user_acl_ptr, user_acl_count);
	call mseg_$add_acl_entries_seg (addr (operation), acl_ptr, code);
	call RETURN (code);



mseg_mbx_ms_gate_target_$ex_acl_delete:
     entry (a_dn, a_en, a_user_acl_ptr, a_user_acl_count, a_area_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_TEMP_ENTRY, mseg_access_operations_$acl_modify_seg);

	user_acl_ptr = a_user_acl_ptr;
	user_acl_count = a_user_acl_count;

	call copy_acl$$delete (user_acl_ptr, user_acl_count);
	call mseg_$delete_acl_entries_seg (addr (operation), acl_ptr, code);
	call RETURN (code);



mseg_mbx_ms_gate_target_$ex_acl_list:
     entry (a_dn, a_en, a_user_acl_ptr, a_user_acl_count, a_area_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_TEMP_ENTRY, mseg_access_operations_$acl_list_seg);

	user_acl_ptr = a_user_acl_ptr;
	user_acl_count = a_user_acl_count;
	area_ptr = a_area_ptr;

	if area_ptr = null ()
	then do;
	          if (user_acl_ptr = null ()) | (user_acl_count < 1)
		then call RETURN (error_table_$argerr);

		call copy_acl (user_acl_ptr, user_acl_count);
		call mseg_$list_acl_entries_seg (addr (operation), acl_ptr, code);
		user_acl_ptr -> segment_acl_array = general_extended_acl.entries;
	     end;
	else do;
		call mseg_$list_acl_seg (addr (operation), acl_ptr, code);
		if code ^= 0
		then call RETURN (code);
		acl_count = general_extended_acl.count;
		on area
		     begin;
			code = error_table_$noalloc;
			call RETURN (code);
		     end;
		allocate segment_acl_array in (user_area) set (user_acl_ptr);
		revert area;
		do i = 1 to acl_count;		/* PL/I always copies at least 1 even if acl_count = 0 */
		     user_acl_ptr -> segment_acl_array (i) = general_extended_acl.entries (i);
		end;
		a_user_acl_ptr = user_acl_ptr;
		a_user_acl_count = acl_count;
	     end;
	call RETURN (code);

mseg_mbx_ms_gate_target_$ex_acl_replace:
     entry (a_dn, a_en, a_user_acl_ptr, a_user_acl_count, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_TEMP_ENTRY, mseg_access_operations_$acl_modify_seg);

	user_acl_ptr = a_user_acl_ptr;
	user_acl_count = a_user_acl_count;

	if user_acl_count > 0
	then call copy_acl (user_acl_ptr, user_acl_count);
	else acl_ptr = null ();

	call mseg_$replace_acl_seg (addr (operation), acl_ptr, code);

	if acl_ptr ^= null ()
	then user_acl_ptr -> segment_acl_array (*).status_code = general_extended_acl.entries (*).status_code;
	call RETURN (code);



mseg_mbx_ms_gate_target_$read_index:
     entry (a_mseg_index, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$read_message);
old_read:
	area_ptr = a_area_ptr;
	arg_ptr = a_arg_ptr;
	ms_wanted = a_ms_wanted;
	ms_id = ""b;
	string (old_read_flags) = "0"b;
	old_read_flags.first_or_last = ms_wanted;
	call read_for_old_entrypoint (ms_id);
	call RETURN (code);


mseg_mbx_ms_gate_target_$delete_index:
     entry (a_mseg_index, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$delete_message);

delete:
	operation.message_info.ms_id = a_ms_id;
	operation.message_info_valid = "1"b;
	call mseg_$delete_message (addr (operation), code);
	call RETURN (code);


mseg_mbx_ms_gate_target_$read_delete_index:
     entry (a_mseg_index, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$read_delete_message);

old_read_delete:
	area_ptr = a_area_ptr;
	ms_wanted = a_ms_wanted;
	arg_ptr = a_arg_ptr;
	string (old_read_flags) = ""b;
	ms_id = ""b;
	old_read_flags.first_or_last = ms_wanted;
	old_read_flags.delete = "1"b;
	call read_for_old_entrypoint (ms_id);
	call RETURN (code);

mseg_mbx_ms_gate_target_$admin_add_index:
     entry (a_mseg_index, a_arg_ptr, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$admin_add_message);
						/* access check needs message access class */

/* This entry point, available through the privileged gate queue_admin_,
   adds a message with attributes specified in the mseg_message_info structure. */

admin_add:
	mseg_message_info_ptr = a_arg_ptr;
	operation.message_info = mseg_message_info;
	operation.message_info_valid = "1"b;
	operation.add_message_info_all_valid = "1"b;	/* This makes mseg_ respect all the fields as input */
	if operation.message_info.version ^= MSEG_MESSAGE_INFO_V1
	then call RETURN (error_table_$unimplemented_version);

	call mseg_check_access_$segment (addr (operation), code);
	if code ^= 0
	then call RETURN (code);

	call mseg_$add_message (addr (operation), code);

	if code = 0
	then do;
		a_ms_id = operation.message_info.ms_id;
		mseg_message_info = operation.message_info;
	     end;
	call RETURN (code);

mseg_mbx_ms_gate_target_$admin_add_file:
     entry (a_dn, a_en, a_arg_ptr, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$admin_add_message);
						/* access check needs message access class */

	go to admin_add;


mseg_mbx_ms_gate_target_$add_index:
     entry (a_mseg_index, a_ms_ptr, a_ms_len, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;

	call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$add_message);

	operation.message_info.ms_access_class = aim_util_$get_access_class (operation.caller.authorization);

add:
	call mseg_check_access_$segment (addr (operation), code);
	if code ^= 0
	then call RETURN (code);
	operation.message_info.ms_ptr = a_ms_ptr;
	operation.message_info.ms_len = a_ms_len;
	operation.message_info_valid = "1"b;
	call mseg_$add_message (addr (operation), code);
	if code ^= 0
	then call RETURN (code);

	a_ms_id = operation.message_info.ms_id;
	call RETURN (code);



/**** WAKEUP entrypoints */

/****^ Error codes returned by these entry point:

   error_table_$ai_restricted
         an attempt to write down a message
         or write a message into an AIM inappropriate mseg.
   error_table_$action_not_performed
         normals not accepted, by urgents are.
   error_table_$no_append
        insufficient access to add a message.
   error_table_$wakeup_denied
        insufficient access to send a wakeup.
   error_table_$messages_deferred
        recipient has deferred messages.
   error_table_$messages_off
        recipient has not initialized for accepting messages.
   error_table_$no_info
        no information can be returned because recipient has higher authorization.
*/

mseg_mbx_ms_gate_target_$wakeup_add_index:
     entry (a_mseg_index, a_ms_ptr, a_ms_len, a_sw, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$add_message);
	operation.message_info.ms_access_class = aim_util_$get_access_class (operation.caller.authorization);
	operation.message_info_valid = "1"b;
	call wakeup_add;

mseg_mbx_ms_gate_target_$wakeup_aim_add_index:
     entry (a_mseg_index, a_ms_ptr, a_ms_len, a_sw, a_access_class, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$add_message);
	operation.message_info.ms_access_class = a_access_class;
	operation.message_info_valid = "1"b;
	call wakeup_add;

mseg_mbx_ms_gate_target_$wakeup_add_file:
     entry (a_dn, a_en, a_ms_ptr, a_ms_len, a_sw, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$add_message);
	operation.message_info.ms_access_class = aim_util_$get_access_class (operation.caller.authorization);
	operation.message_info_valid = "1"b;
	call wakeup_add;

mseg_mbx_ms_gate_target_$wakeup_aim_add_file:
     entry (a_dn, a_en, a_ms_ptr, a_ms_len, a_sw, a_access_class, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$add_message);
	operation.message_info.ms_access_class = a_access_class;
	operation.message_info_valid = "1"b;
	call wakeup_add;


wakeup_add:
     procedure ();

declare	user_accepting		bit (1) aligned;
declare	censor_wakeup_code		bit (1) aligned;
declare	wakeup			bit (1) aligned;
declare	wakeup_code		fixed bin (35);
dcl	1 switch			aligned,		/* wakeup control switches */
	  2 normal_wakeup		bit (1) unaligned,
	  2 urgent_wakeup		bit (1) unaligned,
	  2 always_add		bit (1) unaligned,
	  2 never_add		bit (1) unaligned,
	  2 pad			bit (32) unaligned;

	operation.message_info.ms_ptr = a_ms_ptr;
	operation.message_info.ms_len = a_ms_len;
	unspec (switch) = a_sw;

	wakeup = switch.normal_wakeup | switch.urgent_wakeup;

	if wakeup
	then call investigate_acceptance (user_accepting);
	else user_accepting = "0"b;

	if user_accepting
	then					/* implies that wakeup is set */
	     if aim_check_$greater_or_equal (operation.wakeup_state.access_class,
		operation.message_info.ms_access_class) /* acceptor is higher than planned access class of message */
	     then operation.message_info.ms_access_class = operation.wakeup_state.access_class;
						/* Upgrade, over-riding any user-specified access class */


/**** Now we are ready to check access.
      The user is requesting that we add a message. 

      1) Test to see if the message can be added.
      2) If it cannot be added, quit.
      3) If a wakeup is required, test to see if the wakeup can be sent. 
      4) If it cannot be sent, and always_add is not enabled, then quit.
      5) Add the message.
      6) If a wakeup can be sent, send it. */


/**** Has the user "a" access and is the AIM situation plausible ? */

	operation.access_operation = mseg_access_operations_$add_message;
	call mseg_check_access_$check (addr (operation), code);

	if code ^= 0
	then do;
		if ^switch.never_add
		then do;				/* Never add --> don't do anthing, so we shouldn't audit it. */
			call mseg_check_access_$segment (addr (operation), (0));
						/* Okay, audit */
		     end;
		if code = error_table_$moderr
		then code = error_table_$no_append;
		call RETURN (code);			/* and punt */
	     end;


/**** Now, can we send a wakeup? */

	if wakeup
	then do;
		wakeup_code = 0;
		if switch.normal_wakeup
		then operation.access_operation = mseg_access_operations_$send_normal_wakeup;
		else operation.access_operation = mseg_access_operations_$send_urgent_wakeup;

/**** This just makes the w/u mode checks. It makes NO aim checks */

		if switch.never_add
		then call mseg_check_access_$check (addr (operation), code);
		else call mseg_check_access_$segment (addr (operation), code);

		if code ^= 0
		then if switch.always_add
		     then wakeup_code = error_table_$wakeup_denied;
		     else call RETURN (error_table_$wakeup_denied);


/****  If the user lacks w/u, that lack governs the error code, as 
       calculated above. If the user has w/u, then the user is entitled
       to hear that there is noone accepting by getting messages_off. */

		if ^user_accepting & wakeup_code = 0
		then if switch.always_add
		     then wakeup_code = error_table_$messages_off;
		     else call RETURN (error_table_$messages_off);


/**** Now we have a little problem. We cannot tell if we will succeed
      at sending a wakeup on AIM grounds, since it will depend on
      the receiver's privilege situation. (and, or course, that
      cannot be investigated via admin gate, and could change at any time.)
      So we pretend that receiver IPC privilege don't exist,
      and demand either that we have ipc priv, that no priv is needed,
      or that always_add be on. This check does NOT audit. Turning off
      always add means "if I could send without an AIM error, send.
      If you cannot tell me that, then don't send and return ai_restricted"
      Note that if always_add is on, and we DO call hcs_$wakeup,
      it might return 0 due to target IPC priv. */

		if user_accepting & ^switch.always_add
		then if ((operation.caller.privileges & sys_info$ipc_privilege) = ""b)
		     then if ^aim_check_$greater_or_equal (operation.wakeup_state.access_class,
			     operation.caller.authorization)
			then call RETURN (error_table_$ai_restricted);

/**** From now on, if the acceptor is aim-greater than us, we censor
      all results to no-info. Why isn't this in the access kernel?
      Because it's just too hard to arrange. */

		if user_accepting
		then censor_wakeup_code =
			((operation.caller.privileges & sys_info$ring1_privilege) = ""b)
			& aim_check_$greater (operation.wakeup_state.access_class, operation.caller.authorization);
		else censor_wakeup_code = "0"b;

/**** Okay, now we have passed the per-se access control checks. Now we
      see if the acceptor of messages is willing to accept a message
      from this process. */

		if wakeup_code = 0 & user_accepting
		then do;

			if (switch.urgent_wakeup & ^operation.wakeup_state.accepting_urgent_wakeups)
			then if switch.always_add
			     then wakeup_code = error_table_$messages_deferred;
			     else call WAKEUP_RETURN (error_table_$messages_deferred);

			if (switch.normal_wakeup & ^operation.wakeup_state.accepting_normal_wakeups)
			then do;
				if operation.wakeup_state.accepting_urgent_wakeups
				then wakeup_code = error_table_$action_not_performed;
				else wakeup_code = error_table_$messages_deferred;
				if ^switch.always_add
				then call WAKEUP_RETURN (wakeup_code);

			     end;
		     end;
	     end;


/**** Okay, we are ready to actually do something. If we cannot send
      the wakeup, wakeup_code has the reason why, subject to censorship */

	if switch.never_add
	then do;
		operation.message_info.ms_id = ""b;
		code = 0;
	     end;


	else do;

/* add message */

		operation.access_operation = mseg_access_operations_$add_message;
		call mseg_check_access_$segment (addr (operation), (0));
						/* audit the add now */
		call mseg_$add_message (addr (operation), code);

/* send wakeup */

		if wakeup & code = 0 & wakeup_code = 0 & user_accepting
		then do;
			unspec (event_message) = operation.message_info.ms_id;
			call hcs_$wakeup ((operation.wakeup_state.process_id), operation.wakeup_state.event_channel,
			     event_message, wakeup_code);
			if wakeup_code ^= 0 & wakeup_code ^= error_table_$wakeup_denied
			then wakeup_code = error_table_$messages_off;
		     end;
	     end;

	if code = 0
	then do;					/* the message was added */
		a_ms_id = operation.message_info.ms_id;
		if wakeup
		then call WAKEUP_RETURN (wakeup_code);	/* ... tell the caller what happened to the wakeup (maybe) */
		else call RETURN (0);
	     end;

	else call RETURN (code);


investigate_acceptance:
     procedure (accepting);

declare	accepting			bit (1) aligned;

	accepting = "0"b;				/* until proven otherwise */

	call mseg_$get_wakeup_state_seg (addr (operation), code);

	if (code ^= 0) & (code ^= error_table_$messages_off)
	then call RETURN (code);			/* message segment kaboom */
	if code = 0
	then do;
		test_lock_id = operation.wakeup_state.lock_id;
		call set_lock_$lock (test_lock_id, 0, code);
		if code = 0 | code = error_table_$invalid_lock_reset
		then code = error_table_$messages_off;
		else code = 0;
	     end;
	if code = 0
	then do;
		accepting = "1"b;
		operation.wakeup_state_valid = "1"b;	/* used inside check-access later */
	     end;

	return;
     end investigate_acceptance;

WAKEUP_RETURN:
     procedure (w_code);

declare	w_code			fixed bin (35);

	if censor_wakeup_code
	then call RETURN (error_table_$no_info);
	else call RETURN (w_code);
     end WAKEUP_RETURN;

     end wakeup_add;


mseg_mbx_ms_gate_target_$accept_wakeups_index:
     entry (a_mseg_index, a_event_channel, a_sw, a_code);

	call entry_setup;
	on cleanup call general_clean_up;

	call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$accept_wakeups_seg);
						/* access check requires the segment's wakeup state */

	call accept_wakeups;
	call RETURN (code);


accept_wakeups:
     procedure ();

dcl	1 switch			aligned,		/* wakeup control switches */
	  2 normal_wakeup		bit (1) unaligned,
	  2 urgent_wakeup		bit (1) unaligned;

	user_event_channel = a_event_channel;
	unspec (switch) = substr(a_sw,1,length(unspec(switch)));

	call mseg_$get_wakeup_state_seg (addr (operation), code);
	if (code ^= 0) & (code ^= error_table_$messages_off)
	then return;
	operation.wakeup_state_valid = (code = 0);

	call mseg_check_access_$segment (addr (operation), code);
	if code ^= 0
	then return;

	operation.wakeup_state.accepting_normal_wakeups = switch.normal_wakeup;
	operation.wakeup_state.accepting_urgent_wakeups = switch.urgent_wakeup;
	operation.wakeup_state.event_channel = user_event_channel;
	operation.wakeup_state_valid = "1"b;

	call mseg_$set_wakeup_state_seg (addr (operation), code);
	return;
     end accept_wakeups;


mseg_mbx_ms_gate_target_$incremental_read_index:
     entry (a_mseg_index, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$read_message);

old_incremental_read:
	area_ptr = a_area_ptr;
	dir = a_dir;
	ms_id = a_ms_id;
	arg_ptr = a_arg_ptr;
	string (old_read_flags) = ""b;
	old_read_flags.incremental = "1"b;
	old_read_flags.incremental_direction = dir;
	call read_for_old_entrypoint (ms_id);
	call RETURN (code);

mseg_mbx_ms_gate_target_$get_message_count_index:
     entry (a_mseg_index, a_ms_count, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$get_count_seg);

get_message_count:
	call mseg_$count_messages (addr (operation), ms_count, code);
	a_ms_count = ms_count;
	call RETURN (code);


mseg_mbx_ms_gate_target_$get_mode_index:
     entry (a_mseg_index, a_mode, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$read_fs_attr_seg);

get_mode:
	a_mode = operation.access_info.extended_access_modes;
	call RETURN (code);


mseg_mbx_ms_gate_target_$check_salv_bit_index:
     entry (a_mseg_index, a_turn_off, a_salv_bit, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	turn_off = a_turn_off;

	if ^turn_off
	then call entry_common (INDEX_ENTRY, mseg_access_operations_$read_attr_seg);
	else call entry_common (INDEX_ENTRY, mseg_access_operations_$reset_salvage_bit_seg);

check_salv_bit:
	call mseg_$get_salvaged_flag_seg (addr (operation), salv_bit, code);
	if code ^= 0
	then call RETURN (code);
	if turn_off
	then call mseg_$reset_salvaged_flag_seg (addr (operation), code);
	a_salv_bit = salv_bit;
	call RETURN (code);



mseg_mbx_ms_gate_target_$update_message_index:
     entry (a_mseg_index, a_ms_len, a_ms_id, a_ms_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$update_message);

update_message:
	operation.message_info.ms_len = a_ms_len;
	operation.message_info.ms_id = a_ms_id;
	operation.message_info.ms_ptr = a_ms_ptr;
	operation.message_info_valid = "1"b;
	call mseg_$update_message (addr (operation), code);
	call RETURN (code);


mseg_mbx_ms_gate_target_$read_file:
     entry (a_dn, a_en, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$read_message);
	go to old_read;


mseg_mbx_ms_gate_target_$delete_file:
     entry (a_dn, a_en, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$delete_message);
	go to delete;



mseg_mbx_ms_gate_target_$read_delete_file:
     entry (a_dn, a_en, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$read_delete_message);
	go to old_read_delete;


mseg_mbx_ms_gate_target_$add_file:
     entry (a_dn, a_en, a_ms_ptr, a_ms_len, a_ms_id, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$add_message);
	operation.message_info.ms_access_class = aim_util_$get_access_class (operation.caller.authorization);
	go to add;

mseg_mbx_ms_gate_target_$accept_wakeups_file:
     entry (a_dn, a_en, a_event_channel, a_code);

	call entry_setup;
	on cleanup call general_clean_up;

	call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$accept_wakeups_seg);
						/* access check requires segment's wakeup state */

	call accept_wakeups;
	call RETURN (code);

mseg_mbx_ms_gate_target_$incremental_read_file:
     entry (a_dn, a_en, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$read_message);
	go to old_incremental_read;

mseg_mbx_ms_gate_target_$get_message_count_file:
     entry (a_dn, a_en, a_ms_count, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$get_count_seg);
	go to get_message_count;

mseg_mbx_ms_gate_target_$get_mode_file:
     entry (a_dn, a_en, a_mode, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_BRIEF_ENTRY, mseg_access_operations_$read_fs_attr_seg);
	go to get_mode;


mseg_mbx_ms_gate_target_$check_salv_bit_file:
     entry (a_dn, a_en, a_turn_off, a_salv_bit, a_code);

	turn_off = a_turn_off;
	call entry_setup;
	on cleanup call general_clean_up;

	if ^turn_off
	then call entry_common (FILE_ENTRY, mseg_access_operations_$read_attr_seg);
	else call entry_common (FILE_ENTRY, mseg_access_operations_$reset_salvage_bit_seg);

	go to check_salv_bit;

mseg_mbx_ms_gate_target_$update_message_file:
     entry (a_dn, a_en, a_ms_len, a_ms_id, a_ms_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$update_message);
	go to update_message;

mseg_mbx_ms_gate_target_$o_read_index:
     entry (a_mseg_index, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$read_own_message);

old_o_read:
	area_ptr = a_area_ptr;
	ms_wanted = a_ms_wanted;
	arg_ptr = a_arg_ptr;
	string (old_read_flags) = ""b;
	old_read_flags.first_or_last = ms_wanted;
	old_read_flags.own = "1"b;
	ms_id = ""b;
	call read_for_old_entrypoint (ms_id);
	call RETURN (code);


mseg_mbx_ms_gate_target_$o_incremental_read_index:
     entry (a_mseg_index, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (INDEX_ENTRY, mseg_access_operations_$read_own_message);

old_o_incremental_read:
	area_ptr = a_area_ptr;
	dir = a_dir;
	ms_id = a_ms_id;
	arg_ptr = a_arg_ptr;
	string (old_read_flags) = ""b;
	old_read_flags.incremental = "1"b;
	old_read_flags.incremental_direction = dir;
	old_read_flags.own = "1"b;
	call read_for_old_entrypoint (ms_id);
	call RETURN (code);

mseg_mbx_ms_gate_target_$o_read_file:
     entry (a_dn, a_en, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$read_own_message);
	go to old_o_read;



mseg_mbx_ms_gate_target_$o_incremental_read_file:
     entry (a_dn, a_en, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	call entry_common (FILE_ENTRY, mseg_access_operations_$read_own_message);
	go to old_o_incremental_read;

mseg_mbx_ms_gate_target_$general_read_index:
     entry (a_mseg_index, a_area_ptr, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;
	read_entry_type = INDEX_ENTRY;

read:
	area_ptr = a_area_ptr;
	mseg_message_info_ptr = a_arg_ptr;
	operation.message_info = mseg_message_info;
	if operation.message_info.version ^= MSEG_MESSAGE_INFO_V1
	then do;
		code = error_table_$unimplemented_version;
		call RETURN (code);
	     end;

	if operation.message_info.delete & operation.message_info.own
	then call entry_common (read_entry_type, mseg_access_operations_$read_delete_own_message);
	else if operation.message_info.delete
	then call entry_common (read_entry_type, mseg_access_operations_$read_delete_message);
	else if operation.message_info.own
	then call entry_common (read_entry_type, mseg_access_operations_$read_own_message);
	else call entry_common (read_entry_type, mseg_access_operations_$read_message);

	operation.message_info_valid = "1"b;
	call mseg_$read_message (addr (operation), area_ptr, code);
	mseg_message_info = operation.message_info;
	call RETURN (code);

mseg_mbx_ms_gate_target_$general_read_file:
     entry (a_dn, a_en, a_area_ptr, a_arg_ptr, a_code);

	call entry_setup;
	on cleanup call general_clean_up;

	read_entry_type = FILE_ENTRY;
	go to read;

check_name:
     proc (entryname, code);

dcl	entryname			char (32);
dcl	code			fixed bin (35);
dcl	slength			fixed bin;
dcl	sindex			fixed bin;

	code = 0;
	slength = length (rtrim (entryname));
	sindex = index (reverse (rtrim (entryname)), ".");
	if sindex ^= 0 then
	     if substr (entryname, slength - sindex + 1) = SUFFIX (operation.type) then;
	     else code = error_table_$bad_file_name;
	else code = error_table_$bad_file_name;
	return;
     end check_name;

copy_acl:
     proc (p_acl_ptr, p_acl_count);

dcl	p_acl_ptr			ptr;
dcl	p_acl_count		fixed bin;

	if p_acl_count = 0 | p_acl_ptr = null ()
	then do;
		acl_count = 0;
		acl_ptr = null ();
	     end;

	acl_count = p_acl_count;
	allocate general_extended_acl set (internal_acl_ptr);
	acl_ptr = internal_acl_ptr;

	general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1;
	general_extended_acl.entries = p_acl_ptr -> segment_acl_array;

	return;

copy_acl$$delete:
     entry (p_acl_ptr, p_acl_count);

	if p_acl_ptr = null () | p_acl_count = 0
	then call RETURN (error_table_$null_info_ptr);

	if p_acl_count = -1
	then do;
		acl_ptr, internal_acl_ptr = null ();	/* null to the primitive means "delete all" */
		acl_count = 0;			/* never looked at */
		return;
	     end;

	acl_count = p_acl_count;
	allocate general_delete_acl set (internal_acl_ptr);
	acl_ptr = internal_acl_ptr;

	general_delete_acl.version = GENERAL_DELETE_ACL_VERSION_1;
	general_delete_acl.entries = p_acl_ptr -> delete_acl_array;
	return;

     end copy_acl;



free:
     procedure;

	if internal_acl_ptr ^= null
	then free internal_acl_ptr -> general_extended_acl in (system_area);
	return;

     end free;


set_admin_level:
     procedure;

	validation_set = "1"b;
	if operation.call_admin_gate
	then call admin_gate_$admin_level_no_fs_audit ((0));
						/* we already stored the caller level */
	else call hcs_$level_set (mseg_data_$execution_ring);
	return;
     end set_admin_level;

reset_admin_level:
     procedure;

	if validation_set
	then call hcs_$level_set (operation.caller.validation_level);
	validation_set = "0"b;
	return;
     end reset_admin_level;

general_clean_up:
     procedure;

	if file_sw
	then call mseg_$close_seg (addr (operation), table_ptr, (0));
	if copy_entry
	then call clean_up_copy;
	if internal_acl_ptr ^= null ()
	then do;
		if general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1
		then user_acl_ptr -> segment_acl_array (*).status_code = general_extended_acl.entries (*).status_code;
		else if general_delete_acl.version = GENERAL_DELETE_ACL_VERSION_1
		then user_acl_ptr -> delete_acl_array (*).status_code = general_delete_acl.entries (*).status_code;
		call free;
	     end;
	call reset_admin_level ();

clean_up_copy:
     procedure;

	call mseg_$close_seg (addr (target_operation), table_ptr, (0));
	a_error_on_target = error_on_target;
	return;
     end clean_up_copy;

     end general_clean_up;


RETURN_:
	call general_clean_up;
	if code = error_table_$dirseg
	then code = error_table_$not_seg_type;
	a_code = code;
	return;


EARLY_RETURN:
	if code = error_table_$dirseg
	then code = error_table_$not_seg_type;
	a_code = code;

	return;

read_for_old_entrypoint:
     procedure (a_ms_id);

declare	1 mra			aligned like mseg_return_args;
declare	a_ms_id			bit (72) aligned;

	operation.message_info.ms_id = a_ms_id;

	if ^old_read_flags.incremental
	then do;
		if old_read_flags.first_or_last
		then operation.message_info.message_code = MSEG_READ_LAST;
		else operation.message_info.message_code = MSEG_READ_FIRST;
	     end;
	else if old_read_flags.incremental_direction = "00"b
	then operation.message_info.message_code = MSEG_READ_SPECIFIED;
	else if old_read_flags.incremental_direction = "10"b
	then operation.message_info.message_code = MSEG_READ_BEFORE_SPECIFIED;
	else if old_read_flags.incremental_direction = "01"b
	then operation.message_info.message_code = MSEG_READ_AFTER_SPECIFIED;
	else call RETURN (error_table_$inconsistent);	/* incr with bad direction */

	operation.message_info.own = old_read_flags.own;
	operation.message_info.delete = old_read_flags.delete;
	operation.message_info_valid = "1"b;
	call mseg_$read_message (addr (operation), area_ptr, code);
	if code = 0
	then do;
		mra.ms_ptr = operation.message_info.ms_ptr;
		mra.ms_len = operation.message_info.ms_len;
		mra.sender_id = operation.message_info.sender_id;
		mra.level = operation.message_info.sender_level;
		mra.ms_id = operation.message_info.ms_id;
		mra.sender_authorization = operation.message_info.sender_authorization;
		mra.access_class = operation.message_info.ms_access_class;
		arg_ptr -> mseg_return_args = mra;
	     end;
	return;
     end read_for_old_entrypoint;


entry_setup:
     procedure;

declare	(
	message_segment_$,
	mailbox_$,
	queue_admin_$
	)			bit (36) aligned ext static;

	operation = addr (mseg_data_$template_operation) -> mseg_operation;


/**** Callers may not have access to queue_admin_, so the following
      avoids touching it unneccessarily. */

	if setwordno (cu_$caller_ptr (), 0) = addr (mailbox_$)
	then operation.type = MSEG_TYPE_MBX;
	else if setwordno (cu_$caller_ptr (), 0) = addr (message_segment_$)
	then operation.type = MSEG_TYPE_MS;
	else if setwordno (cu_$caller_ptr (), 0) = addr (queue_admin_$)
	then operation.type = MSEG_TYPE_MS;
	else call sub_err_ (0, "mseg_mbx_ms_gate_target_", ACTION_CANT_RESTART, null (), (0),
		"Caller was not mailbox_, message_segment_, or queue_admin_");

	operation.caller.validation_level = hcs_$level_get ();
	operation.caller.authorization = get_process_authorization_ ();
	operation.caller.max_authorization = mseg_data_$process_max_authorization;
	operation.caller.privileges =
	   substr(aim_util_$get_privileges (operation.caller.authorization),1,length(operation.caller.privileges));
	operation.caller.group_id = mseg_data_$group_id;
	validation_set = "0"b;			/* no need to reset the level */
	operation.call_admin_gate = (mseg_data_$execution_ring = mseg_data_$admin_ring);
	copy_entry = "0"b;
	internal_acl_ptr = null ();
	file_sw = "0"b;

	return;
     end entry_setup;


entry_common:
     procedure (entry_type, base_operation);

declare	entry_type		fixed bin;
declare	base_operation		fixed bin;
declare	(return_code, dont_call_mca)	bit (1) aligned;

	dont_call_mca = "0"b;
	return_code = "0"b;
	go to COMMON;


entry_common$$no_access_check:
     entry (entry_type, base_operation);

	dont_call_mca = "1"b;
	return_code = "0"b;				/* not that it will ever be used */
	go to COMMON;


entry_common$$return_error:
     entry (entry_type, base_operation);

	dont_call_mca = "0"b;
	return_code = "1"b;


COMMON:
	operation.access_operation = base_operation;

/**** This next line sets the validation level to the ring of execution.
      If the ring of execution is 1, it also suppresses ring zero file
      system auditing. It would be better coding practice to reduce
      the scope of this to the minimum neccessary. However, this entire
      subsystem would need to be restructured to support that. */

	call set_admin_level ();

	if entry_type = INDEX_ENTRY
	then call index_setup;
	else if entry_type = FILE_ENTRY
	then call file_setup;
	else if entry_type = FILE_BRIEF_ENTRY
	then call file_brief_setup;
	else if entry_type = FILE_TEMP_ENTRY
	then call file_temp_setup;

	if dont_call_mca				/* caller isn't ready for mseg_check_access_ yet */
	then return;

	call mseg_check_access_$segment (addr (operation), code);
	if code ^= 0
	then if return_code
	     then return;
	     else call RETURN (code);

	return;


index_setup:
     procedure ();

	operation.mseg_index = a_mseg_index;		/* copy the parameter, all such gates have it */

	table_ptr = static_table_ptr (operation.type);
	if table_ptr = null ()
	then call RETURN (error_table_$seg_unknown);

	if operation.mseg_index < 1 | operation.mseg_index > mseg_table.table_length
	then call RETURN (error_table_$seg_unknown);

	operation.mseg_ptr = mseg_table.mseg_ptr (operation.mseg_index);

	if operation.mseg_ptr = null ()
	then call RETURN (error_table_$seg_unknown);

	operation.mseg_ptr_valid = "1"b;
	operation.mseg_index_valid = "1"b;

	return;

     end index_setup;


file_setup:
     procedure ();

	file_sw = "1"b;

	operation.dir_name = a_dn;			/* copy the parameters */
	operation.entryname = a_en;
	operation.mseg_pathname_valid = "1"b;

	call check_name (operation.entryname, code);
	if code ^= 0
	then call RETURN (code);

	call mseg_$initiate_seg (addr (operation), code);
	if code ^= 0
	then do;
		call mseg_check_access_$audit_initiate_failure (addr (operation), code);
		call RETURN (code);			/* must be sure to audit failure and censor code if needed */
	     end;

	return;

     end file_setup;


file_brief_setup:
     procedure ();

	operation.dir_name = a_dn;			/* copy the parameters */
	operation.entryname = a_en;
	operation.mseg_pathname_valid = "1"b;

	call check_name (operation.entryname, code);
	if code ^= 0
	then call RETURN (code);

	return;

     end file_brief_setup;


file_temp_setup:
     procedure ();

	operation.dir_name = a_dn;			/* copy the parameters */
	operation.entryname = a_en;
	operation.mseg_pathname_valid = "1"b;

	call check_name (operation.entryname, code);
	if code ^= 0
	then call RETURN (code);

	return;

     end file_temp_setup;

     end entry_common;


RETURN:
     procedure (return_error_code);

declare	return_error_code		fixed bin (35);

	code = return_error_code;
	go to RETURN_;

     end RETURN;

/* format: off */
%page; %include mseg_data_;
%page; %include mseg_return_args;
%page; %include mseg_message_info;
%page; %include mseg_operation;
%page; %include mseg_wakeup_state;
%page; %include entry_access_info;
%page; %include mseg_access_operations_;
%page; %include mlsys_mailbox_modes;
%page; %include mseg_index_table;
%page; %include sub_err_flags;
%page; %include mseg_entries;
%page; %include acl_structures;
     end mseg_mbx_ms_gate_target_;





		    mseg_message_.pl1               08/06/87  1022.8rew 08/06/87  1019.6      396045



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


/****^  HISTORY COMMENTS:
  1) change(85-04-01,Palter), approve(), audit(), install():
      Pre-hcom comments.
      Created:  April 1985 by G. Palter based upon mseg_, mseg_add_, and
         mseg_util_
  2) change(86-09-30,Lippard), approve(86-11-24,MCR7578),
     audit(87-07-13,Dickson), install(87-08-06,MR12.1-1067):
      Modified to always give new message IDs.
                                                   END HISTORY COMMENTS */


/* Message segment primitive operations (mseg_) which manipulate the individual messages within the segment */

/* format: style3,linecom */

mseg_message_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl	P_mseg_operation_ptr			/* -> description of this operation (I) */
			pointer parameter;
dcl	P_code		fixed binary (35) parameter;

dcl	P_operation_name	character (*) parameter;	/* *_for_mseg: the actual operation performing this act (I) */

dcl	P_ms_count	fixed binary parameter;	/* count_messages: set to # of accessible messages (O) */

dcl	P_users_area_ptr	pointer parameter;		/* read_message*: -> area in which to allocate message (I) */


/* Local copies of parameters */

dcl	users_area	area based (users_area_ptr);
dcl	users_area_ptr	pointer;

dcl	code		fixed binary (35);


/* Remaining declarations */

dcl	1 local_md	aligned like message_descriptor;

dcl	1 mseg_message_bits aligned based (mseg_message_info.ms_ptr),
	  2 data		bit (mseg_message_info.ms_len) unaligned;

dcl	1 local_aef	aligned like audit_event_flags;

dcl	local_message_block (32) bit (36) aligned;

dcl	operation_specific_return
			entry (fixed binary (35)) variable;
dcl	operation_specific_abort
			entry () variable;
dcl	operation_name	character (64);
dcl	operation_started_locally
			bit (1) aligned;

dcl	mseg_dir_name	character (168);
dcl	mseg_entryname	character (32);

dcl	(first_mb_ptr, prev_mb_ptr, next_mb_ptr)
			pointer;
dcl	(prev_md_ptr, next_md_ptr)
			pointer;
dcl	next_message_in_hash_chain
			pointer;

dcl	rqo_detected	bit (1) aligned;
dcl	do_owner_check	bit (1) aligned;

dcl	now		fixed binary (71);
dcl	(n_bits_remaining, n_bits_copied, n_bits_to_copy)
			fixed binary (24);
dcl	message_offset	fixed binary (18) unaligned unsigned;
dcl	(n_blocks_needed, block_no, block_id, last_block_allocated)
			fixed binary (18);
dcl	hash_idx		fixed binary (9);

dcl	(
	error_table_$bad_segment,
	error_table_$bad_subr_arg,
	error_table_$bigarg,
	error_table_$noalloc,
	error_table_$notalloc,
	error_table_$no_message,
	error_table_$null_info_ptr,
	error_table_$rqover,
	error_table_$smallarg,
	error_table_$unimplemented_version
	)		fixed binary (35) external;

dcl	access_operations_$mseg_add_message
			bit (36) aligned external;
dcl	sys_info$ring1_privilege
			bit (36) aligned external;

dcl	access_audit_r1_$get_audit_flags
			entry () returns (bit (36) aligned);
dcl	access_audit_r1_$log_obj_ptr
			entry () options (variable);
dcl	get_process_id_	entry () returns (bit (36));
dcl	mseg_check_access_$message
			entry (pointer, fixed binary (35));
dcl	mseg_utils_$abort_operation
			entry (pointer);
dcl	mseg_utils_$begin_operation
			entry (bit (36) aligned, pointer, character (*), character (*), character (*), pointer,
			bit (1) aligned, fixed binary (35));
dcl	mseg_utils_$finish_operation
			entry (pointer);
dcl	mseg_utils_$salvage_for_cause
			entry (pointer, fixed binary (35)) options (variable);
dcl	read_allowed_	entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);

dcl	(addr, after, before, clock, currentsize, divide, fixed, index, length, min, mod, null, rtrim, setwordno, string,
	substr, unspec, wordno)
			builtin;

dcl	(area, cleanup)	condition;
%page;
/* Add a message */

mseg_message_$add_message:
     entry (P_mseg_operation_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$add_message);
	if rqo_detected
	then call return_from_operation (error_table_$rqover);
	else if code ^= 0
	then call return_from_operation (code);


ADD_MESSAGE:
	mseg_message_info_ptr = addr (mseg_operation.message_info);
	if (mseg_message_info.ms_ptr = null ()) & (mseg_message_info.ms_len ^= 0)
	then call return_from_operation (error_table_$null_info_ptr);
	else if mseg_message_info.ms_len < 0
	then call return_from_operation (error_table_$smallarg);
	else if mseg_message_info.ms_len > (36 * mseg_data_$max_message_size)
	then call return_from_operation (error_table_$bigarg);


	/*** Set that portion of the message descriptor which we already know */

	unspec (local_md) = ""b;

	if mseg_operation.add_message_info_all_valid
	then do; /*** Admin Add -- Caller has supplied the message and all required data about its sender */
	     local_md = mseg_message_info, by name;
	     if rtrim (operation_name) = "mseg_$add_message"
	     then local_md.ms_id = ""b;
	end;

	else do;	/*** Ordinary Add -- Caller has supplied only ms_ptr, ms_len, and ms_access_class */
		local_md.ms_id = ""b;		/* generate one presently */
		local_md.ms_len = mseg_message_info.ms_len;
		local_md.ms_access_class = mseg_message_info.ms_access_class;
		local_md.sender_id = mseg_operation.group_id;
		local_md.sender_process_id = get_process_id_ ();
		local_md.sender_level = mseg_operation.validation_level;
		local_md.sender_authorization = mseg_operation.authorization;
		local_md.sender_max_authorization = mseg_operation.max_authorization;
		if mseg_operation.call_admin_gate
		then local_md.sender_audit = access_audit_r1_$get_audit_flags ();
		else local_md.sender_audit = ""b;
	     end;

	if local_md.ms_id = ""b			/* we must generate a message ID */
	then do;
		now = clock ();			/* ... IDs for now are simply clock readings */
		local_md.ms_id = unspec (now);
	     end;


	/*** Compute the number of blocks needed to hold the message */

	mb_ptr = addr (local_message_block);		/* to allow PL/I to compute block sizes for us */
	md_ptr = addr (local_md);
	message_block_header.data_lth = 0;

	n_blocks_needed = 1				/* ... the first block which includes the descriptor */
	     +
	     divide ((local_md.ms_len - length (first_message_block.pad) + length (other_message_block.pad) - 1),
	     length (other_message_block.pad), 18, 0);

	if n_blocks_needed > mseg_segment.n_blocks_unused
	then do;					/* not enough room in the segment */
		call check_block_map_consistency ();	/* ... be sure the segment's not damanged */
		if mseg_operation.call_admin_gate & ^mseg_operation.suppress_access_checks
		then do;				/* ... audit the covert channel */
			string (local_aef) = ""b;
			local_aef.cc_10_100 = "1"b;
			call access_audit_r1_$log_obj_ptr (operation_name, mseg_operation.validation_level,
			     string (local_aef), access_operations_$mseg_add_message, mseg_ptr,
			     error_table_$notalloc, null (), 0, "Message segment is full.");
		     end;
		call return_from_operation (error_table_$notalloc);
	     end;

	mseg_segment.modification_in_progress = "1"b;	/* a fault now will cause the segment to be salvaged */


	/*** Pre-allocate the blocks for the message and thread them together */

	last_block_allocated = 0;

	do block_no = 1 to n_blocks_needed;

	     begin;
dcl	rest_of_block_map	bit (mseg_segment.n_blocks_allocated - last_block_allocated) unaligned
			defined (mseg_segment.block_map.map) position (last_block_allocated + 1);
		block_id = index (rest_of_block_map, "0"b);
		if block_id = 0			/* ... not as many free blocks as the header claimed */
		then call salvage_and_return (mseg_format_errors_$inconsistent_block_map);
		block_id, last_block_allocated = block_id + last_block_allocated;
	     end;

	     substr (mseg_segment.block_map.map, block_id, 1) = "1"b;
	     mb_ptr = setwordno (mseg_ptr, mseg_segment.block_size * (block_id - 1));

	     if block_no = 1
	     then do;				/* first block of the message */
		     first_mb_ptr = mb_ptr;
		     message_block_header.descriptor_present = "1"b;
		     md_ptr = addr (first_message_block.descriptor);
		end;
	     else prev_mb_ptr -> message_block_header.next_block = wordno (mb_ptr);

	     prev_mb_ptr = mb_ptr;
	end;

	message_block_header.next_block = 0;		/* indicate end of chain for the last block */


	/*** Fill in the real message descriptor in the first block */

	message_descriptor = local_md;		/* copy info we've already gathered */

	message_descriptor.sentinel = MESSAGE_DESCRIPTOR_SENTINEL;

	message_descriptor.message_chain.next_message = 0;/* this will be the last message in the segment */
	message_descriptor.message_chain.prev_message = mseg_segment.message_chain.last_message;

	hash_idx = fixed (substr (local_md.ms_id, 64, 9), 9, 0);
	message_descriptor.prev_message_in_hash_chain = mseg_segment.hash_table.last_message (hash_idx);


	/*** Copy the user's message into the segment */

	n_bits_remaining = mseg_message_info.ms_len;	/* haven't copied anything yet */
	n_bits_copied = 0;

	mb_ptr = first_mb_ptr;

	do block_no = 1 to n_blocks_needed;

	     message_block_header.data_lth = 0;		/* allows PL/I to compute # of bits available in the block */
	     if block_no = 1
	     then n_bits_to_copy = min (n_bits_remaining, length (first_message_block.pad));
	     else n_bits_to_copy = min (n_bits_remaining, length (other_message_block.pad));

	     message_block_header.data_lth = n_bits_to_copy;
	     if n_bits_to_copy > 0			/* there's something to put in this block */
	     then begin;
dcl	source_bits	bit (n_bits_to_copy) unaligned defined (mseg_message_bits.data)
			position (n_bits_copied + 1);
		     if block_no = 1
		     then first_message_block.data = source_bits;
		     else other_message_block.data = source_bits;
		     n_bits_remaining = n_bits_remaining - n_bits_to_copy;
		     n_bits_copied = n_bits_copied + n_bits_to_copy;
		end;

	     mb_ptr = setwordno (mseg_ptr, message_block_header.next_block);
	end;


	/*** Thread the message into the appropriate chains */

	if mseg_segment.n_messages = 0		/* it's the first message */
	then mseg_segment.message_chain.first_message = wordno (first_mb_ptr);
	else do;					/* it's not the first message */
		call set_message_ptrs (mseg_segment.message_chain.last_message, prev_mb_ptr, prev_md_ptr);
		prev_md_ptr -> message_descriptor.message_chain.next_message = wordno (first_mb_ptr);
	     end;

	mseg_segment.message_chain.last_message = wordno (first_mb_ptr);
	mseg_segment.hash_table.last_message (hash_idx) = wordno (first_mb_ptr);

	mseg_segment.n_blocks_unused = mseg_segment.n_blocks_unused - n_blocks_needed;

	mseg_segment.n_messages = mseg_segment.n_messages + 1;

	mseg_segment.modification_in_progress = "0"b;	/* all done */

	if mseg_message_info.ms_id = ""b
	then mseg_message_info.ms_id = local_md.ms_id;	/* return the message ID to our caller */

	call return_from_operation (0);
%page;
/* Add a message on behalf of another message primitive operation -- This entrypoint is identical to add_message, above,
   except that it does not invoke mseg_utils_$begin_operation. */

mseg_message_$add_message_for_mseg:
     entry (P_mseg_operation_ptr, P_operation_name, P_code);

	call setup_operation ();			/* for cleanup handler */
	operation_started_locally = "0"b;

	on cleanup call operation_was_aborted ();

	mseg_operation_ptr = P_mseg_operation_ptr;
	operation_name = P_operation_name;

	mseg_ptr = mseg_operation.mseg_ptr;

	go to ADD_MESSAGE;
%page;
/* Count the accessible messages */

mseg_message_$count_messages:
     entry (P_mseg_operation_ptr, P_ms_count, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$count_messages);
	if rqo_detected
	then do;					/* couldn't even lock the segment: it must be empty */
		P_ms_count = 0;
		call return_from_operation (0);
	     end;
	else if code ^= 0
	then call return_from_operation (code);

	if mseg_segment.n_messages = 0
	then P_ms_count = 0;			/* the segment is empty */

	else if mseg_operation.suppress_access_checks
	then P_ms_count = mseg_segment.n_messages;	/* the caller doesn't want us to worry about access */

	else if ring1_privilege ()
	     | read_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.access_class)
	then P_ms_count = mseg_segment.n_messages;	/* the user has access to see everything in the segment */

	else do;					/* we have to count the messages */
		do_owner_check = "0"b;		/* ... we must have "s" so we don't need to check owner */
		P_ms_count = 0;
		do message_offset = mseg_segment.message_chain.first_message
		     repeat (message_descriptor.message_chain.next_message) while (message_offset ^= 0);
		     call set_message_ptrs (message_offset, mb_ptr, md_ptr);
		     if is_accessible_message ()
		     then P_ms_count = P_ms_count + 1;
		end;
	     end;

	call return_from_operation (0);
%page;
/* Delete a message */

mseg_message_$delete_message:
     entry (P_mseg_operation_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$delete_message);
	if rqo_detected
	then call return_from_operation (error_table_$no_message);
	else if code ^= 0
	then call return_from_operation (code);

	if mseg_segment.n_messages = 0		/* can't delete if there's nothing there */
	then call return_from_operation (error_table_$no_message);

	mseg_message_info_ptr = addr (mseg_operation.message_info);

	call find_message (mseg_message_info.ms_id);
	if mb_ptr = null ()				/* the given ID doesn't identify a real message */
	then call return_from_operation (error_table_$no_message);

	mseg_operation.md_ptr_valid = "1"b;
	mseg_operation.md_ptr = md_ptr;
	call mseg_check_access_$message (mseg_operation_ptr, code);
	if code ^= 0				/* the message can't be deleted */
	then call return_from_operation (code);

	local_md = message_descriptor;		/* will need these later to unthread the message */
	message_offset = wordno (mb_ptr);

	mseg_segment.modification_in_progress = "1"b;	/* a fault now will cause the segment to be salvaged */

	call process_message (mb_ptr, "0"b, "0"b, "1"b);	/* does most of the dirty work */

	call unchain_message ();			/* remove it from the various chains */

	mseg_segment.modification_in_progress = "0"b;	/* all done */

	call return_from_operation (0);
%page;
/* Read (and optionally delete) a message */

mseg_message_$read_message:
     entry (P_mseg_operation_ptr, P_users_area_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	if P_users_area_ptr ^= null ()		/* the user must supply an area */
	then users_area_ptr = P_users_area_ptr;
	else call return_from_operation (error_table_$bad_subr_arg);

	call begin_operation (mseg_operations_$read_message);
	if rqo_detected
	then call return_from_operation (error_table_$no_message);
	else if code ^= 0
	then call return_from_operation (code);

READ_MESSAGE:
	if mseg_segment.n_messages = 0		/* can't read something if there's nothing there */
	then call return_from_operation (error_table_$no_message);

	mseg_message_info_ptr = addr (mseg_operation.message_info);
	if mseg_message_info.version ^= MSEG_MESSAGE_INFO_V1
	then call return_from_operation (error_table_$unimplemented_version);

	do_owner_check = mseg_operation.only_own_access | mseg_message_info.own;


	/*** Find the desired message and check the user's access to same */

	if mseg_message_info.message_code = MSEG_READ_SPECIFIED
	then call find_message (mseg_message_info.ms_id);

	else if mseg_message_info.message_code = MSEG_READ_FIRST
	then do;
		call set_message_ptrs (mseg_segment.message_chain.first_message, mb_ptr, md_ptr);
		call find_next_accessible_message ((72)"0"b);
	     end;

	else if mseg_message_info.message_code = MSEG_READ_LAST
	then do;
		call set_message_ptrs (mseg_segment.message_chain.last_message, mb_ptr, md_ptr);
		call find_previous_accessible_message ((72)"1"b);
	     end;

	else if mseg_message_info.message_code = MSEG_READ_BEFORE_SPECIFIED
	then do;
		call find_message (mseg_message_info.ms_id);
		if mb_ptr = null ()
		then do;				/* given ID doesn't exist: search the entire backward chain */
			call set_message_ptrs (mseg_segment.message_chain.last_message, mb_ptr, md_ptr);
			call find_previous_accessible_message (mseg_message_info.ms_id);
		     end;
		else if message_descriptor.message_chain.prev_message ^= 0
		then do;				/* it exists: search from its previous message */
			call set_message_ptrs (message_descriptor.message_chain.prev_message, mb_ptr, md_ptr);
			call find_previous_accessible_message (mseg_message_info.ms_id);
		     end;
		else call return_from_operation (error_table_$no_message);
	     end;

	else if mseg_message_info.message_code = MSEG_READ_AFTER_SPECIFIED
	then do;
		call find_message (mseg_message_info.ms_id);
		if mb_ptr = null ()
		then do;				/* given ID doesn't exist: search the entire forward chain */
			call set_message_ptrs (mseg_segment.message_chain.first_message, mb_ptr, md_ptr);
			call find_next_accessible_message (mseg_message_info.ms_id);
		     end;
		else if message_descriptor.message_chain.next_message ^= 0
		then do;				/* it exists: search from its next message */
			call set_message_ptrs (message_descriptor.message_chain.next_message, mb_ptr, md_ptr);
			call find_next_accessible_message (mseg_message_info.ms_id);
		     end;
		else call return_from_operation (error_table_$no_message);
	     end;

	else call return_from_operation (error_table_$bad_subr_arg);

	if mb_ptr = null ()				/* didn't find a message to read */
	then call return_from_operation (error_table_$no_message);

	mseg_operation.md_ptr_valid = "1"b;
	mseg_operation.md_ptr = md_ptr;
	call mseg_check_access_$message (mseg_operation_ptr, code);
	if code ^= 0				/* insufficient access to read the message */
	then call return_from_operation (code);


	/*** Allocate space in the user's storage for the message and copy it from the segment */

	mseg_message_info.ms_ptr = null ();		/* for cleanup handler */
	operation_specific_abort = abort_read_operation;
	operation_specific_return = return_from_read_operation;

	mseg_message_info.ms_len = message_descriptor.ms_len;

	on area
	     begin;
		code = error_table_$noalloc;
		go to RETURN_FROM_READ_OPERATION;	/* avoids making return_from_operation non-quick */
	     end;

	allocate mseg_message_bits in (users_area) set (mseg_message_info.ms_ptr);


	/*** We can now copy the relevant data directly from the message descriptor
	     into our caller's mseg_message_info structure.  However, we must not reveal the sender's audit flags unless
	     the caller could obtain them itself (via access_audit_r1_$get_audit_flags) or the process has ring-1
	     privilege.  Otherwise, if we always returned the sender's audit flags, a user could determine his audit
	     flags by adding and then reading a message from any message segment.  (A user isn't allowed to know his
	     audit flags to prevent him from only trying certain "incorrect" acts when he knows he won't be audited.) */

	mseg_message_info = message_descriptor, by name;

	if operation_started_locally			/* never censor if read was initiated directly by mseg_ */
	then if ^(ring1_privilege () | (mseg_operation.caller.validation_level = mseg_data_$admin_ring))
	     then mseg_message_info.sender_audit = ""b;


	/*** Copy the message from the segment and, if requested, delete it */

	local_md = message_descriptor;

	if mseg_message_info.delete
	then do;					/* stash data that will be needed later to finish deletion */
		message_offset = wordno (mb_ptr);
		mseg_segment.modification_in_progress = "1"b;
	     end;

	call process_message (mb_ptr, "1"b, "0"b, (mseg_message_info.delete));
						/* does most of the dirty work */

	if mseg_message_info.delete
	then do;
		call unchain_message ();
		mseg_segment.modification_in_progress = "0"b;
	     end;

	code = 0;					/* success */


RETURN_FROM_READ_OPERATION:
	call return_from_operation (code);



/* Special processing required upon completion of a read operation */

return_from_read_operation:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	if p_code ^= 0				/* the read failed ... */
	then if mseg_message_info.ms_ptr ^= null ()	/* ... so we must eliminate whatever we did manage to read */
	     then do;
		     free mseg_message_bits in (users_area);
		     mseg_message_info.ms_ptr = null ();
		end;

	return;

     end return_from_read_operation;



/* Special processing required upon abnormal termination of a read operation */

abort_read_operation:
     procedure ();

	if mseg_message_info.ms_ptr ^= null ()
	then do;
		free mseg_message_bits in (users_area);
		mseg_message_info.ms_ptr = null ();
	     end;

	return;

     end abort_read_operation;
%page;
/* Read (and optionally delete) a message on behalf of another message primitive operation -- This entrypoint is identical
   to read_message, above, except that it does not invoke mseg_utils_$begin_operation. */

mseg_message_$read_message_for_mseg:
     entry (P_mseg_operation_ptr, P_operation_name, P_users_area_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	operation_started_locally = "0"b;

	on cleanup call operation_was_aborted ();

	mseg_operation_ptr = P_mseg_operation_ptr;
	operation_name = P_operation_name;
	users_area_ptr = P_users_area_ptr;		/* guaranteed non-null by our caller */

	mseg_ptr = mseg_operation.mseg_ptr;

	go to READ_MESSAGE;
%page;
/* Update a message -- The data stored in the message are replaced by the data supplied by the caller.  If the caller
   provides less data than are presently in the message, this operation will only replace the first part of the data and
   leave the remaining data intact.  Thus, this operation can be used to update the application header in a message
   without actually having to first read the message from the segment. */

mseg_message_$update_message:
     entry (P_mseg_operation_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$update_message);
	if rqo_detected
	then call return_from_operation (error_table_$no_message);
	else if code ^= 0
	then call return_from_operation (code);

	if mseg_segment.n_messages = 0		/* can't update if there's nothing there */
	then call return_from_operation (error_table_$no_message);

	mseg_message_info_ptr = addr (mseg_operation.message_info);

	call find_message (mseg_message_info.ms_id);
	if mb_ptr = null ()				/* the given ID doesn't identify a real message */
	then call return_from_operation (error_table_$no_message);

	mseg_operation.md_ptr_valid = "1"b;
	mseg_operation.md_ptr = md_ptr;
	call mseg_check_access_$message (mseg_operation_ptr, code);
	if code ^= 0				/* the message can't be updated */
	then call return_from_operation (code);

	if mseg_message_info.ms_len > message_descriptor.ms_len
	then call return_from_operation (error_table_$bigarg);

	local_md = message_descriptor;

	call process_message (mb_ptr, "0"b, "1"b, "0"b);	/* does the real dirty work */

	call return_from_operation (0);
%page;
/* Common initialization for all operations */

setup_operation:
     procedure ();

	code = 0;

	operation_specific_abort = nulle;		/* nothing special when we abort or return (yet) */
	operation_specific_return = nulle;

	mseg_operation_ptr = null ();

	operation_started_locally = "1"b;		/* abort/return must invoke mseg_utils_ */

	return;

     end setup_operation;



/* Begin the operation -- This procedure isn't part of setup_operation so that we can be certain to have a cleanup handler
   available at all times that the message segment may be in use. */

begin_operation:
     procedure (p_mseg_operation_id);

dcl	p_mseg_operation_id bit (36) aligned parameter;

	mseg_operation_ptr = P_mseg_operation_ptr;

	call mseg_utils_$begin_operation (p_mseg_operation_id, mseg_operation_ptr, operation_name, mseg_dir_name,
	     mseg_entryname, mseg_ptr, rqo_detected, code);

	return;

     end begin_operation;



/* The "null" entry which indicates that there's no special abort/return processing for an operation */

nulle:
     procedure ();

	return;

     end nulle;
%page;
/* Return after completion of an operation */

return_from_operation:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	if operation_specific_return ^= nulle		/* let the operation do anything special */
	then call operation_specific_return (p_code);

	if operation_started_locally & (mseg_operation_ptr ^= null ())
	then call mseg_utils_$finish_operation (mseg_operation_ptr);
						/* may be invoked before we've called begin_operation */

	P_code = p_code;				/* set our caller's status code */
	go to RETURN_FROM_OPERATION;

     end return_from_operation;

RETURN_FROM_OPERATION:
	return;



/* Abort an operation */

operation_was_aborted:
     procedure ();

	if operation_specific_abort ^= nulle		/* let the operation do anything special */
	then call operation_specific_abort ();

	if operation_started_locally
	then call mseg_utils_$abort_operation (mseg_operation_ptr);

	return;

     end operation_was_aborted;



/* Salvage the message segment due to internal inconsistencies and return error_table_$bad_segment to our caller */

salvage_and_return:
     procedure (p_format_error);

dcl	p_format_error	fixed binary (35) parameter;

	call mseg_utils_$salvage_for_cause (mseg_operation_ptr, p_format_error);

	call return_from_operation (error_table_$bad_segment);

     end salvage_and_return;
%page;
/* Set the supplied message block and descriptor pointers from the given offset */

set_message_ptrs:
     procedure (p_message_offset, p_mb_ptr, p_md_ptr);

dcl	p_message_offset	fixed binary (18) unaligned unsigned parameter;
dcl	(p_mb_ptr, p_md_ptr)
			pointer parameter;
dcl	block_id		fixed binary (18);

	if (p_message_offset
	     <= (wordno (addr (mseg_segment.block_map)) + divide (mseg_segment.n_blocks_allocated + 35, 36, 18, 0)))
	     | (p_message_offset > (mseg_segment.block_size * (mseg_segment.n_blocks_allocated - 1)))
	then call salvage_and_return (mseg_format_errors_$invalid_message_block_offset);

	if mod (p_message_offset, mseg_segment.block_size) ^= 0
	then call salvage_and_return (mseg_format_errors_$invalid_message_block_offset);

	block_id = divide (p_message_offset, mseg_segment.block_size, 18, 0) + 1;
	if substr (mseg_segment.block_map.map, block_id, 1) = "0"b
	then call salvage_and_return (mseg_format_errors_$unused_block_in_message);

	p_mb_ptr = setwordno (mseg_ptr, p_message_offset);

	if p_mb_ptr -> message_block_header.descriptor_present
	then do;
		begin;
dcl	saved_mb_ptr	bit (72) aligned;
		     /*** The following code fragment is a replacement for the statement
			     p_md_ptr = addr (p_mb_ptr -> first_message_block_descriptor);
			That statement will not work as PL/I must reference through mb_ptr in order to compute the
			size of first_message_block.data_space.pad.  Additionally, we can't use normal assignment
			statements to save/restore the value of mb_ptr as it is sometimes legimately unitialized
			when this procedure is invoked. */
		     unspec (saved_mb_ptr) = unspec (mb_ptr);
		     mb_ptr = p_mb_ptr;
		     p_md_ptr = addr (first_message_block.descriptor);
		     unspec (mb_ptr) = unspec (saved_mb_ptr);
		end;
		if p_md_ptr -> message_descriptor.sentinel ^= MESSAGE_DESCRIPTOR_SENTINEL
		then call salvage_and_return (mseg_format_errors_$bad_descriptor_sentinel);
	     end;

	else call salvage_and_return (mseg_format_errors_$no_descriptor_in_first_block);

	return;					/* executed iff the message looks OK so far */

     end set_message_ptrs;
%page;
/* Determine if the user has ring1 privilege */

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

	return ((mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b);

     end ring1_privilege;



/* Determine if the current message (mb_ptr, md_ptr) is accessible to (i.e., readable by) the user */

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

	if do_owner_check				/* we have to checks that it's our message */
	then if owner_doesnt_match ()
	     then return ("0"b);			/* ... and it isn't */

	if mseg_operation.suppress_access_checks
	then return ("1"b);				/* our caller doesn't want us to worry about AIM, etc. */

	return (ring1_privilege ()
	     | read_allowed_ (mseg_operation.caller.authorization, message_descriptor.ms_access_class));



/* Determine if the user doesn't own this message */

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

declare	name		character (32) varying;
declare	message_name	character (32) varying;

	name = before (mseg_operation.caller.group_id, ".");
	message_name = before (message_descriptor.sender_id, ".");

	if (name ^= "anonymous") & (message_name ^= "anonymous")
	then /*** The user isn't anonymous and the message wasn't written by an anonymous user.  We can simply test the
		Person_ids to see if the user owns this message. */
	     return (name ^= message_name);

	else if (name = "anonymous") & (message_name = "anonymous")
	then do;	/*** The user is an anonymous user and the message was written by an anonymous user.  We must test the
		     Project_ids to see if the user owns this message. */
		name = before (after (mseg_operation.caller.group_id, "."), ".");
		message_name = before (after (message_descriptor.sender_id, "."), ".");
		return (name ^= message_name);
	     end;

	else /*** Either the user is an anonymous user and the message wsn't written by one or vice-versa.  By
		definition, the user can not possibly own this message. */
	     return ("1"b);

     end owner_doesnt_match;

     end is_accessible_message;
%page;
/* Search the message hash table with the given message ID */

find_message:
     procedure (p_ms_id);

dcl	p_ms_id		bit (72) aligned parameter;
dcl	message_offset	fixed binary (18) unaligned unsigned;
dcl	n_messages_checked	fixed binary (18);

	hash_idx = fixed (substr (p_ms_id, 64, 9), 9, 0);

	next_message_in_hash_chain = null ();		/* hash chain isn't doubly linked (sigh) */
	n_messages_checked = 0;

	do message_offset = mseg_segment.hash_table.last_message (hash_idx)
	     repeat (message_descriptor.prev_message_in_hash_chain) while (message_offset ^= 0);

	     call set_message_ptrs (message_offset, mb_ptr, md_ptr);

	     if message_descriptor.ms_id = p_ms_id	/* found it! */
	     then return;
	     else next_message_in_hash_chain = md_ptr;

	     n_messages_checked = n_messages_checked + 1;
	     if n_messages_checked > mseg_segment.n_messages
	     then call salvage_and_return (mseg_format_errors_$circular_hash_chain);
	end;


	/*** Control arrives here iff the given ID isn't in the hash table */

	mb_ptr, md_ptr = null ();

	return;

     end find_message;
%page;
/* Find the first accessible message in the specified direction along the chronological message chain whose message ID is
   greater than (if forward) or less than (if backward) the specified value.  If the current message (mb_ptr, md_ptr)
   satisfies the criteria, it is selected. */

find_accessible_message:
     procedure (p_ms_id_key);
	return;					/* not used */

dcl	p_ms_id_key	bit (72) aligned parameter;

dcl	(hash_mb_ptr, hash_md_ptr)
			pointer;
dcl	(scan_forward, scan_backward)
			bit (1) aligned;
dcl	message_offset	fixed binary (18) unaligned unsigned;
dcl	n_messages_checked	fixed binary (18);


find_next_accessible_message:				/* ... using the forward chain and ID > KEY */
     entry (p_ms_id_key);

	scan_forward = "1"b;
	scan_backward = "0"b;
	go to FIND_THE_MESSAGE;


find_previous_accessible_message:			/* ... using the backward chain and ID < KEY */
     entry (p_ms_id_key);

	scan_backward = "1"b;
	scan_forward = "0"b;
	go to FIND_THE_MESSAGE;


FIND_THE_MESSAGE:
	n_messages_checked = 0;

	do while (mb_ptr ^= null ());

	     if is_accessible_message ()		/* the user can see this message */
	     then if scan_forward
		then if message_descriptor.ms_id > p_ms_id_key
		     then go to FOUND_THE_MESSAGE;
		     else ;
		else if scan_backward
		then if message_descriptor.ms_id < p_ms_id_key
		     then go to FOUND_THE_MESSAGE;
		     else ;

	     n_messages_checked = n_messages_checked + 1;
	     if n_messages_checked > mseg_segment.n_messages
	     then call salvage_and_return (mseg_format_errors_$circular_message_chain);

	     if scan_forward
	     then message_offset = message_descriptor.message_chain.next_message;
	     else message_offset = message_descriptor.message_chain.prev_message;

	     if message_offset ^= 0			/* there are more candidates */
	     then call set_message_ptrs (message_offset, mb_ptr, md_ptr);
	     else mb_ptr = null ();
	end;


	/*** Control arrives here iff an appropriate message is not found */

	md_ptr = null ();				/* be sure both message pointers are null */
	return;


	/*** Control arrives here when an appropriate message has been found.  If we are going to delete the message, we
	     must find its successor in its hash chain so we can later relink said chain.  This is necessary as the hash
	     chains are not doubly linked.  (In version 6 message segments, we will doubly link the hash chain). */

FOUND_THE_MESSAGE:
	if mseg_message_info.delete
	then do;
		hash_idx = fixed (substr (message_descriptor.ms_id, 64, 9), 9, 0);
		next_message_in_hash_chain = null ();
		n_messages_checked = 0;

		do message_offset = mseg_segment.hash_table.last_message (hash_idx)
		     repeat (hash_md_ptr -> message_descriptor.prev_message_in_hash_chain)
		     while (message_offset ^= 0);
		     call set_message_ptrs (message_offset, hash_mb_ptr, hash_md_ptr);
		     if hash_md_ptr -> message_descriptor.ms_id = message_descriptor.ms_id
		     then return;			/* found it: next_message_in_hash_chain is now properly set */
		     else next_message_in_hash_chain = hash_md_ptr;
		     n_messages_checked = n_messages_checked + 1;
		     if n_messages_checked > mseg_segment.n_messages
		     then call salvage_and_return (mseg_format_errors_$circular_hash_chain);
		end;

		/*** Control arrives here iff the message doesn't appear in its hash chain which means that the
		     message segment is inconsistent. */
		call salvage_and_return (mseg_format_errors_$inconsistent_hash_chain);
	     end;

	return;

     end find_accessible_message;
%page;
/* Process an already extant message for reading, updating, or deletion -- The major portion of the processing for each of
   these operations consists of walking the chain of blocks which comprise the message and validating that it is a
   properly formed message.  Only a small fraction of the work involves the actual reading, updating, or deleting. */

process_message:
     procedure (p_first_mb_ptr, p_read, p_update, p_delete);

dcl	p_first_mb_ptr	pointer parameter;
dcl	(p_read, p_update, p_delete)
			bit (1) aligned parameter;

dcl	next_mb_ptr	pointer;
dcl	first_block	bit (1) aligned;
dcl	(actual_ms_len, n_bits_remaining, n_bits_copied, n_bits_to_copy)
			fixed binary (24);
dcl	(n_actual_blocks, block_id)
			fixed binary (18);

	actual_ms_len = 0;				/* check actual length and # of blocks for inconsistencies */
	n_actual_blocks = 0;

	n_bits_copied = 0;
	if p_update
	then n_bits_remaining = mseg_message_info.ms_len;

	first_block = "1"b;				/* we are called with the first block in the message */

	do mb_ptr = p_first_mb_ptr repeat (next_mb_ptr) while (mb_ptr ^= null ());

	     block_id = divide (wordno (mb_ptr), mseg_segment.block_size, 18, 0) + 1;
	     if substr (mseg_segment.block_map.map, block_id, 1) = "0"b
	     then call salvage_and_return (mseg_format_errors_$unused_block_in_message);

	     actual_ms_len = actual_ms_len + message_block_header.data_lth;
	     if actual_ms_len > local_md.ms_len		/* check that the message length is OK */
	     then call salvage_and_return (mseg_format_errors_$inconsistent_message_length);

	     n_actual_blocks = n_actual_blocks + 1;	/* check that the block chain is OK */
	     if n_actual_blocks > mseg_segment.n_blocks_allocated
	     then call salvage_and_return (mseg_format_errors_$circular_message_blocks);

	     if message_block_header.next_block = 0	/* find the next block now as deleting will zero the header */
	     then next_mb_ptr = null ();
	     else next_mb_ptr = setwordno (mseg_ptr, message_block_header.next_block);

	     if ^first_block			/* only the first block should have a descriptor */
	     then if message_block_header.descriptor_present
		then call salvage_and_return (mseg_format_errors_$descriptor_in_other_block);

	     if p_read
	     then do;  /*** Copy the message from the segment to the storage previously allocated in the user's area */
		     n_bits_to_copy = message_block_header.data_lth;
		     if n_bits_to_copy > 0
		     then begin;			/* if there's something to get from this block */
dcl	target_bits	bit (n_bits_to_copy) unaligned defined (mseg_message_bits.data)
			position (n_bits_copied + 1);
			     if first_block
			     then target_bits = first_message_block.data;
			     else target_bits = other_message_block.data;
			     n_bits_copied = n_bits_copied + n_bits_to_copy;
			end;
		end;

	     else if p_update
	     then do;  /*** Copy the updated portion of the message from the user's storage */
		     n_bits_to_copy = min (n_bits_remaining, message_block_header.data_lth);
		     if n_bits_to_copy > 0		/* there's something to put into this block */
		     then begin;
dcl	source_bits	bit (n_bits_to_copy) unaligned defined (mseg_message_bits.data)
			position (n_bits_copied + 1);
dcl	target_bits	bit (n_bits_to_copy) unaligned defined (other_message_block.data) position (1);
			     target_bits = source_bits;
			     n_bits_remaining = n_bits_remaining - n_bits_to_copy;
			     n_bits_copied = n_bits_copied + n_bits_to_copy;
			end;
		end;

	     if p_delete
	     then do;  /*** Delete this block */
		     substr (mseg_segment.block_map.map, block_id, 1) = "0"b;
		     if first_block
		     then unspec (first_message_block) = ""b;
		     else unspec (other_message_block) = ""b;
		     mseg_segment.n_blocks_unused = mseg_segment.n_blocks_unused + 1;
		end;

	     first_block = "0"b;
	end;

	if actual_ms_len < local_md.ms_len		/* the descriptor says it should be longer */
	then call salvage_and_return (mseg_format_errors_$inconsistent_message_length);

	return;

     end process_message;
%page;
/* Remove the now-deleted message that was located at message_offset and whose descriptor is in local_md from the various
   message chains in the segment */

unchain_message:
     procedure ();

	if local_md.message_chain.prev_message = 0
	then do;					/* it was the first message in the segment */
		if mseg_segment.message_chain.first_message ^= message_offset
		then call salvage_and_return (mseg_format_errors_$inconsistent_forward_chain);
		mseg_segment.message_chain.first_message = local_md.message_chain.next_message;
	     end;
	else do;					/* it wasn't first */
		call set_message_ptrs (local_md.message_chain.prev_message, prev_mb_ptr, prev_md_ptr);
		if prev_md_ptr -> message_descriptor.message_chain.next_message ^= message_offset
		then call salvage_and_return (mseg_format_errors_$inconsistent_forward_chain);
		prev_md_ptr -> message_descriptor.message_chain.next_message = local_md.message_chain.next_message;
	     end;

	if local_md.message_chain.next_message = 0
	then do;					/* it was the last message in the segment */
		if mseg_segment.message_chain.last_message ^= message_offset
		then call salvage_and_return (mseg_format_errors_$inconsistent_backward_chain);
		mseg_segment.message_chain.last_message = local_md.message_chain.prev_message;
	     end;
	else do;					/* it wasn't last */
		call set_message_ptrs (local_md.message_chain.next_message, next_mb_ptr, next_md_ptr);
		if next_md_ptr -> message_descriptor.message_chain.prev_message ^= message_offset
		then call salvage_and_return (mseg_format_errors_$inconsistent_backward_chain);
		next_md_ptr -> message_descriptor.message_chain.prev_message = local_md.message_chain.prev_message;
	     end;

	if next_message_in_hash_chain = null ()
	then do;					/* it was the last message in its hash chain */
		if mseg_segment.hash_table.last_message (hash_idx) ^= message_offset
		then call salvage_and_return (mseg_format_errors_$inconsistent_hash_chain);
		mseg_segment.hash_table.last_message (hash_idx) = local_md.prev_message_in_hash_chain;
	     end;
	else do;					/* it wasn't last */
		if next_message_in_hash_chain -> message_descriptor.prev_message_in_hash_chain ^= message_offset
		then call salvage_and_return (mseg_format_errors_$inconsistent_hash_chain);
		next_message_in_hash_chain -> message_descriptor.prev_message_in_hash_chain =
		     local_md.prev_message_in_hash_chain;
	     end;

	mseg_segment.n_messages = mseg_segment.n_messages - 1;

	return;

     end unchain_message;
%page;
/* Check that the block map and unused block count are consistent */

check_block_map_consistency:
     procedure ();

dcl	(actual_n_blocks_unused, last_block_checked, next_unused_block, next_used_block)
			fixed binary (18);

	actual_n_blocks_unused = 0;
	last_block_checked = 0;

	do while (last_block_checked < mseg_segment.n_blocks_allocated);

	     begin;				/* find the next unused block (if any) */
dcl	rest_of_block_map	bit (mseg_segment.n_blocks_allocated - last_block_checked) unaligned
			defined (mseg_segment.block_map.map) position (last_block_checked + 1);
		next_unused_block = index (rest_of_block_map, "0"b);
	     end;

	     if next_unused_block = 0			/* all the remaining blocks are in use */
	     then last_block_checked = mseg_segment.n_blocks_allocated;

	     else do;				/* at least one more unused block */
		     last_block_checked = last_block_checked + next_unused_block - 1;
		     begin;			/* find the first used block after this unused block */
dcl	rest_of_block_map	bit (mseg_segment.n_blocks_allocated - last_block_checked) unaligned
			defined (mseg_segment.block_map.map) position (last_block_checked + 1);
			next_used_block = index (rest_of_block_map, "1"b);
			if next_used_block = 0	/* ... the rest of the blocks are unused */
			then next_used_block = length (rest_of_block_map) + 1;
		     end;
		     actual_n_blocks_unused = actual_n_blocks_unused + next_used_block - 1;
		     last_block_checked = last_block_checked + next_used_block - 1;
		end;
	end;

	if actual_n_blocks_unused ^= mseg_segment.n_blocks_unused
	then call salvage_and_return (mseg_format_errors_$inconsistent_block_map);

	return;

     end check_block_map_consistency;

/* format: off */
%page; %include mseg_data_;
%page; %include mseg_segment;
%page; %include mseg_wakeup_state;
%page; %include mseg_message;
%page; %include mseg_operation;
%page; %include mseg_message_info;
%page; %include entry_access_info;
%page; %include mseg_operations_;
%page; %include mseg_format_errors_;
%page; %include access_audit_eventflags;
%page;

/* BEGIN MESSAGE DOCUMENTATION


   Message:
   Audit (mseg_$add_message): DENIED addition of a message to a message segment
	ADDED_INFO <Message segment is full.>

   S:	$access_audit

   T:	$run

   M:	A message was not added to a mailbox or message segment because
	there is not enough room for the message in the segment.  Repeated
	occurences of this event over a short period of time could indicate
	an attempt to exploit a moderate bandwidth covert channel.
	ADDED_INFO will identify the user and segment in question.

   A:	$notify_ssa


   END MESSAGE DOCUMENTATION */

/* format: on */

     end mseg_message_;




		    mseg_operations_.cds            05/10/85  0907.4r w 05/06/85  1617.7       73431



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

/* Definition of the message segment primitive operations (mseg_) */

/* Created:  April 1985 by G. Palter */

/* format: style3,linecom */

mseg_operations_:
     procedure () options (variable);


declare	1 mops		aligned,
	  2 (add_acl_entries_seg, add_message, chname_seg, close_seg, compact_seg, copy_seg_source, copy_seg_target,
	       count_messages, create_seg, delete_acl_entries_seg, delete_message, delete_seg, get_salvaged_flag_seg,
	       get_wakeup_state_seg, initiate_seg, list_acl_seg, list_acl_entries_seg, open_seg, read_message,
	       replace_acl_seg, reset_salvaged_flag_seg, reset_wakeup_state_seg, set_max_length_seg,
	       set_safety_switch_seg, set_wakeup_state_seg, update_message)
			bit (36) aligned,
	  2 names		(26) character (64) varying;


dcl	1 cds_data	aligned like cds_args;

dcl	code		fixed binary (35);
dcl	last_operation_id	fixed binary (9);

dcl	MSEG_OPERATIONS_	character (32) static options (constant) initial ("mseg_operations_");

dcl	error_table_$bigarg fixed binary (35) external;
dcl	error_table_$out_of_bounds
			fixed binary (35) external;

dcl	com_err_		entry () options (variable);
dcl	create_data_segment_
			entry (pointer, fixed binary (35));

dcl	(addr, currentsize, hbound, length, maxlength, null, string)
			builtin;
%page;
/* Define the mseg_operations_$OPERATION and mseg_operations_$names constants */

	last_operation_id = 0;

	call operation (mops.add_acl_entries_seg, "mseg_$add_acl_entries_seg", MSEG_REQUIRED_FOR_FS_INTERFACE,
	     MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.add_message, "mseg_$add_message", MSEG_REQUIRED_FOR_MESSAGE,
	     MSEG_BEGIN_FOR_MESSAGE | MSEG_INITIALIZE_HEADER, MSEG_FINISH_FOR_MESSAGE);

	call operation (mops.chname_seg, "mseg_$chname_seg", MSEG_REQUIRE_PATHNAME | MSEG_REQUIRE_MSEG_PTR,
	     MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.close_seg, "mseg_$close_seg", MSEG_REQUIRE_MSEG_PTR | MSEG_REQUIRE_MSEG_INDEX,
	     MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.compact_seg, "mseg_$compact_seg", MSEG_REQUIRED_FOR_SEGMENT, MSEG_BEGIN_FOR_MESSAGE,
	     MSEG_FINISH_FOR_MESSAGE);		/* compaction requires working with the individual messages */

	call operation (mops.copy_seg_source, "mseg_$copy_seg", MSEG_REQUIRED_FOR_SEGMENT, MSEG_BEGIN_FOR_MESSAGE,
	     MSEG_FINISH_FOR_MESSAGE);		/* copying requires working with the individual messages */
	call operation (mops.copy_seg_target, "mseg_$copy_seg", MSEG_REQUIRED_FOR_SEGMENT, MSEG_LOCK_SEGMENT,
	     MSEG_FINISH_FOR_SEGMENT);

	call operation (mops.count_messages, "mseg_$count_messages", MSEG_REQUIRE_MSEG_PTR | MSEG_REQUIRE_ACCESS_INFO,
	     MSEG_BEGIN_FOR_MESSAGE, MSEG_FINISH_FOR_MESSAGE);
						/* there's no individual message for which we'd need info */

	call operation (mops.create_seg, "mseg_$create_seg", MSEG_REQUIRED_FOR_FS_INTERFACE,
	     MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.delete_acl_entries_seg, "mseg_$delete_acl_entries_seg", MSEG_REQUIRED_FOR_FS_INTERFACE,
	     MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.delete_message, "mseg_$delete_message", MSEG_REQUIRED_FOR_MESSAGE, MSEG_BEGIN_FOR_MESSAGE,
	     MSEG_FINISH_FOR_MESSAGE);

	call operation (mops.delete_seg, "mseg_$delete_seg", MSEG_REQUIRE_MSEG_PTR,
	     MSEG_LOCK_SEGMENT | MSEG_DONT_CHECK_LOCK_RESULTS, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.get_salvaged_flag_seg, "mseg_$get_salvaged_flag_seg", MSEG_REQUIRED_FOR_SEGMENT,
	     MSEG_BEGIN_FOR_SEGMENT, MSEG_FINISH_FOR_SEGMENT);

	call operation (mops.get_wakeup_state_seg, "mseg_$get_wakeup_state_seg",
	     MSEG_REQUIRED_FOR_SEGMENT | MSEG_REQUIRE_WAKEUP_STATE_VERSION, MSEG_BEGIN_FOR_SEGMENT,
	     MSEG_FINISH_FOR_SEGMENT);

	call operation (mops.initiate_seg, "mseg_$initiate_seg", MSEG_REQUIRED_FOR_FS_INTERFACE,
	     MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.list_acl_seg, "mseg_$list_acl_seg", MSEG_REQUIRED_FOR_FS_INTERFACE,
	     MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.list_acl_entries_seg, "mseg_$list_acl_entries_seg", MSEG_REQUIRED_FOR_FS_INTERFACE,
	     MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.open_seg, "mseg_$open_seg", MSEG_REQUIRE_MSEG_PTR, MSEG_BEGIN_FOR_FS_INTERFACE,
	     MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.read_message, "mseg_$read_message", MSEG_REQUIRED_FOR_MESSAGE, MSEG_BEGIN_FOR_MESSAGE,
	     MSEG_FINISH_FOR_MESSAGE);

	call operation (mops.replace_acl_seg, "mseg_$replace_acl_seg", MSEG_REQUIRED_FOR_FS_INTERFACE,
	     MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.reset_salvaged_flag_seg, "mseg_$reset_salvaged_flag_seg",
	     MSEG_REQUIRED_FOR_SEGMENT | MSEG_REQUIRE_ACCESS_INFO, MSEG_BEGIN_FOR_SEGMENT, MSEG_FINISH_FOR_SEGMENT);

	call operation (mops.reset_wakeup_state_seg, "mseg_$reset_wakeup_state_seg", MSEG_REQUIRED_FOR_SEGMENT,
	     MSEG_BEGIN_FOR_SEGMENT, MSEG_FINISH_FOR_SEGMENT);

	call operation (mops.set_max_length_seg, "mseg_$set_max_length_seg", MSEG_REQUIRED_FOR_SEGMENT,
	     MSEG_BEGIN_FOR_SEGMENT | MSEG_CHECK_COUNT_CONSISTENCY, MSEG_FINISH_FOR_SEGMENT);

	call operation (mops.set_safety_switch_seg, "mseg_$set_safety_switch_seg",
	     MSEG_REQUIRE_PATHNAME | MSEG_REQUIRE_MSEG_PTR, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE);

	call operation (mops.set_wakeup_state_seg, "mseg_$set_wakeup_state_seg",
	     MSEG_REQUIRED_FOR_SEGMENT | MSEG_REQUIRE_WAKEUP_STATE, MSEG_BEGIN_FOR_SEGMENT, MSEG_FINISH_FOR_SEGMENT);

	call operation (mops.update_message, "mseg_$update_message", MSEG_REQUIRED_FOR_MESSAGE, MSEG_BEGIN_FOR_MESSAGE,
	     MSEG_FINISH_FOR_MESSAGE);


/* Create the data segment */

	cds_data.sections (1).p = addr (mops);
	cds_data.sections (1).len = currentsize (mops);
	cds_data.sections (1).struct_name = "mops";

	cds_data.seg_name = MSEG_OPERATIONS_;
	cds_data.num_exclude_names = 0;
	cds_data.exclude_array_ptr = null ();
	string (cds_data.switches) = ""b;
	cds_data.have_text = "1"b;

	call create_data_segment_ (addr (cds_data), code);
	if code ^= 0
	then call com_err_ (code, MSEG_OPERATIONS_);

RETURN_FROM_MSEG_OPERATIONS_:
	return;
%page;
/* Define a single operation */

operation:
     procedure (p_operation_value, p_operation_name, p_required_for_operation, p_begin_for_operation,
	p_finish_for_operation);

dcl	p_operation_value	bit (36) aligned parameter;
dcl	p_operation_name	character (*) parameter;
dcl	(p_required_for_operation, p_begin_for_operation, p_finish_for_operation)
			bit (9) aligned parameter;

	if last_operation_id >= hbound (mops.names, 1)
	then do;
		call com_err_ (error_table_$out_of_bounds, MSEG_OPERATIONS_,
		     "^/^5xIncrease the dimension of the mops.names array and recompile.");
		go to RETURN_FROM_MSEG_OPERATIONS_;
	     end;

	last_operation_id = last_operation_id + 1;

	mseg_operation_data_ptr = addr (p_operation_value);
	mseg_operation_data.operation_id = last_operation_id;
	string (mseg_operation_data.required_data) = p_required_for_operation;
	string (mseg_operation_data.begin_flags) = p_begin_for_operation;
	string (mseg_operation_data.finish_flags) = p_finish_for_operation;

	if length (p_operation_name) > maxlength (mops.names (last_operation_id))
	then do;
		call com_err_ (error_table_$bigarg, MSEG_OPERATIONS_,
		     "Operation name ""^a"".^/^5xIncrease the maxlength of mops.names and recompile.",
		     p_operation_name);
		go to RETURN_FROM_MSEG_OPERATIONS_;
	     end;

	mops.names (last_operation_id) = p_operation_name;

	return;

     end operation;

/* format: off */
%page; %include mseg_operation_data;
%page; %include cds_args;
/* format: on */

     end mseg_operations_;




		    mseg_segment_.pl1               10/21/92  1059.9rew 10/21/92  1058.8      309996



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1992   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(92-09-03,WAAnderson), approve(92-09-03,MECR0016),
     audit(92-09-17,Vu), install(92-09-24,MR12.5-1017):
     During message segment compaction the message segment gets truncated to a
     length of 0. This action overwrites the lockword held by the calling
     process.  The fix ensures the lockword (which is the first word in the
     segment) does not get set to 0.
  2) change(92-10-02,WAAnderson), approve(92-10-02,MCR8271),
     audit(92-10-13,Vu), install(92-10-21,MR12.5-1032):
     This MCR closes MECR0016.
                                                   END HISTORY COMMENTS */

/* Message segment primitive operations (mseg_) which manipulate the entire message segment as a whole */

/* Created:  April 1985 by G. Palter based upon mseg_ and mseg_compact_ */

/* format: style3,linecom */

mseg_segment_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

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

dcl	P_compaction_ratio	float binary parameter;	/* compact_seg: %'age of waste to cause compaction (I) */

dcl	P_source_mseg_operation_ptr			/* copy_seg: -> description of segment to copy (I) */
			pointer parameter;
dcl	P_target_mseg_operation_ptr			/* copy_seg: -> description of target segment (I) */
			pointer parameter;
dcl	P_error_on_target	bit (1) aligned parameter;	/* copy_seg: set ON => target in error (O) */

dcl	P_salvaged_flag	bit (1) aligned parameter;	/* get_salvage_flag_seg: set ON => segment was salvaged (O) */

dcl	P_max_length	fixed binary (19) parameter;	/* set_max_length_seg: the segment's new max length (I) */


/* Local copies of parameters */

dcl	1 source_mseg_operation
			aligned based (source_mseg_operation_ptr) like mseg_operation;
dcl	source_mseg_operation_ptr
			pointer;

dcl	1 target_mseg_operation
			aligned based (target_mseg_operation_ptr) like mseg_operation;
dcl	target_mseg_operation_ptr
			pointer;

dcl	segment_in_error	fixed binary;
dcl	(
	SOURCE		initial (1),
	TARGET		initial (2)
	)		fixed binary static options (constant);

dcl	code		fixed binary (35);


/* Remaining declartions */

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

dcl	1 target_mseg_segment_header
			aligned based (target_mseg_ptr) like mseg_segment.header;
dcl	target_mseg_ptr	pointer;
dcl	target_mseg_dir_name
			character (168);
dcl	target_mseg_entryname
			character (32);

dcl	source_mseg_ptr	pointer;
dcl	source_mseg_dir_name
			character (168);
dcl	source_mseg_entryname
			character (32);

dcl	source_mseg_message_bits
			bit (source_mseg_operation.ms_len) aligned based (source_mseg_operation.ms_ptr);

dcl	compacted_segment	(compacted_size) bit (36) aligned based;
dcl	compacted_size	fixed binary (19);

dcl	1 local_mseg_segment_header
			aligned like mseg_segment.header;
dcl	initialize_block_map
			bit (1) aligned;

dcl	1 an_operation	aligned like mseg_operation;

dcl	1 local_aef	aligned like audit_event_flags;

dcl	operation_name	character (64);
dcl	operation_specific_return
			entry (fixed binary (35)) variable;
dcl	operation_specific_abort
			entry () variable;

dcl	mseg_dir_name	character (168);
dcl	mseg_entryname	character (32);

dcl	(rqo_detected, salvage_if_errors, free_source_message_bits)
			bit (1) aligned;

dcl	(source_max_length, target_max_length)
			fixed binary (19);
dcl	(n_new_blocks, n_new_header_blocks, n_virgin_blocks, n_used_or_wasted_blocks, n_wasted_blocks)
			fixed binary (18);

dcl       TRUNCATE_ALL_BUT_THE_LOCKWORD fixed bin (19) int static options (constant) init (1); 

dcl	access_operations_$mseg_attr_mod
			bit (36) aligned external;

dcl	(
	error_table_$action_not_performed,
	error_table_$bad_segment,
	error_table_$clnzero,
	error_table_$invalid_max_length,
	error_table_$messages_off,
	error_table_$no_message,
	error_table_$rqover
	)		fixed binary (35) external;

dcl	access_audit_r1_$log_obj_ptr
			entry () options (variable);
dcl	aim_util_$get_access_class
			entry (bit (72) aligned) returns (bit (72) aligned);
dcl	get_process_id_	entry () returns (bit (36));
dcl	get_system_free_area_
			entry () returns (pointer);
dcl	get_temp_segment_	entry (character (*), pointer, fixed binary (35));
dcl	hcs_$get_max_length_seg
			entry (pointer, fixed binary (19), fixed binary (35));
dcl	hcs_$set_max_length_seg
			entry (pointer, fixed binary (19), fixed binary (35));
dcl	hcs_$truncate_seg	entry (pointer, fixed binary (19), fixed binary (35));
dcl	mseg_message_$add_message_for_mseg
			entry (pointer, character (*), fixed binary (35));
dcl	mseg_message_$read_message_for_mseg
			entry (pointer, character (*), pointer, fixed binary (35));
dcl	mseg_utils_$abort_operation
			entry (pointer);
dcl	mseg_utils_$begin_operation
			entry (bit (36) aligned, pointer, character (*), character (*), character (*), pointer,
			bit (1) aligned, fixed binary (35));
dcl	mseg_utils_$finish_operation
			entry (pointer);
dcl	mseg_utils_$salvage_for_cause
			entry (pointer, fixed binary (35)) options (variable);
dcl	release_temp_segment_
			entry (character (*), pointer, fixed binary (35));

dcl	(addr, copy, currentsize, divide, float, length, low, mod, null, rtrim, string, substr, unspec)
			builtin;

dcl	(cleanup, record_quota_overflow)
			condition;
%page;
/* Compact the segment */

mseg_segment_$compact_seg:
     entry (P_mseg_operation_ptr, P_compaction_ratio, P_code);

	call setup_operation ();			/* for cleanup handler */
	target_mseg_ptr = null ();
	salvage_if_errors, free_source_message_bits = "0"b;
	operation_specific_return = return_from_compact_seg;
	operation_specific_abort = abort_compact_seg;

	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$compact_seg);
	if rqo_detected
	then call return_from_operation (0);
	else if code ^= 0
	then call return_from_operation (code);

	if mseg_segment.n_messages = 0		/* can't be any waste unless there's something present */
	then call return_from_operation (0);


	/*** When deciding whether to compact, the ratio of unused blocks to the "size" of the segment is checked
	     against the caller's compaction ratio.  If the unused ratio exceeds the compaction ratio and there is at
	     least one page of unused blocks, the segment is compacted.  However, if the caller's compaction ratio is
	     negative, the compaction is always performed regardless of the amount of space it may (or may not) recover.
	     In order to make the unused block ratio useful, the unused blocks after the last used block are not counted
	     when computing either the size of the segment or the number of unused blocks. */

	if P_compaction_ratio >= 0.0e0
	then do;

		n_virgin_blocks = mseg_segment.n_blocks_allocated - find_last_one_bit (mseg_segment.block_map.map);
		n_used_or_wasted_blocks = mseg_segment.n_blocks_allocated - n_virgin_blocks;
		n_wasted_blocks = mseg_segment.n_blocks_unused - n_virgin_blocks;

		if n_wasted_blocks = 0		/* there's no waste at all */
		then call return_from_operation (0);

		if (float (n_wasted_blocks) / float (n_used_or_wasted_blocks)) < P_compaction_ratio
		then call return_from_operation (0);	/* there isn't enough waste to satisfy our caller */

		if (mseg_segment.block_size * n_wasted_blocks)
		     < mod ((mseg_segment.block_size * n_used_or_wasted_blocks), 1024)
		then call return_from_operation (0);	/* we won't recover any pages so why bother */
	     end;


	/*** Control arrives here only if we are going to compact the segment -- We compact the segment by copying its
	     messages into a "message segment" in the process directory.  This so-called message segment is actually
	     just a temporary segment with an associated mseg_operation structure containing the necessary information
	     to satisfy mseg_message_$add_message_for_mseg. */

	/*** Finish preparation of the source -- Save the segment's wakeup state in its mseg_operation so we can store
	     it in the target segment while initalizing the target's header.  Also, to insure that the target's block
	     map is the proper length, we claim that the target's max length is equal to the source even though, as a
	     temporary segment, its max length may indeed be larger. */

	source_mseg_operation_ptr = mseg_operation_ptr;
	source_mseg_ptr = mseg_ptr;

	if mseg_segment.wakeup_state_set
	then call get_wakeup_state_seg ();
	else mseg_operation.wakeup_state_valid = "0"b;

	call hcs_$get_max_length_seg (mseg_ptr, target_max_length, code);
	if code ^= 0
	then call return_from_operation (code);


	/*** Prepare the target -- Create an mseg_operation which will satisfy mseg_message_$add_message_for_mseg and
	     then get a temporary segment to serve as the target. */

	an_operation = source_mseg_operation;
	an_operation.mseg_ptr_valid,			/* the source segment is never the target ... */
	     an_operation.access_info_valid = "0"b;	/* ... and its access info doesn't apply to the target */
	an_operation.suppress_access_checks = "1"b;	/* must be able to  copy all messages */

	call get_temp_segment_ (operation_name, target_mseg_ptr, code);
	if code ^= 0
	then call return_from_operation (code);

	an_operation.mseg_ptr = target_mseg_ptr;
	an_operation.mseg_ptr_valid = "1"b;

	target_mseg_operation_ptr = addr (an_operation);

	call mseg_utils_$begin_operation (mseg_operations_$copy_seg_target, target_mseg_operation_ptr, ((64)" "),
	     target_mseg_dir_name, target_mseg_entryname, target_mseg_ptr, rqo_detected, code);
	if rqo_detected
	then call return_from_operation (error_table_$rqover);
	else if code ^= 0
	then call return_from_operation (code);


	/*** Copy the source segment to its "target" which actually performs the compaction */

	salvage_if_errors = "1"b;			/* if we RQO reading from the segment, it's busted */

	on record_quota_overflow call return_rqover_from_operation ();

	call initialize_target_header ("1"b);		/* put in the saved wakeup state */

	call copy_messages ();


	/*** Move the target back into the real segment which will complete this operation -- As the compacted segment
	     is guaranteed to not use more pages than its original, we can pratically guarantee that an RQO will not
	     occur on pages that had been zero in the original by first truncating the segment.  If, however, an RQO
	     does occur while copying into the segment, we will stop the copy and salvage what's there as our handler
	     for record_quota_overflow will prevent an automatic salvage by mseg_utils_$abort_operation. */

	segment_in_error = SOURCE;

	call hcs_$truncate_seg (source_mseg_ptr, TRUNCATE_ALL_BUT_THE_LOCKWORD, (0));

	compacted_size =
	     target_mseg_segment_header.block_size
	     * (target_mseg_segment_header.n_blocks_allocated - target_mseg_segment_header.n_blocks_unused);

	source_mseg_ptr -> compacted_segment = target_mseg_ptr -> compacted_segment;

	revert record_quota_overflow;			/* success! */
	call return_from_operation (0);



/* Special processing required upon completion of a compact_seg operation */

return_from_compact_seg:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	if target_mseg_ptr ^= null ()
	then do;
		call release_temp_segment_ (operation_name, target_mseg_ptr, (0));
		target_mseg_ptr = null ();
	     end;

	if salvage_if_errors & (p_code ^= 0)		/* the flag is only set while actually copying */
	then if segment_in_error = SOURCE
	     then if p_code = error_table_$rqover
		then call mseg_utils_$salvage_for_cause (source_mseg_operation_ptr, error_table_$rqover);

	if free_source_message_bits			/* this flag is also only set while acutally copying */
	then if source_mseg_operation.message_info.ms_ptr ^= null ()
	     then do;
		     free source_mseg_message_bits in (system_area);
		     source_mseg_operation.message_info.ms_ptr = null ();
		end;

	return;

     end return_from_compact_seg;



/* Special processing required upon abnormal termination of a compact_seg operation */

abort_compact_seg:
     procedure ();

	if free_source_message_bits			/* this flag is only set while acutally copying */
	then if source_mseg_operation.message_info.ms_ptr ^= null ()
	     then do;
		     free source_mseg_message_bits in (system_area);
		     source_mseg_operation.message_info.ms_ptr = null ();
		end;

	if target_mseg_ptr ^= null ()
	then do;
		call release_temp_segment_ (operation_name, target_mseg_ptr, (0));
		target_mseg_ptr = null ();
	     end;

	return;

     end abort_compact_seg;
%page;
/* Copy the segment -- This entrypoint doesn't use mseg_operation_ptr as we are invoked with two message segments which
   must be given equal treatment in terms of begin/finish/abort operation actions. */

mseg_segment_$copy_seg:
     entry (P_source_mseg_operation_ptr, P_target_mseg_operation_ptr, P_error_on_target, P_code);

	call setup_operation ();			/* for cleanup handler */
	source_mseg_operation_ptr, target_mseg_operation_ptr = null ();
	salvage_if_errors, free_source_message_bits = "0"b;
	operation_specific_return = return_from_copy_seg;
	operation_specific_abort = abort_copy_seg;

	on cleanup call operation_was_aborted ();


	/*** Lock the target segment and verify that it is, in fact, empty */

	segment_in_error = TARGET;

	target_mseg_operation_ptr = P_target_mseg_operation_ptr;

	call mseg_utils_$begin_operation (mseg_operations_$copy_seg_target, target_mseg_operation_ptr, operation_name,
	     target_mseg_dir_name, target_mseg_entryname, target_mseg_ptr, rqo_detected, code);
	if rqo_detected
	then call return_from_operation (error_table_$rqover);
	else if code ^= 0
	then call return_from_operation (code);

	if (target_mseg_segment_header.n_messages ^= 0) | target_mseg_segment_header.wakeup_state_set
	then call return_from_operation (error_table_$clnzero);


	/*** Lock the source segment -- If it's empty, we're done. */

	segment_in_error = SOURCE;

	source_mseg_operation_ptr = P_source_mseg_operation_ptr;

	call mseg_utils_$begin_operation (mseg_operations_$copy_seg_source, source_mseg_operation_ptr, operation_name,
	     source_mseg_dir_name, source_mseg_entryname, source_mseg_ptr, rqo_detected, code);
	if rqo_detected				/* couldn't even lock the source: there's nothing to copy */
	then call return_from_operation (0);
	else if code ^= 0
	then call return_from_operation (code);


	/*** Verify that the max length of the target is, at least, as large as the source */

	segment_in_error = SOURCE;
	call hcs_$get_max_length_seg (source_mseg_ptr, source_max_length, code);
	if code ^= 0
	then call return_from_operation (code);

	segment_in_error = TARGET;
	call hcs_$get_max_length_seg (target_mseg_ptr, target_max_length, code);
	if code ^= 0
	then call return_from_operation (code);

	if target_max_length < source_max_length	/* it may not all fit */
	then call return_from_operation (error_table_$invalid_max_length);


	/*** Everything looks OK -- Copy the segment */

	salvage_if_errors = "1"b;			/* RQO on source or any error on target should salvage */

	on record_quota_overflow call return_rqover_from_operation ();

	call initialize_target_header ("0"b);		/* do not copy the source's wakeup state */

	call copy_messages ();

	revert record_quota_overflow;

	call return_from_operation (0);		/* success! */



/* Return after completion of the copy_seg operation -- If an RQO occured while accessing the source segment, we will
   salvage it because a properly formed message segment should never have message block offsets which reference an all
   zero page and, as we are handling RQO ourselves, the standard abort_operation salvage will not occur.  On the other
   hand, if any error is detected while accessing the target segment, we will salvage it because we shouldn't get an error
   adding messages. */

return_from_copy_seg:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	if salvage_if_errors & (p_code ^= 0)		/* the flag is only set while actually copying */
	then if segment_in_error = SOURCE
	     then if p_code = error_table_$rqover
		then call mseg_utils_$salvage_for_cause (source_mseg_operation_ptr, error_table_$rqover);
		else ;

	     else if segment_in_error = TARGET
	     then if p_code ^= error_table_$bad_segment
		then do;				/* only salvage if mseg_message_ hasn't already done so */
			call mseg_utils_$salvage_for_cause (target_mseg_operation_ptr, p_code);
			if p_code ^= error_table_$rqover
			then p_code = error_table_$bad_segment;
		     end;

	if free_source_message_bits			/* this flag is also only set while acutally copying */
	then if source_mseg_operation.message_info.ms_ptr ^= null ()
	     then do;
		     free source_mseg_message_bits in (system_area);
		     source_mseg_operation.message_info.ms_ptr = null ();
		end;

	if target_mseg_operation_ptr ^= null ()
	then call mseg_utils_$finish_operation (target_mseg_operation_ptr);

	if source_mseg_operation_ptr ^= null ()
	then call mseg_utils_$finish_operation (source_mseg_operation_ptr);

	P_error_on_target = (segment_in_error = TARGET);	/* tell caller where (if anywhere) the error occured */

	return;

     end return_from_copy_seg;



/* Abort the copy_seg operation */

abort_copy_seg:
     procedure ();

	if free_source_message_bits			/* this flag is only set while acutally copying */
	then if source_mseg_operation.message_info.ms_ptr ^= null ()
	     then do;
		     free source_mseg_message_bits in (system_area);
		     source_mseg_operation.message_info.ms_ptr = null ();
		end;

	call mseg_utils_$abort_operation (source_mseg_operation_ptr);

	call mseg_utils_$abort_operation (target_mseg_operation_ptr);

	return;

     end abort_copy_seg;
%page;
/* Get the salvaged flag -- The salvaged indicator is set whenever the message segment is salvaged and remains set until
   it explicitly reset by someone with "d" extended access to the segment. */

mseg_segment_$get_salvaged_flag_seg:
     entry (P_mseg_operation_ptr, P_salvaged_flag, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$get_salvaged_flag_seg);

	if rqo_detected				/* the header is zero and accessing it causes RQOs, */
	then P_salvaged_flag = "0"b;			/* ... so we know the flag is off without actually looking */

	else if code = 0				/* we can look at the header without trouble */
	then P_salvaged_flag = mseg_segment.flags.salvaged;

	call return_from_operation (code);
%page;
/* Get the wakeup acceptance state */

mseg_segment_$get_wakeup_state_seg:
     entry (P_mseg_operation_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$get_wakeup_state_seg);
	if rqo_detected				/* header's empty so no one is accepting wakeups here */
	then call return_from_operation (error_table_$messages_off);
	else if code ^= 0
	then call return_from_operation (code);

	if ^mseg_segment.wakeup_state_set
	then call return_from_operation (error_table_$messages_off);

	call get_wakeup_state_seg ();

	call return_from_operation (0);



/* Actually get the wakeup state -- This internal procedure is only invoked if the message segment's header claims that
   the wakeup state is actually present.  In earlier version 5 message segments, the wakeup state was actually stored in
   several pieces throughout the header.  This internal procedure is also used by compact_seg. */

get_wakeup_state_seg:
     procedure ();

						/** format: idind30 */
dcl	1 old_wakeup_state		aligned,
	  2 state,
	    3 switches		aligned,
	      4 allow_normal	bit (1) unaligned,
	      4 allow_urgent	bit (1) unaligned,
	      4 pad		bit (34) unaligned,
	    3 lock_id		bit (36) aligned,
	    3 event_channel		fixed bin (71),
	    3 process_id		bit (36) aligned,
	  2 pad			(64 - 5) bit (36) aligned;
						/* format: idind20 */

	if mseg_segment.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1
	then mseg_operation.wakeup_state = mseg_segment.wakeup_state.state;

	else do;					/* early version 5 message segment */
		unspec (old_wakeup_state) = unspec (header_msg);
		mseg_operation.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1;
		string (mseg_operation.wakeup_state.flags) = string (old_wakeup_state.switches);
		mseg_operation.wakeup_state.event_channel = old_wakeup_state.event_channel;
		mseg_operation.wakeup_state.access_class = header_msg_access_class;
		mseg_operation.wakeup_state.process_id = old_wakeup_state.process_id;
		mseg_operation.wakeup_state.lock_id = old_wakeup_state.lock_id;
	     end;

	mseg_operation.wakeup_state_valid = "1"b;	/* it's very definitely OK now */

	return;

     end get_wakeup_state_seg;
%page;
/* Reset the salvaged flag */

mseg_segment_$reset_salvaged_flag_seg:
     entry (P_mseg_operation_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$reset_salvaged_flag_seg);
	if rqo_detected				/* header's empty so the salvaged flag is already reset */
	then call return_from_operation (0);
	else if code ^= 0
	then call return_from_operation (code);

	if mseg_segment.flags.salvaged
	then do;

		mseg_segment.flags.salvaged = "0"b;	/* actually reset the flag */

		if mseg_operation.call_admin_gate & ^mseg_operation.suppress_access_checks
		     & mseg_operation.access_info.multiclass
		then do;				/* audit the covert channel */
			string (local_aef) = ""b;
			local_aef.grant = "1"b;
			local_aef.cc_10_100 = "1"b;
			call access_audit_r1_$log_obj_ptr (operation_name, mseg_operation.validation_level,
			     string (local_aef), access_operations_$mseg_attr_mod, mseg_ptr, 0, null (), 0,
			     "Message segment salvage flag reset.");
		     end;
	     end;

	call return_from_operation (0);
%page;
/* Reset the wakeup acceptance state (i.e., turn it off) */

mseg_segment_$reset_wakeup_state_seg:
     entry (P_mseg_operation_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$reset_wakeup_state_seg);
	if rqo_detected				/* header's empty so the wakeup state is already reset */
	then call return_from_operation (0);
	else if code ^= 0
	then call return_from_operation (code);

	mseg_segment.wakeup_state_set = "0"b;
	unspec (mseg_segment.wakeup_state) = ""b;

	call return_from_operation (0);
%page;
/* Set the max length */

mseg_segment_$set_max_length_seg:
     entry (P_mseg_operation_ptr, P_max_length, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$set_max_length_seg);

	if rqo_detected
	then do;	/*** The header is empty and any attempts to access it cause an RQO.  We can still try to set the max
		     length, however, by using a local copy of the header while being careful not to reference its
		     block map which doesn't exist. */
		mseg_ptr = addr (local_mseg_segment_header);
		mseg_segment.n_messages = 0;
		mseg_segment.block_size = mseg_data_$block_size;
		initialize_block_map = "0"b;
	     end;

	else if code = 0
	then do;	/*** We can access the header without problems. */
		if mseg_segment.block_size = 0
		then mseg_segment.block_size = mseg_data_$block_size;
		initialize_block_map = "1"b;
	     end;

	else call return_from_operation (code);		/* couldn't get to the segment at all */

	if mseg_segment.n_messages > 0
	then call return_from_operation (error_table_$action_not_performed);


	/*** The new max length must be large enough to hold the header and a single zero length message. */

	if P_max_length <= 0
	then call return_from_operation (error_table_$invalid_max_length);

	n_new_blocks = divide (P_max_length, mseg_segment.block_size, 18, 0);
						/* format: off */
	n_new_header_blocks =
	     divide ((currentsize (local_mseg_segment_header) + divide ((n_new_blocks + 35), 36, 18, 0)
		    + mseg_segment.block_size - 1), mseg_segment.block_size, 18, 0);
						/* format: on */
	if n_new_blocks <= n_new_header_blocks
	then call return_from_operation (error_table_$invalid_max_length);


	/*** The new max length is OK -- set it */

	call hcs_$set_max_length_seg (mseg_operation.mseg_ptr, P_max_length, code);

	if (code = 0) & initialize_block_map
	then do;	/*** We set the max length and can access the actual header -- Initialize the block map. */
		mseg_segment.n_blocks_allocated = n_new_blocks;
		mseg_segment.n_blocks_unused = n_new_blocks - n_new_header_blocks;
		mseg_segment.block_map.map = copy ("1"b, n_new_header_blocks);
	     end;

	call return_from_operation (code);
%page;
/* Set the wakeup acceptance state */

mseg_segment_$set_wakeup_state_seg:
     entry (P_mseg_operation_ptr, P_code);

	call setup_operation ();			/* for cleanup handler */
	on cleanup call operation_was_aborted ();

	call begin_operation (mseg_operations_$set_wakeup_state_seg);
	if rqo_detected
	then call return_from_operation (error_table_$rqover);
	else if code ^= 0
	then call return_from_operation (code);

	mseg_segment.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1;

	mseg_segment.wakeup_state.flags = mseg_operation.wakeup_state.flags;
	mseg_segment.wakeup_state.event_channel = mseg_operation.wakeup_state.event_channel;

	mseg_segment.wakeup_state.access_class = aim_util_$get_access_class (mseg_operation.caller.authorization);
	mseg_segment.wakeup_state.process_id = get_process_id_ ();
	mseg_segment.wakeup_state.lock_id = mseg_data_$lock_id;

	unspec (mseg_segment.header.wakeup_state.pad) = ""b;

	mseg_segment.wakeup_state_set = "1"b;		/* it's now set */

	call return_from_operation (0);
%page;
/* Common initialization for all operations */

setup_operation:
     procedure ();

	code = 0;

	operation_specific_abort = nulle;		/* nothing special when we abort or return (yet) */
	operation_specific_return = nulle;

	mseg_operation_ptr = null ();

	return;

     end setup_operation;



/* Begin the operation -- This procedure isn't part of setup_operation so that we can be certain to have a cleanup handler
   available at all times that the message segment may be in use. */

begin_operation:
     procedure (p_mseg_operation_id);

dcl	p_mseg_operation_id bit (36) aligned parameter;

	mseg_operation_ptr = P_mseg_operation_ptr;

	call mseg_utils_$begin_operation (p_mseg_operation_id, mseg_operation_ptr, operation_name, mseg_dir_name,
	     mseg_entryname, mseg_ptr, rqo_detected, code);

	return;

     end begin_operation;



/* The "null" entry which indicates that there's no special abort/return processing for an operation */

nulle:
     procedure ();

	return;

     end nulle;
%page;
/* Return after completion of an operation */

return_from_operation:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	if operation_specific_return ^= nulle		/* let the operation do anything special */
	then call operation_specific_return (p_code);

	if mseg_operation_ptr ^= null ()		/* may be invoked before we've called begin_operation */
	then call mseg_utils_$finish_operation (mseg_operation_ptr);

	P_code = p_code;				/* set our caller's status code */
	go to RETURN_FROM_OPERATION;

     end return_from_operation;

RETURN_FROM_OPERATION:
	return;



/* Return error_table_$rqover to our caller after an RQO is detected */

return_rqover_from_operation:
     procedure ();

	if operation_specific_return ^= nulle		/* let the operation do anything special */
	then call operation_specific_return (error_table_$rqover);

	if mseg_operation_ptr ^= null ()		/* may be invoked by copy_seg which doesn't use this value */
	then call mseg_utils_$finish_operation (mseg_operation_ptr);

	P_code = error_table_$rqover;			/* set our caller's status code */
	go to RETURN_FROM_OPERATION;

     end return_rqover_from_operation;



/* Abort an operation */

operation_was_aborted:
     procedure ();

	if operation_specific_abort ^= nulle		/* let the operation do anything special */
	then call operation_specific_abort ();

	call mseg_utils_$abort_operation (mseg_operation_ptr);

	return;

     end operation_was_aborted;
%page;
/* Finds the last one bit in a bit string as index (reverse (bit_string), "1"b) is too slow */

find_last_one_bit:
     procedure (p_bit_string) returns (fixed binary (24));

dcl	p_bit_string	bit (*) unaligned parameter;
dcl	the_bits_as_chars	character (n_chars) aligned based (addr (p_bit_string));
dcl	the_char		character (1) aligned;
dcl	the_char_as_bits	bit (9) aligned based (addr (the_char));
dcl	(n_bits, bit_idx)	fixed binary (24);
dcl	(n_chars, char_idx) fixed binary (21);

	n_bits = length (p_bit_string);

	if mod (n_bits, 9) ^= 0
	then do;					/* must check the last bits by hand */
		do bit_idx = 0 to (mod (n_bits, 9) - 1);
		     if substr (p_bit_string, (n_bits - bit_idx), 1)
		     then return ((n_bits - bit_idx));
		end;
		n_bits = n_bits - mod (n_bits, 9);	/* ... they were all zero */
	     end;

	n_chars = divide (n_bits, 9, 21, 0);
	char_idx = length (rtrim (the_bits_as_chars, low (1)));

	if char_idx = 0
	then return (0);				/* no one bits at all */

	the_char = substr (the_bits_as_chars, char_idx, 1);
	do bit_idx = 9 to 1 by -1;
	     if substr (the_char_as_bits, bit_idx)
	     then return ((9 * (char_idx - 1)) + bit_idx);
	end;

	return ((9 * (char_idx - 1)));		/* won't get here, but ... */

     end find_last_one_bit;
%page;
/* Initialize the copy target's header -- Our caller has already locked the segment and determined its max length. */

initialize_target_header:
     procedure (p_copy_source_wakeup_state);

dcl	p_copy_source_wakeup_state
			bit (1) aligned parameter;

	target_mseg_segment_header.n_messages, target_mseg_segment_header.date_time_last_salvaged = 0;
	unspec (target_mseg_segment_header.message_chain) = ""b;
	string (target_mseg_segment_header.flags) = ""b;
	unspec (target_mseg_segment_header.wakeup_state) = ""b;
	unspec (target_mseg_segment_header.hash_table) = ""b;

	target_mseg_segment_header.sentinel = MSEG_SEGMENT_SENTINEL;
	target_mseg_segment_header.version = MSEG_SEGMENT_VERSION_5;

	target_mseg_segment_header.block_size = mseg_data_$block_size;
	target_mseg_segment_header.n_blocks_allocated =
	     divide (target_max_length, target_mseg_segment_header.block_size, 18, 0);
						/* format: off */
	n_new_header_blocks =
	     divide ((currentsize (target_mseg_segment_header)
		    + divide ((target_mseg_segment_header.n_blocks_allocated + 35), 36, 18, 0)
		    + target_mseg_segment_header.block_size - 1), target_mseg_segment_header.block_size, 18, 0);
						/* format: on */

	target_mseg_segment_header.n_blocks_unused =
	     target_mseg_segment_header.n_blocks_allocated - n_new_header_blocks;

	target_mseg_ptr -> mseg_segment.block_map.map = copy ("1"b, n_new_header_blocks);

	if p_copy_source_wakeup_state
	then do;
		if source_mseg_operation.wakeup_state_valid
		then target_mseg_segment_header.wakeup_state.state = source_mseg_operation.wakeup_state;
		target_mseg_segment_header.wakeup_state_set = source_mseg_operation.wakeup_state_valid;
	     end;

	return;

     end initialize_target_header;
%page;
/* Copy all messages in the source message segment to the target -- We call mseg_message_$read_message_for_mseg and
   mseg_message_$add_message_for_mseg to do the actuall reading/writing.  These special entrypoints are implemented
   knowing that they are invoked with the message segment's already locked. */

copy_messages:
     procedure ();

	source_mseg_operation.suppress_access_checks,	/* insure mseg_message_ copies all the messages */
	     target_mseg_operation.suppress_access_checks = "1"b;
	target_mseg_operation.add_message_info_all_valid = "1"b;

	source_mseg_operation.message_info.version = MSEG_MESSAGE_INFO_V1;
	string (source_mseg_operation.message_info.control_flags) = ""b;
	source_mseg_operation.message_info.ms_ptr = null ();

	system_area_ptr = get_system_free_area_ ();

	free_source_message_bits = "1"b;		/* force cleanup handlers to get rid of leftovers */

	segment_in_error = SOURCE;
	source_mseg_operation.message_info.message_code = MSEG_READ_FIRST;
	call mseg_message_$read_message_for_mseg (source_mseg_operation_ptr, operation_name, system_area_ptr, code);

	do while (code = 0);

	     segment_in_error = TARGET;
	     target_mseg_operation.message_info = source_mseg_operation.message_info;
	     call mseg_message_$add_message_for_mseg (target_mseg_operation_ptr, operation_name, code);
	     if code ^= 0
	     then call return_from_operation (code);

	     if source_mseg_operation.message_info.ms_ptr ^= null ()
	     then do;
		     free source_mseg_message_bits in (system_area);
		     source_mseg_operation.message_info.ms_ptr = null ();
		end;

	     segment_in_error = SOURCE;
	     source_mseg_operation.message_info.message_code = MSEG_READ_AFTER_SPECIFIED;
	     call mseg_message_$read_message_for_mseg (source_mseg_operation_ptr, operation_name, system_area_ptr, code)
		;
	end;

	if code ^= error_table_$no_message		/* we were unable to read a message */
	then call return_from_operation (code);

	free_source_message_bits = "0"b;

	return;

     end copy_messages;

/* format: off */
%page; %include mseg_data_;
%page; %include mseg_segment;
%page; %include mseg_wakeup_state;
%page; %include mseg_operation;
%page; %include mseg_message_info;
%page; %include entry_access_info;
%page; %include mseg_operations_;
%page; %include access_audit_eventflags;
%page;

/* BEGIN MESSAGE DOCUMENTATION


   Message:
   Audit (mseg_$reset_salvaged_flag_seg): GRANTED modifying message segment attributes
	ADDED_INFO <Message segment salvage flag reset.>

   S:	$access_audit

   T:	$run

   M:	The salvaged indicator of a message segment or mailbox was reset at
	the user's request.  Repeated occurences of this event over a short
	period of time could indicate an attempt to exploit a moderate
	bandwidth covert channel.  ADDED_INFO will identify the user and
	segment in question.

   A:	$notify_ssa


   END MESSAGE DOCUMENTATION */

/* format: on */

     end mseg_segment_;




		    mseg_utils_.pl1                 05/22/85  0725.7r w 05/22/85  0649.2      637308



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

/* Utilities used by the message segment primitive operations (mseg_) */

/* Created:  April 1985 by G. Palter based upon mseg_, mseg_error_, mseg_convert_, ms_salvager_, and ms_salv_util_ */
/* Modified: 20 May 1985 by G. Palter to avoid spurious RQOs while salvaging */

/* format: style3,linecom */

mseg_utils_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl	P_mseg_operation_ptr
			pointer parameter;

dcl	P_code		fixed binary (35) parameter;	/* begin_operation: indicates whether we setup OK (Output);
						   salvage_for_cause: why we must salvage (Input) */

dcl	P_operation_id	bit (36) aligned parameter;	/* begin_operation: the operation to be started */
dcl	P_operation_name	character (*) parameter;	/* begin_operation: set to the name of the operation */
dcl	P_mseg_dir_name	character (*) parameter;	/* begin_operation: set to segment's parent if known */
dcl	P_mseg_entryname	character (*) parameter;	/* begin_operation: set to segment' entryname if known */
dcl	P_mseg_ptr	pointer parameter;		/* begin_operation: set -> the segment if available */
dcl	P_rqo_detected	bit (1) aligned parameter;	/* begin_operation: set ON => an RQO occured while locking */


/* Local copies of parameters */

dcl	operation_name	character (64);

dcl	mseg_dir_name	character (168);
dcl	mseg_entryname	character (32);

dcl	rqo_detected	bit (1) aligned;

dcl	code		fixed binary (35);


/* Remaining declarations */

dcl	1 mseg_segment_header
			aligned based (mseg_ptr) like mseg_segment.header;

dcl	1 long_status	aligned like status_branch;

dcl	test_lock		bit (36) aligned;

dcl	salvage_for_cause_arguments
			pointer;

dcl	path_code		fixed binary (35);
dcl	(salvage_report_text_lth, callers_report_text_lth)
			fixed binary (21);
dcl	(mseg_max_length, mseg_cur_length)
			fixed binary (19);
dcl	(n_header_blocks, n_possible_messages, n_messages_recovered)
			fixed binary (18);
dcl	(n_arguments, prefix_lth)
			fixed binary;

dcl	MSEG_UTILS_	character (32) static options (constant) initial ("mseg_utils_");

/* format: off */

dcl	SALVAGER_AND_UPGRADING_ACTIONS
	     (0:9) character (64) varying static options (constant) initial ("",
		"Call to hcs_$get_access_info_seg failed",
		"Call to hcs_$get_max_length_seg failed",
		"Unable to compute size for allocating message blocks",
		"Trying to locate upgrade support procedure",
		"Unable to salvage the segment prior to upgrading it",
		"Initializing the temporary upgraded segment in [pd]",
		"Copying messages into the temporary upgraded segment in [pd]",
		"Call to hcs_$status_long failed",
		"Rebuilding the contents of the message segment");

dcl      (CALL_GET_ACCESS_INFO	initial (1),
	CALL_GET_MAX_LENGTH		initial (2),
	COMPUTING_BLOCK_SIZE	initial (3),
	FINDING_SUPPORT_PROCEDURE	initial (4),
	SALVAGING_ORIGINAL_SEGMENT	initial (5),
	PREPARING_UPGRADED_TEMPORARY	initial (6),
	CREATING_UPGRADED_TEMPORARY	initial (7),
	CALL_STATUS_LONG		initial (8),
	REBUILDING_SEGMENT		initial (9)
	)		fixed binary static options (constant);

dcl      (error_table_$bad_segment, error_table_$bad_subr_arg, error_table_$bigarg, error_table_$improper_data_format,
	error_table_$invalid_max_length, error_table_$lock_wait_time_exceeded, error_table_$no_message,
	error_table_$no_s_permission, error_table_$not_seg_type, error_table_$notalloc, error_table_$null_info_ptr,
	error_table_$rqover, error_table_$seg_busted, error_table_$segfault, error_table_$unimplemented_version)
			fixed binary (35) external;

/* format: on */

dcl	sys_info$ring1_privilege
			bit (36) aligned external;

dcl	admin_gate_$guaranteed_eligibility_off
			entry ();
dcl	admin_gate_$guaranteed_eligibility_on
			entry ();
dcl	admin_gate_$syserr_error_code
			entry (/* fixed binary, fixed binary (35), character (*) */) options (variable);
dcl	aim_check_$greater_or_equal
			entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl	aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned);
dcl	aim_util_$get_privileges
			entry (bit (72) aligned) returns (bit (36) aligned);
dcl	cu_$arg_count	entry (fixed binary, fixed binary (35));
dcl	cu_$arg_list_ptr	entry () returns (pointer);
dcl	find_condition_info_
			entry (pointer, pointer, fixed binary (35));
dcl	get_group_id_	entry () returns (character (32));
dcl	get_lock_id_	entry () returns (bit (36) aligned);
dcl	get_process_max_authorization_
			entry () returns (bit (72) aligned);
dcl	get_ring_		entry () returns (fixed binary (3));
dcl	get_system_free_area_
			entry () returns (pointer);
dcl	get_temp_segment_	entry (character (*), pointer, fixed binary (35));
dcl	hcs_$fs_get_path_name
			entry (pointer, character (*), fixed binary, character (*), fixed binary (35));
dcl	hcs_$get_access_info_seg
			entry (pointer, pointer, fixed binary (35));
dcl	hcs_$get_max_length_seg
			entry (pointer, fixed binary (19), fixed binary (35));
dcl	hcs_$make_entry	entry (pointer, character (*), character (*), entry, fixed binary (35));
dcl	hcs_$set_damaged_sw_seg
			entry (pointer, bit (1) aligned, fixed binary (35));
dcl	hcs_$status_long	entry (character (*), character (*), fixed binary (1), pointer, pointer, fixed binary (35));
dcl	hcs_$truncate_seg	entry (ptr, fixed bin (19), fixed bin (35));
dcl	ioa_$general_rs	entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21),
			bit (1) aligned, bit (1) aligned);
dcl	ioa_$rsnpnnl	entry () options (variable);
dcl	mseg_message_$add_message_for_mseg
			entry (pointer, character (*), fixed binary (35));
dcl	mseg_utils_$salvage_for_cause
			entry (/* pointer, fixed binary (35) */) options (variable);
dcl	pathname_		entry (character (*), character (*)) returns (character (168));
dcl	release_temp_segment_
			entry (character (*), pointer, fixed binary (35));
dcl	set_lock_$lock	entry (bit (36) aligned, fixed binary, fixed binary (35));
dcl	set_lock_$unlock	entry (bit (36) aligned, fixed binary (35));
dcl	sort_items_indirect_$bit
			entry (pointer, pointer, fixed binary (24));
dcl	sub_err_		entry () options (variable);

dcl	(addr, clock, codeptr, copy, convert, currentsize, divide, fixed, hbound, index, lbound, length, max, mod, null,
	rtrim, setwordno, stacq, string, substr, unspec, wordno)
			builtin;

dcl	(cleanup, record_quota_overflow, seg_fault_error)
			condition;
%page;
/* Initialize the perprocess values in mseg_data_ */

mseg_utils_$initialize:
     entry ();

	mseg_data_$group_id = get_group_id_ ();
	mseg_data_$lock_id = get_lock_id_ ();
	mseg_data_$process_max_authorization = get_process_max_authorization_ ();

	mseg_data_$execution_ring = get_ring_ ();	/* this is OK as static data is per ring ... */

	return;
%page;
/* Begin an operation -- First, we verify that the supplied mseg_operation includes the fields required for the operation.
   We then guarantee elibility, if possible, and perform the actions requested by the operation's begin flags, if any. */

mseg_utils_$begin_operation:
     entry (P_operation_id, P_mseg_operation_ptr, P_operation_name, P_mseg_dir_name, P_mseg_entryname, P_mseg_ptr,
	P_rqo_detected, P_code);

	mseg_operation_data_ptr = addr (P_operation_id);
	if (mseg_operation_data.operation_id < lbound (mseg_operations_$names, 1))
	     | (mseg_operation_data.operation_id > hbound (mseg_operations_$names, 1))
	then call sub_err_ (error_table_$bad_subr_arg, MSEG_UTILS_, ACTION_CANT_RESTART, null (), 0,
		"Operation ID = ^12.3b", P_operation_id);

	operation_name = mseg_operations_$names (mseg_operation_data.operation_id);

	mseg_operation_ptr = P_mseg_operation_ptr;

	if mseg_operation_ptr = null ()
	then call sub_err_ (error_table_$null_info_ptr, operation_name, ACTION_CANT_RESTART, null (), 0);

	if mseg_operation.version ^= MSEG_OPERATION_VERSION_1
	then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0,
		"mseg_operation.version = ^d.", mseg_operation.version);

	mseg_operation.operation = P_operation_id;	/* set the operation code */
	mseg_operation_data_ptr = addr (mseg_operation.operation);

	mseg_dir_name = "";				/* initialize output values */
	mseg_entryname = "";
	mseg_ptr = null ();
	rqo_detected = "0"b;
	code = 0;

	mseg_operation_data.already_salvaged,		/* for cleanup handlers and the like */
	     mseg_operation_data.unlock_segment = "0"b;


	/*** Check that required data is present -- In the current implementation, all operations require either the
	     pathname or mseg_ptr.  Of the remaining fields in an mseg_operation, the primitives will only occasionally
	     use the access_info, message_info, and wakeup_state structures.  */

	if mseg_operation_data.required_data.pathname & mseg_operation_data.required_data.mseg_ptr
	then do;	/*** Either the pathname or mseg_ptr or both may be used */
		if ^mseg_operation.mseg_pathname_valid & ^mseg_operation.mseg_ptr_valid
		then call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0,
			"The mseg_operation does not include either a valid pathname or a valid mseg_ptr.");
		if mseg_operation.access_info_valid
		then do;				/* always give preference to the pathname derived in ring 0 */
			mseg_dir_name = mseg_operation.access_info.dir_name;
			mseg_entryname = mseg_operation.access_info.entryname;
		     end;
		else if mseg_operation.mseg_pathname_valid
		then do;				/* caller has supplied the pathname */
			mseg_dir_name = mseg_operation.dir_name;
			mseg_entryname = mseg_operation.entryname;
		     end;
		if mseg_operation.mseg_ptr_valid	/* caller has also supplied an mseg_ptr */
		then mseg_ptr = mseg_operation.mseg_ptr;
	     end;

	else if mseg_operation_data.required_data.pathname
	then /*** This operation requires a valid pathname */
	     if mseg_operation.access_info_valid
	     then do;				/* always give preference to the pathname derived in ring 0 */
		     mseg_dir_name = mseg_operation.access_info.dir_name;
		     mseg_entryname = mseg_operation.access_info.entryname;
		end;
	     else if mseg_operation.mseg_pathname_valid
	     then do;				/* caller has supplied the pathname */
		     mseg_dir_name = mseg_operation.dir_name;
		     mseg_entryname = mseg_operation.entryname;
		end;
	     else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0,
		     "The mseg_operation does not include a valid pathname.");

	else if mseg_operation_data.required_data.mseg_ptr
	then /*** This operation requires a valid mseg_ptr */
	     if mseg_operation.mseg_ptr_valid
	     then mseg_ptr = mseg_operation.mseg_ptr;
	     else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0,
		     "The mseg_operation does not include a valid mseg_ptr.");

	else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0,
		"mseg_operation.operation does not request either the pathname or mseg_ptr.");

	if mseg_operation_data.required_data.access_info
	then if ^mseg_operation.suppress_access_checks	/* we'll only actually need it if checking access */
	     then if mseg_operation.access_info_valid
		then if mseg_operation.access_info.version ^= ENTRY_ACCESS_INFO_VERSION_1
		     then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART,
			     null (), 0, "mseg_operation.access_info.version = ""^a"".",
			     mseg_operation.access_info.version);
		     else ;
		else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0,
			"The mseg_operation does not include a valid access_info structure.");

	if mseg_operation_data.required_data.message_info
	then if mseg_operation.message_info_valid
	     then if mseg_operation.message_info.version ^= MSEG_MESSAGE_INFO_V1
		then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (),
			0, "mseg_operation.message_info.version = ""^a"".", mseg_operation.message_info.version);
		else ;
	     else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0,
		     "The mseg_operation does not include a valid message_info structure.");

	if mseg_operation_data.required_data.wakeup_state
	then if mseg_operation.wakeup_state_valid
	     then if mseg_operation.wakeup_state.version ^= MSEG_WAKEUP_STATE_VERSION_1
		then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (),
			0, "mseg_operation.wakeup_state.version = ""^a"".", mseg_operation.message_info.version);
		else ;
	     else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0,
		     "The mseg_operation does not include a valid wakeup_state structure.");

	if mseg_operation_data.required_data.wakeup_state_version
	then if mseg_operation.wakeup_state.version ^= MSEG_WAKEUP_STATE_VERSION_1
	     then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0,
		     "mseg_operation.wakeup_state.version = ""^a"".", mseg_operation.message_info.version);


	/*** Guarantee eligibility if running in the admin ring (ring 1) */

	if mseg_operation.call_admin_gate
	then call admin_gate_$guaranteed_eligibility_on ();


	/*** Lock the segment if requested */

	if mseg_operation_data.begin_flags.lock_segment
	then do;

		on seg_fault_error call seg_fault_handler ();
		on record_quota_overflow
		     begin;
			rqo_detected = "1"b;	/* let the caller handle RQOs */
			go to RETURN_FROM_BEGIN_OPERATION;
		     end;				/* ... avoids making return_from_begin_operation nonquick */

		if stacq (mseg_segment.lock, mseg_data_$lock_id, (36)"0"b)
		then code = 0;
		else call set_lock_$lock (mseg_segment.lock, 20, code);

		revert record_quota_overflow;
		revert seg_fault_error;

		if mseg_operation_data.begin_flags.dont_check_lock_results
		then call return_from_begin_operation (code);
						/* our caller handles the lock non-standardly */

		else if code = 0			/* we've locked it */
		then mseg_operation_data.finish_flags.unlock_segment = "1"b;

		else if code = error_table_$lock_wait_time_exceeded
		then call return_from_begin_operation (code);
						/* some other process is using the segment */

		else call salvage_and_return_from_begin (code);
	     end;					/* invalid_lock_reset or locked_by_this_process */


	else call return_from_begin_operation (0);	/* don't try anything else if we can't lock the segment */


	/*** Check the header for consistency and initialize it if requested */

	if mseg_operation_data.begin_flags.check_header_consistency
	then if (mseg_segment.sentinel = ""b) & (mseg_segment.header.version = 0)
	     then if mseg_operation_data.begin_flags.initialize_header
		then do;	/*** This segment does not have a header -- However, the operation about to be performed
			     needs the header to behave properly.  Therefore, we must initialize the header now. */

			mseg_segment.sentinel = MSEG_SEGMENT_SENTINEL;
			mseg_segment.header.version = MSEG_SEGMENT_VERSION_5;

			call hcs_$get_max_length_seg (mseg_ptr, mseg_max_length, code);
			if code ^= 0
			then call return_from_begin_operation (code);

			/*** Compute the number of available blocks in the segment based on its max length. */
			mseg_segment.block_size = mseg_data_$block_size;
			mseg_segment.n_blocks_allocated = divide (mseg_max_length, mseg_segment.block_size, 18, 0);
						/* format: off */
			n_header_blocks =
			     divide ((currentsize (mseg_segment_header)
				    + divide ((mseg_segment.n_blocks_allocated + 35), 36, 18, 0)
				    + mseg_segment.block_size - 1),
				   mseg_segment.block_size, 18, 0);
						/* format: on */
			if mseg_segment.n_blocks_allocated <= n_header_blocks
			then /*** The segment doesn't have room for any messages. */
			     call return_from_begin_operation (error_table_$invalid_max_length);
			mseg_segment.n_blocks_unused = mseg_segment.n_blocks_allocated - n_header_blocks;

			/*** Record that the header has been allocated. */
			mseg_segment.block_map.map = copy ("1"b, n_header_blocks);
		     end;


		else /*** This segment does not have a header -- Fortunately, the operation about to be performed
			doesn't require the header for to behave properly so we needn't do anything more. */
		     ;


	     else do;  /*** This segment appears to have a header -- Perform automatic conversion if necessary and then
			make the minimal consistency checks on the header. */

		     if mseg_segment.header.version ^= MSEG_SEGMENT_VERSION_5
		     then if (mseg_segment.header.version >= 2)
			     & (mseg_segment.header.version < MSEG_SEGMENT_VERSION_5)
			then call upgrade_seg ();
			else call salvage_and_return_from_begin (mseg_format_errors_$bad_mseg_version);

		     if mseg_segment.sentinel ^= MSEG_SEGMENT_SENTINEL
		     then call salvage_and_return_from_begin (mseg_format_errors_$bad_mseg_sentinel);

		     if mseg_segment.modification_in_progress
		     then call salvage_and_return_from_begin (mseg_format_errors_$modification_in_progress);

		     if mseg_segment.salvage_in_progress
		     then call salvage_and_return_from_begin (mseg_format_errors_$salvage_in_progress);
		end;


	else call return_from_begin_operation (0);	/* don't check count&chains without checking the header */


	/*** Check the message count and message chain for consistency if requested */

	if mseg_operation_data.begin_flags.check_count_consistency
	then if mseg_segment.n_messages = 0
	     then if (mseg_segment.message_chain.first_message ^= 0) | (mseg_segment.message_chain.last_message ^= 0)
		then call salvage_and_return_from_begin (mseg_format_errors_$inconsistent_message_count);
		else ;				/* no messages and no message chain */

	     else if mseg_segment.n_messages < 0
	     then call salvage_and_return_from_begin (mseg_format_errors_$negative_message_count);

	     else /*** if mseg_segment.n_messages > 0 then */
		if (mseg_segment.message_chain.first_message = 0) | (mseg_segment.message_chain.last_message = 0)
	     then call salvage_and_return_from_begin (mseg_format_errors_$inconsistent_message_count);


	/*** All done */

RETURN_FROM_BEGIN_OPERATION:
	P_operation_name = operation_name;
	P_mseg_dir_name = mseg_dir_name;
	P_mseg_entryname = mseg_entryname;
	P_mseg_ptr = mseg_ptr;
	P_rqo_detected = rqo_detected;

	P_code = code;

	return;



/* Return upon completion of the begin_operation entrypoint */

return_from_begin_operation:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	code = p_code;				/* set the result code */
	go to RETURN_FROM_BEGIN_OPERATION;

     end return_from_begin_operation;



/* Salvage the message segment due to internal inconsistencies and return error_table_$bad_segment to our caller */

salvage_and_return_from_begin:
     procedure (p_format_error);

dcl	p_format_error	fixed binary (35) parameter;

	call mseg_utils_$salvage_for_cause (mseg_operation_ptr, p_format_error);

	call return_from_begin_operation (error_table_$bad_segment);

     end salvage_and_return_from_begin;
%page;
/* Finish an operation -- This entrypoint completes the normal processing of an operation whether or not said operation
   will return a non-zero status code to its caller.  This entrypoint will, under control of the finish flags embedded in
   mseg_operation.operation, truncate the segment if its empty and then unlock it.  However, if this operation doesn't
   hold the lock on the segment, this entrypoint will not even perform these actions as some other process may be using
   the segment or it may have been deleted if this is the delete_seg operation.  In any case, however, we turn off
   guaranteed eligibility if we had turned it on earlier.

   WARNING -- Do not call this entrypoint in a cleanup handler.  A cleanup handler must call abort_operation, instead. */

mseg_utils_$finish_operation:
     entry (P_mseg_operation_ptr);

	mseg_operation_ptr = P_mseg_operation_ptr;
	mseg_operation_data_ptr = addr (mseg_operation.operation);

	if ^mseg_operation_data.finish_flags.unlock_segment
	then return;

	mseg_ptr = mseg_operation.mseg_ptr;

	if mseg_operation_data.finish_flags.truncate_if_possible
	then if (mseg_segment.n_messages = 0)		/* truncate only if no messages ... */
		& ^mseg_segment.flags.wakeup_state_set	/* ... and no one is accepting wakeups ... */
		& ^mseg_segment.flags.salvaged	/* ... and it wasn't salvaged */
	     then call hcs_$truncate_seg (mseg_ptr, 1, (0));

	if ^stacq (mseg_segment.lock, (36)"0"b, mseg_data_$lock_id)
	then call set_lock_$unlock (mseg_segment.lock, (0));

	mseg_operation_data.finish_flags.unlock_segment = "0"b;

	if mseg_operation.call_admin_gate
	then call admin_gate_$guaranteed_eligibility_off ();

	return;
%page;
/* Abort an operation -- This entrypoint aborts the currently running operation.  If the operation had locked the message
   segment, this entrypoint will salvage and unlock the segment as it is possible that it has been left in an inconsistent
   state by whatever event has caused the operation to be unwound.  However, this entrypoint will not take these actions
   unless the current operation actually locked the segment; otherwise, we might salvage the segment while it was being
   used by another process.  In any case, however, we turn off guaranteed eligibility if we had turned it on earlier.

   WARNING -- Do not call this entrypoint except in a cleanup handler.  Use finish_operation, instead, for all other
   circumstances. */

mseg_utils_$abort_operation:
     entry (P_mseg_operation_ptr);

	mseg_operation_ptr = P_mseg_operation_ptr;

	if mseg_operation_ptr = null ()		/* caller hasn't even got an mseg_operation yet */
	then return;

	if ^mseg_operation.mseg_ptr_valid		/* no mseg_ptr -- a file system operation, no doubt */
	then return;

	if mseg_operation.mseg_ptr = null ()		/* delete_seg operation will null pointer if successful */
	then return;

	mseg_ptr = mseg_operation.mseg_ptr;
	mseg_operation_data_ptr = addr (mseg_operation.operation);

	if ^mseg_operation_data.finish_flags.unlock_segment
	then return;				/* we dare not do anything if we don't have it locked */

	if ^mseg_operation_data.finish_flags.already_salvaged
	then call mseg_utils_$salvage_for_cause (mseg_operation_ptr, 0, "The operation was terminated abnormally.");

	if ^stacq (mseg_segment.lock, (36)"0"b, mseg_data_$lock_id)
	then call set_lock_$unlock (mseg_segment.lock, (0));

	mseg_operation_data.finish_flags.unlock_segment = "0"b;

	if mseg_operation.call_admin_gate
	then call admin_gate_$guaranteed_eligibility_off ();

	return;
%page;
/* "Queue" to unlock the segment -- This entrypoint is used by those operations which manage the message segment's lock on
   their own when said operation determines that it has locked the segment and that it should, therefore, be unlocked when
   the operation finishes.  (At present, the only operation which uses this protocol is delete_seg.) */

mseg_utils_$request_unlock_on_finish:
     entry (P_mseg_operation_ptr);

	mseg_operation_ptr = P_mseg_operation_ptr;
	mseg_operation_data_ptr = addr (mseg_operation.operation);

	if mseg_operation_data.finish_flags.unlock_segment
	then return;				/* it's already going to be unlocked */

	mseg_ptr = mseg_operation.mseg_ptr;

	/*** Don't bother to "queue" to unlock the segment unless we already hold the lock */

	test_lock = mseg_segment.lock;
	if stacq (test_lock, (36)"0"b, mseg_data_$lock_id)
	then mseg_operation_data.finish_flags.unlock_segment = "1"b;

	return;
%page;
/* Salvage a message segment due to inconsistencies detected by our caller -- Before salvaging, an error report is
   constructed from our caller's error code and, optional, ioa_ control string and arguments.  If we are running in the
   adminitrative ring (ring 1), the report is placed in the SYSERR log; otherwise, it is displayed via sub_err_. */

mseg_utils_$salvage_for_cause:
     entry (P_mseg_operation_ptr, P_code) options (variable);

	mseg_operation_ptr = P_mseg_operation_ptr;
	mseg_operation_data_ptr = addr (mseg_operation.operation);

	if mseg_operation_data.finish_flags.already_salvaged
	then return;				/* don't try to salvage more than once per operation */

	mseg_operation_data.finish_flags.already_salvaged = "1"b;

	mseg_ptr = mseg_operation.mseg_ptr;

	if (mseg_operation_data.operation_id < lbound (mseg_operations_$names, 1))
	     | (mseg_operation_data.operation_id > hbound (mseg_operations_$names, 1))
	then operation_name = "mseg_$unknown_operation";
	else operation_name = mseg_operations_$names (mseg_operation_data.operation_id);


	/*** Determine the segment's pathname, minimum and maximum access classes, max length, and current length --
	     These data are required for proper operation of the salvager.  (Actually, the pathname isn't required but
	     is determined by the same call used to get the access classes.) */

	if mseg_operation.access_info_valid
	then do;					/* we already have the pathname and access classes */
		mseg_dir_name = mseg_operation.access_info.dir_name;
		mseg_entryname = mseg_operation.access_info.entryname;
	     end;

	else do;					/* we must get the pathname and access classes from ring-0 */
		mseg_operation.access_info.version = ENTRY_ACCESS_INFO_VERSION_1;
		call hcs_$get_access_info_seg (mseg_ptr, addr (mseg_operation.access_info), code);
		if code ^= 0			/* can't get the info we need: try for pathname for error */
		then do;
			call hcs_$fs_get_path_name (mseg_ptr, mseg_dir_name, (0), mseg_entryname, path_code);
			call abort_salvage_for_cause ((path_code = 0), CALL_GET_ACCESS_INFO);
		     end;
		mseg_operation.access_info_valid = "1"b;
		mseg_dir_name = mseg_operation.access_info.dir_name;
		mseg_entryname = mseg_operation.access_info.entryname;
	     end;

	call hcs_$get_max_length_seg (mseg_ptr, mseg_max_length, code);
	if code ^= 0
	then call abort_salvage_for_cause ("1"b, CALL_GET_MAX_LENGTH);

	call hcs_$status_long (mseg_dir_name, mseg_entryname, 0b, addr (long_status), null (), code);
	if (code ^= 0) & (code ^= error_table_$no_s_permission)
	then call abort_salvage_for_cause ("1"b, CALL_STATUS_LONG);
	if long_status.type ^= Segment
	then do;
		code = error_table_$not_seg_type;
		call abort_salvage_for_cause ("1"b, CALL_STATUS_LONG);
	     end;
	mseg_cur_length = min ((1024 * long_status.current_length), mseg_max_length);


	/*** Format and log/print the error report */

	prefix_lth = length (rtrim (operation_name)) + length (": ");

	call cu_$arg_count (n_arguments, (0));
	salvage_for_cause_arguments = cu_$arg_list_ptr ();

	begin options (non_quick);

dcl	1 salvage_report	unaligned,
	  2 prefix	character (prefix_lth) unaligned,
	  2 text		character (1024 - prefix_lth) unaligned;

	     salvage_report.prefix = rtrim (operation_name) || ": ";

	     call ioa_$rsnpnnl ("Beginning salvage of ^a for ^a.^[^/^5x^]", salvage_report.text,
		salvage_report_text_lth, pathname_ (mseg_dir_name, mseg_entryname), mseg_operation.caller.group_id,
		(n_arguments > 2));

	     if n_arguments > 2			/* caller has supplied additional information */
	     then do;
		     begin;
dcl	rest_of_salvage_report_text
			character (length (salvage_report.text) - salvage_report_text_lth) unaligned
			defined (salvage_report.text) position (salvage_report_text_lth + 1);
			call ioa_$general_rs (salvage_for_cause_arguments, 3, 4, rest_of_salvage_report_text,
			     callers_report_text_lth, "0"b, "0"b);
		     end;
		     salvage_report_text_lth = salvage_report_text_lth + callers_report_text_lth;
		end;

	     if mseg_operation.call_admin_gate
	     then begin;				/* report via SYSERR -- include entrypoint name in the text */
dcl	salvage_report_text character (prefix_lth + salvage_report_text_lth) unaligned defined (salvage_report)
			position (1);
		     call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), P_code,
			"^a^[^/^5x^]", salvage_report_text, (P_code ^= 0));
		end;

	     else begin;
dcl	salvage_report_text character (salvage_report_text_lth) unaligned defined (salvage_report.text);
		     call sub_err_ (P_code, operation_name, ACTION_DEFAULT_RESTART, null (), 0, "^[^/^]^a",
			(P_code ^= 0), salvage_report_text);
		end;
	end;


	/*** Actually salvage the segment and report the results */

	code = 0;

	call salvage_seg (n_possible_messages, n_messages_recovered);

	if mseg_operation.call_admin_gate
	then call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), 0,
		"^a: Completed salvage of ^a for ^a.^/^5x^d^[ out of ^d possible^;^s^] message^[s^] recovered.",
		operation_name, pathname_ (mseg_dir_name, mseg_entryname), mseg_operation.caller.group_id,
		n_messages_recovered, (n_messages_recovered ^= n_possible_messages), n_possible_messages,
		((n_messages_recovered ^= 1) | (n_possible_messages ^= 1)));

	else call sub_err_ (0, operation_name, ACTION_DEFAULT_RESTART, null (), 0,
		"Completed salvage of ^a for ^a.^/^5x^d^[ out of ^d possible^;^s^] message^[s^] recovered.",
		pathname_ (mseg_dir_name, mseg_entryname), mseg_operation.caller.group_id, n_messages_recovered,
		(n_messages_recovered ^= n_possible_messages), n_possible_messages,
		((n_messages_recovered ^= 1) | (n_possible_messages ^= 1)));

RETURN_FROM_SALVAGE_FOR_CAUSE:
	return;



/* Report our failure to salvage the segment and return to our caller */

abort_salvage_for_cause:
     procedure (p_have_pathname, p_failed_action);

dcl	p_have_pathname	bit (1) aligned parameter;
dcl	p_failed_action	fixed binary parameter;

	if mseg_operation.call_admin_gate
	then call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), code,
		"^a: Unable to salvage ^[^a^s^;^s^p (pathname unknown)^] for ^a.^/^5x^a^[ --^/^5x^]", operation_name,
		p_have_pathname, pathname_ (mseg_dir_name, mseg_entryname), mseg_ptr, mseg_operation.caller.group_id,
		SALVAGER_AND_UPGRADING_ACTIONS (p_failed_action), (code ^= 0));

	else call sub_err_ (code, operation_name, ACTION_DEFAULT_RESTART, null (), 0,
		"^[^/^5x^]^a.^/^5xUnable to salvage ^[^a^s^;^s^p (pathname unknown)^] for ^a.", (code ^= 0),
		SALVAGER_AND_UPGRADING_ACTIONS (p_failed_action), p_have_pathname,
		pathname_ (mseg_dir_name, mseg_entryname), mseg_ptr, mseg_operation.caller.group_id);

	go to RETURN_FROM_SALVAGE_FOR_CAUSE;

     end abort_salvage_for_cause;
%page;
/* Handle a segment fault while trying to lock the message segment -- If the fault occured because the segment is damaged,
   reset the damaged switch, salvage, and retry the locking operation.  If the fault occured for some other reason (e.g.,
   a connection failure), simply abort the attempt to lock the segment and return the reason to our caller. */

seg_fault_handler:
     procedure ();

dcl	1 local_ci	aligned like condition_info;
dcl	local_code	fixed binary (35);

	code = error_table_$segfault;			/* in case we can't determine the actual reason */

	unspec (local_ci) = ""b;
	local_ci.version = condition_info_version_1;

	call find_condition_info_ (null (), addr (local_ci), local_code);

	if local_code = 0				/* found the fault frame ... */
	then if local_ci.mc_ptr ^= null ()		/* ... and the machine conditions ... */
	     then if local_ci.mc_ptr -> mc.errcode ^= 0	/* ... and they provide specific details */
		then code = local_ci.mc_ptr -> mc.errcode;

	if (code = error_table_$seg_busted) & ^mseg_operation_data.begin_flags.dont_check_lock_results
	     & ^mseg_operation_data.finish_flags.already_salvaged
	then do;	/*** The segment is damaged and we haven't already tried to salvage it. */
		call hcs_$set_damaged_sw_seg (mseg_ptr, "0"b, (0));
		call mseg_utils_$salvage_for_cause (mseg_operation_ptr, code);
		if ^stacq (mseg_segment.lock, (36)"0"b, mseg_data_$lock_id)
		then call set_lock_$unlock (mseg_segment.lock, (0));
		return;				/* retry */
	     end;

	else do;	/*** Either it's some other form of segfault or we've already tried to fix it once -- Inform the user
		     that we can't access the segment.  He can either try to fix the segment or delete it. */
		mseg_operation_data.unlock_segment = "0"b;
		mseg_operation_data.truncate_if_possible = "0"b;
		go to RETURN_FROM_BEGIN_OPERATION;
	     end;

     end seg_fault_handler;
%page;
/* Upgrade an old format message segment to the current format -- We are always called with the segment locked. */

upgrade_seg:
     procedure () options (non_quick);

dcl	1 original_mseg_segment_header
			aligned based (original_mseg_ptr) like mseg_segment.header;
dcl	original_mseg_ptr	pointer;

dcl	1 upgraded_mseg_segment_header
			aligned based (upgraded_mseg_ptr) like mseg_segment.header;
dcl	upgraded_mseg_ptr	pointer;

dcl	original_mseg_message_bits
			bit (original_operation.message_info.ms_len) aligned
			based (original_operation.message_info.ms_ptr);

dcl	upgraded_segment	(upgraded_size) bit (36) aligned based;

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

dcl	1 original_operation
			aligned like mseg_operation;
dcl	1 upgraded_operation
			aligned like mseg_operation;

dcl	upgrade_procedure_name
			character (32);
dcl	salvage_old_segment entry (pointer, bit (1) aligned) variable;
dcl	get_old_wakeup_state
			entry (pointer) variable;
dcl	read_old_message	entry (pointer, pointer, fixed binary (35)) variable;

dcl	(original_mseg_dir_name, upgraded_mseg_dir_name)
			character (168);
dcl	(original_mseg_entryname, upgraded_mseg_entryname)
			character (32);
dcl	original_version_picture
			picture "9";

dcl	(salvage_completed, rqo_detected)
			bit (1) aligned;

dcl	path_code		fixed binary (35);
dcl	upgraded_size	fixed binary (19);
dcl	(n_upgraded_blocks_allocated, n_upgraded_header_blocks, n_messages_discarded)
			fixed binary (18);
dcl	original_version	fixed binary;


	mseg_operation_data.finish_flags.already_salvaged = "1"b;
						/* prevent the current salvager from destroying the segment */

	original_operation.message_info.ms_ptr,		/* for cleanup handler */
	     upgraded_mseg_ptr = null ();

	on cleanup call cleanup_after_upgrade_seg ();

	code = 0;


	/*** Determine the segment's pathname, minimum and maximum access classes, and max length -- These data are
	     required for proper upgrading of the segment.  (Actually, the pathname isn't required but is determined by
	     the same call used to get the access classes.) */

	original_operation = mseg_operation;		/* we dare not change our caller's operation */
	original_mseg_ptr = original_operation.mseg_ptr;

	if original_operation.access_info_valid
	then do;					/* we already have the pathname and access classes */
		original_mseg_dir_name = original_operation.access_info.dir_name;
		original_mseg_entryname = original_operation.access_info.entryname;
	     end;

	else do;					/* we must get the pathname and access classes from ring-0 */
		original_operation.access_info.version = ENTRY_ACCESS_INFO_VERSION_1;
		call hcs_$get_access_info_seg (original_mseg_ptr, addr (original_operation.access_info), code);
		if code ^= 0			/* can't get the info we need: try for pathname for error */
		then do;
			call hcs_$fs_get_path_name (original_mseg_ptr, original_mseg_dir_name, (0),
			     original_mseg_entryname, path_code);
			call abort_upgrade_seg ((path_code = 0), CALL_GET_ACCESS_INFO);
		     end;
		original_operation.access_info_valid = "1"b;
		original_mseg_dir_name = original_operation.access_info.dir_name;
		original_mseg_entryname = original_operation.access_info.entryname;
	     end;

	call hcs_$get_max_length_seg (original_mseg_ptr, mseg_max_length, code);
	if code ^= 0
	then call abort_upgrade_seg ("1"b, CALL_GET_MAX_LENGTH);


	/*** Compute the size of the upgraded segment's header and block map and verify that there will be room in the
	     segment for at least one message */

	n_upgraded_blocks_allocated = divide (mseg_max_length, mseg_data_$block_size, 18, 0);

	n_upgraded_header_blocks =
	     divide
	     ((currentsize (upgraded_mseg_segment_header) + divide ((n_upgraded_blocks_allocated + 35), 36, 18, 0)
	     + mseg_data_$block_size - 1), mseg_data_$block_size, 18, 0);

	if n_upgraded_blocks_allocated < n_upgraded_header_blocks
	then do;
		code = error_table_$invalid_max_length;
		call abort_upgrade_seg ("1"b, 0);
	     end;


	/*** Find the proper support procedure -- A procedure named "mseg_upgrade_from_vN_", where N is a version
	     number, exists for any older version of message segment which can be upgraded to the current version.  This
	     procedure contains the three entrypoints which are required to upgrade that version of message segment --
	     salvage, get_wakeup_state, and read_message. */

	original_version = original_mseg_segment_header.version;

	upgrade_procedure_name = "mseg_upgrade_from_v" || convert (original_version_picture, original_version) || "_";

	call hcs_$make_entry (codeptr (upgrade_seg), upgrade_procedure_name, "salvage", salvage_old_segment, code);
	if code ^= 0
	then call abort_upgrade_seg ("1"b, FINDING_SUPPORT_PROCEDURE);

	call hcs_$make_entry (codeptr (upgrade_seg), upgrade_procedure_name, "get_wakeup_state", get_old_wakeup_state,
	     code);
	if code ^= 0
	then call abort_upgrade_seg ("1"b, FINDING_SUPPORT_PROCEDURE);

	call hcs_$make_entry (codeptr (upgrade_seg), upgrade_procedure_name, "read_message", read_old_message, code);
	if code ^= 0
	then call abort_upgrade_seg ("1"b, FINDING_SUPPORT_PROCEDURE);


	/*** Salvage the segment using its version's salvager */

	call salvage_old_segment (addr (original_operation), salvage_completed);

	if ^salvage_completed
	then do;
		code = 0;				/* the salvager hasalready given a detailed accouting ... */
		call abort_upgrade_seg ("1"b, SALVAGING_ORIGINAL_SEGMENT);
	     end;


	/*** Initialize the upgraded message segment -- This message segment is actually a temporary in the process
	     directory with an associated mseg_operation that will satisfy mseg_message_$add_message_for_mseg. */

	on record_quota_overflow
	     begin;
		/*** Any RQO that occurs between now and the completion of the message copying loop is considered
		     fatal to the conversion process.  This decision is proper as the only possible RQOs are either
		     while reading the original segment or writing into the upgraded segment.  As the upgraded segment
		     is in the process directory, an RQO writing into it is clearly fatal.  An RQO while reading the
		     original segment is fatal as, after the above salvaging, the original can not contain any message
		     which tries to reference a block which is in a page of zeroes because only a zero page can cause
		     an RQO while reading. */
		code = error_table_$rqover;
		call abort_upgrade_seg ("1"b, CREATING_UPGRADED_TEMPORARY);
	     end;

	upgraded_operation = original_operation;
	upgraded_operation.mseg_ptr_valid,		/* the original segment is never the upgraded one ... */
	     upgraded_operation.access_info_valid = "0"b; /* ... and its access info doesn't apply either */
	upgraded_operation.suppress_access_checks = "1"b; /* must be able to copy all messages */

	call get_temp_segment_ (operation_name, upgraded_mseg_ptr, code);
	if code ^= 0
	then call abort_upgrade_seg ("1"b, PREPARING_UPGRADED_TEMPORARY);

	upgraded_operation.mseg_ptr = upgraded_mseg_ptr;
	upgraded_operation.mseg_ptr_valid = "1"b;

	call mseg_utils_$begin_operation (mseg_operations_$copy_seg_target, addr (upgraded_operation), ((64)" "),
	     upgraded_mseg_dir_name, upgraded_mseg_entryname, upgraded_mseg_ptr, rqo_detected, code);
	if rqo_detected
	then code = error_table_$rqover;
	if code ^= 0
	then call abort_upgrade_seg ("1"b, PREPARING_UPGRADED_TEMPORARY);

	upgraded_mseg_segment_header.n_messages, upgraded_mseg_segment_header.date_time_last_salvaged = 0;
	unspec (upgraded_mseg_segment_header.message_chain) = ""b;
	string (upgraded_mseg_segment_header.flags) = ""b;
	unspec (upgraded_mseg_segment_header.hash_table) = ""b;

	upgraded_mseg_segment_header.sentinel = MSEG_SEGMENT_SENTINEL;
	upgraded_mseg_segment_header.version = MSEG_SEGMENT_VERSION_5;

	upgraded_mseg_segment_header.block_size = mseg_data_$block_size;
	upgraded_mseg_segment_header.n_blocks_allocated = n_upgraded_blocks_allocated;
	upgraded_mseg_segment_header.n_blocks_unused = n_upgraded_blocks_allocated - n_upgraded_header_blocks;

	upgraded_mseg_ptr -> mseg_segment.block_map.map = copy ("1"b, n_upgraded_header_blocks);


	/*** Upgrade the segment's wakeup acceptance state */

	unspec (upgraded_mseg_segment_header.wakeup_state) = ""b;

	call get_old_wakeup_state (addr (original_operation));

	if original_operation.wakeup_state_valid
	then do;
		upgraded_mseg_segment_header.wakeup_state_set = "1"b;
		upgraded_mseg_segment_header.wakeup_state.state = original_operation.wakeup_state;
	     end;


	/*** Upgrade the messages -- A message is upgraded by reading it from the original segment and adding it to the
	     upgraded segment in the process directory.  If we can't read a message, we consider this to be a fatal
	     error in the conversion process.  If we can't add a message because it's too large, we remember the event
	     but continue copying.  We must continue copying because subsequent messages may be small enough to fit in
	     the upgraded segment.  Our final report when the upgrade is complete will report any lost messages. */

	original_operation.suppress_access_checks,	/* insure that all messages are copied */
	     upgraded_operation.suppress_access_checks = "1"b;
	upgraded_operation.add_message_info_all_valid = "1"b;

	n_messages_discarded = 0;

	original_operation.message_info.version = MSEG_MESSAGE_INFO_V1;
	string (original_operation.message_info.control_flags) = ""b;
	original_operation.message_info.ms_ptr = null ();

	system_area_ptr = get_system_free_area_ ();

	original_operation.message_info.message_code = MSEG_READ_FIRST;
	call read_old_message (addr (original_operation), system_area_ptr, code);

	do while (code = 0);

	     upgraded_operation.message_info = original_operation.message_info;
	     substr (upgraded_operation.message_info.ms_id, 1, 18) = ""b;

	     call mseg_message_$add_message_for_mseg (addr (upgraded_operation), operation_name, code);
	     if (code = error_table_$bigarg) | (code = error_table_$notalloc)
	     then n_messages_discarded = n_messages_discarded + 1;
	     else if code ^= 0
	     then call abort_upgrade_seg ("1"b, CREATING_UPGRADED_TEMPORARY);

	     if original_operation.message_info.ms_ptr ^= null ()
	     then do;
		     free original_mseg_message_bits in (system_area);
		     original_operation.message_info.ms_ptr = null ();
		end;

	     original_operation.message_info.message_code = MSEG_READ_AFTER_SPECIFIED;
	     call read_old_message (addr (original_operation), system_area_ptr, code);
	end;

	if code ^= error_table_$no_message		/* we were unable to read a message */
	then call abort_upgrade_seg ("1"b, CREATING_UPGRADED_TEMPORARY);

	revert record_quota_overflow;

	code = 0;					/* message copying succeeded! */


	/*** Copy the upgraded segment into place -- If an RQO occurs while moving the segment back into place, we will
	     consider the conversion completed but we will also salvage the segment with the current salvager to discard
	     any incomplete messages. */

	upgraded_size =
	     upgraded_mseg_segment_header.block_size
	     * (upgraded_mseg_segment_header.n_blocks_allocated - upgraded_mseg_segment_header.n_blocks_unused);

	call hcs_$truncate_seg (original_mseg_ptr, upgraded_size, (0));

	on record_quota_overflow
	     begin;
		mseg_operation_data.finish_flags.already_salvaged = "0"b;
		call mseg_utils_$salvage_for_cause (mseg_operation_ptr, error_table_$rqover,
		     "Some messages will be lost as a result of upgrading this segment.");
		go to COMPLETE_UPGRADE_AFTER_RQO;
	     end;

	original_mseg_ptr -> upgraded_segment = upgraded_mseg_ptr -> upgraded_segment;

	revert record_quota_overflow;

COMPLETE_UPGRADE_AFTER_RQO:
	call cleanup_after_upgrade_seg ();


	/*** The segment has been upgraded -- Display a report only if we were forced to discard any messages */

	if n_messages_discarded > 0
	then if original_operation.call_admin_gate
	     then call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), 0,
		     "^a: Upgraded ^a from version ^d to version ^d for ^a.^/^5x^d message^[s^] were deleted.",
		     operation_name, pathname_ (original_mseg_dir_name, original_mseg_entryname), original_version,
		     MSEG_SEGMENT_VERSION_5, original_operation.caller.group_id, n_messages_discarded,
		     (n_messages_discarded ^= 1));

	     else call sub_err_ (0, operation_name, ACTION_DEFAULT_RESTART, null (), 0,
		     "Upgraded ^a from version ^d to version ^d for ^a.^/^5x^d message^[s^] were deleted.",
		     pathname_ (original_mseg_dir_name, original_mseg_entryname), original_version,
		     MSEG_SEGMENT_VERSION_5, original_operation.caller.group_id, n_messages_discarded,
		     (n_messages_discarded ^= 1));

	mseg_operation_data.finish_flags.already_salvaged = "0"b;
						/* new problems during the operation should force a salvage */

	return;



/* Cleanup after upgrading a message segment */

cleanup_after_upgrade_seg:
     procedure ();

	if original_operation.message_info.ms_ptr ^= null ()
	then do;
		free original_mseg_message_bits in (system_area);
		original_operation.message_info.ms_ptr = null ();
	     end;

	if upgraded_mseg_ptr ^= null ()
	then do;
		call release_temp_segment_ (operation_name, upgraded_mseg_ptr, (0));
		upgraded_mseg_ptr = null ();
	     end;

	return;

     end cleanup_after_upgrade_seg;



/* Abort the attempt to upgrade a message segment -- We must report the failure and then return
   error_table_$improper_data_format to the caller of mseg_utils_$begin_operation. */

abort_upgrade_seg:
     procedure (p_have_pathname, p_failed_action);

dcl	p_have_pathname	bit (1) aligned parameter;
dcl	p_failed_action	fixed binary parameter;

	if original_operation.call_admin_gate
	then call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), code,
		"^a: Unable to upgrade ^[^a^s^;^s^p (pathname unknown)^] from version ^d to version ^d for ^a.^/^5x^[^a^[ --^/^5x^]^;^s^[^/^5x^]^]",
		operation_name, p_have_pathname, pathname_ (original_mseg_dir_name, original_mseg_entryname),
		original_mseg_ptr, original_version, MSEG_SEGMENT_VERSION_5, original_operation.caller.group_id,
		(p_failed_action ^= 0), SALVAGER_AND_UPGRADING_ACTIONS (p_failed_action), (code ^= 0));

	else call sub_err_ (code, operation_name, ACTION_DEFAULT_RESTART, null (), 0,
		"^[^[^/^5x^]^a.^;^s^s^]^/^5xUnable to upgrade ^[^a^s^;^s^p (pathname unknown)^] from version ^d to version ^d for ^a.",
		(p_failed_action ^= 0), (code ^= 0), SALVAGER_AND_UPGRADING_ACTIONS (p_failed_action),
		p_have_pathname, pathname_ (original_mseg_dir_name, original_mseg_entryname), original_mseg_ptr,
		original_version, MSEG_SEGMENT_VERSION_5, original_operation.caller.group_id);

	code = error_table_$improper_data_format;

	go to RETURN_FROM_BEGIN_OPERATION;

     end abort_upgrade_seg;

     end upgrade_seg;
%page;
/* Salvage a message segment */

salvage_seg:
     procedure (p_n_possible_messages, p_n_messages_recovered) options (non_quick);

dcl	(p_n_possible_messages, p_n_messages_recovered)
			fixed binary (18);
dcl	(n_possible_messages, n_messages_recovered)
			fixed binary (18);

/* format: idind30 */

dcl	1 local_mseg_segment_header	aligned like mseg_segment.header;

dcl	1 local_message_block	aligned,
	  2 header		aligned like message_block_header,
	  2 data_space,
	    3 data		bit (324) unaligned,
	  2 descriptor		aligned like message_descriptor;

dcl	1 local_wakeup_state	aligned like mseg_wakeup_state;

dcl	1 old_wakeup_state		aligned,
	  2 state,
	    3 switches		aligned,
	      4 allow_normal	bit (1) unaligned,
	      4 allow_urgent	bit (1) unaligned,
	      4 pad		bit (34) unaligned,
	    3 lock_id		bit (36) aligned,
	    3 event_channel		fixed bin (71),
	    3 process_id		bit (36) aligned,
	  2 pad			(64 - 5) bit (36) aligned;

/* format: idind20 */

dcl	mseg_segment_blocks (n_blocks_available) bit (36 * probable_block_size) aligned based (mseg_ptr);

dcl	prev_md_ptr	pointer;

dcl	mseg_segment_aim_range
			(2) bit (72) aligned;

dcl	block_size_unknown	bit (1) aligned;

dcl	(probable_block_size, n_blocks_available, n_header_blocks, last_used_block, max_blocks_per_message,
	n_blocks_recovered, last_recovered_block, block_id, n_message_blocks, message_block_idx, message_block_id,
	last_block_checked, next_unused_block, message_index)
			fixed binary (18);
dcl	(max_bits_in_first_block, max_bits_in_other_blocks)
			fixed binary;
dcl	hash_idx		fixed binary (9);


	/*** All RQOs are fatal -- Clearly any RQO while touching a page with data in it will prevent us from
	     successully salvaging the segment.  Further, if we touch a zero page that causes an RQO, we will have
	     increased the records used value and, as a result, we'll loop with an RQO until that page is flushed which
	     may be a very long time.  Therefore, we'll abort the salvage rather than loop. */

	on record_quota_overflow
	     begin;
		code = error_table_$rqover;
		call abort_salvage_for_cause ("1"b, REBUILDING_SEGMENT);
	     end;


	/*** Force the segment lock to insure that no one can get at the segment while we salvage it */

	mseg_segment.lock = mseg_data_$lock_id;
	mseg_operation_data.finish_flags.unlock_segment = "1"b;

	mseg_segment.salvage_in_progress = "1"b;

	mseg_segment_aim_range (1) = mseg_operation.access_info.parent_access_class;
	mseg_segment_aim_range (2) = mseg_operation.access_info.access_class;


	/*** Determine the block size used for this segment -- If the block size in the header does not yield the
	     correct number of available blocks (i.e., more blocks than are occupied by the header and block map), we
	     will assume that the segment uses the default block size.  If the default block size also fails, we will
	     abort our attempts at salvaging the segment. */

	block_size_unknown = "1"b;			/* ... really need do until */

	do probable_block_size = mseg_segment.block_size repeat (mseg_data_$block_size) while (block_size_unknown);

	     if (probable_block_size > (currentsize (message_block_header) + currentsize (message_descriptor)))
		& (probable_block_size < mseg_max_length)
	     then do;				/* this block size is large enough for proper operation */

		     n_blocks_available = divide (mseg_max_length, probable_block_size, 18, 0);
						/* format: off */
		     n_header_blocks =
			divide ((currentsize (mseg_segment_header) + divide ((n_blocks_available + 35), 36, 18, 0)
			         + probable_block_size - 1),
			        probable_block_size, 18, 0);
						/* format: on */
		     if (n_blocks_available > n_header_blocks) | (probable_block_size = mseg_data_$block_size)
		     then block_size_unknown = "0"b;	/* stop when the blocksize is OK or the default */
		end;
	end;

	if n_blocks_available <= n_header_blocks	/* couldn't get a workable block size */
	then call abort_salvage_for_cause ("1"b, COMPUTING_BLOCK_SIZE);

	max_blocks_per_message = divide (mseg_data_$max_message_size, probable_block_size, 18, 0);


	/*** Find the last non-zero block in the segment -- By definition, the messages in a correctly formatted message
	     segment will never contain a block which is entirely zeroes.  Therefore, the last non-zero block in the
	     segment is the upper bound of the blocks which we must examine for valid messages.  (The lower bound, of
	     course, is the first block after the block map.) */

	last_used_block = divide (mseg_cur_length, probable_block_size, 18, 0);
						/* hcs_$status_long has told us in which page to find it */


	/*** Compute the maximum amount of data which will fit into the first block and all subsequent blocks of a
	     message -- PL/I can perform this computation for us provided that we have valid values for
	     mseg_segment.block_size and message_block_header.data_lth.  Because we don't want to actually change the
	     segment until we've completed recovering messages, we temporarily use automatic copies of a message segment
	     header and a message block to perform these computations. */

	mseg_ptr = addr (local_mseg_segment_header);
	mseg_segment.block_size = probable_block_size;

	mb_ptr = addr (local_message_block);
	message_block_header.data_lth = 0;

	max_bits_in_first_block = length (first_message_block.pad);
	max_bits_in_other_blocks = length (other_message_block.pad);

	mseg_ptr = mseg_operation.mseg_ptr;


/* Begin the actual reconstruction of the segment */

RECONSTRUCT_THE_SEGMENT:
	begin;

dcl	1 new_block_map	aligned,
	  2 map		bit (n_blocks_available) unaligned;

dcl	1 nonzero_block_map aligned,
	  2 map		bit (n_blocks_available) unaligned;

dcl	1 message_id_ptrs	aligned,
	  2 n_ptrs	fixed binary (18),
	  2 ptrs		(n_blocks_available) pointer unaligned;

dcl	1 sorted_message_indeces
			aligned,
	  2 n_indeces	fixed binary (18),
	  2 indeces	(n_blocks_available) fixed binary (18);

dcl	message_offsets	(n_blocks_available) fixed binary (18) unsigned;
dcl	message_ids	(n_blocks_available) bit (72) aligned;
dcl	block_offsets	(max_blocks_per_message) fixed binary (18) unsigned;

	     new_block_map.map = copy ("1"b, n_header_blocks);
	     nonzero_block_map.map = copy ("1"b, n_header_blocks);

	     n_blocks_recovered, last_recovered_block = n_header_blocks;


	     /*** Examine the message blocks -- We check each message block individually to see if it might be the first
		block of a message.  If it passes the preliminary test, we assume it is the beginning of a message and
		we then carefully check the entire possible message for validity.  If it passes all of our checks, we
		record it as a recovered message and mark all of its blocks allocated. */

	     n_possible_messages, n_messages_recovered = 0;

	     do block_id = (n_header_blocks + 1) to last_used_block;

		substr (nonzero_block_map.map, block_id, 1) = (mseg_segment_blocks (block_id) ^= ""b);

		if possible_message (block_id)
		then do;

			n_possible_messages = n_possible_messages + 1;

			if valid_message (block_id)
			then do;

				n_messages_recovered = n_messages_recovered + 1;

				message_offsets (n_messages_recovered) = block_offsets (1);
				message_ids (n_messages_recovered) = message_descriptor.ms_id;

				do message_block_idx = 1 to n_message_blocks;
				     message_block_id =
					divide (block_offsets (message_block_idx), probable_block_size, 18, 0)
					+ 1;
				     substr (new_block_map.map, message_block_id, 1) = "1"b;
				     n_blocks_recovered = n_blocks_recovered + 1;
				     last_recovered_block = max (last_recovered_block, message_block_id);
				end;
			     end;
		     end;
	     end;


	     /*** Zero the unused blocks -- We can easily zero those unused blocks beyond the last block recovered by
		truncation.  The intervening unused blocks, however, must be zeroed individually. */

	     call hcs_$truncate_seg (mseg_ptr, (last_recovered_block * probable_block_size), (0));

	     last_block_checked = n_header_blocks;	/* nothing in the header/block map is unused */

	     do while (last_block_checked < last_recovered_block);

		begin;
dcl	rest_of_block_map	bit (last_recovered_block - last_block_checked) unaligned
			defined (new_block_map.map) position (last_block_checked + 1);
		     next_unused_block = index (rest_of_block_map, "0"b);
		end;

		if next_unused_block = 0
		then last_block_checked = last_recovered_block;

		else do;
			last_block_checked = last_block_checked + next_unused_block;
			begin;
dcl	nonzero_indicator	bit (1) unaligned defined (nonzero_block_map.map) position (last_block_checked);
dcl	the_block		bit (36 * probable_block_size) aligned defined (mseg_segment_blocks (last_block_checked));
			     if nonzero_indicator
			     then the_block = ""b;
			end;
		     end;
	     end;


	     /*** Reconstruct the message chains -- Sort the recovered messages by their IDs before building the chains
		to insure that reading forward/backward will work properly. */

	     message_id_ptrs.n_ptrs, sorted_message_indeces.n_indeces = n_messages_recovered;

	     do message_index = 1 to n_messages_recovered;
		message_id_ptrs.ptrs (message_index) = addr (message_ids (message_index));
		sorted_message_indeces.indeces (message_index) = message_index;
	     end;

	     call sort_items_indirect_$bit (addr (message_id_ptrs), addr (sorted_message_indeces),
		length (message_ids (1)));

	     unspec (mseg_segment.message_chain) = ""b;
	     unspec (mseg_segment.hash_table) = ""b;

	     prev_md_ptr = null ();

	     do message_index = 1 to n_messages_recovered;

		mb_ptr = setwordno (mseg_ptr, message_offsets (sorted_message_indeces.indeces (message_index)));
		md_ptr = addr (first_message_block.descriptor);

		message_descriptor.message_chain.prev_message = mseg_segment.message_chain.last_message;
		message_descriptor.message_chain.next_message = 0;

		if mseg_segment.message_chain.first_message = 0
		then mseg_segment.message_chain.first_message = wordno (mb_ptr);
		else prev_md_ptr -> message_descriptor.message_chain.next_message = wordno (mb_ptr);

		mseg_segment.message_chain.last_message = wordno (mb_ptr);

		hash_idx = fixed (substr (message_descriptor.ms_id, 64, 9), 9, 0);
		message_descriptor.prev_message_in_hash_chain = mseg_segment.hash_table.last_message (hash_idx);
		mseg_segment.hash_table.last_message (hash_idx) = wordno (mb_ptr);

		prev_md_ptr = md_ptr;
	     end;


	     /*** Reconstruct the wakeup state */

	     if mseg_segment.wakeup_state_set		/* segment claims to have a wakeup state */
	     then if mseg_segment.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1
		then				/* ... which appears to be the new style */
		     local_wakeup_state = mseg_segment.wakeup_state.state;

		else do;				/* ... which appears to be the old style */
			unspec (old_wakeup_state) = unspec (header_msg);
			local_wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1;
			string (local_wakeup_state.flags) = string (old_wakeup_state.switches);
			local_wakeup_state.event_channel = old_wakeup_state.event_channel;
			local_wakeup_state.access_class = header_msg_access_class;
			local_wakeup_state.process_id = old_wakeup_state.process_id;
			local_wakeup_state.lock_id = old_wakeup_state.lock_id;
		     end;

	     else local_wakeup_state.version = "";	/* no wakeup state is present */

	     if local_wakeup_state.version ^= MSEG_WAKEUP_STATE_VERSION_1
	     then do;
RESET_SEGMENT_WAKEUP_STATE:
		     mseg_segment.wakeup_state_set = "0"b;
		     unspec (mseg_segment.wakeup_state) = ""b;
		end;

	     else if (local_wakeup_state.process_id = ""b) | (local_wakeup_state.lock_id = ""b)
	     then go to RESET_SEGMENT_WAKEUP_STATE;

	     else if ^aim_check_$in_range (local_wakeup_state.access_class, mseg_segment_aim_range)
	     then go to RESET_SEGMENT_WAKEUP_STATE;

	     else do;				/* wakeup state looks OK: put it back into the segment */
		     mseg_segment.wakeup_state_set = "1"b;
		     mseg_segment.wakeup_state.state = local_wakeup_state;
		     mseg_segment.header.wakeup_state.pad = ""b;
		end;


/* Complete reconstruction of the header and block map and then return to our caller */

	     p_n_possible_messages = max (n_possible_messages, mseg_segment.n_messages);
	     p_n_messages_recovered = n_messages_recovered;

	     mseg_segment.n_messages = n_messages_recovered;

	     mseg_segment.block_size = probable_block_size;
	     mseg_segment.n_blocks_allocated = n_blocks_available;
	     mseg_segment.n_blocks_unused = n_blocks_available - n_blocks_recovered;

	     mseg_segment.block_map.map = new_block_map.map;

	     mseg_segment.modification_in_progress, mseg_segment.salvage_in_progress = "0"b;
	     mseg_segment.salvaged = "1"b;

	     mseg_segment.sentinel = MSEG_SEGMENT_SENTINEL;
	     mseg_segment.header.version = MSEG_SEGMENT_VERSION_5;

	     mseg_segment.date_time_last_salvaged = clock ();

	     return;
%page;
/* Determine if the specified block might be the first block of a message */

possible_message:
     procedure (p_block_id) returns (bit (1) aligned);

dcl	p_block_id	fixed binary (18) parameter;

	if substr (new_block_map.map, p_block_id, 1) = "1"b
	then call not_a_message ();			/* this block is already used by another message */

	mb_ptr = setwordno (mseg_ptr, (p_block_id - 1) * probable_block_size);

	if ^first_message_block.descriptor_present	/* there's no descriptor in this block */
	then call not_a_message ();

	md_ptr = addr (first_message_block.descriptor);

	if message_descriptor.sentinel ^= MESSAGE_DESCRIPTOR_SENTINEL
	then call not_a_message ();			/* the descriptor isn't properly formatted */

	if message_descriptor.ms_id = ""b		/* the "message" doesn't have a valid message ID */
	then call not_a_message ();

	do message_index = 1 to n_messages_recovered;
	     if message_ids (message_index) = message_descriptor.ms_id
	     then call not_a_message ();		/* the "message" has a duplicate message ID */
	end;

	if (message_descriptor.ms_len < 0) | (message_descriptor.ms_len > (36 * mseg_data_$max_message_size))
	then call not_a_message ();			/* the "message" is too small or too large to be real */

	if ^aim_check_$in_range (message_descriptor.ms_access_class, mseg_segment_aim_range)
	then call not_a_message ();			/* message with this access class can't be in this segment */

	if ^aim_check_$greater_or_equal (message_descriptor.ms_access_class, message_descriptor.sender_authorization)
	then if (aim_util_$get_privileges (message_descriptor.sender_authorization) & sys_info$ring1_privilege) = ""b
	     then call not_a_message ();		/* sender couldn't add it without privileges he didn't have */

	/*** Control arrives here only if this block contains a plausible message */

	return ("1"b);


/* Control arrives here if the block does not contain a plausible message */

not_a_message:
     procedure ();

	go to RETURN_NOT_A_MESSAGE;

     end not_a_message;

RETURN_NOT_A_MESSAGE:
	return ("0"b);

     end possible_message;
%page;
/* Validate that a probable message is, in fact, a real message -- We must check all the blocks which are claimed to be
   part of this message for validity.  We don't have to check the message descriptor itself, however, as that has already
   been done for us by the possible_message internal procedure and, in fact, md_ptr still locates the descriptor. */

valid_message:
     procedure (p_block_id) returns (bit (1) aligned);

dcl	p_block_id	fixed binary (18) parameter;

dcl	first_block	bit (1) aligned;
dcl	actual_ms_len	fixed binary (24);
dcl	block_offset	fixed binary (18) unsigned;

	block_offset = (p_block_id - 1) * probable_block_size;

	first_block = "1"b;				/* this is the first block */
	n_message_blocks = 0;			/* nothing valid yet */
	actual_ms_len = 0;

	do while (block_offset ^= 0);

	     if mod (block_offset, probable_block_size) ^= 0
	     then call not_a_message ();		/* it's not a valid block offset */

	     message_block_id = divide (block_offset, probable_block_size, 18, 0) + 1;

	     if (message_block_id <= n_header_blocks) | (message_block_id > n_blocks_available)
	     then call not_a_message ();		/* this block is not within the segment */

	     if substr (new_block_map.map, message_block_id, 1) = "1"b
	     then call not_a_message ();		/* this block is already in use in another message */

	     do message_block_idx = 1 to n_message_blocks;
		if block_offsets (message_block_idx) = block_offset
		then call not_a_message ();		/* this block is already in this message */
	     end;

	     if n_message_blocks = max_blocks_per_message
	     then call not_a_message ();		/* this "message" has too many blocks */

	     n_message_blocks = n_message_blocks + 1;
	     block_offsets (n_message_blocks) = block_offset;

	     mb_ptr = setwordno (mseg_ptr, block_offset);

	     if message_block_header.data_lth < 0	/* a block can't have a negative length! */
	     then call not_a_message ();

	     if first_block
	     then do;				/* the first block -- just check its length */
		     if message_block_header.data_lth > max_bits_in_first_block
		     then call not_a_message ();	/* too many bits to fit in the block */
		     if message_block_header.next_block ^= 0
		     then if message_block_header.data_lth ^= max_bits_in_first_block
			then call not_a_message ();	/* there's more to come but this block's not full */
		end;

	     else do;				/* all other blocks ... */
		     if message_block_header.descriptor_present
		     then call not_a_message ();	/* a descriptor when there shouldn't be one */
		     if message_block_header.data_lth > max_bits_in_other_blocks
		     then call not_a_message ();	/* too many bits to fit in the block */
		     if message_block_header.next_block ^= 0
		     then if message_block_header.data_lth ^= max_bits_in_other_blocks
			then call not_a_message ();	/* there's more to come but this block's not full */
		end;

	     actual_ms_len = actual_ms_len + message_block_header.data_lth;
	     if actual_ms_len > message_descriptor.ms_len
	     then call not_a_message ();		/* we've found more bits than supposedly are in the message */

	     block_offset = message_block_header.next_block;
	     first_block = "0"b;
	end;

	if actual_ms_len < message_descriptor.ms_len
	then call not_a_message ();			/* the message isn't as long as it should be */

	/*** Control arrives here only if the message is valid */

	return ("1"b);


/* Control arrives here if the message is not valid */

not_a_message:
     procedure ();

	go to RETURN_NOT_A_MESSAGE;

     end not_a_message;

RETURN_NOT_A_MESSAGE:
	return ("0"b);

     end valid_message;

	end RECONSTRUCT_THE_SEGMENT;

/* format: off */
%page; %include mseg_message;
/* format: on */

     end salvage_seg;

/* format: off */
%page; %include mseg_data_;
%page; %include mseg_segment;
%page; %include mseg_wakeup_state;
%page; %include mseg_operation;
%page; %include mseg_operation_data;
%page; %include mseg_operations_;
%page; %include mseg_message_info;
%page; %include entry_access_info;
%page; %include mseg_format_errors_;
%page; %include sub_err_flags;
%page; %include syserr_constants;
%page; %include condition_info;
%skip; %include mc;
%page; %include status_structures;
%page;

/* BEGIN MESSAGE DOCUMENTATION


   Message:
   mseg_$OPERATION: Beginning salvage of PATH for USER_ID.  REASON

   S:	$log

   T:	$run

   M:	The message segment primitives operation OPERATION detected an
	internal inconsistency in the message segment or mailbox PATH and
	has requested that the segment be salvaged.  REASON provides an
	explanation of why the operation invoked the salvager.

   A:	$ignore


   Message:
   mseg_$OPERATION: Completed salvage of PATH for USER_ID.
	N {out of M possible} messages recovered.

   S:	$log

   T:	$run

   M:	The salvage of the message segment or mailbox PATH requested by the
	message segment primitives operation OPERATION has been completed.
	Of the M messages which might have been in the segment, only N could
	be recovered; the others have been deleted.  If all possible
	messages were recovered, the "out of M possible" phrase is omitted
	from the message.

   A:	$inform_sa
	The administrator may wish to notify the owner of the segment that
	some of his messages have been lost.


   Message:
   mseg_$OPERATION: Unable to salvage PTR (pathname unknown) for USER_ID.
	Call to hcs_$get_access_info_seg failed.  REASON

   S:	$log

   T:	$run

   M:	$err
	OPERATION identifies the message segment primitives operation which
	provoked the attempted salvage.  PTR is USER_ID's pointer to the
	message segment or mailbox which could not be salvaged.  REASON
	provides additional information about the failure of the call to
	hcs_$get_access_info_seg.

   A:	$inform


   Message:
   mseg_$OPERATION: Unable to salvage PATH for USER_ID.  Rebuilding the
	contents of the message segment -- Record quota overflow.

   S:	$log

   T:	$run

   M:	The salvage of the message segment or mailbox PATH requested by the
	message segment primitives operation OPERATION failed due to a lack
	of quota.  The segment in question will remain inaccessible until
	the salvage can be successfully completed.

   A:	$inform_sa
	In order to make the message segment or mailbox accessible again,
	the administrator must increase the quota available to the segment
	to any value greater than the current length of the segment.  The
	administrator should then attempt to use the segment to allow the
	salvager to be run to completion.


   Message:
   mseg_$OPERATION: Unable to salvage PATH for USER_ID.  REASON

   S:	$log

   T:	$run

   M:	$err
	OPERATION identifies the message segment primitives operation which
	provoked the attempted salvage.  PATH is the pathname of the message
	segment or mailbox which could not be salvaged.  REASON provides
	additional information about the failure of the attempted salvage.

   A:	$inform


   Message:
   mseg_$OPERATION: Upgraded PATH from version N to version 5 for USER_ID.
	M messages were deleted.

   S:	$log

   T:	$run

   M:	The format of the message segment or mailbox PATH was upgraded from
	the old format known as "version N" to the latest format.  However,
	M messages in the segment could not be upgraded to the current
	format because there was no room for them in the segment.  As a
	consequence, these messages were deleted.  OPERATION identifies the
	message segment primitives operation which required that the segment
	be upgraded.

   A:	$inform_sa
	The administrator may wish to notify the owner of the segment that
	some of his messages have been lost.


   Message:
   mseg_$OPERATION: Unable to upgrade PTR (pathname unknown) from version N
	to version 5 for USER_ID.  Call to hcs_$get_access_info_seg failed.
	REASON

   S:	$log

   T:	$run

   M:	$err
	OPERATION identifies the message segment primitives operation which
	required that the segment be upgraded.  PTR is USER_ID's pointer to
	the message segment or mailbox which could not be upgraded.  REASON
	provides additional information about the failure of the call to
	hcs_$get_access_info_seg.

   A:	$inform


   Message:
   mseg_$OPERATION: Unable to upgrade PATH from version N to version 5 for
	USER_ID.  REASON

   S:	$log

   T:	$run

   M:	$err
	OPERATION identifies the message segment primitives operation which
	required that the segment be upgraded.  PATH is the pathname of the
	message segment or mailbox which could not be upgraded.  REASON
	provides additional information about the failure of the attempted
	upgrade.

   A:	$inform


   END MESSAGE DOCUMENTATION */

/* format: on */

     end mseg_utils_;




		    suffix_mbx_.pl1                 08/05/87  0812.1r   08/04/87  1539.2      175815



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */




/* format: style2,idind30,indcomtxt */

/* Typed-segment primitives for mailboxes */

/* Created:  January 1983 by G. Palter */
/* Modified 2/18/83 Jay Pattin to add lots more entrypoints */
/* 830922 BIM for fixed up extended objects. */
/* 1984.08.28 MAP to respecify include file mail_system_mbx_modes */
/* 1984.10.05 MAP to fix empty ACL blowouts */
/* 1985-05-02, BIM: use mseg_access_mode_values instead of the old mlsys file */
/* 1985-05-06, BIM: always free old_acl_array and return codes on specific acl listing. */

suffix_mbx_:
     procedure ();



/* Common Parameters */

          dcl     P_desired_version             character (*) parameter;
          dcl     P_dirname                     character (*) parameter;
                                                            /* directory containing the mailbox */
          dcl     P_ename                       character (*) parameter;
                                                            /* name of the mailbox */
          dcl     P_code                        fixed binary (35) parameter;


/* suffix_info and list_switches Parameters */

          dcl     P_suffix_info_ptr             ptr parameter;
          dcl     P_switch_list_ptr             ptr parameter;

/* chname_file Parameters */

          dcl     P_old_name                    character (*) parameter;
                                                            /* name to be deleted */
          dcl     P_new_name                    character (*) parameter;
                                                            /* name to be added */

/* copy parameter */

          dcl     P_copy_options_ptr            pointer parameter;

/* Parameters used by most ACL entries */

          dcl     P_acl_ptr                     pointer parameter;
                                                            /* -> an ACL array structure */

/* list_acl Parameters */

          dcl     P_user_area_ptr               pointer parameter;
                                                            /* -> area where to allocate listed_acl if non-null */

/* replace_acl Parameters */

          dcl     P_no_sysdaemon                bit (1) parameter;
                                                            /* ON => do not add explicit *.SysDaemon.* term */

/* switch Parameters */

          dcl     P_switch_name                 char (*) parameter;
          dcl     P_value                       bit (1) aligned parameter;

/* (get set)_max_length and bit_count parameters */

          dcl     P_max_length                  fixed bin (19) parameter;

/* get_user_access_modes parameters */

          dcl     (P_modes, P_exmodes)          bit (36) aligned;
          dcl     P_ring                        fixed bin;
          dcl     P_user_name                   char (*);

/* Remaining declarations */

          dcl     old_acl_ptr                   pointer;
          dcl     user_area_ptr                 pointer;
          dcl     user_area                     area based (P_user_area_ptr);
          dcl     system_free_area              area based (get_system_free_area_ ());

          dcl     idx                           fixed binary;
          dcl     rings                         (3) fixed bin (3);
          dcl     value                         bit (1);
          dcl     err_switch                    bit (1) aligned;

          dcl     error_table_$argerr           fixed bin (35) ext static;
          dcl     error_table_$unsupported_operation
                                                fixed binary (35) external;
          dcl     error_table_$unimplemented_version
                                                fixed bin (35) ext static;

          dcl     get_system_free_area_         entry () returns (pointer);
          dcl     get_user_free_area_           entry () returns (pointer);
          dcl     hcs_$get_max_length           entry (char (*), char (*), fixed bin (19), fixed bin (35));
          dcl     hcs_$get_safety_sw            entry (char (*), char (*), bit (1), fixed bin (35));
          dcl     hcs_$get_user_access_modes    entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
                                                bit (36) aligned, fixed bin (35));
          dcl     mailbox_$copy                 entry (character (*), character (*), character (*), character (*),
                                                bit (1) aligned, fixed binary (35));
          dcl     mailbox_$chname_file          entry (character (*), character (*), 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, pointer,
                                                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_$set_max_length_file  entry (char (*), char (*), fixed bin (19), fixed bin (35));
          dcl     mailbox_$set_safety_switch    entry (char (*), char (*), bit (1) aligned, fixed bin (35));
          dcl     mailbox_$validate             entry (character (*), character (*), fixed binary (35));

          dcl     cleanup                       condition;

          dcl     null                          builtin; 

/* format: off */
%page; %include acl_structures;
%page; %include access_mode_values;
%page; %include mseg_access_mode_values;
%page; %include suffix_info;
%page; %include copy_options;
%page; %include copy_flags;
/* format: on */

/* Deletes a mailbox */

delentry_file:
     entry (P_dirname, P_ename, P_code);

          call mailbox_$delete (P_dirname, P_ename, P_code);
          return;


/* Changes the names on a mailbox */

chname_file:
     entry (P_dirname, P_ename, P_old_name, P_new_name, P_code);

          call mailbox_$chname_file (P_dirname, P_ename, P_old_name, P_new_name, P_code);
          return;

/* copies a mailbox */
copy:
     entry (P_copy_options_ptr, P_code);

          copy_options_ptr = P_copy_options_ptr;
          if copy_options.extend | copy_options.update
          then do;
                    P_code = error_table_$unsupported_operation;
                    return;
               end;

          call mailbox_$copy (copy_options.source_dir, copy_options.source_name, copy_options.target_dir,
               copy_options.target_name, err_switch, P_code);

          copy_options.target_err_switch = err_switch;
          return;


/* validates that an entry is a mailbox */

validate:
     entry (P_dirname, P_ename, P_code);

          call mailbox_$validate (P_dirname, P_ename, P_code);
          return;


/* Returns information about mailboxes */

suffix_info:
     entry (P_suffix_info_ptr);

          suffix_info_ptr = P_suffix_info_ptr;

          suffix_info.version = SUFFIX_INFO_VERSION_1;
          suffix_info.type = "mbx";
          suffix_info.type_name = "mailbox";
          suffix_info.plural_name = "mailboxes";
          string (suffix_info.flags) = ""b;
          suffix_info.extended_acl = "0"b;                  /* only one set of meaningful modes */
          suffix_info.has_switches = "1"b;
          suffix_info.modes = "adroswu";
          suffix_info.max_mode_len = 7;
          suffix_info.num_ring_brackets = 0;                /* Don't display them */
          string (suffix_info.copy_flags) = ""b;
          suffix_info.copy_flags.names, suffix_info.copy_flags.acl, suffix_info.copy_flags.max_length,
               suffix_info.copy_flags.safety_switch = "1"b;
          suffix_info.info_pathname = "extended_access.gi.info";

          return;

/* returns names of non-standard switches */

list_switches:
     entry (P_desired_version, P_user_area_ptr, P_switch_list_ptr, P_code);

          if P_desired_version ^= SWITCH_LIST_VERSION_1
          then do;
                    P_code = error_table_$unimplemented_version;
                    return;
               end;

          user_area_ptr = P_user_area_ptr;
          if user_area_ptr = null ()
          then user_area_ptr = get_user_free_area_ ();
          alloc_switch_count, alloc_switch_name_count = 1;
          allocate switch_list in (user_area);

          switch_list.version = SWITCH_LIST_VERSION_1;
          switch_list.switches (1).name_index = 1;
          switch_list.switches (1).name_count = 1;
          switch_list.switches (1).default_value = "0"b;
          switch_list.names (1) = "safety";

          P_switch_list_ptr = switch_list_ptr;
          return;
%page;
/* Adds ACL entries to a mailbox */

add_acl_entries:
     entry (P_dirname, P_ename, P_acl_ptr, P_code);

          old_acl_ptr = null ();
          on cleanup
               begin;
                    if old_acl_ptr ^= null ()
                    then free old_acl_ptr -> segment_acl_array;
                    old_acl_ptr = null ();
               end;

          acl_ptr = P_acl_ptr;
          acl_count = general_acl.count;

          allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
          do idx = 1 to acl_count;
               old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx).access_name;
               old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx).mode;
               old_acl_ptr -> segment_acl_array (idx).status_code = 0;
          end;

          call mailbox_$mbx_acl_add (P_dirname, P_ename, old_acl_ptr, acl_count, P_code);
          general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
          free old_acl_ptr -> segment_acl_array;
          return;



/* Lists ACL entries on a mailbox */

list_acl:
     entry (P_dirname, P_ename, P_desired_version, P_user_area_ptr, P_acl_ptr, P_code);


          old_acl_ptr = null ();

          on cleanup
               begin;
                    if old_acl_ptr ^= null ()
                    then do;
                              free old_acl_ptr -> segment_acl_array;
                              old_acl_ptr = null ();
                         end;
               end;

          acl_ptr = P_acl_ptr;

          if acl_ptr ^= null ()
          then do;                                          /* wants to list specific entries */
                    if general_acl.version ^= GENERAL_ACL_VERSION_1
                    then do;
                              P_code = error_table_$unimplemented_version;
                              return;
                         end;
                    acl_count = general_acl.count;
                    allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
                                                            /* only access_name is interesting */
                    old_acl_ptr -> segment_acl_array (*).access_name = general_acl.entries (*).access_name;

                    call mailbox_$mbx_acl_list (P_dirname, P_ename, old_acl_ptr, acl_count, null (), P_code);
                    general_acl.entries (*).mode = old_acl_ptr -> segment_acl_array (*).extended_mode;
                    general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
                    free old_acl_ptr -> segment_acl_array;
               end;


          else do;                                          /* wants to list an acl entirely */
                    if P_desired_version ^= GENERAL_ACL_VERSION_1
                    then do;
                              P_code = error_table_$unimplemented_version;
                              return;
                         end;
                    if user_area_ptr = null ()
                    then user_area_ptr = get_user_free_area_ ();
                    call mailbox_$mbx_acl_list (P_dirname, P_ename, old_acl_ptr, acl_count, get_system_free_area_ (),
                         P_code);                           /* caller wants the entire ACL */
                    if P_code ^= 0
                    then return;
                    if acl_count = 0
                    then do;
                              P_acl_ptr = null ();
                              return;
                         end;

                    allocate general_acl in (user_area);
                    P_acl_ptr = acl_ptr;
                    general_acl.version = GENERAL_ACL_VERSION_1;
                    do idx = 1 to acl_count;
                         general_acl.entries (idx).access_name = old_acl_ptr -> segment_acl_array (idx).access_name;
                         general_acl.entries (idx).mode = old_acl_ptr -> segment_acl_array (idx).extended_mode;
                         general_acl.entries (*).status_code = 0;
                    end;
                    free old_acl_ptr -> segment_acl_array;
                    P_acl_ptr = acl_ptr;
               end;

          return;
%page;
/* Deletes ACL entries from a message segment */

delete_acl_entries:
     entry (P_dirname, P_ename, P_acl_ptr, P_code);

          old_acl_ptr = null ();

          on cleanup
               begin;
                    if old_acl_ptr ^= null ()
                    then do;
                              free old_acl_ptr -> segment_acl_array;
                              old_acl_ptr = null ();
                         end;
               end;

          acl_ptr = P_acl_ptr;
          acl_count = general_delete_acl.count;

          allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
          segment_acl_array (*).access_name = general_delete_acl.entries (*).access_name;

          call mailbox_$mbx_acl_delete (P_dirname, P_ename, old_acl_ptr, acl_count, null (), P_code);

          general_delete_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
          free old_acl_ptr -> segment_acl_array;

          return;
%page;
/* Replaces the ACL of a message segment */

replace_acl:
     entry (P_dirname, P_ename, P_acl_ptr, P_no_sysdaemon, P_code);

          old_acl_ptr = null ();

          on cleanup
               begin;
                    if old_acl_ptr ^= null ()
                    then do;
                              free old_acl_ptr -> segment_acl_array;
                              old_acl_ptr = null ();
                         end;
               end;

          acl_ptr = P_acl_ptr;
          acl_count = general_acl.count;

          if ^P_no_sysdaemon
          then acl_count = acl_count + 1;                   /* add aow *.SysDaemon.* */
          if acl_count = 0                                  /* cannot have no_sysdaemon */
          then do;
                    call mailbox_$mbx_acl_replace (P_dirname, P_ename, null (), -1, P_code);
                    return;
               end;

          allocate segment_acl_array in (system_free_area) set (old_acl_ptr);

          if ^P_no_sysdaemon
          then do;
                    old_acl_ptr -> segment_acl_array (1).access_name = "*.SysDaemon.*";
                    old_acl_ptr -> segment_acl_array (1).extended_mode = MSEG_A_ACCESS | MSEG_O_ACCESS | MSEG_W_ACCESS;
                    old_acl_ptr -> segment_acl_array (1).status_code = 0;

                    do idx = 2 to acl_count;
                         old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx-1).access_name;
                         old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx-1).mode;
                         old_acl_ptr -> segment_acl_array (idx).mode = ""b;
                         old_acl_ptr -> segment_acl_array (idx).status_code = 0;

                    end;
               end;
          else do idx = 1 to acl_count;                     /* no need to splice in funny acl */
                    old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx).access_name;
                    old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx).mode;
                    old_acl_ptr -> segment_acl_array (idx).mode = ""b;
                    old_acl_ptr -> segment_acl_array (idx).status_code = 0;

               end;

          call mailbox_$mbx_acl_replace (P_dirname, P_ename, old_acl_ptr, acl_count, P_code);

          if ^P_no_sysdaemon                                /* have to skip sysdaemon acl entry */
          then /* copy back status codes */
               do idx = 1 to acl_count;
                    general_acl.entries (idx).status_code = old_acl_ptr -> segment_acl_array (idx + 1).status_code;
               end;
          else general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
          free old_acl_ptr -> segment_acl_array;
          return;

%page;
get_switch:
     entry (P_dirname, P_ename, P_switch_name, P_value, P_code);

          call mailbox_$validate (P_dirname, P_ename, P_code);
          if P_code = 0
          then do;
                    if P_switch_name = "safety"
                    then do;
                              call hcs_$get_safety_sw (P_dirname, P_ename, value, P_code);
                              P_value = value;
                         end;
                    else P_code = error_table_$argerr;
               end;

          return;

set_switch:
     entry (P_dirname, P_ename, P_switch_name, P_value, P_code);

          call mailbox_$validate (P_dirname, P_ename, P_code);
          if P_code = 0
          then do;
                    if P_switch_name = "safety"
                    then call mailbox_$set_safety_switch (P_dirname, P_ename, P_value, P_code);
                    else P_code = error_table_$argerr;
               end;

          return;
%page;
get_max_length:
     entry (P_dirname, P_ename, P_max_length, P_code);

          call mailbox_$validate (P_dirname, P_ename, P_code);
          if P_code = 0
          then call hcs_$get_max_length (P_dirname, P_ename, P_max_length, P_code);
          return;


set_max_length:
     entry (P_dirname, P_ename, P_max_length, P_code);

          call mailbox_$set_max_length_file (P_dirname, P_ename, P_max_length, P_code);
          return;


get_user_access_modes:
     entry (P_dirname, P_ename, P_user_name, P_ring, P_modes, P_exmodes, P_code);

          P_exmodes = ""b;
          call mailbox_$validate (P_dirname, P_ename, P_code);
          if P_code = 0
          then call hcs_$get_user_access_modes (P_dirname, P_ename, P_user_name, P_ring, ((36)"0"b), P_modes, P_code);
          return;

     end suffix_mbx_;




		    suffix_ms_.pl1                  05/09/85  1151.8r w 05/06/85  1617.7      173160



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */



/* format: style2,idind30,indcomtxt */

/* Typed-segment primitives for message segments */

/* Created:  January 1983 by G. Palter */
/* Modified: 2/20/83 Jay Pattin to add lots more entries */
/* 830922 BIM for new calling sequences for acls */
/* 1984.08.28 MAP to set user_area_ptr when list_acl is invoked */
/* 1985-05-02, BIM: remove unneeded include of access_mode_values */
/* 1985-05-06, BIM: check code on exit from message_segment_$acl_list */

suffix_ms_:
     procedure ();


/* Common Parameters */

          dcl     P_desired_version             character (*) parameter;
          dcl     P_dirname                     character (*) parameter;
                                                            /* directory containing the message segment */
          dcl     P_ename                       character (*) parameter;
                                                            /* name of the message segment */
          dcl     P_code                        fixed binary (35) parameter;

/* suffix_info and list_switches Parameters */

          dcl     P_suffix_info_ptr             ptr parameter;
          dcl     P_switch_list_ptr             ptr parameter;

/* chname_file Parameters */

          dcl     P_old_name                    character (*) parameter;
                                                            /* name to be deleted */
          dcl     P_new_name                    character (*) parameter;
                                                            /* name to be added */

/* copy parameters */

          dcl     P_copy_options_ptr            ptr parameter;

/* Parameters used by most ACL entries */

          dcl     P_acl_ptr                     pointer parameter;
                                                            /* -> an ACL array structure */


/* list_acl Parameters */

          dcl     P_user_area_ptr               pointer parameter;
                                                            /* -> area where to allocate listed_acl if non-null */


/* replace_acl Parameters */

          dcl     P_no_sysdaemon                bit (1) parameter;
                                                            /* ON => do not add explicit *.SysDaemon.* term */

/* switch Parameters */

          dcl     P_switch_name                 char (*) parameter;
          dcl     P_value                       bit (1) aligned parameter;

/* (get set)_max_length and bit_count parameters */

          dcl     P_max_length                  fixed bin (19) parameter;

/* get_user_access_modes parameters */

          dcl     (P_modes, P_exmodes)          bit (36) aligned;
          dcl     P_ring                        fixed bin;
          dcl     P_user_name                   char (*);

/* Remaining declarations */

          dcl     old_acl_ptr                   pointer;

          dcl     user_area_ptr                 pointer;
          dcl     user_area                     area based (user_area_ptr);
          dcl     system_free_area              area based (get_system_free_area_ ());

          dcl     idx                           fixed binary;
          dcl     rings                         (3) fixed bin (3);
          dcl     value                         bit (1);
          dcl     err_switch                    bit (1) aligned;

          dcl     error_table_$argerr           fixed binary (35) external;
          dcl     error_table_$unsupported_operation
                                                fixed binary (35) external;
          dcl     error_table_$unimplemented_version
                                                fixed bin (35) ext static;

          dcl     (get_system_free_area_, get_user_free_area_)
                                                entry () returns (pointer);
          dcl     hcs_$get_max_length           entry (char (*), char (*), fixed bin (19), fixed bin (35));
          dcl     hcs_$get_safety_sw            entry (char (*), char (*), bit (1), fixed bin (35));
          dcl     hcs_$get_user_access_modes    entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
                                                bit (36) aligned, fixed bin (35));
          dcl     message_segment_$copy         entry (character (*), character (*), character (*), character (*),
                                                bit (1) aligned, fixed binary (35));
          dcl     message_segment_$chname_file  entry (character (*), character (*), character (*), character (*),
                                                fixed binary (35));
          dcl     message_segment_$delete       entry (character (*), character (*), fixed binary (35));
          dcl     message_segment_$ms_acl_add   entry (character (*), character (*), pointer, fixed binary,
                                                fixed binary (35));
          dcl     message_segment_$ms_acl_delete
                                                entry (character (*), character (*), pointer, fixed binary, pointer,
                                                fixed binary (35));
          dcl     message_segment_$ms_acl_list  entry (character (*), character (*), pointer, fixed binary, pointer,
                                                fixed binary (35));
          dcl     message_segment_$ms_acl_replace
                                                entry (character (*), character (*), pointer, fixed binary,
                                                fixed binary (35));
          dcl     message_segment_$set_max_length_file
                                                entry (char (*), char (*), fixed bin (19), fixed bin (35));
          dcl     message_segment_$set_safety_switch
                                                entry (char (*), char (*), bit (1) aligned, fixed bin (35));
          dcl     message_segment_$validate     entry (character (*), character (*), fixed binary (35));
          dcl     sub_err_                      entry () options (variable);

          dcl     cleanup                       condition;

          dcl     null                          builtin;    /* format: off */
%page; %include suffix_info;
%page; %include copy_options;
%page; %include copy_flags;
%page; %include acl_structures;
%include sub_err_flags;
/* format: on */



/* Deletes a message segment */

delentry_file:
     entry (P_dirname, P_ename, P_code);

          call message_segment_$delete (P_dirname, P_ename, P_code);
          return;



/* Changes the names on a message segment */

chname_file:
     entry (P_dirname, P_ename, P_old_name, P_new_name, P_code);

          call message_segment_$chname_file (P_dirname, P_ename, P_old_name, P_new_name, P_code);
          return;

/* copies a message segment */

copy:
     entry (P_copy_options_ptr, P_code);

          copy_options_ptr = P_copy_options_ptr;
          if copy_options.extend | copy_options.update
          then do;
                    P_code = error_table_$unsupported_operation;
                    return;
               end;

          call message_segment_$copy (copy_options.source_dir, copy_options.source_name, copy_options.target_dir,
               copy_options.target_name, err_switch, P_code);

          copy_options.target_err_switch = err_switch;
          return;


/* validates that an entry is a message segment */

validate:
     entry (P_dirname, P_ename, P_code);

          call message_segment_$validate (P_dirname, P_ename, P_code);
          return;


/* Returns information about message segments */

suffix_info:
     entry (P_suffix_info_ptr);

          suffix_info_ptr = P_suffix_info_ptr;

          if suffix_info.version ^= SUFFIX_INFO_VERSION_1
          then call sub_err_ (error_table_$unimplemented_version, "bad suffix info version", ACTION_CANT_RESTART, null (),
                    (0), "Invalid version ^a in call to suffix_ms_$suffix_info.", suffix_info.version);
          suffix_info.type = "ms";
          suffix_info.type_name = "message segment";
          suffix_info.plural_name = "message segments";
          string (suffix_info.flags) = ""b;
          suffix_info.extended_acl = "0"b;
          suffix_info.has_switches = "1"b;
          suffix_info.modes = "adros";
          suffix_info.max_mode_len = 5;
          suffix_info.num_ring_brackets = 0;                /* Don't display them */
          string (suffix_info.copy_flags) = ""b;
          suffix_info.copy_flags.names, suffix_info.copy_flags.acl, suffix_info.copy_flags.max_length,
               suffix_info.copy_flags.safety_switch = "1"b;

          suffix_info.info_pathname = "extended_access.gi.info";

          return;

/* returns names of non-standard switches */

list_switches:
     entry (P_desired_version, P_user_area_ptr, P_switch_list_ptr, P_code);

          if P_desired_version ^= SWITCH_LIST_VERSION_1
          then do;
                    P_code = error_table_$unimplemented_version;
                    return;
               end;
          alloc_switch_count, alloc_switch_name_count = 1;
          user_area_ptr = P_user_area_ptr;
          if user_area_ptr = null ()
          then user_area_ptr = get_user_free_area_ ();

          allocate switch_list in (user_area);

          switch_list.version = SWITCH_LIST_VERSION_1;
          switch_list.switches (1).name_index = 1;
          switch_list.switches (1).name_count = 1;
          switch_list.switches (1).default_value = "0"b;
          switch_list.names (1) = "safety";

          P_switch_list_ptr = switch_list_ptr;
          return;
%page;
/* Adds ACL entries to a message segment */
/**** This has to convert structures from the new interface to the old one. */

add_acl_entries:
     entry (P_dirname, P_ename, P_acl_ptr, P_code);

          old_acl_ptr = null ();

          on cleanup
               begin;
                    if old_acl_ptr ^= null ()
                    then do;
                              free old_acl_ptr -> segment_acl_array;
                              old_acl_ptr = null ();
                         end;
               end;

          acl_ptr = P_acl_ptr;
          acl_count = general_acl.count;
          allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
          do idx = 1 to acl_count;                          /* no aggregate, since we rearrange */
               old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx).access_name;
               old_acl_ptr -> segment_acl_array (idx).mode = ""b;
               old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx).mode;
               old_acl_ptr -> segment_acl_array (idx).status_code = 0;
          end;

          call message_segment_$ms_acl_add (P_dirname, P_ename, old_acl_ptr, acl_count, P_code);
          general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
          free old_acl_ptr -> segment_acl_array;
          return;



/* Lists ACL entries on a message segment */

list_acl:
     entry (P_dirname, P_ename, P_desired_version, P_user_area_ptr, P_acl_ptr, P_code);

          old_acl_ptr = null ();

          on cleanup
               begin;
                    if old_acl_ptr ^= null ()
                    then do;
                              free old_acl_ptr -> segment_acl_array;
                              old_acl_ptr = null ();
                         end;
               end;

	user_area_ptr = P_user_area_ptr;
          acl_ptr = P_acl_ptr;

          if acl_ptr ^= null ()
          then do;                                          /* wants to list specific entries */
                    if general_acl.version ^= GENERAL_ACL_VERSION_1
                    then do;
                              P_code = error_table_$unimplemented_version;
                              return;
                         end;
                    acl_count = general_acl.count;
                    allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
                                                            /* only access_name is interesting */
                    old_acl_ptr -> segment_acl_array (*).access_name = general_acl.entries (*).access_name;

                    call message_segment_$ms_acl_list (P_dirname, P_ename, old_acl_ptr, acl_count, null (), P_code);
                    general_acl.entries (*).mode = old_acl_ptr -> segment_acl_array (*).extended_mode;
                    general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
                    free old_acl_ptr -> segment_acl_array;

               end;


          else do;                                          /* wants to list an acl entirely */
                    if P_desired_version ^= GENERAL_ACL_VERSION_1
                    then do;
                              P_code = error_table_$unimplemented_version;
                              return;
                         end;
                    if user_area_ptr = null ()
                    then user_area_ptr = get_user_free_area_ ();
                    call message_segment_$ms_acl_list (P_dirname, P_ename, old_acl_ptr, acl_count,
                         get_system_free_area_ (), P_code); /* caller wants the entire ACL */
		if P_code ^= 0 then return;
                    if acl_count = 0
                    then do;
                              P_acl_ptr = null ();
                              return;
                         end;

                    allocate general_acl in (user_area);
                    P_acl_ptr = acl_ptr;
                    general_acl.version = GENERAL_ACL_VERSION_1;
                    do idx = 1 to acl_count;
                         general_acl.entries (idx).access_name = old_acl_ptr -> segment_acl_array (idx).access_name;
                         general_acl.entries (idx).mode = old_acl_ptr -> segment_acl_array (idx).extended_mode;
                         general_acl.entries (*).status_code = 0;
                    end;
                    free old_acl_ptr -> segment_acl_array;
                    P_acl_ptr = acl_ptr;
               end;

          return;
%page;
/* Deletes ACL entries from a message segment */

delete_acl_entries:
     entry (P_dirname, P_ename, P_acl_ptr, P_code);

          old_acl_ptr = null ();

          on cleanup
               begin;
                    if old_acl_ptr ^= null ()
                    then do;
                              free old_acl_ptr -> segment_acl_array;
                              old_acl_ptr = null ();
                         end;
               end;

          acl_ptr = P_acl_ptr;
          acl_count = general_delete_acl.count;

          allocate segment_acl_array in (system_free_area) set (old_acl_ptr);
          segment_acl_array (*).access_name = general_delete_acl.entries (*).access_name;

          call message_segment_$ms_acl_delete (P_dirname, P_ename, old_acl_ptr, acl_count, null (), P_code);

          general_delete_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
          free old_acl_ptr -> segment_acl_array;

          return;
%page;
/* Replaces the ACL of a message segment */

/**** NOTE -- the default SysDaemon access for an mseg is NULL.
      Therefore, the no_sysdaemon switch is a noop. */

replace_acl:
     entry (P_dirname, P_ename, P_acl_ptr, P_no_sysdaemon, P_code);

          old_acl_ptr = null ();

          on cleanup
               begin;
                    if old_acl_ptr ^= null ()
                    then do;
                              free old_acl_ptr -> segment_acl_array;
                              old_acl_ptr = null ();
                         end;
               end;

          acl_ptr = P_acl_ptr;
          acl_count = general_acl.count;

          if acl_count = 0                                  /* cannot have no_sysdaemon */
          then do;
                    call message_segment_$ms_acl_replace (P_dirname, P_ename, null (), -1, P_code);
                    return;
               end;

          allocate segment_acl_array in (system_free_area) set (old_acl_ptr);

          do idx = 1 to acl_count;                          /* no need to splice in funny acl */
               old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx).access_name;
               old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx).mode;
               old_acl_ptr -> segment_acl_array (idx).mode = ""b;
               old_acl_ptr -> segment_acl_array (idx).status_code = 0;

          end;

          call message_segment_$ms_acl_replace (P_dirname, P_ename, old_acl_ptr, acl_count, P_code);

          general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code;
          free old_acl_ptr -> segment_acl_array;

          return;
%page;
get_switch:
     entry (P_dirname, P_ename, P_switch_name, P_value, P_code);

          call message_segment_$validate (P_dirname, P_ename, P_code);
          if P_code = 0
          then do;
                    if P_switch_name = "safety"
                    then do;
                              call hcs_$get_safety_sw (P_dirname, P_ename, value, P_code);
                              P_value = value;
                         end;
                    else P_code = error_table_$argerr;
               end;

          return;

set_switch:
     entry (P_dirname, P_ename, P_switch_name, P_value, P_code);

          call message_segment_$validate (P_dirname, P_ename, P_code);
          if P_code = 0
          then do;
                    if P_switch_name = "safety"
                    then call message_segment_$set_safety_switch (P_dirname, P_ename, P_value, P_code);
                    else P_code = error_table_$argerr;
               end;

          return;
%page;
get_max_length:
     entry (P_dirname, P_ename, P_max_length, P_code);

          call message_segment_$validate (P_dirname, P_ename, P_code);
          if P_code = 0
          then call hcs_$get_max_length (P_dirname, P_ename, P_max_length, P_code);
          return;

set_max_length:
     entry (P_dirname, P_ename, P_max_length, P_code);

          call message_segment_$set_max_length_file (P_dirname, P_ename, P_max_length, P_code);
          return;


get_user_access_modes:
     entry (P_dirname, P_ename, P_user_name, P_ring, P_modes, P_exmodes, P_code);

          P_exmodes = ""b;                                  /* msegs, like dirs, have only modes, no exmodes */
          call message_segment_$validate (P_dirname, P_ename, P_code);
          if P_code = 0
          then call hcs_$get_user_access_modes (P_dirname, P_ename, P_user_name, P_ring, ((36)"0"b), P_modes, P_code);
          return;

     end suffix_ms_;



		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
