



		    as_user_message_.alm            03/19/85  1108.7rew 03/19/85  0929.9        7389



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" ***********************************************************
" Transfer vector for as user message entrypoints
"
" Written 1985-02-16 by BIM 

	name	as_user_message_

	macro	tv
	entry	&1
&1:	call6	&2
&end

	tv	priv_system_init,(user_message_priv_$system_init)
	tv	priv_add_message,(user_message_priv_$add_message)
	tv	priv_delete_message_id,(user_message_priv_$delete_message_id)
	tv	priv_delete_process_messages,(user_message_priv_$delete_process_messages)
	tv	user_read_message,(user_message_$read_message)
	tv	admin_read_message,(user_message_admin_$read_message)
	end




		    asum_.pl1                       08/04/87  1446.2rew 08/04/87  1221.5       21987



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

/**** asum_.pl1 -- Gate target for as_user_message_ subsystem */

/* format: style2 */

/**** Written 1985-02-20 by BIM */


/****^  HISTORY COMMENTS:
  1) change(87-06-24,GDixon), approve(87-07-07,MCR7719),
     audit(87-06-25,Hartogs), install(87-08-04,MR12.1-1055):
     Change declaration of asum_read_delete_ops_$priv_delete_process_id to
     match the actual subroutine.
                                                   END HISTORY COMMENTS */

asum_:
     procedure;

	declare asum_inner_ring_caller_
				 entry (entry, pointer);
	declare asum_inner_ring_caller_$initial
				 entry (entry, pointer);
	declare asum_add_message_	 entry (pointer, fixed binary (35));
	declare asum_read_delete_ops_$user_read_message
				 entry (pointer, pointer, fixed binary (35));
	declare asum_read_delete_ops_$priv_delete_message_id
				 entry (bit (72) aligned, fixed binary (35));
	declare asum_read_delete_ops_$priv_delete_process_id
				 entry (bit (36) aligned, fixed binary (35));
	declare asum_read_delete_ops_$admin_read
				 entry (pointer, pointer, pointer, fixed binary (35));

	declare asum_system_init_	 entry (fixed binary (35));
	declare cu_$arg_list_ptr	 entry returns (pointer);


priv_add:
     entry;
	call asum_inner_ring_caller_ (asum_add_message_, cu_$arg_list_ptr ());
	return;

user_read:
     entry;
	call asum_inner_ring_caller_ (asum_read_delete_ops_$user_read_message, cu_$arg_list_ptr ());
	return;

priv_delete_process_messages:
     entry;
	call asum_inner_ring_caller_ (asum_read_delete_ops_$priv_delete_process_id, cu_$arg_list_ptr ());
	return;

priv_delete_message_id:
     entry;
	call asum_inner_ring_caller_ (asum_read_delete_ops_$priv_delete_message_id, cu_$arg_list_ptr ());
	return;

admin_read:
     entry;
	call asum_inner_ring_caller_ (asum_read_delete_ops_$admin_read, cu_$arg_list_ptr ());
	return;

system_init:
     entry;
	call asum_inner_ring_caller_$initial (asum_system_init_, cu_$arg_list_ptr ());

     end asum_;




		    asum_add_message_.pl1           09/04/86  1451.3rew 09/04/86  1441.5       71568



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


/****^  HISTORY COMMENTS:
  1) change(85-05-31,Swenson), approve(86-07-25,MCR7302),
     audit(86-08-13,EJSharpe), install(86-09-04,MR12.0-1147):
     Fixed to ensure all sending process security-relevant information is set
     in message segment entry.
                                                   END HISTORY COMMENTS */


/* asum_add_message_ -- procedure that appends a message to the
   database for delivery. This is the gate target, effectively */

/* format: style2,indcomtxt */

asum_add_message_:
     procedure (P_add_info_ptr, P_code);

/* Written 2/20/85 BIM */
/* Modified 1985-04, BIM: changed for new mseg_ calling sequences. */

/**** NOTE: this implements the initial strategy of keeping all the destination
      information in the _system segment. This limits to 16K messages
      outstanding. For volume applications, something better is needed.

      Also, note that this locks the database for the entire operation,
      making no use of the potential lockless update.
*/

	declare P_add_info_ptr	 pointer;
	declare P_code		 fixed bin (35);


	declare 1 add_info		 aligned like as_user_message_add_info;
	declare code		 fixed bin (35);
	declare message_added	 bit (1) aligned;
	declare hx		 fixed bin;
	declare ms_ptr		 pointer;
	declare start_n_segments	 fixed bin;
	declare sx		 fixed bin;

/* Entries */

	declare asum_error_		 entry options (variable);
	declare asum_find_segment_	 entry (fixed binary, pointer);
	declare asum_create_segment_	 entry (fixed binary, pointer);
	declare get_group_id_	 entry () returns (char (32));
	declare get_process_authorization_
				 entry () returns (bit (72) aligned);
	declare get_process_max_authorization_
				 entry () returns (bit (72) aligned);
	declare set_lock_$lock	 entry (bit (36) aligned, fixed binary, fixed binary (35));
	declare set_lock_$unlock	 entry (bit (36) aligned, fixed binary (35));

	declare error_table_$bad_arg	 fixed bin (35) ext static;
	declare error_table_$notalloc	 fixed bin (35) ext static;

	dcl     addr		 builtin;
	dcl     bin		 builtin;
	dcl     bit		 builtin;
	dcl     hbound		 builtin;
	dcl     stacq		 builtin;
	dcl     unspec		 builtin;

%include as_user_message_system;
%include as_user_message_add;
%include asum_data_;
%include mseg_entries;
%include mseg_data_;
%include mseg_operation;
%include mseg_access_operation;
%include mseg_wakeup_state;
%include mseg_message_info;
%include entry_access_info;


	as_user_message_add_info_ptr = P_add_info_ptr;
	add_info = as_user_message_add_info;		/* Copy the parm. We will copy back out */
	as_user_message_system_info_ptr = asum_data_$system_info_ptr;
	as_user_message_perprocess_info_ptr = asum_data_$process_info_ptr;
	if add_info.process_id = ""b | add_info.handle = ""b
	then call RETURN_ERROR (error_table_$bad_arg);

	call lock_database;
	do hx = 1 to hbound (as_user_message_system_info.destination_am, 1);
	     if stacq (as_user_message_system_info.destination_am (hx).process_id, add_info.process_id, ""b)
	     then go to HAVE_HX;
	end;

	call asum_error_ (0, "asum_add_message_", "destination AM full.");
HAVE_HX:
	if hx > as_user_message_system_info.highest_in_use
	then begin;
		declare his		 bit (36) aligned based (his_ptr);
		declare his_ptr		 pointer;
		declare new_his		 bit (36) aligned;
		declare old_his		 bit (36) aligned;

		old_his = unspec (as_user_message_system_info.highest_in_use);
		new_his = bit (bin (hx, 36), 36);
		his_ptr = addr (as_user_message_system_info.highest_in_use);
		do while (^stacq (his, new_his, old_his) & hx > bin (old_his, 36));
						/* use old_his to assure same comparison as stacq */
		     old_his = unspec (as_user_message_system_info.highest_in_use);
		end;
	     end;


	message_added = "0"b;
	do while (^message_added);
	     start_n_segments = as_user_message_system_info.n_segments;
	     do sx = 0 to start_n_segments - 1;
		call asum_find_segment_ (sx, ms_ptr);	/* in PP data or the hard way */
		call TRY_ADD_MESSAGE (hx, ms_ptr);

	     end;
	     if ^message_added
	     then call ADD_SEGMENT;			/* but start at the beginning again */
	end;

	call unlock_database;

/**** Arrive here on success */

	P_code = 0;
	as_user_message_add_info = add_info;		/* Copy parm back out */
	return;

RETURN_ERROR:
     procedure (code);
	declare code		 fixed bin (35);
	P_code = code;
	go to ERROR_RETURN;
     end RETURN_ERROR;

ERROR_RETURN:
	return;


ADD_SEGMENT:
     procedure;

	if start_n_segments ^= as_user_message_system_info.n_segments
	then return;

/**** So readers don't have to lock, create before bumping the count.
      readers won't try to look at an uninitialized segment, and
      writers will wait on the lock and then discover that we have added one. */

	call asum_create_segment_ (as_user_message_system_info.n_segments, ms_ptr);
	as_user_message_system_info.n_segments = as_user_message_system_info.n_segments + 1;
	return;
     end ADD_SEGMENT;

lock_database:
     procedure;

	if ^stacq (as_user_message_system_info.lock, asum_data_$lock_id, ""b)
	then call set_lock_$lock (as_user_message_system_info.lock, -1, (0));
	asum_data_$db_locked = "1"b;
	return;
     end lock_database;

unlock_database:
     procedure;

	if ^stacq (as_user_message_system_info.lock, ""b, asum_data_$lock_id)
	then call set_lock_$unlock (as_user_message_system_info.lock, (0));
	asum_data_$db_locked = "0"b;
	return;
     end unlock_database;

TRY_ADD_MESSAGE:
     procedure (hx, a_mseg_ptr);

	declare hx		 fixed bin;
	declare a_mseg_ptr		 pointer;
	declare l_message_id	 bit (72) aligned;
	declare 1 am_entry		 aligned like as_user_message_system_info.destination_am based (amep);
	declare amep		 pointer;
	declare 1 mop		 aligned like mseg_operation;

	amep = addr (as_user_message_system_info.destination_am (hx));

	mop = addr (mseg_data_$template_operation) -> mseg_operation;
	mop.suppress_access_checks = "1"b;
	mop.mseg_ptr = a_mseg_ptr;
	mop.mseg_ptr_valid = "1"b;
	mop.message_info.ms_ptr = add_info.message_ptr;
	mop.message_info.ms_len = 36 * add_info.message_length;
	mop.message_info.ms_id = ""b;			/* let mseg generate it */
	mop.message_info.ms_access_class = add_info.message_access_class;
	mop.message_info.sender_id = get_group_id_ ();
	mop.message_info.sender_process_id = asum_data_$process_id;
	mop.message_info.sender_level = asum_data_$entry_ring;
	mop.message_info.sender_authorization = get_process_authorization_ ();
	mop.message_info.sender_max_authorization = get_process_max_authorization_ ();
	mop.message_info.sender_audit = ""b;
	mop.message_info_valid = "1"b;
	mop.add_message_info_all_valid = "1"b;

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

	l_message_id = mop.message_info.ms_id;

	if code ^= 0 & code ^= error_table_$notalloc
	then do;
		do while (
		     ^stacq (as_user_message_system_info.destination_am (hx).process_id, ""b, add_info.process_id));
		end;

		call asum_error_ (code, "asum_add_message_", "Failed to add message to message segment.");
	     end;
	if code = error_table_$notalloc
	then return;
	if code = 0
	then do;
		unspec (as_user_message_id) = l_message_id;
		as_user_message_id.segment_index = sx;
		l_message_id = unspec (as_user_message_id);
		add_info.message_id = l_message_id;
		am_entry.handle = add_info.destination_info.handle;
		am_entry.message_id = l_message_id;
		am_entry.ring = add_info.destination_info.ring;
		am_entry.group_id = add_info.destination_info.group_id;
		am_entry.reader_deletes = add_info.destination_info.reader_deletes;
		am_entry.access_class = add_info.message_access_class;
		message_added = "1"b;
	     end;
	return;
     end TRY_ADD_MESSAGE;

     end asum_add_message_;




		    asum_create_segment_.pl1        04/09/85  1435.7r w 04/08/85  1128.1       52389



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */
/* asum_create_segment_ -- program to create (if needed) and initialize
   one segment of the as_user_message. Note that this program is NOT
   used by a process reading that wants to initiate a new segment,
   only by a process that KNOWS that the segment in question has not
   yet been used in the current session. Thus it cheerfully truncates
   segments that already exist. */

/* format: style5,indcomtxt */

/* Written 2/20/85, BIM */

asum_create_segment_:
        procedure (P_segment_index, P_segment_ptr);

        declare P_segment_index	fixed bin;      /* Which segment do we create ? */
        declare P_segment_ptr		pointer;

%include asum_data_;
%include as_user_message_system;
%include access_mode_values;
%page;

        declare code		fixed bin (35);
        declare saved_privileges	bit (36) aligned;
        declare segment_entryname	char (32);
        declare seg_ptr		pointer;
        declare first		bit (1) aligned;

        declare admin_gate_$set_privileges
				entry (bit (36) aligned,
				bit (36) aligned);
        declare admin_gate_$reset_privileges
				entry (bit (36) aligned);
        declare asum_error_		entry options (variable);
					      /* signals a condition, unwinding */
        declare delete_$path		entry (character (*), character (*),
				bit (36) aligned, character (*),
				fixed binary (35));
        declare hcs_$create_branch_	entry (char (*), char (*), ptr,
				fixed bin (35));
        declare hcs_$replace_acl	entry (char (*), char (*), ptr,
				fixed bin, bit (1), fixed bin (35));
        declare hcs_$truncate_seg	entry (ptr, fixed bin (19),
				fixed bin (35));
        declare initiate_file_	entry (character (*), character (*),
				bit (*), pointer, fixed binary (24),
				fixed binary (35));
        declare pathname_		entry (character (*), character (*))
				returns (character (168));
        declare error_table_$noentry	fixed bin (35) ext static;

        declare (
	      sys_info$seg_privilege,
	      sys_info$dir_privilege
	      )			bit (36) aligned external;

        declare cleanup		condition;

        dcl     addr		builtin;
        dcl     string		builtin;
        dcl     substr		builtin;
%page;


        first = "0"b;
        go to COMMON;
first:
        entry (P_segment_ptr);

        first = "1"b;
COMMON:
/**** Assume caller is at validation level 1 */
        saved_privileges = ""b;
        on cleanup
	      begin;
	      if substr (saved_privileges, 36, 1) = "1"b then
		    call admin_gate_$reset_privileges (saved_privileges);
	      end;

        if ^first then
	      do;
	      as_user_message_segment_name.constant =
		AS_USER_MESSAGE_SEGMENT_NAME_CONSTANT;
	      as_user_message_segment_name.index = P_segment_index;

	      segment_entryname = string (as_user_message_segment_name);
	      end;
        else
	      segment_entryname = AS_USER_MESSAGE_SYSTEM_NAME;

RETRY_INITIATE:
        call initiate_file_ (asum_data_$db_dir, segment_entryname, RW_ACCESS,
	  seg_ptr, (0), code);
        if code ^= error_table_$noentry & code ^= 0     /* Something is busted */
	  then
	      call PROBLEM_SEGMENT;		      /* ACL, or seg-fault, or ?dir? */

        if code = error_table_$noentry then
	      call CREATE_SEGMENT;

/**** We get here with the segment initiated. */

        call hcs_$truncate_seg (seg_ptr, 0, code);
        if code ^= 0 then
	      call asum_error_ (code, "asum_create_segment_",
		"Failed to truncate segment ^a",
		pathname_ (asum_data_$db_dir, segment_entryname));

/**** The segment now exists and is empty. The message segment
      primitives provide no entrypoint to initialize an empty
      segment. They initialize it when you add something.
      So at this point we hand the segment up to our caller,
      who has the data to write the first message. */

        P_segment_ptr = seg_ptr;
        return;
%page;

PROBLEM_SEGMENT:
        procedure;


        if asum_data_$db_multiclass then
	      call admin_gate_$set_privileges (sys_info$seg_privilege
		| sys_info$dir_privilege, saved_privileges);

        call delete_$path (asum_data_$db_dir, segment_entryname, "101110"b, "",
	  code);

        if code ^= 0 then
	      call asum_error_ (code, "asum_create_segment_",
		"Segment ^a exists, but cannot be initiated or deleted.",
		pathname_ (asum_data_$db_dir, segment_entryname));

        end PROBLEM_SEGMENT;

%page;

CREATE_SEGMENT:
        procedure;

        if asum_data_$db_multiclass & ^substr (saved_privileges, 36, 1)
					      /* might be already set */
	  then
	      call admin_gate_$set_privileges (sys_info$seg_privilege
		| sys_info$dir_privilege, saved_privileges);

        call hcs_$create_branch_ (asum_data_$db_dir, segment_entryname,
	  addr (asum_data_$db_cbi), code);
        if code ^= 0 then
	      call asum_error_ (code, "asum_create_segment_",
		"Failed to append ^a",
		pathname_ (asum_data_$db_dir, segment_entryname));

        code = 0;
        if asum_data_$db_multiclass then
	      call hcs_$replace_acl (asum_data_$db_dir, segment_entryname,
		addr (asum_data_$acl_entries), asum_data_$n_acl_entries,
		"1"b, code);
        if code ^= 0 then
	      call asum_error_ (code, "asum_create_segment_",
		"Failed to replace the ACL of ^a",
		pathname_ (asum_data_$db_dir, segment_entryname));
        if substr (saved_privileges, 36, 1) = "1"b then
	      call admin_gate_$reset_privileges (saved_privileges);
        go to RETRY_INITIATE;			      /* Okay, its there now */

        end CREATE_SEGMENT;
        end asum_create_segment_;




		    asum_data_.cds                  03/15/89  0851.9r w 03/15/89  0800.6       35199



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */
/* asum_data_ -- static information for the as_user_message facility */
/* format: style2,indcomtxt */

asum_data_:
     procedure;

/* Created 1985-01, BIM */


/* Automatic */

	dcl     1 cdsa		 aligned like cds_args;
	dcl     code		 fixed bin (35);

/* Constants */

	dcl     NAME		 char (32) int static init ("asum_data_") options (constant);
	dcl     EXCLUDE_PAD		 (1) char (32) aligned static options (constant) init ("pad*");


/* Entries */

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

	declare sys_info$access_class_ceiling
				 bit (72) aligned ext;

/* The structure */

	dcl     static_ptr		 pointer;
	dcl     1 asum_data_static	 aligned based (static_ptr),
		2 db_dir		 char (168) unaligned,
						/* Where ? */
		2 db_dir_rb	 (2) fixed bin (3),
		2 db_rb		 (3) fixed bin (3), /* What RB's? */
		2 db_multiclass	 bit (1) aligned,	/* Multiclass */
		2 db_cbi		 aligned like create_branch_info,
						/* The whole story */
		2 db_dir_cbi	 aligned like create_branch_info,
		2 system_info_ptr	 pointer init (null ()),
		2 process_info_ptr	 pointer init (null ()),
		2 entry_ring	 fixed bin (3),	/* perprocess, for auditing purposes */
		2 lock_id		 bit (36) aligned,
		2 process_id	 bit (36) aligned,	/* cheapify locking */
		2 db_locked	 bit (1) aligned,	/* for cleanup handlers */
		2 n_acl_entries	 fixed bin,
		2 acl_entries	 (static_n_acl_entries refer (asum_data_static.n_acl_entries)) aligned
				 like general_extended_acl_entry;


	declare static_n_acl_entries	 fixed bin;

%page;
%include acl_structures;
%include access_mode_values;
%include create_branch_info;
%include cds_args;
%page;


	static_n_acl_entries = 1;
	allocate asum_data_static;
	asum_data_static.db_dir = ">system_control_1>user_messages";
	asum_data_static.db_rb (*) = 1;
	asum_data_static.db_dir_rb (*) = 1;
	asum_data_static.db_multiclass = "1"b;
	asum_data_static.acl_entries (1).access_name = "*.*.*";
	asum_data_static.acl_entries (1).mode = RW_ACCESS;
	asum_data_static.acl_entries (1).extended_mode = "11111"b;
						/* just in case */
	asum_data_static.acl_entries (1).status_code = 0;

	begin;
	     declare cbip		      pointer;
	     declare 1 CBI		      aligned like create_branch_info based (cbip);
	     cbip = addr (asum_data_static.db_cbi);

	     unspec (CBI) = ""b;
	     CBI.version = create_branch_version_2;
	     CBI.priv_upgrade_sw = asum_data_static.db_multiclass;
	     CBI.parent_ac_sw = ^CBI.priv_upgrade_sw;
	     CBI.mode = ""b;			/* ACL set seperately */
	     CBI.rings = asum_data_static.db_rb;
	     CBI.userid = "*.*.*";
	     CBI.bitcnt = 0;
	     CBI.quota = 0;
	     if CBI.priv_upgrade_sw
	     then CBI.access_class = sys_info$access_class_ceiling;
	     else ;				/* ignored */
	     CBI.dir_quota = 0;

	     addr (asum_data_static.db_dir_cbi) -> CBI = CBI;
	     cbip = addr (asum_data_static.db_dir_cbi);
	     CBI.dir_sw = "1"b;
	     CBI.parent_ac_sw = "1"b;
	     CBI.priv_upgrade_sw = "0"b;
	     CBI.rings (1) = 1;
	     CBI.rings (2) = 1;
	     CBI.mode = SMA_ACCESS;
	     CBI.userid = "*.*.*";
	end;

/* Now set up call to create data base */

	cdsa.sections (2).p = addr (asum_data_static);
	cdsa.sections (2).len = size (asum_data_static);
	cdsa.sections (2).struct_name = "asum_data_static";

	cdsa.seg_name = NAME;
	cdsa.num_exclude_names = 1;
	cdsa.exclude_array_ptr = addr (EXCLUDE_PAD);

	string (cdsa.switches) = "0"b;
	cdsa.switches.have_static = "1"b;

	call create_data_segment_ (addr (cdsa), code);

	if code ^= 0
	then call com_err_ (code, NAME);
	return;
     end asum_data_;




		    asum_error_.pl1                 05/09/85  1151.3rew 05/07/85  1544.3       17829



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */
/* asum_error_ -- general error trap */

/* format: style2 */

/**** Written 1985-02-20 by BIM */

asum_error_:
     procedure options (variable);

	declare error_switch	 bit (1) aligned;
	declare as_user_message_error_ condition;

	declare admin_gate_$syserr	 entry options (variable);
	declare cu_$arg_list_ptr	 entry returns (ptr);
	declare cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare convert_status_code_	 entry (fixed binary (35), character (8) aligned, character (100) aligned);
	declare ioa_$general_rs	 entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21),
				 bit (1) aligned, bit (1) aligned);


	declare ioa_		 entry () options (variable);

%include asum_data_;
%include syserr_constants;


	declare code_ptr		 pointer;
	declare code		 fixed bin (35) based (code_ptr);
	declare error_message	 char (100) aligned;
	declare message_1		 char (1000);
	declare name_ptr		 ptr;
	declare name_length		 fixed bin (21);
	declare name		 char (name_length) based (name_ptr);


	error_switch = "1"b;
	go to COMMON;
log:
     entry;
	error_switch = "0"b;

COMMON:
	call cu_$arg_ptr (1, code_ptr, (0), (0));
	if code ^= 0
	then call convert_status_code_ (code, "", error_message);
	else error_message = "";

	call cu_$arg_ptr (2, name_ptr, name_length, (0));
	message_1 = "";
	call ioa_$general_rs (cu_$arg_list_ptr (), 3, 4, message_1, (0), "0"b, "0"b);
	if asum_data_$db_multiclass
	then call admin_gate_$syserr (LOG, "^a: ^a ^a", name, error_message, message_1);
	else call ioa_ ("^a: ^a ^a", name, error_message, message_1);
	if error_switch
	then signal as_user_message_error_;
     end asum_error_;




		    asum_find_segment_.pl1          04/09/85  1435.7r w 04/08/85  1128.1       28305



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */
/* asum_find_segment_ -- per-process finder of existing segments.
   assumes that asum_data_$system_info_ptr is set.
   tolerates asum_data_$process_info_ptr = null ();
*/

/* format: style5,indcomtxt */

/**** Written 1985-02-20 by BIM */

asum_find_segment_:
        procedure (P_segment_index, P_segment_ptr);

        declare P_segment_index	fixed bin;      /* Which segment do we create ? */
        declare P_segment_ptr		pointer;

        dcl     null		builtin;
        dcl     string		builtin;

%include asum_data_;
%include as_user_message_system;
%include access_mode_values;
%page;

        declare code		fixed bin (35);
        declare segment_entryname	char (32);
        declare seg_ptr		pointer;
        declare first		bit (1) aligned;

        declare asum_error_		entry options (variable);
					      /* signals a condition, unwinding */

        declare initiate_file_	entry (character (*), character (*),
				bit (*), pointer, fixed binary (24),
				fixed binary (35));
        declare pathname_		entry (character (*), character (*))
				returns (character (168));
%page;

        first = "0"b;
        go to COMMON;

first:
        entry;
        first = "1"b;
COMMON:
        as_user_message_perprocess_info_ptr = asum_data_$process_info_ptr;
        as_user_message_system_info_ptr = asum_data_$system_info_ptr;

        if ^first then
	      do;
	      as_user_message_segment_name.constant =
		AS_USER_MESSAGE_SEGMENT_NAME_CONSTANT;
	      as_user_message_segment_name.index = P_segment_index;

	      segment_entryname = string (as_user_message_segment_name);
	      end;
        else
	      segment_entryname = AS_USER_MESSAGE_SYSTEM_NAME;

        seg_ptr = null ();
        if ^first then
	      if asum_data_$process_info_ptr ^= null () then
		    call look_in_perprocess_info;

        if seg_ptr = null () then
	      do;
	      call initiate_file_ (asum_data_$db_dir, segment_entryname,
		RW_ACCESS, seg_ptr, (0), code);
	      if code ^= 0 then
		    if ^first then
			  call asum_error_ (code, "asum_find_segment_",
			      "Missing segment index ^d", P_segment_index)
			      ;
		    else
			  call asum_error_ (code, "asum_find_segment_",
			      "Missing as_user_message_system_data");
	      if asum_data_$process_info_ptr ^= null () then
		    if ^first then
			  as_user_message_perprocess_info
			      .mseg_ptr (P_segment_index) = seg_ptr;
		    else
			  asum_data_$system_info_ptr = seg_ptr;

	      end;

        if ^first then
	      P_segment_ptr = seg_ptr;
        return;

look_in_perprocess_info:
        procedure;

        if as_user_message_perprocess_info.mseg_ptr (P_segment_index) ^= null ()
	  then
	      seg_ptr =
		as_user_message_perprocess_info.mseg_ptr (P_segment_index);
        return;

        end look_in_perprocess_info;

        end asum_find_segment_;





		    asum_inner_ring_caller_.pl1     05/17/85  1652.7rew 05/17/85  1644.7       53253



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

/* asum_inner_ring_caller_ -- sets up an error handler and cleanup handler,
   sets up perprocess info, find the first segment, and calls the
   real target. The system info ptr and perprocess info per are set
   in static to avoid massively complicated arg list manipulation. */

/* format: style2,indcomtxt */

/**** Written 1985-02-20 by BIM
      Modified 1985-05-17 by E. Swenson: Added check for locked database.
*/

asum_inner_ring_caller_:
     procedure (P_target, P_arg_list_ptr);

/* Parameters */

	declare P_target		 entry variable;
	declare P_arg_list_ptr	 pointer;

/* Entries */

	declare admin_gate_$syserr	 entry options (variable);
	declare asum_error_		 entry options (variable);
	declare asum_find_segment_$first
				 entry;
	declare cu_$generate_call	 entry (entry, ptr);
	declare cu_$level_get	 entry returns (fixed bin (3));
	declare cu_$level_set	 entry (fixed bin (3));
	declare get_process_id_	 entry () returns (bit (36));
	declare get_lock_id_	 entry () returns (bit (36));
declare  get_group_id_ entry() returns(char(32));
	declare get_ring_		 entry () returns (fixed bin (3));
	declare get_system_free_area_	 entry () returns (ptr);
	declare ioa_		 entry options (variable);
	declare set_lock_$unlock	 entry (bit (36) aligned, fixed binary (35));
	declare sub_err_		 entry options (variable);

/* External */

	declare error_table_$fatal_error
				 fixed bin (35) external;
	declare sys_info$time_of_bootload
				 fixed bin (71) aligned external;

/* Constant */

	dcl     ME		 char (32) initial ("asum_inner_ring_caller_") internal static options (constant);

/* Conditions */

	declare cleanup		 condition;
	declare as_user_message_error_ condition;

/* Misc */

	declare system_area		 area based (get_system_free_area_ ());
	declare initial_switch	 bit (1) aligned;

	dcl     null		 builtin;

%page;
	initial_switch = "0"b;
	as_user_message_system_info_ptr = asum_data_$system_info_ptr;
	go to COMMON;

initial:
     entry (P_target, P_arg_list_ptr);
	initial_switch = "1"b;

COMMON:
	asum_data_$entry_ring = cu_$level_get ();
	on cleanup
	     begin;
		call cu_$level_set (asum_data_$entry_ring);
		if ^initial_switch
		then if asum_data_$db_locked
		     then do;
			     call set_lock_$unlock (as_user_message_system_info.lock, (0));
			     asum_data_$db_locked = "0"b;
			end;
	     end;

	on as_user_message_error_ /* message is already written */ goto NON_LOCAL_ABORT;
						/* will cause cleanup handlers to run */

	call cu_$level_set (get_ring_ ());
	if ^initial_switch
	then call get_static_pointers;		/* insures that we have the neccessary pointers */

	call cu_$generate_call (P_target, P_arg_list_ptr);

	if ^initial_switch
	then if asum_data_$db_locked
	     then do;
		     call set_lock_$unlock (as_user_message_system_info.lock, (0));
		     asum_data_$db_locked = "0"b;
		     if asum_data_$db_multiclass
		     then call admin_gate_$syserr (LOG, "^a: ASUM database found locked after return from call by ^a.", ME, get_group_id_ ());
		     else call ioa_ ("^a: ASUM database found locked after return from call by ^a.", ME, get_group_id_ ());
		end;

	call cu_$level_set (asum_data_$entry_ring);
	return;

/**** The following code is executed upon any ASUM program signalling
      the as_user_message_error_ condition.  The non-local goto will
      cause cleanup handlers to run.  Then we will check to see if the
      database is locked, and unlock it if necessary.  We will also
      reset the validation level. */

NON_LOCAL_ABORT:
	if ^initial_switch
	then if asum_data_$db_locked
	     then do;
		     call set_lock_$unlock (as_user_message_system_info.lock, (0));
		     asum_data_$db_locked = "0"b;
		end;
	call cu_$level_set (asum_data_$entry_ring);
	call sub_err_ (error_table_$fatal_error, ME, ACTION_CANT_RESTART, null (), (0),
	     "An unexpected error has occured during the execution of an as user message facility program.  See the syserr log for details."
	     );
	return;

get_static_pointers:
     procedure;

	if asum_data_$process_info_ptr = null ()
	then do;
		asum_data_$process_id = get_process_id_ ();
		asum_data_$lock_id = get_lock_id_ ();
		allocate as_user_message_perprocess_info in (system_area);
		as_user_message_perprocess_info.sentinel = AS_USER_MESSAGE_PROCESS_SENTINEL;
		as_user_message_perprocess_info.mseg_ptr (*) = null ();
		asum_data_$process_info_ptr = as_user_message_perprocess_info_ptr;
	     end;

	if asum_data_$system_info_ptr = null ()
	then do;
		call asum_find_segment_$first;
		as_user_message_system_info_ptr = asum_data_$system_info_ptr;
		if as_user_message_system_info.time_of_bootload ^= sys_info$time_of_bootload
		then call asum_error_ (0, "asum_inner_ring_caller_", "as_user_message facility not initialized.");
	     end;
	return;
     end get_static_pointers;

/* format: off */

%page; %include as_user_message_system;
%page; %include asum_data_;
%page; %include sub_err_flags;
%page; %include syserr_constants;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   asum_inner_ring_caller_: ASUM database found locked after return from call 
      by GROUP_ID

   S:	$info

   T:	$run

   M:	$err
   The AS user message facility was called and upon return from the call
   the transfer routine asum_inner_ring_caller_ detected that the ASUM
   database (>sc1>user_messages>as_user_message_system) was left locked.
   The lock has been unlocked but the database may be inconsistent.
   This should never happen and if it does, indicates a coding error in the
   AS user message facility.  

   A:	$contact

   END MESSAGE DOCUMENTATION */

     end asum_inner_ring_caller_;




		    asum_read_delete_ops_.pl1       08/04/87  1446.2rew 08/04/87  1221.5      186426



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


/****^  HISTORY COMMENTS:
  1) change(85-06-12,Swenson), approve(86-07-25,MCR7302),
     audit(86-08-13,EJSharpe), install(86-09-04,MR12.0-1147):
     Fixed setting of highest_in_use counter when messages are deleted from db.
  2) change(85-08-01,Swenson), approve(86-07-25,MCR7302),
     audit(86-08-13,EJSharpe), install(86-09-04,MR12.0-1147):
     Fixed to correctly perform access checks for unprivileged read entries.
  3) change(87-05-31,GDixon), approve(87-07-07,MCR7719),
     audit(87-06-24,Hartogs), install(87-08-04,MR12.1-1055):
     Sort destination_am entries by message_id in admin_search, so that entries
     can be read out in successive calls by message_id.
  4) change(87-06-24,GDixon), approve(87-07-07,MCR7719),
     audit(87-06-24,Hartogs), install(87-08-04,MR12.1-1055):
     Change calling sequence of priv_delete_process_id to properly declare
     the process_id as bit(36) aligned.
                                                   END HISTORY COMMENTS */


/* asum_read_delete_ops_.pl1 -- all entries that read and/or delete
   messages. */

/* format: style2 */

asum_read_delete_ops_:
     procedure;

/***** Modification history:

       Created 1985-02-11, BIM
       Modified 1985-04, BIM: new mseg_ calling sequence
       Modified 1985-05-17, EJS: Fixed failure to unlock when no message
          is found for a user.
*/

/**** This procedure contains all the entries that have to search
      the database. They are collected here to share internal procedures
      that search the handle/pid associative memory. */

/**** ENTRIES HERE ARE GATE TARGETS! */


%include asum_data_;

	declare aim_check_$equal	 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	declare aim_check_$greater_or_equal
				 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	declare asum_find_segment_	 entry (fixed binary, pointer);
	declare asum_error_		 entry () options (variable);
	declare match_star_name_	 entry (character (*), character (*), fixed binary (35));
	declare get_group_id_	 entry () returns (char (32));
	declare get_process_authorization_
				 entry () returns (bit (72) aligned);
	declare get_privileges_	 entry () returns (bit (36) aligned);
	declare set_lock_$lock	 entry (bit (36) aligned, fixed binary, fixed binary (35));
	declare set_lock_$unlock	 entry (bit (36) aligned, fixed binary (35));


	declare 1 admin_read_info	 aligned like as_user_message_admin_read_info;
	declare 1 read_info		 aligned like as_user_message_info;
	declare 1 search		 aligned,
		2 process_id	 bit (36) aligned,	/** 777777777777 for ANY */
		2 ring		 fixed bin (3) aligned,
						/** -1 for ANY */
		2 handle		 bit (72) aligned,	/** zero for ANY */
		2 message_id	 bit (72) aligned,
		2 read_this_one	 bit (1) aligned,
		2 read_the_next_one	 bit (1) aligned,
		2 aim_privileged	 bit (1) aligned,
		2 authorization	 bit (72) aligned,
		2 delete		 bit (1) aligned,
		2 group_id	 char (32) unaligned;

	declare 1 mop		 aligned like mseg_operation;

	declare g_message_id	 bit (72) aligned;
	declare g_process_id	 bit (36) aligned;
	declare delete_the_message	 bit (1) aligned;

	declare P_area_ptr		 pointer;
	declare P_admin_read_info_ptr	 pointer;
	declare area_ptr		 pointer;
	declare P_read_info_ptr	 pointer;
	declare read_info_ptr	 pointer;
	declare P_message_id	 bit (72) aligned;
	declare P_process_id	 bit (36) aligned;
	declare P_code		 fixed bin (35);
	declare code		 fixed bin (35);

	declare sys_info$ring1_privilege
				 bit (36) aligned ext;
	declare error_table_$notalloc	 fixed bin (35) ext static;
	declare error_table_$unimplemented_version
				 fixed bin (35) ext static;
	declare error_table_$bad_arg	 fixed bin (35) ext static;
	declare error_table_$no_message
				 fixed bin (35) ext static;

	dcl     addr		 builtin;
	dcl     divide		 builtin;
	dcl     max		 builtin;
	dcl     stacq		 builtin;
	dcl     unspec		 builtin;


user_read_message:
     entry (P_area_ptr, P_read_info_ptr, P_code);

	code = 0;

/**** COPY PARAMETERS IN */

	area_ptr = P_area_ptr;
	read_info_ptr = P_read_info_ptr;
	read_info = read_info_ptr -> as_user_message_info;

	as_user_message_system_info_ptr = asum_data_$system_info_ptr;

	if read_info.version ^= AS_USER_MESSAGE_INFO_VERSION_1
	then call error_return (error_table_$unimplemented_version, USER_READ_ERROR);


/****+ What search criteria do we have? 
         Process_id         --- this process
         Handle             --- as given (if any)
         Prev_message_id    --- as given (if any)
         Ring               --- as given (if any)
         */

/**** The structure "search" is used as an implicit parameter by 
      search table to describe the search information. */

	unspec (search) = ""b;
	search.process_id = asum_data_$process_id;
	search.group_id = get_group_id_ ();
	if read_info.no_handle_given
	then search.handle = ""b;
	else if read_info.message_handle = ""b
	then call error_return (error_table_$bad_arg, USER_READ_ERROR);
	else search.handle = read_info.message_handle;
	if read_info.read_message_id & read_info.read_after_message_id
	then call error_return (error_table_$bad_arg, USER_READ_ERROR);
	if read_info.read_message_id
	then do;
		search.message_id = read_info.message_id;
		search.read_this_one = "1"b;
	     end;
	if read_info.read_after_message_id
	then do;
		search.message_id = read_info.message_id;
		search.read_the_next_one = "1"b;
	     end;
	search.delete = ^read_info.dont_delete;		/* if message is to be deleted, take it out of the list NOW */
	if read_info.ring_given
	then search.ring = max (asum_data_$entry_ring, read_info.message_ring);
	else search.ring = asum_data_$entry_ring;	/*  so that only one process can read it */
	search.authorization = get_process_authorization_ ();
	search.aim_privileged = ((get_privileges_ () & sys_info$ring1_privilege) ^= ""b);

	call lock_database;				/* This could all be done locklessly, but that efficiency is */
						/*  not neccessary for MR11 */

	g_message_id = search_table ();		/* Look for a message; delete_message is also set to the index in the table */

	if g_message_id = ""b
	then do;
		call unlock_database;
		call error_return (error_table_$no_message, USER_READ_ERROR);
	     end;

/**** we know which message we want by ID. It has not been deleted from the mseg yet, even if it is to be. */

	call read_out_message (g_message_id, code);	/* sets fields in read_info, allocates in area, deletes as needed */

	if code ^= 0 & code ^= error_table_$notalloc
	then call asum_error_ (code, "asum_read_delete_ops_", "Message ^.3b missing.", g_message_id);

	call unlock_database;

	P_code = code;
	read_info_ptr -> as_user_message_info = read_info;
	return;

USER_READ_ERROR:
	return;


priv_delete_message_id:
     entry (P_message_id, P_code);

	code = 0;
	g_message_id = P_message_id;

	as_user_message_system_info_ptr = asum_data_$system_info_ptr;

	call lock_database;

	call delete$$message_id (code);

	call unlock_database;

	P_code = code;
	return;


priv_delete_process_id:
     entry (P_process_id, P_code);

	code = 0;
	g_process_id = P_process_id;

	as_user_message_system_info_ptr = asum_data_$system_info_ptr;

	call lock_database;

	call delete$$process_id (code);

	call unlock_database;


	code = P_code;
	return;


admin_read:
     entry (P_admin_read_info_ptr, P_read_info_ptr, P_area_ptr, P_code);

	code = 0;
	as_user_message_admin_read_info_ptr = P_admin_read_info_ptr;
	as_user_message_info_ptr = P_read_info_ptr;
	area_ptr = P_area_ptr;

	admin_read_info = as_user_message_admin_read_info;
	read_info = as_user_message_info;
	as_user_message_system_info_ptr = asum_data_$system_info_ptr;

	if admin_read_info.version ^= AS_USER_MESSAGE_ADMIN_READ_INFO_VERSION_1
	     | read_info.version ^= AS_USER_MESSAGE_INFO_VERSION_1
	then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	call lock_database;
	call admin_search;
	call unlock_database;
	P_code = code;
	as_user_message_info = read_info;
	return;
















delete$$message_id:
     procedure (code);

	declare code		 fixed bin (35);
	declare delete_by		 fixed bin (1);
	declare (
	        MID		 init (0),
	        PID		 init (1)
	        )			 fixed bin int static options (constant);
	declare 1 am		 aligned like as_user_message_system_info.destination_am based (amep);
	declare amep		 pointer;
	declare hx		 fixed bin;

	delete_by = MID;
	go to COMMON;

delete$$process_id:
     entry (code);

	delete_by = PID;

COMMON:
	code = error_table_$no_message;
	do hx = 1 to as_user_message_system_info.highest_in_use;
	     amep = addr (as_user_message_system_info.destination_am (hx));
	     if am.process_id = ""b
	     then ;
	     else if delete_by = PID
	     then do;
		     if am.process_id = g_process_id
		     then do;
			     call delete_mseg_msg (am.message_id);
			     call delete_am_entry (hx);
			     code = 0;		/* got one */
			end;
		end;
	     else if delete_by = MID
	     then do;
		     if am.message_id = g_message_id
		     then do;
			     call delete_mseg_msg (am.message_id);
			     call delete_am_entry (hx);
			     code = 0;		/* got one */
			     return;		/* only one per */
			end;
		end;
	end;
	return;					/* no_message */
     end delete$$message_id;

search_table:
     procedure returns (bit (72) aligned);

/**** This procedure searches for destination matches, looking for the
      oldest message that matches. Since this implementation keeps the
      table locked for the duration, this can assume that nothing will
      change. */

	declare youngest_message_id	 bit (72) aligned;
	declare amep		 pointer;
	declare 1 am		 aligned like as_user_message_system_info.destination_am based (amep);
	declare am_real_message_id	 bit (72) aligned;
	declare search_real_message_id bit (72) aligned;
	declare x			 fixed bin;
	declare message_x		 fixed bin;

	youngest_message_id = (72)"1"b;

	delete_the_message = "0"b;

	unspec (as_user_message_id) = search.message_id;
	as_user_message_id.segment_index = 0;
	search_real_message_id = unspec (as_user_message_id);

	do x = 1 to as_user_message_system_info.highest_in_use;
	     amep = addr (as_user_message_system_info.destination_am (x));
	     if am.process_id = ""b
	     then go to TRY_NEXT;

	     if (am.process_id ^= (36)"1"b) & (search.process_id ^= am.process_id)
	     then go to TRY_NEXT;
	     if (am.process_id = (36)"1"b) & ^group_match (am.group_id, search.group_id)
	     then go to TRY_NEXT;
	     if (search.ring >= 0) & (search.ring ^= am.ring)
	     then go to TRY_NEXT;
	     if (search.handle ^= ""b) & (search.handle ^= am.handle)
	     then go to TRY_NEXT;

	     if ^check_aim ()
	     then goto TRY_NEXT;

	     else if search.read_this_one
	     then /* No other matching required */
		if am.message_id = search.message_id
		then return (SET_RETURN_INFO_AND_MAYBE_DELETE (x));
		else ;
	     else do;
		     unspec (as_user_message_id) = am.message_id;
		     as_user_message_id.segment_index = 0;
		     am_real_message_id = unspec (as_user_message_id);

		     if (search.read_the_next_one & am_real_message_id > search_real_message_id)
			| ^search.read_the_next_one
		     then if am_real_message_id < youngest_message_id
			then do;
				youngest_message_id = am_real_message_id;
				message_x = x;
			     end;
		end;
TRY_NEXT:
	end;

	if youngest_message_id = (72)"1"b
	then return (""b);
	else return (SET_RETURN_INFO_AND_MAYBE_DELETE (message_x));
%page;
check_aim:
     procedure returns (bit (1) aligned);

	if search.aim_privileged
	then return ("1"b);
	if aim_check_$greater_or_equal (search.authorization, am.access_class)
	then return ("1"b);				/* Deletion AIM later on */
	return ("0"b);
     end check_aim;

SET_RETURN_INFO_AND_MAYBE_DELETE:
     procedure (P_message_index) returns (bit (72) aligned);

	dcl     P_message_index	 fixed bin parameter;
	dcl     message_id		 bit (72) aligned automatic;

	amep = addr (as_user_message_system_info.destination_am (P_message_index));
	read_info.destination_info.group_id = am.group_id;
	read_info.destination_info.process_id = am.process_id;
	read_info.destination_info.ring = am.ring;
	read_info.message_info.message_handle = am.handle;
	message_id = am.message_id;

	if am.reader_deletes & search.delete
	then do;
		if search.aim_privileged | aim_check_$equal (search.authorization, am.access_class)
		then do;
			call delete_am_entry (P_message_index);
			delete_the_message = "1"b;
		     end;
	     end;
	return (message_id);

     end SET_RETURN_INFO_AND_MAYBE_DELETE;

     end search_table;

group_match:
     procedure (star, try) returns (bit (1) aligned);

	declare (star, try)		 char (32);
	declare code		 fixed bin (35);

	if star = ""
	then return ("1"b);
	call match_star_name_ (try, star, code);
	return (code = 0);
     end group_match;

read_out_message:
     procedure (a_mid, code);
	declare a_mid		 bit (72) aligned;
	declare code		 fixed bin (35);
	declare fx		 fixed bin;
	declare mseg_ptr		 pointer;

	unspec (as_user_message_id) = a_mid;
	fx = as_user_message_id.segment_index;
	as_user_message_id.segment_index = 0;
	mop = addr (mseg_data_$template_operation) -> mseg_operation;
	mop.message_info.message_code = MSEG_READ_SPECIFIED;
	mop.message_info.control_flags = ""b;
	mop.message_info.delete = delete_the_message;
	mop.message_info.ms_id = unspec (as_user_message_id);
	mop.suppress_access_checks = "1"b;
	mop.message_info_valid = "1"b;
	call asum_find_segment_ (fx, mseg_ptr);
	mop.mseg_ptr = mseg_ptr;
	mop.mseg_ptr_valid = "1"b;
	call mseg_$read_message (addr (mop), area_ptr, code);
	read_info.message_ptr = mop.message_info.ms_ptr;
	read_info.message_length = divide (mop.message_info.ms_len, 36, 18, 0);
	read_info.message_id = mop.message_info.ms_id;
	read_info.message_info.message_access_class = mop.message_info.ms_access_class;
	read_info.message_info.message_ring = mop.message_info.sender_level;
						/* messages don't have rings */
	read_info.sender_info.group_id = mop.message_info.sender_id;
	read_info.sender_info.process_id = mop.message_info.sender_process_id;
	return;

     end read_out_message;

delete_mseg_msg:
     procedure (a_mid);

	declare a_mid		 bit (72) aligned;
	declare code		 fixed bin (35);
	declare fx		 fixed bin;
	declare mseg_ptr		 pointer;

	unspec (as_user_message_id) = a_mid;
	fx = as_user_message_id.segment_index;
	as_user_message_id.segment_index = 0;
	call asum_find_segment_ (fx, mseg_ptr);
	mop = addr (mseg_data_$template_operation) -> mseg_operation;
	mop.message_info.ms_id = unspec (as_user_message_id);
	mop.message_info_valid = "1"b;
	mop.suppress_access_checks = "1"b;
	call asum_find_segment_ (fx, mseg_ptr);
	mop.mseg_ptr = mseg_ptr;
	mop.mseg_ptr_valid = "1"b;

	call mseg_$delete_message (addr (mop), code);
	if code ^= 0
	then call asum_error_ (code, "asum_read_delete_ops_", "Failed to delete message ^.3b from message segment ^d.",
		a_mid, fx);
	return;
     end delete_mseg_msg;

error_return:
     procedure (code, return_label);
	declare code		 fixed bin (35);
	declare return_label	 label;

	P_code = code;
	go to return_label;
     end error_return;


admin_search:
     procedure;

/**** DUMB program to search against the admin_search data structure */

	declare 1 am		 aligned based (amep)
				 like as_user_message_system_info.destination_am;
	declare amep		 pointer;
	declare hx		 fixed bin;
	declare mid_mask		 bit (72) aligned init ("000777777777777777777777"b3) int static
				 options (constant);
	declare 1 min_am		 aligned based (min_amep)
				 like as_user_message_system_info.destination_am;
    	declare min_amep		 pointer;
          declare minx		 fixed bin;
	declare 1 temp_am		 aligned like as_user_message_system_info.destination_am automatic;

	if as_user_message_system_info.highest_in_use = 0 then
	code = error_table_$no_message;

/**** This algorithm depends upon the destination_am being sorted in message_id
      order, so we can step through from one id to the next in successive
      admin_read calls. */

	do minx = 1 to as_user_message_system_info.highest_in_use-1;
	     min_amep = addr (as_user_message_system_info.destination_am (minx));
	     do hx = minx to as_user_message_system_info.highest_in_use;
		amep = addr (as_user_message_system_info.destination_am (hx));
		if min_am.message_id > am.message_id then do;
		     temp_am = am;
		     am = min_am;
		     min_am = temp_am;
		end;
	     end;
	end;

	search.authorization = get_process_authorization_ ();
	search.aim_privileged = ((get_privileges_ () & sys_info$ring1_privilege) ^= ""b);

	do hx = 1 to as_user_message_system_info.highest_in_use;
	     amep = addr (as_user_message_system_info.destination_am (hx));
	     if am.process_id = ""b
	     then go to TRY_NEXT;
	     if admin_read_info.after_message_id ^= ""b
	     then if (am.message_id & mid_mask) <= (admin_read_info.after_message_id & mid_mask)
		then go to TRY_NEXT;
	     if admin_read_info.target_handle ^= ""b
	     then if am.handle ^= admin_read_info.target_handle
		then go to TRY_NEXT;
	     if admin_read_info.target_process_id ^= ""b
	     then if am.process_id ^= admin_read_info.target_process_id
		then go to TRY_NEXT;
	     if admin_read_info.target_group_id ^= ""
	     then if ^group_match (admin_read_info.target_group_id, am.group_id)
		then go to TRY_NEXT;

	     if ^search.aim_privileged
	     then if ^aim_check_$greater_or_equal (search.authorization, am.access_class)
		then go to TRY_NEXT;

/**** Well, the target spec matches. If there is a source spec, we have to
      read the message out to see who sent it. Pain, as they say, in the ass.
*/

	     delete_the_message = "0"b;
	     call read_out_message (am.message_id, code);
	     if code ^= 0 & code ^= error_table_$notalloc
	     then call asum_error_ (code, "asum_read_delete_ops_", "Failed to read out message ^.3b", am.message_id);
	     if code ^= 0
	     then return;				/* Caller area too small */

	     if (admin_read_info.source_group_id ^= ""
		& ^group_match (admin_read_info.source_group_id, mop.message_info.sender_id))
		| (admin_read_info.source_process_id ^= ""b
		& admin_read_info.source_process_id ^= mop.message_info.sender_process_id)
	     then begin;
		     declare to_free	      bit (mop.message_info.ms_len) based (mop.message_info.ms_ptr);
		     free to_free;
		     go to TRY_NEXT;
		end;

	     read_info.destination_info.group_id = am.group_id;
	     read_info.destination_info.process_id = am.process_id;
	     read_info.destination_info.ring = am.ring;
	     read_info.sender_info.group_id = mop.message_info.sender_id;
	     read_info.sender_info.process_id = mop.message_info.sender_process_id;
	     read_info.message_handle = am.handle;
	     read_info.dont_delete = ^am.reader_deletes;
	     return;
TRY_NEXT:
	end;
	code = error_table_$no_message;
	return;
     end admin_search;
%page;
delete_am_entry:
     procedure (amx);

	declare amx		 fixed bin;
	declare hx		 fixed bin;

	declare q			 bit (1) aligned;

	q = stacq (as_user_message_system_info.destination_am (amx).process_id, ""b,
	     (as_user_message_system_info.destination_am (amx).process_id));
	if amx = as_user_message_system_info.highest_in_use
	then do;
		do hx = amx to 1 by -1 while (as_user_message_system_info.destination_am (hx).process_id = ""b);
		end;				/* hx is 0 or index of last in use */
		as_user_message_system_info.highest_in_use = hx;
	     end;
	return;
     end delete_am_entry;

lock_database:
     procedure;

	if ^stacq (as_user_message_system_info.lock, asum_data_$lock_id, ""b)
	then call set_lock_$lock (as_user_message_system_info.lock, -1, (0));
	asum_data_$db_locked = "1"b;
	return;
     end lock_database;

unlock_database:
     procedure;

	if ^stacq (as_user_message_system_info.lock, ""b, asum_data_$lock_id)
	then call set_lock_$unlock (as_user_message_system_info.lock, (0));
	asum_data_$db_locked = "0"b;
	return;
     end unlock_database;

/* format: off */
%page; %include as_user_message_system;
%page; %include mseg_message_info;
%page; %include as_user_message_info;
%page; %include as_user_message_aread;
%page; %include mseg_operation;
%page; %include mseg_access_operation;
%page; %include mseg_wakeup_state;
%page; %include entry_access_info;
%page; %include mseg_entries;
%page; %include mseg_data_;

     end asum_read_delete_ops_;




		    asum_system_init_.pl1           08/04/87  1446.2rew 08/04/87  1221.6       70101



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


/****^  HISTORY COMMENTS:
  1) change(86-03-28,Swenson), approve(87-07-07,MCR7719),
     audit(87-06-24,Hartogs), install(87-08-04,MR12.1-1055):
     Fixed so that the Initializer process can use the UM facility.
                                                   END HISTORY COMMENTS */


/* asum_system_init_.pl1 -- program called by the initializer
   to set up as_user_messages */

/* format: style5,indcomtxt */

asum_system_init_:
        procedure (P_error_code);		      /* Full complaint registered via syserr */

/**** Created: 1985-02-01, BIM */

        declare P_error_code		fixed bin (35);

        declare asum_error_$log	entry options (variable);
        declare asum_create_segment_	entry (fixed binary, pointer);
        declare asum_create_segment_$first
				entry (pointer);
        declare expand_pathname_	entry (character (*), character (*),
				character (*), fixed binary (35));
        dcl     get_process_id_	entry () returns (bit (36) aligned);
        dcl     get_lock_id_		entry () returns (bit (36) aligned);
        declare get_system_free_area_	entry () returns (ptr);
        declare hcs_$star_		entry (char (*), char (*),
				fixed bin (2), ptr, fixed bin, ptr, ptr,
				fixed bin (35));
        declare hcs_$status_minf	entry (char (*), char (*),
				fixed bin (1), fixed bin (2),
				fixed bin (24), fixed bin (35));
        declare hcs_$create_branch_	entry (char (*), char (*), ptr,
				fixed bin (35));
        declare hphcs_$delentry_file	entry (char (*), char (*),
				fixed bin (35));
        declare hphcs_$chname_file	entry (char (*), char (*), char (*),
				char (*), fixed bin (35));
        declare hcs_$replace_inacl	entry (char (*), char (*), ptr,
				fixed bin, bit (1), fixed bin (3),
				fixed bin (35));
        declare pathname_		entry (character (*), character (*))
				returns (character (168));
        declare unique_chars_		entry (bit (*)) returns (char (15));

        declare code		fixed bin (35);

        declare error_table_$noentry	fixed bin (35) ext static;
        declare sys_info$time_of_bootload
				fixed bin (71) ext;

        dcl     addr		builtin;
        dcl     null		builtin;
        dcl     sum			builtin;
        dcl     unspec		builtin;
%page;
%include as_user_message_system;
%include asum_data_;


        P_error_code = 0;
        call find_or_create_db_dir;
        call clean_out_db_dir;
        call initialize_first_segment;
        return;

ERROR:
        P_error_code = -1;
        return;


find_or_create_db_dir:
        procedure;

        declare type		fixed bin (2);

        call hcs_$status_minf (asum_data_$db_dir, "", (0), type, (0), code);
        if code = error_table_$noentry then
	      call create_db_dir;
        else if code ^= 0 then
	      do;
	      call remove_old_entry;
	      call create_db_dir;
	      end;
        else if type ^= 2			      /* Directory */
	  then
	      do;
	      call rename_old_entry;
	      call create_db_dir;
	      end;

        return;

remove_old_entry:
        procedure;

        call asum_error_$log (0, "asum_system_init_",
	  "Cannot get status of ^a. It will be deleted.", asum_data_$db_dir);
        call hphcs_$delentry_file (asum_data_$db_dir, "", code);
        if code ^= 0 then
	      do;
	      call asum_error_$log (code, "asum_system_init_",
		"Failed to delete old db_dir ^a", asum_data_$db_dir);
	      go to ERROR;
	      end;

        return;

        end remove_old_entry;

rename_old_entry:
        procedure;

        declare shriek		char (15);
        declare entryname		char (32);

        shriek = unique_chars_ (""b);
        call expand_pathname_ (asum_data_$db_dir, (""), entryname, (0));
        call asum_error_$log (0, "asum_system_init_",
	  "^a is not a directory. It will be renamed to ^a.",
	  asum_data_$db_dir, shriek);
        call hphcs_$chname_file (asum_data_$db_dir, "", entryname, shriek, code)
	  ;
        if code ^= 0 then
	      do;
	      call asum_error_$log (code, "asum_system_init_",
		"Failed to rename ", asum_data_$db_dir);
	      go to ERROR;
	      end;
        return;
        end rename_old_entry;

create_db_dir:
        procedure;


        declare dir_name		char (168);
        declare entryname		char (32);

        call asum_error_$log (0, "asum_system_init_", "Creating directory ^a",
	  asum_data_$db_dir);
        call expand_pathname_ (asum_data_$db_dir, dir_name, entryname, (0));
        call hcs_$create_branch_ (dir_name, entryname,
	  addr (asum_data_$db_dir_cbi), code);
        if code ^= 0 then
	      do;
	      call asum_error_$log (code, "asum_system_init_",
		"Failed to create ^a", asum_data_$db_dir);
	      go to ERROR;
	      end;
        call hcs_$replace_inacl (asum_data_$db_dir, "",
	  addr (asum_data_$acl_entries), asum_data_$n_acl_entries, "1"b,
	  (asum_data_$db_rb (1)), code);
        if code ^= 0 then
	      do;
	      call asum_error_$log (code, "asum_system_init_",
		"Failed to set inital acl of ^a", asum_data_$db_dir);
	      go to ERROR;
	      end;
        return;
        end create_db_dir;
        end find_or_create_db_dir;


clean_out_db_dir:
        procedure;

        declare sx			fixed bin;

        call hcs_$star_ (asum_data_$db_dir, "**", star_ALL_ENTRIES,
	  get_system_free_area_ (), star_entry_count, star_entry_ptr,
	  star_names_ptr, code);

        if code ^= 0 then
	      return;

        do sx = 1 to star_entry_count;
	      call hphcs_$delentry_file (asum_data_$db_dir,
		star_names (star_entries (sx).nindex), code);
	      if code ^= 0 then
		    call asum_error_$log (code, "asum_system_init_",
		        "Failed to delete ^a",
		        pathname_ (asum_data_$db_dir,
		        star_names (star_entries (sx).nindex)));
        end;
        free star_names;
        free star_entries;
        return;


%include star_structures;

        end clean_out_db_dir;


initialize_first_segment:
        procedure;

        declare first_segment_ptr	pointer;
        declare sys_area		area based (get_system_free_area_ ());

        allocate as_user_message_perprocess_info in (sys_area);
        asum_data_$process_info_ptr = as_user_message_perprocess_info_ptr;

/**** Be sure to set these values, or else the process which calls this
      entry will never be able to use the ASUM facility itself. */

        asum_data_$process_id = get_process_id_ ();
        asum_data_$lock_id = get_lock_id_ ();

        as_user_message_perprocess_info.sentinel =
	  AS_USER_MESSAGE_PROCESS_SENTINEL;
        as_user_message_perprocess_info.mseg_ptr (*) = null ();

        call asum_create_segment_$first (first_segment_ptr);
        as_user_message_system_info_ptr = first_segment_ptr;
        asum_data_$system_info_ptr = first_segment_ptr;

        as_user_message_system_info.sentinel = AS_USER_MESSAGE_SYSTEM_SENTINEL;
        as_user_message_system_info.time_of_bootload =
	  sys_info$time_of_bootload;
        as_user_message_system_info.lock = ""b;
        as_user_message_system_info.n_segments = 1;
        as_user_message_system_info.highest_in_use = 0;
        unspec (as_user_message_system_info.destination_am) = ""b;

        call asum_create_segment_ (0, first_segment_ptr);
        as_user_message_perprocess_info.mseg_ptr (0) = first_segment_ptr;
        return;
        end initialize_first_segment;
        end asum_system_init_;






		    display_user_messages.pl1       07/13/88  1243.4r w 07/13/88  0937.9      396855



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

/****^  HISTORY COMMENTS:
  1) change(87-05-28,GDixon), approve(87-07-07,MCR7719),
     audit(87-07-08,Hartogs), install(87-08-04,MR12.1-1055):
      A) Initial coding, cribbed from display_connection_list.
  2) change(87-07-07,GDixon), approve(87-07-07,MCR7719),
     audit(87-07-08,Hartogs), install(87-08-04,MR12.1-1055):
      A) Remove magic numbers in several places.
      B) Correct coding error in matching_entry subroutine.
                                                   END HISTORY COMMENTS */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* display_user_messages:  a utility to display contents of the	       */
/* active_connection_list table, maintained by the connection_list_manager_  */
/* subsystem.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	

display_user_messages:
     proc;


/* AUTOMATIC */

dcl  brief_sw			bit(1) aligned automatic;
dcl  code				fixed bin(35) automatic;
dcl  entry_var			entry variable;
dcl (exclude, match)		char(100) varying automatic;
dcl  message_handle			bit(72) aligned automatic;
dcl  message_id			bit(72) aligned automatic;
dcl  octal_sw			bit(1) aligned automatic;
dcl  1 source			aligned automatic,
       2 id			char(32),
       2 person			char(24),
       2 project			char(12),
       2 tag			char(1) unal,
       2 tag_pad			char(3) unal;
dcl  source_id			bit(36) aligned automatic;
dcl  system_area_ptr		ptr automatic;
dcl  1 target			aligned automatic like source;
dcl  target_id			bit(36) aligned automatic;


/* BASED */

dcl  system_area			area based (system_area_ptr);
     

/* ENTRIES */

dcl  date_time_$format		entry (char(*), fixed bin(71),
				     char(*), char(*))
				     returns(char(250) var);
dcl  dump_segment_			entry (ptr, ptr, fixed bin,
				     fixed bin(18), fixed bin(18),
				     bit(*));
dcl  get_system_free_area_		entry() returns(ptr);
dcl  ioa_				entry() options(variable);
dcl  user_message_admin_$read_message   entry (ptr, ptr, ptr, fixed bin(35));
	

/* BUILTINS AND CONDITIONS */

dcl (addr, after, before, char, dimension, index, hbound, lbound, length,
     ltrim, max, null, rtrim, size, string, substr, unspec)
				builtin;
dcl (cleanup, linkage_error)		condition;


/* INTERNAL STATIC */

dcl  COMMAND_VERSION		char(3) int static options(constant)
				init("1.0");
dcl  CONTINUATION_LINE		char(8) int static options(constant)
				init("
	      ");
dcl  DO_NOT_BLOCK			fixed bin int static options(constant)
				init(-1);
dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1)
				     int static options(constant);
dcl  ME				char (21) int static options (constant)
				init ("display_user_messages");
dcl  ZERO_OFFSET			fixed bin(18) int static
				options(constant) init(0);

/* EXTERNAL STATIC */

dcl (error_table_$bad_arg,
     error_table_$bad_opt,
     error_table_$no_message)		fixed bin(35) ext static;
dcl  iox_$user_output		ptr ext static;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* INVOCATION TYPE AND ARGUMENTS:				       */
/* 1) Initialize variables, and establish cleanup handler.		       */
/* 2) Create standalone ssu_ invocation for argument processing.	       */
/* 3) Initialize argument handling routines.			       */
/* 4) Process input arguments, reporting any errors as they are encountered. */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

     call initialize_args();
     on cleanup call cleanup_invocation();
     call ssu_$standalone_invocation (sci_ptr, ME, COMMAND_VERSION,
        cu_$arg_list_ptr(),exit_proc, code); 
     call check_invocation_type (ALLOW_COMMAND);
     call process_args();
     call scan_messages();



/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* REVOCATION AND EXIT:					       */
/*   This point is reached when normal processing completes successfully,    */
/* or when the error$fatal routine is called to abnormally end processing.   */
/*							       */
/* 1) Cleanup the standalone invocation.			       */
/* 2) Return to command processor.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

EXIT:
     call cleanup_invocation();
     return;

exit_proc:
     proc;
     go to EXIT;
     end exit_proc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* alloc_aumi: get next aumi structure from array.  Handle array overflow    */
/* gracefully.						       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  1 aumi_struct			structure aligned
				based (aumi_struct_ptr),
       2 count			fixed bin,
       2 max_count			fixed bin,
       2 array (aumi_struct_count refer (aumi_struct.max_count))
				like as_user_message_info;
dcl  aumi_struct_count		fixed bin;
dcl (aumi_struct_ptr, temp_struct_ptr)	ptr;
dcl  1 auto_aumi_struct		structure aligned automatic,
       2 count			fixed bin,
       2 max_count			fixed bin,
       2 array (50)			like as_user_message_info;

dcl  1 aumi			aligned based(aumi_ptr)
				like as_user_message_info;
dcl  aumi_ptr			ptr;
dcl  aumi_message_time		fixed bin(71)
				based(addr(aumi.message_id));
dcl  aumi_message (aumi.message_length) fixed bin(35) based (aumi.message_ptr);
dcl  ax				fixed bin;
dcl  AUMI_ARRAY_INCREMENT		fixed bin int static options(constant)
				init(50);

alloc_aumi:
     procedure;

     if aumi_struct.count = aumi_struct.max_count then do;
        aumi_struct_count = aumi_struct.max_count + AUMI_ARRAY_INCREMENT;
        allocate aumi_struct in (system_area) set (temp_struct_ptr);
        temp_struct_ptr -> aumi_struct.max_count = aumi_struct.max_count;
        temp_struct_ptr -> aumi_struct = aumi_struct;
        temp_struct_ptr -> aumi_struct.max_count =
	 aumi_struct.max_count + AUMI_ARRAY_INCREMENT;
        if aumi_struct_ptr ^= addr (auto_aumi_struct) then
	 free aumi_struct in (system_area);
        aumi_struct_ptr = temp_struct_ptr;
        temp_struct_ptr = null;
        end;

     ax = aumi_struct.count + 1;
     aumi_ptr = addr(aumi_struct.array(ax));
     aumi.version = AS_USER_MESSAGE_INFO_VERSION_1;
     aumi.flags = FALSE;
     aumi.flags.no_handle_given = TRUE;
     aumi.flags.dont_delete = TRUE;
     aumi.message_info.message_ptr = null;
     aumi.message_info.message_length = 0;
     aumi_struct.count = ax;
     return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

alloc_aumi$init:
     entry;

     auto_aumi_struct.count = 0;
     auto_aumi_struct.max_count = dimension(auto_aumi_struct.array,1);
     aumi_struct_ptr = addr (auto_aumi_struct);
     temp_struct_ptr = null;
     return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


alloc_aumi$term:
     entry;

     if temp_struct_ptr = aumi_struct_ptr then
        temp_struct_ptr = null;
     if temp_struct_ptr ^= null then
        free temp_struct_ptr -> aumi_struct in (system_area);
     do ax = 1 to aumi_struct.count;
        if aumi_struct.message_ptr(ax) ^= null then do;
	 aumi_ptr = addr(aumi_struct.array(ax));
	 free aumi_message in (system_area);
	 aumi.message_ptr = null;
	 end;
        end;
     if aumi_struct_ptr ^= addr (auto_aumi_struct) then
        free aumi_struct in (system_area);
     return;

     end alloc_aumi;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARGUMENT PROCESSING:					       */
/* Declare variables and subroutines needed for argument processing.	       */
/*							       */
/* CHECK INVOCATION TYPE:					       */
/* 1) Initialize error handling subroutines.			       */
/* 2) Determine whether invoked as command or af.			       */
/* 3) Is this type of invocation allowed?			       */
/* 4) Initialize af return argument, and index of current argument.	       */
/*							       */
/* SEE OTHER ARGUMENT PROCESSING PROGRAMS:			       */
/*   get_arg, get_ctl_arg, get_bit36_opt, get_bit72_opt		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  af_sw			bit(1) aligned,	/* on: active fnc*/
     arg				char(argl) based(argp),
     argl				fixed bin(21),	/* current arg   */
     argp				ptr,
     argn				fixed bin,	/* arg count     */
     argx				fixed bin,	/* arg index     */
     bit_opt			bit(72) var aligned,/* 1-2 word octal*/
     opt				char(optl) based(optp),
     optl				fixed bin(21),	/* current option*/
     optp				ptr,
     ret				char(retl) varying based(retp),
     retl				fixed bin(21),	/* af return val */
     retp				ptr,
     sci_ptr			ptr;		/* ssu_ info ptr */

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

dcl (ALLOW_COMMAND			init(1),
     ALLOW_AF			init(2),
     ALLOW_COMMAND_AF		init(3)) fixed bin int static options(constant);

check_invocation_type:
     proc (allowed);

dcl  allowed			fixed bin;
dcl (error_table_$active_function,
     error_table_$not_act_fnc)	fixed bin(35) ext static;

     call error$init();
     call ssu_$return_arg (sci_ptr, argn, af_sw, retp, retl);
     if allowed = ALLOW_COMMAND & af_sw then
        call error$fatal (sci_ptr, error_table_$active_function);
     else if allowed = ALLOW_AF & ^af_sw then
        call error$fatal (sci_ptr, error_table_$not_act_fnc);
     else if allowed = ALLOW_COMMAND_AF then;
     if af_sw then
        ret = "";
     argx = 0;
     end check_invocation_type;



/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CLEANUP:						       */
/* 1) Destroy the ssu_ invocation (releasing temp segs obtained thru ssu_).  */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

cleanup_invocation:
     proc;

     call alloc_aumi$term();

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

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


cv_access_class:
     procedure (class) returns (char(256) varying);

dcl  class			bit(72) aligned parameter;

dcl  class_str			char(256) automatic,
     code				fixed bin(35);

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

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

     call convert_access_class_$to_string_short (class, class_str, code);
     if code ^= 0 then do;
        if code = error_table_$smallarg then;
        else class_str = "Unknown";
        end;
     return (rtrim(class_str));

     end cv_access_class;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


cv_message_type:
     procedure (source, target, handle, message) returns (char(256) varying);

dcl (source, target)		char(32) parameter;
dcl  handle			bit(72) aligned parameter;
dcl  message			(*) fixed bin(35) parameter;

dcl  type				char(256) varying;

     if handle = SYSTEM_MESSAGE_HANDLE then do;
        type = "system message: ";
        if addr(message) ^= null then do;
	 system_message_ptr = addr(message);
	 if system_message.header.version = SYSTEM_MESSAGE_VERSION_1 then do;
	    if lbound(SYSTEM_MESSAGE_TYPES,1) <= system_message.header.type &
	       system_message.header.type <= hbound(SYSTEM_MESSAGE_TYPES,1)
	    then do;
	       type = type ||
		SYSTEM_MESSAGE_TYPES(system_message.header.type);
	       if ^brief_sw then do;
		type = type || ": ";
		type = type || rtrim(warn_system_message.caller);
		type = type || CONTINUATION_LINE;
		type = type || warn_system_message.text;
		end;
	       end;
	    else do;
	       type = type || "UNKNOWN TYPE (";
	       type = type || ltrim(char(system_message.header.type));
	       type = type || ")";
	       end;
	    end;
	 else do;
	    type = type || "UNKNOWN VERSION (";
	    type = type || rtrim(system_message.header.version);
	    type = type || ")";
	    end;
	 end;
        else
	 type = type || "NULL MESSAGE POINTER";
        end;

     else if handle = USER_MESSAGE_LS_CONNECTION_INFO_HANDLE then do;
        type = "ls ";
LS_DIAL:
        if addr(message) ^= null then do;
	 ls_connection_message_ptr = addr(message);
	 if ls_connection_message.version = LS_CONNECTION_MESSAGE_V1 then do;
	    if ls_connection_message.reason = LS_MSG_CONNECTED then
	       type = type || "connected: ";
	    else if ls_connection_message.reason = LS_MSG_DISCONNECTED then
	       type = type || "disconnected: ";
	    else do;
	       type = type || "unknown operation";
	       type = type ||
		cv_octal(unspec(ls_connection_message.reason));
	       type = type || " ";
	       end;
	    type = type || rtrim (ls_connection_message.io_module_name);
	    type = type || " ";
	    type = type || rtrim (ls_connection_message.connection_name);
	    end;
	 else do;
	    type = type || "connection: ";
	    type = type || "UNKNOWN VERSION (";
	    type = type || rtrim (ls_connection_message.version);
	    type = type || ")";
	    end;
	 end;
        else do;
	 type = type || "connection: ";
	 type = type || "NULL MESSAGE POINTER";
	 end;
        end;

     else if substr(handle, length(handle) -
        length (USER_MESSAGE_LS_CONNECTION_INFO_HANDLE_LOWER_18) + 1,
        length (USER_MESSAGE_LS_CONNECTION_INFO_HANDLE_LOWER_18)) =
        USER_MESSAGE_LS_CONNECTION_INFO_HANDLE_LOWER_18 then do;
        type = "ls dial ";
        go to LS_DIAL;
        end;

     else do;
        if addr(message) = null then
	 type = "UNKNOWN MESSAGE: NULL POINTER";
        else do;
	 as_com_channel_info_ptr, ls_response_ptr = addr(message);
	 if lbound (LS_RESPONSE_TYPES, 1) <=
	    login_server_response_header.message_type &
	    login_server_response_header.message_type <=
	    hbound (LS_RESPONSE_TYPES, 1) then do;
	    type = "ls ";
	    type = type ||
	       LS_RESPONSE_TYPES (login_server_response_header.message_type);
	    type = type || "response";

	    if login_server_response_header.message_type =
	       LS_UNKNOWN_RESPONSE then;

	    else if login_server_response_header.message_type =
	       LS_VALIDATE_RESPONSE then do;
	       if login_server_response_header.version ^=
		LS_VALIDATE_RESPONSE_VERSION_1 then do;
		type = type || ": UNKNOWN VERSION (";
		type = type ||
		   rtrim (login_server_response_header.version);
		type = type || ")";
		end;
	       else do;
		type = type || ": ";
		type = type ||
		   rtrim (login_server_validate_response.person_id);
		type = type || ".";
		type = type || 
		   rtrim (login_server_validate_response.project_id);
		if ^brief_sw then
		   type = type || cv_status_code (
		   login_server_validate_response.status_code);
		end;
	       end;

	    else if login_server_response_header.message_type =
	       LS_PROCESS_RESPONSE then do;
	       if login_server_response_header.version ^=
		LOGIN_SERVER_PROCESS_RESPONSE_VERSION_1 then do;
		type = type || ": UNKNOWN VERSION (";
		type = type ||
		   rtrim (login_server_response_header.version);
		type = type || ")";
		end;
	       else do;
		type = type || ": ";
		type = type ||
		   rtrim (login_server_process_response.process_group_id);
		if ^brief_sw then do;
		   type = type || CONTINUATION_LINE;
		   if login_server_process_response.flags.
		      message_coordinator then
		      type = type || "MESSAGE COORD";
		   else if login_server_process_response.flags.created then
		      type = type || "CREATE";
		   else
		   if login_server_process_response.flags.connected then
		      type = type || "CONNECT";
		   else
		   if login_server_process_response.flags.new_proc then
		      type = type || "NEW_PROC";
		   else
		   if login_server_process_response.flags.destroyed then
		      type = type || "DESTROY";
		   if login_server_process_response.process_id ^= ""b
		   then 
		      type = type || cv_octal (
		         login_server_process_response.process_id);
		   type = type || cv_status_code (
		      login_server_process_response.status_code);
		   if login_server_process_response.
		      accounting_message_length > 0 then do;
		      type = type || ": ";
		      type = type ||
		         login_server_process_response.accounting_message;
		      end;
		   end;
		end;
	       end;

	    else if login_server_response_header.message_type =
	       LS_LIST_RESPONSE then do;
	       if login_server_response_header.version ^=
		LOGIN_SERVER_LIST_RESPONSE_VERSION_1 then do;
		type = type || ": UNKNOWN VERSION (";
		type = type ||
		   rtrim (login_server_response_header.version);
		type = type || ")";
		end;
	       end;

	    else if login_server_response_header.message_type =
	       LS_DIAL_RESPONSE then do;
	       if login_server_response_header.version ^=
		LOGIN_SERVER_DIAL_RESPONSE_VERSION_1 then do;
		type = type || ": UNKNOWN VERSION (";
		type = type ||
		   rtrim (login_server_response_header.version);
		type = type || ")";
		end;
	       else do;
		type = type || ": ";
		type = type ||
		   rtrim (login_server_dial_response.process_group_id);
		if ^brief_sw then 
		   type = type || cv_octal (
		      login_server_dial_response.process_id);
		end;
	       end;

	    else if login_server_response_header.message_type =
	       LS_TERMINATION_RESPONSE then do;
	       if login_server_response_header.version ^=
		LOGIN_SERVER_TERMINATION_RESPONSE_VERSION_1 then do;
		type = type || ": UNKNOWN VERSION (";
		type = type ||
		   rtrim (login_server_response_header.version);
		type = type || ")";
		end;
	       else do;
		type = type || ": ";
		type = type || rtrim (
		   login_server_termination_response.process_group_id);
		if ^brief_sw then do;
		   type = type ||
		      cv_octal (
		      login_server_termination_response.process_id);
		   type = type || CONTINUATION_LINE;
		   if login_server_termination_response.flags.new_proc then
		      type = type || "new_proc";
		   else if login_server_termination_response.
		      flags.fatal_error then
		      type = type || "fatal error";
		   else
		      type = type || "logout";
		   type = type || cv_status_code (
		      login_server_termination_response.status_code);
		   end;
		end;
	       end;	    

	    else if login_server_response_header.message_type =
	       LS_NEW_PROC_RESPONSE then do;
	       if login_server_response_header.version ^=
		LOGIN_SERVER_NEW_PROC_RESPONSE_VERSION_1 then do;
		type = type || ": UNKNOWN VERSION (";
		type = type ||
		   rtrim (login_server_response_header.version);
		type = type || ")";
		end;
	       else
		type = type || cv_octal (
		login_server_new_proc_response.new_process_id);
	       end;     

	    else if login_server_response_header.message_type =
	       LS_OPERATOR_RESPONSE then do;
	       if login_server_response_header.version ^=
		LOGIN_SERVER_OPERATOR_RESPONSE_VERSION_1 then do;
		type = type || ": UNKNOWN VERSION (";
		type = type ||
		   rtrim (login_server_response_header.version);
		type = type || ")";
		end;
	       else do;
		type = type || ": ";
		type = type ||
		   rtrim (login_server_operator_response.process_group_id);
		if ^brief_sw then do;
		   if login_server_operator_response.process_id ^= ""b then
		      type = type || cv_octal (
		      login_server_operator_response.process_id);
		   type = type || cv_status_code (
		      login_server_operator_response.status_code);
		   end;
		end;
	       end;
	    end;

	 else if dimension(message,1) = size(as_com_channel_info) &
	    as_com_channel_info.version =
	    AS_COM_CHANNEL_INFO_VERSION_1 then do;
	    type = "com channel info";
	    if ^brief_sw then do;
	       type = type || " for ";
	       type = type || rtrim(as_com_channel_info.channel_name);
	       end;
	    end;

	 else
	    type = "UNKNOWN MESSAGE TYPE";
	 end;
        end;
     return (type);

     end cv_message_type;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* cv_octal: return octal representation of a word.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


cv_octal:
     procedure (word) returns (char(13));

dcl  word				bit(36) aligned parameter;

dcl  octal_id			char(13);

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

     call ioa_$rsnnl (" ^12.3b", octal_id, 0, word);
     return (octal_id);

     end cv_octal;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


cv_status_code:
     procedure (code) returns (char(100) varying);

dcl  code				fixed bin(35) parameter;

dcl  long				char(100) aligned,
     short			char(8) aligned;
     
dcl  convert_status_code_		entry (fixed bin(35), char(8) aligned,
				     char(100) aligned);

     if code = 0 then
        return ("");
     call convert_status_code_ (code, short, long);
     if short ^= "" then
        return (" (" || rtrim(short) || ")");
     else
        return (" (" || rtrim(long) || ")");
     end cv_status_code;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


cv_target:
     procedure (target) returns (char(32) varying);

dcl  1 target			aligned parameter
				like as_user_message_info.destination_info;

dcl  code				fixed bin(35),
     group			char(32) varying,
     pers				char(24),
     proj				char(12),
     tag				char(1);

dcl  get_userid_$info		entry (bit(36) aligned, char(*),
				     char(*), char(*), fixed bin,
				     fixed bin, fixed bin, 
				     fixed bin(35));

     if target.process_id = ""b then
        return (rtrim (target.group_id));
     else if target.group_id ^= "" & target.group_id ^= "*.*.*" then
        return (rtrim (target.group_id));
     else do;
        call get_userid_$info (target.process_id, pers, proj, tag, 0,
	   0, 0, code);
        if code = 0 then do;
	 group = rtrim(pers);
	 group = group || ".";
	 group = group || rtrim(proj);
	 group = group || ".";
	 group = group || tag;
	 return (group);
	 end;
        else do;
	 return (cv_octal (target.process_id));
	 end;
        end;

     end cv_target;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* display_message:  Display one matching user message.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  1 begin			aligned automatic,
       2 (target, type)		fixed bin;
dcl  matching_entries		fixed bin;
dcl  need_heading			bit(1) aligned automatic;
dcl  1 width			aligned automatic,
       2 (source, target, type)	fixed bin;

display_message:
     procedure;

     matching_entries = matching_entries + 1;

     if brief_sw then do;
        if need_heading then do;
	 call ioa_ (
	    "^/SOURCE^vtTARGET^vtMESSAGE",
	    begin.target, begin.type);
	 need_heading = "0"b;
	 end;
        call ioa_ ("^a^vt^a^vt^a",  before(aumi.sender_info.group_id, "."),
	 begin.target, before (cv_target (aumi.destination_info), "."),
	 begin.type, cv_message_type (aumi.sender_info.group_id,
	 aumi.destination_info.group_id, aumi.message_handle, aumi_message));
        end;

     else do;
        call ioa_ ("");
        call ioa_ ("Source name:    ^32a pid:  ^12.3b",
	 aumi.sender_info.group_id, aumi.sender_info.process_id);
        call ioa_ ("Target name:    ^32a pid:  ^12.3b    ring:  ^d",
	 cv_target(aumi.destination_info), aumi.destination_info.process_id,
	 aumi.destination_info.ring);
        call ioa_ ("Message handle: ^24.3b^8x  id:  ^24.3b",
	 aumi.message_handle, aumi.message_id);
        call ioa_ ("Message time:   ^a",
	 date_time_$format ("clock", aumi_message_time, "", ""));
        if aumi.message_access_class ^= ""b then
	 call ioa_ ("Message class:  ^a",
	 cv_access_class (aumi.message_access_class));
        if aumi.message_ring ^= 4 then
	 call ioa_ ("Message ring:   ^d", aumi.message_ring);
        call ioa_ ("Message length: ^d words", aumi.message_length);
        call ioa_ ("Message type:   ^a",
	 cv_message_type (aumi.sender_info.group_id,
	 aumi.destination_info.group_id, aumi.message_handle, aumi_message));

        if octal_sw & aumi.message_length > 0 then do;
	 call ioa_ ("");
	 string(dump_segment_format_structure) = ""b;
	 dump_segment_format_structure.offset = TRUE;
	 dump_segment_format_structure.ascii = TRUE;
	 dump_segment_format_structure.raw_data = TRUE;
	 dump_segment_format_structure.interpreted_data = TRUE;
	 dump_segment_format_structure.suppress_duplicates = TRUE;
	 call dump_segment_ (iox_$user_output, addr(aumi_message),
	    DO_NOT_BLOCK, ZERO_OFFSET, dimension(aumi_message,1),
	    dump_segment_format);
	 end;
        end;
     return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


display_message$init:
     entry;

     matching_entries = 0;
     need_heading = TRUE;
     width.source = length("SOURCE");
     width.target = length("TARGET");
     width.type = length("TYPE");
     begin = 0;
     return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


display_message$matching_entry_count:
     entry returns (fixed bin);
     return (matching_entries);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


display_message$set_widths:
     entry;

dcl (COLUMN_1			init(1),
     COLUMN_GUTTER			init(2)) fixed bin int static
				options(constant);

     width.source = max (width.source,
        length (before (rtrim (aumi.sender_info.group_id), ".")));
     width.target = max (width.target,
        length (before (cv_target (aumi.destination_info), ".")));
     width.type = max (width.type,
        length (cv_message_type (aumi.sender_info.group_id,
        aumi.destination_info.group_id, aumi.message_handle, aumi_message)));
     begin.target = COLUMN_1 + width.source + COLUMN_GUTTER;
     begin.type = begin.target + width.target + COLUMN_GUTTER;
     end display_message;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ERROR REPORTING ROUTINES:					       */
/* 1) Nonfatal errors set a switch, which can be tested via error_occurred   */
/*    function.						       */
/* 2) Fatal errors abort the subsystem by calling the exit_proc, which       */
/*    branches to the EXIT label to exit the command.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  error_occurred_sw		bit(1);

error:
     proc options (variable);

dcl  code				fixed bin(35) based (codep),
     codep			ptr;

dcl  cu_$arg_list_ptr		entry returns(ptr),
     cu_$arg_ptr			entry (fixed bin, ptr, fixed bin(21),
				     fixed bin(35)),
     cu_$generate_call		entry (entry, ptr);

dcl  CODE_ARG			fixed bin int static options(constant) init(2),
    (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant);

     call cu_$arg_ptr (CODE_ARG, codep, 0, 0);
     if code = 0 then return;
     if code = -1 then code = 0;
     error_occurred_sw = TRUE;
     call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr());
     return;


error$init:
     entry;
     error_occurred_sw = FALSE;
     return;


error$occurred:
     entry returns (bit(1));
     return (error_occurred_sw);
	

error$fatal:
     entry options(variable);
	
     call cu_$arg_ptr (CODE_ARG, codep, 0, 0);
     if code = 0 then return;
     if code = -1 then code = 0;
     error_occurred_sw = TRUE;
     call ioa_ ("");
     call cu_$generate_call (ssu_$abort_subsystem, cu_$arg_list_ptr());
     end error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* ARGUMENT GETTING FUNCTIONS:				       */
/*  get_arg: 	Get next argument.				       */
/*  get_arg_count:	Get number of arguments.			       */
/*  get_ctl_arg:	Get next argument, which must be a control argument.     */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

get_arg:
     proc returns (bit(1));

dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant);

     if argx < argn then do;
        argx = argx + 1;
        call ssu_$arg_ptr (sci_ptr, argx, argp, argl);
        return (TRUE);
        end;
     else
        return (FALSE);
     end get_arg;


get_ctl_arg:
     proc returns (bit(1));

dcl  index			builtin;

dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant),
     error_table_$bad_arg		fixed bin(35) ext static;

     if get_arg() then
        if index(arg, "-") = 1 then
        return (TRUE);
     else
        call error$fatal (sci_ptr, error_table_$bad_arg,
        "^a.^/A control argument was expected.", arg);
     return (FALSE);
     end get_ctl_arg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* CONTROL ARG OPERAND GETTING FUNCTIONS:			       */
/*  get_bit36_opt:  Gets next arg, treats it as an octal integer operand.    */
/*  get_bit72_opt:  Gets next arg, treats it as 2-word octal integer operand.*/
/*  get_opt:        Gets next arg.				       */
/*							       */
/* Both allow the caller to specify whether the operand is required (an      */
/* opt_desc is provided) or optional (opt_desc="").		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

get_bit36_opt:
     proc (arg_name, opt_desc) returns (bit(1));

dcl  arg_name			char(*),
     opt_desc			char(*);

dcl  code				fixed bin(35);
dcl  max_bits			fixed bin;
dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1)
				     int static options(constant),
    (error_table_$bad_arg,
     error_table_$noarg)		fixed bin(35) ext static;

     max_bits = 36;
     go to GET_BIT_COMMON;

get_bit72_opt:
     entry (arg_name, opt_desc) returns (bit(1));
     max_bits = 72;

GET_BIT_COMMON:
     if argx < argn then do;
        argx = argx + 1;
        call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
        bit_opt = oct_to_bit (opt, max_bits, code);
        if code ^= 0 then do;
	 call error (sci_ptr, error_table_$bad_arg,
	    "^a ^a
^a must be followed by a^[n^] ^a.",
	    arg_name, opt, arg_name,
	    vowel(opt_desc), opt_desc);
	 return (FALSE);
	 end;
        else return (TRUE);
        end;
     else if opt_desc ^= "" then do;
        call error (sci_ptr, error_table_$noarg,
	 "^/^a must be followed by a^[n^] ^a.", arg_name,
	 vowel(opt_desc), opt_desc);
        return (FALSE);
        end;
     else return (FALSE);
     end get_bit36_opt;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


get_opt:
     proc (arg_name, opt_desc) returns (bit(1));

dcl  arg_name			char(*),
     opt_desc			char(*);

dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant),
     error_table_$noarg		fixed bin(35) ext static;

     if argx < argn then do;
        argx = argx + 1;
        call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
        if index(opt, "-") = 1 then do;			/* options cannot*/
	 argx = argx - 1;				/*  look like    */
	 go to NO_OPT;				/*  control args */
	 end;
        else
	 return (TRUE);
        end;

     else
NO_OPT:
     if opt_desc ^= "" then do;
        call error (sci_ptr, error_table_$noarg,
	 "^/^a must be followed by a^[n^] ^a.", arg_name,
	 vowel(opt_desc), opt_desc);
        return (FALSE);
        end;
     return (FALSE);
     end get_opt;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


vowel:
     proc (str) returns (bit(1));			/* does opt_desc */
						/* begin with a  */
						/* vowel?	       */

dcl  str				char(*);

dcl (search, substr)		builtin;

dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant);

     if search ("aeiouAEIO", substr(str,1,1)) > 0 then
        return (TRUE);
     else
        return (FALSE);
     end vowel;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */


group_id:
     procedure (arg) returns (1 like source);

dcl  arg				char(*);
dcl  1 group			aligned automatic like source;

     group.id = arg;
     group.person = before(arg,".");
     if group.person = "" then group.person = "*";
     group.project = before(after(arg,"."),".");
     if group.project = "" then group.project = "*";
     group.tag = after(after(arg,"."),".");
     if group.tag = "" then group.tag = "*";
     return (group);

     end group_id;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* INITIALIZATION.						       */
/* 1) Initialize variables holding argument values.		       */
/* 2) Initialize ssu_ info pointer.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

initialize_args:
     proc;

     sci_ptr = null;

     brief_sw = TRUE;
     octal_sw = FALSE;

     exclude, match, source, target = "";
     source_id, target_id, message_id, message_handle = ""b;

     call alloc_aumi$init();

     aumari.version = AS_USER_MESSAGE_ADMIN_READ_INFO_VERSION_1;
     aumari.source_group_id = "";
     aumari.source_process_id = ""b;
     aumari.target_group_id = "";
     aumari.target_process_id = ""b;
     aumari.target_handle = ""b;
     aumari.after_message_id = ""b;

     call display_message$init();

     system_area_ptr = get_system_free_area_ ();

     end initialize_args;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* matching_entry: return TRUE if active_connection_list entry match the     */
/* criteria given in input control args.  Otherwise, return FALSE.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

matching_entry:
     procedure returns (bit(1));

dcl  ok_so_far			bit(1);

     ok_so_far = TRUE;
     if message_id ^= ""b & ok_so_far then
        ok_so_far = (aumi.message_id = message_id);

     if message_handle ^= ""b & ok_so_far then
        ok_so_far = (aumi.message_handle = message_handle);

     if source_id ^= ""b & ok_so_far then
        ok_so_far = (aumi.sender_info.process_id = source_id);

     if target_id ^= ""b & ok_so_far then
        ok_so_far = (aumi.destination_info.process_id = target_id);

     if source.id ^= "" & ok_so_far then do;
        if source.person ^= "*" then
	 ok_so_far = (source.person = before(aumi.sender_info.group_id,"."));
        if source.project ^= "*" & ok_so_far then
	 ok_so_far = 
	 (source.project = before(after(aumi.sender_info.group_id,"."),"."));
        if source.tag ^= "*" & ok_so_far then
	 ok_so_far =
	 (source.tag = after(after(aumi.sender_info.group_id,"."),"."));
        end;

     if target.id ^= "" & ok_so_far then do;
        if aumi.destination_info.group_id = "" |
	 aumi.destination_info.group_id = "*.*.*" then 
	 aumi.destination_info.group_id = cv_target (aumi.destination_info);
        if target.person ^= "*" then
	 ok_so_far =
	 (target.person = before(aumi.destination_info.group_id,"."));
        if target.project ^= "*" & ok_so_far then
	 ok_so_far = (target.project =
	 before(after(aumi.destination_info.group_id,"."),"."));
        if target.tag ^= "*" & ok_so_far then
	 ok_so_far =
	 (target.tag = after(after(aumi.destination_info.group_id,"."),"."));
        end;

     if match ^= "" & ok_so_far then do;
        ok_so_far = index (cv_message_type (aumi.sender_info.group_id,
	 aumi.destination_info.group_id, aumi.message_handle, aumi_message),
	 match) > 0;
        end;
     
     if exclude ^= "" & ok_so_far then do;
        ok_so_far = index (cv_message_type (aumi.sender_info.group_id,
	 aumi.destination_info.group_id, aumi.message_handle, aumi_message),
	 exclude) = 0;
        end;

     return (ok_so_far);

     end matching_entry;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* oct_to_bit: converts octal integer to bit(36) or bit(72) string.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

oct_to_bit:
     procedure (integer, max_bits, code) returns (bit(72) varying aligned);

dcl  integer			char(*) parameter;
dcl  max_bits			fixed bin;
dcl  code				fixed bin(35) parameter;
     
dcl  bits				bit(73) varying;
dcl  digit			fixed bin;
dcl  oct_bits (48:55 /* = 060:067 octal = "0":"7" */)
				bit(3) int static options(constant)
      init("0"b3, "1"b3, "2"b3, "3"b3, "4"b3, "5"b3, "6"b3, "7"b3);

dcl (length, rank, substr, verify)	builtin;

dcl  ZERO_BITS			bit(72) aligned int static
				options(constant) init("0"b);

dcl (error_table_$bad_conversion,
     error_table_$size_error)		fixed bin(35) ext static;

     code = 0;

     if verify (integer, "01234567") > 0 then do;		/* check for     */
        code = error_table_$bad_conversion;		/* nonoctal      */
        return (""b);				/* digits	       */
        end;

     bits = ""b;					/* convert octal */
     do digit = 1 to length(integer);			/* digits to bits*/
        bits = bits || oct_bits(rank(substr(integer,digit,1)));
        end;

     if length(bits) > max_bits then do;		/* check for too */
        code = error_table_$size_error;			/* many digits   */
        return (""b);
        end;

     bits = substr(ZERO_BITS, 1, max_bits - length(bits)) || bits;
						/* right adjust  */
     return (bits);

     end oct_to_bit;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* PROCESS ARGUMENTS					       */
/* 1) Match argument to ctl_arg name and operands.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

process_args:
     proc;

CTL_ARG_LOOP:
     do while (get_ctl_arg ());

        if arg = "-brief" | arg = "-bf" then 
	 brief_sw = TRUE;
        else if arg = "-long" | arg = "-lg" then
	 brief_sw = FALSE;
        else if arg = "-octal" | arg = "-oc" then 
	 octal_sw = TRUE;
        else if arg = "-no_octal" | arg = "-noc" then
	 octal_sw = FALSE;

        else if arg = "-source" | arg = "-sc" then do;
	 if get_opt (arg, "source group id") then
	    source = group_id (opt);
	 end;
        else if arg = "-target" | arg = "-tgt" then do;
	 if get_opt (arg, "target group id") then
	    target = group_id (opt);
	 end;

        else if arg = "-source_id" | arg = "-scid" | arg = "-sid" then do;
	 if get_bit36_opt (arg, "octal source process id") then
	    source_id = bit_opt;
	 end;
        else if arg = "-target_id" | arg = "-tgtid" | arg = "-tid" |
	      arg = "-process_id" | arg = "-processid" |
	      arg = "-pid" then do;
	 if get_bit36_opt (arg, "octal target process id") then
	    target_id = bit_opt;
	 end;

        else if arg = "-message_id" | arg = "-mid" then do;
	 if get_bit72_opt (arg, "octal message identifier") then
	    message_id = bit_opt;
	 end;

        else if arg = "-handle" | arg = "-hdl" then do;
	 if get_bit72_opt (arg, "octal message handle") then
	    message_handle = bit_opt;
	 end;

        else if arg = "-match_data" | arg = "-match" then do;
	 if get_opt (arg, "match string") then
	    match = opt;
	 end;
        else if arg = "-exclude_data" | arg = "-exclude" | arg = "-ex" then do;
	 if get_opt ( arg, "exclude string") then
	    exclude = opt;
	 end;

        else if index (arg, "-") ^= 1 then
	 call error (sci_ptr, error_table_$bad_arg, "^a
Usage: ^a {-control_args}", arg, ME);

        else
	 call error (sci_ptr, error_table_$bad_opt, "^a", arg);
        end CTL_ARG_LOOP;

     if octal_sw then				/* -octal implies*/
        brief_sw = FALSE;				/* -brief.       */

     if error$occurred() then				/* stop now if   */
        call error$fatal (sci_ptr, -1);			/* ctl arg errs  */

     end process_args;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* scan_messages:  Walk through user message entries, displaying	       */
/* those that match the user's criteria.			       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

scan_messages:
     procedure;

     on linkage_error begin;
        call error$fatal (sci_ptr, -1,
	 "Incorrect access to the user_message_admin_ gate.");
        end;
     entry_var = user_message_admin_$read_message;	/* force linkage */
     revert linkage_error;				/* error now.    */

     aumari.after_message_id = "0"b;			/* get 1st entry */
     code = 0;
     do while (code = 0);
        call alloc_aumi();
        call user_message_admin_$read_message (addr(aumari), addr(aumi),
	 addr(system_area), code);
        if code ^= 0 then
	 aumi_struct.count = aumi_struct.count - 1;
        else aumari.after_message_id = aumi.message_id;	/* get next entry*/
        end;

     if brief_sw then
     do ax = 1 to aumi_struct.count;
        aumi_ptr = addr (aumi_struct.array(ax));
        if matching_entry() then 
	 call display_message$set_widths();
        end;
     
     do ax = 1 to aumi_struct.count;
        aumi_ptr = addr (aumi_struct.array(ax));
        if matching_entry() then
	 call display_message();
        end;

     if code ^= error_table_$no_message then
        call error$fatal (sci_ptr, code, "Getting user messages.");

     if display_message$matching_entry_count() = 0 then
        call error$fatal (sci_ptr, -1,
        "No matching user messages were found.");

     end scan_messages;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
 %include as_com_channel_info;
 %include as_user_message_aread;

dcl  1 aumari			aligned automatic like as_user_message_admin_read_info;
 %include as_user_message_info;
 %include dialup_values;
 %include dump_segment_format;
 %include login_server_messages;
 %include ls_connection_message;
 %include system_message;
 %include user_message_handles;
 %include user_attributes;
 %include user_table_entry;

     end display_user_messages;




		    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
