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 =", ("=""" -> "= """). 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