



		    add_key.pl1                     11/11/89  1111.8r w 11/11/89  0805.5       27792



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
add_key:
     proc (p_journal_control_block_ptr, p_info_ptr, p_code);

/* After doing the specified add_key operation on the vfile, an entry is made
   in the journal recording the key and descriptor.  Only the input_desc and input_key case is allowed.

   Written  by  Lindsey Spratt 08/06/79
   Modified by Chris Jones 02/15/85 for privileges and clean up.
*/
/* Parameter */


dcl	p_journal_control_block_ptr
			   ptr;
dcl	p_info_ptr	   ptr;
dcl	p_code		   fixed bin (35);

/* Automatic */

dcl	privileges_string	   bit (36) aligned;

/* Based */
/* Controlled */
/* Builtin */

dcl	null		   builtin;

dcl	cleanup		   condition;

/* Entry */

dcl	iox_$control	   entry (ptr, char (*), ptr, fixed bin (35));
dcl	rcprm_registry_util_$turn_off_privs
			   entry (bit (36) aligned);
dcl	rcprm_registry_util_$turn_on_privs
			   entry (bit (36) aligned);

/* External */

dcl	error_table_$locked_by_this_process
			   fixed bin (35) ext;
dcl	error_table_$bad_arg   fixed bin (35) ext;

	ak_info_ptr = p_info_ptr;
	journal_control_block_ptr = p_journal_control_block_ptr;
	if ^ak_info.input_desc & ^ak_info.input_key then do;
	     p_code = error_table_$bad_arg;
	     return;
	end;
	privileges_string = ""b;
	on cleanup call rcprm_registry_util_$turn_off_privs (privileges_string);

	call rcprm_registry_util_$turn_on_privs (privileges_string);
	call iox_$control (journal_control_block.vfile_iocb_ptr, "add_key", ak_info_ptr, p_code);
	if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
	     call rcprm_registry_util_$turn_off_privs (privileges_string);
	     return;
	end;

	a_key_len = ak_info.key_len;
	a_rec_len = 0;
	alloc journal_entry in (journal_area);
	journal_entry.key_str = ak_info.key;
	journal_entry.descriptor = ak_info.descrip;
	journal_entry.inc_ref_count = "0"b;
	journal_entry.dec_ref_count = "0"b;
	journal_entry.type = ADD_KEY;
	journal_entry.next_ptr = null;
	if journal_control_block.latest_entry_ptr ^= null then
	     journal_control_block.latest_entry_ptr -> journal_entry.next_ptr = journal_entry_ptr;
	journal_entry.prev_ptr = journal_control_block.latest_entry_ptr;
	journal_control_block.latest_entry_ptr = journal_entry_ptr;
	call rcprm_registry_util_$turn_off_privs (privileges_string);
	return;

%include journal_entry;
%include journal_control_block;
%include ak_info;

     end add_key;




		    commit.pl1                      11/11/89  1111.8r w 11/11/89  0807.2       38781



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
commit:
     proc (p_journal_control_block_ptr, p_code);

/* Complete whatever changes are in progress.

   Written  by  Lindsey Spratt 08/06/79
   Modified 11/21/79 by C. D. Tavares to commit in forward order instead of reverse.
   Modified 02/15/85 by Chris Jones for privileges and clean up.
*/
/* Parameter */

dcl	p_journal_control_block_ptr
			   ptr;
dcl	p_code		   fixed bin (35);

/* Automatic */

dcl	privileges_string	   bit (36) aligned;
dcl	scratch_area_ptr	   ptr;

/* Based */

dcl	scratch_area	   area (4096) based (scratch_area_ptr);

/* Controlled */
/* Builtin */

dcl	null		   builtin;

dcl	cleanup		   condition;

/* Entry */

dcl	iox_$control	   entry (ptr, char (*), ptr, fixed bin (35));
dcl	iox_$delete_record	   entry (ptr, fixed bin (35));
dcl	get_system_free_area_  entry returns (ptr);
dcl	rcprm_registry_util_$turn_off_privs
			   entry (bit (36) aligned);
dcl	rcprm_registry_util_$turn_on_privs
			   entry (bit (36) aligned);

/* External */

dcl	error_table_$locked_by_this_process
			   fixed bin (35) ext;

	journal_control_block_ptr = p_journal_control_block_ptr;
	scratch_area_ptr = get_system_free_area_ ();

	if journal_control_block.latest_entry_ptr = null then do;
	     p_code = 0;
	     return;
	end;

	do journal_entry_ptr = journal_control_block.latest_entry_ptr repeat (journal_entry.prev_ptr)
	     while (journal_entry.prev_ptr ^= null);
	end;					/* Find the first journal entry */

	rs_info_ptr = null ();
	privileges_string = ""b;
	on cleanup call clean_up;

	call rcprm_registry_util_$turn_on_privs (privileges_string);

	do while (journal_entry_ptr ^= null);

	     goto ENTRY_TYPE (journal_entry.type);

ENTRY_TYPE (1):					/* RS_LOCK */
ENTRY_TYPE (7):					/* RS_LOCK_COUNT */
ENTRY_TYPE (8):					/* RS_LOCK_CREATE */
	     alloc rs_info in (scratch_area);
	     rs_info.version = rs_info_version_2;
	     rs_info.unlock_sw = "1"b;
	     rs_info.lock_sw = "0"b;
	     rs_info.locate_sw = "1"b;
	     rs_info.descriptor = journal_entry.descriptor;
	     call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;
	     free rs_info;

	     goto NEXT;

ENTRY_TYPE (2):					/* write_record */
	     goto NEXT;

ENTRY_TYPE (3):					/* delete_record */
	     alloc rs_info in (scratch_area);
	     rs_info.version = rs_info_version_2;
	     rs_info.locate_sw = "1"b;
	     rs_info.descriptor = journal_entry.descriptor;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     free rs_info;

	     call iox_$delete_record (journal_control_block.vfile_iocb_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     goto NEXT;


ENTRY_TYPE (4):					/* add_key */
	     goto NEXT;


ENTRY_TYPE (5):					/* delete_key */
	     goto NEXT;


ENTRY_TYPE (6):					/* RS_COUNT */
	     goto NEXT;

NEXT:
	     journal_entry_ptr = journal_entry.next_ptr;
	     if journal_entry_ptr ^= null then
		journal_entry.prev_ptr = null;
	end;
	call clean_up;
	return;

clean_up:
     proc;

	if rs_info_ptr ^= null () then
	     free rs_info;
	call rcprm_registry_util_$turn_off_privs (privileges_string);

     end clean_up;

%include journal_entry;
%include journal_control_block;
%include rs_info;
     end;						/* end commit */




		    delete_key.pl1                  11/11/89  1111.8r w 11/11/89  0805.2       27378



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
delete_key:
     proc (p_journal_control_block_ptr, p_info_ptr, p_code);

/* After doing the specified delete_key operation on the vfile, an entry is made
   in the journal recording the key and descriptor.  Only the input_desc and input_key case is allowed.

   Written  by  Lindsey Spratt 08/06/79
   Modified by Chris Jones 02/15/85 for privileges and clean up.
*/
/* Parameter */



dcl	p_journal_control_block_ptr
			   ptr;
dcl	p_info_ptr	   ptr;
dcl	p_code		   fixed bin (35);

/* Automatic */

dcl	privileges_string	   bit (36) aligned;

/* Based */
/* Controlled */
/* Builtin */

dcl	null		   builtin;

dcl	cleanup		   condition;

/* Entry */

dcl	iox_$control	   entry (ptr, char (*), ptr, fixed bin (35));
dcl	rcprm_registry_util_$turn_off_privs
			   entry (bit (36) aligned);
dcl	rcprm_registry_util_$turn_on_privs
			   entry (bit (36) aligned);

/* External */

dcl	error_table_$locked_by_this_process
			   fixed bin (35) ext;
dcl	error_table_$bad_arg   fixed bin (35) ext;

	ak_info_ptr = p_info_ptr;
	journal_control_block_ptr = p_journal_control_block_ptr;
	if ^ak_info.input_desc | ^ak_info.input_key then do;
	     p_code = error_table_$bad_arg;
	     return;
	end;
	privileges_string = ""b;
	on cleanup call rcprm_registry_util_$turn_off_privs (privileges_string);

	call rcprm_registry_util_$turn_on_privs (privileges_string);

	call iox_$control (journal_control_block.vfile_iocb_ptr, "delete_key", ak_info_ptr, p_code);
	if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then
	     return;


	a_key_len = ak_info.key_len;
	a_rec_len = 0;
	alloc journal_entry in (journal_area);
	journal_entry.key_str = ak_info.key;
	journal_entry.descriptor = ak_info.descrip;
	journal_entry.inc_ref_count = "0"b;
	journal_entry.dec_ref_count = "0"b;
	journal_entry.type = DELETE_KEY;
	journal_entry.next_ptr = null;
	journal_entry.prev_ptr = journal_control_block.latest_entry_ptr;
	if journal_control_block.latest_entry_ptr ^= null then
	     journal_control_block.latest_entry_ptr -> journal_entry.next_ptr = journal_entry_ptr;
	journal_control_block.latest_entry_ptr = journal_entry_ptr;
	call rcprm_registry_util_$turn_off_privs (privileges_string);
	return;

%include journal_entry;
%include journal_control_block;
%include ak_info;
     end;						/* end delete_key */




		    delete_record.pl1               11/11/89  1111.8r w 11/11/89  0808.5       34290



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
delete_record:
     proc (p_journal_control_block_ptr, p_code);

/* Deletes the current key, after recording it and its descriptor.

   Written  by  Lindsey Spratt 08/06/79
   Modified by Chris Jones 02/15/85 to clean up.
*/

/* Parameter */


dcl	p_journal_control_block_ptr
			   ptr;
dcl	p_code		   fixed bin (35);

/* Automatic */

dcl	privileges_string	   bit (36) aligned;
dcl	scratch_area_ptr	   ptr;

/* Based */

dcl	scratch_area	   area (4096) based (scratch_area_ptr);

/* Builtin */

dcl	null		   builtin;

/* Condition */

dcl	cleanup		   condition;

/* Entry */

dcl	iox_$control	   entry (ptr, char (*), ptr, fixed bin (35));
dcl	get_system_free_area_  entry returns (ptr);
dcl	rcprm_registry_util_$turn_off_privs
			   entry (bit (36) aligned);
dcl	rcprm_registry_util_$turn_on_privs
			   entry (bit (36) aligned);

/* External */

dcl	error_table_$locked_by_this_process
			   fixed bin (35) ext;

	journal_control_block_ptr = p_journal_control_block_ptr;
	gk_info_ptr, rs_info_ptr = null ();
	privileges_string = ""b;
	on cleanup call clean_up;

	scratch_area_ptr = get_system_free_area_ ();
	call rcprm_registry_util_$turn_on_privs (privileges_string);
	gk_key_len = 256;
	alloc gk_info in (scratch_area);

	gk_info.input_desc = "0"b;
	gk_info.input_key = "0"b;
	gk_info.desc_code = 0;
	gk_info.current = "1"b;
	gk_info.version = gk_info_version_0;

	call iox_$control (journal_control_block.vfile_iocb_ptr, "get_key", gk_info_ptr, p_code);
	if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
	     call clean_up;
	     return;
	end;

	alloc rs_info in (scratch_area);
	rs_info.version = rs_info_version_2;
	rs_info.locate_sw = "0"b;
	rs_info.inc_ref_count = "1"b;
	call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
	     call clean_up;
	     return;
	end;
	call iox_$control (journal_control_block.vfile_iocb_ptr, "delete_key", null, p_code);
	if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
	     call clean_up;
	     return;
	end;

	a_key_len = gk_info.key_len;
	a_rec_len = 0;
	alloc journal_entry in (journal_area);
	journal_entry.inc_ref_count = "0"b;
	journal_entry.dec_ref_count = "0"b;
	journal_entry.key_str = gk_info.key;
	journal_entry.type = DELETE_RECORD;
	journal_entry.descriptor = gk_info.descrip;
	journal_entry.next_ptr = null;
	journal_entry.prev_ptr = journal_control_block.latest_entry_ptr;
	if journal_control_block.latest_entry_ptr ^= null then
	     journal_control_block.latest_entry_ptr -> journal_entry.next_ptr = journal_entry_ptr;
	journal_control_block.latest_entry_ptr = journal_entry_ptr;
	call clean_up;
	return;

clean_up:
     proc;

	if gk_info_ptr ^= null () then
	     free gk_info;
	if rs_info_ptr ^= null () then
	     free rs_info;
	call rcprm_registry_util_$turn_off_privs (privileges_string);

     end clean_up;

%include journal_control_block;
%include journal_entry;
%page;
%include ak_info;
%include rs_info;

     end delete_record;




		    print_data.pl1                  11/11/89  1111.8r w 11/11/89  0806.7      120105



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

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
print_data:
     proc (p_stuff, print_data_info_ptr, p_code);

/*
   This program is for printing p_stuff, a string produced by a "put data",
   in a special format.  print_data_info, based on print_data_info_ptr, is
   used to control the format, as well as select the output switch.
   Written by Lindsey L. Spratt.
   Modified:
   06/21/79  by  Lindsey Spratt; add rtrim(ltrim()) of intervals, check for
   correct print_data_info version, add error code reporting.
   02/15/85 by Chris Jones to clean up properly.
*/

/* Automatic */

dcl	start_scan_idx	   fixed bin (24);
dcl	code		   fixed bin (35);
dcl	p_code		   fixed bin (35);
dcl	more_intervals	   bit (1);
dcl	first_interval	   bit (1);
dcl	1 item,
	  2 storage_id	   char (256) varying,
	  2 value		   char (1024) varying;
dcl	storage_id_pad	   char (256) varying;
dcl	interval_spec	   char (256) varying;
dcl	first_blank	   fixed bin (35);
dcl	temp_seg_ptrs	   (2) ptr;
dcl	target_ptr	   ptr;
dcl	source_ptr	   ptr;
dcl	current_period	   fixed bin (35);
dcl	current_quote	   fixed bin (35);
dcl	following_quote	   fixed bin (35);
dcl	following_double_quote fixed bin (35);
dcl	temp_value	   char (32) varying;
dcl	more		   bit (1);
dcl	null		   builtin;
dcl	found		   bit (1);
dcl	level		   fixed bin;
dcl	root_of_level_list	   ptr;
dcl	p_stuff		   char (*) varying;

/* Based */

dcl	1 level_id	   based,
	  2 str		   char (32) varying,
	  2 next		   ptr;
dcl	temp_seg		   char (sys_info$max_seg_size * 4) varying based;

/* External */

dcl	sys_info$max_seg_size  fixed bin (35) ext;
dcl	error_table_$unimplemented_version
			   fixed bin (35) ext;

/* Entry */

dcl	ioa_$ioa_switch	   entry options (variable);
dcl	ioa_		   entry options (variable);
dcl	ioa_$rsnnl	   entry options (variable);
dcl	get_temp_segments_	   entry (char (*), pointer dimension (*), fixed bin (35));
dcl	release_temp_segments_ entry (char (*), pointer dimension (*), fixed bin (35));

/* Builtin */

dcl	(bin, bit, copy, index, length, ltrim, reverse, rtrim, substr)
			   builtin;

/* Condition */

dcl	cleanup		   condition;


	if print_data_info.version ^= print_data_info_version_1 then do;
	     p_code = error_table_$unimplemented_version;
	     return;
	end;

	temp_seg_ptrs (*) = null ();
	root_of_level_list = null ();

	on cleanup call clean_up;

	call get_temp_segments_ ("print_data", temp_seg_ptrs, code);
	source_ptr = temp_seg_ptrs (1);
	target_ptr = temp_seg_ptrs (2);
	source_ptr -> temp_seg = p_stuff;
	target_ptr -> temp_seg = "";
	more_intervals = "1"b;
	interval_spec = rtrim (ltrim (print_data_info.intervals));
	start_scan_idx = 1;
	call setup_interval (start_scan_idx);
	first_interval = "1"b;
	do while (more_intervals | first_interval);
	     first_interval = "0"b;			/* The following loop parses a storage_id and a value out of p_stuff.
						   first_blank identifies the end of the storage_id which begins p_stuff. */

	     first_blank = index (source_ptr -> temp_seg, " ");
	     root_of_level_list = null;
	     do while (first_blank > 0);
		item.storage_id = substr (source_ptr -> temp_seg, 1, first_blank);
						/* p_stuff is set up to begin with the storage_id. */
		current_period = index (item.storage_id, ".");
						/* The storage id is indented two spaces for each level in the id. */
		storage_id_pad = "";
		do level = 1 by 1 while (current_period > 0);
		     temp_value = substr (item.storage_id, 1, current_period - 1);
		     call check_level (temp_value, level, found);
		     item.storage_id = substr (copy (item.storage_id, 1), current_period + 1);
		     if ^found then do;
			temp_value = storage_id_pad || copy (temp_value, 1);
			if print_data_info.output_switch ^= null then
			     call ioa_$ioa_switch (print_data_info.output_switch, "^a", temp_value);
			else call ioa_ ("^a", temp_value);
		     end;
		     storage_id_pad = copy (" ", print_data_info.indentation) || storage_id_pad;
		     current_period = index (item.storage_id, ".");
		end;
		call check_level (item.storage_id, level, found);
		item.storage_id = storage_id_pad || copy (item.storage_id, 1);
		target_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, first_blank + 1));
		call switch_source_and_target;	/*  The string is processed for quotes, and quote doubling.  */

		if substr (source_ptr -> temp_seg, 1, 1) = """" then do;
		     current_quote = 1;
		     more = "1"b;
		     do while (more);
			following_quote =
			     index (substr (source_ptr -> temp_seg, current_quote + 1), """") + current_quote;
			following_double_quote =
			     index (substr (source_ptr -> temp_seg, current_quote + 1), """""") + current_quote;
			if following_double_quote = current_quote | following_quote < following_double_quote then
			     more = "0"b;
			else current_quote = following_quote;
		     end;
		     item.value = substr (source_ptr -> temp_seg, 1, following_quote);
		     source_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, following_quote + 1));

		     if substr (source_ptr -> temp_seg, 1, 1) = "b" then do;
						/*  Allow for bit strings. */
			item.value = copy (item.value, 1) || "b";
			if print_data_info.flags.octal then do;
			     call ioa_$rsnnl ("^oo", item.value, 0,
				bin (
				bit (substr (item.value, 2, length (item.value) - 3), length (item.value) - 3)));
			end;
			target_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, 2));
			call switch_source_and_target;
		     end;
		end;
		else do;
		     first_blank = index (source_ptr -> temp_seg, " ");
		     if first_blank = 0 then
			first_blank = length (source_ptr -> temp_seg);
		     item.value = substr (source_ptr -> temp_seg, 1, first_blank);
		     target_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, first_blank));
		     call switch_source_and_target;
		end;
		if print_data_info.output_switch ^= null then
		     call ioa_$ioa_switch (print_data_info.output_switch, "^a^vt^a", item.storage_id,
			print_data_info.value_column, item.value);
		else call ioa_ ("^a^vt^a", item.storage_id, print_data_info.value_column, item.value);
		first_blank = index (source_ptr -> temp_seg, " ");
	     end;
	     call setup_interval (start_scan_idx);
	end;
	call clean_up;
	return;					/* End of print_data main proc. */

clean_up:
     proc;

dcl	current_level_ptr	   ptr;

	do current_level_ptr = root_of_level_list repeat root_of_level_list while (current_level_ptr ^= null ());
	     root_of_level_list = current_level_ptr -> level_id.next;
	     free current_level_ptr -> level_id;
	end;
	call release_temp_segments_ ("print_data", temp_seg_ptrs, (0));

     end clean_up;

switch_source_and_target:
     proc;
dcl	temp_ptr		   ptr;
	temp_ptr = target_ptr;
	target_ptr = source_ptr;
	source_ptr = temp_ptr;
     end;

check_level:
     proc (p_str, p_level, p_found);
dcl	p_str		   char (*) varying;
dcl	p_level		   fixed bin;
dcl	p_found		   bit (1);
dcl	idx		   fixed bin;
dcl	next_level_ptr	   ptr;
dcl	current_level_ptr	   ptr;

	current_level_ptr, next_level_ptr = root_of_level_list;
	do idx = 1 to p_level while (next_level_ptr ^= null);
	     current_level_ptr = next_level_ptr;
	     next_level_ptr = current_level_ptr -> level_id.next;
	end;
	if next_level_ptr ^= null			/* Implies p_level is less than length of level_list. */
	then do;
	     if current_level_ptr -> level_id.str = p_str then do;
		p_found = "1"b;
		return;
	     end;
	     else do;				/* Already printed component at this level is different than current component,
						   so the rest (higher levels) of the level_list is no longer appropriate. */
		current_level_ptr -> level_id.str = p_str;
		current_level_ptr -> level_id.next = null;
		current_level_ptr = next_level_ptr;
		do while (current_level_ptr ^= null);
		     next_level_ptr = current_level_ptr -> level_id.next;
		     free current_level_ptr -> level_id;
		     current_level_ptr = next_level_ptr;
		end;
		p_found = "0"b;
	     end;
	end;
	else if idx = p_level then do;		/* This implies level_list is one shorter than p_level. */
	     allocate level_id set (next_level_ptr);
	     if current_level_ptr ^= null then
		current_level_ptr -> level_id.next = next_level_ptr;
	     else root_of_level_list = next_level_ptr;
	     next_level_ptr -> level_id.str = p_str;
	     next_level_ptr -> level_id.next = null;
	     p_found = "0"b;
	end;
	else do;					/* idx > p_level */
	     current_level_ptr -> level_id.str = p_str;
	     p_found = "0"b;
	end;
     end check_level;

setup_interval:
     proc (p_scan_idx);
dcl	p_scan_idx	   fixed bin (24);
dcl	start_scan_idx	   fixed bin (24);
dcl	scan_length	   fixed bin (24);

	start_scan_idx = p_scan_idx;
	call get_interval (start_scan_idx, scan_length, more_intervals);
	p_scan_idx = scan_length + start_scan_idx;
	source_ptr -> temp_seg = rtrim (ltrim (substr (p_stuff, start_scan_idx, scan_length)));

/* All occurences of =" are expanded to =<SP>", ("=""" -> "= """).  Since this
   doesn't change number or ordering of quotes, this change does not alter the
   parsing of quoted strings.  It is necessary to insure proper parsing of
   storage id's from their values when their values are strings, bit or
   character.  */

	start_scan_idx = 1;
	target_ptr -> temp_seg = "";
	scan_length = index (source_ptr -> temp_seg, "=""");
	do while (scan_length > 0);
	     target_ptr -> temp_seg =
		target_ptr -> temp_seg || substr (source_ptr -> temp_seg, start_scan_idx, scan_length);
	     target_ptr -> temp_seg = target_ptr -> temp_seg || " ";
	     start_scan_idx = scan_length + start_scan_idx;
	     scan_length = index (substr (source_ptr -> temp_seg, start_scan_idx), "=""");
	end;

	target_ptr -> temp_seg = target_ptr -> temp_seg || substr (source_ptr -> temp_seg, start_scan_idx);
	call switch_source_and_target;
     end;



get_interval:
     proc (p_start_scan_idx, p_scan_length, p_more_intervals);
dcl	p_start_scan_idx	   fixed bin (24);
dcl	p_scan_length	   fixed bin (24);
dcl	p_more_intervals	   bit (1);
dcl	interval		   char (256) varying;
dcl	interval_idx	   fixed bin;
dcl	delimiter_idx	   fixed bin;
dcl	start_scan_idx	   fixed bin (35);
dcl	scan_length	   fixed bin (35);

	if interval_spec = "" then do;
	     p_more_intervals = "0"b;
	     p_scan_length = length (p_stuff) - p_start_scan_idx;
	     return;
	end;
	interval_idx = index (interval_spec, " ") - 1;
	if interval_idx = -1 then
	     interval_idx = length (interval_spec);
	interval = substr (interval_spec, 1, interval_idx);
	interval_spec = ltrim (substr (copy (interval_spec, 1), interval_idx + 1));
	delimiter_idx = index (interval, "|");
	if delimiter_idx = 0 then do;
	     p_start_scan_idx = index (substr (p_stuff, p_start_scan_idx), interval);
	     p_start_scan_idx = p_start_scan_idx - index (reverse (substr (p_stuff, 1, p_start_scan_idx)), " ");
	     source_ptr -> temp_seg = substr (p_stuff, p_start_scan_idx);
	     p_scan_length = length (p_stuff);
	     interval_spec = "";
	     p_more_intervals = "0"b;
	     return;
	end;
	else if delimiter_idx = 1 then do;
	     p_scan_length = index (substr (p_stuff, p_start_scan_idx), substr (interval, 2));
	     p_scan_length = p_scan_length - index (reverse (substr (p_stuff, p_start_scan_idx, p_scan_length)), " ");
	     source_ptr -> temp_seg = ltrim (rtrim (substr (p_stuff, p_start_scan_idx, p_scan_length)));
	     p_scan_length = p_start_scan_idx + p_scan_length - 1;
	     if interval_spec = "" then
		p_more_intervals = "0"b;
	     else p_more_intervals = "1"b;
	     return;
	end;
	else if delimiter_idx = length (interval) then do;
	     p_start_scan_idx = index (substr (p_stuff, p_start_scan_idx), interval);
	     p_start_scan_idx = p_start_scan_idx - index (reverse (substr (p_stuff, 1, p_start_scan_idx)), " ");
	     source_ptr -> temp_seg = substr (p_stuff, p_start_scan_idx);
	     p_scan_length = length (p_stuff);
	     interval_spec = "";
	     p_more_intervals = "0"b;
	     return;
	end;
	else do;					/* Both a beginning and an end are given for the interval. */
	     start_scan_idx = index (substr (p_stuff, p_start_scan_idx), substr (interval, 1, delimiter_idx - 1));
	     start_scan_idx =
		start_scan_idx - index (reverse (substr (p_stuff, p_start_scan_idx, start_scan_idx)), " ");
	     p_start_scan_idx = start_scan_idx;
	     scan_length = index (substr (p_stuff, p_start_scan_idx), substr (interval, delimiter_idx + 1));
	     scan_length = scan_length - index (reverse (substr (p_stuff, p_start_scan_idx, scan_length)), " ");
	     p_scan_length = scan_length;
	     if interval_spec = "" then
		p_more_intervals = "0"b;
	     else p_more_intervals = "1"b;
	     return;
	end;
     end;

%include print_data_info;

     end print_data;




		    rcprm_find_op.pl1               11/11/89  1111.8rew 11/11/89  0808.5       66501



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */
/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcprm_find_op:
     procedure (a_action, a_resource_desc_item_ptr, a_reconstruct_flag, a_priv_sw, a_operation, a_seek_attr_flag,
	a_error_code);

/*    This program determines the operation needed by rcp_access_kernel_
   *    given the action and the given attributes.
   *    Created 850110 by Maria M. Pozzo
   *
*/

/*                    ARGUMENT DATA                           */

dcl	a_action		   fixed bin;		/* (I) Action being performed */
dcl	a_resource_desc_item_ptr
			   ptr;			/* (I) Attributes that were selected by the user */
dcl	a_reconstruct_flag	   bit (1) aligned;		/* (I) True if this is a reconstruct operation. */
dcl	a_priv_sw		   bit (1) aligned;		/* (I) True if this is a privileged gate call. */
dcl	a_operation	   bit (36) aligned;	/* (O) Encoded RCP operation. */
dcl	a_seek_attr_flag	   bit (1) aligned;		/* (O) "1"b if seeking by attributes, "0"b if by name or uid */
dcl	a_error_code	   fixed bin (35);		/* (O) Error code */

/*                    AUTOMATIC DATA                          */

dcl	priv_sw		   bit (1) aligned;
dcl	reconstruct_flag	   bit (1) aligned;
dcl	seek_attr_flag	   bit (1) aligned;

dcl	operation		   bit (36) aligned;

dcl	action		   fixed bin;
dcl	error_code	   fixed bin (35);

dcl	resource_desc_item_ptr ptr;
dcl	operation_ptr	   ptr;

dcl	1 resource_desc_item   like resource_descriptions.item based (resource_desc_item_ptr) aligned;
dcl	1 en_access_op	   like encoded_access_op based (operation_ptr) aligned;

/*                      EXTERNAL ENTRIES                  */

dcl	error_table_$resource_spec_ambiguous
			   ext fixed bin (35) static;
dcl	error_table_$resource_not_free
			   ext fixed bin (35) static;
dcl	error_table_$resource_free
			   ext fixed bin (35) static;
dcl	error_table_$resource_not_modified
			   ext fixed bin (35) static;
dcl	access_operations_$rcp_register
			   bit (36) aligned external;
dcl	access_operations_$rcp_deregister
			   bit (36) aligned external;
dcl	access_operations_$rcp_register_acquire
			   bit (36) aligned external;
dcl	access_operations_$rcp_acquire
			   bit (36) aligned external;
dcl	access_operations_$rcp_release
			   bit (36) aligned external;
dcl	access_operations_$rcp_reserve
			   bit (36) aligned external;
dcl	access_operations_$rcp_cancel
			   bit (36) aligned external;
dcl	access_operations_$rcp_status
			   bit (36) aligned external;
dcl	access_operations_$rcp_set
			   bit (36) aligned external;
dcl	access_operations_$rcp_set_access
			   bit (36) aligned external;
dcl	access_operations_$rcp_clear
			   bit (36) aligned external;
dcl	access_operations_$rcp_reconstruct_registry
			   bit (36) aligned external;
%page;
/*  Copy arguments */

	action = a_action;
	resource_desc_item_ptr = a_resource_desc_item_ptr;
	reconstruct_flag = a_reconstruct_flag;
	priv_sw = a_priv_sw;

/*  Initialize local variables */

	operation = "0"b;
	operation_ptr = addr (operation);
	ops_ptr = addr (en_access_op.detailed_operation);
	seek_attr_flag = "1"b;
	error_code = 0;

/*  Find out if we're seeking for the resource by name or uid, or just */
/*  by attributes */

	if resource_desc_item.given.name | resource_desc_item.given.uid then
	     seek_attr_flag = "0"b;

/*  Check for register and acquire operation first */
/*  The resource name must be given and the uid must NOT be given */
/*  unless this is a reconstruct operation. If owner, release_lock */
/*  or aim_range is given then this is an implicit acquire.   */

	if action = Register then do;
	     if ^resource_desc_item.given.name then
		error_code = error_table_$resource_spec_ambiguous;
	     if resource_desc_item.given.uid & ^reconstruct_flag then
		error_code = error_table_$resource_spec_ambiguous;
	     if resource_desc_item.given.owner | resource_desc_item.given.release_lock
		| resource_desc_item.given.aim_range then
		operation = access_operations_$rcp_register_acquire;
	     else operation = access_operations_$rcp_register;
	end;
	else if action = Acquire then
	     operation = access_operations_$rcp_acquire;

/*  Check for the Set operation next */
/*  Cannot Set by attributes. */
/*  Cannot Set the owner. */
/*  If the acs_path is given or the access_class, this is a set_access */
/*  operation. All other requests are a set operation. */

	else if action = Set then do;
	     if seek_attr_flag then do;
		error_code = error_table_$resource_spec_ambiguous;
		goto MAIN_RETURN;
	     end;
	     if resource_desc_item.given.owner then do;
		error_code = error_table_$resource_not_modified;
		goto MAIN_RETURN;
	     end;
	     if (resource_desc_item.given.potential_aim_range | resource_desc_item.given.aim_range
		| resource_desc_item.given.acs_path) then
		operation = access_operations_$rcp_set_access;
	     else operation = access_operations_$rcp_set;
	end;

/* Check Status operation next. */
/* Cannot Status by attributes. */

	else if action = Status then do;
	     if seek_attr_flag then do;
		error_code = error_table_$resource_spec_ambiguous;
		goto MAIN_RETURN;
	     end;
	     operation = access_operations_$rcp_status;
	end;

/*  Check release operation next. */
/*  Cannot release the resource by attributes. */

	else if action = Release then do;
	     if seek_attr_flag then do;
		error_code = error_table_$resource_spec_ambiguous;
		goto MAIN_RETURN;
	     end;
	     operation = access_operations_$rcp_release;
	end;

/*  Check reserve operation next. */

	else if action = Reserve then
	     operation = access_operations_$rcp_reserve;

/*  Check cancel operation next. */
/*  Cannot cancel a resource by attributes. */

	else if action = Cancel then do;
	     if seek_attr_flag then do;
		error_code = error_table_$resource_spec_ambiguous;
		goto MAIN_RETURN;
	     end;
	     operation = access_operations_$rcp_cancel;
	end;

/* Check Deregister next. */
/* Cannot deregister resource by attributes. */

	else if action = Deregister then do;
	     if seek_attr_flag then do;
		error_code = error_table_$resource_spec_ambiguous;
		goto MAIN_RETURN;
	     end;
	     operation = access_operations_$rcp_deregister;
	end;

/* Clear operation */
/* Cannot clear a resource by attributes. */

	else if action = Clear then do;
	     if seek_attr_flag then do;
		error_code = error_table_$resource_spec_ambiguous;
		goto MAIN_RETURN;
	     end;
	     operation = access_operations_$rcp_clear;
	end;

/* Now set the selected given arguments for this operation from the */
/* given flags. */

	detailed_operation.given = resource_desc_item.given, by name;
	detailed_operation.priv_gate_call = priv_sw;
	detailed_operation.search = seek_attr_flag;

MAIN_RETURN:
	a_operation = operation;
	a_seek_attr_flag = seek_attr_flag;
	a_error_code = error_code;

	return;

%page;
%include access_audit_encoded_op;
%page;
%include rcp_ops;
%page;
%include rcprm_action_codes;
%page;
%include resource_control_desc;

     end rcprm_find_op;




		    rcprm_find_resource_.pl1        11/11/89  1111.8rew 11/11/89  0805.9      582786



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcprm_find_resource_:
     proc;
	return;

/* This procedure is charged with locating specific resources in RCP resource
   management registries.

   The register entrypoint makes a certain resource known to the system so that
   it may be referred to by name.

   The deregister entrypoint removes a certain resource from the registries so
   that it may no longer be used by any process.

   The acquire entrypoint finds a free resource that meets or exceeds given
   criteria, and "acquires it to" the calling process such that this process
   now owns/controls and is the "resource executive" for the resource.

   The release entrypoint relinquishes a resource back to the free pool,
   providing the requestor is the owner (not just a resource executive.)

   The reserve entrypoint finds a resource that meets or exceeds the given
   criteria, and belongs to the "system pool".  The resource is then
   temporarily allocated for the use of the calling process.  This implements a
   variant of a "scratch tape" facility.  Note that this entrypoint does NOT
   perform the actual RCP reservation, but only locates a resource suitable for
   such a reservation in the case where the requestor does not specify a
   resource which already belongs to him.

   The status entrypoint will find a resource given its name or UID, and return
   all the information about it that a user needs to (or is allowed to) know.

   The set entrypoint will find a resource given its name or UID, and replace
   various properties of it (depending on your privilege and access).

   The clear entrypoint is used to confirm to resource management that a volume
   that has been released has had its contents destroyed (via degaussing or
   whatever) and can return to the free pool to be acquired by someone else.
   This is only necessary of the volume is to be locked on release, as noted
   in the RTDT.

   The reconstruct entrypoint does all of the above things. It is used solely
   by rcprm_journalize_$reconstruct.  It includes the proper action code.
   The main difference is that we don't try to grab the transaction control
   file because we know it's mylocked.
*/

/* Written 05/09/78 by C. D. Tavares */
/* Modified 11/21/79 by CDT to make privileged release use the real
   owner's name, not that of the releaser. */
/* Modified 12/10/79 by CDT to take advantage of new facility to sleep in ring
   1 */
/* Modified 02/27/80 by CDT to make scratch selection match on potential
   attributes, not current attributes; and to disable setting of current
   attributes in contexts where the desired_attribute field is used only as a
   search criterion (i.e. in an acquisition by attributes instead of by name */
/* Modified 06/17/81 by CDT to detect multiple requests for same resource
   in same call, and to complain about attempt to change owner in set entry */
/* Modified 04/83 by B. Braun to:
   1. correct problem of RQO in the process_dir (phx11736, phx14452).
   2. prevent damage to the registry during aquistion of resources by
   locking the registry record upon modification (phx11638, phx13502).
   3. decrement the ref_count on free key when deregistering a resource
   (phx11636). */
/* Modified 1/85 by Maria Pozzo and Chris Jones for B2 effort. */

/****^  HISTORY COMMENTS:
  1) change(87-06-08,Rauschelbach), approve(87-06-26,MCR7713),
     audit(87-07-08,Farley), install(87-07-15,MR12.1-1041):
     Fixes:
     1) No longer returns awaiting-clear state for resources to which
     the user does not have access.
     2) The clear operation now functions.
     3) A catch for when operation-type is not handled was added.
     4) Error reporting now returns error_table_$action_not_performed for the
     global error code.
     5) Error code in the structure is now set when an error occurred on a
     specific resource.
  2) change(87-07-14,Rauschelbach), approve(87-08-07,MCR7748),
     audit(87-11-11,Farley), install(87-11-30,MR12.2-1004):
     Removed signal to vfile_error condition as it was erroneously left in from
     debugging.
                                                   END HISTORY COMMENTS */

/* automatic */

dcl	action		   fixed bin;
dcl	audit_obj_ok	   bit (1);
dcl	auto_registration	   bit (1) aligned initial (""b);
dcl	base_rno		   fixed bin;
dcl	base_given_uid	   bit (1);
dcl	base_given_name	   bit (1);
dcl	base_uid		   bit (36);
dcl	base_name		   char (32);
dcl	base_type		   char (32);
dcl	bl		   fixed bin (21);
dcl	bp		   pointer;
dcl	callers_rdp	   ptr;
dcl	clear_ok		   bit (1);
dcl	code		   fixed bin (35);
dcl	cur_level		   fixed bin;
dcl	requestor_owner_id	   char (32) varying;
dcl	current_rew	   bit (3);
dcl	found		   bit (1) aligned;
dcl	is_volume		   bit (1);
dcl	lock_sw		   bit (1) aligned;
dcl	old_key		   char (256) varying;
dcl	operation		   bit (36) aligned;
dcl	operation_ptr	   ptr;
dcl	priv_sw		   bit (1) aligned initial ("0"b);
dcl	prev_level	   fixed bin;
dcl	proxy_authorization	   bit (72) aligned;
dcl	proxy_call	   bit (1) aligned initial ("0"b);
dcl	proxy_group_id	   char (32);
dcl	read_key		   char (256) varying;
dcl	rec_len		   fixed bin (21);
dcl	reconstruct_operation  bit (1) aligned initial ("0"b);
dcl	record_descrip	   fixed bin (35);
dcl	registry_dir	   char (64);
dcl	registry_open	   char (32);
dcl	reserver_info_ptr	   ptr;
dcl	resource_type	   char (32) defined (registry_open);
dcl	rno		   fixed bin;
dcl	seek_attr_flag	   bit (1) aligned;
dcl	simple_code	   fixed bin (35);
dcl	sstruc_ptr	   pointer;
dcl	swno		   fixed bin;
dcl	temp_acs_path	   char (168);
dcl	temp_atts		   (2) bit (72) aligned based (addr (temp_relatts));
dcl	temp_bounds	   (2) bit (72) aligned;
dcl	temp_bounds_based	   (2) bit (72) aligned based;
dcl	temp_key		   char (256) varying;
dcl	temp_non_var_key	   char (256);
dcl	temp_owner_name	   char (32);
dcl	temp_relatts	   (4) bit (72) aligned;
dcl	temp_mode		   bit (3);
dcl	transaction_time	   fixed bin (71);
dcl	tsw_ptr		   pointer;
dcl	validity		   fixed bin;
dcl	who_am_i		   char (32);

dcl	1 en_access_op	   like encoded_access_op based (operation_ptr) aligned;
dcl	1 record_status	   aligned automatic like rs_info;
dcl	1 rs		   aligned automatic like rs_info;
dcl	1 res_info	   aligned automatic like resource_info;
dcl	1 req_info	   aligned automatic like requestor_info;

dcl	1 add_key_info	   automatic,
	  2 header	   like ak_header,
	  2 key		   char (256);

dcl	1 get_key_info	   automatic,
	  2 header	   like gk_header,
	  2 key		   char (256);

/* static */

dcl	my_owner_id	   char (32) varying static initial ("");
dcl	my_group_id	   char (32) static initial ("");

dcl	(
	Absolute		   initial (0),
	Relative		   initial (1)
	)		   fixed bin static options (constant);

dcl	(Move_rel, Equal)	   initial (0) fixed bin static options (constant);

dcl	Lowest_Aim_Range	   (2) fixed bin (71) aligned static options (constant) initial ((2)0);

dcl	sys_areap		   pointer static initial (null);

/* entries */

dcl	absolute_pathname_$add_suffix
			   entry (char (*), char (*), char (*), fixed bin (35));
dcl	admin_gate_$syserr	   ext entry options (variable);
dcl	admin_gate_$syserr_error_code
			   ext entry options (variable);
dcl	cu_$level_get	   ext entry (fixed bin);
dcl	cu_$level_set	   ext entry (fixed bin);
dcl	cv_rcp_attributes_$make_rel
			   ext entry (char (*), (2) bit (72) aligned, (4) bit (72) aligned, fixed bin (35));
dcl	cv_rcp_attributes_$modify_rel
			   ext entry ((2) bit (72) aligned, (4) bit (72) aligned, (2) bit (72) aligned);
dcl	cv_rcp_attributes_$test_valid
			   ext entry (char (*), (2) bit (72) aligned, fixed bin, fixed bin (35));
dcl	rcprm_find_op	   ext
			   entry (fixed bin, ptr, bit (1) aligned, bit (1) aligned, bit (36) aligned,
			   bit (1) aligned, fixed bin (35));
dcl	hcs_$get_authorization ext entry (bit (72) aligned, bit (72) aligned);
dcl	get_process_authorization_
			   ext entry returns (bit (72) aligned);
dcl	get_group_id_	   ext entry returns (char (32));
dcl	get_ring_		   ext entry returns (fixed bin);
dcl	get_system_free_area_  ext entry returns (pointer);
dcl	admin_gate_$make_uid   ext entry (bit (36) aligned);
dcl	rcp_access_kernel_	   entry (bit (36) aligned, ptr, ptr, bit (3), fixed bin (35));
dcl	rcp_audit		   entry (char (*), bit (36) aligned, ptr, ptr, char (*), bit (3), bit (3),
			   (2) fixed bin (3), bit (1), fixed bin (35));
dcl	rcp_compute_aim_mode$permissible_aim
			   entry ((2) bit (72) aligned, (2) bit (72) aligned, fixed bin (35));
dcl	resource_info_$get_type
			   entry (char (*), bit (1), fixed bin (35));
dcl	resource_info_$lock_on_release
			   ext entry (char (*), bit (1) aligned, fixed bin (35));
dcl	resource_info_$canonicalize_name
			   entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));
dcl	resource_info_$default_attributes
			   ext entry (char (*) aligned, bit (72) aligned, fixed bin (35));
dcl	resource_info_$set_arbitrary_attributes
			   ext entry (char (*), bit (72) aligned, (2) bit (72) aligned, fixed bin (35));

dcl	rcp_reserve_$approve_schedule
			   ext entry (pointer, fixed bin, char (*), pointer, bit (18) unaligned, fixed bin (35));
dcl	rcp_cancel_id_$remove_schedule
			   ext entry (pointer, fixed bin, char (*), pointer, bit (18) unaligned, fixed bin (35));
dcl	rcprm_journalize_	   ext entry (pointer, fixed bin, fixed bin (71), char (*));
dcl	rcprm_registry_util_$grab_transaction_control_file
			   entry (ptr, char (*), fixed bin (35));
dcl	rcprm_registry_util_$grab_registry
			   entry (ptr, char (*), char (*), fixed bin (35));
dcl	rcprm_registry_util_$release_transaction_control_file
			   entry (ptr, fixed bin (35));
dcl	rcprm_registry_util_$release_registry
			   entry (ptr, fixed bin (35));
dcl	rcprm_registry_util_$free_key
			   entry (ptr, char (*));
dcl	rcprm_registry_util_$system_key
			   entry (ptr, char (*));
dcl	rcprm_registry_util_$name_key
			   entry (char (*), ptr, char (*));
dcl	rcprm_registry_util_$owner_key
			   entry (char (*), ptr, char (*));
dcl	rcprm_registry_util_$uid_key
			   entry (bit (36) aligned, ptr, char (*));

/* external variables */

dcl	(
	error_table_$action_not_performed,
	error_table_$resource_awaiting_clear,
	error_table_$bad_resource_spec,
	error_table_$duplicate_request,
	error_table_$end_of_info,
	error_table_$namedup,
	error_table_$no_record,
	error_table_$not_abs_path,
	error_table_$not_privileged,
	error_table_$not_seg_type,
	error_table_$rcp_attr_not_permitted,
	error_table_$rcp_bad_attributes,
	error_table_$resource_bad_access,
	error_table_$resource_free,
	error_table_$resource_locked,
	error_table_$resource_not_free,
	error_table_$resource_unavailable,
	error_table_$resource_unknown,
	error_table_$unimplemented_version,
	error_table_$unsupported_operation
	)		   ext fixed bin (35) static;

dcl	sys_info$max_seg_size  fixed bin (35) ext static;

/* based variables */

dcl	based_bits	   bit (bl * 9) aligned based (bp);
dcl	based_charstring	   char (bl) aligned based (bp);
dcl	sys_area		   based (sys_areap) area (sys_info$max_seg_size);

dcl	potential_attributes_based
			   bit (72) based;

dcl	1 switch_struc	   aligned based (sstruc_ptr),
	  2 maxno		   fixed bin,
	  2 usedno	   fixed bin initial (0),
	  2 xxx		   (resource_descriptions.n_items refer (switch_struc.maxno)) aligned,
	    3 registry	   char (32),
	    3 sw_ptr	   pointer;

/* builtins and conditions */

dcl	cleanup		   condition;

dcl	(addr, clock, length, null, rtrim, size, string, substr, unspec)
			   builtin;

priv_acquire:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	priv_sw = "1"b;

acquire:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

dcl	p_resource_desc_ptr	   ptr parameter;
dcl	p_registry_dir	   char (*) parameter;
dcl	p_code		   fixed bin (35) parameter;

	action = Acquire;
	who_am_i = "rcprm_find_resource_$acquire";
	goto common_2;
%skip (4);
priv_release:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	priv_sw = "1"b;

release:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	action = Release;
	who_am_i = "rcprm_find_resource_$release";
	goto common_2;
%skip (4);
clear:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	action = Clear;
	priv_sw = "1"b;
	who_am_i = "rcprm_find_resource_$clear";
	goto common_2;
%skip (4);
priv_reserve:
     entry (p_resource_desc_ptr, p_registry_dir, p_reserver_info_ptr, p_code);

dcl	p_reserver_info_ptr	   pointer parameter;	/* reserver passes this, what it is is up to him */

	priv_sw = "1"b;

reserve:
     entry (p_resource_desc_ptr, p_registry_dir, p_reserver_info_ptr, p_code);

	action = Reserve;
	who_am_i = "rcprm_find_resource_$reserve";
	goto common_1;

reserve_proxy:
     entry (p_resource_desc_ptr, p_registry_dir, p_reserver_info_ptr, p_proxy_group_id, p_proxy_authorization, p_code);

dcl	p_proxy_group_id	   char (*) parameter;
dcl	p_proxy_authorization  bit (72) aligned parameter;

	action = Reserve;
	proxy_call = "1"b;
	proxy_group_id = p_proxy_group_id;
	proxy_authorization = p_proxy_authorization;
	who_am_i = "rcprm_find_resource_$reserve";
	goto common_1;
%skip (4);
priv_cancel:
     entry (p_resource_desc_ptr, p_registry_dir, p_reserver_info_ptr, p_code);

	priv_sw = "1"b;

cancel:
     entry (p_resource_desc_ptr, p_registry_dir, p_reserver_info_ptr, p_code);

	action = Cancel;
	who_am_i = "rcprm_find_resource_$cancel";
	goto common_1;
%skip (4);
priv_status:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	priv_sw = "1"b;

status:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	action = Status;
	who_am_i = "rcprm_find_resource_$status";
	goto common_2;
%skip (4);
priv_set:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	priv_sw = "1"b;

set:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	action = Set;
	who_am_i = "rcprm_find_resource_$status";
	goto common_2;
%skip (4);
auto_register:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	auto_registration = "1"b;

register:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	priv_sw = "1"b;
	action = Register;
	who_am_i = "rcprm_find_resource_$register";
	goto common_2;
%skip (4);
deregister:
     entry (p_resource_desc_ptr, p_registry_dir, p_code);

	priv_sw = "1"b;
	action = Deregister;
	who_am_i = "rcprm_find_resource_$deregister";
	goto common_2;
%skip (4);
reconstruct:
     entry (p_resource_desc_ptr, p_registry_dir, p_action, p_tsw_ptr, p_code);

dcl	p_action		   fixed bin parameter;
dcl	p_tsw_ptr		   pointer parameter;

	priv_sw = "1"b;
	action = p_action;
	reconstruct_operation = "1"b;
	who_am_i = "rcprm_find_resource_$reconstruct";
	goto common_2;

common_1:
	reserver_info_ptr = p_reserver_info_ptr;

common_2:
	audit_obj_ok = "0"b;			/* For auditing purposes, different audit calls depending on if we have retrieved the object (if it exists), etc. */
	registry_dir = p_registry_dir;
	operation = ""b;
	operation_ptr = addr (operation);
	ops_ptr = addr (en_access_op.detailed_operation);
	seek_attr_flag = "0"b;
	code = 0;

	call cu_$level_get (prev_level);
	tsw_ptr, ak_info_ptr, gk_info_ptr, sstruc_ptr, resource_desc_ptr = null;
	registry_open = "";

	unspec (record_status) = ""b;
	record_status.version = rs_info_version_2;
	record_status.record_ptr = null ();
	record_ptr = null ();

	if sys_areap = null then
	     sys_areap = get_system_free_area_ ();
	if my_owner_id = "" then do;
	     my_group_id = get_group_id_ ();
	     my_owner_id = rtrim (my_group_id);
	     my_owner_id = substr (my_owner_id, 1, length (my_owner_id) - 2);
	end;

	if ^proxy_call then
	     requestor_owner_id = my_owner_id;
	else do;
	     requestor_owner_id = proxy_group_id;
	     requestor_owner_id = rtrim (requestor_owner_id);
	     requestor_owner_id = substr (requestor_owner_id, 1, length (requestor_owner_id) - 2);
	end;

	on cleanup call clean_up (0, ""b);

/* ------------------------- */

clean_up:
     proc (code, error_matters);

dcl	code		   fixed bin (35) parameter;
dcl	error_matters	   bit (1) aligned parameter;

dcl	i		   fixed bin;
dcl	saved_code	   fixed bin (35);

	saved_code = 0;
	if tsw_ptr ^= null then do;
	     do i = 1 to switch_struc.usedno;
		if sw_ptr (i) ^= null then do;
		     if ^error_matters then do;	/* real abort, roll back */
			call iox_$control (sw_ptr (i), "rollback", null, code);
			call save_code_if_error;
		     end;
		     call rcprm_registry_util_$release_registry (sw_ptr (i), code);
		     call save_code_if_error;
		end;
	     end;
	     if ^reconstruct_operation then do;
		call rcprm_registry_util_$release_transaction_control_file (tsw_ptr, code);
		call save_code_if_error;
	     end;
	end;
	if sstruc_ptr ^= null then do;
	     free switch_struc;
	     sstruc_ptr = null ();
	end;
	if resource_desc_ptr ^= null () then do;
	     free resource_descriptions;
	     resource_desc_ptr = null ();
	end;

	if error_matters then
	     code = saved_code;

	call cu_$level_set (prev_level);
	return;

save_code_if_error:
	proc;

	     if saved_code = 0 then
		saved_code = code;

	end save_code_if_error;

     end clean_up;

/* ------------------------- */

	cur_level = get_ring_ ();
	call cu_$level_set (cur_level);

	call get_resource_descriptions;

	if resource_descriptions.version_no ^= resource_desc_version_1 then
	     call error_return (error_table_$unimplemented_version);

/* Loop through the structure to make sure the caller didn't ask for the
   operation to be done to the same resource more than once.  Yeah, somebody
   did it, and it screwed up the record locking. */

	do base_rno = 1 to resource_descriptions.n_items - 1;
	     base_given_uid = resource_descriptions.item (base_rno).given.uid;
	     base_given_name = resource_descriptions.item (base_rno).given.name;
	     base_uid = resource_descriptions.item (base_rno).uid;
	     base_name = resource_descriptions.item (base_rno).name;
	     base_type = resource_descriptions.item (base_rno).type;

	     do rno = base_rno + 1 to resource_descriptions.n_items;
		if resource_descriptions.item (rno).type = base_type then do;

		     if resource_descriptions.item (rno).given.name & base_given_name
			& (resource_descriptions.item (rno).name = base_name) then
			call error_return_in_struc (error_table_$duplicate_request);

		     if resource_descriptions.item (rno).given.uid & base_given_uid
			& (resource_descriptions.item (rno).uid = base_uid) then
			call error_return_in_struc (error_table_$duplicate_request);
		end;
	     end;
	end;

/* So much for user damage.  Back to work. */

	allocate switch_struc in (sys_area) set (sstruc_ptr);

	transaction_time = clock ();

/* First, seize the transaction control vfile exclusively.  This is a cheap
   way to avoid deadlock, but if it proves overly contentious, we'll have to
   implement shared transactions.  */

	if reconstruct_operation then
	     tsw_ptr = p_tsw_ptr;

	else do;
	     call rcprm_registry_util_$grab_transaction_control_file (tsw_ptr, registry_dir, code);
	     if code ^= 0 then
		call error_return (code);
	end;

/* Process the requests one by one. */

	do rno = 1 to resource_descriptions.n_items;

/*  Do some initial setup */

	     call setup_request ();

/* This block of code finds a resource by name or UID. */

	     if ^seek_attr_flag then do;
		call seek_specific ();
		if code ^= 0 then
		     goto MAIN_RETURN;
	     end;

/* This block of code finds a resource by potential attributes only */

	     else do;
		call seek_attr ();
		if code ^= 0 then
		     goto MAIN_RETURN;
	     end;

/* Now we have the (an) appropriate resource.  Process it. */

	     record_descrip = record_status.descriptor;	/* luckily, this is always set */
	     record_status.create_sw = ""b;
	     temp_owner_name = rtrim (requestor_owner_id);/* start out on right foot */

	     if action = Register then do;
		call register ();
		call acquire ();
		call subset ();			/* Doesn't set AIM attributes. */
		call status ();
	     end;
	     else if action = Acquire then do;
		call acquire ();
		call subset ();			/* Doesn't set AIM attributes. */
		call status ();
	     end;
	     else if action = Set then do;
		call set ();			/* Does set  AIM attributes */
		call status ();
	     end;
	     else if action = Release then do;
		call release (clear_ok);
		if clear_ok then
		     call clear ();
	     end;
	     else if action = Status then
		call status ();
	     else if action = Clear then
		call clear ();
	     else if action = Reserve then
		call reserve ();
	     else if action = Deregister then
		call deregister ();
	     else if action = Cancel then
		call cancel ();
	     else call error_return (error_table_$unsupported_operation);
MAIN_RETURN:
	     if code = 0 then
		resource_descriptions.item (rno).status_code = code;
	     else call error_return_in_struc (code);	/* that didn't hurt, now, did it? */
	end;

/* Auditing for registers is done here. */

	if action = Register | action = Acquire then
	     call audit ((0));
	call process_end ();
	p_code = 0;
	return;

error_return_in_struc:
     proc (int_code);

/* the real code is shoved in the structure and a vanilla code is returned */

dcl	int_code		   fixed bin (35) parameter;
dcl	bad_code		   fixed bin (35);

	resource_descriptions.item (rno).status_code = int_code;
	bad_code = error_table_$action_not_performed;
	goto error_common;

error_return:
     entry (int_code);				/* the main difference is that int_code is preserved */

	bad_code = int_code;

error_common:
	call audit (bad_code);
	code = bad_code;
	call put_resource_descriptions ();
	call clean_up (0, ""b);
	goto return_hard;
     end error_return_in_struc;

return_hard:
	p_code = code;
	return;

current_auth:
     proc returns ((2) bit (72) aligned);

dcl	temp_bounds	   (2) bit (72) aligned;

	temp_bounds (1) = get_process_authorization_ ();
	string (addr (temp_bounds (1)) -> aim_template.privileges) = ""b;
	temp_bounds (2) = temp_bounds (1);
	return (temp_bounds);

     end current_auth;

chase:
     proc (descriptor, bp, bl);

dcl	(
	descriptor	   fixed bin (35),
	bp		   pointer,
	bl		   fixed bin (21)
	)		   parameter;

	if descriptor = 0 then do;
	     bp = addr (bp);			/* gotta point somewhere */
	     bl = 0;
	     return;
	end;

	unspec (rs) = ""b;
	rs.version = rs_info_version_2;
	rs.locate_sw = "1"b;
	rs.descriptor = descriptor;

	call iox_$control (sw_ptr (swno), "record_status", addr (rs), code);
	if code ^= 0 then
	     call error_return_in_struc (code);

	bl = rs.record_length;
	bp = rs.record_ptr;

	return;

     end chase;

swap_descriptor:
     proc (descriptor, old_key, new_key, bp, bl);

dcl	descriptor	   fixed bin (35) parameter;
dcl	(old_key, new_key)	   char (*) varying parameter;
dcl	bp		   pointer parameter;
dcl	bl		   fixed bin (21) parameter;

dcl	test_key		   char (256) varying;
dcl	found		   bit (1) aligned;
dcl	based_record	   char (bl) based;

	unspec (rs) = ""b;
	rs.version = rs_info_version_2;

/* First find record to which old descriptor points and decrement its refcount. */

	if descriptor ^= 0 then do;			/* make sure there is a record, first */

	     rs.locate_sw = "1"b;
	     rs.descriptor = descriptor;

	     call iox_$control (sw_ptr (swno), "record_status", addr (rs), code);
	     if code ^= 0 then
		call error_return_in_struc (code);

	     if bl = rs.record_length then		/* check for replacement to same value */
		if rs.record_ptr -> based_record = bp -> based_record then do;
		     descriptor = rs.descriptor;	/* no need to replace X with X */
		     return;
		end;

	     rs.dec_ref_count = "1"b;

	     call iox_$control (sw_ptr (swno), "record_status", addr (rs), code);
	     if code ^= 0 then
		call error_return_in_struc (code);

	     if rs.ref_count = 1 then do;		/* only one reference left; got to be the major key */
						/* means no record is using it, so garbage-collect it. */
		unspec (get_key_info) = ""b;
		get_key_info.input_key = "1"b;
		get_key_info.input_desc = "1"b;
		get_key_info.descrip = descriptor;
		get_key_info.key_len = length (get_key_info.key);
		get_key_info.head_size = length (get_key_info.key);
		get_key_info.key = old_key;
		get_key_info.rel_type = Equal;
		get_key_info.version = gk_info_version_0;

		call iox_$control (sw_ptr (swno), "get_key", addr (get_key_info), code);
						/* locate the record, setting the current record position to it */
		if code ^= 0 then
		     call error_return_in_struc (code);

		call iox_$delete_record (sw_ptr (swno), code);
						/* smash record */
		if code ^= 0 then
		     call error_return_in_struc (code);
	     end;
	end;

/* Now create the new record (or find one like it) and patch it back onto that key. */

	if bl = 0 then do;				/* no new record, done */
	     descriptor = 0;
	     return;
	end;

	found = ""b;

	call iox_$seek_key (sw_ptr (swno), (new_key), 0, code);

	if code = 0 then do;			/* some exist, try to match them */

	     unspec (rs) = ""b;
	     rs.version = rs_info_version_2;

	     test_key = new_key;

	     do while (test_key = new_key & ^found);

		call iox_$control (sw_ptr (swno), "record_status", addr (rs), code);
		if code ^= 0 then
		     call error_return_in_struc (code);

		if rs.record_length = bl then
		     if rs.record_ptr -> based_record = bp -> based_record then
			found = "1"b;

		if ^found then do;
		     call iox_$position (sw_ptr (swno), Move_rel, 1, code);
		     call iox_$read_key (sw_ptr (swno), test_key, 0, code);
		     if code = error_table_$end_of_info then
			test_key = "";
		     else if code ^= 0 then
			call error_return_in_struc (code);
		end;
	     end;

	     if ^found then
		call iox_$seek_key (sw_ptr (swno), (new_key), 0, code);
						/* fix key for insertion so next write works. */
	end;
	else if code ^= error_table_$no_record then
	     call error_return_in_struc (code);

	if ^found then do;
	     call iox_$write_record (sw_ptr (swno), bp, bl, code);
	     if code ^= 0 then
		call error_return_in_struc (code);
	end;

	unspec (rs) = ""b;
	rs.version = rs_info_version_2;
	rs.inc_ref_count = "1"b;

	call iox_$control (sw_ptr (swno), "record_status", addr (rs), code);
	if code ^= 0 then
	     call error_return_in_struc (code);

	descriptor = rs.descriptor;

	return;

     end swap_descriptor;

insert_descriptor:
     proc (descriptor, key, bp, bl);

dcl	descriptor	   fixed bin (35) parameter;
dcl	key		   char (*) varying parameter;
dcl	bp		   ptr parameter;
dcl	bl		   fixed bin (21) parameter;

	call swap_descriptor (descriptor, key, key, bp, bl);

     end insert_descriptor;

swap_key:
     proc (descriptor, old_key, new_key, initial_record);

dcl	descriptor	   fixed bin (35) parameter;
dcl	(old_key, new_key)	   char (256) varying;
dcl	initial_record	   char (*) parameter;

	unspec (add_key_info) = ""b;
	add_key_info.input_key, add_key_info.input_desc = "1"b;
	add_key_info.descrip = descriptor;

	if old_key ^= "" then do;
	     add_key_info.key_len = length (old_key);
	     add_key_info.key = old_key;

	     call iox_$control (sw_ptr (swno), "delete_key", addr (add_key_info), code);
	     if code ^= 0 then
		call error_return (code);
	end;

	call iox_$seek_key (sw_ptr (swno), (new_key), 0, code);
	if code = error_table_$no_record then
	     if initial_record ^= "" then do;

		call iox_$write_record (sw_ptr (swno), addr (initial_record), length (initial_record), code);
		if code ^= 0 then
		     call error_return_in_struc (code);
	     end;
	     else code = 0;				/* may as well be clean about it */
	else if code ^= 0 /* from seek_key */ then
	     call error_return_in_struc (code);

	if new_key ^= "" then do;
	     add_key_info.key_len = length (new_key);
	     add_key_info.key = new_key;

	     call iox_$control (sw_ptr (swno), "add_key", addr (add_key_info), code);
	     if code ^= 0 then
		call error_return (code);
	end;

	return;

     end swap_key;

make_owner_key:
     proc (owner_name) returns (char (*) varying);

dcl	owner_name	   char (*) parameter;

dcl	key		   char (256);

	if owner_name = "system" then
	     return (REGISTRY_SYSTEM_KEY);
	else if owner_name = "free" then
	     return (REGISTRY_FREE_KEY);
	else do;
	     call rcprm_registry_util_$owner_key (owner_name, null (), key);
	     return (rtrim (key));
	end;

     end make_owner_key;

setup_request:
     proc ();

/*  This internal subroutine does some initial setup necessary */
/*  to find the desired resource */

	if ^reconstruct_operation then
	     if resource_descriptions.item (rno).given.name then do;
		call resource_info_$canonicalize_name (resource_descriptions.item (rno).type,
		     (resource_descriptions.item (rno).name), resource_descriptions.item (rno).name, code);

		if code ^= 0 then
		     call error_return_in_struc (code);
	     end;

/* Open the correct registry, if it is not already open. */

	if registry_open = "" | registry_open ^= resource_descriptions.item (rno).type then do;
						/* open a different registry */
	     registry_open = resource_descriptions.item (rno).type;

	     do swno = 1 to switch_struc.usedno while (switch_struc.registry (swno) ^= registry_open);
	     end;

	     if swno > switch_struc.usedno then do;
		call rcprm_registry_util_$grab_registry (sw_ptr (swno), registry_dir, registry_open, code);
		if code ^= 0 then
		     call error_return_in_struc (code);
		switch_struc.usedno = swno;
		switch_struc.registry (swno) = registry_open;

		if (^reconstruct_operation) & (action ^= Status) then do;
						/* set the last transaction time for this registry to now */
		     call iox_$seek_key (sw_ptr (swno), (REGISTRY_HEADER_KEY), 0, code);
		     if code = error_table_$no_record then
			code = error_table_$not_seg_type;
		     if code ^= 0 then
			call error_return_in_struc (code);

		     call iox_$control (sw_ptr (swno), "record_status", addr (record_status), code);
						/* locate and lock the header for modification */
		     if code ^= 0 then
			call error_return (code);

		     header_ptr = record_status.record_ptr;
		     registry_header.last_transaction_time = transaction_time;
						/* set this for edification of rcprm_journalize_ */
		end;
	     end;
	end;

	call rcprm_find_op (action, addr (resource_descriptions.item (rno)), reconstruct_operation, priv_sw, operation,
	     seek_attr_flag, code);
	if code ^= 0 then
	     call error_return_in_struc (code);
     end setup_request;

seek_specific:
     proc ();


	if resource_descriptions.item (rno).given.name then
	     if resource_descriptions.item (rno).name = "scratch" then
		call error_return_in_struc (error_table_$bad_resource_spec);
						/* scratch is a "special" name and should never get here */

	if action = Register then
	     record_status.create_sw = "1"b;

/* Create key to locate record by (in the case of register, to create it by) */

	if resource_descriptions.item (rno).given.name then
	     call rcprm_registry_util_$name_key ((resource_descriptions.item (rno).name), null (), temp_non_var_key);
	else call rcprm_registry_util_$uid_key (resource_descriptions.item (rno).uid, null (), temp_non_var_key);

	temp_key = rtrim (temp_non_var_key);
	call iox_$seek_key (sw_ptr (swno), temp_key, rec_len, code);

	if action = Register then
	     if code ^= error_table_$no_record then
		call error_return_in_struc (error_table_$namedup);
	     else code = 0;				/* good register */
	else if code ^= 0 then
	     call error_return_in_struc (error_table_$resource_unknown);

	if action = Register then do;			/* create a registry record instead of locating one */
	     rr_strl = length (rtrim (resource_descriptions.item (rno).name));
	     record_status.record_length, record_status.max_rec_len = size (null -> registry_record) * 4;
	end;

	if action ^= Status then
	     record_status.lock_sw = "1"b;		/* must lock record to change it */
	else record_status.lock_sw = ""b;

	call iox_$control (sw_ptr (swno), "record_status", addr (record_status), code);
						/* locate (or create) record */
	if code ^= 0 then
	     call error_return (code);
	record_ptr = record_status.record_ptr;
	audit_obj_ok = "1"b;			/* Now we can audit a specific object if we fail. */

/* Make the simple checks first. */

	call simple_checks ();

/*  Ok, see if there is enough access to return this error info. */
	if code ^= 0 then do;
	     simple_code = code;
	     call setup_kernel_call (proxy_call, addr (req_info), addr (res_info));
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), current_rew, code);
	     if current_rew ^= N_ACCESS then		/* Has enough access to see code. */
		call error_return_in_struc (simple_code);
	     else call error_return (code);		/* No, let them see the incorrect access code. */
	end;
	else do;					/* Check user's access to resource, depending on what he wants to do with it */

/* If we are reserving a device, the device name was */
/* generated internally and we will not audit it until */
/* we have access. */

	     call resource_info_$get_type ((resource_type), is_volume, code);
	     if code ^= 0 then
		call error_return_in_struc (code);
	     if action = Reserve & (^is_volume) then
		detailed_operation.search = "1"b;
	     call setup_kernel_call (proxy_call, addr (req_info), addr (res_info));
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), current_rew, code);
	     if code ^= 0 then
		call error_return_in_struc (error_table_$resource_bad_access);
						/* Ok, we have access then if it is a Reserve of a device */
						/* then audit it now. */

	     if action = Reserve & (^is_volume) then do;
		detailed_operation.search = "0"b;
		call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), current_rew, code);
	     end;
	end;

/* At this point, we know the user has enough access to find out about the device. */


	if resource_descriptions.item (rno).given.name & resource_descriptions.item (rno).given.uid
	     & resource_descriptions.item (rno).uid ^= registry_record.uid & ^reconstruct_operation then
	     call error_return_in_struc (error_table_$bad_resource_spec);
     end seek_specific;

seek_attr:
     proc ();

/* Find out if the attributes of the resource matter to the user or not */

	if ^resource_descriptions.item (rno).given.desired_attributes then do;
	     temp_relatts (*) = ""b;
	     call resource_info_$default_attributes (resource_descriptions.item (rno).type, temp_relatts (1), code);
	     if code ^= 0 then
		call error_return_in_struc (code);
	end;
	else temp_relatts = resource_descriptions.item (rno).desired_attributes (*);

/* Now decide what pool of resources we will choose a resource from. */

	if action = Acquire then
	     call rcprm_registry_util_$free_key (null (), temp_non_var_key);

	else if action = Reserve then do;
	     if resource_descriptions.item (rno).given.owner then do;
		call rcprm_registry_util_$free_key (null (), temp_non_var_key);
	     end;
	     else call rcprm_registry_util_$system_key (null (), temp_non_var_key);
	end;

	temp_key = rtrim (temp_non_var_key);
	call iox_$seek_key (sw_ptr (swno), temp_key, rec_len, code);
	if code ^= 0 then do;
	     if code = error_table_$no_record then
		code = error_table_$resource_unavailable;
	     call error_return_in_struc (code);
	end;

	unspec (record_status) = ""b;
	record_status.version = rs_info_version_2;

	found = ""b;

/* Someday there will be an outer loop here which will implement the fancy "resource best-fit backup"
   algorithm which will eliminate certain stupidities of the current algorithm which can cause an error
   of the form "no appropriate resource available" for multiple requests just because it snarfed up a very
   sophisticated resource for a preceding (simple) request, and now has only simple
   resources left to satisfy a sophisticated request.  But that day is NOT today. */

	do while (^found);

	     audit_obj_ok = "0"b;			/* if we fail, we don't have an object to audit at this point so use different methods for auditing. */
	     resource_descriptions.item (rno).name = "";

	     call iox_$position (sw_ptr (swno), Move_rel, 1, code);
						/* move forward one key */
						/* this leads the loop since the first owner record */
						/* is always the owner name, not a resource record */
	     if code ^= 0 then
		call error_return_in_struc (code);

	     call iox_$read_key (sw_ptr (swno), read_key, 0, code);
	     if code = error_table_$end_of_info then
		code = error_table_$resource_unavailable;
	     if code ^= 0 then
		call error_return_in_struc (code);

	     if read_key ^= temp_key then
		call error_return_in_struc (error_table_$resource_unavailable);

	     call iox_$control (sw_ptr (swno), "record_status", addr (record_status), code);
	     if code ^= 0 then
		call error_return_in_struc (code);

	     record_ptr = record_status.record_ptr;
	     audit_obj_ok = "1"b;			/* Ok, we have an object to audit if we should fail now. */

/* do the most inexpensive checks first */

	     call simple_checks ();
	     if code ^= 0 then
		goto try_another_resource;

	     call chase (registry_record.potential_attributes_desc, bp, bl);
	     if (bp -> potential_attributes_based & unspec (temp_atts)) ^= unspec (temp_atts) then
		goto try_another_resource;

/*  Check the access */

	     call setup_kernel_call (proxy_call, addr (req_info), addr (res_info));
	     call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), current_rew, code);

	     if code ^= 0 then
		goto try_another_resource;

	     if action = Reserve then do;
		resource_descriptions.item (rno).name = registry_record.name.string;

		call rcp_reserve_$approve_schedule (resource_desc_ptr, rno, registry_dir, reserver_info_ptr,
		     registry_record.reserver_chain, code);
		if code ^= 0 then
		     goto try_another_resource;
	     end;

	     found = "1"b;				/* got one! */
try_another_resource:
	     code = 0;

	end;

/* Auditing for search by attribute operations is */
/* performed at select time and only for successful */
/* selections.  We call the kernel to do the auditing */
/* since it has the information neeeded to do so. */

	detailed_operation.search = "0"b;
	temp_mode = ""b;
	call rcp_access_kernel_ (operation, addr (req_info), addr (res_info), temp_mode, code);


/* lock the registry record before updating */
	record_status.lock_sw = "1"b;			/* record must be locked for modification	*/
	record_status.locate_sw = "1"b;		/* previous chase altered current_position	*/
	call iox_$control (sw_ptr (swno), "record_status", addr (record_status), code);
	if code ^= 0 then
	     call error_return_in_struc (code);
	record_status.locate_sw = "0"b;		/* clean up structure			*/

     end seek_attr;

register:
     proc ();

	registry_record.free = "1"b;

	registry_record.name.n = length (rtrim (resource_descriptions.item (rno).name));
	registry_record.name.string = resource_descriptions.item (rno).name;

	if ^reconstruct_operation then do;		/* when reconstructing we want to use the old uid */
	     call admin_gate_$make_uid (registry_record.uid);
	     resource_descriptions.item (rno).uid = registry_record.uid;
	end;
	else registry_record.uid = resource_descriptions.item (rno).uid;

	call rcprm_registry_util_$uid_key (resource_descriptions.item (rno).uid, null (), temp_non_var_key);
	temp_key = rtrim (temp_non_var_key);

	call swap_key (record_descrip, "", temp_key, ""); /* Add the key */

	if resource_descriptions.item (rno).given.potential_aim_range then
	     temp_bounds (*) = resource_descriptions.item (rno).potential_aim_range (*);
	else temp_bounds = current_auth ();

/* Here we check to see whether an RCP administrator at a higher level is
   attempting to make a resource "appear" at a lower level.  But we disable
   this check for auto registration; because the only alternative would be
   to take the max of the given lower bound (from the defaults in the RTDT)
   and the user's current authorization-- and this would result in really
   haphazard registration of resources.  Generally, people who are worried
   about AIM security won't be using auto_registration for other reasons. */

	if ^auto_registration then do;
	     call rcp_compute_aim_mode$permissible_aim (temp_bounds, temp_bounds, code);
	     if code ^= 0 then
		call error_return_in_struc (code);
	end;

	call insert_descriptor (registry_record.potential_aim_range_desc, REGISTRY_AIM_RANGE_KEY, addr (temp_bounds),
	     size (temp_bounds) * 4);

     end register;

acquire:
     proc ();
	if resource_descriptions.item (rno).given.owner then
	     temp_owner_name = resource_descriptions.item (rno).owner;
	else if action = Register then
	     temp_owner_name = "free";		/* free */

	temp_key = make_owner_key (temp_owner_name);

	if registry_record.owner_desc = 0 then
	     old_key = "";
	else do;
	     call rcprm_registry_util_$free_key (null (), temp_non_var_key);
	     old_key = rtrim (temp_non_var_key);
	end;

	registry_record.reserver_chain = ""b;
	resource_descriptions.item (rno).rew = current_rew;

	if (action ^= Register) | (resource_descriptions.item (rno).given.owner) then do;
	     if resource_descriptions.item (rno).given.aim_range then
		temp_bounds (*) = resource_descriptions.item (rno).aim_range (*);
	     else temp_bounds (*) = current_auth ();

	     call chase (registry_record.potential_aim_range_desc, bp, bl);
	     if bl = 0 then
		bp = addr (Lowest_Aim_Range);		/* none found, set to lowest */

	     call rcp_compute_aim_mode$permissible_aim (bp -> temp_bounds_based, temp_bounds, code);
	     if code ^= 0 then
		call error_return_in_struc (code);

	     call insert_descriptor (registry_record.aim_range_desc, REGISTRY_AIM_RANGE_KEY, addr (temp_bounds),
		size (temp_bounds) * 4);
	end;

	call swap_key (record_descrip, old_key, temp_key, rtrim (temp_owner_name));
	call swap_descriptor (registry_record.owner_desc, old_key, temp_key, addr (temp_owner_name),
	     length (rtrim (temp_owner_name)));
	registry_record.system = (temp_owner_name = "system");
	registry_record.free = (temp_owner_name = "free");

     end acquire;

set:
     proc ();
	if resource_descriptions.item (rno).given.potential_aim_range then do;
	     temp_bounds (*) = resource_descriptions.item (rno).potential_aim_range (*);
	     if resource_descriptions.item (rno).given.aim_range then
		bp = addr (temp_bounds);		/* don't sweat, a later check will validate this */
	     else do;
		call chase (registry_record.aim_range_desc, bp, bl);
		if bl = 0 then
		     bp = addr (Lowest_Aim_Range);	/* none found, set to lowest */
	     end;

						/* check the new potentials against the currents */

	     call rcp_compute_aim_mode$permissible_aim (temp_bounds, bp -> temp_bounds_based, code);
	     if code ^= 0 then
		call error_return_in_struc (code);

	     call insert_descriptor (registry_record.potential_aim_range_desc, REGISTRY_AIM_RANGE_KEY,
		addr (temp_bounds), size (temp_bounds) * 4);
	end;

	if resource_descriptions.item (rno).given.aim_range then
	     if registry_record.free then		/* free resources don't have set access classes */
		call error_return_in_struc (error_table_$resource_free);
	     else do;
		temp_bounds (*) = resource_descriptions.item (rno).aim_range (*);

		call chase (registry_record.potential_aim_range_desc, bp, bl);
		if bl = 0 then
		     bp = addr (Lowest_Aim_Range);	/* none found, set to lowest */
						/* check the potentials against the new currents */

		call rcp_compute_aim_mode$permissible_aim (bp -> temp_bounds_based, temp_bounds, code);
		if code ^= 0 then
		     call error_return_in_struc (code);

		call insert_descriptor (registry_record.aim_range_desc, REGISTRY_AIM_RANGE_KEY, addr (temp_bounds),
		     size (temp_bounds) * 4);
	     end;

subset:
     entry;
	if (resource_descriptions.item (rno).given.potential_attributes | (action = Register)) then do;
	     temp_atts (*) = ""b;
	     if resource_descriptions.item (rno).given.potential_attributes then
		temp_atts (1) = resource_descriptions.item (rno).potential_attributes;

	     call cv_rcp_attributes_$test_valid (resource_type, temp_atts, validity, code);
	     if code ^= 0 then
		call error_return_in_struc (code);

	     call insert_descriptor (registry_record.potential_attributes_desc, REGISTRY_ATTRIBUTES_KEY,
		addr (temp_atts), size (temp_atts) * 2);/* chars per word, but we only want half of the array */

	     registry_record.attributes (*) = registry_record.attributes (*) & temp_atts (1);
	end;

	if resource_descriptions.item (rno).given.location then
	     call insert_descriptor (registry_record.location_desc, REGISTRY_LOCATION_KEY,
		addr (resource_descriptions.item (rno).location),
		length (rtrim (resource_descriptions.item (rno).location)));

	if resource_descriptions.item (rno).given.charge_type then
	     call insert_descriptor (registry_record.charge_type_desc, REGISTRY_CHARGE_TYPE_KEY,
		addr (resource_descriptions.item (rno).charge_type),
		length (rtrim (resource_descriptions.item (rno).charge_type)));

	if resource_descriptions.item (rno).given.usage_lock then
	     registry_record.usage_lock = resource_descriptions.item (rno).usage_lock;

	if resource_descriptions.item (rno).given.release_lock then
	     registry_record.release_lock = resource_descriptions.item (rno).release_lock;


	if resource_descriptions.item (rno).given.acs_path then do;
	     if registry_record.free then		/* free resource can't have an ACS */
		call error_return_in_struc (error_table_$resource_free);
	     temp_acs_path = resource_descriptions.item (rno).acs_path;
	     if temp_acs_path = "" then
		;				/* wants to have no ACS */
	     else if substr (temp_acs_path, 1, 1) ^= ">" then
		call error_return_in_struc (error_table_$not_abs_path);
	     else do;
		call absolute_pathname_$add_suffix (temp_acs_path, "acs", temp_acs_path, code);
		if code ^= 0 then
		     call error_return_in_struc (code);
	     end;

	     call insert_descriptor (registry_record.acs_path_desc, REGISTRY_ACS_PATH_KEY, addr (temp_acs_path),
		length (rtrim (temp_acs_path)));
	end;

	if resource_descriptions.item (rno).given.comment then
	     call insert_descriptor (registry_record.comment_desc, REGISTRY_COMMENT_KEY,
		addr (resource_descriptions.item (rno).comment),
		length (rtrim (resource_descriptions.item (rno).comment)));

	if resource_descriptions.item (rno).given.user_alloc then
	     registry_record.user_alloc = resource_descriptions.item (rno).user_alloc;

	if resource_descriptions.item (rno).given.desired_attributes & ^seek_attr_flag then do;

	     temp_relatts = resource_descriptions.item (rno).desired_attributes (*);

	     call cv_rcp_attributes_$test_valid (resource_type, temp_atts, validity, code);
	     if code ^= 0 then
		call error_return_in_struc (code);

	     call chase (registry_record.potential_attributes_desc, bp, bl);
	     if (bp -> potential_attributes_based | temp_atts (1)) ^= bp -> potential_attributes_based then
		call error_return_in_struc (error_table_$rcp_attr_not_permitted);
						/* some desired attribute is not a potential attribute */

	     if validity = Absolute then
		registry_record.attributes = temp_atts;

	     else if validity = Relative then do;
		call cv_rcp_attributes_$make_rel (resource_type, (temp_atts), temp_relatts, code);
		if code ^= 0 then
		     call error_return_in_struc (code);

		call cv_rcp_attributes_$modify_rel ((registry_record.attributes), temp_relatts,
		     registry_record.attributes);
	     end;

	     else call error_return_in_struc (error_table_$rcp_bad_attributes);
	end;
     end set;

status:
     proc ();

	if ^resource_descriptions.item (rno).given.name then
	     resource_descriptions.item (rno).name = registry_record.name.string;
	if ^resource_descriptions.item (rno).given.uid then
	     resource_descriptions.item (rno).uid = registry_record.uid;
	resource_descriptions.item (rno).user_alloc = registry_record.flags.user_alloc;
	resource_descriptions.item (rno).release_lock = registry_record.flags.release_lock;
	resource_descriptions.item (rno).usage_lock = registry_record.flags.usage_lock;
	resource_descriptions.item (rno).awaiting_clear = registry_record.flags.awaiting_clear;
	resource_descriptions.item (rno).attributes (1) = registry_record.attributes (1);
	resource_descriptions.item (rno).attributes (2) = registry_record.attributes (2);
	resource_descriptions.item (rno).rew = current_rew;

	call chase (registry_record.location_desc, bp, bl);
	resource_descriptions.item (rno).location = based_charstring;

	call chase (registry_record.comment_desc, bp, bl);
	resource_descriptions.item (rno).comment = based_charstring;

	call chase (registry_record.charge_type_desc, bp, bl);
	resource_descriptions.item (rno).charge_type = based_charstring;

	call chase (registry_record.owner_desc, bp, bl);
	resource_descriptions.item (rno).owner = based_charstring;

	call chase (registry_record.acs_path_desc, bp, bl);
	resource_descriptions.item (rno).acs_path = based_charstring;

	call chase (registry_record.potential_attributes_desc, bp, bl);
	resource_descriptions.item (rno).potential_attributes = based_bits;

	call chase (registry_record.potential_aim_range_desc, bp, bl);
	addr (resource_descriptions.item (rno).potential_aim_range (1)) -> based_bits = based_bits;

	if ^registry_record.free then
	     call chase (registry_record.aim_range_desc, bp, bl);
	addr (resource_descriptions.item (rno).aim_range (1)) -> based_bits = based_bits;
						/* if free, use potential bounds as real bounds, doesn't matter */

     end status;

reserve:
     proc ();

	if seek_attr_flag then do;			/* only do this block if a specific resource was requested */
						/* because we've already done this for "you choose one" requests */

	     call rcp_reserve_$approve_schedule (resource_desc_ptr, rno, registry_dir, reserver_info_ptr,
		registry_record.reserver_chain, code);
	     if code ^= 0 then
		call error_return_in_struc (code);
	end;

/* If this is a system resource, we move this entry to the tail of the system pool with the following call.
   This not only results in allowing us to rotate our stock, but also makes future calls to find available
   resources faster by keeping the most-likely-to-be-available resources at the head of the line. */

	if registry_record.system then
	     call swap_key (record_descrip, (REGISTRY_SYSTEM_KEY), (REGISTRY_SYSTEM_KEY), "system");

     end reserve;

deregister:
     proc ();


/* Perform violent disassembly on this poor record, tearing out of its vitals all record descriptors
   and freeing up (at least one usage of) the records they point to.  Note that although some of the
   descriptors we attempt to free have no business being in a free record, we will second-guess them anyway,
   in case some misguided RCP administrator has unfairly visited various invocations of set_resource upon
   poor, innocent free resources.  In any case, the swap subroutines are sufficiently robust as to know
   whether these descriptors really exist or not. */

	call insert_descriptor (registry_record.potential_aim_range_desc, REGISTRY_AIM_RANGE_KEY, null, 0);
	call insert_descriptor (registry_record.aim_range_desc, REGISTRY_AIM_RANGE_KEY, null, 0);
	call insert_descriptor (registry_record.potential_attributes_desc, REGISTRY_ATTRIBUTES_KEY, null, 0);
	call insert_descriptor (registry_record.acs_path_desc, REGISTRY_ACS_PATH_KEY, null, 0);
	call insert_descriptor (registry_record.location_desc, REGISTRY_LOCATION_KEY, null, 0);
	call insert_descriptor (registry_record.comment_desc, REGISTRY_COMMENT_KEY, null, 0);
	call insert_descriptor (registry_record.charge_type_desc, REGISTRY_CHARGE_TYPE_KEY, null, 0);
	call insert_descriptor (registry_record.owner_desc, REGISTRY_FREE_KEY, null, 0);

	call swap_key (record_descrip, (REGISTRY_FREE_KEY), "", "");

	call rcprm_registry_util_$uid_key (registry_record.uid, null (), temp_non_var_key);
	temp_key = rtrim (temp_non_var_key);

	call swap_key (record_descrip, temp_key, "", "");

	call rcprm_registry_util_$name_key (registry_record.name.string, null (), temp_non_var_key);
	temp_key = rtrim (temp_non_var_key);

	call iox_$seek_key (sw_ptr (swno), temp_key, 0, code);
	if code ^= 0 then
	     call error_return_in_struc (code);

	call iox_$delete_record (sw_ptr (swno), code);
	if code ^= 0 then
	     call error_return_in_struc (code);

     end deregister;

release:
     proc (ok);

dcl	ok		   bit (1);
	ok = "1"b;

	call resource_info_$lock_on_release (resource_type, lock_sw, code);
	if lock_sw then do;
	     registry_record.awaiting_clear = "1"b;
	     registry_record.usage_lock = "1"b;
	     resource_descriptions.item (rno).usage_lock = "1"b;
	     resource_descriptions.item (rno).awaiting_clear = "1"b;
	     ok = "0"b;
	end;
	if code ^= 0 then
	     call error_return_in_struc (code);

     end release;

clear:
     proc ();

/* We know the user has rew access, because this was called from Release,
   which checks it, or he made a privileged call to get here. */

	if priv_sw then do;				/* Clear or privileged Release */
	     call chase (registry_record.owner_desc, bp, bl);
	     temp_key = make_owner_key ((based_charstring));
	end;

	else temp_key = make_owner_key (temp_owner_name);

	registry_record.usage_lock = ""b;
	registry_record.awaiting_clear = ""b;

	temp_owner_name = "free";
	call swap_descriptor (registry_record.owner_desc, temp_key, REGISTRY_FREE_KEY, addr (temp_owner_name),
	     length ("free"));

	call swap_key (record_descrip, temp_key, (REGISTRY_FREE_KEY), "free");

	call insert_descriptor (registry_record.comment_desc, REGISTRY_COMMENT_KEY, null, 0);
	call insert_descriptor (registry_record.acs_path_desc, REGISTRY_ACS_PATH_KEY, null, 0);
	call insert_descriptor (registry_record.aim_range_desc, REGISTRY_AIM_RANGE_KEY, null, 0);

	registry_record.free = "1"b;
	registry_record.system = ""b;

/* "Degauss" the registry to prevent information passdown on a secure system;
   also leaves the registry clean for the next guy in general. */

	registry_record.flags.user_alloc = ""b;
	registry_record.attributes (2) = ""b;		/* deprotect all attributes */

	call chase (registry_record.potential_attributes_desc, bp, bl);
	temp_atts (1) = based_bits;

	call resource_info_$set_arbitrary_attributes (resource_type, temp_atts (1), registry_record.attributes, code);
	if code ^= 0 then
	     call error_return_in_struc (code);

     end clear;

cancel:
     proc ();

	call rcp_cancel_id_$remove_schedule (resource_desc_ptr, rno, registry_dir, reserver_info_ptr,
	     registry_record.reserver_chain, code);
	if code ^= 0 then
	     call error_return_in_struc (code);

/* If this is a "scratch"  or "system" resource, "degauss" the registry record so that
   no information may be passed to a lower authorization via this path. */

	if registry_record.system then do;
	     registry_record.flags.user_alloc = ""b;

	     call chase (registry_record.potential_attributes_desc, bp, bl);
	     temp_atts (1) = based_bits;

	     call resource_info_$set_arbitrary_attributes (resource_type, temp_atts (1), registry_record.attributes,
		code);
	     if code ^= 0 then
		call error_return_in_struc (code);
	end;

     end cancel;

process_end:
     proc ();

	if (action ^= Status) then
	     do swno = 1 to switch_struc.usedno;
	     call iox_$control (sw_ptr (swno), "commit", null, code);
	     if code ^= 0 then do;
		if swno > 1 then
		     call admin_gate_$syserr_error_code (BEEP, code,
			"RCP: Registries may be in an inconsistent state.");
		call error_return (code);
	     end;
	end;

	if action = Release then
	     do rno = 1 to resource_descriptions.n_items;
	     if resource_descriptions.item (rno).awaiting_clear then
		call admin_gate_$syserr (BEEP, "RCP: Schedule ^a ^a for manual clearing.",
		     resource_descriptions.item (rno).type, resource_descriptions.item (rno).name);
	end;

	else if action = Clear then
	     do rno = 1 to resource_descriptions.n_items;
	     call admin_gate_$syserr (ANNOUNCE, "RCP: ^[Operator^s^;^a^] certified manual clearing of ^a ^a.",
		(my_group_id = "Initializer.SysDaemon.z"), my_group_id, resource_descriptions.item (rno).type,
		resource_descriptions.item (rno).name);
	end;

/* Journalize all successful operations that changed registry information */

	if action ^= Status & action ^= Reserve & action ^= Cancel & ^reconstruct_operation then
						/* certainly don't want to journalize those! */
	     call rcprm_journalize_ (resource_desc_ptr, action, transaction_time, registry_dir);

	call put_resource_descriptions;
	call clean_up (code, "1"b);
	if code ^= 0 then
	     call error_return (code);

     end process_end;

/**** Routines to copy the resource descriptions from the caller's space, and back again.  get_* allocates the storage
      in system_area.  These must (obviously) be called in the correct order. ****/

get_resource_descriptions:
     proc;

dcl	based_bits	   (wordcount) bit (36) aligned based;
dcl	wordcount		   fixed bin (19);

	callers_rdp = p_resource_desc_ptr;		/* this is remembered for put... */
	Resource_count = callers_rdp -> resource_descriptions.n_items;
	allocate resource_descriptions in (sys_area) set (resource_desc_ptr);
	wordcount = size (resource_descriptions);
	resource_desc_ptr -> based_bits = callers_rdp -> based_bits;
	resource_descriptions.n_items = Resource_count;	/* prevent caller "cleverness" */
	return;

put_resource_descriptions:
     entry;

	wordcount = size (resource_descriptions);
	callers_rdp -> based_bits = resource_desc_ptr -> based_bits;
	return;

     end get_resource_descriptions;
%page;
setup_kernel_call:
     proc (a_proxy_call, a_requestor_info_ptr, a_resource_info_ptr);

dcl	a_proxy_call	   bit (1) aligned;
dcl	a_requestor_info_ptr   ptr;
dcl	a_resource_info_ptr	   ptr;

	if a_proxy_call then do;
	     a_requestor_info_ptr -> requestor_info.user_id = proxy_group_id;
	     a_requestor_info_ptr -> requestor_info.current_authorization = proxy_authorization;
	end;
	else do;
	     a_requestor_info_ptr -> requestor_info.user_id = get_group_id_ ();
	     call hcs_$get_authorization (a_requestor_info_ptr -> requestor_info.current_authorization, (""b));
						/*	     a_requestor_info_ptr -> requestor_info.current_authorization = get_authorization_ ();  */
	end;
	a_requestor_info_ptr -> requestor_info.validation_level = prev_level;
	a_resource_info_ptr -> resource_info.registry_dir = registry_dir;
	a_resource_info_ptr -> resource_info.registry_switch_ptr = sw_ptr (swno);
	a_resource_info_ptr -> resource_info.registry_record_ptr = record_ptr;
	a_resource_info_ptr -> resource_info.resource_type = resource_type;
	if action = Register then
	     a_resource_info_ptr -> resource_info.resource_name = resource_descriptions.item (rno).name;
	else a_resource_info_ptr -> resource_info.resource_name = registry_record.name.string;
	return;
     end setup_kernel_call;
%page;
simple_checks:
     proc ();

	if registry_record.awaiting_clear & action ^= Clear & action ^= Status then
	     code = error_table_$resource_awaiting_clear;

	if ^registry_record.awaiting_clear & action = Clear then
	     code = error_table_$resource_not_free;
	if registry_record.usage_lock & ^registry_record.awaiting_clear & ^priv_sw then
	     code = error_table_$resource_locked;
	if ^registry_record.free & action = Acquire then
	     code = error_table_$resource_not_free;
	if action = Reserve then
	     if registry_record.user_alloc then
		code = error_table_$resource_locked;
	if action = Release & (registry_record.release_lock & ^priv_sw) then
	     code = error_table_$not_privileged;
	if action = Release & registry_record.free then
	     code = error_table_$resource_free;
	if action = Deregister & ^registry_record.free then
	     code = error_table_$resource_not_free;
	return;
     end simple_checks;
%page;
audit:
     proc (a_code);

dcl	a_code		   fixed bin (35);
dcl	save_code		   fixed bin (35);
dcl	based_charstring	   char (bl) aligned based (bp);
dcl	bl		   fixed bin (21);
dcl	bp		   ptr;
dcl	current_owner	   char (32);
dcl	path		   char (168);
dcl	raw_mode		   bit (3);
dcl	rcp_rbs		   (2) fixed bin (3);
dcl	local_code	   fixed bin (35);
dcl	1 auto_event_flags	   like audit_event_flags aligned;
dcl	reg_name		   char (32);
dcl	suffixed_name_$make	   entry (char (*), char (*), char (32), fixed bin (35));
dcl	pathname_		   entry (char (*), char (*)) returns (char (168));
dcl	access_audit_r1_$log_obj_path
			   entry options (variable);	/*  Copy args and initialize local variables. */

	save_code = a_code;
	local_code = 0;
	rcp_rbs = 0;
	rcp_rbs (1) = -1;
	raw_mode = ""b;

/* If this is an audit of failure, most operations are audited in the kernel */
/* with the exception of registers and acquires which are audited here.  */
/* Operations which fail before an object is found, particularly in the */
/* case of an error_table_$namedup, are audited here. */

	if save_code ^= 0 then			/* It failed. */
	     if action ^= Acquire & action ^= Register then
						/* Audit these always. */
		if audit_obj_ok then		/* We have an object - already audited. */
		     return;

/* If we don't have an object to audit, this is a failure.  Except in */
/* the case of a Register or Acquire.  In the case of a Register we never */
/* had an object to audit prior to this operation, so we audit the operation */
/* on the registry. */

	if ^audit_obj_ok | action = Register then do;
	     call suffixed_name_$make ((resource_type), "rcpr", reg_name, local_code);
	     path = pathname_ ((registry_dir), reg_name);
	     unspec (detailed_operation) = "0"b;
	     unspec (auto_event_flags) = ""b;
	     auto_event_flags.grant = (save_code = 0);
	     auto_event_flags.priv_op = priv_sw;
	     call access_audit_r1_$log_obj_path ("rcprm_find_resource_", prev_level, unspec (auto_event_flags),
		operation, path, save_code, null (), 0);
	end;

	else do;

/* We have an object to audit. Get the object owner prior to */
/* this operation. If it's an acquire operation the previous owner is */
/* always "free". */

	     if action = Acquire then
		current_owner = "free";
	     else do;
		call chase (registry_record.owner_desc, bp, bl);
		if bl = 0 then
		     current_owner = "free";
		else current_owner = based_charstring;
	     end;

/* This is a failure audit. */

	     if save_code ^= 0 then do;
		call setup_kernel_call (proxy_call, addr (req_info), addr (res_info));
		call rcp_audit (who_am_i, operation, addr (req_info), addr (res_info), current_owner, ("000"b),
		     raw_mode, rcp_rbs, ("1"b), (save_code));
	     end;

/* This is a success. */

	     else call rcp_audit (who_am_i, operation, addr (req_info), addr (res_info), current_owner, (current_rew),
		     raw_mode, rcp_rbs, ("1"b), (save_code));
	end;
	a_code = save_code;
	return;
     end audit;
%page;
%include access_mode_values;
%page;
%include access_audit_encoded_op;
%page;
%include access_audit_eventflags;
%page;
%include resource_control_desc;
%page;
%include rcp_ops;
%page;
%include rcp_registry;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_info;
%page;
%include rcprm_action_codes;
%page;
%include iox_dcls;
%page;
%include iox_modes;
%page;
%include rs_info;
%page;
%include ak_info;
%page;
%include rcprm_registry_keys;
%page;
%include aim_template;
%page;
%include syserr_constants;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Registries may be in an inconsistent state. ERROR_CODE

   S: $beep

   T: $run

   M: An RCP Resource Management transaction was not properly committed to the
   registries. $err

   A: $contact


   Message:
   RCP: Schedule VOLUME for manual clearing.

   S: $beep

   T: $run

   M: The data contained on VOLUME is to be destroyed by the operator via
   degaussing or other site-mandated method.

   A: The operator must erase the specified resource, and must acknowledge
   when this has been done by issuing the clear_resource command or the
   appropriate site-defined "x" Initializer request.


   Message:
   RCP: Operator certified manual clearing of VOLUME.
   RCP: USERID certified manual clearing of VOLUME.

   S: $info

   T: In response to an operator or administrator command.

   M: This message is printed for auditing purposes when site-madated
   destruction of data is accomplished.

   A: $ignore

   END MESSAGE DOCUMENTATION */

     end rcprm_find_resource_;




		    rcprm_journal_file_.pl1         11/11/89  1111.8r w 11/11/89  0806.0      147474



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcprm_journal_file_:
rcprm_journal_file_attach:
     proc (p_iocb_ptr, p_options_array, p_com_err_sw, p_code);

/* This I/O module uses vfile_ to manage an indexed file.  All calls which
   might result in a modification of the file are either journalized or
   disallowed, depending on the call.  The journal is used for both committing
   and rolling back the file.

   This module is a special hack for RCP, so it can roll back changes to a
   vfile_.

   Written  by Lindsey Spratt  08/02/79
   Modified 08/79 by C. D. Tavares to fix faults in commit/rollback if switch not open
   Modified 04/83 by B. Braun to correct a problem of RQO in process_dir (phx11736 phx14452)
   Modified 02/85 by Chris Jones to use privileges and to clean up better.
*/
/* Parameter */

dcl	p_actual_len	   fixed bin (21);
dcl	p_not_used	   bit (1) aligned;
dcl	p_buffer_len	   fixed bin (21);
dcl	p_buffer_ptr	   ptr;
dcl	p_info_ptr	   ptr;
dcl	p_key		   char (256) varying;
dcl	p_len		   fixed bin (21);
dcl	p_open_mode	   fixed bin;
dcl	p_pos_type	   fixed bin;
dcl	p_skip		   fixed bin (21);
dcl	p_com_err_sw	   bit (1);
dcl	p_order		   char (*);
dcl	p_code		   fixed bin (35);
dcl	p_options_array	   (*) char (*) varying;
dcl	p_iocb_ptr	   ptr;

/* Automatic */

dcl	area_ptr		   ptr;
dcl	attach_idx	   fixed bin;
dcl	attach_description	   char (256) varying;
dcl	cleanup_jcb_ptr	   ptr;
dcl	display_temp_str	   char (4096) varying;
dcl	1 my_area_info	   like area_info aligned;
dcl	option_idx	   fixed bin;
dcl	privileges_string	   bit (36) aligned;

/* Based */

dcl	area		   area (4096) based (area_ptr);

/* Builtin */

dcl	addr		   builtin;
dcl	bin		   builtin;
dcl	bit		   builtin;
dcl	codeptr		   builtin;
dcl	hbound		   builtin;
dcl	length		   builtin;
dcl	null		   builtin;
dcl	substr		   builtin;

dcl	cleanup		   condition;

/* Constant */

dcl	myname		   char (19) init ("rcprm_journal_file_") options (constant) internal static;

/* Controlled */
/* Entry */

dcl	add_key		   entry (ptr, ptr, fixed bin (35));
dcl	delete_key	   entry (ptr, ptr, fixed bin (35));
dcl	record_status	   entry (ptr, ptr, fixed bin (35));
dcl	rollback		   entry (ptr, fixed bin (35));
dcl	write_record	   entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl	print_data	   entry (char (*) var, ptr, fixed bin (35));
dcl	define_area_	   entry (ptr, fixed bin (35));
dcl	release_area_	   entry (ptr);
dcl	unique_chars_	   entry (bit (*)) returns (char (15));
dcl	com_err_		   entry options (variable);
dcl	commit		   entry (ptr, fixed bin (35));
dcl	delete_record	   entry (ptr, fixed bin (35));
dcl	get_system_free_area_  entry returns (ptr);
dcl	rcprm_registry_util_$turn_off_privs
			   entry (bit (36) aligned);
dcl	rcprm_registry_util_$turn_on_privs
			   entry (bit (36) aligned);

/* External */

dcl	error_table_$argerr	   fixed bin (35) ext;
dcl	error_table_$no_operation
			   fixed bin (35) ext;
dcl	error_table_$locked_by_this_process
			   fixed bin (35) ext;

	if hbound (p_options_array, 1) < 1 then do;
	     if p_com_err_sw then
		call com_err_ (error_table_$argerr, myname, "no file name specified.");
	     p_code = error_table_$argerr;
	     return;
	end;
	attach_description = "vfile_";
	do option_idx = 1 to hbound (p_options_array, 1);
	     attach_description = attach_description || " " || p_options_array (option_idx);
	end;

	area_ptr = get_system_free_area_ ();

	call init_for_clean_up;
	on cleanup call clean_up;

	alloc journal_control_block in (area) set (cleanup_jcb_ptr);
	journal_control_block_ptr = cleanup_jcb_ptr;

	call iox_$attach_name (unique_chars_ ("0"b) || ".jf", journal_control_block.vfile_iocb_ptr,
	     (attach_description), codeptr (rcprm_journal_file_), p_code);
	if p_code ^= 0 then do;
	     if p_com_err_sw then
		call com_err_ (p_code, myname, "can not attach ^a.", attach_description);
	     call clean_up;
	     return;
	end;

	my_area_info.version = 1;
	my_area_info.extend = "1"b;
	my_area_info.no_freeing = "1"b;
	my_area_info.dont_free = "1"b;
	my_area_info.owner = myname;
	my_area_info.areap = null;
	my_area_info.size = sys_info$max_seg_size;
	call define_area_ (addr (my_area_info), p_code);
	if p_code ^= 0 then do;
	     if p_com_err_sw then
		call com_err_ (p_code, myname, "Could not get area for journal.");
	     call clean_up;
	     return;
	end;
	journal_control_block.journal_area_ptr = my_area_info.areap;
	cleanup_jcb_ptr = null ();
	p_iocb_ptr -> iocb.attach_descrip_ptr = addr (journal_control_block.attach);
	p_iocb_ptr -> iocb.attach_data_ptr = journal_control_block_ptr;
	p_iocb_ptr -> iocb.actual_iocb_ptr = p_iocb_ptr;
	p_iocb_ptr -> iocb.open_descrip_ptr = null;
	p_iocb_ptr -> iocb.open_data_ptr = null;

	journal_control_block.attach = myname;
	do attach_idx = 1 to hbound (p_options_array, 1);
	     journal_control_block.attach = journal_control_block.attach || " ";
	     journal_control_block.attach = journal_control_block.attach || p_options_array (attach_idx);
	end;

	p_iocb_ptr -> iocb.get_line = iox_$err_no_operation;
	p_iocb_ptr -> iocb.get_chars = iox_$err_no_operation;
	p_iocb_ptr -> iocb.put_chars = iox_$err_no_operation;
	p_iocb_ptr -> iocb.modes = iox_$err_no_operation;
	p_iocb_ptr -> iocb.rewrite_record = iox_$err_no_operation;

	p_iocb_ptr -> iocb.detach_iocb = rcprm_journal_file_detach_iocb;
	p_iocb_ptr -> iocb.open = rcprm_journal_file_open;
	p_iocb_ptr -> iocb.close = iox_$err_not_open;
	p_iocb_ptr -> iocb.control = rcprm_journal_file_control;
	p_iocb_ptr -> iocb.seek_key = rcprm_journal_file_seek_key;
	p_iocb_ptr -> iocb.write_record = rcprm_journal_file_write_record;
	p_iocb_ptr -> iocb.read_record = rcprm_journal_file_read_record;
	p_iocb_ptr -> iocb.delete_record = rcprm_journal_file_delete_record;
	p_iocb_ptr -> iocb.read_key = rcprm_journal_file_read_key;
	p_iocb_ptr -> iocb.read_length = rcprm_journal_file_read_length;
	p_iocb_ptr -> iocb.position = rcprm_journal_file_position;

	journal_control_block.latest_entry_ptr = null;
	p_code = 0;
	return;

rcprm_journal_file_control:
     entry (p_iocb_ptr, p_order, p_info_ptr, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.open_data_ptr;
	call init_for_clean_up;
	on cleanup call clean_up;

	call rcprm_registry_util_$turn_on_privs (privileges_string);
	if p_order = "io_call" then do;
	     io_call_infop = p_info_ptr;
	     if io_call_info.order_name = "commit" | io_call_info.order_name = "rollback" then do;
		p_code = error_table_$no_operation;
		return;
	     end;
	     else if io_call_info.order_name = "record_status" | io_call_info.order_name = "rs" then do;
		area_ptr = get_system_free_area_ ();

		alloc rs_info in (area);
		rs_info.version = rs_info_version_2;
		if nargs ^= 0 then do;
		     rs_info.lock_sw = bit (substr (io_call_info.args (1), 1, 1), 1);
		     rs_info.unlock_sw = bit (substr (io_call_info.args (1), 2, 1), 1);
		     rs_info.create_sw = bit (substr (io_call_info.args (1), 3, 1), 1);
		     rs_info.locate_sw = bit (substr (io_call_info.args (1), 4, 1), 1);
		     rs_info.inc_ref_count = bit (substr (io_call_info.args (1), 5, 1), 1);
		     rs_info.dec_ref_count = bit (substr (io_call_info.args (1), 6, 1), 1);
		     rs_info.locate_pos_sw = bit (substr (io_call_info.args (1), 7, 1), 1);
		end;
		if nargs = 2 then
		     rs_info.descriptor = bin (io_call_info.args (2), 35);
		call record_status (journal_control_block_ptr, rs_info_ptr, p_code);

		put string (display_temp_str) data (rs_info);
		alloc print_data_info in (area);
		print_data_info.version = print_data_info_version_1;
		print_data_info.indentation = 1;
		print_data_info.value_column = 40;
		print_data_info.output_switch = null;
		print_data_info.octal = "0"b;
		print_data_info.intervals = "";
		call print_data (display_temp_str, print_data_info_ptr, p_code);
	     end;
	     else if io_call_info.order_name = "add_key" | io_call_info.order_name = "ak" then do;
		area_ptr = get_system_free_area_ ();
		ak_key_len = 256;
		alloc ak_info in (area);
		ak_info.input_key = bit (substr (io_call_info.args (1), 1, 1), 1);
		ak_info.input_desc = bit (substr (io_call_info.args (1), 2, 1), 1);
		if ak_info.input_key then do;
		     ak_info.key_len = length (io_call_info.args (2));
		     ak_info.key = io_call_info.args (2);
		     if ak_info.input_desc then
			ak_info.descrip = bin (io_call_info.args (3), 35);
		end;
		else if ak_info.input_desc then
		     ak_info.descrip = bin (io_call_info.args (2), 35);
		call add_key (journal_control_block_ptr, ak_info_ptr, p_code);
		if ak_info_ptr ^= null then
		     ak_info.key_len = ak_key_len;

	     end;
	     else if io_call_info.order_name = "delete_key" | io_call_info.order_name = "dk" then do;
		if nargs = 0 then
		     ak_info_ptr = null;
		else do;
		     area_ptr = get_system_free_area_ ();
		     ak_key_len = 256;
		     alloc ak_info in (area);
		     ak_info.input_key = bit (substr (io_call_info.args (1), 1, 1), 1);
		     ak_info.input_desc = bit (substr (io_call_info.args (1), 2, 1), 1);
		     if ak_info.input_key then do;
			ak_info.key_len = length (io_call_info.args (2));
			ak_info.key = io_call_info.args (2);
			if ak_info.input_desc then
			     ak_info.descrip = bin (io_call_info.args (3), 35);
		     end;
		     else if ak_info.input_desc then
			ak_info.descrip = bin (io_call_info.args (2), 35);
		end;
		call delete_key (journal_control_block_ptr, ak_info_ptr, p_code);
		if ak_info_ptr ^= null then
		     ak_info.key_len = ak_key_len;
	     end;
	     else call iox_$control (journal_control_block.vfile_iocb_ptr, "io_call", io_call_infop, p_code);
	end;
	else if p_order = "record_status" | p_order = "rs" then
	     call record_status (journal_control_block_ptr, p_info_ptr, p_code);
	else if p_order = "add_key" | p_order = "ak" then
	     call add_key (journal_control_block_ptr, p_info_ptr, p_code);
	else if p_order = "delete_key" | p_order = "dk" then
	     call delete_key (journal_control_block_ptr, p_info_ptr, p_code);
	else if p_order = "get_key" | p_order = "gk" then
	     call iox_$control (journal_control_block.vfile_iocb_ptr, p_order, p_info_ptr, p_code);
	else if p_order = "seek_head" | p_order = "sh" then
	     call iox_$control (journal_control_block.vfile_iocb_ptr, p_order, p_info_ptr, p_code);
	else if p_order = "rollback" then
	     if p_iocb_ptr -> iocb.open_data_ptr ^= null	/* switch is open */
		then
		call rollback (journal_control_block_ptr, p_code);
	     else p_code = 0;
	else if p_order = "commit" then
	     if p_iocb_ptr -> iocb.open_data_ptr ^= null	/* switch is open */
		then
		call commit (journal_control_block_ptr, p_code);
	     else p_code = 0;
	else p_code = error_table_$argerr;
	if p_code = error_table_$locked_by_this_process then
	     p_code = 0;
	call clean_up;
	return;

rcprm_journal_file_write_record:
     entry (p_iocb_ptr, p_buffer_ptr, p_buffer_len, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call write_record (journal_control_block_ptr, p_buffer_ptr, p_buffer_len, p_code);
	if p_code = error_table_$locked_by_this_process then
	     p_code = 0;
	return;


rcprm_journal_file_delete_record:
     entry (p_iocb_ptr, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call delete_record (journal_control_block_ptr, p_code);
	if p_code = error_table_$locked_by_this_process then
	     p_code = 0;
	return;


rcprm_journal_file_seek_key:
     entry (p_iocb_ptr, p_key, p_len, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call iox_$seek_key (journal_control_block.vfile_iocb_ptr, p_key, p_len, p_code);
	if p_code = error_table_$locked_by_this_process then
	     p_code = 0;
	return;


rcprm_journal_file_read_record:
     entry (p_iocb_ptr, p_buffer_ptr, p_buffer_len, p_actual_len, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call iox_$read_record (journal_control_block.vfile_iocb_ptr, p_buffer_ptr, p_buffer_len, p_actual_len, p_code);
	if p_code = error_table_$locked_by_this_process then
	     p_code = 0;
	return;


rcprm_journal_file_read_length:
     entry (p_iocb_ptr, p_len, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call iox_$read_length (journal_control_block.vfile_iocb_ptr, p_len, p_code);
	if p_code = error_table_$locked_by_this_process then
	     p_code = 0;
	return;


rcprm_journal_file_read_key:
     entry (p_iocb_ptr, p_key, p_len, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call iox_$read_key (journal_control_block.vfile_iocb_ptr, p_key, p_len, p_code);
	if p_code = error_table_$locked_by_this_process then
	     p_code = 0;
	return;


rcprm_journal_file_close:
     entry (p_iocb_ptr, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call iox_$close (journal_control_block.vfile_iocb_ptr, p_code);
	if p_code = 0 | p_code = error_table_$locked_by_this_process then do;
	     p_iocb_ptr -> iocb.close = iox_$err_not_open;
	     p_iocb_ptr -> iocb.detach_iocb = rcprm_journal_file_detach_iocb;
	     p_iocb_ptr -> iocb.open_data_ptr = null;
	     p_iocb_ptr -> iocb.open_descrip_ptr = null;
	     p_code = 0;
	end;
	return;


rcprm_journal_file_detach_iocb:
     entry (p_iocb_ptr, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call iox_$detach_iocb (journal_control_block.vfile_iocb_ptr, p_code);
	if p_code = 0 | p_code = error_table_$locked_by_this_process then do;
	     call iox_$destroy_iocb (journal_control_block.vfile_iocb_ptr, (0));
	     p_code = 0;
	     call release_area_ (journal_control_block.journal_area_ptr);
	     area_ptr = get_system_free_area_ ();
	     free journal_control_block;
	     p_iocb_ptr -> iocb.attach_data_ptr = null;
	     p_iocb_ptr -> iocb.attach_descrip_ptr = null;
	     p_iocb_ptr -> iocb.open = iox_$err_not_attached;
	     p_iocb_ptr -> iocb.detach_iocb = iox_$err_not_attached;
	end;
	return;


rcprm_journal_file_position:
     entry (p_iocb_ptr, p_pos_type, p_skip, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call iox_$position (journal_control_block.vfile_iocb_ptr, p_pos_type, p_skip, p_code);
	if p_code = error_table_$locked_by_this_process then
	     p_code = 0;
	return;


rcprm_journal_file_open:
     entry (p_iocb_ptr, p_open_mode, p_not_used, p_code);

	journal_control_block_ptr = p_iocb_ptr -> iocb.attach_data_ptr;
	call iox_$open (journal_control_block.vfile_iocb_ptr, p_open_mode, p_not_used, p_code);
	if p_code = 0 | p_code = error_table_$locked_by_this_process then do;
	     p_code = 0;
	     p_iocb_ptr -> iocb.close = rcprm_journal_file_close;
	     p_iocb_ptr -> iocb.detach_iocb = iox_$err_not_closed;
	     p_iocb_ptr -> iocb.open_data_ptr = journal_control_block_ptr;
	     journal_control_block.open_desc = iox_modes (p_open_mode);
	     p_iocb_ptr -> iocb.open_descrip_ptr = addr (journal_control_block.open_desc);
	end;
	return;

init_for_clean_up:
     proc;

	cleanup_jcb_ptr, rs_info_ptr, print_data_info_ptr, ak_info_ptr = null ();
	privileges_string = ""b;

     end init_for_clean_up;

clean_up:
     proc;

	if cleanup_jcb_ptr ^= null () then
	     free cleanup_jcb_ptr -> journal_control_block;
	if rs_info_ptr ^= null () then
	     free rs_info;
	if print_data_info_ptr ^= null () then
	     free print_data_info;
	if ak_info_ptr ^= null () then
	     free ak_info;
	call rcprm_registry_util_$turn_off_privs (privileges_string);

     end clean_up;

%include journal_control_block;
%page;
%include iocb;
%page;
%include iox_dcls;
%page;
%include iox_modes;
%page;
%include io_call_info;
%page;
%include area_info;
%page;
%include rs_info;
%page;
%include ak_info;
%page;
%include print_data_info;

     end rcprm_journal_file_;




		    rcprm_journalize_.pl1           10/27/92  1455.6rew 10/27/92  1453.8      260064



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




/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
  2) change(92-09-23,Zimmerman), approve(92-09-23,MCR8267),
     audit(92-10-26,Schroth), install(92-10-27,MR12.5-1041):
     Fix journal list traversal problems encountered when date deleting
     journals. (phx18654)
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcprm_journalize_:
     proc (arg_resource_desc_ptr, arg_action, arg_clock_time, arg_system_dir);

/* This routine manages the RCPRM journal-- a backup mechanism that allows one
   to recover clobbered registries given a good (manually-requested) checkpoint
   copy of the registries, and the journal (that this module manages, ahem)
   which describes every operation which occurred since the checkpoint. */

/* Written 01/08/79 by C. D. Tavares */
/* Modified 11/21/79 by CDT to fix several bugs and add a recovery strategy to
   allow reconstruction to continue after errors. */
/* Modified 7/13/82 by BLB to ignore action_not_performed error from
   admin_gate_$reclassify_sys_seg */
/* Modified 1984-11-02 BIM to recover from missing obsolete journals. */
/* Modified 1984-12-27 by Keith Loepere for version 2 create_branch_info. */
/* Modified 1985-02-15 by Chris Jones to use privileges when creating journals,
   to use rcprm_registry_util_, and for better clean up. */

dcl	arg_resource_desc_ptr  pointer parameter;
dcl	arg_action	   fixed bin parameter;
dcl	arg_clock_time	   fixed bin (71) parameter;
dcl	arg_system_dir	   char (*) parameter;

/* automatic */

dcl	auto_code		   fixed bin (35);
dcl	clock_time	   fixed bin (71);
dcl	n_doublewords	   fixed bin;
dcl	journal_dir	   char (168);
dcl	prev_time		   fixed bin (71);
dcl	privileges_string	   bit (36) aligned;
dcl	system_dir	   char (168) automatic;

declare  current_journal_name	  char (32);
declare  missing_journal	  bit (1) aligned;

/* static */

dcl	max_seg_size	   fixed bin static initial (0);

dcl	1 force_flags	   like force_write_flags aligned static;

dcl	DEFAULT_JOURNAL_NAME   char (13) static options (constant) init ("rcprm.journal");

/* external static */

dcl	(
	sys_info$max_seg_size,
	error_table_$no_record,
	error_table_$recoverable_error,
	error_table_$not_seg_type,
	error_table_$action_not_performed,
	error_table_$noentry
	)		   ext fixed bin (35) static;

/* entries */

dcl	(
	admin_gate_$syserr_error_code,
	admin_gate_$syserr
	)		   ext entry options (variable);
dcl	admin_gate_$reclassify_sys_seg
			   ext entry (char (*), char (*), bit (72) aligned, fixed bin (35));
dcl	get_group_id_	   entry returns (char (32));
dcl	get_max_authorization_ ext entry returns (bit (72) aligned);
dcl	get_ring_		   entry returns (fixed bin);
dcl	hcs_$chname_file	   entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl	hcs_$chname_seg	   entry (ptr, char (*), char (*), fixed bin (35));
dcl	hcs_$create_branch_	   entry (char (*), char (*), pointer, fixed bin (35));
dcl	hcs_$force_write	   ext entry (pointer, pointer, fixed bin (35));
dcl	initiate_file_	   entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl	ioa_$rsnnl	   entry options (variable);
dcl	pathname_		   entry (char (*), char (*)) returns (char (168));
dcl	rcprm_registry_util_$grab_registry
			   entry (ptr, char (*), char (*), fixed bin (35));
dcl	rcprm_registry_util_$grab_transaction_control_file
			   entry (ptr, char (*), fixed bin (35));
dcl	rcprm_registry_util_$release_registry
			   entry (ptr, fixed bin (35));
dcl	rcprm_registry_util_$release_transaction_control_file
			   entry (ptr, fixed bin (35));
dcl	rcprm_registry_util_$turn_off_privs
			   entry (bit (36) aligned);
dcl	rcprm_registry_util_$turn_on_privs
			   entry (bit (36) aligned);
dcl	terminate_file_	   entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl	unique_chars_	   entry (bit (*)) returns (char (15));

dcl	sys_info$access_class_ceiling
			   bit (72) aligned ext static;

/* based */

dcl	based_words	   (n_doublewords) fixed bin (71) aligned based;

/* builtins and conditions */

dcl	(addr, addrel, binary, currentsize, divide, hbound, null, pointer, rel, rtrim, unspec)
			   builtin;

dcl	cleanup		   condition;

	tsw_attach_ptr, journalp, switch_ptr = null ();
	resource_desc_ptr = arg_resource_desc_ptr;
	clock_time = arg_clock_time;
	system_dir = arg_system_dir;
	rcp_priv_was_on = 1;
	call cu_$level_get (prev_level);
	on cleanup call clean_up ("0"b, (0));

	call journalize (auto_code);
	if auto_code ^= 0 then
	     call admin_gate_$syserr_error_code (BEEP, auto_code, "RCP: Journal lost transaction for ^a.",
		get_group_id_ ());

	return;

journalize:
     proc (code);

dcl	code		   fixed bin (35) parameter;

	call find_journal ("1"b, code);
	if code ^= 0 then
	     return;

	n_doublewords = divide (currentsize (resource_desc_ptr -> resource_descriptions) + 1, 2, 35, 0);
	if journal.next_free_word + (n_doublewords * 2) > max_seg_size then do;
	     call make_new_journal (code);
	     if code ^= 0 then
		return;
	end;

	je_ptr = pointer (journalp, journal.next_free_word);

	journal_entry.clock_time = clock_time;
	journal_entry.n_doublewords = n_doublewords;
	journal_entry.action = arg_action;
	journal_entry.j_resource_desc = resource_desc_ptr -> based_words;

	journal.next_free_word = journal.next_free_word + currentsize (journal_entry);
	journal.own_last_transaction_time = clock_time;

	call hcs_$force_write (journalp, addr (force_flags), code);
	if code ^= 0 then do;
	     call admin_gate_$syserr_error_code (LOG, code, "RCP: Journal could not be forcibly written.");
	     code = 0;
	end;

	call terminate_file_ (journalp, (0), TERM_FILE_TERM, (0));
	return;

     end journalize;
%skip (4);
find_journal:
     proc (create_sw, code);

dcl	create_sw		   bit (1) aligned parameter;
dcl	code		   fixed bin (35) parameter;

	if max_seg_size = 0 then do;			/* initialize constants */
	     max_seg_size = sys_info$max_seg_size;
	     unspec (force_flags) = ""b;
	     force_flags.priority_write,		/* anything we can get away with */
		force_flags.lru_or_mru = "1"b;	/* MRU */
	end;

	journal_dir = pathname_ (system_dir, "journals");
	current_journal_name = DEFAULT_JOURNAL_NAME;
	call initiate_file_ (journal_dir, current_journal_name, RW_ACCESS, journalp, (0), code);

	if code = error_table_$noentry then
	     if create_sw then do;
		call make_new_journal (code);
		if code ^= 0 then
		     return;
	     end;

	return;

     end find_journal;
%skip (4);
find_previous_journal:
     proc (code);

dcl	code		   fixed bin (35) parameter;


	current_journal_name = journal.previous_journal_name;
	call initiate_file_ (journal_dir, current_journal_name, RW_ACCESS, journalp, (0), code);
	if code ^= 0 then
	     call admin_gate_$syserr_error_code (BEEP, code, "RCP: Cannot initiate journal ^a.",
		pathname_ (journal_dir, current_journal_name));

	return;

     end find_previous_journal;

%skip (4);
make_new_journal:
     proc (code);

dcl	code		   fixed bin (35) parameter;

dcl	from_journal_name	   char (32);
dcl	to_journal_name	   char (32);


dcl	1 cbi		   like create_branch_info aligned automatic;

	call ioa_$rsnnl ("rcprm.journal.^a", to_journal_name, (0), unique_chars_ (""b));

	if journalp ^= null then do;

/* If here, we were called because an old log had too little room left--
   so part of our job is to rename the old log before creating a new one. */

	     from_journal_name = journal.own_name;
	     journal.subsequent_journal_name = to_journal_name;
	     prev_time = journal.own_last_transaction_time;

	     call hcs_$chname_file (journal_dir, DEFAULT_JOURNAL_NAME, DEFAULT_JOURNAL_NAME, "", code);
						/* remove name "rcprm.journal" from exiting journal */
	     if code ^= 0 then
		return;

	     call terminate_file_ (journalp, (0), TERM_FILE_TERM, (0));
	end;

	else do;
	     from_journal_name = "";			/* first journal in chain */
	     prev_time = 0;
	     call admin_gate_$syserr (LOG, "RCP: Creating ^a.", pathname_ (journal_dir, DEFAULT_JOURNAL_NAME));
	end;

	unspec (cbi) = ""b;
	cbi.version = create_branch_version_2;
	cbi.mode = RW_ACCESS;
	cbi.rings (*) = get_ring_ ();
	cbi.userid = "*.*.*";
	cbi.access_class = get_max_authorization_ ();	/* This fellow may not be allowed to SYSTEM_HIGH */
	cbi.priv_upgrade_sw = (cbi.rings (3) = 1);
	cbi.parent_ac_sw = ^cbi.priv_upgrade_sw;

	call rcprm_registry_util_$turn_on_privs (privileges_string);
	call hcs_$create_branch_ (journal_dir, to_journal_name, addr (cbi), code);
	call rcprm_registry_util_$turn_off_privs (privileges_string);
	if code ^= 0 then
	     return;

	call admin_gate_$reclassify_sys_seg (journal_dir, to_journal_name, sys_info$access_class_ceiling, code);
						/* Force the seg to SYSTEM_HIGH via privileged call */
	if code ^= 0 & code ^= error_table_$action_not_performed then
	     return;

	call hcs_$chname_file (journal_dir, to_journal_name, "", DEFAULT_JOURNAL_NAME, code);
						/* add name "rcprm.journal" to new current journal */
	if code ^= 0 then
	     return;

	call initiate_file_ (journal_dir, DEFAULT_JOURNAL_NAME, RW_ACCESS, journalp, (0), code);
	if code ^= 0 then
	     return;				/* wow, something really sick */

	journal.version = 0;
	journal.next_free_word = currentsize (journal);
	journal.previous_journal_last_transaction_time = prev_time;
	journal.previous_journal_name = from_journal_name;
	journal.own_name = to_journal_name;
	journal.subsequent_journal_name = "";

	return;

     end make_new_journal;

make_fresh_journal:
     entry (arg_system_dir, code);

/* This entry gets rid of all old journal entries and starts a fresh journal. */

dcl	temp_ptr		   pointer;

dcl	delete_$ptr	   ext entry (pointer, bit (*), char (*), fixed bin (35));

/* This entry called from the proper validation level, jump right into code. */

	call cu_$level_get (prev_level);
	rcp_priv_was_on = 1;			/* so it won't get reset in window */
	tsw_attach_ptr, journalp, resource_desc_ptr, switch_ptr = null;
	system_dir = arg_system_dir;

	on cleanup call clean_up (""b, 0);

	call find_journal (""b, code);
	if code ^= 0 then
	     return;

	from_time = journal.own_last_transaction_time;
	temp_ptr = journalp;

	missing_journal = "0"b;			/* set to 1 if we failed to set journalp in find_previous_journal */
	do while (^missing_journal);
	     if journal.previous_journal_name = "" then
		go to STOP_CHASING;

	     call find_previous_journal (code);
	     if code ^= 0 then
		missing_journal = "1"b;
	     call delete_$ptr (temp_ptr, "101101"b, "rcprm_journalize_", code);
						/* delete Journal(x), journalp -> Journal(x-1) */
						/* force, no question, delete anything and chase */
	     if code ^= 0 then
		call rename_bad_journal;
	     temp_ptr = journalp;			/* temp_ptr -> Journal(x-1), find_revious_journal will set journalp -> Journal(x-2) */
	end;

STOP_CHASING:
	if ^missing_journal				/* if we have one left at this point */
	then do;
	     call delete_$ptr (temp_ptr, "101101"b, "rcprm_journalize_", code);
	     if code ^= 0 then
		call rename_bad_journal;
	end;

	journalp = null;
	call make_new_journal (code);
	if code ^= 0 then
	     return;

	journal.previous_journal_last_transaction_time, journal.own_last_transaction_time = from_time;
	call terminate_file_ (journalp, (0), TERM_FILE_TERM, (0));
	return;

reconstruct:
     entry (arg_system_dir, arg_enames, arg_rtdeps, code);

dcl	arg_enames	   char (*) dimension (*) parameter;
dcl	arg_rtdeps	   pointer dimension (*) parameter;
dcl	code		   fixed bin (35) parameter;

/* automatic */

dcl	action		   fixed bin;
dcl       done                   bit (1) aligned;
dcl	from_time		   fixed bin (71);
dcl	eoj		   bit (1) aligned;
dcl	(i, j, k)		   fixed bin;
dcl	n_resources	   fixed bin;
dcl	operation		   bit (36) aligned;
dcl	prev_level	   fixed bin;
dcl	rcp_priv_was_on	   fixed bin (35);
dcl	reclen		   fixed bin (21);
dcl	switch_ptr	   pointer;
dcl	syserr_called	   bit (1) aligned;
dcl       tjournalp              pointer;
dcl	tsw_attach_ptr	   pointer;
dcl	who_am_i		   char (64);

/* external static */

dcl	error_table_$bad_date  ext fixed bin (35) static;
dcl	access_operations_$rcp_reconstruct_registry
			   bit (36) aligned ext static;

/* entries */

dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	get_temp_segment_	   entry (char (*), pointer, fixed bin (35));
dcl	release_temp_segment_  entry (char (*), pointer, fixed bin (35));
dcl	suffixed_name_$new_suffix
			   entry (char (*), char (*), char (*), char (32), fixed bin (35));
dcl	(
	system_privilege_$rcp_priv_on,
	system_privilege_$rcp_priv_off
	)		   ext entry (fixed bin (35));

dcl	rcprm_find_resource_$reconstruct
			   ext entry (pointer, char (*), fixed bin, pointer, fixed bin (35));
dcl	rcprm_registry_mgr_$audit
			   entry (char (*), bit (36) aligned, fixed bin, char (*), char (*), bit (1),
			   fixed bin (35));
dcl	rcprm_registry_mgr_$update_registry_header_mylock
			   ext entry (char (*), pointer, fixed bin (35));

	call cu_$level_get (prev_level);
	rcp_priv_was_on = 1;			/* so it won't get reset in window */
	tsw_attach_ptr, journalp, resource_desc_ptr, switch_ptr = null;

	on cleanup call clean_up (""b, 0);

	call cu_$level_set (get_ring_ ());
	call system_privilege_$rcp_priv_on (rcp_priv_was_on);

	n_resources = hbound (arg_enames, 1);

	begin;

dcl	1 registry_data	   (n_resources) aligned,	/* automatic adjustable */
	  2 resource_name	   char (32) unaligned,
	  2 rtdep		   pointer,
	  2 dtcm		   fixed bin (71);

	     operation = access_operations_$rcp_reconstruct_registry;
	     ops_ptr = addr (addr (operation) -> encoded_access_op.detailed_operation);
	     detailed_operation.priv_gate_call = "1"b;
	     who_am_i = "rcprm_journalize_$reconstruct";
	     do i = 1 to n_resources;
		registry_data.resource_name (i) = arg_enames (i);
		registry_data.rtdep (i) = arg_rtdeps (i);
	     end;

	     system_dir = arg_system_dir;
	     code = 0;
%skip (4);

/* Find the journal and scoot back to the proper time. */

	     call find_journal (""b, code);		/* find the current journal */
	     if code ^= 0 then
		call audit ("");

	     done = "0"b;
	     tjournalp = null ();

	     do while (^done);			/* find older journals */
		tjournalp = journalp;		/* keep track of the journal we've currently got
						   so we don't loose it when we go looking for
						   the next one */
		call find_previous_journal (code);
		if code = 0 then do;
		     call terminate_file_ (tjournalp, (0), TERM_FILE_TERM, code);
						/* no longer interested in the last one. */
		     if code ^= 0 then
			call audit ("");
		     if journal.previous_journal_name = "" then
			done = "1"b;  /* end of the list */
		end;
		else do; 
		     /*** The list was improperly terminated, either by
			some form of crash damage or by someone deleting
			the journals by hand.  If the former, it will be
			caught and handled in the next code block.  If the
			latter, everything should still work o.k....   */
		     journalp = tjournalp;		/* journalp now points at something useful, the oldest */
		     done = "1"b;
		end;
		
	     end;

/* We must make ABSOLUTELY SURE that no operations had been performed on any
   of the registries between the time they were saved and the time of the
   first recorded journal entry.  We do this by checking the field at the
   header of the journal that gives the clock_time of the last transaction
   that occurred in the last set of journals before they were deleted
   (this field is carried over across the deletion) and verifying that it is
   less than the DTCM of the affected registries.  All transaction times
   recorded in the journal are generated BEFORE rcprm_find_resource_ attempts
   to perform whatever operation it is bidden-- therefore, we are ASSURED that
   if the DTCM of the registry is greater than the transaction time recorded in
   the journal, that transaction has already been incorporated.  Likewise
   we are ASSURED that if the DTCM of the registry is NOT greater than the
   transaction time of the last transaction in the previous set of journals,
   this transaction (and possibly a few transactions previous to it) have NOT
   been incorporated, and if we start reconstruction from this time, we will
   certainly lose!  So we require that from_time CAN NOT be greater than the
   DTCM of any registry. */

	     from_time = journal.previous_journal_last_transaction_time;

/* Before we can attach any registries, we must grab the transaction control file
   with an iron fist to make sure nobody slams things around behind our backs */

	     call rcprm_registry_util_$grab_transaction_control_file (tsw_attach_ptr, system_dir, code);
	     if code ^= 0 then
		call audit ("");

	     call get_temp_segment_ ("rcprm_journalize_", resource_desc_ptr, code);
	     if code ^= 0 then
		call audit ("");

	     header_ptr = resource_desc_ptr;
%skip (4);

/* Attach each registry under consideration and examine its DTCM
   (as recorded in last_transaction_time) */

	     do i = 1 to n_resources;

/**** Open each registry in turn.  First, remove any "rcpr" suffix from registry_data, then attach
      and open the registry. ****/

		call suffixed_name_$new_suffix ((registry_data.resource_name (i)), "rcpr", "",
		     registry_data.resource_name (i), code);
		if code ^= 0 then
		     call audit (registry_data.resource_name (i));

		call rcprm_registry_util_$grab_registry (switch_ptr, system_dir, registry_data.resource_name (i),
		     code);
		if code ^= 0 then
		     call audit (registry_data.resource_name (i));

		call iox_$seek_key (switch_ptr, (REGISTRY_HEADER_KEY), reclen, code);
		if code = error_table_$no_record then
		     code = error_table_$not_seg_type;
		if code ^= 0 then
		     call audit (registry_data.resource_name (i));

		call iox_$read_record (switch_ptr, header_ptr, reclen, 0, code);
		if code ^= 0 then
		     call audit (registry_data.resource_name (i));

		registry_data.dtcm (i) = registry_header.last_transaction_time;

		call rcprm_registry_util_$release_registry (switch_ptr, code);
		if code ^= 0 then
		     call audit (registry_data.resource_name (i));

/**** Note that there is a potential problem here (which won't be fixed for this release).  If a registry has
      not been changed at all since the last copy_registry -reset, we'll report an error.  This isn't tragic,
      merely confusing (the safe copy of the registry is correct, but we'll probably cause some concern to
      whoever is doing the copying). ****/
		if registry_data.dtcm (i) < from_time then do;
		     code = error_table_$bad_date;
		     call audit (registry_data.resource_name (i));
		end;
	     end;
	     switch_ptr = null;


/* Here is where we start walking through all the journal entries,
   processing them one by one. */

	     eoj = ""b;

	     je_ptr = pointer (journalp, currentsize (journal));

	     syserr_called = ""b;

	     do while (^eoj);			/* until end of journal */
		action = journal_entry.action;
		n_doublewords = journal_entry.n_doublewords;
		resource_desc_ptr -> based_words = journal_entry.j_resource_desc;

		do i = 1 by 1 while (i ^> resource_descriptions.n_items);
		     do j = 1 to n_resources
			while (registry_data.resource_name (j) ^= resource_descriptions.type (i));
		     end;

		     if j > n_resources then
			goto dont_want_it;		/* we're not updating the registry for this type */
		     if journal_entry.clock_time ^> registry_data.dtcm (j) then do;
dont_want_it:
			do k = i to resource_descriptions.n_items - 1;
			     unspec (resource_descriptions.item (k)) = unspec (resource_descriptions.item (k + 1));
			end;
			resource_descriptions.n_items = resource_descriptions.n_items - 1;
			i = i - 1;		/* "this" item now new, check it again */
		     end;
		end;

		if resource_descriptions.n_items > 0 then do;

/* We can't simulate the original call in the original process, but by jiggling
   some of the given bits we CAN simulate a privileged call on behalf of the
   original user that will accomplish the same thing (we hope!)  First,
   do all the operations in as easy a mode as possible-- don't tempt fate! */

		     resource_descriptions.given.name (*) = "1"b;
		     resource_descriptions.given.uid (*) = "0"b;

/* Registrations, deregistrations and clears are always proxy-type operations,
   so no additional fiddling with the given bits is necessary (with the
   minor exception of turning the given.uid bit on for registrations to
   signify that the old UID of the resource must be reused.)  We don't
   journalize reservations or cancellations, so we don't have to worry about
   those.  We don't journalize statuses because they never change the registry.
   Releases need only the resource name, and we have that.  Sets carry all
   their own information with them, so these are repeatable.  Only acquisitions
   are left, and we have to diddle these slightly, because some of the
   necessary information is sometimes derived from implication. */

		     if action = Acquire then
			resource_descriptions.given.owner (*), resource_descriptions.given.aim_range (*) = "1"b;

		     if action = Register then
			resource_descriptions.given.uid (*) = "1"b;

/* Now we cross our fingers and push the red button. */

		     call rcprm_find_resource_$reconstruct (resource_desc_ptr, system_dir, action, tsw_attach_ptr,
			code);			/* special entry does not try to seize rcp.tcf */
		     if code ^= 0 then do;		/* wow, bought the farm. */
			if code ^= error_table_$action_not_performed then
			     call audit (registry_data.resource_name (j));
						/* error was general, not resource-related */

/* If code = action_not_performed, error was resource-related and REAL code is
   in resource_descriptions structure.  Print notification. */

			if ^syserr_called then
			     call admin_gate_$syserr (BEEP, "RCP: Error during registry reconstruction for ^a.",
				get_group_id_ ());

			do i = 1 to resource_descriptions.n_items;
			     call admin_gate_$syserr_error_code (LOG, resource_descriptions.item (i).status_code,
				"RCP: Could not ^a ^a ^a.", Action_noun (action),
				resource_descriptions.item (i).type, resource_descriptions.item (i).name);
			end;

			syserr_called = "1"b;	/* Don't goose beeper more than once */
			code = 0;
		     end;
		end;

		call find_next_entry;
		call rcprm_registry_mgr_$audit (who_am_i, operation, prev_level, system_dir,
		     registry_data.resource_name (j), "1"b, 0);
	     end;

/* Now we update the headers in the registry to account for RTDT's that may
   have been installed between the checkpoint time and the present. */

	     do i = 1 to n_resources;
		call rcprm_registry_mgr_$update_registry_header_mylock (system_dir, registry_data.rtdep (i), code);
		if code ^= 0 then
		     call audit (registry_data.resource_name (i));
						/* to have come so far... */
	     end;
	end;					/* begin block */

/* If we make it to here, we light a candle to Babbage and collapse. */

	call clean_up ("1"b, code);
	if code = 0 then
	     if syserr_called then do;
		code = error_table_$recoverable_error;
		call admin_gate_$syserr_error_code (BEEP, code, "RCP: End of reconstruction operation.");
	     end;

	return;
%skip (4);
find_next_entry:
     proc;

/* This subroutine finds the next transaction entry in the journal. */

dcl	new_name		   char (32);

	je_ptr = addrel (je_ptr, currentsize (journal_entry));
						/* addrel, addrel, mea culpa! */

	if binary (rel (je_ptr)) < max_seg_size then
	     if journal_entry.clock_time > 0 then
		return;				/* great, easy */

	new_name = journal.subsequent_journal_name;

	call terminate_file_ (journalp, (0), TERM_FILE_TERM, code);
	if code ^= 0 then
	     goto error_return;

	if new_name = "" then do;
	     eoj = "1"b;
	     return;
	end;
	journal_dir = pathname_ (system_dir, "journals");
	call initiate_file_ (journal_dir, new_name, RW_ACCESS, journalp, (0), code);
	if code ^= 0 then do;
	     call admin_gate_$syserr_error_code (BEEP, code, "RCP: Cannot initiate journal ^a.",
		pathname_ (system_dir, new_name));
	     goto error_return;
	end;

	je_ptr = pointer (journalp, currentsize (journal));
	return;
     end find_next_entry;

%skip (4);
clean_up:
     proc (error_matters, code);

dcl	error_matters	   bit (1) aligned parameter;
dcl	code		   fixed bin (35) parameter;

	if resource_desc_ptr ^= null then
	     call release_temp_segment_ ("rcprm_journalize_", resource_desc_ptr, code);
	if error_matters then
	     if code ^= 0 then
		goto error_return;

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

	if rcp_priv_was_on = 0 then
	     call system_privilege_$rcp_priv_off (0);

	if switch_ptr ^= null then do;
	     call rcprm_registry_util_$release_registry (switch_ptr, code);
	     if error_matters then
		if code ^= 0 then
		     goto error_return;
	end;

	if tsw_attach_ptr ^= null then do;
	     call rcprm_registry_util_$release_transaction_control_file (tsw_attach_ptr, code);
	     if error_matters then
		if code ^= 0 then
		     goto error_return;
	end;

	call cu_$level_set (prev_level);

	return;

     end clean_up;

rename_bad_journal:
     procedure;

declare  p_code		  fixed bin (35);

	p_code = code;

	call hcs_$chname_seg (temp_ptr, current_journal_name, rtrim (current_journal_name) || ".bad", code);
	if code = 0 then
	     call admin_gate_$syserr_error_code (LOG, p_code,
		"RCP: Failed to delete old journal ^a. Renamed it to ^a.bad",
		pathname_ (journal_dir, current_journal_name), current_journal_name);
	else call admin_gate_$syserr_error_code (LOG, code,
		"RCP: Failed to rename or delete old journal ^a. Use hp_delete_vtoce.",
		pathname_ (journal_dir, current_journal_name));
	return;

     end rename_bad_journal;


%skip (4);
error_return:
	call clean_up (""b, (0));
	return;
%page;
audit:
     proc (a_registry_name);

dcl	a_registry_name	   char (*);

	call rcprm_registry_mgr_$audit (who_am_i, operation, prev_level, system_dir, a_registry_name, "0"b, code);
	goto error_return;

     end audit;

%include access_audit_encoded_op;
%page;
%include rcp_ops;
%page;
%include rcprm_journal;
%page;
%include resource_control_desc;
%page;
%include rcprm_registry_keys;
%page;
%include iox_dcls;
%page;
%include rcprm_action_codes;
%page;
%include iox_modes;
%page;
%include rcp_registry;
%page;
%include force_write_flags;
%page;
%include create_branch_info;
%page;
%include syserr_constants;
%page;
%include access_mode_values;
%page;
%include terminate_file;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   RCP: Journal lost transaction for USERID. ERROR_CODE

   S: $beep

   T: $run

   M: Some RCP Resource Management activity, while successfully completed, was
   not properly journalized for recovery purposes.  Subsequently, if the
   registries become damaged before they are safely copied by the System
   Administrator, this activity will be lost.

   A: $contact_sa


   Message:
   RCP: Journal could not be forcibly written.  ERROR CODE

   S: $info

   T: $run

   M: A force-write to disk of the RCP journal failed.  $err

   A: $contact


   Message:
   RCP: Cannot initiate journal PATH.  ERROR_CODE

   S: $beep

   T: $run

   M: The RCP journal at PATH has been damaged or is missing.

   A: $contact


   Message:
   RCP: Creating DIRNAME>rcprm.journal

   S: $info

   T: $run

   M: Printed by RCP Resource Management when first enabled.

   A: $ignore


   Message:
   RCP: Error during registry reconstruction for USERID.
   RCP: Could not OPERATION RESOURCE_TYPE RESOURCE_NAME
   {may occur multiple times}
   RCP: End of reconstruction operation.

   S: $beep


   T: This message should only occur during a special session.  The second
   message in the series may occur multiple times.

   M: The specified RCP Resource Management activity failed to be re-performed
   during an attempt to reconstruct the registries by the System Administrator.
   $err

   A: $contact_sa

   END MESSAGE DOCUMENTATION */

     end rcprm_journalize_;




		    rcprm_list_resource_.pl1        11/11/89  1111.8rew 11/11/89  0806.7      169551



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




/****^  HISTORY COMMENTS:
  1) change(87-06-08,Rauschelbach), approve(87-06-26,MCR7713),
     audit(87-07-08,Farley), install(87-07-15,MR12.1-1041):
     Changed to obey rcp privilege by using get_process_authorization_ instead
     of get_authorization_.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */

rcprm_list_resource_:
     proc (p_resource_type, p_registry_dir, p_userid, p_user_area_ptr, p_n_resources, p_return_ptr, p_code);

/* This procedure is charged with returning a list of resources owned by
   various groups.  The selection is made by the userid argument.  It can
   select from among:
   1) a certain user.project (userid = user.project)
   2) any user.project (privileged) (userid = user.project)
   3) a certain project (project administrators only) (userid = *.project)
   4) the system (userid = "system")
   5) the free pool (userid = "free")
   6) everything but the free pool (i.e. all acquisitions) (userid = "*.*")
   7) all users (i.e. all registered resources of a given type) (userid = "**")
*/

/* Written 06/23/78 by C. D. Tavares */
/* Modified 11/27/79 by CDT to fix bug where lists via *.Project were
   bombing out on encountering interspersed name records for different users on
   that project. */
/* Modified 12/10/79 by CDT to take advantage of new facility to sleep in ring
   1 */
/* Modified 02/27/80 by CDT to remove non-quick blocks */
/* Modified 06/18/81 by CDT to look for and reject * in the Project field,
   not just treat it like a project name */
/* Modified 09/81 by M.R. Jordan to fix a bug in listing resources awaiting manual clear. */
/* Modified 04/83 by B. Braun to correct a typo error so 'free' and 'system' are once again accepted as arguments to
   the list_resources -user control argument.  (TRs phx12946, phx13300). */
/* Modified 04/83 by B. Braun to cleanup iocbs left laying about. (TR phx11736) */
/* Modified 01/85 by Chris Jones to clean up the code, rationalize registry operations. */
/* Modified 03/85 by Chris Jones to add auditing. */

/* parameters */

dcl	p_resource_type	   char (*) parameter;	/* (I) e.g. "tape_vol" */
dcl	p_registry_dir	   char (*) parameter;	/* (I) directory registries are in */
dcl	p_userid		   char (*) parameter;	/* (I) Personid.Project, or "system" or "free" or ** or *.* */
dcl	p_user_area_ptr	   pointer parameter;	/* (I) area to allocate resource_list structure in */
dcl	p_n_resources	   fixed bin (35) parameter;	/* (O) number of resources in resource_list */
dcl	p_return_ptr	   pointer parameter;	/* (O) pointer to allocated structure */
dcl	p_code		   fixed bin (35) parameter;	/* (O) standard status code */

/* automatic */

dcl	access_mode	   fixed bin (5);
dcl	awaiting_clear	   bit (1) aligned initial ("0"b);
dcl	code		   fixed bin (35);
dcl	cur_level		   fixed bin;
dcl	do_seek_head	   bit (1) initial ("0"b) aligned;
dcl	done		   bit (1) aligned;
dcl	find_by_resource_name  bit (1) aligned initial ("0"b);
dcl	found		   bit (1) aligned;
dcl	germane_descriptor	   fixed bin (35);
dcl	i		   fixed bin (35);
dcl	next_resource_list_ptr ptr;
dcl	original_key	   char (256);
dcl	pdt_name		   char (32);
dcl	project		   char (32);
dcl	prev_level	   fixed bin;
dcl	last_known_key	   char (64) varying;
dcl	last_ptr		   pointer;
dcl	priv_sw		   bit (1) aligned;
dcl	real_resource_record   bit (1) aligned;
dcl	registry_dir	   char (64);
dcl	resource_type	   char (32);
dcl	return_ptr	   ptr;
dcl	rew		   bit (3);
dcl	rno		   fixed bin;
dcl	sw_ptr		   pointer initial (null ());
dcl	tcf_sw_ptr	   pointer initial (null ());
dcl	user_area_ptr	   ptr init (null ());
dcl	userid		   char (32);

dcl	1 authorization	   aligned automatic like aim_template;
dcl	1 record_status	   aligned automatic like rs_info;
dcl	1 req_info	   aligned automatic like requestor_info;
dcl	1 res_info	   aligned automatic like resource_info;
dcl	1 get_key_info	   automatic,
	  2 header	   like gk_header,
	  2 key		   char (256) unaligned;

dcl	1 circular_list	   aligned automatic,
	  2 high_water_mark	   fixed bin,
	  2 latest_entry	   fixed bin,
	  2 entry		   (20) aligned,		/* 20 should be pretty efficient */
	    3 descriptor	   fixed bin (35),
	    3 rew		   bit (3) aligned;

/* static */

dcl	pdt_dirname	   char (168) initial (">system_control_1>pdt") static;

dcl	Move_rel		   initial (0) fixed bin static options (constant);

/* entries */

dcl	access_audit_r1_$log_obj_path
			   entry options (variable);
dcl	cu_$level_get	   ext entry (fixed bin);
dcl	cu_$level_set	   ext entry (fixed bin);
dcl	get_authorization_	   entry () returns (bit (72) aligned);
dcl	get_process_authorization_
			   entry () returns (bit (72) aligned);
dcl	get_group_id_	   entry () returns (char (32));
dcl	get_group_id_$tag_star ext entry returns (char (32));
dcl	get_ring_		   ext entry returns (fixed bin);
dcl	hcs_$get_user_effmode  entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
dcl	pathname_		   entry (char (*), char (*)) returns (char (168));
dcl	rcp_compute_aim_mode   entry (ptr, ptr, bit (3), fixed bin (35));
dcl	rcprm_registry_util_$free_key
			   entry (ptr, char (*));
dcl	rcprm_registry_util_$owner_key
			   entry (char (*), ptr, char (*));
dcl	rcprm_registry_util_$project_key
			   entry (char (*), ptr, char (*));
dcl	rcprm_registry_util_$skeleton_key
			   entry (ptr, char (*));
dcl	rcprm_registry_util_$skeleton_acquisition_key
			   entry (ptr, char (*));
dcl	rcprm_registry_util_$system_key
			   entry (ptr, char (*));
dcl	rcprm_registry_util_$grab_transaction_control_file
			   entry (ptr, char (*), fixed bin (35));
dcl	rcprm_registry_util_$release_transaction_control_file
			   entry (ptr, fixed bin (35));
dcl	rcprm_registry_util_$grab_registry
			   entry (ptr, char (*), char (*), fixed bin (35));
dcl	rcprm_registry_util_$release_registry
			   entry (ptr, fixed bin (35));
dcl	suffixed_name_$make	   entry (char (*), char (*), char (32), fixed bin (35));

/* external variables */

dcl	(
	error_table_$insufficient_access,
	error_table_$no_record,
	error_table_$bad_name,
	error_table_$end_of_info,
	error_table_$smallarg
	)		   ext fixed bin (35) static;
dcl	access_operations_$rcp_list
			   bit (36) aligned ext static;

/* based variables */

dcl	user_area		   area based (user_area_ptr);

/* builtins and conditions */

dcl	(area, cleanup)	   condition;

dcl	(addr, after, before, hbound, null, rtrim, reverse, substr, unspec)
			   builtin;

	priv_sw = "0"b;
	goto common;

priv:
     entry (p_resource_type, p_registry_dir, p_userid, p_user_area_ptr, p_n_resources, p_return_ptr, p_code);

	priv_sw = "1"b;
	goto common;

awaiting_clear:
     entry (p_resource_type, p_registry_dir, p_userid, p_user_area_ptr, p_n_resources, p_return_ptr, p_code);

	priv_sw = "1"b;
	awaiting_clear = "1"b;
	goto common;

common:
/**** Copy relevant arguments ****/
	resource_type = p_resource_type;
	registry_dir = p_registry_dir;
	userid = p_userid;
	user_area_ptr = p_user_area_ptr;
	return_ptr = null ();
	call cu_$level_get (prev_level);
	unspec (authorization) = get_process_authorization_ ();

	if awaiting_clear then do;
	     find_by_resource_name = "1"b;		/* no owner hijinks necessary */
	     call rcprm_registry_util_$skeleton_key (addr (get_key_info.header), get_key_info.key);
	end;

	else if userid = "free" then
	     call rcprm_registry_util_$free_key (addr (get_key_info.header), get_key_info.key);
	else if userid = "system" then
	     call rcprm_registry_util_$system_key (addr (get_key_info.header), get_key_info.key);
	else if userid = "" | userid = get_group_id_$tag_star ()
						/* asking for ourself */
	     | userid = reverse (after (reverse (get_group_id_$tag_star ()), ".")) then do;
	     call rcprm_registry_util_$owner_key (get_group_id_$tag_star (), addr (get_key_info.header),
		get_key_info.key);
	end;

	else if userid = "*.*" then do;		/* requesting info on all acquired resources */
	     if ^priv_sw then do;
		code = error_table_$insufficient_access;
		call error_return;
	     end;
	     call rcprm_registry_util_$skeleton_acquisition_key (addr (get_key_info.header), get_key_info.key);
	end;

	else if userid = "**" then do;		/* requesting info on all registered resources */
	     if ^priv_sw then do;
		code = error_table_$insufficient_access;
		call error_return;
	     end;

	     find_by_resource_name = "1"b;
	     call rcprm_registry_util_$skeleton_key (addr (get_key_info.header), get_key_info.key);
	end;
	else if substr (userid, 1, 2) = "*." then do;	/* requesting info on one project */
	     call breakapart (userid, (""), project);

	     pdt_name = rtrim (project) || ".pdt";	/* use PDT as an ACS */
	     call hcs_$get_user_effmode (pdt_dirname, pdt_name, "", -1, access_mode, code);

	     if code ^= 0 then
		call error_return;
	     if access_mode < R_ACCESS_BIN then do;	/* no read permission */
		code = error_table_$insufficient_access;
		call error_return;
	     end;

	     call rcprm_registry_util_$project_key (project, addr (get_key_info.header), get_key_info.key);
	end;

	else do;					/* request for particular user ^= caller */
	     if ^priv_sw then do;
		code = error_table_$insufficient_access;
		call error_return;
	     end;


/* Make sure caller is not asking for "Person.*" */

	     call breakapart (userid, (""), project);
	     if project = "*" then do;
		code = error_table_$bad_name;
		call error_return;
	     end;

	     call rcprm_registry_util_$owner_key (userid, addr (get_key_info.header), get_key_info.key);
	end;
	original_key = substr (get_key_info.key, 1, get_key_info.head_size);

/* Now we've figured out exactly what it is that the caller wants us to do
   (and whether the caller can do it.)  So now we do it. */

	on cleanup call clean_up ((0), "0"b);

	cur_level = get_ring_ ();
	call cu_$level_set (cur_level);

	call rcprm_registry_util_$grab_transaction_control_file (tcf_sw_ptr, registry_dir, code);
	if code ^= 0 then
	     call error_return;

	call rcprm_registry_util_$grab_registry (sw_ptr, registry_dir, resource_type, code);
	if code ^= 0 then
	     call error_return;

	rno = 0;
	last_known_key = "";

	call iox_$control (sw_ptr, "get_key", addr (get_key_info), code);
	if code ^= 0 then do;
	     call clean_up (code, "1"b);
	     if code ^= 0 then
		call error_return;
	     goto return_to_caller;
	end;

	done = "0"b;
	get_key_info.input_key = "0"b;		/* just get the current key */
	get_key_info.current = "1"b;			/* from now on */

	unspec (record_status) = ""b;
	record_status.version = rs_info_version_2;

	on area
	     begin;
	     code = error_table_$smallarg;
	     call error_return;
	end;

	circular_list.high_water_mark = -1;
	circular_list.latest_entry = 0;
	Max_entries = 100;				/* seems like a nice enough number */

	allocate resource_list in (user_area) set (resource_list_ptr);
	return_ptr = resource_list_ptr;		/* save it now for error_return */

/* Now loop, finding all relevant resources. */

	do while (^done);

	     real_resource_record = "0"b;

	     if substr (get_key_info.key, 1, get_key_info.head_size) ^= original_key then
		done = "1"b;
	     else if find_by_resource_name then
		real_resource_record = "1"b;		/* no owner record hijinks necessary */
	     else if get_key_info.key = last_known_key then
		real_resource_record = "1"b;		/* first record of a given user key is username record, not a real resource record */
	     else last_known_key = rtrim (get_key_info.key);

	     if ^done & real_resource_record then do;
		call iox_$control (sw_ptr, "record_status", addr (record_status), code);
		if code = 0 then
		     ;
		else if code = error_table_$no_record then
		     real_resource_record = "0"b;	/* is not, but has just been garbage-collected */
						/* and should never bother us again! */
		else call error_return;

		if real_resource_record then do;
		     record_ptr = record_status.record_ptr;

/* see if we have enough access to report the existence of this resource.  This
   computation takes into account ONLY the AIM range of the resource (since r
   raw mode is not necessary to list the existence of a resource, but
   read_allowed_ IS.) Once we know our access to any resource, theoretically we
   know our access to any other resource possessing the same AIM descriptor.
   So we make use of this fact (for efficiency) and look up the known
   descriptors in a small internal table before passing the question off to the
   external subroutine that acts as RCP's AIM security kernel.  (Note that all
   descriptors found in this manner have gone through the kernel at least once
   anyway.) */

		     if authorization.privileges.rcp then
			rew = "111"b;
		     else do;

			if registry_record.free then
			     germane_descriptor = registry_record.potential_aim_range_desc;
			else germane_descriptor = registry_record.aim_range_desc;

			found = "0"b;

			do i = circular_list.latest_entry to circular_list.high_water_mark while (^found),
			     1 to circular_list.latest_entry - 1 while (^found);
			     if circular_list.descriptor (i) = germane_descriptor then do;
				rew = circular_list.rew (i);
				found = "1"b;
			     end;
			end;

/**** It wasn't found, so we ask rcp_compute_aim_mode to tell us what access this AIM
      range confers on us. ****/
			if ^found then do;
			     res_info.registry_dir = registry_dir;
			     res_info.registry_switch_ptr = sw_ptr;
			     res_info.registry_record_ptr = record_ptr;
			     res_info.resource_type = resource_type;
			     res_info.resource_name = "";
			     req_info.user_id = get_group_id_ ();
			     req_info.current_authorization = get_authorization_ ();
			     req_info.validation_level = prev_level;
			     call rcp_compute_aim_mode (addr (req_info), addr (res_info), rew, code);
			     if code ^= 0 then
				call error_return;

/* enter the information into the circular list */

			     if circular_list.latest_entry = hbound (circular_list.descriptor, 1) then
				i, circular_list.latest_entry = 1;
			     else i, circular_list.latest_entry = circular_list.latest_entry + 1;

			     if circular_list.latest_entry > circular_list.high_water_mark then
				circular_list.high_water_mark = circular_list.latest_entry;

			     circular_list.descriptor (i) = germane_descriptor;
			     circular_list.rew (i) = rew;
			end;
		     end;

		     if ^priv_sw & registry_record.awaiting_clear then
			rew = "000"b;		/* don't report spectral resources */

		     if awaiting_clear then		/* do we want only those awaiting clear? */
			if registry_record.awaiting_clear = "0"b then
						/* yes, and this one isn't */
			     rew = "000"b;		/* ignore it-- make believe we can't read it */

		     if substr (rew, 1, 1) = "1"b then do;
						/* we can know this resource exists */
			rno = rno + 1;		/* gound another one */

			if resource_list.n_resources = resource_list.max_entries then do;
			     last_ptr = resource_list_ptr;
			     allocate resource_list in (user_area) set (resource_list_ptr);
			     last_ptr -> resource_list.forward_ptr = resource_list_ptr;
			end;

			i, resource_list.n_resources = resource_list.n_resources + 1;
			resource_list.resource_name (i) = registry_record.name.string;
		     end;

		end;

	     end;
	     if ^done then do;
		call iox_$position (sw_ptr, Move_rel, 1, code);
		if code = 0 then
		     ;
		else if code = error_table_$end_of_info then
		     done = "1"b;
		else call error_return;
		if ^done then do;
		     call iox_$control (sw_ptr, "get_key", addr (get_key_info), code);
		     if code ^= 0 then
			call error_return;
		end;
	     end;
	end;
	call audit (0);

	call clean_up (code, "1"b);
	if code ^= 0 then
	     call error_return;

return_to_caller:
	p_n_resources = rno;			/* tell caller how many we found */
	p_return_ptr = return_ptr;
	p_code = code;
	return;

breakapart:
     proc (userid, user_name, project);

dcl	userid		   char (*) parameter;
dcl	user_name		   char (*) parameter;
dcl	project		   char (*) parameter;

	user_name = before (userid, ".");
	project = before (after (userid, "."), ".");

     end breakapart;


clean_up:
     proc (code, error_matters);

dcl	code		   fixed bin (35) parameter;
dcl	error_matters	   bit (1) aligned parameter;

	if sw_ptr ^= null () then do;
	     call rcprm_registry_util_$release_registry (sw_ptr, code);
	     call return_if_real_error;
	end;

	if tcf_sw_ptr ^= null () then do;
	     call rcprm_registry_util_$release_transaction_control_file (tcf_sw_ptr, code);
	     call return_if_real_error;
	end;

	call cu_$level_set (prev_level);

cleanup_return:
	return;

return_if_real_error:
	proc;

	     if error_matters & code ^= 0 then
		goto cleanup_return;

	end return_if_real_error;

     end clean_up;

error_return:
     proc;

	call audit (code);
	call clean_up ((0), "0"b);
	do resource_list_ptr = return_ptr repeat next_resource_list_ptr while (resource_list_ptr ^= null ());
	     next_resource_list_ptr = resource_list.forward_ptr;
	     free resource_list;
	end;
	rno = 0;
	return_ptr = null ();
	goto return_to_caller;

     end error_return;

audit:
     proc (code);

dcl	code		   fixed bin (35) parameter;

dcl	1 auto_event_flags	   like audit_event_flags aligned;
dcl	registry_name	   char (32);

	unspec (auto_event_flags) = ""b;
	auto_event_flags.grant = (code = 0);
	auto_event_flags.priv_op = priv_sw;
	call suffixed_name_$make (resource_type, "rcpr", registry_name, (0));
	call access_audit_r1_$log_obj_path ("rcprm_list_resource_", prev_level, unspec (auto_event_flags),
	     access_operations_$rcp_list, pathname_ (registry_dir, registry_name), code, null (), 0);

     end audit;

test:
     entry (newdirname);

dcl	newdirname	   char (*) parameter;

	if newdirname = "" then
	     pdt_dirname = ">system_control_1>pdt";
	else pdt_dirname = newdirname;
	return;

%include access_audit_eventflags;
%page;
%include resource_list;
%page;
%include rcp_registry;
%page;
%include rcp_requestor_info;
%page;
%include rcp_resource_info;
%page;
%include aim_template;
%page;
%include iox_dcls;
%page;
%include iox_modes;
%page;
%include access_mode_values;
%page;
%include rs_info;
%page;
%include ak_info;

     end rcprm_list_resource_;




		    rcprm_registry_mgr_.pl1         11/11/89  1111.8r w 11/11/89  0808.7      256302



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcprm_registry_mgr_:
     proc;
	return;

/* This module implements registry management functions of creation and
   replacement of registry header, for RCP resource management.
   Written 05/10/78 by C. D. Tavares */
/* Modified 11/21/79 by CDT to fix bug in comparing headers during update. */
/* Modified 12/10/79 by CDT to take advantage of new facility to sleep in ring
   1 */
/* Modified 10/03/80 by CDT to fix bug where copy_registry always tried
   to lock rcp.tcf in source dir even if there wasn't one, to check whether the
   source and target registries of the copy were the same file, to improve
   error messages reflected back to ring 4, and to change journal dir's ring
   brackets to 1,7. */
/* Modified 04/83 by B. Braun to cleanup iocbs left laying about. (TR phx11736) */
/* Modified 12/84 by Keith Loepere for version 2 create_branch_info. */
/* Modified 02/12/85 by Maria Pozzo copy_registry: to create a null
   component(s) in the new registry when a component(s) is missing in
   the original.  Returns a warning message to the user. */
/* Modified 02/14/85 by Chris Jones for RCP auditing and to clean up better. */

dcl	p_registry_dir	   char (*) parameter;
dcl	p_registry_entry	   char (*) parameter;
dcl	p_rtdep		   ptr;
dcl	p_code		   fixed bin (35) parameter;

/* entries */

dcl	cu_$level_get	   entry (fixed bin);
dcl	cu_$level_set	   entry (fixed bin);
dcl	get_group_id_	   entry () returns (char (32));
dcl	get_process_authorization_
			   entry () returns (bit (72) aligned);
dcl	get_ring_		   entry () returns (fixed bin (3));
dcl	hcs_$append_branchx	   entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1),
			   fixed bin (1), fixed bin (24), fixed bin (35));
dcl	hcs_$create_branch_	   entry (char (*), char (*), ptr, fixed bin (35));
dcl	hcs_$set_dir_ring_brackets
			   entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
dcl	hcs_$status_minf	   entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl	pathname_		   entry (char (*), char (*)) returns (char (168));
dcl	rcprm_registry_util_$create_transaction_control_file
			   entry (char (*), fixed bin (35));
dcl	rcprm_registry_util_$grab_registry
			   entry (ptr, char (*), char (*), fixed bin (35));
dcl	rcprm_registry_util_$grab_registry_create
			   entry (ptr, char (*), char (*), fixed bin (35));
dcl	rcprm_registry_util_$grab_registry_old
			   entry (ptr, char (*), char (*), fixed bin (35));
dcl	rcprm_registry_util_$grab_registry_no_journalize
			   entry (ptr, char (*), char (*), fixed bin (35));
dcl	rcprm_registry_util_$grab_transaction_control_file
			   entry (ptr, char (*), fixed bin (35));
dcl	rcprm_registry_util_$release_registry
			   entry (ptr, fixed bin (35));
dcl	rcprm_registry_util_$release_transaction_control_file
			   entry (ptr, fixed bin (35));
dcl	suffixed_name_$make	   entry (char (*), char (*), char (32), fixed bin (35));

/* automatic */

dcl	1 cbi		   like create_branch_info aligned;
dcl	code		   fixed bin (35);
dcl	cur_level		   fixed bin;
dcl	dir_rbs		   (2) fixed bin (3);
dcl	error_msg		   char (256);
dcl	i		   fixed bin;
dcl	ME		   char (64);
dcl	operation		   bit (36) aligned;
dcl	prev_level	   fixed bin initial (-1);
dcl	record_len	   fixed bin (21);
dcl	registry_dir	   char (168);
dcl	registry_name	   char (32);
dcl	(switch_ptr, tcf_switch_ptr)
			   pointer initial (null);

/* internal static and constants */

dcl	(
	Create		   initial (0),
	Locate		   initial (1)
	)		   fixed bin static options (constant);

dcl	ALL_USERS		   char (5) static options (constant) init ("*.*.*");
dcl	JOURNALS_DIR_ENTRYNAME char (8) static options (constant) init ("journals");
dcl	REGISTRY_SUFFIX	   char (4) static options (constant) init ("rcpr");
dcl	REGISTRY_OLD_SUFFIX	   char (3) static options (constant) init ("old");
dcl	RING_7_BRACKETS	   (3) fixed bin (3) static options (constant) init (7, 7, 7);

/* external static */

dcl	access_operations_$rcp_copy_registry
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_delete_registry
			   bit (36) aligned ext static;
dcl	access_operations_$rcp_update_registry_header
			   bit (36) aligned ext static;

dcl	(
	error_table_$namedup,
	error_table_$improper_data_format,
	error_table_$no_record,
	error_table_$noentry,
	error_table_$rcp_missing_registry_component
	)		   external fixed bin (35) static;

dcl	sys_info$access_class_ceiling
			   bit (72) aligned ext static;

/* builtins, etc. */

dcl	(addr, char, currentsize, length, ltrim, null, unspec)
			   builtin;

dcl	cleanup		   condition;

create_registry:
     entry (p_registry_dir, p_rtdep, p_code);

	registry_dir = p_registry_dir;
	rtdep = p_rtdep;
	call cu_$level_get (prev_level);

	on cleanup call clean_up;

	cur_level = get_ring_ ();
	call cu_$level_set (cur_level);

	operation = ""b;				/* no special operation */
	ME = "rcprm_registry_mgr_$create_registry";

	call suffixed_name_$make ((rtde.name), REGISTRY_SUFFIX, registry_name, code);
	if code ^= 0 then
	     goto error_return;


/* First, check to see that we are really creating a previously nonexistant registry. */

	call hcs_$status_minf (registry_dir, registry_name, 0 /* no chase */, 0, 0, code);
	call revise_error (error_table_$noentry, error_table_$namedup);
						/* accept noentry as OK, reject 0 as namedup */
	if code ^= 0 then
	     goto error_return;

/* Before creating the registry, try creating the transaction control file in
   case there isn't one yet. */

	call rcprm_registry_util_$create_transaction_control_file (registry_dir, code);
	call revise_error (error_table_$namedup, 0);
	if code ^= 0 then
	     goto error_return;

/* See if we should create a new journal dir. */

	call hcs_$append_branchx (registry_dir, JOURNALS_DIR_ENTRYNAME, SMA_ACCESS_BIN, RING_7_BRACKETS, ALL_USERS,
	     1 /* dir */, 0, 0, code);
	if code = error_table_$namedup then
	     code = 0;
	else if code ^= 0 then
	     goto error_return;
	else do;
	     dir_rbs (1) = cur_level;
	     dir_rbs (2) = 7;
	     call hcs_$set_dir_ring_brackets (registry_dir, JOURNALS_DIR_ENTRYNAME, dir_rbs, code);
	     if code ^= 0 then
		goto error_return;
	end;


/* Now we create an SSF to serve as the registry.  Although the registry will
   immediately become an MSF (a record file), we want to set certain attributes
   of it, like multiclass AIM attributes, so that the file will perform
   properly.  Then we just rely on msf_manager_ and make_msf_ to correctly
   propagate these attributes when it becomes an MSF (and when new components
   are dynamically added. */

	call fillin_cbi;
	call hcs_$create_branch_ (registry_dir, registry_name, addr (cbi), code);
	if code ^= 0 then
	     goto error_return;

/* Now, prepare we to transmogrify yon beeste into an MSF. */

	call rcprm_registry_util_$grab_registry_create (switch_ptr, registry_dir, registry_name, code);
	if code ^= 0 then
	     goto error_return;

	call write_header (Create);

/* Now add the necessary keys to the registry. */

	call add_key (REGISTRY_SYSTEM_KEY, "system");
	call add_key (REGISTRY_FREE_KEY, "free");

good_return:
	call clean_up;
	call audit_success;
	p_code = 0;
	return;

error_return:
	call clean_up;
	call audit_failure;
	p_code = code;
	return;

write_header:
     proc (action);

dcl	action		   fixed bin parameter;

dcl	1 auto_header	   aligned automatic,
	  2 rtde_size	   fixed bin (18),
	  2 rtde_template	   (currentsize (rtde)) bit (36) aligned,
	  2 other		   like registry_header.other aligned;

	unspec (auto_header.rtde_template) = unspec (rtde);
	unspec (auto_header.other) = ""b;
	auto_header.rtde_size = currentsize (rtde);

	call iox_$seek_key (switch_ptr, (REGISTRY_HEADER_KEY), 0, code);
	if action = Create then
	     call revise_error (error_table_$no_record, error_table_$namedup);
	if code ^= 0 then
	     goto error_return;

	if action = Create then
	     call iox_$write_record (switch_ptr, addr (auto_header), currentsize (auto_header) * 4, code);
	else call iox_$rewrite_record (switch_ptr, addr (auto_header), currentsize (auto_header) * 4, code);
	if code ^= 0 then
	     goto error_return;

	return;

compare_header:
     entry;

	unspec (auto_header) = ""b;

	call iox_$seek_key (switch_ptr, (REGISTRY_HEADER_KEY), record_len, code);
	if code ^= 0 then
	     goto error_return;

	if record_len > currentsize (auto_header) * 4 then
	     goto not_format;

	call iox_$read_record (switch_ptr, addr (auto_header), record_len, 0, code);
	if code ^= 0 then
	     goto error_return;

	if unspec (auto_header.rtde_template) ^= unspec (rtde) then
	     goto not_format;

     end write_header;

not_format:
	code = error_table_$improper_data_format;
	goto error_return;

revise_error:
     proc (ok_code, zero_becomes_code);

dcl	(ok_code, zero_becomes_code)
			   fixed bin (35) parameter;

	if code = ok_code then
	     code = 0;
	else if code = 0 then
	     code = zero_becomes_code;

     end revise_error;

add_key:
     proc (key, string_arg);

dcl	key		   char (*) varying parameter;
dcl	string_arg	   char (*) parameter;

	call iox_$seek_key (switch_ptr, rtrim (key), 0, code);
	call revise_error (error_table_$no_record, error_table_$namedup);
	if code ^= 0 then
	     goto error_return;

	call iox_$write_record (switch_ptr, addr (string_arg), length (string_arg), code);
	if code ^= 0 then
	     goto error_return;

     end add_key;

update_registry_header:
     entry (p_registry_dir, p_rtdep, p_code);

/* This entry updates the header record in the registry with a new RTDE. */

dcl	mylocked		   bit (1) aligned;

	mylocked = ""b;
	goto update_header_common;

update_registry_header_mylock:
     entry (p_registry_dir, p_rtdep, p_code);

	mylocked = "1"b;

update_header_common:
	registry_dir = p_registry_dir;
	rtdep = p_rtdep;
	call cu_$level_get (prev_level);


	on cleanup call clean_up;

	operation = access_operations_$rcp_update_registry_header;
	ME = "rcprm_registry_mgr_$update_registry_header";

	call suffixed_name_$make ((rtde.name), REGISTRY_SUFFIX, registry_name, code);
	if code ^= 0 then
	     goto error_return;
	call cu_$level_set (get_ring_ ());

	if ^mylocked then do;
	     call rcprm_registry_util_$grab_transaction_control_file (tcf_switch_ptr, registry_dir, code);
	     if code ^= 0 then
		goto error_return;
	end;

	call rcprm_registry_util_$grab_registry_no_journalize (switch_ptr, registry_dir, registry_name, code);
	if code ^= 0 then
	     goto error_return;

	call iox_$seek_key (switch_ptr, (REGISTRY_HEADER_KEY), record_len, code);
	if code ^= 0 then
	     goto not_format;

	begin;

/* Read the current header and make sure that the position of all currently
   known attributes is preserved.  Later on we might write a procedure to
   reformat all records to free up attribute positions, but for now it is
   an error of the worst kind. */

dcl	record_buffer	   char (record_len) aligned;
dcl	rbp		   ptr;
dcl	rtde_copyp	   ptr;

	     rbp = addr (record_buffer);

	     call iox_$read_record (switch_ptr, rbp, record_len, 0, code);
	     if code ^= 0 then
		goto error_return;

	     rtde_copyp = addr (rbp -> registry_header.rtde_copy);

	     if rtde_copyp -> rtde.n_defined_attributes > rtdep -> rtde.n_defined_attributes then
		goto not_format;

	     do i = 1 to rtde_copyp -> rtde.n_defined_attributes;
		if rtde_copyp -> rtde.attribute_names (i) ^= rtdep -> rtde.attribute_names (i) then
		     goto not_format;
	     end;
	end;

	call write_header (Locate);

	goto good_return;

validate_registry:
     entry (p_registry_dir, p_rtdep, p_code);

/* This entry checks to make sure that the RTDE in the RTDT agrees with the
   RTDE in the registry.  If they are different (could happen in the case of a
   partial reload or other calamity) RCP would otherwise be mighty confused. */

	registry_dir = p_registry_dir;
	rtdep = p_rtdep;
	call cu_$level_get (prev_level);
	operation = ""b;
	ME = "rcprm_registry_mgr_$validate_registry";

	call suffixed_name_$make ((rtde.name), REGISTRY_SUFFIX, registry_name, code);
	if code ^= 0 then
	     goto error_return;
	on cleanup call clean_up;

	call rcprm_registry_util_$grab_registry (switch_ptr, registry_dir, registry_name, code);
	if code ^= 0 then
	     goto error_return;

	call compare_header;

	call rcprm_registry_util_$release_registry (switch_ptr, code);
	if code ^= 0 then
	     goto error_return;

	goto good_return;

delete_registry:
     entry (p_registry_dir, p_registry_entry, p_code);

/* automatic */

dcl	cur_ring		   fixed bin;

/* entries */

dcl	hcs_$get_dir_ring_brackets
			   entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
dcl	admin_gate_$syserr	   entry () options (variable);
dcl	delete_$path	   entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));

/* external static */

dcl	error_table_$not_seg_type
			   ext fixed bin (35);

	registry_dir = p_registry_dir;
	call cu_$level_get (prev_level);

	on cleanup call clean_up;

	cur_ring = get_ring_ ();
	call cu_$level_set (cur_ring);

	operation = access_operations_$rcp_delete_registry;
	ME = "rcprm_registry_mgr_$delete_registry";

	call suffixed_name_$make (p_registry_entry, REGISTRY_OLD_SUFFIX, registry_name, code);
	if code ^= 0 then
	     goto error_return;

	call hcs_$get_dir_ring_brackets (registry_dir, registry_name, dir_rbs, code);
	if code ^= 0 then
	     goto error_return;

	if (dir_rbs (1) ^= cur_ring) | (dir_rbs (2) ^= cur_ring) then do;
	     code = error_table_$not_seg_type;
	     goto error_return;
	end;

	call rcprm_registry_util_$grab_registry_old (switch_ptr, registry_dir, registry_name, code);
	if code ^= 0 then
	     goto error_return;

	call iox_$seek_key (switch_ptr, (REGISTRY_HEADER_KEY), 0, code);
	if code ^= 0 then				/* this may not be a registry, or it */
	     call admin_gate_$syserr (BEEP,		/* may just be a screwed-up registry */
		"rcprm_registry_mgr_$delete_registry:  Deleting (possibly bogus) registry ^a for ^a.",
		pathname_ (registry_dir, registry_name), get_group_id_ ());
						/* so be a suspicious bugger */

	call rcprm_registry_util_$release_registry (switch_ptr, code);
	if code ^= 0 then
	     goto error_return;

	call delete_$path (registry_dir, registry_name, "101100"b /* force, brief, dir or seg, no chase */,
	     "rcprm_registry_mgr_", code);
	if code ^= 0 then
	     goto error_return;

	goto good_return;

remove_registry:
     entry (p_registry_dir, p_registry_entry, p_code);

dcl	hcs_$chname_file	   entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl	suffixed_name_$new_suffix
			   entry (char (*), char (*), char (*), char (32), fixed bin (35));

dcl	new_name		   char (32);

	registry_dir = p_registry_dir;
	call cu_$level_get (prev_level);

	on cleanup call clean_up;

	cur_ring = get_ring_ ();
	call cu_$level_set (cur_ring);

	operation = ""b;
	ME = "rcprm_registry_mgr_$remove_registry";

	call suffixed_name_$make (p_registry_entry, REGISTRY_SUFFIX, registry_name, code);
	if code ^= 0 then
	     goto error_return;

	call suffixed_name_$new_suffix (registry_name, REGISTRY_SUFFIX, REGISTRY_OLD_SUFFIX, new_name, code);
	if code ^= 0 then
	     goto error_return;

	call hcs_$chname_file (registry_dir, registry_name, registry_name, new_name, code);
	if code ^= 0 then
	     goto error_return;

	goto good_return;

copy_registry:
     entry (p_registry_dir, p_registry_names, p_target_dir, p_target_names, p_error_msg, p_reset_journal_sw, p_code);

/* This entry copies any number of registries from one directory to another.
   It also allows the caller to delete the old journal and make a fresh one
   after all the registries have been successfully copied.  */

dcl	p_registry_names	   dimension (*) char (*) parameter;
dcl	p_target_names	   dimension (*) char (*) parameter;
dcl	p_target_dir	   char (*) parameter;
dcl	p_error_msg	   char (*) parameter;
dcl	p_reset_journal_sw	   bit (1) parameter;

dcl	target_dir	   char (168);
dcl	target_name	   char (32);
dcl	(registry_path, target_path)
			   char (168);
dcl	regno		   fixed bin;
dcl	(from_msf_fcbp, to_msf_fcbp)
			   pointer initial (null);
dcl	increment		   fixed bin;
dcl	save_uid		   bit (36);
dcl	bc		   fixed bin (24);
dcl	(newsegp, comp1p, to_ptr, from_ptr)
			   pointer;
dcl	copy_message	   char (168);
dcl	missing_component	   fixed bin;
dcl	bit_count		   fixed bin (24);

dcl	1 auto_requestor_info  like requestor_info aligned;
dcl	1 auto_resource_info   like resource_info aligned;
dcl	1 auto_status	   like status_branch automatic aligned;

dcl	based_seg		   bit (bc) aligned based;

dcl	(dim, lbound, hbound, rtrim)
			   builtin;

dcl	(
	error_table_$bad_arg,
	error_table_$no_s_permission,
	error_table_$sameseg
	)		   ext fixed bin (35) static;

dcl	msf_manager_$open	   entry (char (*), char (*), ptr, fixed bin (35));
dcl	msf_manager_$get_ptr   entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24), fixed bin (35));
dcl	msf_manager_$close	   entry (pointer);
dcl	hcs_$set_bc_seg	   entry (ptr, fixed bin (24), fixed bin (35));
dcl	hcs_$status_long	   entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl	rcp_audit		   entry (char (*), bit (36) aligned, ptr, ptr, char (*), bit (3), bit (3),
			   (2) fixed bin (3), bit (1), bit (1), fixed bin (35));
dcl	rcprm_journalize_$make_fresh_journal
			   ext entry (char (*), fixed bin (35));

	registry_dir = p_registry_dir;
	target_dir = p_target_dir;
	if dim (p_registry_names, 1) ^= dim (p_target_names, 1)
	     | lbound (p_registry_names, 1) ^= lbound (p_target_names, 1) then do;
	     error_msg = "Dimensions of arrays do not match";
	     code = error_table_$bad_arg;
	     return;
	end;

	call cu_$level_get (prev_level);
	on cleanup call clean_up;

	cur_level = get_ring_ ();
	call cu_$level_set (cur_level);

	operation = access_operations_$rcp_copy_registry;
	ME = "rcprm_registry_mgr_$copy_registry";

/* lock the transaction file so no one can update registries while we are
   trying to copy them.  Note that if
   there is no transaction file, we won't require one (user can be copying
   registries from any dir, not just system dir-- in fact, user may be copying
   registries back INTO the system dir).  If there is no transaction file in
   the system dir, we will try the target dir just in case the user IS copying
   registries back into the system dir (although he SHOULDN'T be doing this
   except in special session!!) */

	error_msg = "rcp.tcf in " || registry_dir;
	call rcprm_registry_util_$grab_transaction_control_file (tcf_switch_ptr, registry_dir, code);
	if code ^= 0 then do;			/* locate failed, try target dir? */
	     error_msg = "rcp.tcf in " || target_dir;
	     call rcprm_registry_util_$grab_transaction_control_file (tcf_switch_ptr, target_dir, code);
	     if code ^= 0 then do;
		tcf_switch_ptr = null ();
		error_msg = "No rcp.tcf. ";
	     end;
	end;					/* if neither exists, so what. */

	do regno = lbound (p_registry_names, 1) to hbound (p_registry_names, 1);

	     registry_name = p_registry_names (regno);
	     call suffixed_name_$make (registry_name, REGISTRY_SUFFIX, registry_name, code);
	     if code ^= 0 then
		call return_error_msg (pathname_ (registry_dir, registry_name));

	     target_name = p_target_names (regno);
	     call suffixed_name_$make (target_name, REGISTRY_SUFFIX, target_name, code);
	     if code ^= 0 then
		call return_error_msg (pathname_ (target_dir, target_name));

	     registry_path = pathname_ (registry_dir, registry_name);
	     target_path = pathname_ (target_dir, target_name);

	     call hcs_$status_long (registry_dir, registry_name, 1,
						/* chase */
		addr (auto_status), null, code);
	     if code = error_table_$no_s_permission then
		code = 0;
	     else if code ^= 0 then
		call return_error_msg (registry_path);

	     save_uid = auto_status.uid;
	     auto_status.uid = ""b;			/* in case next call fails */

	     call hcs_$status_long (target_dir, target_name, 1,
						/* chase */
		addr (auto_status), null, code);
	     if code = error_table_$no_s_permission then
		code = 0;
	     else if code = error_table_$noentry then
		code = 0;
	     else if code ^= 0 then
		call return_error_msg (target_path);

	     if auto_status.uid = save_uid then do;
		code = error_table_$sameseg;
		call return_error_msg (registry_path);
	     end;

	     call delete_$path (target_dir, target_name, "101111"b, "rcprm_registry_mgr_", code);
						/* delete everything and don't ask questions */
	     if code = error_table_$noentry then
		code = 0;				/* ok, wasn't there */
	     if code ^= 0 then
		call return_error_msg (target_path);

	     call fillin_cbi;

	     call hcs_$create_branch_ (target_dir, target_name, addr (cbi), code);
	     if code ^= 0 then
		call return_error_msg (target_path);

/* Now we have a properly AIM'ed, ACL'ed and ring'ed registry.  Now use
   msf_manager_ to do the drudge work. */

	     call msf_manager_$open (registry_dir, registry_name, from_msf_fcbp, code);
	     if code ^= 0 then
		call return_error_msg (registry_path);

	     call msf_manager_$open (target_dir, target_name, to_msf_fcbp, code);
	     if code ^= 0 then
		call return_error_msg (target_path);

	     call msf_manager_$get_ptr (to_msf_fcbp, 0, "1"b, newsegp, 0, code);
	     if code ^= 0 then
		call return_error_msg (target_path);
	     call msf_manager_$get_ptr (to_msf_fcbp, 1, "1"b, comp1p, 0, code);
						/* this is to make it an MSF right away */
						/* Don't ask me why, but copy_seg_ does it this way */
	     if code ^= 0 then
		call return_error_msg (target_path);

	     call hcs_$status_minf (registry_dir, registry_name, 1, 2, bit_count, code);
	     if code ^= 0 then
		call return_error_msg (registry_path);
	     copy_message = "Missing Component(s) ";
	     missing_component = -1;			/* Since component 0 is valid */
	     do increment = 0 to (bit_count - 1);
		call msf_manager_$get_ptr (from_msf_fcbp, increment, "0"b, from_ptr, bc, code);
		if code = error_table_$noentry then do;
		     copy_message = rtrim (copy_message) || " " || ltrim (char (increment));
		     missing_component = increment;
		     code = 0;
		end;
		if code = 0 then do;
		     if increment = 0 then
			to_ptr = newsegp;
		     else if increment = 1 then
			to_ptr = comp1p;
		     else call msf_manager_$get_ptr (to_msf_fcbp, increment, "1"b, to_ptr, 0, code);
		     if code ^= 0 then
			call return_error_msg (target_path);

		     to_ptr -> based_seg = from_ptr -> based_seg;

		     call hcs_$set_bc_seg (to_ptr, bc, code);
		     if code ^= 0 then
			call return_error_msg (target_path);
		end;
	     end;

	     call msf_manager_$close (from_msf_fcbp);
	     from_msf_fcbp = null;

	     call msf_manager_$close (to_msf_fcbp);
	     to_msf_fcbp = null;
	end;

/* Great.  We got this far with no errors.  Reset the journal if we've been asked. */

	if p_reset_journal_sw then do;
	     call rcprm_journalize_$make_fresh_journal (registry_dir, code);
	     if code ^= 0 then
		call return_error_msg ("Resetting journal in " || pathname_ (registry_dir, JOURNALS_DIR_ENTRYNAME));
	end;
	if missing_component >= 0 then do;
	     copy_message = rtrim (copy_message) || " - null component(s) created in new registry.";
	     error_msg = error_msg || copy_message;
	     code = error_table_$rcp_missing_registry_component;
	     call return_error_msg (error_msg);
	end;

	goto good_return;

/* Routine to fill in create_branch_info */

fillin_cbi:
     proc;

	unspec (cbi) = ""b;
	cbi.version = create_branch_version_2;
	cbi.priv_upgrade_sw = (cur_level = 1);		/* want this to be a multiclass seg */
	cbi.parent_ac_sw = ^cbi.priv_upgrade_sw;
	cbi.mode = RW_ACCESS;
	cbi.rings (*) = cur_level;
	cbi.userid = ALL_USERS;
	cbi.access_class = sys_info$access_class_ceiling;

     end fillin_cbi;

audit:
     entry (a_ME, a_operation, a_prev_level, a_reg_dir, a_reg_name, a_success, a_code);

dcl	a_ME		   char (*);
dcl	a_operation	   bit (36) aligned;
dcl	a_prev_level	   fixed bin;
dcl	a_reg_dir		   char (*);
dcl	a_reg_name	   char (*);
dcl	a_success		   bit (1);
dcl	a_code		   fixed bin (35);


	ME = a_ME;
	operation = a_operation;
	prev_level = a_prev_level;
	registry_dir = a_reg_dir;
	registry_name = a_reg_name;
	code = a_code;
	if a_success then
	     call audit_success ();
	else call audit_failure ();

	return;
%page;
audit_success:
     proc;

dcl	raw_mode		   bit (3);
dcl	rbs		   (2) fixed bin (3);
	raw_mode = N_ACCESS;
	rbs = 0;
	rbs (1) = -1;

	if operation = ""b then
	     return;				/* no auditable event */

	call setup_audit (raw_mode);
	call rcp_audit (ME, operation, requestor_info_ptr, resource_info_ptr, "", RW_ACCESS, raw_mode, rbs, "1"b, "0"b,
	     (0));

     end audit_success;

audit_failure:
     proc;

dcl	raw_mode		   bit (3);
dcl	rbs		   (2) fixed bin (3);
	raw_mode = N_ACCESS;
	rbs = 0;
	rbs (1) = -1;

	if operation = ""b then
	     return;

	call setup_audit (raw_mode);
	call rcp_audit (ME, operation, requestor_info_ptr, resource_info_ptr, "", N_ACCESS, raw_mode, rbs, "1"b, "0"b,
	     code);

     end audit_failure;

setup_audit:
     proc (a_raw_mode);

dcl	a_raw_mode	   bit (3);
dcl	temp_mode		   bit (36) aligned;
dcl	local_code	   fixed bin (35);

dcl	hcs_$get_user_raw_mode entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35));
dcl	pathname_		   entry (char (*), char (*)) returns (char (168));
	local_code = 0;

/* Set up the requestor information */

	requestor_info_ptr = addr (auto_requestor_info);
	requestor_info.user_id = get_group_id_ ();
	requestor_info.current_authorization = get_process_authorization_ ();
	requestor_info.validation_level = prev_level;

/* Set up the resource information. */

	resource_info_ptr = addr (auto_resource_info);
	resource_info.registry_dir = registry_dir;
	resource_info.registry_switch_ptr = null ();
	resource_info.registry_record_ptr = null ();
	resource_info.resource_type = registry_name;
	resource_info.resource_name = "";

/* Set up the operation. */

	addr (addr (operation) -> encoded_access_op.detailed_operation) -> detailed_operation.priv_gate_call = "1"b;

/* Since we don't call the kernel, set up the raw mode for auditing */
/* purposes only. */

	call hcs_$get_user_raw_mode ((pathname_ (rtrim (registry_dir), registry_name)), "", (requestor_info.user_id),
	     temp_mode, local_code);
	if local_code ^= 0 then
	     a_raw_mode = ""b;
	else a_raw_mode = substr (temp_mode, 1, 3);

     end setup_audit;

return_error_msg:
     proc (message);

dcl	message		   char (*);

	p_error_msg = message;
	goto error_return;

     end return_error_msg;

clean_up:
     proc;

	if from_msf_fcbp ^= null then
	     call msf_manager_$close (from_msf_fcbp);

	if to_msf_fcbp ^= null then
	     call msf_manager_$close (to_msf_fcbp);

	if switch_ptr ^= null then
	     call rcprm_registry_util_$release_registry (switch_ptr, (0));

	if tcf_switch_ptr ^= null then
	     call rcprm_registry_util_$release_transaction_control_file (tcf_switch_ptr, (0));

	call cu_$level_set (prev_level);

     end clean_up;

%include access_mode_values;
%page;
%include rcp_registry;
%page;
%include rcprm_registry_keys;
%page;
%include iox_dcls;
%page;
%include iox_modes;
%page;
%include create_branch_info;
%page;
%include rcp_requestor_info;
%include rcp_resource_info;
%page;
%include access_audit_encoded_op;
%include rcp_ops;
%page;
%include status_structures;
%page;
%include syserr_constants;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   rcprm_registry_mgr_$delete_registry: Deleting (possibly bogus) registry PATH for USERID.

   S:	$beep

   T:	$run

   M:	The segment at PATH does not seem to be an RCP registry.  It may
   simply be a damaged registry, or a user may be attempting to use
   delete_registry to delete a non-registry object.

   A:	$contact_sa


   END MESSAGE DOCUMENTATION */

     end rcprm_registry_mgr_;




		    rcprm_registry_util_.pl1        11/11/89  1111.8r w 11/11/89  0808.7      100899



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */
/* Various common operations on RCP registries. */
/* Written January 1985 by Chris Jones */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcprm_registry_util_:
     proc;

	return;

dcl	p_code		   fixed bin (35) parameter;	/* (O) status code */
dcl	p_gk_header_ptr	   ptr;			/* (I) pointer to a gk_header structure to be filled in */
dcl	p_iocb_ptr	   ptr;			/* (I/O) pointer to an IOCB we're manipulating */
dcl	p_key		   char (*) parameter;	/* (O) the key we construct */
dcl	p_owner		   char (*) parameter;	/* (I) the owner for whom we will construct a key */
dcl	p_privileges_string	   bit (36) aligned parameter;/* (I/O) privileges that were on before we diddled them */
dcl	p_project		   char (*) parameter;	/* (I) the project for whome we will construct a key */
dcl	p_record_ptr	   ptr;			/* (O) pointer to a registry record */
dcl	p_registry_dir	   char (*) parameter;	/* (I) directory registries are stored in */
dcl	p_resource_type	   char (*) parameter;	/* (I) resource type (for knowing which registry to use) */
dcl	p_resource_name	   char (*) parameter;	/* (I) name of a resource */
dcl	p_uid		   bit (36) aligned parameter;/* (I) UID of a resource */

dcl	1 cbi		   like create_branch_info aligned automatic;
dcl	code		   fixed bin (35);
dcl	create_sw		   bit (1) aligned;
dcl	cur_level		   fixed bin;
dcl	i		   fixed bin;
dcl	io_module		   char (32);
dcl	iocb_ptr		   ptr;
dcl	registry_dir	   char (168);
dcl	resource_name	   char (32);
dcl	resource_type	   char (32);
dcl	suffix		   char (4);
dcl	temp_string	   char (256);

dcl	1 get_key_info	   aligned,
	  2 header	   like gk_header,
	  2 key		   char (40) unaligned;

dcl	1 record_status	   like rs_info aligned;

dcl	Relative_useconds	   bit (2) initial ("10"b) static options (constant);
dcl	Sleep_times	   (5) fixed bin (71) static options (constant) initial (.25f6, .50f6, .75f6, 1.5f6, 3.0f6);
dcl	TRANSACTION_CONTROL_FILE_NAME
			   char (7) static options (constant) init ("rcp.tcf");

dcl	admin_gate_$reset_privileges
			   entry (bit (36) aligned);
dcl	admin_gate_$set_privileges
			   entry (bit (36) aligned, bit (36) aligned);
dcl	cu_$level_get	   entry (fixed bin);
dcl	hcs_$create_branch_	   entry (char (*), char (*), ptr, fixed bin (35));
dcl	ioa_$rsnnl	   entry () options (variable);
dcl	pathname_		   entry (char (*), char (*)) returns (char (168));
dcl	suffixed_name_$make	   entry (char (*), char (*), char (32), fixed bin (35));
dcl	timer_manager_$sleep   entry (fixed bin (71), bit (2));
dcl	unique_chars_	   entry (bit (*)) returns (char (15));

dcl	error_table_$file_busy fixed bin (35) ext static;
dcl	error_table_$lock_wait_time_exceeded
			   fixed bin (35) ext static;

dcl	sys_info$access_class_ceiling
			   bit (72) aligned ext static;
dcl	sys_info$dir_privilege bit (36) aligned ext static;

dcl	cleanup		   condition;

dcl	(addr, after, before, hbound, lbound, length, null, rtrim, unspec)
			   builtin;

free_key:
     entry (p_gk_header_ptr, p_key);

	call init_gk_header;
	call set_full_key (REGISTRY_FREE_KEY);
	return;

name_key:
     entry (p_resource_name, p_gk_header_ptr, p_key);

	call init_gk_header;
	call set_full_key (REGISTRY_NAME_KEY_HEAD || rtrim (p_resource_name));
	return;

owner_key:
     entry (p_owner, p_gk_header_ptr, p_key);

	call init_gk_header;
	call set_full_key (REGISTRY_OWNER_KEY_HEAD || flip_person_and_project (p_owner));
	return;

project_key:
     entry (p_project, p_gk_header_ptr, p_key);

	call init_gk_header;
	call set_partial_key (REGISTRY_OWNER_KEY_HEAD || rtrim (p_project) || ".");
	return;

skeleton_key:
     entry (p_gk_header_ptr, p_key);

	call init_gk_header;
	call set_partial_key (REGISTRY_NAME_KEY_HEAD);
	return;

skeleton_acquisition_key:
     entry (p_gk_header_ptr, p_key);

	call init_gk_header;
	call set_partial_key (REGISTRY_OWNER_KEY_HEAD);
	return;

system_key:
     entry (p_gk_header_ptr, p_key);

	call init_gk_header;
	call set_full_key (REGISTRY_SYSTEM_KEY);
	return;

uid_key:
     entry (p_uid, p_gk_header_ptr, p_key);

	call init_gk_header;
	call ioa_$rsnnl ("^a^w", temp_string, (0), REGISTRY_UID_KEY_HEAD, p_uid);
	call set_full_key (rtrim (temp_string));
	return;

create_transaction_control_file:
     entry (p_registry_dir, p_code);

	registry_dir = p_registry_dir;
	iocb_ptr = null ();
	call fillin_cbi;
	call hcs_$create_branch_ (registry_dir, TRANSACTION_CONTROL_FILE_NAME, addr (cbi), code);
	if code ^= 0 then
	     goto CREATE_TCF_RETURN;

/* Make this file be an MSF by creating and deleting an arbitrary record */

	call grab_transaction_control_file_create (iocb_ptr, registry_dir, code);
	if code ^= 0 then
	     goto CREATE_TCF_RETURN;

/* force this file into an MSF by creating and deleting an arbitrary record. */

	call iox_$seek_key (iocb_ptr, "garbage", (0), (0));
	call iox_$write_record (iocb_ptr, addr (iocb_ptr), 8, code);
	if code ^= 0 then
	     goto CREATE_TCF_RETURN;
	call iox_$delete_record (iocb_ptr, code);
	if code ^= 0 then
	     goto CREATE_TCF_RETURN;

CREATE_TCF_RETURN:
	call toss_iocb (iocb_ptr);
	p_code = code;
	return;

grab_transaction_control_file:
     entry (p_iocb_ptr, p_registry_dir, p_code);

	create_sw = "0"b;
	goto GRAB_TCF_COMMON;

grab_transaction_control_file_create:
     entry (p_iocb_ptr, p_registry_dir, p_code);

	create_sw = "1"b;

GRAB_TCF_COMMON:
	registry_dir = p_registry_dir;
	call ioa_$rsnnl ("vfile_ ^a^[ -old^] -exclusive", temp_string, (0),
	     pathname_ (registry_dir, TRANSACTION_CONTROL_FILE_NAME), ^create_sw);
	iocb_ptr = null ();

	on cleanup call toss_iocb (iocb_ptr);

	call iox_$attach_name ("rcp_transactions_", iocb_ptr, temp_string, null (), code);
	if code ^= 0 then
	     goto GRAB_TCF_RETURN;

	code = error_table_$file_busy;
	do i = lbound (Sleep_times, 1) to hbound (Sleep_times, 1) while (code = error_table_$file_busy);
	     call iox_$open (iocb_ptr, Keyed_sequential_update, "0"b, code);
	     if code = error_table_$file_busy then
		call timer_manager_$sleep (Sleep_times (i), Relative_useconds);
	end;

	if code = error_table_$file_busy then
	     code = error_table_$lock_wait_time_exceeded;
	if code ^= 0 then
	     call toss_iocb (iocb_ptr);

GRAB_TCF_RETURN:
	p_iocb_ptr = iocb_ptr;
	p_code = code;
	return;

release_transaction_control_file:
     entry (p_iocb_ptr, p_code);

release_registry:
     entry (p_iocb_ptr, p_code);

	iocb_ptr = p_iocb_ptr;
	call iox_$close (iocb_ptr, code);
	if code ^= 0 then
	     goto RELEASE_TCF_RETURN;
	call iox_$detach_iocb (iocb_ptr, code);
	if code ^= 0 then
	     goto RELEASE_TCF_RETURN;
	call iox_$destroy_iocb (p_iocb_ptr, code);

RELEASE_TCF_RETURN:
	p_code = code;
	return;

grab_registry:
     entry (p_iocb_ptr, p_registry_dir, p_resource_type, p_code);

	create_sw = "0"b;
	io_module = "rcprm_journal_file_";
	suffix = "rcpr";
	goto GRAB_REGISTRY_COMMON;

grab_registry_no_journalize:
     entry (p_iocb_ptr, p_registry_dir, p_resource_type, p_code);

	create_sw = "0"b;
	io_module = "vfile_";
	suffix = "rcpr";
	goto GRAB_REGISTRY_COMMON;

grab_registry_old:
     entry (p_iocb_ptr, p_registry_dir, p_resource_type, p_code);

	create_sw = "0"b;
	io_module = "rcprm_journal_file_";
	suffix = "old";
	goto GRAB_REGISTRY_COMMON;

grab_registry_create:
     entry (p_iocb_ptr, p_registry_dir, p_resource_type, p_code);

	create_sw = "1"b;
	io_module = "rcprm_journal_file_";
	suffix = "rcpr";

GRAB_REGISTRY_COMMON:
	registry_dir = p_registry_dir;
	resource_type = p_resource_type;
	iocb_ptr = null ();
	on cleanup call toss_iocb (iocb_ptr);

	call suffixed_name_$make (resource_type, suffix, resource_type, code);
	if code ^= 0 then
	     goto GRAB_REGISTRY_RETURN;

	call ioa_$rsnnl ("^a ^a ^[-old ^]-exclusive -stationary -dup_ok", temp_string, (0), io_module,
	     pathname_ (registry_dir, resource_type), ^create_sw);

	call iox_$attach_name (unique_chars_ ("0"b), iocb_ptr, temp_string, null (), code);
	if code ^= 0 then
	     goto GRAB_REGISTRY_RETURN;

	call iox_$open (iocb_ptr, Keyed_sequential_update, "0"b, code);

GRAB_REGISTRY_RETURN:
	if code ^= 0 then
	     call toss_iocb (iocb_ptr);
	p_iocb_ptr = iocb_ptr;
	p_code = code;
	return;

find_resource_record:
     entry (p_iocb_ptr, p_resource_name, p_record_ptr, p_code);

	iocb_ptr = p_iocb_ptr;
	resource_name = p_resource_name;
	call name_key (resource_name, addr (get_key_info.header), get_key_info.key);
	unspec (record_status) = ""b;
	record_status.version = rs_info_version_2;
	record_status.record_ptr = null ();
	call iox_$control (iocb_ptr, "get_key", addr (get_key_info), code);
	if code ^= 0 then
	     goto find_record_return;

	call iox_$control (iocb_ptr, "record_status", addr (record_status), code);

find_record_return:
	p_record_ptr = record_status.record_ptr;
	p_code = code;
	return;

turn_on_privs:
     entry (p_privileges_string);

	call admin_gate_$set_privileges (sys_info$dir_privilege, p_privileges_string);
	return;

turn_off_privs:
     entry (p_privileges_string);

	call admin_gate_$reset_privileges (p_privileges_string);
	return;

init_gk_header:
     proc;

	gk_info_ptr = p_gk_header_ptr;
	if gk_info_ptr ^= null () then do;
	     unspec (gk_header) = ""b;		/* start clean */
	     gk_header.version = gk_info_version_0;
	     gk_header.input_key = "1"b;
	end;

     end init_gk_header;

set_full_key:
     proc (key);

dcl	key		   char (*) varying parameter;

	if gk_info_ptr ^= null () then
	     gk_header.head_size, gk_header.key_len = length (p_key);
	p_key = key;
	return;

set_partial_key:
     entry (key);

	if gk_info_ptr ^= null () then
	     gk_header.head_size, gk_header.key_len = length (key);
	p_key = key;

     end set_full_key;

flip_person_and_project:
     proc (personid) returns (char (*));

dcl	personid		   char (*) parameter;

	return (before (after (rtrim (personid), "."), ".") || "." || before (personid, "."));

     end flip_person_and_project;

toss_iocb:
     proc (iocb_ptr);

dcl	iocb_ptr		   ptr;

	if iocb_ptr ^= null () then do;
	     call iox_$close (iocb_ptr, (0));
	     call iox_$detach_iocb (iocb_ptr, (0));
	     call iox_$destroy_iocb (iocb_ptr, (0));
	end;
	iocb_ptr = null ();

     end toss_iocb;

fillin_cbi:
     proc;

	call cu_$level_get (cur_level);
	unspec (cbi) = ""b;
	cbi.version = create_branch_version_2;
	cbi.priv_upgrade_sw = (cur_level = 1);		/* want this to be a multiclass seg */
	cbi.parent_ac_sw = ^cbi.priv_upgrade_sw;
	cbi.mode = RW_ACCESS;
	cbi.rings (*) = cur_level;
	cbi.userid = "*.*.*";
	cbi.access_class = sys_info$access_class_ceiling;

     end fillin_cbi;

%include rcprm_registry_keys;
%page;
%include ak_info;
%page;
%include rs_info;
%page;
%include iox_dcls;
%page;
%include iox_modes;
%page;
%include create_branch_info;
%page;
%include access_mode_values;
%page;

     end rcprm_registry_util_;




		    rcprm_verify_registries_.pl1    11/11/89  1111.8rew 11/11/89  0806.7       33732



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




/****^  HISTORY COMMENTS:
  1) change(87-06-25,Rauschelbach), approve(87-06-29,MCR7736),
     audit(87-07-21,Farley), install(87-08-06,MR12.1-1063):
     System error message documentation was added. Also set
     RTDT_area_len.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rcprm_verify_registries_:
     proc (p_sysdir, p_code);

dcl	p_sysdir		   char (*) parameter;
dcl	p_code		   fixed bin (35) parameter;

/* automatic */

dcl	caller_ring	   fixed bin;
dcl	code		   fixed bin (35);
dcl	error_occurred	   bit (1) initial (""b) aligned;
dcl	registry_dir	   char (168);
dcl	sysdir		   char (168);

/* builtins and conditions */

dcl	(null, pointer)  builtin;

dcl	cleanup		   condition;

/* entries */

dcl	admin_gate_$syserr_error_code
			   ext entry options (variable);
dcl	(
	cu_$level_set,
	cu_$level_get
	)		   ext entry (fixed bin);
dcl	get_ring_		   ext entry returns (fixed bin);
dcl	initiate_file_	   entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl	pathname_		   entry (char (*), char (*)) returns (char (168));
dcl	rcprm_registry_mgr_$validate_registry
			   ext entry (char (*), pointer, fixed bin (35));
dcl       sys_info$max_seg_size  fixed bin(35) ext static;
dcl	terminate_file_	   entry (ptr, fixed bin (24), bit (*), fixed bin (35));

/* external static */

dcl	error_table_$action_not_performed
			   ext fixed bin (35) static;

	sysdir = p_sysdir;
	call cu_$level_get (caller_ring);
	rtdtp = null ();

	on cleanup call clean_up;

	call cu_$level_set (get_ring_ ());

	RTDT_area_len = sys_info$max_seg_size - 32; /* Size of author info is 28, and there are four words before it in rtdt. */

	call initiate_file_ (sysdir, "rtdt", R_ACCESS, rtdtp, (0), code);
	if code ^= 0 then
	     goto returner;

	registry_dir = pathname_ (sysdir, "rcp");

	do rtdep = pointer (rtdt.first_resource, rtdt.rtdt_area)
	     repeat pointer (rtde.next_resource, rtdt.rtdt_area) while (rtdep ^= null);

	     if rtde.valid then
		if ^rtde.is_synonym then do;
		     call rcprm_registry_mgr_$validate_registry (registry_dir, rtdep, code);
		     if code ^= 0 then do;
			call admin_gate_$syserr_error_code (BEEP, code, "rcprm_verify_registries_: ^a.rcpr",
			     pathname_ (registry_dir, (rtde.name)));
			error_occurred = "1"b;
		     end;
		end;
	end;

	if error_occurred then
	     code = error_table_$action_not_performed;
	else code = 0;

returner:
	call clean_up;
	p_code = code;
	return;

clean_up:
     proc;

	if rtdtp ^= null () then
	     call terminate_file_ (rtdtp, 0, TERM_FILE_TERM, (0));
	call cu_$level_set (caller_ring);

     end clean_up;

%include access_mode_values;
%page;
%include rtdt;
%page;
%include syserr_constants;
%page;
%include terminate_file;

     end rcprm_verify_registries_;
/* BEGIN MESSAGE DOCUMENTATION

   Message: rcprm_verify_registries_: REGISTRY.rcpr

   S:     $beep

   T:     $run

   M:     There is an error in the named registry.

   A:     $contact_sa

   END MESSAGE DOCUMENTATION */





		    record_status.pl1               11/11/89  1111.8r w 11/11/89  0806.0       36063



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


/* Written by Lindsey Spratt, most likely */
/* Modified by Chris Jones, February 1985, to use privileges and to clean up. */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
record_status:
     proc (p_journal_control_block_ptr, p_info_ptr, p_code);

/* Parameter */

dcl	p_journal_control_block_ptr
			   ptr;
dcl	p_info_ptr	   ptr;
dcl	p_code		   fixed bin (35);

/* Automatic */

dcl	privileges_string	   bit (36) aligned;
dcl	temp_key		   char (256) varying;

/* Based */

dcl	dummy_record	   char (rs_info.record_length) based (rs_info.record_ptr);

/* Builtin */

dcl	length		   builtin;
dcl	null		   builtin;

/* Condition */

dcl	cleanup		   condition;

/* External */

dcl	rcprm_registry_util_$turn_off_privs
			   entry (bit (36) aligned);
dcl	rcprm_registry_util_$turn_on_privs
			   entry (bit (36) aligned);

dcl	error_table_$locked_by_this_process
			   fixed bin (35) ext;

	journal_control_block_ptr = p_journal_control_block_ptr;
	rs_info_ptr = p_info_ptr;
	privileges_string = ""b;

	on cleanup call clean_up;

	call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
	     call clean_up;
	     return;
	end;

	if rs_info.lock_sw then
	     if rs_info.create_sw then do;
		if ^rs_info.locate_sw then do;
		     call iox_$read_key (journal_control_block.vfile_iocb_ptr, temp_key, 0, p_code);
		     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
			call clean_up;
			return;
		     end;

		     a_key_len = length (temp_key);
		end;

		else a_key_len = 0;

		a_rec_len = 0;

		allocate journal_entry in (journal_area);

		if a_key_len > 0 then
		     journal_entry.key_str = temp_key;
		journal_entry.type = RS_LOCK_CREATE;
	     end;

	     else if rs_info.inc_ref_count | rs_info.dec_ref_count then do;
		a_rec_len = rs_info.record_length;
		a_key_len = 0;

		allocate journal_entry in (journal_area);

		journal_entry.inc_ref_count = rs_info.inc_ref_count;
		journal_entry.dec_ref_count = rs_info.dec_ref_count;
		journal_entry.rec_str = dummy_record;
		journal_entry.type = RS_LOCK_COUNT;
	     end;

	     else do;
		a_rec_len = rs_info.record_length;
		a_key_len = 0;

		allocate journal_entry in (journal_area);

		journal_entry.rec_str = dummy_record;
		journal_entry.type = RS_LOCK;
	     end;

	else if rs_info.inc_ref_count | rs_info.dec_ref_count then do;
	     a_rec_len, a_key_len = 0;

	     allocate journal_entry in (journal_area);

	     journal_entry.inc_ref_count = rs_info.inc_ref_count;
	     journal_entry.dec_ref_count = rs_info.dec_ref_count;

	     journal_entry.type = RS_COUNT;
	end;

	else do;
	     call clean_up;
	     return;
	end;

	journal_entry.descriptor = rs_info.descriptor;
	journal_entry.next_ptr = null;
	journal_entry.prev_ptr = journal_control_block.latest_entry_ptr;
	if journal_control_block.latest_entry_ptr ^= null then
	     journal_control_block.latest_entry_ptr -> journal_entry.next_ptr = journal_entry_ptr;
	journal_control_block.latest_entry_ptr = journal_entry_ptr;
	call clean_up;
	return;

clean_up:
     proc;

	call rcprm_registry_util_$turn_off_privs (privileges_string);

     end clean_up;

%include journal_entry;
%include journal_control_block;
%include rs_info;
%include iox_dcls;
     end;




		    rollback.pl1                    11/11/89  1111.8r w 11/11/89  0806.7       85320



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
rollback:
     proc (p_journal_control_block_ptr, p_code);

/* Walk through the journal, starting at the latest entry and following the
   previous pointers.  At each entry, undo what that entry did.

   Written  by  Lindsey Spratt 08/06/79
   Modified by Chris Jones 02/14/85 to use privileges and to clean up properly.
*/
/* Parameter */

dcl	p_journal_control_block_ptr
			   ptr;
dcl	p_code		   fixed bin (35);


/* Automatic */

dcl	privileges_string	   bit (36) aligned;
dcl	scratch_area_ptr	   ptr;

/* Based */

dcl	scratch_area	   area (4096) based (scratch_area_ptr);

/* Builtin */

dcl	addr		   builtin;
dcl	length		   builtin;
dcl	null		   builtin;

/* Condition */

dcl	cleanup		   condition;

/* Entry */

dcl	get_system_free_area_  entry returns (ptr);
dcl	rcprm_registry_util_$turn_off_privs
			   entry (bit (36) aligned);
dcl	rcprm_registry_util_$turn_on_privs
			   entry (bit (36) aligned);

/* External */

dcl	error_table_$locked_by_this_process
			   fixed bin (35) ext;

	journal_control_block_ptr = p_journal_control_block_ptr;
	scratch_area_ptr = get_system_free_area_ ();

	journal_entry_ptr = journal_control_block.latest_entry_ptr;
	ak_info_ptr, gk_info_ptr, rs_info_ptr = null ();
	privileges_string = ""b;
	on cleanup call clean_up;

	call rcprm_registry_util_$turn_on_privs (privileges_string);
	do while (journal_entry_ptr ^= null);

	     goto ENTRY_TYPE (journal_entry.type);

ENTRY_TYPE (1):					/* RS_LOCK */
	     allocate rs_info in (scratch_area);
	     rs_info.version = rs_info_version_2;
	     rs_info.locate_sw = "1"b;
	     rs_info.descriptor = journal_entry.descriptor;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     call iox_$rewrite_record (journal_control_block.vfile_iocb_ptr, addr (journal_entry.rec_str),
		journal_entry.rec_len, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;
	     rs_info.lock_sw = "0"b;
	     rs_info.unlock_sw = "1"b;

	     rs_info.locate_sw = "0"b;
	     rs_info.inc_ref_count = "0"b;
	     rs_info.dec_ref_count = "0"b;
	     call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);

	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     free rs_info;
	     goto NEXT;

ENTRY_TYPE (2):					/* write_record */
	     gk_key_len = journal_entry.key_len;
	     alloc gk_info in (scratch_area);
	     gk_info.key = journal_entry.key_str;
	     gk_info.descrip = journal_entry.descriptor;
	     gk_info.input_desc = "1"b;
	     gk_info.input_key = "1"b;
	     gk_info.rel_type = 0;
	     gk_info.head_size = journal_entry.key_len;
	     gk_info.reset_pos = "0"b;
	     gk_info.version = gk_info_version_0;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "get_key", gk_info_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     call iox_$delete_record (journal_control_block.vfile_iocb_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     free gk_info;
	     goto NEXT;

ENTRY_TYPE (3):					/* delete_record */
	     ak_key_len = journal_entry.key_len;
	     alloc ak_info in (scratch_area);

	     ak_info.input_key = "1"b;
	     ak_info.input_desc = "1"b;
	     ak_info.descrip = journal_entry.descriptor;
	     ak_info.key = journal_entry.key_str;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "add_key", ak_info_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     free ak_info;
	     alloc rs_info in (scratch_area);
	     rs_info.locate_sw = "1"b;
	     rs_info.dec_ref_count = "1"b;
	     rs_info.descriptor = journal_entry.descriptor;
	     rs_info.version = rs_info_version_2;
	     call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;
	     free rs_info;
	     goto NEXT;


ENTRY_TYPE (4):					/* add_key */
	     ak_key_len = journal_entry.key_len;
	     alloc ak_info in (scratch_area);
	     ak_info.input_desc = "1"b;
	     ak_info.input_key = "1"b;
	     ak_info.descrip = journal_entry.descriptor;
	     ak_info.key = journal_entry.key_str;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "delete_key", ak_info_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     free ak_info;
	     goto NEXT;


ENTRY_TYPE (5):					/* delete_key */
	     ak_key_len = journal_entry.key_len;
	     alloc ak_info in (scratch_area);
	     ak_info.input_desc = "1"b;
	     ak_info.input_key = "1"b;
	     ak_info.descrip = journal_entry.descriptor;
	     ak_info.key = journal_entry.key_str;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "add_key", ak_info_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     free ak_info;
	     goto NEXT;

ENTRY_TYPE (6):					/* RS_COUNT */
	     allocate rs_info in (scratch_area);

	     rs_info.version = rs_info_version_2;
	     rs_info.locate_sw = "1"b;
	     rs_info.descriptor = journal_entry.descriptor;
	     rs_info.inc_ref_count = journal_entry.dec_ref_count;
	     rs_info.dec_ref_count = journal_entry.inc_ref_count;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	     free rs_info;
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     goto NEXT;

ENTRY_TYPE (7):					/* RS_LOCK_COUNT */
	     allocate rs_info in (scratch_area);

	     rs_info.version = rs_info_version_2;
	     rs_info.locate_sw = "1"b;
	     rs_info.descriptor = journal_entry.descriptor;
	     rs_info.inc_ref_count = journal_entry.dec_ref_count;
	     rs_info.dec_ref_count = journal_entry.inc_ref_count;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     call iox_$rewrite_record (journal_control_block.vfile_iocb_ptr, addr (journal_entry.rec_str),
		length (journal_entry.rec_str), p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     rs_info.locate_sw = "0"b;
	     rs_info.unlock_sw = "1"b;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	     free rs_info;
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then
		return;

	     goto NEXT;

ENTRY_TYPE (8):					/* RS_LOCK_CREATE */
	     if journal_entry.key_len > 0 then do;
		gk_key_len = journal_entry.key_len;

		allocate gk_info in (scratch_area);

		gk_info.version = gk_info_version_0;
		gk_info.input_key = "1"b;
		gk_info.input_desc = "1"b;
		gk_info.descrip = journal_entry.descriptor;
		gk_info.key = journal_entry.key_str;

		call iox_$control (journal_control_block.vfile_iocb_ptr, "get_key", gk_info_ptr, p_code);
		free gk_info;
		if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		     call clean_up;
		     return;
		end;
	     end;

	     allocate rs_info in (scratch_area);

	     rs_info.version = rs_info_version_2;

	     call iox_$control (journal_control_block.vfile_iocb_ptr, "record_status", rs_info_ptr, p_code);
	     free rs_info;
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
		call clean_up;
		return;
	     end;

	     call iox_$delete_record (journal_control_block.vfile_iocb_ptr, p_code);
	     if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then
		return;

	     goto NEXT;

NEXT:
	     journal_entry_ptr = journal_entry.prev_ptr;
	     journal_control_block.latest_entry_ptr = journal_entry_ptr;
	end;
	return;

clean_up:
     proc;

	if ak_info_ptr ^= null () then
	     free ak_info;
	if gk_info_ptr ^= null () then
	     free gk_info;
	if rs_info_ptr ^= null () then
	     free rs_info;
	call rcprm_registry_util_$turn_off_privs (privileges_string);

     end clean_up;

%include journal_entry;
%include journal_control_block;
%include ak_info;
%include rs_info;
%include iox_dcls;
     end;						/* end rollback */




		    write_record.pl1                11/11/89  1111.8r w 11/11/89  0809.2       32967



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
write_record:
     proc (p_journal_control_block_ptr, p_buffer_ptr, p_buffer_len, p_code);

/*  Write the given record at the current position.  Use get_key to
   get the current key and new descriptor, make an entry using this information.

   Written  by  Lindsey Spratt 08/06/79
   Modified by Chris Jones 02/14/85 for setting and resetting privileges, and to
   cleanup properly.
*/
/* Parameter */

dcl	p_journal_control_block_ptr
			   ptr;
dcl	p_buffer_ptr	   ptr;
dcl	p_buffer_len	   fixed bin (21);
dcl	p_code		   fixed bin (35);

/* Automatic */

dcl	privileges_string	   bit (36) aligned;
dcl	scratch_area_ptr	   ptr;

/* Based */

dcl	scratch_area	   area (4096) based (scratch_area_ptr);

/* Controlled */
/* Builtin */

dcl	null		   builtin;

/* Condition */

dcl	cleanup		   condition;

/* Entry */

dcl	get_system_free_area_  entry returns (ptr);
dcl	iox_$write_record	   entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl	iox_$control	   entry (ptr, char (*), ptr, fixed bin (35));
dcl	rcprm_registry_util_$turn_on_privs
			   entry (bit (36) aligned);
dcl	rcprm_registry_util_$turn_off_privs
			   entry (bit (36) aligned);

/* External */

dcl	error_table_$locked_by_this_process
			   fixed bin (35) ext;


	journal_control_block_ptr = p_journal_control_block_ptr;
	privileges_string = ""b;
	gk_info_ptr = null ();
	on cleanup call clean_up;

	call rcprm_registry_util_$turn_on_privs (privileges_string);
	call iox_$write_record (journal_control_block.vfile_iocb_ptr, p_buffer_ptr, p_buffer_len, p_code);

	if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then
	     return;

	gk_key_len = 256;
	scratch_area_ptr = get_system_free_area_ ();
	alloc gk_info in (scratch_area);
	gk_info.input_desc = "0"b;
	gk_info.input_key = "0"b;
	gk_info.current = "1"b;
	gk_info.version = gk_info_version_0;

	call iox_$control (journal_control_block.vfile_iocb_ptr, "get_key", gk_info_ptr, p_code);
	if p_code ^= 0 & p_code ^= error_table_$locked_by_this_process then do;
	     call clean_up;
	     return;
	end;

	a_key_len = gk_info.key_len;
	a_rec_len = 0;
	alloc journal_entry in (journal_area);
	journal_entry.type = WRITE_RECORD;
	journal_entry.key_str = gk_info.key;
	journal_entry.descriptor = gk_info.descrip;
	journal_entry.inc_ref_count = "0"b;
	journal_entry.dec_ref_count = "0"b;
	journal_entry.next_ptr = null;
	journal_entry.prev_ptr = journal_control_block.latest_entry_ptr;
	if journal_control_block.latest_entry_ptr ^= null then
	     journal_control_block.latest_entry_ptr -> journal_entry.next_ptr = journal_entry_ptr;
	journal_control_block.latest_entry_ptr = journal_entry_ptr;
	call clean_up;
	return;

clean_up:
     proc;

	call rcprm_registry_util_$turn_off_privs (privileges_string);
	if gk_info_ptr ^= null () then
	     free gk_info;

     end clean_up;

%include journal_entry;
%include journal_control_block;
%include ak_info;

     end;						/* end write_record */




		    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
