alloc_cb_file.pl1 11/04/82 1940.0rew 11/04/82 1620.6 10368 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ alloc_cb_file: proc (size, cb_ptr); if system_areap = null /* first call this process */ then system_areap = get_system_free_area_ (); allocate cb in (free_area) set (cb_ptr); return; free_cb_file: entry (size, cb_ptr); free cb_ptr -> cb in (free_area); return; dcl size fixed; dcl null builtin; dcl cb_ptr ptr; /* points to the control block to created or freed */ dcl get_system_free_area_ entry () returns (ptr); dcl free_area area based (system_areap); dcl system_areap ptr static init (null); dcl 1 cb based (cb_ptr), 2 cb_words (size) fixed; end alloc_cb_file;  change_index.pl1 11/04/82 1940.0rew 11/04/82 1619.7 278235 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ change_index: proc (iocb_ptr, abort_exit); indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; f_b_ptr = file_base_ptr; fs_ptr = indx_cb.file_state_ptr; is_ptr = indx_cb.index_state_ptr; call initialize_substate; do while (index_action ^= 0); /* the change cycle */ pos_ptr = change_position_ptr; call prepare_next_state; call save_node_head; if index_action = insert_action then do; if last_branch_num = 1 then call insert_at_root; else do; call set_new_cont_space; space = scat_space + new_cont_space; if space < 0 then call overflow; else do; call simple_insert (branch_num); call adjust_branch_num; end; end; end; /* end insert action */ else do; call set_old_key_info; if index_action = delete_action then do; call simple_delete; space = cont_space (node_ptr) + scat_space; if space > half_node_length then call underflow; else call adjust_branch_num; end; /* end delete action */ else do; /* replace action */ x = old_key_length - new_key_length; if x = 0 then do; record_designator (branch_num) = new_record_designator; /* should use record_descrip, but compiler problems */ substr (keys, key_pos (branch_num), new_key_length) = substr (new_key_string, 1, new_key_length); call adjust_branch_num; end; else do; y = cont_space (node_ptr); space = y + scat_space + x; if space >= 0 then do; /* key will fit */ call replace_key; if space > half_node_length then call underflow; else call adjust_branch_num; end; else do; /* key won't fit, turn into overflow-insert */ call set_new_branch; call simple_delete; call overflow; end; end; end; /* end replace action */ end; call switch_index_state; end; /* end change cycle */ return; /* end change_index routine */ prepare_next_state: proc; /* sets up alternate index state variables */ a_s_ptr = addr (index_state_blocks (1 - index_state)); a_s_ptr -> index_action = 0; a_s_ptr -> index_substate = 0; a_s_ptr -> branch_num_adjust = 0; a_s_ptr -> index_height = index_height; a_s_ptr -> current_node = file_position_ptr -> node; a_s_ptr -> number_of_nodes = number_of_nodes; a_s_ptr -> index_tail_comp_num = index_tail_comp_num; a_s_ptr -> free_node_designator = free_node_designator; end prepare_next_state; initialize_substate: proc; if repeating then do; if index_substate = 0 then repeating = "0"b; else next_substate = 0; return; /* don't alter permanent substate vars */ end; branch_num_adjust = 0; index_substate = 0; file_substate = file_substate + 1; end initialize_substate; save_node_head: proc; if repeating then do; /* restore header variables */ call check_index_substate; last_branch_num = old_last_branch_num; low_key_pos = old_low_key_pos; scat_space = old_scat_space; return; end; old_last_branch_num = last_branch_num; old_low_key_pos = low_key_pos; old_scat_space = scat_space; index_substate = index_substate + 1; end save_node_head; switch_index_state: proc; if a_s_ptr -> index_action = 0 then if new_desc_val = 0 /* not replacing non-leaf key */ then go to switch; change_position_ptr = parent_position_ptr; /* pop change position */ a_s_ptr -> change_node = node; call save_position_stack; switch: index_state = 1 - index_state; /* switch states */ index_state_ptr = a_s_ptr; is_ptr = index_state_ptr; return; /* end of switch_state routine */ save_position_stack: proc; p = root_position_ptr; do i = 1 to a_s_ptr -> index_height; p = p -> son_position_ptr; a_s_ptr -> saved_node (i) = p -> node; a_s_ptr -> saved_branch_num (i) = p -> branch_num; end; dcl p ptr; dcl i fixed; end save_position_stack; end switch_index_state; simple_insert: proc (b_num); if new_cont_space < 0 then call compact_node (node_ptr); if b_num < last_branch_num then call move_bytes (node_ptr, 5 + bd_len * b_num, bd_len, bd_len * (last_branch_num - b_num)); call insert_key (b_num); last_branch_num = last_branch_num + 1; branch (b_num + 1) = new_branch; return; dcl i fixed; dcl b_num fixed; end; /* end simple insert */ insert_key: proc (br_num); low_key_pos = low_key_pos - new_key_length; if repeating then do; call check_index_substate; return; end; record_designator (br_num) = new_record_designator; /* should use record_descrip, but compiler problems */ key_length (br_num) = new_key_length; key_pos (br_num) = low_key_pos; substr (keys, low_key_pos, new_key_length) = substr (new_key_string, 1, new_key_length); index_substate = index_substate + 1; dcl br_num fixed; end insert_key; simple_delete: proc; call free_key_space; last_branch_num = last_branch_num - 1; if branch_num < last_branch_num then call move_bytes (node_ptr, 5 + bd_len * (branch_num + 1), -bd_len, bd_len * (last_branch_num - branch_num)); return; dcl len fixed; end; /* end simple delete */ adjust_branch_num: proc; branch_num = branch_num + branch_num_adjust; end; move_bytes: proc (np, source_offset, displacement, n_bytes); dest_offset = source_offset + displacement; call save_new_string; call set_new_string; return; /* end move_bytes main routine */ save_new_string: proc; if repeating then do; call check_index_substate; return; end; substr (spare_node, dest_offset, n_bytes) = substr (np -> keys, source_offset, n_bytes); index_substate = index_substate + 1; end; set_new_string: proc; if repeating then do; call check_index_substate; return; end; substr (np -> keys, dest_offset, n_bytes) = substr (spare_node, dest_offset, n_bytes); index_substate = index_substate + 1; end; dcl np ptr; dcl (source_offset, displacement, n_bytes, dest_offset) fixed; end move_bytes; set_new_branch: proc; if repeating then do; call check_index_substate; return; end; new_branch = branch (branch_num + 1); index_substate = index_substate + 1; end; set_old_key_info: proc; if repeating then do; call check_index_substate; return; end; old_key_pos = key_pos (branch_num); old_key_length = key_length (branch_num); index_substate = index_substate + 1; end; free_key_space: proc; if old_key_pos = low_key_pos then low_key_pos = low_key_pos + old_key_length; else scat_space = scat_space + old_key_length; end; replace_key: proc; call free_key_space; if new_key_length > y then do; /* make room for larger key */ call zero_key; call compact_node (node_ptr); end; call insert_key (branch_num); return; /* end of replace_key routine */ zero_key: proc; if repeating then do; call check_index_substate; return; end; key_length (branch_num) = 0; index_substate = index_substate + 1; end zero_key; end replace_key; compact_node: proc (n_ptr); np = n_ptr; call make_compact_copy; call set_compacted_node; np -> low_key_pos = new_low_key_pos; np -> scat_space = 0; return; /* end of compaction routine */ make_compact_copy: proc; if repeating then do; call check_index_substate; return; end; n_keys = np -> last_branch_num - 1; len = n_keys * bd_len + node_head_length; substr (spare_node, 1, len) = substr (np -> keys, 1, len); k = node_length + 1; do i = 1 to n_keys; m = np -> key_length (i); if m > 0 then do; k = k - m; substr (spare_node, k, m) = substr (np -> keys, np -> key_pos (i), m); addr (spare_node) -> key_pos (i) = k; end; end; new_low_key_pos = k; index_substate = index_substate + 1; dcl (n_keys, len) fixed; end make_compact_copy; set_compacted_node: proc; if repeating then do; call check_index_substate; return; end; substr (np -> keys, 1, node_length) = substr (spare_node, 1, node_length); index_substate = index_substate + 1; end; dcl (np, n_ptr) ptr; dcl (i, k, m) fixed; end; /* end compact node */ set_new_cont_space: proc; new_cont_space = cont_space (node_ptr) - new_key_length - bd_len; end set_new_cont_space; cont_space: proc (np) returns (fixed); return (np -> low_key_pos - 1 - node_head_length + bd_len - np -> last_branch_num * bd_len); dcl np ptr; end cont_space; insert_at_root: proc; call extend_position_stack (indx_cb_ptr); /* sets change position to new frame */ pos_ptr = change_position_ptr; call create_node (node, node_ptr); call set_first_branch; only_branch_in_root = node; a_s_ptr -> index_height = index_height + 1; a_s_ptr -> current_node = file_position_ptr -> node; old_index_height = a_s_ptr -> index_height; branch_num = 1; new_cont_space = 0; /* avoids unnecessary compaction */ call simple_insert (1); call adjust_branch_num; return; set_first_branch: proc; if repeating then do; call check_index_substate; return; end; branch (1) = only_branch_in_root; index_substate = index_substate + 1; end; end; /* end insert_at_root */ overflow: proc; is_overflow = "1"b; num_of_keys = last_branch_num; /* num of keys in node + 1 for inserted key */ call get_parent; if is_ks_out then do; /* create right brother but don't balance */ call split (num_of_keys - 1); call adjust_position_right; return; end; if p_b_num < p_n_ptr -> last_branch_num then do; /* try rotate right */ call get_right_brother; call rotate_right; /* sets count */ if first_count > 0 then do; call adjust_position_right; return; end; end; /* rotate left or split */ if p_b_num > 1 then do; /* try left brother */ call get_left_brother; call rotate_left; /* sets count */ if second_count > 0 then do; call adjust_position_left; return; end; end; /* must split node, p_b_num irrelevant(no pivot),split sets b_n_ptr */ call find_split_num; call split (split_num); /* split_num is num of key after last included in space */ call adjust_position_right; return; /* end overflow code */ get_parent: proc; p_n_ptr = parent_position_ptr -> node_ptr; p_b_num = parent_position_ptr -> branch_num; end; get_right_brother: proc; b_node = p_n_ptr -> branch (p_b_num + 1); b_n_ptr = get_ptr (b_node); call set_b_vars; return; /* end of get_right_brother routine */ get_left_brother: entry; p_b_num = p_b_num - 1; b_node = p_n_ptr -> branch (p_b_num); b_n_ptr = get_ptr (b_node); call set_b_vars; return; /* end of get_left_brother routine */ set_b_vars: proc; if repeating then do; call check_index_substate; return; end; b_space = cont_space (b_n_ptr) + b_n_ptr -> scat_space; last_b_num = b_n_ptr -> last_branch_num; index_substate = index_substate + 1; end set_b_vars; end get_right_brother; find_split_num: proc; if repeating then do; call check_index_substate; return; end; space = node_head_length; do split_num = 1 repeat (split_num + 1) while (space < half_node_length); space = space + bd_len + key_length (split_num); end; index_substate = index_substate + 1; end find_split_num; underflow: entry; is_overflow = "0"b; call get_parent; if p_b_num < p_n_ptr -> last_branch_num then do; /* balance or combine with right brother */ call get_right_brother; num_of_keys = last_b_num - 1; dest_np = node_ptr; if is_combination_possible () then call combine (node_ptr, b_n_ptr); else call rotate_left; call adjust_branch_num; end; else if p_b_num > 1 then do; /* balance or combine with left brother */ call get_left_brother; num_of_keys = last_b_num - 1; parent_position_ptr -> branch_num = p_b_num; dest_np = b_n_ptr; if is_combination_possible () then do; call combine (b_n_ptr, node_ptr); call set_node_to_brother; branch_num = last_b_num + branch_num + branch_num_adjust; end; else do; call rotate_right; branch_num = branch_num + branch_num_adjust + count; a_s_ptr -> branch_num_adjust = 1; end; end; else /* the parent node is the root node */ if last_branch_num = 1 /* height of tree decreases */ then call underflow_to_root; else call adjust_branch_num; return; /* end of underflow code */ underflow_to_root: proc; call set_root_branch; call free_node (node, node_ptr); a_s_ptr -> index_height = index_height - 1; old_index_height = a_s_ptr -> index_height; node_ptr = parent_position_ptr -> node_ptr; node = parent_position_ptr -> node; a_s_ptr -> current_node = file_position_ptr -> node; branch_num = 1; root_position_ptr = pos_ptr; return; /* end of underflow_to_root routine */ set_root_branch: proc; if repeating then do; call check_index_substate; return; end; only_branch_in_root = branch (1); index_substate = index_substate + 1; end; end underflow_to_root; /* Declarations */ dcl is_new_key bit (1) aligned; dcl is_overflow bit (1) aligned; dcl (p_n_ptr, b_n_ptr) ptr; /* parent,brother nodes */ dcl b_node fixed (35); /* brother node designator */ dcl last_b_num_left fixed; /* used in combining node with left brother */ dcl p_b_num fixed; /* branch num for pivot kay is parent */ dcl n_ptr ptr; dcl (dest_np, np1, np2) ptr; dcl i fixed; dcl num_of_keys fixed; /* number of keys available for rotation, includes new key in overflow case */ get_key: proc (i, p, k); /* locates the node(p)and branch_num(k)for the ith key"in" the source node. Allows for new key. This routine is used in rotate_x and split */ p = np1; k = i; if is_overflow then if i >= branch_num then if i = branch_num then do; /* use new key */ p = addr (fake_node); k = 1; is_new_key = "1"b; return; end; else k = k - 1; is_new_key = "0"b; return; dcl i fixed; /* 1<=i<=num_of_keys */ dcl k fixed; dcl p ptr; end; /* end get_key */ split: proc (n); /* creates new right brother */ count = num_of_keys - n + 1; call create_node (b_node, b_n_ptr); a_s_ptr -> new_branch = b_node; a_s_ptr -> index_action = insert_action; call set_nps; call split_keys; np2 -> last_branch_num = 0; call finish_dest_node; call finish_left_node; return; /* end of split routine */ split_keys: proc; if repeating then do; call check_index_substate; return; end; call get_key (n, p, k); call set_upbound_key; np2 -> branch (1) = first_branch; call set_dest_node_info; dest_b_num = num_of_keys - n; do i = num_of_keys to n + 1 by -1; call get_key (i, source_n_ptr, source_b_num); call move_adjust; dest_b_num = dest_b_num - 1; end; index_substate = index_substate + 1; end split_keys; dcl n fixed; /* index of first key to be moved */ dcl b_num fixed; dcl n_ptr ptr; end; /* end split */ move_adjust: proc; /* adjust low_key_pos and free space count in source */ source_key_pos = source_n_ptr -> key_pos (source_b_num); source_key_len = source_n_ptr -> key_length (source_b_num); if source_key_pos > min_source_key_pos then new_scat_space = new_scat_space + source_key_len; else if ^is_new_key then min_source_key_pos = min_source_key_pos + source_key_len; move: entry; /* moves key and bd_words from source node to dest node */ dest_bd_words = source_bd_words; min_dest_key_pos = min_dest_key_pos - source_key_len; dest_n_ptr -> key_pos (dest_b_num) = min_dest_key_pos; substr (dest_n_ptr -> keys, min_dest_key_pos, source_key_len) = substr (source_n_ptr -> keys, source_key_pos, source_key_len); dcl source_bd_words (branch_and_descrip_size) based (addr (source_n_ptr -> descrip (source_b_num))) fixed; dcl dest_bd_words (branch_and_descrip_size) based (addr (dest_n_ptr -> descrip (dest_b_num))) fixed; end move_adjust; set_new_key_and_descrip: proc (n_ptr, b_num); a_s_ptr -> new_key_length = n_ptr -> key_length (b_num); substr (a_s_ptr -> new_key_string, 1, a_s_ptr -> new_key_length) = substr (n_ptr -> keys, n_ptr -> key_pos (b_num), a_s_ptr -> new_key_length); a_s_ptr -> new_record_designator = n_ptr -> record_designator (b_num); return; dcl n_ptr ptr; dcl b_num fixed; end; /* end set-new_key */ compact_if_nec: proc; b_n_ptr -> last_branch_num = last_b_num; if must_compact_dest then call compact_node (np2); end; rotate_right: proc; i = num_of_keys; /* defines first key to be moved */ di = -1; call compute_count; call set_first_count; if first_count ^= 0 then do; /* rotation is possible */ a_s_ptr -> index_action = replace_action; call compact_if_nec; call move_bytes (np2, bd_len + 1, count * bd_len, bd_len * (np2 -> last_branch_num - 1) + 4); call rotate_keys_right; np2 -> branch (1) = first_branch; call finish_dest_node; call finish_left_node; end; return; /* end rotate_right code */ rotate_keys_right: proc; if repeating then do; call check_index_substate; return; end; call set_dest_node_info; dest_b_num = count; call move_key_down; np2 -> branch (count + 1) = np2 -> branch (1); call get_key (num_of_keys + 1 - count, p, k); call set_upbound_key; do i = 1 to count - 1; call get_key (num_of_keys + 1 - i, source_n_ptr, source_b_num); dest_b_num = dest_b_num - 1; call move_adjust; end; index_substate = index_substate + 1; end rotate_keys_right; set_first_count: proc; if repeating then do; call check_index_substate; return; end; first_count = count; index_substate = index_substate + 1; end; set_second_count: proc; if repeating then do; call check_index_substate; return; end; second_count = count; index_substate = index_substate + 1; end; rotate_left: entry; i = 1; /* defines first key to be moved */ di = 1; call compute_count; call set_second_count; if second_count ^= 0 then do; /* rotation is possible */ a_s_ptr -> index_action = replace_action; call compact_if_nec; call rotate_keys_left; np1 -> branch (1) = first_branch; call finish_dest_node; call finish_right_node; end; return; /* end rotate_left */ rotate_keys_left: proc; if repeating then do; call check_index_substate; return; end; call set_dest_node_info; call move_key_down; call get_key (count, p, k); call set_upbound_key; do i = 1 to count - 1; call get_key (i, source_n_ptr, source_b_num); dest_b_num = dest_b_num + 1; call move_adjust; end; index_substate = index_substate + 1; end rotate_keys_left; dcl i fixed; /* indexes keys "in" source node-including inserted keys */ dcl di fixed; /* defines order to take keys from source node */ compute_count: proc; call set_nps; if repeating then do; call check_index_substate; return; end; if is_overflow then do; x = space; y = b_space; end; else do; x = b_space; y = space; end; dy = bd_len + p_n_ptr -> key_length (p_b_num); /* parent key is first to be moved */ count = 0; call get_key (i, p, k); dx = bd_len + p -> key_length (k); do while (i > 0); /* i=0 just a convienient stop flag */ if dy > y then i = 0; else do; /* key will fit */ count = count + 1; y = y - dy; x = x + dx; if x >= y then i = 0; /* nodes are more or less balanced */ else do; dy = dx; i = i + di; call get_key (i, p, k); dx = bd_len + p -> key_length (k); end; end; end; if x < 0 then count = 0; /* can not move enough keys to correct overflow */ else if count > 0 then if y < np2 -> scat_space then must_compact_dest = "1"b; else must_compact_dest = "0"b; index_substate = index_substate + 1; return; dcl (x, y) fixed; /* x is space in source node,y in target node. Initially x=y if possible. Constraint is y>=o */ dcl (dx, dy) fixed; end; /* end compute_count_set_nps */ end; /* end rotate_right */ set_dest_node_info: proc; dest_n_ptr = np2; dest_b_num = np2 -> last_branch_num; min_dest_key_pos = np2 -> low_key_pos; end; move_key_down: proc; source_n_ptr = p_n_ptr; source_b_num = p_b_num; source_key_pos = source_n_ptr -> key_pos (source_b_num); source_key_len = source_n_ptr -> key_length (source_b_num); call move; np2 -> branch (dest_b_num + 1) = np1 -> branch (1); end move_key_down; set_upbound_key: proc; call set_new_key_and_descrip (p, k); first_branch = p -> branch (k + 1); min_source_key_pos = np1 -> low_key_pos; new_scat_space = np1 -> scat_space; key_len = p -> key_length (k); if p -> key_pos (k) > min_source_key_pos then new_scat_space = new_scat_space + key_len; else if ^is_new_key then min_source_key_pos = min_source_key_pos + key_len; dcl key_len fixed; end; finish_dest_node: proc; np2 -> low_key_pos = min_dest_key_pos; np2 -> last_branch_num = np2 -> last_branch_num + count; end; set_nps: proc; if is_overflow then do; np1 = node_ptr; np2 = b_n_ptr; end; else do; np1 = b_n_ptr; np2 = node_ptr; end; end set_nps; finish_left_node: proc; /* called after split or right rotate */ call set_source_vars; if is_overflow then /* main node is left one */ if branch_num <= last_branch_num then do; /* new key must be inserted */ call set_new_cont_space; call simple_insert (branch_num); end; else /* new key was moved */ np1 -> last_branch_num = np1 -> last_branch_num + 1; end; /* end finish_left_node */ finish_right_node: proc; /* called after left rotate */ call set_source_vars; if is_overflow then do; /* main node is right one */ if branch_num <= count then do; /* new key was moved */ np1 -> last_branch_num = np1 -> last_branch_num + 1; call left_shift (count - 1); end; else do; /* new key must be inserted */ call left_shift (count); call set_new_cont_space; call simple_insert (branch_num - count); end; end; else /* underflow case,brother node is right one */ call left_shift (count); end; /* end finish_right_node */ set_source_vars: proc; np1 -> last_branch_num = np1 -> last_branch_num - count; np1 -> low_key_pos = min_source_key_pos; np1 -> scat_space = new_scat_space; end; left_shift: proc (n); /* shifts descriptors n places left within node */ disp = n * bd_len; call move_bytes (np1, 1 + node_head_length + disp, -disp, bd_len * (np1 -> last_branch_num - 1)); dcl (disp, n) fixed; end; /* end left_shift */ is_combination_possible: proc returns (bit (1)); spare_space = space + b_space + node_head_length - node_length - p_n_ptr -> key_length (p_b_num) - bd_len; if spare_space >= 0 then do; if spare_space < dest_np -> scat_space then must_compact_dest = "1"b; else must_compact_dest = "0"b; return ("1"b); end; return ("0"b); end is_combination_possible; combine: proc (n_ptr_1, n_ptr_2); /* moves key in parent and all keys in node 2 (the right node) into node 1 (movement to left), deletes node 2 */ a_s_ptr -> index_action = delete_action; np1 = n_ptr_2; np2 = n_ptr_1; call compact_if_nec; call combine_keys; call finish_dest_node; call free_node (p_n_ptr -> branch (p_b_num + 1), np1); /* delete right node */ return; /* end of combine routine */ combine_keys: proc; if repeating then do; call check_index_substate; return; end; call set_dest_node_info; call move_key_down; count = np1 -> last_branch_num; source_n_ptr = np1; do source_b_num = 1 to count - 1; dest_b_num = dest_b_num + 1; source_key_pos = source_n_ptr -> key_pos (source_b_num); source_key_len = source_n_ptr -> key_length (source_b_num); call move; end; index_substate = index_substate + 1; end combine_keys; dcl (n_ptr_1, n_ptr_2) ptr; end; /* end combine */ adjust_position_right: proc; /* used after split or right rotation for overflow */ call adjust_branch_num; if branch_num > last_branch_num then do; branch_num = branch_num - last_branch_num; call set_node_to_brother; a_s_ptr -> branch_num_adjust = 1; end; else if branch_num = last_branch_num then if file_position_ptr = pos_ptr then call set_current_node_to_parent; return; end; /* end adjust_position_right */ adjust_position_left: proc; /* used after left rotation for overflow */ parent_position_ptr -> branch_num = p_b_num; branch_num = branch_num + branch_num_adjust - count; if branch_num = 0 then if file_position_ptr = pos_ptr /* position moves to parent */ then do; call set_current_node_to_parent; return; end; if branch_num <= 0 /* position is in left node */ then do; call set_node_to_brother; branch_num = last_branch_num + branch_num; end; else a_s_ptr -> branch_num_adjust = 1; /* position is in right node */ return; end; /* end adjust_position_left */ set_node_to_brother: proc; node = b_node; node_ptr = b_n_ptr; a_s_ptr -> current_node = file_position_ptr -> node; end; set_current_node_to_parent: proc; file_position_ptr = parent_position_ptr; a_s_ptr -> current_node = parent_position_ptr -> node; end; dcl p ptr; dcl k fixed; end; /* end overflow_underflow */ create_node: proc (designator, node_ptr_arg); /* ref17 */ a_s_ptr -> number_of_nodes = number_of_nodes + 1; free_node_ptr = get_ptr (free_node_designator); call save_create_free_info; if free_node_designator ^= 0 then if old_number_of_free_nodes > 0 then do; /* grab a free node from the list */ designator = nodes (old_number_of_free_nodes); number_of_free_nodes = old_number_of_free_nodes - 1; node_ptr_arg = get_ptr (designator); end; else do; /* use this free node */ designator = free_node_designator; node_ptr_arg = free_node_ptr; a_s_ptr -> free_node_designator = old_next_node_designator; end; else if old_seg_lim + node_size <= max_seg_limit then do; /* use next available page of index tail */ call make_designator (index_tail_comp_num, (old_seg_lim), designator); node_ptr_arg = get_ptr (designator); seg_limit (index_tail_comp_num) = old_seg_lim + node_size; end; else do; /* get a new index file component */ a_s_ptr -> index_tail_comp_num = new_index_comp_num; call get_new_seg (iocb_ptr, a_s_ptr -> index_tail_comp_num, node_ptr_arg, index_substate, abort_exit); comp_link (a_s_ptr -> index_tail_comp_num) = index_tail_comp_num; call make_designator (a_s_ptr -> index_tail_comp_num, 0, designator); seg_limit (a_s_ptr -> index_tail_comp_num) = node_size; end; node_ptr_arg -> last_branch_num = 1; node_ptr_arg -> low_key_pos = node_length + 1; node_ptr_arg -> scat_space = 0; return; /* end create node code */ save_create_free_info: proc; if repeating then do; call check_index_substate; return; end; old_seg_lim = abs (seg_limit (index_tail_comp_num)); old_number_of_free_nodes = number_of_free_nodes; old_next_node_designator = next_node_designator; new_index_comp_num = last_comp_num + 1; index_substate = index_substate + 1; end save_create_free_info; free_node: entry (designator, node_ptr_arg); a_s_ptr -> number_of_nodes = number_of_nodes - 1; if free_node_designator ^= 0 then do; /* at least one free node exists */ free_node_ptr = get_ptr (free_node_designator); call save_create_free_info; if old_number_of_free_nodes < (node_size - 2) then do; /* add new entry to free list */ number_of_free_nodes = old_number_of_free_nodes + 1; nodes (number_of_free_nodes) = designator; unspec (node_words) = "0"b; return; end; end; free_node_ptr = node_ptr_arg; number_of_free_nodes = 0; next_node_designator = free_node_designator; a_s_ptr -> free_node_designator = designator; return; /* end of free_node routine */ dcl 1 free_node based (free_node_ptr), 2 number_of_free_nodes fixed, 2 next_node_designator fixed (35), 2 nodes (1 /* really node-size-2 */) fixed (35); dcl designator fixed (35); dcl node_ptr_arg ptr; dcl node_words (node_size) fixed based (node_ptr_arg); dcl free_node_ptr ptr; end create_node; check_index_substate: proc; next_substate = next_substate + 1; if index_substate = next_substate then repeating = "0"b; /* execution resumes normally */ end check_index_substate; get_ptr: proc (descriptor) returns (ptr); return (addr (seg_ptr_array (desc.comp_num) -> seg_array (fixed (desc.offset)))); dcl descriptor fixed (35); dcl 1 desc like designator_struct aligned based (addr (descriptor)); end get_ptr; /* Arguments */ dcl iocb_ptr ptr; dcl abort_exit label; /* Local Variables */ dcl (source_n_ptr, dest_n_ptr) ptr; dcl (source_b_num, source_key_pos, source_key_len, dest_b_num) fixed; dcl pos_ptr ptr; dcl spare_space fixed; dcl new_cont_space fixed; dcl space fixed; dcl (x, y) fixed; dcl a_s_ptr ptr; /* Constants Depending on Node Structure */ dcl bd_len static options (constant) fixed init (12); dcl branch_and_descrip_size static options (constant) fixed init (3); dcl node_head_length static options (constant) fixed init (16); /* includes first branch */ %include vfile_indx; %include iocbv; end change_index;  change_record_list.pl1 11/04/82 1940.0rew 11/04/82 1620.7 253269 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* The initial design and implementation of this program was by M. D. MacLaren (1974) */ /* All changes since 1975 by M. Asherman: Modified to support recovery from interruptions. Extended to support stationary type records. Modified to avoid wasting first two words of each record component. Extended to support transaction mode updates. Changed for new comp_array format in file header to avoid csl's. */ /* the following conventions must be observed in manipulating the file statistics giving the number_of_allocated_records and the number_of_free_blocks: fs_ptr->number_of_free_blocks is reconstructed, using the protected variable old_number_of_free_blocks in the allocation logic, and using the protected variable old_num_free in the freeing logic. fs_ptr->number_of_allocated_records is always protected. the alternate state statistics are always reconstructed. */ change_record_list: proc (iocb_ptr, record_action, buff_ptr, abort_exit); indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; f_b_ptr = file_base_ptr; fs_ptr = indx_cb.file_state_ptr; os_ptr = indx_cb.o_s_ptr; if record_action = allocate_action then do; header_size = 2; call set_required_block_size; call allocate; if ^indx_cb.repeating /* non-recovery execution */ then addr (seg_array (block_offset)) -> excess_words = required_block_size - needed_block_size; /* save min block size info for later attempt to replace tail in compact form */ end; else if record_action = free_action then do; /* get rid of preceding allocation */ call find_new_ind_block; /* locate after image block */ call free; /* disposes of allocation */ end; /* done with cleaning up interrupted stat rewrite */ else if record_action = insert_action then if ^file_base.was_stat /* non-stationary record */ then do; /* requires smaller block header in this case */ header_size = 2; /* block size and record length words */ call set_required_block_size; call allocate; /* finds available block of sufficient size */ end; else do; /* make a new stationary record */ header_size = stat_header_size; /* reserve space for lock and counts */ call set_required_block_size; call allocate; if ^indx_cb.repeating /* non-recovery execution */ then do; /* mark record as such */ stat_block.ref_count = file_base.old_ref_count; /* for initial key or ref count in record_status */ block_head.stationary = "1"b; /* keeps descriptor valid during rewrites */ if file_base.was_transaction then do; stat_block.ref_count_after = file_base.old_ref_count; stat_block.ind_comp = new_rec_des.comp_num; time_stamp_struct.ind_offset = new_rec_des.offset; stat_block.prev_mod = -3; /* signifies pre-creation */ end; else stat_block.time_stamp_words = clock (); end; end; else do; call find_old_block; if record_action = delete_action then if ^file_base.was_stat then call free; /* completely dispose of record allocation */ else do; /* logically delete the record, but leave around until ref_count diminishes */ if ^file_base.is_partial_deletion & ^file_base.out_of_index /* key also deleted */ then do; new_count = file_base.old_ref_count - 1; /* will decrement for deleted key pointing to this record */ if ^indx_cb.repeating /* protect during recovery */ then ind_head.ref_count = new_count; end; else new_count = file_base.old_ref_count; /* count stays the same */ if ^indx_cb.repeating /* not recovery case */ then do; /* otherwise allocation is protected */ block_head.after_applies = "1"b; time_stamp_struct.time_last_modified = clock (); ind_head.prev_desc = -1; /* stands for logical deletion */ ind_head.prev_mod = file_base.old_modifier; block_head.indirect = "1"b; block_head.after_applies = "0"b; end; if file_base.was_ind /* already in indirect form */ then do; /* dispose of indirect allocation, if any */ if file_base.old_ind_desc > 0 /* additional block does exist */ then do; call find_old_ind_block; call free; os_ptr -> number_of_allocated_records = number_of_allocated_records; /* don't count ind block as separate */ end; if new_count <= 0 /* no more references to this record */ then do; /* dispose of entirely */ call find_old_block; /* locate fixed portion */ call free; /* garbage collect */ end; else os_ptr -> number_of_allocated_records = number_of_allocated_records; end; else if new_count <= 0 /* no more references to this compact stat record */ then call free; /* can completely dispose of */ else do; /* logically delete a compact stationary record */ required_block_size = minimum_block_size; residue = file_base.prior_block_size - minimum_block_size; go to check_tail; end; end; else do; /* replace action */ /* replace the current record image, using buffer pointed to by buff_ptr arg for the case of non-stationary records */ if ^file_base.was_stat /* non-stationary type record */ then do; /* rewrite a movable record */ header_size = 2; call set_required_block_size; residue = prior_block_size - required_block_size; if residue < 0 then do; /* get a new block */ call allocate; call find_old_block; /* restore former location */ call free; end; else do; /* use old block */ new_descriptor = old_record_designator; block_head.lock_flag = "1"b; /* in case of record level synch */ call copy_buffer; /* must do before touching residue */ check_tail: if residue >= minimum_block_size then do; /* use first part of block and free residual space */ if ^indx_cb.repeating /* not recovery case */ then do; /* otherwise protect block header */ block_head.block_size = required_block_size; /* make residue allocated block and free it */ block_offset = block_offset + required_block_size; seg_array (block_offset) = 0; /* clear flags and first word stuff */ block_head.block_size = residue; end; /* this can't be repeated since the free logic is not repeatable, and it involves subsequent changes to these same locations; i.e. we must consistently protect these values, since we have chosen not to reconstruct them during recovery execution */ else block_offset = block_offset + required_block_size; call free; end; end; end; /* end of non-stat rewrite case */ else /* rewrite a stationary record */ /* replace the current image with that pointed to by new_descriptor */ if file_base.was_transaction /* transaction */ then if (^file_base.was_ind) & (file_base.old_prev_mod = -3) /* compact, pre-created record */ then go to compact_case; /* replace after image in compact tail */ else do; /* replace new indirect image */ call find_old_ind_block; /* locate old new contents */ call free; /* dispose of previous after-image */ end; else if file_base.was_ind /* indirect record */ then do; block_head.after_applies = "1"b; time_stamp_struct.time_last_modified = clock (); ind_head.prev_mod = file_base.old_modifier; ind_head.prev_desc = file_base.new_descriptor; block_head.after_applies = "0"b; if file_base.old_ind_desc ^= 0 /* old block existed */ then do; /* dispose of old indirect block */ call find_old_ind_block; call free;/* de-allocates */ end; end; /* end of indirect record rewrite logic */ else do; /* rewrite compact stationary type record */ compact_case: if file_base.new_descriptor > 0 then do; block_ptr = addr (seg_array (block_offset)); record_ptr = addr (seg_array (block_offset + stat_header_size - 1)); call find_new_ind_block; /* after image */ call save_needed_blksz; required_block_size = file_base.needed_blksz; if (file_base.prior_block_size >= required_block_size /* old alloc big enough */) then do; /* copy back into initial block */ if ^indx_cb.repeating then if file_base.was_transaction then do; /* replace compact after image */ record_head.record_length = file_base.new_record_length; record_head.record = addr (seg_array (block_offset + 1)) -> record_head.record; end; else do; /* non-TP case */ block_ptr -> block_head.after_applies = "1"b; addr (block_ptr -> stat_block.time_stamp_words) -> time_stamp_struct.time_last_modified = clock (); record_head.record_length = file_base.new_record_length; record_head.record = addr (seg_array (block_offset + 1)) -> record_head.record; /* copy back into old */ block_ptr -> stat_block.prev_mod = file_base.old_modifier; block_ptr -> block_head.after_applies = "0"b; addr (block_ptr -> stat_block.time_stamp_words) -> time_stamp_struct.time_last_modified = clock (); end; call free; /* deallocate after image */ call find_old_block; /* back to header */ residue = file_base.prior_block_size - required_block_size; go to check_tail; /* see how much extra */ end; /* record left in compact form */ else call find_old_block; /* back to header */ end; /* convert compact record into indirect form */ if file_base.was_transaction then do; /* replace after image under TP */ /* record was created in this transaction, and is being subsequently rewritten, deleted, or rolled back */ ind_head.prev_desc = -1; block_head.indirect = "1"b; end; else do; /* called by rewrite or checkpoint logic */ block_head.after_applies = "1"b; time_stamp_struct.time_last_modified = clock (); ind_head.prev_desc = file_base.new_descriptor; block_head.indirect = "1"b; stat_block.prev_mod = file_base.old_modifier; block_head.after_applies = "0"b; end; required_block_size = minimum_block_size; residue = file_base.prior_block_size - minimum_block_size; /* tail of init block */ go to check_tail; /* free tail, if large enough */ end; os_ptr -> number_of_allocated_records = number_of_allocated_records; end; end; os_ptr -> number_of_free_blocks = number_of_free_blocks; return; /* end main code */ find_old_block: proc; /* locate previously existing record */ comp_num = old_rec_des.comp_num; seg_ptr = seg_ptr_array (comp_num); block_offset = fixed (old_rec_des.offset, 18); end find_old_block; find_new_ind_block: proc; /* locates newly allocated image block */ comp_num = new_rec_des.comp_num; /* locate the new allocation */ block_offset = fixed (new_rec_des.offset, 18); seg_ptr = seg_ptr_array (comp_num); /* logic of rewrite guarantees that this comp is initiated */ end find_new_ind_block; find_old_ind_block: proc; /* finds old indirect allocation */ comp_num = old_ind_des.comp_num; seg_ptr = seg_ptr_array (comp_num); block_offset = fixed (old_ind_des.offset, 18); end find_old_ind_block; set_required_block_size: proc; min_recl = max (file_base.saved_min_cap, new_record_length + file_base.saved_min_res); needed_block_size = header_size + 2 * divide (min_recl + 7, 8, 18, 0); required_block_size = max (minimum_block_size, needed_block_size); end set_required_block_size; save_needed_blksz: proc; if indx_cb.repeating then do; call check_file_substate; return; end; file_base.needed_blksz = 6 + addr (seg_array (block_offset)) -> block_head.block_size - addr (seg_array (block_offset)) -> block_head.excess_words; /* enforce min block size */ file_substate = file_substate + 1; end save_needed_blksz; allocate: proc; /* grabs a block of space from the free list */ call find_free_block; if need_new_seg then do; call use_new_segment; /* creates new component if necessary */ if indx_cb.repeating /* recovery in progress */ then return; /* protect permanent file variables */ end; else do; /* allocate block of space in existing segment */ rover_seg_ptr = seg_ptr; old_rover_comp_num = comp_num; if indx_cb.repeating then return; /* protect state during recovery execution */ rover_comp_num = comp_num; is_this_block_free = "0"b; if residue < minimum_block_size then call allocate_whole_block; else call allocate_part_block; /* frees the residue */ end; os_ptr -> number_of_allocated_records = number_of_allocated_records + 1; copy_buffer: entry; /* does the assignment of the record's contents */ block_offset = fixed (new_rec_des.offset); /* locate allocated record block */ record_ptr = addr (seg_array (block_offset + header_size - 1)); record_head.record_length = new_record_length; /* set len in block header */ if buff_ptr ^= null then record_head.record = buffer; /* does the assignment */ else if block_head.block_size > header_size /* room for record contents */ then do; /* just zero first and last words, in case non-zero */ seg_array (block_offset + header_size) = 0; /* free list thread word */ seg_array (block_offset + block_head.block_size - 1) = 0; /* free block size tail word */ end; return; /* end of allocate code */ find_free_block: proc; /* searches free list for block of sufficient size */ if repeating then do; /* restore non-permanent vars and skip search */ call check_file_substate; comp_num = new_rec_des.comp_num; block_offset = fixed (new_rec_des.offset); residue = old_residue; seg_ptr = get_seg_ptr (iocb_ptr, comp_num); return; end; need_new_seg = "0"b; /* will be set if no adequate block */ seg_ptr = rover_seg_ptr; comp_num = rover_comp_num; block_offset = rover_offset; file_base.old_number_of_free_blocks = number_of_free_blocks; search_not_done = "1"b; do while (search_not_done); /* look for suitable block */ if block_offset = 0 /* indicates segment is full */ then do; /* try another component */ comp_num = comp_link (comp_num); block_offset = init_offset (comp_num); seg_ptr = get_seg_ptr (iocb_ptr, comp_num); go to check_rover; /* give up search if at starting point */ end; else do; /* check this block's size */ block_offset = non_neg (block_offset); residue = block_head.block_size - required_block_size; if residue >= 0 then do; /* satisfactory block found */ new_rec_des.comp_num = comp_num; new_rec_des.offset = bit (block_offset); old_prev_free_block = prev_free_block; /* save for recovery */ old_next_free_block = next_free_block; old_residue = residue; search_not_done = "0"b; end; else do; /* block too small -- try next on list */ block_offset = next_free_block; check_rover: if block_offset = rover_offset then if comp_num = rover_comp_num then do; /* back at start--search failed */ new_rec_des.comp_num = last_comp_num + 1; new_rec_des.offset = "0"b; need_new_seg = "1"b; search_not_done = "0"b; end; end; end; end; file_substate = file_substate + 1; dcl search_not_done bit (1) aligned; end find_free_block; use_new_segment: proc; /* finds new component and allocates record block */ comp_num = new_rec_des.comp_num; call get_new_seg (iocb_ptr, comp_num, seg_ptr, file_substate, abort_exit); block_offset = 0; old_rover_comp_num = comp_num; rover_seg_ptr = seg_ptr; call set_new_comp_link; if indx_cb.repeating /* recovery case */ then return; /* protect state */ comp_link (0) = comp_num; residue = max_seg_limit - required_block_size - block_offset; if residue < minimum_block_size /* use whole seg */ then do; block_head.block_size = max_seg_limit; /* whole segment is allocated block */ seg_limit (comp_num) = max_seg_limit; init_offset (comp_num) = 0; rover_offset = 0; end; else do; block_head.block_size = required_block_size; block_offset = required_block_size + block_offset; is_preceding_block_free = "0"b; is_this_block_free = "1"b; block_head.block_size = residue; next_free_block = 0; prev_free_block = 0; init_offset (comp_num) = block_offset; rover_offset = block_offset; seg_limit (comp_num) = block_offset + size (block_head); number_of_free_blocks = old_number_of_free_blocks + 1; end; end use_new_segment; set_new_comp_link: proc; if repeating then do; call check_file_substate; return; end; is_preceding_block_free = "0"b; is_this_block_free = "0"b; rover_comp_num = comp_num; comp_link (comp_num) = comp_link (0); file_substate = file_substate + 1; end; allocate_whole_block: proc; /* uses entire block for new record */ rover_offset = old_next_free_block; if old_prev_free_block ^= 0 then addr (seg_array (non_neg (old_prev_free_block))) -> next_free_block = old_next_free_block; else init_offset (comp_num) = old_next_free_block; if old_next_free_block ^= 0 then addr (seg_array (non_neg (old_next_free_block))) -> prev_free_block = old_prev_free_block; following_block_offset = block_offset + block_head.block_size; if following_block_offset = max_seg_limit then seg_limit (comp_num) = max_seg_limit; /* allocating last block in segment */ else addr (seg_array (following_block_offset)) -> is_preceding_block_free = "0"b; /* set block end */ number_of_free_blocks = old_number_of_free_blocks - 1; end allocate_whole_block; allocate_part_block: proc; /* allocates first part and frees the residual space */ residue_offset = block_offset + required_block_size; rover_offset = residue_offset; /* Set links in residue and free block list */ if old_prev_free_block ^= 0 then addr (seg_array (non_neg (old_prev_free_block))) -> next_free_block = residue_offset; else init_offset (comp_num) = residue_offset; if old_next_free_block ^= 0 then addr (seg_array (non_neg (old_next_free_block))) -> prev_free_block = residue_offset; addr (seg_array (residue_offset)) -> prev_free_block = old_prev_free_block; addr (seg_array (residue_offset)) -> next_free_block = old_next_free_block; block_head.block_size = required_block_size; /* set header info for residue of block */ block_offset = residue_offset; is_preceding_block_free = "0"b; is_this_block_free = "1"b; block_head.block_size = residue; /* set block end */ following_block_offset = block_offset + residue; if following_block_offset = max_seg_limit then seg_limit (comp_num) = block_offset + size (block_head); else seg_array (following_block_offset - 1) = residue; end allocate_part_block; dcl residue fixed (19); dcl residue_offset fixed (18); end allocate; free: proc; /* places new block onto the free list */ call save_old_vars; call make_free; /* does the work in protected procedure--in case called twice */ return; /* end of free routine */ make_free: proc; if repeating then do; call check_file_substate; return; end; if prec_block_was_free then call merge_preceding_block; else call free_this_block; if following_block_offset = max_seg_limit then seg_limit (comp_num) = block_offset + size (block_head); /* last block in segment--set new seg_limit */ else do; /* take care of next block */ p = addr (seg_array (following_block_offset)); if next_block_was_free then call merge_next_block; else do; /* set next block's prior block info */ p -> is_preceding_block_free = "1"b; seg_array (following_block_offset - 1) = former_block_size; end; end; number_of_free_blocks = old_num_free + 1 - times_merged; os_ptr -> number_of_allocated_records = number_of_allocated_records - 1; file_substate = file_substate + 1; end make_free; save_old_vars: proc; /* sets permanent block info for crash recovery */ if repeating then do; call check_file_substate; return; end; old_init_offset = init_offset (comp_num); old_block_size = block_head.block_size; prec_block_was_free = is_preceding_block_free; old_num_free = number_of_free_blocks; former_rover_comp_num = rover_comp_num; former_rover_offset = rover_offset; if prec_block_was_free then do; prev_block_size = seg_array (block_offset - 1); former_block_size = prev_block_size + old_block_size; end; else former_block_size = old_block_size; following_block_offset = block_offset + old_block_size; if following_block_offset < max_seg_limit then do; p = addr (seg_array (following_block_offset)); /* p-> next block */ next_block_size = p -> block_head.block_size; next_next_free_block = p -> next_free_block; next_block_was_free = p -> is_this_block_free; if (following_block_offset = old_init_offset) & ^prec_block_was_free then next_prev_free_block = non_zero (block_offset); /* thread will be changed */ else next_prev_free_block = p -> prev_free_block; /* usual case */ end; file_substate = file_substate + 1; end save_old_vars; merge_preceding_block: proc; /* combines new block with preceding free block */ times_merged = 1; old_block_offset = block_offset; block_offset = old_block_offset - prev_block_size; call zero_words (addr (seg_array (old_block_offset - 1)), 1 + old_block_size); block_head.block_size = prev_block_size + old_block_size; /* combined size */ following_block_offset = block_offset + block_head.block_size; end merge_preceding_block; free_this_block: proc; /* puts new block onto the free list */ times_merged = 0; next_free_block = old_init_offset; prev_free_block = 0; nzbo = non_zero (block_offset); init_offset (comp_num) = nzbo; if next_free_block ^= 0 then addr (seg_array (non_neg (next_free_block))) -> prev_free_block = nzbo; is_this_block_free = "1"b; unspec (block_head.flags) = "0"b; call zero_words (addr (seg_array (block_offset + size (block_head))), old_block_size - size (block_head)); following_block_offset = block_offset + old_block_size; return; dcl nzbo fixed (18) unsigned; end free_this_block; merge_next_block: proc; /* combines new block with following free block */ times_merged = times_merged + 1; block_head.block_size = former_block_size + next_block_size; /* Adjust links to-from removed block */ if next_prev_free_block ^= 0 then addr (seg_array (non_neg (next_prev_free_block))) -> next_free_block = next_next_free_block; else init_offset (comp_num) = next_next_free_block; if next_next_free_block ^= 0 then addr (seg_array (non_neg (next_next_free_block))) -> prev_free_block = next_prev_free_block; /* Adjust rover if it designates block being removed from free list */ if following_block_offset = former_rover_offset then if comp_num = former_rover_comp_num then rover_offset = non_zero (block_offset); /* Set end of merged block */ if (following_block_offset + next_block_size) = max_seg_limit then do; /* merged block is last in seg */ call zero_words (p, size (block_head)); seg_limit (comp_num) = block_offset + size (block_head); end; else do; call zero_words (p, next_block_size - 1); seg_array (block_offset + block_head.block_size - 1) = block_head.block_size; end; return; end merge_next_block; dcl p ptr; dcl times_merged fixed; dcl old_block_offset fixed (18); end free; non_neg: proc (offset) returns (fixed (18)); if offset = 262143 /* 2**18 - 1 */ then return (0); /* stands for offset 0 */ return (offset); dcl offset fixed (18); end non_neg; non_zero: proc (offset) returns (fixed (18)); if offset = 0 then return (262143); return (offset); dcl offset fixed (18); end non_zero; zero_words: proc (p, n); if n > 0 then unspec (words) = "0"b; return; dcl words (n) fixed based (p); dcl p ptr; dcl n fixed (19); end; /* end zero words */ check_file_substate: proc; next_substate = next_substate + 1; if file_substate = next_substate then repeating = "0"b; /* execution resumes normally */ end check_file_substate; /* Declarations */ dcl new_count fixed (34); dcl os_ptr ptr; dcl buff_ptr ptr; dcl buffer char (new_record_length) based (buff_ptr); dcl iocb_ptr ptr; dcl record_action fixed; dcl abort_exit label; dcl pos_ptr ptr; /* not used in this procedure */ dcl header_size fixed; dcl min_recl fixed (21); dcl block_ptr ptr; dcl 1 block_head based (addr (seg_array (block_offset))), 2 is_preceding_block_free bit (1) unal, 2 is_this_block_free bit (1) unal, 2 block_size fixed (19) unal, 2 flags, 3 lock_flag bit (1) unal, 3 stationary bit (1) unal, 3 indirect bit (1) unal, 3 after_applies bit (1) unal, 3 pad bit (6) unal, 3 excess_words fixed (3) unal, /* only used in indirect allocations */ 2 prev_free_block fixed (18) aligned, 2 next_free_block fixed (18) aligned; dcl 1 stat_block based (addr (seg_array (block_offset))), 2 pad bit (26) unal, 2 ref_count_after fixed (15) unal, 2 ind_comp fixed (13) unal, 2 ref_count fixed (15) unal, 2 record_lock bit (36) aligned, 2 modifier fixed (35), 2 time_stamp_words fixed (71) aligned, 2 prev_mod fixed (35), 2 record_length fixed (21), 2 record char (0 refer (stat_block.record_length)); dcl 1 ind_head based (addr (seg_array (block_offset))), 2 pad bit (26) unal, 2 ref_count_after fixed (15) unal, 2 ind_comp fixed (13) unal, 2 ref_count fixed (15) unal, 2 record_lock bit (36) aligned, 2 modifier fixed (35), 2 time_stamp_words fixed (71) aligned, 2 prev_mod fixed (35), 2 prev_desc fixed (35); dcl 1 time_stamp_struct based (addr (stat_block.time_stamp_words)), 2 ind_offset bit (18) unal, 2 time_last_modified fixed (53) unal; dcl record_ptr ptr; dcl 1 record_head based (record_ptr), 2 record_length fixed (21) aligned, 2 record char (0 refer (record_head.record_length)); dcl 1 old_rec_des like designator_struct aligned based (addr (old_record_designator)); dcl 1 old_ind_des like designator_struct aligned based (addr (file_base.old_ind_desc)); dcl 1 new_rec_des like designator_struct aligned based (addr (new_descriptor)); dcl comp_num fixed; dcl block_offset fixed (18); dcl following_block_offset fixed (18); dcl required_block_size fixed (19); dcl residue fixed (19); %include vfile_indx; %include iocbv; dcl clock builtin; dcl needed_block_size fixed (19); end /* end change_record_list */;  check_file_version.pl1 10/16/90 1526.9rew 10/16/90 1518.0 77733 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-10-15,Zimmerman), approve(90-10-15,MCR8216), audit(90-10-15,Zwick), install(90-10-16,MR12.4-1043): Increase maximum number of components in MSF to 1250. END HISTORY COMMENTS */ check_file_version: proc (indx_cb_ptr, code); f_b_ptr = file_base_ptr; fs_ptr = file_state_ptr; code = 0; if file_version = file_version_MR2 /* original version */ then do; old_file_state_ptr = addr (old_file_state_blocks (file_state)); if old_f_s_block.file_action ^= 0 /* too bad--no crashproofing */ then do; code = error_table_$bad_file; /* nothing can be done */ call sub_err_ (code, "vfile_", "c", null, code, "Old file is inconsistent because of interrupted update--this version does not support recovery from interruptions." ); end; end; else if file_version = file_version_MR3 /* MR3.0 version */ then do; old_file_state_ptr = addr (v20_fs_blocks (file_state)); if v20_fsb.file_action ^= 0 /* operation in progress */ then do; code = error_table_$unimplemented_version; /* user must adjust with version 20 vfile_ before transformation can occur */ call sub_err_ (code, "vfile_", "c", null, code, "Operation in progress--this file must be adjusted with the MR3 version of vfile_."); end; end; else if file_version = file_version_MR6 then if (file_state_block.file_action = 0) | (file_state_block.file_action = read_exclude) then ; /* no operations in progress */ else do; /* complain--must adjust with old version vfile_ first */ code = error_table_$unimplemented_version; call sub_err_ (code, "vfile_", "c", null, code, "Operation in progress--this file must be adjusted with the MR6 version of vfile_."); end; else do; code = error_table_$bad_file; /* unrecognizable version */ call sub_err_ (code, "vfile_", "c", null, code, "Unrecognizable indexed file version number."); end; if (code = 0) & ^is_read_only then do; /* make the version transformation */ if (program_version > 11) & (program_version < 23) then do; code = error_table_$unimplemented_version; call sub_err_ (code, "vfile_", "c", null, code, "Old version file must be adjusted with MR6 version of vfile_ in order to fix bad header statistics caused by old bugs." ); return; end; if file_version = file_version_MR2 then do; call move_comp_info; call move_file_statis; call move_index_statis; end; else if file_version = file_version_MR3 then call move_v20_statis; file_version = file_version_MR6; call rebuild_comp_array; file_version = current_file_version; end; return; /* end of file version update routine */ rebuild_comp_array: proc; /* repacks items in comp_array */ comp_info_ptr = addr (file_base.max_comp_num); do while (y_count <= 2 * true_max_comp_num); /* loop through array */ i = divide (y_count, 2, 17, 0); /* current element number */ if 2 * i = y_count /* first copy old values into safe location */ then do; file_base.old_init_offset = comp_info.init_offset (i); file_base.former_rover_comp_num = comp_info.comp_link (i); /* these are just convenient header slots for temporary use */ end; else do; /* now copy from temp back into comp_array in new format */ comp_table.init_offset (i) = file_base.old_init_offset; comp_table.comp_link (i) = file_base.former_rover_comp_num; end; y_count = y_count + 1; end; /* note each cycle is repeatable */ dcl i fixed; end rebuild_comp_array; move_comp_info: proc; comp_info_ptr = addr (old_version_comp_info); do while (x_count <= true_max_comp_num); /* if this loop is interrupted, x_count will keep track of progress */ n = true_max_comp_num - x_count; addr (file_base.max_comp_num) -> comp_info.comp_table (n) = comp_info.comp_table (n); x_count = x_count + 1; end; file_base.first_free_comp_num = 0; file_base.last_comp_num = comp_info.last_comp_num; file_base.max_comp_num = true_max_comp_num; end move_comp_info; move_file_statis: proc; file_state_block.file_action = 0; file_state_block.number_of_records = old_f_s_block.number_of_records; file_state_block.total_key_length = old_f_s_block.total_key_length; file_state_block.total_record_length = old_f_s_block.total_record_length; record_state_ptr = addr (record_state_blocks (record_state)); file_state_block.number_of_allocated_records = record_state_block.number_of_allocated_records; file_state_block.number_of_free_blocks = record_state_block.number_of_free_blocks; call set_default_stats; end move_file_statis; move_index_statis: proc; index_state = 0; index_state_ptr = addr (index_state_blocks (0)); is_ptr = index_state_ptr; number_of_nodes = old_version_number_of_nodes; free_node_designator = old_version_free_node_designator; index_tail_comp_num = old_version_index_tail_comp_num; index_height = old_version_index_height; n = node_head_length + branch_and_descrip_length + 1; new_key_pos = n; /* usually set at file creation */ addr (index_state_blocks (1)) -> new_key_pos = n; end move_index_statis; move_v20_statis: proc; file_state_block.file_action = 0; file_state_block.number_of_records = v20_fsb.number_of_records; file_state_block.total_key_length = v20_fsb.total_key_length; file_state_block.total_record_length = v20_fsb.total_record_length; file_state_block.number_of_allocated_records = v20_fsb.number_of_allocated_records; file_state_block.number_of_free_blocks = v20_fsb.number_of_free_blocks; call set_default_stats; end move_v20_statis; set_default_stats: proc; /* used with old version indexed files */ file_state_block.number_of_keys = file_state_block.number_of_records; file_state_block.duplicate_keys = 0; file_state_block.dup_key_bytes = 0; end set_default_stats; dcl pos_ptr ptr; /* not used by this proc */ dcl code fixed (35); %include vfile_error_codes; dcl current_file_version static fixed init (40); dcl file_version_MR2 static internal options (constant) init (10); dcl file_version_MR3 static internal options (constant) init (20); dcl file_version_MR6 static internal options (constant) init (30); dcl node_head_length static fixed init (16); dcl branch_and_descrip_length static fixed init (12); dcl n fixed; dcl 1 v20_file_header based (f_b_ptr), /* MR3.0 version header */ 2 words (62) fixed, 2 v20_fs_blocks (0:1), /* file state blocks */ 3 words (7) fixed; dcl 1 v20_fsb based (old_file_state_ptr), /* MR3.0 file state block */ 2 file_action fixed, 2 file_substate fixed, 2 number_of_records fixed (34), 2 total_key_length fixed (34), 2 total_record_length fixed (34), 2 number_of_allocated_records fixed (34), 2 number_of_free_blocks fixed (34); dcl record_state_ptr ptr; dcl 1 record_state_block based (record_state_ptr), 2 words (2) fixed, 2 number_of_free_blocks fixed (34), 2 number_of_allocated_records fixed (34); dcl old_file_state_ptr ptr; dcl 1 old_f_s_block based (old_file_state_ptr), 2 file_action fixed, 2 word fixed, 2 number_of_records fixed (34), 2 total_key_length fixed (34), 2 total_record_length fixed (34); dcl comp_info_ptr ptr; dcl 1 comp_info based (comp_info_ptr), 2 max_comp_num fixed, 2 last_comp_num fixed, 2 first_free_comp_num /* not supported--used for converting versions */, 2 comp_table (0:true_max_comp_num) aligned, 3 seg_limit fixed (19), 3 comp_link fixed (15) unal, 3 init_offset fixed (18) unal; %include vfile_indx; dcl sub_err_ entry options (variable); end check_file_version;  create_position_stack.pl1 11/04/82 1940.0rew 11/04/82 1620.7 33930 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ create_position_stack: proc (indx_cb_ptr); f_b_ptr = file_base_ptr; is_ptr = index_state_ptr; if file_version = 10 /* previous file version */ then old_index_height = old_version_index_height; else old_index_height = index_height; position_stack_height = max (min_stack_height, old_index_height + 1); call alloc_cb_file (size (position_stack), position_stack_ptr); call chain_stack_frames; return; /* end create_position_stack code */ extend_position_stack: entry; /* This inserts a new position frame immediately below the root. change_position_ptr is set to this new frame. The whole stack may be reallocated. */ f_b_ptr = file_base_ptr; is_ptr = index_state_ptr; change_position_ptr = root_position_ptr; if parent_position_ptr = null then do; /* reallocate stack, get one more frame */ old_stack_ptr = position_stack_ptr; old_stack_height = position_stack_height; position_stack_height = position_stack_height + 1; call alloc_cb_file (size (position_stack), position_stack_ptr); call chain_stack_frames; file_position_ptr = root_position_ptr; do i = 1 to old_stack_height; /* copy old stack */ change_position_ptr = addr (position_stack (i)); old_frame_ptr = addr (old_stack (i)); node_ptr = old_frame_ptr -> node_ptr; node = old_frame_ptr -> node; if node = current_node then file_position_ptr = change_position_ptr; branch_num = old_frame_ptr -> branch_num; end; parent_position_ptr = addr (position_stack (position_stack_height)); parent_position_ptr -> parent_position_ptr = null; parent_position_ptr -> son_position_ptr = change_position_ptr; call free_cb_file (size (old_stack), old_stack_ptr); end; /* Set up new root frame */ root_position_ptr = parent_position_ptr; root_position_ptr -> node_ptr = node_ptr; root_position_ptr -> node = node; root_position_ptr -> branch_num = 1; return; /* end extend stack code */ free_position_stack: entry; call free_cb_file (size (position_stack), position_stack_ptr); return; dcl 1 position_stack (position_stack_height) based (position_stack_ptr), 2 words (size (position_frame)); dcl 1 old_stack (old_stack_height) based (old_stack_ptr), 2 words (size (position_frame)); dcl pos_ptr ptr defined (change_position_ptr); dcl sp ptr; dcl old_frame_ptr ptr; dcl old_stack_ptr ptr; dcl old_stack_height fixed; dcl i fixed; dcl min_stack_height static fixed init (4); /* 1 would work */ chain_stack_frames: proc; sp = null; do i = 1 to position_stack_height; change_position_ptr = addr (position_stack (i)); son_position_ptr = sp; branch_num = 1; /* clear upper half word */ if sp ^= null then sp -> parent_position_ptr = change_position_ptr; sp = change_position_ptr; if i = old_index_height + 1 then do; /* set_root position */ node_ptr = addr (root_node_block); node = fixed (rel (node_ptr), 35); root_position_ptr = change_position_ptr; end; end; parent_position_ptr = null; return; end; /* end chain_stack_frames */ %include vfile_indx; end /* end create_position_stack */;  create_seg_ptrs.pl1 10/16/90 1526.9rew 10/16/90 1517.7 105804 /****^ ********************************************************* * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ********************************************************* */ /****^ HISTORY COMMENTS: 1) change(90-10-12,Zimmerman), approve(90-10-12,MCR8216), audit(90-10-15,Zwick), install(90-10-16,MR12.4-1043): Data_Mgt 63 (phx21194): Raise the max number of components in an MSF to 1250. END HISTORY COMMENTS */ /* Changed 6/13/77 for even-word aligned allocations to have correct max_record_size */ /* Modified: 07/14/81 by Lindsey Spratt: In get_seg_ptr, when closing the current fcb and re-opening, set the fcbp in the attach block as well as the fcb_ptr in the indx_cb, since the fcb may have moved. Change from using the iocbv include file to the iocb.incl.pl1 include file. This is necessary because the iocbv.incl.pl1 include file has been deleted from the system as obsolete. 11/16/82 by Lindsey Spratt: Changed to extend the seg_ptr_array when an attempt to get a seg_ptr for a compnum >= seg_ptr_array_limit is made via the get_seg_ptr entry. 02/05/85 by Steve Herbst: Fixed $get_seg_ptr to reinitialize file information when the file has been closed and reopened because msf_manager_$get_ptr has failed. Fixes bug allowing KST overflow to damage files. */ /* format: style2,ind3 */ create_seg_ptrs: proc (iocb_ptr); begin; indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; f_b_ptr = file_base_ptr; if file_version = 10 /* previous file version */ then do; /* use old version file base info */ comp_number = old_version_index_tail_comp_num; comp_info_ptr = addr (old_version_comp_info); end; else do; index_state_ptr = addr (index_state_blocks (index_state)); is_ptr = index_state_ptr; comp_number = index_tail_comp_num; comp_info_ptr = addr (file_base.max_comp_num); end; seg_ptr_array_limit = comp_info.last_comp_num + 2; /* allow 2 for growth, note: this must be large enough for alloc_cb_file */ call alloc_cb_file (size (seg_ptr_array), seg_ptr_array_ptr); seg_ptr_array = null; seg_ptr_array (0) = f_b_ptr; do while (comp_number > 0); /* initiate additional index components */ p = get_seg_ptr (iocb_ptr, comp_number); /* sets value in seg_ptr_array */ if file_version <= 30 /* old version comp_table */ then comp_number = old_comp_info.comp_link (comp_number); else comp_number = comp_info.comp_link (comp_number); end; node_length = 4 * node_size; half_node_length = 2 * node_size; if file_version >= 40 /* latest version doesn't waste first two words */ then max_record_size = 4 * max_seg_limit - 8; /* compare with seq files */ else max_record_size = 4 * max_seg_limit - 16; rover_seg_ptr = get_seg_ptr (iocb_ptr, rover_comp_num); old_last_comp_num = comp_info.last_comp_num; old_rover_comp_num = rover_comp_num; return; dcl comp_info_ptr ptr; dcl 1 comp_info based (comp_info_ptr), 2 max_comp_num fixed, 2 last_comp_num fixed, 2 first_free_comp_num fixed, 2 comp_table (0:true_max_comp_num) aligned, 3 seg_limit fixed (19), 3 comp_link fixed (17) unal, 3 init_offset fixed (18) unsigned unal; dcl 1 old_comp_info based (comp_info_ptr), 2 max_comp_num fixed, 2 last_comp_num fixed, 2 first_free_comp_num /* not supported--used for converting versions */, 2 comp_table (0:true_max_comp_num), 3 seg_limit fixed (19), 3 comp_link fixed (15) unal, 3 init_offset fixed (18) unal; end; /* end of create_seg_ptrs routine */ free_seg_ptrs: entry (iocb_ptr); indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; call free_cb_file (size (seg_ptr_array), seg_ptr_array_ptr); return; get_new_seg: entry (iocb_ptr, comp_num, seg_ptr, substate_arg, abort_exit); indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; f_b_ptr = file_base_ptr; fs_ptr = file_state_ptr; /* not yet supported if first_free_comp_num^=0 then do; use existing component comp_num=first_free_comp_num; first_free_comp_num=comp_link(comp_num); call msf_manager_$get_ptr(fcb_ptr,comp_num,"0"b,seg_ptr,foo24,foo); seg_ptr_array(comp_num)=seg_ptr; end; */ /* else */ do; /* create new component */ if comp_num >= max_comp_num then if max_comp_num < true_max_comp_num then max_comp_num = true_max_comp_num; else go to abort_exit; if comp_num >= seg_ptr_array_limit then call extend_seg_ptr_array (1); last_comp_num = comp_num; call adjust_if_nec; call set_new_ptr; old_last_comp_num = last_comp_num; end; return; /* end get new seg */ /* not yet supported free_seg:entry(iocb_ptr,comp_num,seg_ptr); the segment must already be zeroed indx_cb_ptr=iocb_ptr->iocb.open_data_ptr; f_b_ptr=file_base_ptr; seg_ptr_array(comp_num)=null; call hcs_$set_bc_seg(seg_ptr,0,foo); seg_limit(comp_num)=0; comp_link(comp_num)=first_free_comp_num; first_free_comp_num=comp_num; return; */ adjust_if_nec: proc; if repeating then do; call check_substate; if substate_arg = next_substate then call msf_manager_$adjust (fcb_ptr, comp_num - 1, foo24, "000"b, foo); return; end; substate_arg = substate_arg + 1; end adjust_if_nec; set_new_ptr: proc; if repeating then do; call check_substate; seg_ptr = get_seg_ptr (iocb_ptr, comp_num); return; end; call msf_manager_$get_ptr (fcb_ptr, comp_num, "1"b, seg_ptr, foo24, foo); if seg_ptr = null /* unable to get new component */ then do; if foo ^= 0 then call sub_err_ (foo, "vfile_", "c", null, foo, "Unable to create a new msf component."); return; end; seg_ptr_array (comp_num) = seg_ptr; substate_arg = substate_arg + 1; end set_new_ptr; check_substate: proc; next_substate = next_substate + 1; if substate_arg = next_substate then repeating = "0"b; /* execution resumes normally */ end check_substate; set_bitcounts: entry (iocb_ptr); indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; f_b_ptr = file_base_ptr; do i = 0 to last_comp_num; if seg_limit (i) > 0 then do; if seg_ptr_array (i) = null then call msf_manager_$get_ptr (fcb_ptr, i, "0"b, seg_ptr_array (i), foo24, foo); call hcs_$set_bc_seg (seg_ptr_array (i), 36 * seg_limit (i), foo); if foo = 0 then seg_limit (i) = -seg_limit (i); end; end; return; /* end set_bitcounts code */ get_seg_ptr: entry (iocb_ptr, comp_num) returns (ptr); indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; if comp_num >= seg_ptr_array_limit then call extend_seg_ptr_array (comp_num - seg_ptr_array_limit + 1); if seg_ptr_array (comp_num) = null then do; call msf_manager_$get_ptr (fcb_ptr, comp_num, "0"b, p, foo24, foo); if p = null /* unexpected failure */ then if atb.shared /* maybe due to an asynch change */ then do; /* in case msf_manager_ bug has struck */ call msf_manager_$close (indx_cb.fcb_ptr); /* try closing and reopening msf */ call msf_manager_$open (substr (attach_descrip_string, 8, dname_len), substr (attach_descrip_string, 9 + dname_len, ename_len), indx_cb.fcb_ptr, foo); iocb_ptr -> iocb.attach_data_ptr -> atb.fcbp = indx_cb.fcb_ptr; /* The fcb may have moved */ /* between closing and opening,*/ /* so the attach_block ptr must be updated.*/ seg_ptr_array (*) = null; /* reinitialize file info */ call msf_manager_$get_ptr (indx_cb.fcb_ptr, 0, "0"b, seg_ptr_array (0), foo24, foo); indx_cb.file_base_ptr = seg_ptr_array (0); iocb_ptr -> iocb.attach_data_ptr -> atb.fsp = seg_ptr_array (0); call msf_manager_$get_ptr (indx_cb.fcb_ptr, comp_num, "0"b, p, foo24, foo); /* try one more time */ end; if (p = null) & (foo ^= 0) then do; if (true_max_comp_num > comp_num) & (foo = error_table_$noentry) then; /* Do nothing: this file has hit limit before, */ else /* but can now be extended. */ call sub_err_ (foo, "vfile_", "c", null, foo, "Can't get a pointer to this msf component."); end; else seg_ptr_array (comp_num) = p; end; return (seg_ptr_array (comp_num)); /* end get_seg_ptr */ make_designator: entry (comp_num, offset, designator); designator_struct.comp_num = comp_num; designator_struct.offset = bit (offset); return; /* end make designator */ extend_seg_ptr_array: proc (p_number_of_new_components); dcl p_number_of_new_components fixed bin; dcl comp_idx fixed bin; old_array_limit = seg_ptr_array_limit; old_array_ptr = seg_ptr_array_ptr; seg_ptr_array_limit = seg_ptr_array_limit + p_number_of_new_components; call alloc_cb_file (size (seg_ptr_array), seg_ptr_array_ptr); do comp_idx = 0 to old_array_limit; seg_ptr_array (comp_idx) = old_array (comp_idx); end; do comp_idx = old_array_limit + 1 to seg_ptr_array_limit; seg_ptr_array (comp_idx) = null; end; call free_cb_file (size (old_array), old_array_ptr); return; dcl old_array_limit fixed; dcl old_array_ptr ptr; dcl old_array (0:old_array_limit) ptr based (old_array_ptr); end; /* end extend_seg_ptrs */ dcl substate_arg fixed; dcl (comp_num, comp_number) fixed; dcl p ptr; dcl i fixed; dcl foo fixed (35); dcl foo24 fixed (24); dcl offset fixed (18); dcl abort_exit label; dcl pos_ptr ptr defined (file_position_ptr); /* not used in this module */ dcl hcs_$set_bc_seg entry (ptr, /* pointer to seg, input */ fixed bin (24), /* bit count to be set */ fixed bin (35)); /* status code */ dcl sub_err_ entry options (variable); dcl msf_manager_$close entry (ptr); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed (35)); dcl msf_manager_$get_ptr entry (ptr, /* fcb_ptr */ fixed bin, /* component number of desired segment */ bit (1), /* create switch */ ptr, /* ptr to seg or null if error, output */ fixed bin (24), /* bitcount of segment, output */ fixed bin (35)); /* status code */ dcl msf_manager_$adjust entry (ptr, fixed, fixed (24), bit (3), fixed (35)); dcl error_table_$noentry fixed bin(35) ext static; %include vfile_indx; %include iocb; %include vf_attach_block; dcl iocb_ptr ptr; end /* end create_seg_ptrs */;  delete_old_subsets.pl1 11/04/82 1940.0rew 11/04/82 1620.7 31014 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ delete_old_subsets: proc (p_iocb_ptr); /* START OF DECLARATIONS */ /* Parameter */ dcl p_iocb_ptr ptr; /* Automatic */ dcl attach_descrip char (256) varying; dcl mode fixed bin; dcl fcb_ptr ptr; dcl code fixed bin (35); dcl pos_ptr ptr; dcl iocb_ptr ptr; dcl dname char (168); dcl ename char (32); /* Based */ /* Builtin */ /* Controlled */ /* Constant */ dcl SET_BC_AND_TRUNCATE init ("110"b) bit (3) internal static options (constant); dcl myname init ("vfile_") char (6) internal static options (constant); dcl PATHNAME_START init (8) fixed bin internal static options (constant); /* Entry */ dcl msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35)); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)); dcl msf_manager_$close entry (ptr); dcl sub_err_ entry options (variable); /* External */ /* END OF DECLARATIONS */ iocb_ptr = null; indx_cb_ptr = p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_data_ptr; attach_descrip = p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.attach_descrip_string; dname = substr (attach_descrip, PATHNAME_START, p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.dname_len); ename = substr (attach_descrip, PATHNAME_START + p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.dname_len + 1, p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.ename_len); mode = p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.opening_mode; call iox_$close (p_iocb_ptr, code); if code ^= 0 then call sub_err_ (code, myname, "s", null, 0, "Unable to close the temporary for subsets."); call iox_$detach_iocb (p_iocb_ptr, code); if code ^= 0 then call sub_err_ (code, myname, "s", null, 0, "Unable to detach the switch for subsets."); call msf_manager_$open (dname, ename, fcb_ptr, code); if code ^= 0 then call sub_err_ (code, myname, "s", null, 0, "Unable to open the msf for temporary subsets."); call msf_manager_$adjust (fcb_ptr, 0, 0, SET_BC_AND_TRUNCATE, code); if code ^= 0 then call sub_err_ (code, myname, "s", null, 0, "Unable to adjust the msf ofr temporary subsets."); call msf_manager_$close (fcb_ptr); if code ^= 0 then call sub_err_ (code, myname, "s", null, 0, "Unable to close the msf ofr temporary subsets."); call iox_$attach_ptr (p_iocb_ptr, (attach_descrip), null, code); if code ^= 0 then call sub_err_ (code, myname, "s", null, 0, "Unable to attach the temporary subset vfile_."); call iox_$open (p_iocb_ptr, mode, "0"b, code); if code ^= 0 then call sub_err_ (code, myname, "s", null, 0, "Unable to open the temporary subset vfile_."); return; %include iocb; %include iox_dcls; %include vfile_indx; %include vf_attach_block; end delete_old_subsets;  fast_put.alm 11/04/82 1940.0rew 11/04/82 1633.0 18531 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** "fast_put: proc(iocb_ptr,buff_ptr,buff_len,code); name fast_put segdef fast_put fast_put: epp1 pr0|2,* pr1 gets addr of first arg epp1 pr1|0,* pr1->iocb epp1 pr1|open_data_ptr,* pr1->cb_uns_file "len=max(buff_len,0); ldq pr0|6,* q gets arg2 tpl 2,ic done if buff_len is > 0 ldq 0,dl else set len to zero "cb_uns_file.write_pos=cb_uns_file.write_pos+len; lda pr1|write_pos save old value of write pos sta pr0|8,* use last arg for temp asq pr1|write_pos advance write position "if write_pos<=cb_uns_file.write_limit then do; lda pr1|write_pos a gets new write pos cmpa pr1|write_limit write_pos::write_limit tpnz slow_put exception--make external call "record_write=buffer; epp2 pr0|4,* pr2 gets addr of buff_ptr arg epp2 pr2|0,* pr2->buffer lda pr0|8,* get saved write position epp3 pr1|seg_ptr,* pr3->segment base mlr (pr,rl),(pr,rl,al),fill(040) copy buffer into the file desc9a pr2|0,ql output buffer descrip desc9a pr3|-1(3),ql file position descrip "code=0. return, end; stz pr0|8,* arg4<--0 short_return done with put_chars operation "write_pos=write_pos-len; slow_put: lda pr0|8,* a<--saved write position sta pr1|write_pos restores write pos to former value "call open_uns_file$put_chars_uns_file(iocb_ptr,buff_ptr,buff_len,code); fld 4*2048,dl set up arg count for external call callsp |[put_chars_uns_file] handles exceptional cases short_return "declarations: equ open_data_ptr,18 in iocb equ write_pos,10 in cb_uns_file equ write_limit,2 " equ seg_ptr,0 " end  find_key.alm 11/04/82 1940.0rew 11/04/82 1633.0 52335 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** "find_key: proc(indx_cb_ptr,(key_ptr),search_code); name find_key segdef find_key find_key: epp1 pr0|2,* pr1<-->indx_cb_ptr epp1 pr1|0,* pr1<-->indx_cb epp2 pr1|file_position_ptr,* pr2<-->position_frame epp5 pr2|node_ptr,* pr5<-->node_block epp3 pr0|4,* pr3<-->key_ptr epp3 pr3|0,* pr3<-->key lxl5 pr3|0 x5<-length(key) "q=branch(branch_num).if q=0 then return; eax2 0 will be set if key found descent: ldq pr2|branch_num ql<-position_frame.branch_num qls 1 ql<-2*branch_num adq pr2|branch_num ql<-3*branch_num ldq pr5|0,ql q<-branch(branch_num) tnz get_son if branch(branch_num)^=0 ==>get_son stz pr0|6,* clear garbage in arg3 stx2 pr0|6,* set result in arg3 short_return "pos_ptr=son_position_ptr; get_son: epp2 pr2|son_position_ptr,* pr2<-son_position_ptr spri2 pr1|file_position_ptr pos_ptr<-son_position_ptr "node=q; stq pr2|node position_frame.node<-q "node_ptr=addr(seg_ptr_array(q.comp_num)->seg_array(q.offset)); eaa 0,qu au<-q.comp_num,al<-0 als 1 au<-2*q.comp_num epp5 pr1|seg_ptr_array_ptr,*au pr5<-->seg_ptr_array(comp_num) epp5 pr5|0,*ql pr5<-->seg_array(q.offset) spri5 pr2|node_ptr node_ptr<-->seg_array(q.offset) "low=1 eax3 1 low<-1 "high=last_branch_num-1; ldq pr5|last_branch_num ql<-last_branch_num sbq 1,dl ql<-last_branch_num-1 qls 18 qu<-last_branch_num, ql<-0 epp1 pr0|6,* pr1<-->arg3 stq pr1|0 high<-last_branch_num-1 epp2 pr0|4,* pr2<-->arg2 "search: i=(low+high)/2 ; search: eaq 0,3 qu<-low adq pr1|0 qu<-(low+high) qrl 1 i<-(low+high)/2 eax4 0,qu x4<-(low+high)/2 stx4 pr2|0 arg2<-(low+high)/2 adx4 pr2|0 x4<-2*i adx4 pr2|0 x4<-3*i "if substr(keys,key_pos(i),key_length(i))=key ==>not_low eax3 1,qu low=i+1 tra continue ==>continue "else if substr=key then search_code=1; not_low: tnz unequal if substr>key ==>unequal eax2 1 will be copied into arg "high=i-1; unequal: eaq -1,qu qu<-i-1 stq pr1|0 high<-i-1 "if low<=high then go to search; continue: cmpx3 pr1|0 low::high tmoz search if high>=low ==>search "branch_num=low. go to descent; done: epp1 pr0|2,* pr1<-->indx_cb_ptr epp1 pr1|0,* pr1<-->indx_cb epp2 pr1|file_position_ptr,* pr2<-->position_frame sxl3 pr2|branch_num branch_num<-low tra descent descend to leaf entry last last: epp1 pr0|2,* pr1<-->indx_cb_ptr epp1 pr1|0,* pr1<-->indx_cb epp2 pr1|file_position_ptr,* pr2<-->position_frame epp5 pr2|node_ptr,* pr5<-->node_block epp3 pr0|4,* pr3<-->key_ptr epp3 pr3|0,* pr3<-->key lxl5 pr3|0 x5<-length(key) "q=branch(branch_num).if q=0 then return; eax2 0 will be set if key found ldescent: ldq pr2|branch_num ql<-position_frame.branch_num qls 1 ql<-2*branch_num adq pr2|branch_num ql<-3*branch_num ldq pr5|0,ql q<-branch(branch_num) tnz lget_son if branch(branch_num)^=0 ==>lget_son stz pr0|6,* clear garbage in arg3 stx2 pr0|6,* set result in arg3 short_return "pos_ptr=son_position_ptr; lget_son: epp2 pr2|son_position_ptr,* pr2<-son_position_ptr spri2 pr1|file_position_ptr pos_ptr<-son_position_ptr "node=q; stq pr2|node position_frame.node<-q "node_ptr=addr(seg_ptr_array(q.comp_num)->seg_array(q.offset)); eaa 0,qu au<-q.comp_num,al<-0 als 1 au<-2*q.comp_num epp5 pr1|seg_ptr_array_ptr,*au pr5<-->seg_ptr_array(comp_num) epp5 pr5|0,*ql pr5<-->seg_array(q.offset) spri5 pr2|node_ptr node_ptr<-->seg_array(q.offset) "low=1 eax3 1 low<-1 "high=last_branch_num-1; ldq pr5|last_branch_num ql<-last_branch_num sbq 1,dl ql<-last_branch_num-1 qls 18 qu<-last_branch_num, ql<-0 epp1 pr0|6,* pr1<-->arg3 stq pr1|0 high<-last_branch_num-1 epp2 pr0|4,* pr2<-->arg2 "lsearch: i=(low+high)/2 ; lsearch: eaq 0,3 qu<-low adq pr1|0 qu<-(low+high) qrl 1 i<-(low+high)/2 eax4 0,qu x4<-(low+high)/2 stx4 pr2|0 arg2<-(low+high)/2 adx4 pr2|0 x4<-2*i adx4 pr2|0 x4<-3*i "if substr(keys,key_pos(i),key_length(i))=key ==>lnot_low low: eax3 1,qu low=i+1 tra lcontinue ==>lcontinue "else if substr=key then do search_code=1 low=i+1 end; lnot_low: tnz lunequal if substr>key ==>unequal eax2 1 will be copied into arg tra low set low=i+1 "high=i-1; lunequal: eaq -1,qu qu<-i-1 stq pr1|0 high<-i-1 "if low<=high then go to lsearch; lcontinue: cmpx3 pr1|0 low::high tmoz lsearch if high>=low ==>lsearch "branch_num=low. go to ldescent; ldone: epp1 pr0|2,* pr1<-->indx_cb_ptr epp1 pr1|0,* pr1<-->indx_cb epp2 pr1|file_position_ptr,* pr2<-->position_frame sxl3 pr2|branch_num branch_num<-low tra ldescent descend to leaf "declarations: equ file_position_ptr,22 in indx_cb equ node_ptr,4 in position_frame equ branch_num,7 in position_frame equ son_position_ptr,2 in position_frame equ node,6 in position_frame equ seg_ptr_array_ptr,8 in indx_cb equ last_branch_num,0 in node_block "this routine depends upon having branch_and_descrip_size=3 end  open_blk_file.pl1 11/08/82 1652.6rew 11/08/82 1651.2 454311 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* This module supports I/O on blocked files */ open_blk_file: proc (iocb_ptr, fcb_ptr_arg, first_seg_ptr, is_new_file, mode, close_x, first_seg_bitcount, max_comp_size, code); code = 0; if is_new_file | ((first_seg_ptr -> bf_head.end_pos = 0) & (mode > 4) & (atb.max_rec_len > 0) & ^atb.inv_lock_reset) then do; /* initialize empty file */ first_seg_ptr -> bf_head.max_rec_len = iocb_ptr -> iocb.attach_data_ptr -> atb.max_rec_len; /* determines block size */ first_seg_ptr -> bf_head.max_comp_size = max_comp_size; if is_new_file then call hcs_$set_bc_seg (first_seg_ptr, 36 * (size (bf_head)), code); /* sets initial bitcount */ first_seg_ptr -> bf_head.version = current_bf_version; end; call create_initialize_cb; /* prepare control block */ call create_seg_ptrs; /* allocates seg_ptr_array if msf */ if (cb_ptr -> cb.file_base_ptr -> bf_head.file_action ^= 0) & (mode > 4) /* operation in progress and output opening */ then call adjust_op; /* adjusts the inconsistency */ if (code = 0) & (file_base_ptr -> bf_head.version ^= current_bf_version /* old or bad file */) then if mode > 4 /* modify opening */ then call convert_file; /* brings version up to date */ else cb.old_version = "1"b; /* can use without converting if input-only */ if code = 0 then call set_entries_and_positions; /* opening is successful */ else do; /* cleanup */ call free_seg_ptrs; /* de-allocates seg_ptr_array if msf */ call free_cb_file (size (cb), cb_ptr); /* release open_data_block */ return; end; if mode > 4 then if ^cb.shared then do; /* set action and time_stamp */ file_base_ptr -> bf_head.file_action = unshared_opening; file_base_ptr -> bf_head.time_last_modified = clock (); return; end; else go to unlock; /* leave unlocked for shared openings */ exit: return; /* end of open routine */ verify_done: if cb.shared then if file_base_ptr -> bf_head.time_last_modified ^= initial_time_stamp then do; /* asynch changes--must retry or abort */ cb.scan_backward = was_scan_backward; cb.current_pos = old_current_pos; cb.next_pos = old_next_pos; cb.current_status = old_current_status; if clock () < time_limit /* time left to keep trying */ then go to retry_ent (current_entry); code = error_table_$file_busy; /* unable to verify result in time */ end; return; /* back to caller */ init_entry: /* initialization for passive shared operations */ if cb.wait_time < 0 then time_limit = forever; else time_limit = clock () + cb.micro_wait_time; was_scan_backward = cb.scan_backward; old_current_pos = cb.current_pos; old_next_pos = cb.next_pos; old_end_pos = cb.end_pos; /* save for detecting asynch eof changes */ old_current_status = cb.current_status; cb.as_ins_del = "00"b; /* set if asynch insertion or deletion detected */ if cb.handler_required /* asynch component deletions possible */ then do; setup_handler: comp_num = 0; /* initial ref is to header comp */ on seg_fault_error begin; /* deals with asynch comp deletions */ on seg_fault_error system; /* fuck you */ dname = substr (attach_descrip_string, 8, dname_len); ename = substr (attach_descrip_string, 9 + dname_len, ename_len); on seg_fault_error go to inv_header; call hcs_$status_mins (cb.file_base_ptr, type, bc, foo); if foo ^= 0 then do; /* re-initiate header ptr */ inv_header: on seg_fault_error system; call hcs_$terminate_seg (cb.file_base_ptr, 1, foo); call hcs_$initiate ((dname), (ename), "", 1, 1, cb.file_base_ptr, foo); /* re-initiate header component, in case this was cause of fault */ if foo = 0 then go to resume; dname = dname || ">" || ename; /* probably is an msf */ call hcs_$initiate ((dname), "0", "", 1, 1, cb.file_base_ptr, foo); if foo = 0 /* header ptr had to be re-initialized, msf case */ then go to resume; end; else if comp_num > 0 /* may have faulted because of ref to later comp */ then do; /* try re-initiating this component if necessary */ on seg_fault_error system; call hcs_$status_mins (cb.seg_ptr_array_ptr -> seg_ptr_array (comp_num), type, bc, foo); if foo ^= 0 then do; /* re-obtain ptr to component */ dname = dname || ">" || ename; call hcs_$terminate_seg (seg_ptr_array (comp_num), 1, foo); call hcs_$initiate ((dname), ltrim (char (comp_num)), "", 1, 1, cb.seg_ptr_array_ptr -> seg_ptr_array (comp_num), foo); if foo = 0/* that was the problem */ then go to resume; end; end; call continue_to_signal_ (foo); /* unaccountable error */ resume: dcl dname char (168) var; dcl ename char (32) var; dcl type fixed (2); dcl bc fixed (24); dcl foo fixed (35); end; /* end of handler logic */ end; go to retry_ent (current_entry); /* continue with operation */ position_blk_file: entry (iocb_ptr, pos_type, n_recs, code); cb_ptr = iocb_ptr -> iocb.open_data_ptr; if cb.shared then do; current_entry = 1; go to init_entry; retry_ent (1): call prepare_process; end; code = 0; if pos_type = 2 /* direct positioning */ then if n_recs < 0 /* absolute position must be >=0 */ then code = error_table_$negative_nelem; else if (n_recs > cb_ptr -> cb.end_pos) & ^cb.noend /* attempt to pass eof */ then do; /* signal error and go to end of file */ eof_error: call position_eof; code = error_table_$end_of_info; end; else do; /* successful position operation */ cb_ptr -> cb.next_pos = n_recs; cb_ptr -> cb.current_pos = n_recs; cb.current_status = "00"b; /* indicates that record is not definitely known to be either present or absent */ end; else if pos_type = 0 /* relative positioning */ then if (cb.as_ins_del = "01"b) & ^cb.noend then do; code = error_table_$asynch_deletion; /* warn user his position is not where he may think */ cb.current_status = "01"b; /* current known absent */ end; else do; /* skip forward or backward */ cb_ptr -> cb.next_pos = cb_ptr -> cb.next_pos + n_recs; /* move next position */ if cb_ptr -> cb.next_pos < 0 /* attempt to pass bof */ then do; /* signal error and go to file base */ call position_bof; code = error_table_$end_of_info; end; else if (cb_ptr -> cb.next_pos > cb_ptr -> cb.end_pos) & ^cb.noend /* attempt to pass eof */ then go to eof_error; else do; cb.current_status = "00"b; cb_ptr -> cb.current_pos = cb_ptr -> cb.next_pos; /* successful skip */ end; end; else if pos_type = -1 /* beginning of file */ then call position_bof; else if pos_type = 1 /* end of file */ then call position_eof; else do; code = error_table_$bad_arg; return; /* don't alter scan state */ end; cb_ptr -> cb.scan_backward = ((code = 0) & (pos_type = 0) & (n_recs < 0)); /* for masking logically absent records */ go to verify_done; /* end of main position routine */ read_length_blk_file: entry (iocb_ptr, rec_len, code); cb_ptr = iocb_ptr -> iocb.open_data_ptr; if cb.shared then do; current_entry = 2; go to init_entry; retry_ent (2): call prepare_process; end; call find_next_record; /* sets code */ if code = 0 /* record found at next position */ then rec_len = max (0, seg_ptr -> seg (pos)); /* record length at record head */ go to verify_done; /* end of read_length routine */ read_blk_file: entry (iocb_ptr, buff_ptr, buff_len, rec_len, code); cb_ptr = iocb_ptr -> iocb.open_data_ptr; if cb.shared then do; current_entry = 3; go to init_entry; retry_ent (3): call prepare_process; end; call find_next_record; if code = 0 /* record found */ then do; /* read the record */ rec_len = max (0, seg_ptr -> seg (pos));/* length in record header */ if rec_len > buff_len /* record too big for buffer */ then do; /* signal error, but still prepare to move part record */ code = error_table_$long_record; n = buff_len; /* smaller than rec_len */ end; else n = rec_len; /* move entire record into buffer */ if n > 0 /* in case negative */ then substr (buff_ptr -> buffer, 1, n) = substr (seg_ptr -> seg_str, 4 * (pos + 1) + 1, n); /* move record into buffer */ cb_ptr -> cb.next_pos = cb_ptr -> cb.next_pos + 1; /* advance next record position */ end; go to verify_done; /* end of read_record routine */ end_update: if cb.shared then do; file_base_ptr -> bf_head.file_action = 0; /* mark operation complete */ go to unlock; end; return; unlock_exit: if cb.shared then do; unlock: if stacq (file_base_ptr -> bf_head.file_lock, "0"b, cb.saved_lock_copy) /* resets the lock */ then ; end; return; /* exit */ write_blk_file: entry (iocb_ptr, buff_ptr, buff_len, code); cb_ptr = iocb_ptr -> iocb.open_data_ptr; code = 0; if buff_len > cb_ptr -> cb.max_rec_len /* record length exceeds maximum */ then code = error_table_$long_record; else if buff_len < 0 then code = error_table_$negative_nelem; else do; if cb.shared then do; if cb.handler_required /* comps may vanish */ then do; /* handle seg_fault_errors */ current_entry = 6; /* handler must be in my frame */ go to setup_handler;/* kludged call */ end; /* now OK to reference file */ retry_ent (6): call lock_file_check; end; if cb_ptr -> cb.next_pos < cb_ptr -> cb.end_pos /* not at end of file */ then if cb_ptr -> cb.appending | (cb_ptr -> cb.mode = 5) then do; /* go to eof--not an error */ action = append; call position_eof; /* instead go to end of file */ end; else if cb.as_ins_del = "10"b then do; /* warn user he is not appending as expected */ code = error_table_$asynch_insertion; cb.current_status = "00"b; /* still may be logically deleted, however */ cb.scan_backward = "0"b; end; else if cb_ptr -> cb.mode = 6 /* input_output */ then action = write_trunc; /* truncate after write */ else action = rewrite; /* replace an existing rec */ else if cb.as_ins_del = "01"b then if ^cb_ptr -> cb.noend & (cb_ptr -> cb.mode = 5) /* output opening */ then do; /* no error--just get back to eof */ action = append; call position_eof; end; else do; /* asynchronously moved to eof--warn him */ code = error_table_$asynch_deletion; cb.current_status = "01"b; /* known absent */ cb.scan_backward = "0"b; end; else action = append; /* extending file */ cb_ptr -> cb.current_pos = cb_ptr -> cb.next_pos; /* set current position */ if code ^= 0 /* asynch insertion or deletion */ then go to unlock_exit; end; if code = 0 then do; if cb_ptr -> cb.ssf_sw /* might be full */ then if cb_ptr -> cb.current_pos >= cb_ptr -> cb.capacity /* not enough room */ then do; code = error_table_$file_is_full; go to unlock_exit; end; call init_update (action); call get_current_pos; if comp_num > cb_ptr -> cb.last_comp_num/* must extend msf */ then do while (comp_num > cb.last_comp_num); call set_bc (cb_ptr -> cb.capacity); /* set bitcount of full component */ call extend_seg_ptr_array (cb.last_comp_num + 1); /* may re-allocate seg_ptr_array */ cb_ptr -> cb.last_comp_num = cb.last_comp_num + 1; call msf_manager_$get_ptr (cb.fcb_ptr, cb.last_comp_num, "1"b, seg_ptr, foo24, code); /* create a new component */ if code ^= 0 then go to exit; cb.seg_ptr_array_ptr -> seg_ptr_array (cb.last_comp_num) = seg_ptr; file_base_ptr -> bf_head.last_comp = cb.last_comp_num; end; else seg_ptr = get_seg_ptr (comp_num); call insert_record; /* does the assignment */ if cb_ptr -> cb.current_pos >= cb_ptr -> cb.end_pos /* at eof */ then do; if cb.shared then file_base_ptr -> bf_head.end_pos = cb.next_pos; cb_ptr -> cb.end_pos = cb_ptr -> cb.next_pos; /* advance end */ end; else if action = write_trunc /* must truncate now */ then do; call truncate_file; /* truncates at next position */ cb.current_pos = cb.next_pos - 1; end; /* current_pos at record just written, next at eof */ go to end_update; /* clears action and unlocks if shared */ end; return; /* end of write_record routine */ rewrite_blk_file: entry (iocb_ptr, buff_ptr, buff_len, code); cb_ptr = iocb_ptr -> iocb.open_data_ptr; if buff_len > cb_ptr -> cb.max_rec_len /* record length exceeds maximum */ then code = error_table_$long_record; else if buff_len < 0 then code = error_table_$negative_nelem; else do; /* proceed with rewrite */ if cb.shared then do; if cb.handler_required then do; current_entry = 7; go to setup_handler; end; retry_ent (7): call lock_file_check; end; if cb.current_pos >= cb.end_pos /* end of file */ then do; if cb.as_ins_del = "01"b then code = error_table_$asynch_deletion; else code = error_table_$no_record; cb.current_status = "01"b; /* known absent */ cb.scan_backward = "0"b; go to unlock_exit; /* abort */ end; call get_current_pos; seg_ptr = get_seg_ptr (comp_num); if seg_ptr -> seg (pos) = 0 /* logically absent record--error */ then do; if cb.current_status = "10"b /* should be present */ then code = error_table_$asynch_deletion; else code = error_table_$no_record; cb.current_status = "01"b; /* now we know it's absent */ end; else do; /* successful rewrite */ call init_update (rewrite); code = 0; call insert_record; /* does the work */ go to end_update; end; go to unlock_exit; end; return; /* end of rewrite routine */ delete_blk_file: entry (iocb_ptr, code); cb_ptr = iocb_ptr -> iocb.open_data_ptr; if cb.shared then do; if cb.handler_required then do; current_entry = 8; go to setup_handler; end; retry_ent (8): call lock_file_check; end; if cb.current_pos >= cb.end_pos /* at or beyond eof */ then do; /* treat as an error */ if cb.as_ins_del = "01"b then code = error_table_$asynch_deletion; else code = error_table_$no_record; cb.current_status = "01"b; cb.scan_backward = "0"b; go to unlock_exit; end; call get_current_pos; seg_ptr = get_seg_ptr (comp_num); if seg_ptr -> seg (pos) = 0 /* already deleted or not present */ then do; if cb.current_status = "10"b then code = error_table_$asynch_deletion; else code = error_table_$no_record; cb.current_status = "01"b; end; else do; /* successful deletion */ if cb.current_pos = cb.end_pos - 1 /* last record */ then action = eof_delete; else action = non_eof_delete; call init_update (action); code = 0; unspec (addr (seg_ptr -> seg (pos)) -> record_block) = "0"b; /* zero entire block */ if action = non_eof_delete then do; cb.current_status = "00"b; cb_ptr -> cb.current_pos = cb_ptr -> cb.current_pos + 1; /* advance */ end; else call set_true_eof; /* finds last non-deleted record */ cb_ptr -> cb.next_pos = cb_ptr -> cb.current_pos; /* by convention after delete */ cb_ptr -> cb.scan_backward = "0"b; /* resume default forward scanning */ go to end_update; end; go to unlock_exit; control_blk_file: entry (iocb_ptr, order, info_ptr, code); cb_ptr = iocb_ptr -> iocb.open_data_ptr; code = 0; if order = "read_position" then do; /* return next record and end of file positions */ if cb.shared then do; current_entry = 4; go to init_entry; retry_ent (4): call prepare_process; end; info_ptr -> info1.end_pos = cb_ptr -> cb.end_pos; /* get eof position */ info_ptr -> info1.next_pos = cb_ptr -> cb.next_pos; /* get next position */ go to verify_done; end; else if order = "record_status" then do; rs_info_ptr = info_ptr; if (rs_info.version < rs_info_version_1) | (rs_info.version > rs_info_version_2) then code = error_table_$unimplemented_version; else if substr (string (rs_info.flags), 1, 6) ^= "0"b /* only 7th bit is supported */ then code = error_table_$bad_arg; else do; /* fill in info structure */ if cb.shared then do; current_entry = 5; go to init_entry; retry_ent (5): call prepare_process; end; if rs_info.locate_pos_sw /* set position */ then if (rs_info.record_length >= cb.end_pos) & ^cb_ptr -> cb.noend then go to norec; else do; /* use record_length arg as absolute pos */ cb.next_pos = rs_info.record_length; cb.current_pos = rs_info.record_length; cb.scan_backward = "0"b; end; else if cb.current_pos >= cb.end_pos then do; norec: if cb.as_ins_del = "01"b then code = error_table_$asynch_deletion; else code = error_table_$no_record; cb.current_status = "01"b; go to exit; /* no need to verify */ end; call get_current_pos; seg_ptr = get_seg_ptr (comp_num); rs_info.max_rec_len = cb.max_rec_len; rs_desc.comp_num = comp_num; rs_desc.offset = pos_bits; if seg_ptr ^= null then do; rs_info.record_ptr = addr (seg_ptr -> seg (pos + 1)); rs_info.record_length = max (0, seg_ptr -> seg (pos)); end; if (seg_ptr = null) | ((seg_ptr -> seg (pos) = 0) & ^cb_ptr -> cb.old_version) then do; /* error--logically absent record */ if cb.current_status = "10"b then code = error_table_$asynch_deletion; else code = error_table_$no_record; cb.current_status = "01"b; rs_info.record_ptr = null; rs_info.record_length = 0; end; else code = 0; go to verify_done; end; end; else if (order = "truncate") & (cb_ptr -> cb.mode > 4) then do; if cb.shared then do; if cb.handler_required then do; current_entry = 9; go to setup_handler; end; retry_ent (9): call lock_file_check; end; if cb.next_pos > cb.end_pos /* beyond end of file--error */ then do; if cb.as_ins_del = "01"b then code = error_table_$asynch_deletion; else code = error_table_$end_of_info; cb.current_status = "01"b; go to unlock_exit; end; cb.current_pos = cb.next_pos; cb.scan_backward = "0"b; if ^cb.shared then do; file_base_ptr -> bf_head.file_action = truncate; call truncate_file; file_base_ptr -> bf_head.file_action = unshared_opening; return; end; call init_update (truncate); call truncate_file; /* does the truncation at next_record_pos */ go to end_update; end; else if order = "max_rec_len" then do; /* obtain and possibly set the file's max_rec_len */ info_ptr -> info2.old_max_recl = cb_ptr -> cb.max_rec_len; if info_ptr -> info2.new_max_recl < 0 /* negative length is meaningless */ then code = error_table_$negative_nelem; else if info_ptr -> info2.new_max_recl > 0 /* indicates setting desired */ then if (cb_ptr -> cb.mode = 4) /* changing max_rec_len not permitted unless file empty and opened for output */ then code = error_table_$no_operation; else do; /* OK to change max_rec_len */ if cb.shared then do; if cb.handler_required then do; current_entry = 10; go to setup_handler; end; retry_ent (10): call lock_file_check; file_base_ptr -> bf_head.time_last_modified = clock (); cb.old_time_stamp = file_base_ptr -> bf_head.time_last_modified; end; if cb.end_pos > 0 then code = error_table_$no_operation; else do; cb_ptr -> cb.file_base_ptr -> bf_head.max_rec_len = info_ptr -> info2.new_max_recl; call set_maxl; /* propagates change to cb variables */ end; go to unlock_exit; end; end; else if order = "file_status" then do; call vfile_status_$seg (iocb_ptr, cb.file_base_ptr, info_ptr, code); return; end; else if order = "io_call" then call vfile_io_control (iocb_ptr, cb.file_base_ptr, info_ptr, code); else code = error_table_$no_operation; /* invalid order call */ return; /* end of main control routine */ close_blk_file: entry (iocb_ptr); /* cleanup routine called by vfile_attach */ cb_ptr = iocb_ptr -> iocb.open_data_ptr; if cb_ptr -> cb.mode > 4 /* eof may have moved */ then do; /* set end of file properly */ if cb.shared /* file not locked */ then do; if cb.handler_required then do; current_entry = 11; go to setup_handler; end; retry_ent (11): if ^stac (addr (file_base_ptr -> bf_head.file_lock), cb.saved_lock_copy) then go to just_cleanup; /* unable to lock--let other user close */ else if file_base_ptr -> bf_head.file_action ^= 0 then do; /* leave locked invalidly */ leave_locked: if stacq (file_base_ptr -> bf_head.file_lock, (36)"1"b, cb.saved_lock_copy) then ; /* make the lock invalid */ go to just_cleanup; end; else if cb.old_time_stamp ^= file_base_ptr -> bf_head.time_last_modified then call reinit_cb_vars; /* for asynch changes */ else ; /* cb info is valid */ end; else if (file_base_ptr -> bf_head.file_action ^= unshared_opening) & (file_base_ptr -> bf_head.file_action ^= 0) then go to leave_locked; call position_eof; call get_current_pos; rel_pos = cb_ptr -> cb.end_pos - base_pos; /* eof position relative to base of last comp */ if (rel_pos = 0) & (cb_ptr -> cb.end_pos > 0) /* eof at seg_end */ then rel_pos = cb_ptr -> cb.capacity; /* indicates last comp is full */ call set_bc (rel_pos); /* set bitcount of last_comp_num */ cb_ptr -> cb.file_base_ptr -> bf_head.end_pos = cb_ptr -> cb.end_pos; /* set end position in header */ file_base_ptr -> bf_head.file_action = 0; if stacq (file_base_ptr -> bf_head.file_lock, "0"b, cb.saved_lock_copy) /* unlock the file */ then ; end; just_cleanup: call free_seg_ptrs; /* de-allocates seg_ptr_array, if any */ call free_cb_file (size (cb), cb_ptr); /* deallocates open data block */ return; /* end of close routine */ find_next_record: proc; /* locates record at next position */ do while ("1"b); /* may loop past logically absent records */ cb_ptr -> cb.current_pos = cb_ptr -> cb.next_pos; if cb_ptr -> cb.current_pos >= cb_ptr -> cb.end_pos /* beyond eof */ then do; /* error--at end of file */ cb.current_status = "01"b; /* no current record */ if cb.as_ins_del = "01"b then code = error_table_$asynch_deletion; else code = error_table_$end_of_info; cb_ptr -> cb.scan_backward = "0"b; /* reset to default forward scanning */ return; end; else do; /* next record found */ call get_current_pos; seg_ptr = get_seg_ptr (comp_num); if (seg_ptr -> seg (pos) ^= 0) | cb.old_version /* not logically absent */ then do; code = 0; cb.current_status = "10"b; /* known to be present */ cb.scan_backward = "0"b; return; end; else if cb.current_status = "10"b /* should have been present */ then do; code = error_table_$asynch_deletion; cb.current_status = "01"b; return; end; cb.current_status = "00"b; /* will have to scan */ if cb_ptr -> cb.scan_backward /* preceding operation was backspace */ then if cb_ptr -> cb.next_pos <= 0 /* at bof */ then do; /* error--scanned to bof */ code = error_table_$end_of_info; cb.scan_backward = "0"b; cb.current_status = "01"b; return; end; else cb_ptr -> cb.next_pos = cb_ptr -> cb.next_pos - 1; /* scan backward */ else cb_ptr -> cb.next_pos = cb_ptr -> cb.next_pos + 1; /* scan forward--default case */ end; end; /* end of scan loop */ end find_next_record; get_seg_ptr: proc (comp) returns (ptr); if cb.seg_ptr_array_ptr -> seg_ptr_array (comp) = null then call msf_manager_$get_ptr (cb.fcb_ptr, comp, "0"b, cb.seg_ptr_array_ptr -> seg_ptr_array (comp), foo24, foo); return (cb.seg_ptr_array_ptr -> seg_ptr_array (comp)); dcl comp fixed; end get_seg_ptr; get_current_pos: proc; comp_num = divide (cb_ptr -> cb.current_pos, capacity, 34, 0); base_pos = comp_num * cb_ptr -> cb.capacity; pos = (cb.current_pos - base_pos) * cb.block_size + size (bf_head); end get_current_pos; prepare_process: proc; /* initialize for attempt at passive shared operation */ code = 0; do while ("1"b); /* wait loop */ initial_time_stamp = file_base_ptr -> bf_head.time_last_modified; if file_base_ptr -> bf_head.file_action = 0 then go to not_busy; lock_copy = file_base_ptr -> bf_head.file_lock; if stac (addr (lock_copy), cb.saved_lock_copy) then go to not_busy; if clock () >= time_limit then do; file_busy: code = error_table_$file_busy; go to exit; /* abort entire operation */ end; call set_lock_$lock (lock_copy, 1, code); if code ^= error_table_$lock_wait_time_exceeded then go to file_busy; end; /* end of wait loop */ not_busy: if initial_time_stamp ^= cb.old_time_stamp then do; call reinit_cb_vars; /* note asynch header changes */ cb.old_time_stamp = initial_time_stamp; end; dcl lock_copy bit (36) aligned; end prepare_process; reinit_cb_vars: proc; /* used to reinitialize cb variables to corresponding header values after detecting asynch changes since last saving these vals */ if cb.end_pos ^= file_base_ptr -> bf_head.end_pos then do; if (cb.current_pos < old_end_pos) & (cb.current_pos >= file_base_ptr -> bf_head.end_pos) then cb.as_ins_del = "01"b; else if (cb.current_pos >= old_end_pos) & (cb.current_pos < file_base_ptr -> bf_head.end_pos) then cb.as_ins_del = "10"b; else cb.as_ins_del = "00"b; cb.end_pos = file_base_ptr -> bf_head.end_pos; end; if ^cb.noend then if cb.current_pos >= cb.end_pos /* asynch deletions from eof */ then call position_eof; /* might be more reasonable to return an error code as well--in any case we can't let user stay at an impossible position */ if cb.last_comp_num ^= file_base_ptr -> bf_head.last_comp then do; call extend_seg_ptr_array (file_base_ptr -> bf_head.last_comp); cb.last_comp_num = file_base_ptr -> bf_head.last_comp; end; if cb.max_rec_len ^= file_base_ptr -> bf_head.max_rec_len then call set_maxl; /* asynch record size change */ end reinit_cb_vars; insert_record: proc; /* places buffer contents into current record position */ cb_ptr -> cb.next_pos = cb_ptr -> cb.current_pos + 1; /* set next position to following record */ if buff_len <= 0 /* special case zero length records to distinguish from logically absent */ then seg_ptr -> seg (pos) = -1; /* convention for zero-length records */ else do; /* copy buffer and set record_length */ substr (seg_ptr -> seg_str, 4 * (pos + 1) + 1, buff_len) = substr (buff_ptr -> buffer, 1, buff_len); /* copy buffer contents */ seg_ptr -> seg (pos) = buff_len; /* sets record length */ end; cb_ptr -> cb.scan_backward = "0"b; /* resume default forward scanning */ cb.current_status = "10"b; end insert_record; lock_file_check: proc; /* used to lock file in shared openings */ if ^stac (addr (file_base_ptr -> bf_head.file_lock), cb.saved_lock_copy) then do; /* more effort required to set lock */ call set_lock_$lock (file_base_ptr -> bf_head.file_lock, cb.wait_time, code); if code ^= 0 /* as we expect unless it was just unlocked */ then if code = error_table_$invalid_lock_reset then code = 0; /* file_action will still be checked */ else do; /* locked by live process--abort or may interfere */ code = error_table_$file_busy; go to exit; /* external return to caller */ end; end; old_end_pos = cb.end_pos; cb.as_ins_del = "00"b; if cb.old_time_stamp ^= file_base_ptr -> bf_head.time_last_modified then do; call reinit_cb_vars; /* note asynch header changes */ cb.old_time_stamp = file_base_ptr -> bf_head.time_last_modified; end; if file_base_ptr -> bf_head.file_action ^= 0 /* update in progress */ then call adjust_op; /* cleans up interrupted operation */ end lock_file_check; init_update: proc (action_code); /* sets file_action and time_last_modified */ /* for shared updates--otherwise header is only altered on closing or when a truncate operation occurs */ if ^cb.shared then return; file_base_ptr -> bf_head.change_pos = cb.current_pos; /* save position at which change is to occur */ file_base_ptr -> bf_head.file_action = action_code; /* identifies which update entry is involved */ file_base_ptr -> bf_head.time_last_modified = clock (); /* tells shared readers that the file has changed asynchronously */ cb.old_time_stamp = file_base_ptr -> bf_head.time_last_modified; dcl action_code fixed; end init_update; /* file marked as having an operation in progress */ position_eof: proc; /* sets positions to end of file */ cb.current_status = "01"b; /* current record not defined */ cb_ptr -> cb.next_pos = cb_ptr -> cb.end_pos; cb_ptr -> cb.current_pos = cb_ptr -> cb.end_pos; end position_eof; position_bof: proc; /* sets positions to beginning of file */ cb.current_status = "00"b; /* current record status unknown */ cb_ptr -> cb.next_pos = 0; cb_ptr -> cb.current_pos = 0; end position_bof; set_true_eof: proc; /* sets eof after last non-deleted record */ do while (cb.current_pos > 0); /* find true eof */ cb_ptr -> cb.current_pos = cb_ptr -> cb.current_pos - 1; /* backspace */ call get_current_pos; /* look at preceding record */ seg_ptr = get_seg_ptr (comp_num); if seg_ptr -> seg (pos) ^= 0 /* record found */ then do; cb_ptr -> cb.current_pos = cb_ptr -> cb.current_pos + 1; go to set_eof; /* exit from loop */ end; end; /* backspace loop */ set_eof: cb_ptr -> cb.end_pos = cb_ptr -> cb.current_pos; if cb.shared then file_base_ptr -> bf_head.end_pos = cb.end_pos; cb.current_status = "01"b; end set_true_eof; create_initialize_cb: proc; /* prepares open data block */ call alloc_cb_file (size (cb), cb_ptr); /* allocates space in linkage section */ iocb_ptr -> iocb.open_data_ptr = cb_ptr; /* set pointer in iocb */ cb_ptr -> cb.mode = mode; /* save opening mode */ cb_ptr -> cb.file_base_ptr = first_seg_ptr; /* pointer to base of file component */ cb_ptr -> cb.appending = iocb_ptr -> iocb.attach_data_ptr -> atb.appending; /* causes positioning to eof instead of truncation in input_output openings */ cb.fcb_ptr = fcb_ptr_arg; cb.is_msf = atb.msf; cb.ssf_sw = atb.ssf; cb.noend = atb.noend_sw; cb.scan_backward = "0"b; /* determines direction of scanning over logically absent records */ cb.old_version = "0"b; /* for read-only openings on old version files */ cb.shared = atb.shared; cb.saved_lock_copy = "0"b; cb.as_ins_del = "00"b; call set_lock_$lock (cb.saved_lock_copy, 0, foo); if cb.shared then do; current_entry = 12; go to setup_handler; end; retry_ent (12): if file_base_ptr -> bf_head.version = current_bf_version then cb.last_comp_num = file_base_ptr -> bf_head.last_comp; else cb.last_comp_num = atb.last_comp; if (mode > 4) & (file_base_ptr -> bf_head.max_comp_size <= 0) /* old file */ then file_base_ptr -> bf_head.max_comp_size = max_comp_size; cb_ptr -> cb.max_comp_size = file_base_ptr -> bf_head.max_comp_size; /* needed to determine capacity */ call set_maxl; /* initializes max_len dependent cb variables */ cb_ptr -> cb.end_pos = file_base_ptr -> bf_head.end_pos; /* get eof position */ if cb.shared then do; /* see if asynch component deletions possible */ call hcs_$get_safety_sw_seg (file_base_ptr, safety_sw, code); cb.handler_required = ^ssf_sw & (^safety_sw | ^is_msf); cb.wait_time = atb.wait_time; cb.micro_wait_time = 1000000 * cb.wait_time; cb.old_time_stamp = file_base_ptr -> bf_head.time_last_modified; end; end create_initialize_cb; set_entries_and_positions: proc; /* sets iocb entries for valid operations and positions to start or end of file depending on opening mode */ close_x = close_blk_file; /* close routine called by vfile_attach */ call position_bof; if mode ^= 5 /* input operations supported */ then do; /* set passive entries */ iocb_ptr -> iocb.read_record = read_blk_file; iocb_ptr -> iocb.read_length = read_length_blk_file; iocb_ptr -> iocb.position = position_blk_file; iocb_ptr -> iocb.control = control_blk_file; end; else do; /* output-only opening */ iocb_ptr -> iocb.control = control_blk_file; iocb_ptr -> iocb.write_record = write_blk_file; end; if mode = 6 /* input_output */ then iocb_ptr -> iocb.write_record = write_blk_file; else if mode = 7 /* sequential_update */ then do; /* output operations also supported */ iocb_ptr -> iocb.write_record = write_blk_file; iocb_ptr -> iocb.rewrite_record = rewrite_blk_file; iocb_ptr -> iocb.delete_record = delete_blk_file; end; if (mode = 5) | ((mode = 6) & (^cb_ptr -> cb.appending)) /* output or input_output without -append attach option */ then call position_eof; /* position at open should be eof */ end set_entries_and_positions; truncate_file: proc; /* truncates file at next record position */ cb_ptr -> cb.current_pos = cb.next_pos; cb_ptr -> cb.end_pos = cb_ptr -> cb.next_pos; /* next position becomes eof */ cb_ptr -> cb.file_base_ptr -> bf_head.end_pos = cb_ptr -> cb.end_pos; /* mark new eof in file header */ if ^cb.is_msf then call hcs_$truncate_seg (cb_ptr -> cb.file_base_ptr, size (bf_head) + cb_ptr -> cb.end_pos * cb_ptr -> cb.block_size, code); /* truncates the file */ else do; call get_current_pos; if (base_pos = cb.end_pos) & (comp_num > 0) /* end of segment case */ then do; /* don't keep last seg with just a header */ comp_num = comp_num - 1; /* true last comp */ pos = size (bf_head) + cb.capacity * cb.block_size; /* word offset of first word beyond last record in the file */ end; call msf_manager_$adjust (cb.fcb_ptr, comp_num, 36 * pos, "010"b, code); file_base_ptr -> bf_head.last_comp = comp_num; cb.last_comp_num = comp_num; end; call set_true_eof; /* in case preceding records are absent anyway */ cb.next_pos = cb.end_pos; end truncate_file; set_maxl: proc; /* sets cb variables which depend on max_rec_len */ cb_ptr -> cb.max_rec_len = cb_ptr -> cb.file_base_ptr -> bf_head.max_rec_len; /* use max from file header */ cb_ptr -> cb.block_size = divide (cb_ptr -> cb.max_rec_len + 7, 4, 19, 0); /* block has single word header */ cb_ptr -> cb.capacity = divide (cb_ptr -> cb.max_comp_size - size (bf_head), cb_ptr -> cb.block_size, 17, 0); /* capacity of each seg, in records */ end set_maxl; create_seg_ptrs: proc; /* allocates seg_ptr_array if file is an msf */ if cb.last_comp_num <= 0 then do; /* ssf case--just return */ cb_ptr -> cb.seg_ptr_array_limit = -1; /* indicates no separate allocation */ cb_ptr -> seg_ptr_array_ptr = addr (cb.file_base_ptr); /* superimpose array */ return; end; cb.seg_ptr_array_limit = max (3, cb.last_comp_num); call alloc_cb_file (size (seg_ptr_array), cb.seg_ptr_array_ptr); do i = 0 to cb.seg_ptr_array_limit; /* initialize array to null */ cb.seg_ptr_array_ptr -> seg_ptr_array (i) = null; end; seg_ptr_array (0) = cb.file_base_ptr; end create_seg_ptrs; free_seg_ptrs: proc; /* de-allocates seg_ptr_array, if any */ if cb_ptr -> cb.seg_ptr_array_limit < 0 /* no array */ then return; call free_cb_file (size (seg_ptr_array), cb_ptr -> cb.seg_ptr_array_ptr); end free_seg_ptrs; extend_seg_ptr_array: proc (new_last_comp); /* may re-allocate seg_ptr_array to accomodate a new msf component */ if new_last_comp <= cb.seg_ptr_array_limit /* enough room */ then return; if ^cb_ptr -> cb.is_msf /* msf not yet opened */ then do; call msf_manager_$open (substr (attach_descrip_string, 8, dname_len), substr (attach_descrip_string, 9 + dname_len, ename_len), cb.fcb_ptr, foo); cb_ptr -> cb.is_msf = "1"b; atb.fcbp = cb.fcb_ptr; end; old_array_limit = cb.seg_ptr_array_limit; cb.seg_ptr_array_limit = 4 * divide (new_last_comp + 4, 4, 17, 0) - 1; old_array_ptr = cb.seg_ptr_array_ptr; call alloc_cb_file (size (seg_ptr_array), cb.seg_ptr_array_ptr); do i = 0 to cb.seg_ptr_array_limit; /* initialize array to null */ cb.seg_ptr_array_ptr -> seg_ptr_array (i) = null; end; do i = 0 to cb.last_comp_num; cb.seg_ptr_array_ptr -> seg_ptr_array (i) = old_seg_ptr_array (i); end; if old_array_limit > 0 /* old array was separately allocated */ then call free_cb_file (size (old_seg_ptr_array), old_array_ptr); dcl old_seg_ptr_array (0:old_array_limit) ptr based (old_array_ptr); dcl old_array_limit fixed; dcl old_array_ptr ptr; dcl new_last_comp fixed; end extend_seg_ptr_array; set_bc: proc (nrecs); /* sets bitcount on last comp */ call hcs_$set_bc_seg (get_seg_ptr (cb.last_comp_num), 36 * (size (bf_head) + nrecs * cb.block_size), foo); dcl nrecs fixed (19); end set_bc; adjust_file: proc; /* called when an interrupted opening is detected */ call adjust_bit_count_ (substr (attach_descrip_string, 8, dname_len), substr (attach_descrip_string, 9 + dname_len, ename_len), "0"b, bc, code); /* find last non-zero word */ if bc > 0 then do; /* proceed with adjustment */ tot_nz_words = divide (bc, 36, 34, 0); full_comp_size = size (bf_head) + cb.capacity * cb.block_size; full_comps = divide (tot_nz_words, full_comp_size, 17, 0); nz_words = tot_nz_words - full_comps * full_comp_size; /* words in last comp */ base_pos = cb.capacity * full_comps; /* rec_no at base of last comp */ nz_recs = divide (nz_words - size (bf_head) + cb_ptr -> cb.block_size - 1, cb_ptr -> cb.block_size, 17, 0); /* count of non-zero records */ tot_nz_recs = base_pos + nz_recs; /* total adjusted record count */ file_base_ptr -> bf_head.last_comp = full_comps; cb.last_comp_num = full_comps; if (tot_nz_recs > cb_ptr -> cb.end_pos) | /* eof is not properly set */ ((tot_nz_recs ^= cb.end_pos) & (file_base_ptr -> bf_head.version = current_bf_version)) then if get_seg_ptr (cb.last_comp_num) -> seg (size (bf_head) + cb_ptr -> cb.block_size * (nz_recs - 1)) ^= 0 /* last record is valid */ then do; cb_ptr -> cb.end_pos = tot_nz_recs; file_base_ptr -> bf_head.end_pos = tot_nz_recs; end; else do; /* last record is incomplete--delete it */ cb_ptr -> cb.next_pos = tot_nz_recs - 1; call truncate_file; /* removes dubious last record */ end; end; end adjust_file; adjust_op: proc; /* makes file consistent */ if (file_base_ptr -> bf_head.file_action = eof_delete) | (file_base_ptr -> bf_head.file_action = unshared_opening) | (file_base_ptr -> bf_head.file_action = append) then call adjust_file; else if file_base_ptr -> bf_head.file_action = write_trunc then if file_base_ptr -> bf_head.end_pos > file_base_ptr -> bf_head.change_pos + 1 /* rewrite phase */ then call print_warning; /* contents may be bad */ else go to finish_trunc; /* just do the truncation */ else if file_base_ptr -> bf_head.file_action = non_eof_delete then call re_zero; /* clean up garbage */ else if file_base_ptr -> bf_head.file_action = truncate then do; /* finish a truncation */ finish_trunc: call position_eof; call truncate_file; end; else call print_warning; /* non_eof_replacement */ cb.current_pos = old_current_pos; /* reset positions */ cb.next_pos = old_next_pos; file_base_ptr -> bf_head.file_action = 0; return; /* operation in progress has been adjusted */ print_warning: proc; /* signals fact that record may have bad contents */ call sub_err_ (0, "vfile_", "c", null, foo, "Record contents may be damaged for position: ^d", file_base_ptr -> bf_head.change_pos); end print_warning; re_zero: proc; /* handles interrupted deletions */ cb.current_pos = file_base_ptr -> bf_head.change_pos; call get_current_pos; seg_ptr = get_seg_ptr (comp_num); unspec (addr (seg_ptr -> seg (pos)) -> record_block) = "0"b; cb.current_pos = old_current_pos; end re_zero; end adjust_op; convert_file: proc; /* brings old file up to current version, or detects bad version */ if first_seg_ptr -> bf_head.version ^= bf_version_0 /* previous version file? */ then do; /* not previous version */ code = error_table_$unimplemented_version; /* unknown version--abort */ return; /* opening will fail */ end; if atb.inv_lock_reset /* old file was being updated */ then call adjust_file; /* not really necessary if operation was truncate */ call position_bof; do while (cb_ptr -> cb.current_pos < cb_ptr -> cb.end_pos); /* convert zero-length records */ call get_current_pos; seg_ptr = get_seg_ptr (comp_num); if seg_ptr -> seg (pos) = 0 /* old-style zero-length record */ then seg_ptr -> seg (pos) = -1; /* new representation for zero-length records */ cb_ptr -> cb.current_pos = cb_ptr -> cb.current_pos + 1; /* advance through file */ end; /* end of loop which converts records */ file_base_ptr -> bf_head.last_comp = cb.last_comp_num; first_seg_ptr -> bf_head.version = current_bf_version; /* completes conversion atomically */ end convert_file; dcl (vfile_io_control, vfile_status_$seg) entry (ptr, ptr, ptr, fixed (35)); dcl current_entry fixed; dcl full_comp_size fixed (19); dcl stacq builtin; dcl set_lock_$lock entry (bit (36) aligned, fixed, fixed (35)); dcl seg_ptr ptr; dcl sub_err_ entry options (variable); dcl action fixed; dcl clock builtin; dcl (iocb_ptr, fcb_ptr_arg, first_seg_ptr) ptr; dcl rel_pos fixed (19); dcl base_pos fixed (34); dcl tot_nz_words fixed (34); dcl full_comps fixed; dcl tot_nz_recs fixed; dcl comp_num fixed; dcl seg_ptr_array (0:cb_ptr -> cb.seg_ptr_array_limit) ptr based (cb.seg_ptr_array_ptr); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed (35)); dcl msf_manager_$adjust entry (ptr, /* fcb_ptr */ fixed bin, /* component number of segment to be made last segment */ fixed bin (24), /* bit count for that seg */ bit (3), /* "010" = dont set bit counts, truncate segment, dont terminate components */ fixed bin (35)); /* status code */ dcl msf_manager_$get_ptr entry (ptr, /* fcb_ptr */ fixed bin, /* component number of desired segment */ bit (1), /* create switch */ ptr, /* ptr to seg or null if error, output */ fixed bin (24), /* bitcount of segment, output */ fixed bin (35)); /* status code */ dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed (24), fixed (35)); dcl d_name char (168) aligned; dcl e_name char (32) aligned; dcl d_len fixed; dcl bc fixed (24); dcl hcs_$fs_get_path_name entry (ptr, char (*) aligned, fixed, char (*) aligned, fixed (35)); dcl hcs_$status_mins entry (ptr, fixed (2), fixed (24), fixed (35)); dcl hcs_$terminate_seg entry (ptr, fixed (1), fixed (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35)); dcl is_new_file bit (1) aligned; dcl mode fixed; /* may be 4,5,6, or 7 */ dcl close_x entry; dcl first_seg_bitcount fixed (24); /* of no interest in this module */ dcl max_comp_size fixed (19); dcl code fixed (35); dcl 1 bf_head aligned based, /* standard header for blocked files */ 2 common_header_words, 3 file_type_code fixed (35), 3 file_lock bit (36) aligned, 3 time_last_modified fixed (71), 2 version fixed, 2 change_pos fixed (34), /* record being modified when shared */ 2 reserved1 (1) fixed, 2 last_comp fixed, /* last msf component number */ 2 max_rec_len fixed (21), /* bytes */ 2 end_pos fixed, /* number of records */ 2 file_action fixed, /* non-zero value indicates truncation in progress */ 2 max_comp_size fixed (19), 2 reserved2 (4) fixed; %include iocbv; %include rs_info; %include vf_attach_block; dcl hcs_$set_bc_seg entry (ptr, fixed (24), fixed (35)); dcl (size, max, null, divide) builtin; dcl i fixed; dcl cb_ptr ptr; dcl bf_version_0 static internal fixed options (constant) init (0); dcl current_bf_version static internal fixed options (constant) init (1); dcl 1 cb based (cb_ptr) aligned, /* open data block--controls blocked files */ 2 file_base_ptr ptr, /* points to base of segment */ 2 seg_ptr_array_ptr ptr, 2 fcb_ptr ptr, 2 mode fixed, /* opening mode (=4,5,6, or 7) */ 2 appending bit (1) aligned, /* -append option */ 2 max_comp_size fixed (19), /* determines capacity of file */ 2 max_rec_len fixed (21), /* determines block size */ 2 block_size fixed (19), /* words, including header */ 2 capacity fixed (19), /* max number of records per comp */ 2 current_pos fixed (34), /* current record number */ 2 next_pos fixed (34), /* next record position (0,1,2,...) */ 2 end_pos fixed (34), /* number of records in file */ 2 last_comp_num fixed, 2 is_msf bit (1) aligned, 2 ssf_sw bit (1) aligned, 2 seg_ptr_array_limit fixed, 2 noend bit (1) aligned, /* if on, user pay position beyond eof */ 2 scan_backward bit (1) aligned, /* for masking logically absent records */ 2 old_version bit (1) aligned, /* set if file does not support logical deletion */ 2 shared bit (1) aligned, /* on if -share attachment */ 2 wait_time fixed, /* applies only if shared */ 2 saved_lock_copy bit (36) aligned, /* copy of my lock id */ 2 micro_wait_time fixed (71), /* wait_time in microseconds */ 2 old_time_stamp fixed (71), 2 handler_required bit (1) aligned, /* applies if sharing */ 2 current_status bit (2) aligned, 2 as_ins_del bit (2) aligned; dcl old_end_pos fixed (34); dcl old_current_status bit (2) aligned; dcl (pos_type, n_recs) fixed; dcl seg_fault_error condition; dcl time_limit fixed (71); dcl forever static internal fixed (54) aligned init (1.801e16); dcl (error_table_$negative_nelem, error_table_$asynch_insertion, error_table_$asynch_deletion, error_table_$lock_wait_time_exceeded, error_table_$invalid_lock_reset, error_table_$safety_sw_on, error_table_$file_busy, error_table_$unimplemented_version, error_table_$end_of_info, error_table_$no_record, error_table_$bad_arg, error_table_$no_operation, error_table_$long_record, error_table_$file_is_full) external fixed (35); dcl seg (0:cb.max_comp_size) fixed aligned based; dcl pos fixed (19); dcl 1 pos_struct based (addr (pos)), 2 pad_bits bit (18) unal, 2 pos_bits bit (18) unal; dcl buff_ptr ptr; dcl (buff_len, rec_len) fixed (21); dcl buffer char (buff_len) based (buff_ptr); dcl n fixed (21); dcl substr builtin; dcl order char (*); dcl info_ptr ptr; dcl was_scan_backward bit (1) aligned; dcl (old_next_pos, old_current_pos) fixed (34); dcl write_trunc static internal fixed options (constant) init (-9); dcl rewrite static internal fixed options (constant) init (-2); dcl eof_delete static internal fixed options (constant) init (-3); dcl non_eof_delete static internal fixed options (constant) init (-10); dcl unshared_opening static internal fixed options (constant) init (-11); dcl append static internal fixed options (constant) init (-1); dcl truncate static internal fixed options (constant) init (1); dcl 1 info1 based (info_ptr), /* for "read_position" order */ 2 next_pos fixed, /* output */ 2 end_pos fixed; /* output */ dcl continue_to_signal_ entry (fixed (35)); dcl initial_time_stamp fixed (71); dcl safety_sw bit (1); dcl hcs_$get_safety_sw_seg entry (ptr, bit (1), fixed (35)); dcl 1 info2 based (info_ptr), /* for "max_rec_len" order */ 2 old_max_recl fixed (21), /* output */ 2 new_max_recl fixed (21); /* input */ dcl foo fixed (35); dcl foo24 fixed (24); dcl nz_words fixed (19); dcl nz_recs fixed; dcl addr builtin; dcl 1 record_block based, 2 recl fixed (21), 2 rec_words (cb.block_size - 1) fixed; dcl seg_str char (1000000) aligned based; dcl alloc_cb_file entry (fixed, ptr); dcl free_cb_file entry (fixed, ptr); dcl hcs_$truncate_seg entry (ptr, fixed (18), fixed (35)); end open_blk_file;  open_indx_file.pl1 10/16/90 1526.9rew 10/16/90 1518.4 1820997 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-10-12,Zimmerman), approve(90-10-12,MCR8216), audit(90-10-15,Zwick), install(90-10-16,MR12.4-1043): Data_Mgt 63 (phx21194): Raise the max number of components in an MSF to 1250. END HISTORY COMMENTS */ /* The initial design and implementation of this program was by M. D. MacLaren (1974) */ /* All extensions, optimizations, and bug fixes since 1975 designed and implemented by M. Asherman */ /* The above was true up through 1978. Major modifications have been made by Jim Paradise prior to the first listed modification. Modified: 05/31/79 by Lindsey L. Spratt; fix "delete" bug by correcting a check seeing if the key associated with branch_num is the same as the key in automatic storage.( a tip of the hat to Chris D. Tavares for figuring out this fix) Also, added code to check for improperly converted files, since check_file_version was not doing the comp_table reformatting it should have been doing. Modified by Jim Paradise on January 16, 1980 to correctly handle modifiers of stationary records; problems due to interaction of tp code and redefinition meaning of stationary header variable: modifier 04/29/80 by Jim Paradise to add fix to select/exclude logic to not try to free at times there is not anything to free in returned descrip list, Found and fix provided by Jim Gray. Modified by Jim Paradise on June 27, 1980 to fix a performance bug, when inserting duplicate keys search for them on the right. Based on the fix provided by Ed Brunnell. 12/18/80 by Lindsey L. Spratt: add the ability to delete old subsets from the "subset" vfile built for holding the results of selection and exclusion. This also involved adding a new bit to the common_sl_info structure, common_sl_info.delete_old_subsets. 06/29/81 by Lindsey Spratt: Changed to use the iocb.incl.pl1 include file instead of the (now obsolete) iocbv.incl.pl1 include file. This required explicitly qualifying with a locator value (iocb_ptr) all references to elements of the iocb structure. Also, moved (nearly) all include files to the end of the source. 01/20/82 by Lindsey Spratt: Changed rewrite_indx_file entry point to only reference the "current" node when indx_cb.outside_index is off. This was causing a null pointer fault when no valid position had established (e.g., the only kind of positioning done since the opening of the file was via the record_status control order.) 01/21/82 by Lindsey Spratt: Changed the declaration of the error_info structure from fixed to fixed bin (35). There was a size mis-match between indx_cb.requested (fixed bin(34)) and error_info.requested (fixed bin(17)). 03/31/82 by Lindsey Spratt: Changed close_indx_file to re-initialize the file_state pointers (fs_ptr, o_s_ptr, os_ptr, and indx_cb.file_state_ptr) when entered. (vfile bug 23.) 04/05/82 by Lindsey Spratt: Changed the select control order to not allocate a descriptor array when the caller's selection gets an error_table_$no_record (i.e., when flag = select_flag, and indx_cb.subset_selected = "00"b, indicating that no selection has taken place). This is checked in get_subset_status. */ /* format: style2,ind3 */ open_indx_file: proc (iocb_ptr, fcb_ptr_arg, first_seg_ptr, is_new_file, mode_arg, close_x, first_seg_bitcount, component_size_arg, code); go to open_file; init_down_up: /* prologue for ops which must first lock file */ indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; passive = "0"b; go to init_body; init_up_down: /* prologue for semi-passive operations */ indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; passive = indx_cb.stat; /* lock file first if non-stationary */ go to init_body; initialize: /* prologue for all passive index operations */ indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; passive = "1"b; /* will never lock on this operation */ init_body: code = 0; cleanup_flags = "000000"b; /* nothing locked */ if ^indx_cb.shared /* unshared opening */ then do; saved_state.shared = "0"b; timeout = 0; go to retry_loc (current_retry_loc); /* back to mainline with handler established */ end; saved_state_block = current_state_block; /* for cleanup */ /* continue initialization for a shared operation */ pos_ptr = file_position_ptr; f_b_ptr = file_base_ptr; fs_ptr = indx_cb.file_state_ptr; if indx_cb.wait_time < 0 /* will wait indefinitely */ then timeout = eternity; /* may wait forever */ else timeout = clock () + indx_cb.wait_time; /* microseconds */ on cleanup call restore_abort; if current_retry_loc = rs_retry_2 then go to retry_loc (rs_retry_2); if leave_locked /* file left locked by me */ then go to retry_loc (current_retry_loc); if ^passive then do; /* insist on first locking the file */ call lock_file_check; go to retry_loc (current_retry_loc); end; fault_ok = "0"b; /* set when possible asynch file change errors should be handled */ on any_other begin; /* asynch change handler */ if fault_ok /* fault may be due to asynch change to the file */ then do; /* see if this is the case */ fault_ok = "0"b; /* suppress recursive any_other handling */ call find_condition_info_ (null, addr (cond_info), er_code); /* gets condition name */ if asynch_change_condition (cond_name) /* OK to handle */ then if iocb_ptr -> iocb.open_data_ptr -> indx_cb.file_base_ptr -> file_base.change_count ^= iocb_ptr -> iocb.open_data_ptr -> indx_cb.last_change_count /* file has changed--note indx_cb_ptr may not be valid now */ then go to try_again; /* reattempt operation or abort */ fault_ok = "1"b; /* pass on this fault, but resume handling others */ end; call continue_to_signal_ (er_code); /* quit or file not changed--must be an error */ asynch_change_condition: proc (cond_name) returns (bit (1) aligned); /* returns "1"b if condition may have arisen from asynch file change */ if length (cond_name) > length ("simfault_") then if substr (cond_name, 1, length ("simfault_")) = "simfault_" then return ("1"b); if cond_name = "sub_err_" then if sub_err_info.name = "vfile_" then return ("1"b); /* OK to handle vfile_'s own sub_err_ only */ else return ("0"b); do i = 1 to num_conds; /* check each possible condition known */ if cond_name = as_cond_names (i) /* match */ then return ("1"b); end; /* try each name in loop */ return ("0"b); /* not a condition which should be handled */ dcl 1 sub_err_info based (cond_info.infop), 2 pad (70), 2 name char (32); dcl cond_name char (32) var; dcl i fixed; dcl num_conds static internal fixed options (constant) init (21); dcl as_cond_names (1:21) static options (constant) char (32) var internal init ("fault_tag_1", "fault_tag_3", "fixedoverflow", "illegal_modifier", "linkage_error", "lockup", "no_execute_permission", "no_read_permission", "no_write_permission", "not_in_read_bracket", "not_in_write_bracket", "out_of_bounds", "overflow", "seg_fault_error", "size", "storage", "stringrange", "stringsize", "subscriptrange", "truncation", "underflow"); end asynch_change_condition; dcl find_condition_info_ entry (ptr, ptr, fixed (35)); dcl 1 cond_info aligned, 2 words1 (3) fixed, 2 cond_name char (32) var, /* all that interests us */ 2 infop ptr, 2 words2 (12) fixed init ((12) 0); dcl er_code fixed (35); end; /* end of any_other handler */ call prepare_process; go to retry_loc (current_retry_loc); /* end of initialization pseudo-proc */ try_again: /* reattempt a passive operation if time enough */ indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; call restore_state; call prepare_process; /* may wait on file lock */ go to retry_loc (current_retry_loc); /* back to mainline */ verify_done: if indx_cb.shared then if cleanup_flags ^= "000000"b /* not passive */ then go to unlock_exit; /* don't leave things locked */ else do; call save_correct_pos; if ^indx_cb.leave_locked then do; /* verify a passive operation */ if indx_cb.last_change_count = file_base.change_count /* file unchanged during operation */ then return; /* result is therefore verified--done */ call restore_state; /* resets process vars to their former values */ if clock () > timeout /* time limit exhausted */ then do; /* abort */ code = error_table_$file_busy; return; end; call prepare_process; go to retry_loc (current_retry_loc); end; end; return; /* external exit */ passive_abort: indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; if saved_state.shared /* state has been saved */ then call restore_state; return; /* seek_key routine for openings with mode keyed_sequential_output */ seek_key_ks_out: entry (iocb_ptr, key, rec_len, code); current_retry_loc = seek_kso_retry; go to initialize; retry_loc (1): if indx_cb.pos_incorrect then do; /* position correctly to end of file */ call position_eof; indx_cb.pos_incorrect = "0"b; end; else do; pos_ptr = file_position_ptr; indx_cb.outside_index = "0"b; /* current pos moves into index */ branch_num = last_branch_num; call set_at_eof; /* sets indx_cb vars */ end; indx_cb.new_key = key; /* save key for insertion */ call compare_last_key (indx_cb.new_key); /* sets code and key_is_dup */ if code = 0 /* indx_cb.new_key larger than last key in file */ then do; code = error_table_$no_record; indx_cb.ready_to_write = "1"b; end; else indx_cb.ready_to_write = (key_is_dup & dup_ok); /* write will succeed if key exists and duplications are allowed */ go to verify_done; /* end seek_key for keyed sequential output */ seek_key_indx_file: entry (iocb_ptr, key, rec_len, code); current_retry_loc = seek_retry; go to initialize; retry_loc (2): indx_cb.at_bof, indx_cb.at_eof = "0"b; file_position_ptr = root_position_ptr; indx_cb.outside_index = "0"b; indx_cb.skip_state = 0; /* revert to forward scanning over deletions */ call find_key (indx_cb_ptr, (addr (key)), search_code); /* 2nd arg is destroyed */ pos_ptr = file_position_ptr; indx_cb.pos_incorrect = "0"b; /* Now set file position and code */ if search_code = 0 /* means not found */ then code = error_table_$no_record; else do; /* try to get ptr and len */ call find_from_leaf; /* in case match was in upper node */ indx_cb.current_descrip = record_designator (branch_num); call set_next_reclp_seek (block_ptr, lock_ptr); /* sets ptr and length */ /* limits scanning to entries for this key */ /* also sets the code to indicate failure */ end; /* either len is known or error code set */ if (code = 0) | (code ^= error_table_$no_record) then do; /* set position indicators and recl arg */ rec_len = record_len; indx_cb.current_record_is_valid = "1"b; indx_cb.next_record_position = 1; indx_cb.ready_to_write = dup_ok; end; else do; /* set indicators for unsuccessful seek */ rec_len = 0; indx_cb.current_record_is_valid = "0"b; indx_cb.next_record_position = 0; if ^is_read_only then do; indx_cb.ready_to_write = "1"b; indx_cb.new_key = key; end; end; go to verify_done; /* end of seek_key routine */ dcl search_code fixed (35); read_length_indx_file: entry (iocb_ptr, rec_len, code); current_retry_loc = read_len_retry; go to initialize; retry_loc (3): call find_next_record; if code = 0 /* next record exists */ then do; /* get its length */ call set_next_reclp (block_ptr, lock_ptr); rec_len = record_len; end; go to verify_done; /* end of read_length routine */ read_key_indx_file: entry (iocb_ptr, key, rec_len, code); current_retry_loc = read_key_retry; go to initialize; retry_loc (4): call find_next_record; if code = 0 /* next position exists */ then do; call set_next_reclp (block_ptr, lock_ptr); rec_len = record_len; len = get_key_length (); if len > 0 then key = substr (keys, key_pos (branch_num), len); else key = ""; end; go to verify_done; /* end of read_key routine */ read_indx_file: entry (iocb_ptr, buff_ptr, buff_len, rec_len, code); current_retry_loc = read_retry; go to initialize; retry_loc (5): call find_next_record; if code = 0 /* next position exists */ then do; call set_next_reclp_and_contents (block_ptr, lock_ptr); rec_len = record_len; if is_sequential_open & ((code = 0) | ((code ^= error_table_$end_of_info) & (code ^= error_table_$no_record))) then indx_cb.next_record_position = 2; /* next record follows that just read */ else indx_cb.next_record_position = 0; end; go to verify_done; /* end of read routine */ position_indx_file: entry (iocb_ptr, pos_type, skip, code); if pos_type = 0 then do; current_retry_loc = skip_retry; saved_error_info = iocb_ptr -> iocb.open_data_ptr -> indx_cb.error; go to initialize; retry_loc (6): if indx_cb.next_record_position = 0 /* position may be undefined */ then do; call find_next_record; /* sets position indicators */ if code ^= 0 /* really is an error */ then return; end; indx_cb.outside_index = "0"b; /* current pos moves back into index */ if pos_incorrect then do; call restore_position; if code ^= 0 then go to verify_done; end; else pos_ptr = file_position_ptr; indx_cb.at_bof, indx_cb.at_eof = "0"b; indx_cb.skip_state = 0; if skip >= 0 /* forward skip */ then do; count = skip + indx_cb.next_record_position - 1; indx_cb.current_record_is_valid, indx_cb.ready_to_write = "0"b; do while (count > 0); /* advance until count zero or eof reached */ branches_left = last_branch_num - branch_num; /* branches in current node */ if branches_left > 0 then if (indx_cb.subset_selected = "00"b) & (branch (branch_num) = 0) /* leaf node */ then do; /* skip over a chunk of branches in one node */ chunk_size = min (count, branches_left); /* as many as possible */ branch_num = branch_num + chunk_size; /* will be last if more to skip */ count = count - chunk_size; /* remainder to be skipped */ end; else do; /* skip one from upper to leaf */ if indx_cb.subset_selected ^= "00"b then do; /* see if this entry is being masked */ call check_subset (record_designator (branch_num)); if ^rec_deleted /* this one counts */ then count = count - 1; end; else count = count - 1; /* none are being masked */ branch_num = branch_num + 1;/* next non-leaf branch */ call find_leftmost_descendent; end; else do; /* move to entry from last branch in a node */ call find_this_entry; if pos_ptr = root_position_ptr /* at end of file */ then do; count = -count; /* causes exit from loop */ code = error_table_$end_of_info; end; end; end; if code ^= 0 /* attempted to pass eof */ then do; call position_eof; /* set position properly */ indx_cb.error.type = skip_error; /* error -- attempt to pass end of file on position skip */ indx_cb.error.requested = skip; /* number of skips specified in call */ indx_cb.error.received = skip + count; /* number of records actually skipped */ end; else indx_cb.next_record_position = 1; end; /* end of forward skip case */ else do; /* backward skip */ count = 1 - skip - indx_cb.next_record_position; do while (count > 0); if count = 1 then do; /* backspace by a single branch */ back_1: call find_prev_entry; /* handles exceptions */ if branch_num = 1 /* beginning of file */ then do; code = error_table_$end_of_info; count = -count; /* causes exit from loop */ end; else do; branch_num = branch_num - 1; if indx_cb.subset_selected ^= "00"b then do; call check_subset (record_designator (branch_num)); if ^rec_deleted then count = count - 1; end; else count = count - 1; end; end; else if branch_num > 1 /* not at first branch in node */ then if (indx_cb.subset_selected = "00"b) & (branch (branch_num) = 0) then do; /* skip over a bunch of leaf branches */ chunk_size = min (count, branch_num - 1); count = count - chunk_size; branch_num = branch_num - chunk_size; /* does the backspacing */ end; else go to back_1; else go to back_1; end; if code ^= 0 then do; /* set position properly and save error info */ call position_bof; indx_cb.error.type = skip_error; indx_cb.error.requested = skip; indx_cb.error.received = skip - count; /* actual number successfully skipped */ end; else do; indx_cb.next_record_position = 1; indx_cb.current_record_is_valid = "1"b; indx_cb.ready_to_write = dup_ok; indx_cb.skip_state = -1; /* causes reverse scanning over deleted records */ end; end; /* end of backward skip case */ end; /* end of position skip case */ else if abs (pos_type) = 1 /* valid type */ then do; current_retry_loc = pos_bof_or_eof_retry; go to initialize; retry_loc (7): if pos_type = 1 then call position_eof; else call position_bof; indx_cb.outside_index = "0"b; pos_incorrect = "0"b; end; else do; code = error_table_$bad_arg; return; end; go to verify_done; /* end of position routine */ control_indx_file: entry (iocb_ptr, order, info_ptr_arg, code); info_ptr = info_ptr_arg; code = 0; if order = "get_key" then do; current_retry_loc = gk_retry; go to initialize; retry_loc (8): /* first validate arguments in info structure */ if ^gk_inf.input_key & (gk_inf.current = "1"b) & (gk_inf.input_desc) then do; code = error_table_$bad_arg; go to exit; /* abort */ end; if (gk_inf.current & ^gk_inf.input_key) | (^gk_inf.input_desc & (gk_inf.desc_code = 1)) /* current position required */ then do; call check_current; if code ^= 0 then go to verify_done; /* abort--no current position */ if ^gk_inf.input_key & gk_inf.current /* current key required */ then if indx_cb.outside_index /* no current key is defined */ then do; code = error_table_$no_key; gk_inf.descrip = indx_cb.current_descrip; gk_inf.key_len = 0; go to verify_done; /* abort this operation */ end; if gk_inf.reset_pos & (^indx_cb.shared | ^saved_state.current_record_is_valid) then do; saved_state.skip_state = indx_cb.skip_state; call save_correct_pos; end; end; else if gk_inf.reset_pos & ^indx_cb.shared then do; saved_state.skip_state = indx_cb.skip_state; call save_correct_pos; end; if ^gk_inf.input_key /* current or next position */ then if gk_inf.current /* current position */ then if indx_cb.subset_selected ^= "00"b /* must see if this record is being masked */ then do; call check_subset (indx_cb.current_descrip); if rec_deleted then code = error_table_$no_record; end; else ; /* just set gk_info and return now */ else do; /* find next entry, possibly scanning over unwanted descriptors */ if pos_incorrect then do; call restore_position; if code ^= 0 then go to verify_done; end; else pos_ptr = indx_cb.file_position_ptr; if indx_cb.next_record_position = 1 then if branch_num < last_branch_num then go to next_found; else ; /* will have to handle special case */ else if indx_cb.next_record_position = 2 then branch_num = branch_num + 1; else do; code = error_table_$no_record; go to next_found; /* abort */ end; call find_this_entry; if pos_ptr = root_position_ptr /* eof */ then do; code = error_table_$end_of_info; if ^gk_inf.reset_pos then call position_eof; end; next_found: if code = 0 then do; pad_key_ptr = addr (indx_cb.new_key); /* in case previous seek_head applies */ call gk_scan; /* find valid entry by scanning if necessary */ end; end; else do; /* seek to proper location in index */ pad_key_ptr = addr (gk_pad_key); pad_key_len = 256; /* must pad with 0's for proper seek */ len = min (fixed (gk_inf.head_size), gk_inf.key_len); unspec (substr (pad_key, len + 1, 256 - len)) = "0"b; /* pad with 0's */ substr (pad_key, 1, len) = substr (gk_inf.key, 1, len); indx_cb.pos_incorrect = "0"b; call seek_head ((gk_inf.rel_type), addr (pad_key_info), (fixed (gk_inf.head_size))); if pos_ptr = root_position_ptr /* no luck */ then do; if ^gk_inf.reset_pos then indx_cb.at_bof, indx_cb.at_eof = "0"b; code = error_table_$no_key; end; else do; if gk_inf.rel_type = 0 then indx_cb.skip_state = fixed (gk_inf.head_size); /* indicates scanning after head match */ else indx_cb.skip_state = 0; /* just scan forward */ call gk_scan; /* finds satisfactory descriptor */ if ^indx_cb.shared & ^gk_inf.reset_pos then call save_correct_pos; /* in case of scan */ end; end; if code = 0 then do; gk_inf.key_len = get_key_length (); gk_inf.key = substr (keys, key_pos (branch_num), key_length (branch_num)); gk_inf.descrip = record_designator (branch_num); if ^gk_inf.reset_pos /* leave position here */ then do; indx_cb.ready_to_write = indx_cb.dup_ok; indx_cb.outside_index, indx_cb.at_eof, indx_cb.at_bof = "0"b; indx_cb.current_record_is_valid = "1"b; indx_cb.next_record_position = 1; end; else do; indx_cb.skip_state = saved_state.skip_state; indx_cb.pos_incorrect = "1"b; end; end; else if ^gk_inf.reset_pos /* leave next position undefined */ then do; indx_cb.ready_to_write, indx_cb.current_record_is_valid, indx_cb.outside_index = "0"b; if ^(indx_cb.at_bof | indx_cb.at_eof) then indx_cb.next_record_position = 0; end; else do; indx_cb.skip_state = saved_state.skip_state; indx_cb.pos_incorrect = "1"b; end; go to verify_done; end; indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; code = 0; if order = "record_status" then do; call check_rs_args; /* aborts on error */ if code ^= 0 /* fatal error detected by arg checking */ then return; /* abort--don't bother looking at file */ current_retry_loc = rs_retry_1; if indx_cb.shared then if ^passive_op & (^indx_cb.stat | rs_info.create_sw) /* first must lock file */ then go to init_down_up; else if ^(indx_cb.outside_index | rs_info.locate_sw) then go to initialize; else do; /* get file's change count, but synch at record level */ current_retry_loc = rs_retry_2; go to initialize; retry_loc (9): new_change_count = file_base.change_count; if new_change_count ^= indx_cb.last_change_count /* asynch change */ then do; /* bring process vars up to date */ call initialize_ptrs; indx_cb.pos_incorrect = "1"b; indx_cb.last_change_count = new_change_count; end; /* open data consistent with last change count now */ end; /* file level verification will occur if non-stationary */ else go to init_up_down; retry_loc (10): call record_status; /* may create rec or alter lock, as well as returning info and setting current current record pos outside index */ if rs_info.unlock_sw & ^rs_info.lock_sw /* explicit unlocking without locking */ then if code = 0 then code = error_table_$lock_not_locked; /* complain if not already locked by me */ else if code = error_table_$locked_by_this_process /* expected */ then do; i_locked_rec = "1"b; /* cause unlocking to be done */ code = 0; end; if ^passive_op /* file modification */ then go to unlock_exit; /* unlock after shared file alteration */ else if rs_info.unlock_sw then go to unlock_exit; /* unlock the record only */ else if ^indx_cb.outside_index /* file level synchronization */ then go to verify_done; /* will re-attempt operation if asynch changes detected */ else if block_ptr ^= null then if ^block_ptr -> record_block.stationary /* non-stationary */ then go to verify_done; /* may have to retry to get snapshot */ return; /* may have already made external exit */ end; /* record_status proc does external exit */ if order = "seek_head" then if is_sequential_open & ^is_ks_out & (mode > 7 /* keyed */) then do; /* won't be no_operation */ if (info.rel_type < 0) | (info.rel_type > 2) | (n < 0) then do; /* bag arg--abort */ code = error_table_$bad_arg; return; end; else do; current_retry_loc = sh_retry; go to initialize; retry_loc (11): indx_cb.at_bof, indx_cb.at_eof = "0"b; indx_cb.outside_index = "0"b; pad_key_ptr = addr (indx_cb.new_key); pad_key_len = 256; unspec (substr (pad_key, n + 1, 256 - n)) = "0"b; /* pad with zeroes, not blanks */ substr (pad_key, 1, n) = search_key; call seek_head (info.rel_type, addr (pad_key_info), info.n); if pos_ptr = indx_cb.root_position_ptr /* not found */ then code = error_table_$no_record; if code = 0 then do; if indx_cb.dup_ok then indx_cb.ready_to_write = "1"b; else indx_cb.ready_to_write = "0"b; indx_cb.current_record_is_valid = "1"b; indx_cb.next_record_position = 1; if info.rel_type = 0 /* exact match was required */ then indx_cb.skip_state = n; /* will only scan while head condition is met */ else indx_cb.skip_state = 0; /* any subsequent entry will do on detection of deletion */ if indx_cb.subset_selected ^= "00"b /* select or exclude in effect */ then call sh_scan; /* scan for entry in the current subset */ end; else do; indx_cb.ready_to_write = "0"b; indx_cb.current_record_is_valid = "0"b; indx_cb.next_record_position = 0; end; pos_incorrect = "0"b; go to verify_done; /* will save key if shared */ end; end; if ^is_read_only /* must have modify access */ then do; if (order = "add_key") then go to add_key; else if (order = "delete_key") then go to delete_key; /* does the work */ else if (order = "reassign_key") then go to reassign_key; end; if order = "select" then go to select; if order = "exclude" then go to exclude; if order = "error_status" then do; if error_info.version ^= 1 then code = error_table_$bad_arg; else do; error_info.type = indx_cb.error.type; error_info.requested = indx_cb.error.requested; error_info.received = indx_cb.error.received; end; return; end; if order = "min_block_size" then do; indx_cb.min_res = max (0, mbs_info.min_residue); indx_cb.min_cap = max (0, mbs_info.min_capacity); return; end; if indx_cb.shared then do; if (order = "set_wait_time") then do; /* change setting of max wait time */ if new_wait_time = -2 /* collection delay version */ then if wt_info.collection_delay_time < 0 then code = error_table_$bad_arg; else indx_cb.collection_delay_time = 1000000 * wt_info.collection_delay_time; else if new_wait_time < -1 then code = error_table_$bad_arg; else indx_cb.wait_time = 1000000 * new_wait_time; return; /* that's all there is to it */ end; if (order = "set_file_lock") & ^indx_cb.is_read_only then do; /* attempt to lock or unlock the file */ if info_ptr -> set_lock_flag /* wants to set the lock */ then if indx_cb.leave_locked then code = error_table_$locked_by_this_process; else do; /* lock and restore process vars */ current_retry_loc = lock_file_retry; go to init_down_up; /* setup handler */ retry_loc (24): if set_lock_info.exclusive then file_action = read_exclude; /* stops readers */ indx_cb.read_exclu = info_ptr -> exclusive; indx_cb.leave_locked = "1"b; /* remember locked */ end; else if ^indx_cb.leave_locked then do; code = error_table_$lock_not_locked; if indx_cb.file_base_ptr -> file_base.lock_word = indx_cb.saved_lock_copy /* my lock */ then call check_code (code, "File lock set by another opening in this process. This opening can't clear the lock. Either unlock from the opening that locked, of force unlocking with the vfile_adjust command."); end; else do; /* OK to unlock */ saved_state_block = current_state_block; cleanup_flags = "100000"b; /* OK to unlock file */ on cleanup call restore_abort; leave_locked = "0"b; /* remember I unlocked */ f_b_ptr = file_base_ptr; pos_ptr = file_position_ptr; fs_ptr = indx_cb.file_state_ptr; if file_action = read_exclude then file_action = 0; /* clear read lock */ indx_cb.read_exclu = "0"b; go to unlock_exit; /* sets last_change_count */ end; return; /* finished with operation */ end; end; if order = "file_status" then do; call vfile_status_$seg (iocb_ptr, file_base_ptr, info_ptr, code); return; end; if order = "io_call" then do; call vfile_io_control (iocb_ptr, file_base_ptr, info_ptr, code); return; /* work done on recursive call */ end; if order = "io_call_af" then do; call vfile_io_control$af (iocb_ptr, file_base_ptr, info_ptr, code); return; /* return from call for active function */ end; code = error_table_$no_operation; return; /* end of control routine */ get_ptr: proc (designator_arg) returns (ptr); return (addr (seg_ptr_array (des_arg.comp_num) -> seg_array (fixed (des_arg.offset)))); dcl designator_arg fixed (35); dcl 1 des_arg like designator_struct aligned based (addr (designator_arg)); end; lock_current_record: proc (block_ptr, lock_ptr, i_locked_mask, ref_count_change); /* non-passive, non-scanning */ /* delete_record suppresses cleanup by setting input_only flag */ if indx_cb.repeating /* recovery in progress */ then do; /* reconstruct pointers */ f_b_ptr = indx_cb.file_base_ptr; fs_ptr = indx_cb.file_state_ptr; block_ptr = get_pointer (indx_cb.current_descrip); lock_ptr = null; cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask); if file_base.was_stat /* record may have been stationary type */ then do; /* get correct lock_ptr */ if (file_action = reassigning_key) /* maybe non-stat */ then if ^block_ptr -> record_block.stationary then return; /* suppress unlocking */ lock_ptr = addr (block_ptr -> stat_struct.record_lock); end; return; end; passive = "0"b; scan = "0"b; /* treats logical deletion as error without scanning */ go to get_reclp; /* main body of record access synch routine */ set_next_reclp_and_contents: /* for read_record op */ set_next_reclp_seek: /* passive with restricted scanning, i.e. scanning of duplicate keys matching seek arg */ set_next_reclp: entry (block_ptr, lock_ptr); /* passive with scanning */ passive = "1"b; /* never modify via this entry */ scan = "1"b; /* means scan over absent entries, if found */ go to get_reclp; set_current_reclp: entry (block_ptr, lock_ptr); /* passive, non-scanning */ passive = "1"b; scan = "0"b; /* will not scan if record is logically absent */ get_reclp: code = 0; block_ptr = null; /* loop condition */ lock_ptr = null; record_ptr = null; record_len = 0; max_rec_wds = 0; /* allocated block size minus header size */ ref_cnt = 0; /* reference count--stationary records only */ do while (block_ptr = null); /* may loop over logically absent records */ if indx_cb.subset_selected ^= "00"b /* may be masked */ then call check_subset (indx_cb.current_descrip); /* sets rec_deleted flag */ /* will know whether or not to clean up by nullness of block_ptr */ else rec_deleted = "0"b; /* entry not masked so far */ if ^rec_deleted /* OK to look for allocation */ then do; /* look at the record block allocation */ if indx_cb.current_descrip <= 0 /* no allocation possible for this descriptor */ then do; /* check for error and return */ if ^passive /* only attempt to lock may regard as an error */ then if indx_cb.trans then code = error_table_$no_room_for_lock; /* must support null descriptor special case */ return; /* nothing more to do in this routine */ end; /* will exit loop with non-null block_ptr */ if indx_cb.shared & ^indx_cb.leave_locked & ^i_locked_file & ^indx_cb.outside_index /* possible asynch file change errors */ then if indx_cb.last_change_count ^= file_base.change_count /* asynch change has occurred--descriptor may not be valid--reobtain */ then go to verify_done; /* will abort if no time left */ block_ptr = get_pointer (indx_cb.current_descrip); /* ptr to block header */ if block_ptr = null /* should never happer */ then call check_code (error_table_$no_record, "Can't obtain record pointer--reason unknown."); if ^block_ptr -> record_block.stationary /* non-stationary record */ then call inspect_non_stat_rec; /* gets lock ptr if room */ else call inspect_stat_record; /* sees if logically deleted */ end; /* rec_deleted flag set if logically absent */ if rec_deleted /* user can't see this entry */ then do; /* see if OK to scan and/or garbage-collect */ call mask_entry; /* OK to scan if returned code = 0 */ /* no refl entry required, since deletion is irreversible */ /* until index changes supported under TP, however, there is still the reversible deletion of pre-created records to be considered */ if code ^= 0 /* can't scan--just return with error */ then return; /* abort */ /* otherwise block_ptr will necessarily be null */ end; /* fall through case scans next entry */ end; /* scan over logically masked or deleted entries */ return; /* end of main get_reclp routine */ mask_entry: proc; /* takes care of scanning and cleanup */ /* returns either with a non-zero code or null block_ptr */ if ^scan /* don't scan--return no_record error */ then do; /* still may clean up one entry, though */ if ^indx_cb.is_read_only & indx_cb.stat & (block_ptr ^= null) /* OK to collect */ then do; if indx_cb.outside_index then if (ref_cnt > 0) | passive /* nothing can be collected now */ then do; /* return immediately */ code = error_table_$no_record; return; end; else threshold = 0; /* garbage collection threshold */ else threshold = 1; /* can delete one key along with the record */ call collect_item; /* may delete key and/or record */ end; code = error_table_$no_record; /* warn user record is absent */ return; /* done with non-scanning case */ end; if block_ptr ^= null /* may have to clean up */ then do; /* end up with null block_ptr */ if ^indx_cb.is_read_only & indx_cb.stat /* may collect item */ then do; threshold = 1; /* only delete key for larger ref counts */ call collect_item; indx_cb.outside_index = "0"b; /* in case only the key was deleted */ end; else if indx_cb.skip_state >= 0 then indx_cb.next_record_position = 2; block_ptr = null; /* allow scanning to continue if final code is zero */ lock_ptr = null; end; else if indx_cb.skip_state >= 0 then indx_cb.next_record_position = 2; /* advance */ if (indx_cb.skip_state < 0) /* scan backwards */ then if indx_cb.next_record_position = 2 /* staggerred next and current */ then do; /* reset next to current--must exist */ indx_cb.next_record_position = 1; indx_cb.current_descrip = record_designator (branch_num); code = 0; /* clear any old code */ return; /* backward scan continues successfully */ end; else call backspace; /* also sets code */ else call find_next_record; /* scan forward--also sets code */ if code = 0 /* did not run into either end of file */ then do; /* see if code must be set */ if current_retry_loc = seek_retry then if key = substr (keys, key_pos (branch_num), get_key_length ()) then return; /* OK to check this entry--key matches */ else ; /* fall through complains about no_record error */ else if indx_cb.skip_state > 0 /* follows seek_head */ then if substr (indx_cb.new_key, 1, indx_cb.skip_state) = substr (keys, key_pos (branch_num), min (get_key_length (), indx_cb.skip_state)) /* head still matches that of prior seek_head */ then return; /* OK to continue search for record with this descrip */ else ; /* fall through and complain */ else return; /* previous entry obtained without eof error */ code = error_table_$no_record; /* complain */ end; /* fall through resets skip state */ else if (current_retry_loc = seek_retry) /* called by seek_key */ & (code = error_table_$end_of_info) then code = error_table_$no_record; /* suitable code */ /* unable to continue scanning, although permitted */ indx_cb.skip_state = 0; /* resume normal scanning forward */ return; /* done masking one entry */ collect_item: proc; /* garbage collection routine */ if indx_cb.trans then if (mod > 0) & (mod = current_t_code) /* locked by this transaction */ then go to handle_pos; /* don't garbage collect yet */ if cur_mod = -3 /* special case--means creation in progress */ then do; call get_lock_status (lock_ptr, er_code); if er_code ^= error_table_$lock_is_invalid then go to handle_pos; /* maybe skip over this entry */ end; if ref_cnt <= threshold /* record can be removed */ /* ref count obtained in set_current_image_info logic */ then if indx_cb.shared then if time_stamp + indx_cb.collection_delay_time > clock () then go to handle_pos; /* just skip over entry if scanning */ if indx_cb.shared then indx_cb.shared = ^indx_cb.leave_locked & ^i_locked_file; else saved_state.skip_state = indx_cb.skip_state; indx_cb.is_sequential_open = "1"b; if ref_cnt <= threshold /* OK to dispose of stationary header */ then call delete_indx_file (iocb_ptr, er_code); else call control_indx_file (iocb_ptr, "delete_key", null, er_code); if indx_cb.mode < 11 then indx_cb.is_sequential_open = "1"b; else indx_cb.is_sequential_open = "0"b; indx_cb.skip_state = saved_state.skip_state; indx_cb.shared = saved_state.shared; pos_ptr = indx_cb.file_position_ptr; /* because of intervening external vfile_ calls */ return; /* item collected */ handle_pos: if scan & (indx_cb.skip_state >= 0) then indx_cb.next_record_position = 2; /* skip over entry */ dcl er_code fixed (35); end collect_item; dcl threshold fixed (34); end mask_entry; inspect_non_stat_rec: proc; /* examines a non-stationary record */ blksz = block_ptr -> record_block.block_size; max_rec_wds = blksz - 2; if (blksz > divide (length (block_ptr -> record_block.record) + 11, 4, 19, 0)) then lock_ptr = addr (block_ptr -> non_stat_struct.record_lock); /* room for lock at tail of block */ else lock_ptr = null; /* no room for separate record lock */ if indx_cb.trans /* transaction mode--error--record must be stationary */ then code = error_table_$no_room_for_lock; /* rec header too small */ else if lock_ptr = null /* can't touch lock */ then if passive then if block_ptr -> record_block.lock_flag then call get_lock_status (addr (file_base_ptr -> file_base.lock_word), code); else code = 0; else code = 0; /* no lock to set--treat as successful */ else if ^passive /* wants to lock--file must first be locked */ then if indx_cb.shared & ^indx_cb.leave_locked & ^i_locked_file /* I haven't locked */ then do; /* file must first be locked to lock non-stat record */ call lock_file_check; /* may adjust the file */ /* aborts if file busy or unrecoverable */ go to retry_loc (current_retry_loc); /* try again with file locked */ end; /* never lock non-stationary record without first locking file */ else do; /* try to lock the record */ call compute_time_left; if ^(lock_ptr -> based_lock = indx_cb.saved_lock_copy) then cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask); call set_lock (lock_ptr, time_left, code); /* really shouldn't wait with file locked in all cases */ if code ^= 0 /* lock was set */ then if (code = error_table_$locked_by_this_process) | (code = error_table_$invalid_lock_reset) /* not fatal */ then if ^block_ptr -> record_block.lock_flag /* record is valid */ then do; code = 0; cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask); end; else ; /* locking was complete */ else if code = error_table_$lock_wait_time_exceeded then code = error_table_$record_busy; /* appropriate code */ end; /* done with locking attempt */ else if block_ptr -> record_block.lock_flag /* may be busy */ then call get_lock_status (lock_ptr, code); /* sets code without locking */ else code = 0; /* contents must be valid */ record_ptr = addr (block_ptr -> record_block.record); record_len = length (record_ptr -> based_vstring); if current_retry_loc = read_retry /* contents also wanted */ then call return_contents; dcl blksz fixed (19); end inspect_non_stat_rec; inspect_stat_record: proc; /* looks at a stationary record */ lock_ptr = addr (block_ptr -> stat_struct.record_lock); if passive /* just obtaining status--not locking */ then do while ("1"b); /* loop for asynch changes */ keep_loopin: call get_current_image_info; if code ^= 0 /* fatal error at this point */ then if code ^= error_table_$higher_inconsistency then return; /* abort immediately */ else do; /* maybe waiting will help */ call get_lock_status (lock_ptr, code); if code ^= error_table_$record_busy /* not other live process--no point waiting */ then do; code = error_table_$higher_inconsistency; return; /* warn user that he can't get valid image */ end; mics_left = timeout - clock (); if mics_left <= 0 /* no time to wait */ then return; call timer_manager_$sleep (min (50000, mics_left), "10"b); code = 0; /* set up for another try */ go to keep_loopin; end; if ind_desc = -1 /* logically deleted */ then do; /* return immediately */ rec_deleted = "1"b; if cur_mod ^= -3 /* still must take care or ref list */ then return; /* may continue scanning */ end; else if ind_desc = -2 /* means that before image applies */ then if block_ptr -> record_block.indirect then ind_desc = block_ptr -> ind_struct.prev_desc; else ind_desc = indx_cb.current_descrip; /* compact case */ if mod = 0 /* may need lock status to warn user */ then if block_ptr -> record_block.lock_flag then call get_lock_status (lock_ptr, code); if indx_cb.shared & indx_cb.trans /* reference within a transaction */ & ((code = 0) | (code = error_table_$locked_by_this_process) | (code = error_table_$lock_is_invalid)) then do; /* take care of reference list */ if current_t_code = 0 /* no transaction number assigned yet */ then call get_t_code; /* assigns a code or aborts if unable */ if (mod ^= current_t_code) /* not already locked by this transaction */ then call set_ref_list_entry (block_ptr); /* detects invalid prior ref */ end; call set_stat_reclp; /* ptr to stationary rec contents */ if current_retry_loc = read_retry then call return_contents; if fixed (time_stamp_struct.time_last_modified) = time_stamp then return; if clock () > timeout then do; code = error_table_$record_busy; return; end; end; /* loop until record snapshot passively obtained */ else do; /* lock the record and look at its header */ reattempt: /* retry point for post-adjustment case */ call compute_time_left; if ^(lock_ptr -> based_lock = indx_cb.saved_lock_copy) then cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask); call set_lock (lock_ptr, time_left, code); er_code = code; /* save returned code giving lock status */ call get_current_image_info; if code ^= 0 /* lock was non-zero */ then if code = error_table_$higher_inconsistency then do; if er_code = error_table_$locked_by_this_process then code = error_table_$record_busy;/* suppress attempt to unlock record */ else if stacq (lock_ptr -> based_lock, (36)"1"b, indx_cb.saved_lock_copy) then ; /* invalidate the lock again */ return; /* abort--fatal error */ end; else if code = error_table_$lock_wait_time_exceeded then do; /* abort with suitable code */ code = error_table_$record_busy; return; end; else if mod = 0 /* see if warning required */ then if block_ptr -> record_block.lock_flag then ; /* leave code non-zero as a warning */ else do; code = 0; cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask); /* permit unlocking */ end; else if code = error_table_$locked_by_this_process then if ^(indx_cb.trans) then do; /* abort with suitable code */ code = error_table_$record_busy;/* fatal error */ return; /* not locked by own transaction */ end; else if (mod = current_t_code) then code = 0; /* suppress warning--already locked by this trans */ else do; /* abort with suitable code */ code = error_table_$record_busy;/* fatal error */ return; /* not locked by own transaction */ end; else do; /* adjust record left locked by dead process */ call adjust_record (iocb_ptr, indx_cb.current_descrip, cur_mod, code); call check_code (code, "Can't adjust a record locked by dead process."); go to reattempt; /* adjustment ends by unlocking--do again */ end; if ind_desc = -1 /* logically deleted record */ then if cur_mod = -3 /* new record this transaction */ then if mod = 0 /* this operation is creating */ then ind_desc = indx_cb.current_descrip; else rec_deleted = "1"b; else do; /* not a pre-creation case */ rec_deleted = "1"b; if block_ptr -> stat_struct.modifier = 0 then do; /* mark vfile_ operation in progress */ cleanup_flags = cleanup_flags | (i_locked_mask & negmod_mask); /* set bit indicating modifier set */ block_ptr -> stat_struct.modifier = -1; end; go to adjust_ref_count; /* suppress ref list manipulation */ end; if indx_cb.trans /* modification inside a transaction */ then do; if current_t_code = 0 then call get_t_code; if mod ^= current_t_code /* not already locked by this transaction */ then do; /* take care of ref list */ if block_ptr -> stat_struct.prev_mod = -3 /* new record */ then call add_lock_list_entry (block_ptr, cleanup_flags & passive_ref_bit_mask); /* no need to verify this reference */ else do; call set_lock_list_entry (block_ptr, cleanup_flags & passive_ref_bit_mask); /* check for prior passive ref */ if (code ^= 0) & (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset) /* fatal error */ then return; /* abort */ block_ptr -> stat_struct.ind_comp = -1; time_stamp_struct.ind_offset = (17)"1"b; /* after descrip= -2 */ block_ptr -> stat_struct.ref_count_after = ref_cnt; /* indicates after image initially same as before--special case */ end; block_ptr -> stat_struct.modifier = current_t_code; call set_stat_reclp; ind_desc = -2; end; else if ind_desc = -2 /* before image applies */ then do; if block_ptr -> record_block.indirect then ind_desc = block_ptr -> ind_struct.prev_desc; else ind_desc = indx_cb.current_descrip; call set_stat_reclp; ind_desc = -2; end; else call set_stat_reclp; end; else do; /* initialize header for non-TP modification */ cleanup_flags = cleanup_flags | (i_locked_mask & negmod_mask); /* leave record locked but still need to zero modifier */ block_ptr -> stat_struct.modifier = -1; /* non-TP operation in progress */ call set_stat_reclp; end; adjust_ref_count: if ref_count_change < 0 /* decrementing */ then do; /* check lower limit constraint */ if rec_deleted /* logically absent */ then min_ref_count = 0; /* zero references permitted--can clean up */ else min_ref_count = 1; /* not deleted--at least one ref must remain */ if ref_cnt + ref_count_change < min_ref_count then do; /* abort */ code = error_table_$last_reference; return; /* suppress changing ref count below minimum */ end; end; else if ref_cnt + ref_count_change > max_ref_count then do; code = error_table_$too_many_refs; return; end; ref_cnt = ref_cnt + ref_count_change; if rec_deleted & ^is_read_only & (ref_count_change ^= 0) & (block_ptr -> stat_struct.modifier = -1) /* record_status ref_count change on a deleted record */ then do; block_ptr -> stat_struct.ref_count_after = ref_cnt; block_ptr -> stat_struct.ref_count = ref_cnt; end; /* permits garbage collection of unkeyed records */ end; /* lock is now set */ return; /* end of main stat rec inspection routine */ get_current_image_info: proc; /* same as set_current_image_info, except that it checks for the case of an item that may have already been modified by this transaction */ mod = block_ptr -> stat_struct.modifier; if (mod <= 0) | ^indx_cb.trans then call set_current_image_info; else if (mod = current_t_code) /* own transaction */ then do; /* get after image info */ time_stamp = fixed (time_stamp_struct.time_last_modified); cur_mod = mod; ind_des.comp = stat_struct.ind_comp; ind_des.offset = time_stamp_struct.ind_offset; ref_cnt = stat_struct.ref_count_after; end; else call set_current_image_info; /* handle any other case but own transaction */ end get_current_image_info; set_stat_reclp: proc; if ind_desc > 0 /* record allocation exists */ then do; if ind_desc = indx_cb.current_descrip /* compact case */ then do; max_rec_wds = block_ptr -> record_block.block_size - stat_header_size; record_ptr = addr (block_ptr -> stat_struct.record); end; else do; p = get_pointer (ind_desc); max_rec_wds = p -> record_block.block_size - 2; record_ptr = addr (p -> record_block.record); end; record_len = length (record_ptr -> based_vstring); end; dcl p ptr; end set_stat_reclp; dcl er_code fixed (35); dcl min_ref_count fixed; dcl mics_left fixed (71); end inspect_stat_record; return_contents: proc; /* gets record contents for read_record */ if record_len > 0 then if record_len <= buff_len then buffer = substr (record_ptr -> based_vstring, 1, record_len); else do; if buff_len > 0 then substr (buffer, 1, buff_len) = substr (record_ptr -> based_vstring, 1, buff_len); code = error_table_$long_record; end; end return_contents; get_t_code: proc; /* initializes the current transaction */ call transaction_call_$assign (indx_cb.tcfp, 0, er_code); /* creates a unique tcf entry for this transaction */ call check_code (er_code, "Unable to assign a transaction number to the current transaction."); dcl er_code fixed (35); end get_t_code; get_lock_status: proc (lockp, er_code); lock_copy = lockp -> based_lock; call set_lock (addr (lock_copy), 0, er_code); if er_code = 0 then return; if er_code = error_table_$lock_wait_time_exceeded then er_code = error_table_$record_busy; else if er_code = error_table_$invalid_lock_reset then er_code = error_table_$lock_is_invalid; dcl lockp ptr; dcl er_code fixed (35); dcl lock_copy bit (36) aligned; end get_lock_status; %include set_current_image_info; dcl 1 non_stat_struct based (block_ptr), 2 words (record_block.block_size - 1), 2 record_lock bit (36) aligned; dcl scan bit (1) aligned; dcl passive bit (1) aligned; dcl ref_count_change fixed; dcl (lock_ptr, block_ptr) ptr; dcl i_locked_mask bit (36) aligned; end lock_current_record; check_subset: proc (descrip); /* sees if descriptor has been excluded */ temp_cbp = indx_cb.temp_iocbp -> iocb.open_data_ptr; temp_cbp -> indx_cb.file_position_ptr = temp_cbp -> indx_cb.root_position_ptr; subset_key = current_subset_bytes || descrip_bytes; call find_key (temp_cbp, (addr (subset_key)), search_code); if indx_cb.subset_selected = "10"b then if search_code = 0 then rec_deleted = "1"b; else rec_deleted = "0"b; else if search_code ^= 0 then rec_deleted = "1"b; else rec_deleted = "0"b; /* verbose form to avoid operator call */ dcl descrip fixed (35); dcl descrip_bytes char (4) based (addr (descrip)); dcl temp_cbp ptr; dcl current_subset_bytes char (4) based (addr (indx_cb.current_subset)); dcl search_code fixed (35); dcl subset_key char (8) var; end check_subset; gk_scan: proc; /* called by get_key to find satisfactory descriptor */ if ^gk_inf.input_desc then if gk_inf.desc_code = 0 then desc_known = "0"b; else desc_known = "1"b; else desc_known = "1"b; if desc_known then do; if gk_inf.input_desc then wanted_desc = gk_inf.descrip; else wanted_desc = indx_cb.current_descrip; if indx_cb.subset_selected ^= "00"b then do; call check_subset (wanted_desc); if rec_deleted then do; if ^gk_inf.reset_pos then indx_cb.at_bof, indx_cb.at_eof = "0"b; go to norec; /* logically absent record */ end; end; end; else if indx_cb.subset_selected = "00"b /* any entry will do */ then return; /* current position is satisfactory */ reset_position = gk_inf.reset_pos; go to scan_loop; /* skip setup code for seek_head scan */ sh_scan: entry; /* handles scanning for seek_head */ desc_known = "0"b; reset_position = "0"b; scan_loop: do while ("1"b); descrip = record_designator (branch_num); if desc_known then if descrip = wanted_desc then return; /* desired descriptor found */ else ; /* must keep looking--scan */ else do; call check_subset (descrip); if ^rec_deleted /* not logically masked by current subset */ then do; if ^reset_position then indx_cb.current_descrip = descrip;/* must be valid for check_current */ return; /* done with scanning */ end; end; if indx_cb.skip_state < 0 /* scanning backward */ then do; call find_prev_entry; if branch_num = 1 /* bof */ then do; if ^reset_position then call position_bof; norec: code = error_table_$no_record; /* abort */ indx_cb.skip_state = 0; /* resume default forward scanning */ return; /* stop scanning */ end; branch_num = branch_num - 1; end; else do; branch_num = branch_num + 1; /* advance one index entry */ call find_this_entry; if pos_ptr = indx_cb.root_position_ptr /* eof */ then do; if ^reset_position then call position_eof; go to norec; end; if indx_cb.skip_state > 0 then if substr (keys, key_pos (branch_num), min (key_length (branch_num), indx_cb.skip_state)) > substr (pad_key, 1, indx_cb.skip_state) /* key out of range */ then do; if ^reset_position then do; indx_cb.next_record_position = 0; indx_cb.current_record_is_valid = "0"b; end; go to norec; end; end; end; dcl desc_known bit (1) aligned; dcl (wanted_desc, descrip) fixed (35); dcl reset_position bit (1) aligned; end gk_scan; find_next_record: proc; code = 0; if pos_incorrect /* must restore index pos */ then do; call restore_position; if code ^= 0 then return; /* asynch deletion */ end; else pos_ptr = file_position_ptr; indx_cb.ready_to_write = indx_cb.dup_ok; indx_cb.outside_index, indx_cb.at_eof, indx_cb.at_bof = "0"b; /* reset if outside */ indx_cb.current_record_is_valid = "1"b; if indx_cb.next_record_position = 1 then do; if branch_num < last_branch_num then go to set_current; end; else if indx_cb.next_record_position = 2 then do; /* next record follows current position */ branch_num = branch_num + 1; indx_cb.next_record_position = 1; end; else do; /* next record is undefined */ code = error_table_$no_record; indx_cb.current_record_is_valid = "0"b; indx_cb.ready_to_write = "0"b; return; end; call find_this_entry; if pos_ptr = root_position_ptr /* end of file */ then do; call position_eof; /* set process info and position */ code = error_table_$end_of_info; end; else do; set_current: indx_cb.current_descrip = record_designator (branch_num); end; end find_next_record; find_this_entry: proc; /* routine gets position of following index proc */ call find_leftmost_descendent; /* in case we are not at a leaf */ find_from_leaf: entry; loop: if branch_num = last_branch_num then if last_branch_num > 1 then do; pos_ptr = parent_position_ptr; go to loop; end; file_position_ptr = pos_ptr; end find_this_entry; find_prev_entry: proc; /* routine finds position of preceding index entry */ call find_rightmost_descendent; /* in case non-leaf */ loop: if branch_num = 1 then if last_branch_num > 1 then do; pos_ptr = parent_position_ptr; /* position moves to parent node */ go to loop; end; file_position_ptr = pos_ptr; end find_prev_entry; backspace: proc; /* moves index position back one, setting code if end of info */ code = 0; if indx_cb.pos_incorrect then do; call restore_position; if code ^= 0 then return; /* asynch deletion */ end; else pos_ptr = indx_cb.file_position_ptr; indx_cb.outside_index = "0"b; call find_prev_entry; if branch_num = 1 /* beginning of file */ then do; code = error_table_$end_of_info; call position_bof; return; end; branch_num = branch_num - 1; indx_cb.current_descrip = record_designator (branch_num); end backspace; seek_head: proc (rel_type, key_ptr, head_len); indx_cb.file_position_ptr = indx_cb.root_position_ptr;/* prepare for descent */ call find_key (indx_cb_ptr, (key_ptr), foo); pos_ptr = indx_cb.file_position_ptr; call find_from_leaf; /* in case of match in upper node */ do while (pos_ptr ^= root_position_ptr); if substr (key_ptr -> based_vstring, 1, head_len) = substr (keys, key_pos (branch_num), min (key_length (branch_num), head_len)) /* heads match */ then if rel_type ^= 2 /* that's fine */ then return; /* satisfactory entry found */ else do; /* keep searching forward */ branch_num = branch_num + 1; call find_this_entry; /* handles exceptional cases */ end; else if rel_type > 0 /* looking for larger head--fine */ then return; /* search done */ else pos_ptr = root_position_ptr; /* causes exit from loop */ end; dcl rel_type fixed; dcl key_ptr ptr; dcl head_len fixed; end seek_head; get_pointer: proc (descrip) returns (ptr); if descrip < 4096 then return (null); if (desc.comp_num >= 0) & (desc.comp_num <= indx_cb.old_last_comp_num) /* in case shared and unlocked */ then if seg_ptr_array (desc.comp_num) = null then p = get_seg_ptr (iocb_ptr, (desc.comp_num)); else ; /* fall through */ else call check_code (error_table_$bad_arg, "Invalid msf component."); return (get_ptr (descrip)); dcl p ptr; dcl descrip fixed (35); dcl 1 desc aligned based (addr (descrip)), 2 comp_num fixed (17) unal, 2 offset bit (18) unal; end get_pointer; get_key_length: proc returns (fixed); len = key_length (branch_num); if indx_cb.min_key_len <= 0 /* keys never padded with blanks */ then return (len); if len = indx_cb.min_key_len then do; tail_len = verify (reverse (substr (keys, key_pos (branch_num), len)), " ") - 1; if tail_len < 0 then tail_len = len; len = len - tail_len; end; return (len); dcl len fixed; dcl tail_len fixed; end; /* end get_key_length */ compare_last_key: proc (key); /* used to verify key order in kso openings */ key_is_dup = "0"b; /* will be set if user seeks last key in file */ if last_branch_num > 1 /* file not empty */ then if key <= substr (keys, key_pos (last_branch_num - 1), key_length (last_branch_num - 1)) then do; /* key not larger--maybe dup */ code = error_table_$key_order; if key = substr (keys, key_pos (last_branch_num - 1), key_length (last_branch_num - 1)) then key_is_dup = "1"b; end; dcl key char (256) var; end compare_last_key; check_rs_args: proc; /* routine validates args to the "record_status" order */ rs_info_ptr = info_ptr; if (rs_info.version < rs_info_version_1) | (rs_info.version > rs_info_version_2) /* only versions currently supported */ then code = error_table_$unimplemented_version; else if indx_cb.trans & rs_info.unlock_sw & ^rs_info.unlock_sw /* no unlocking under -trans */ then code = error_table_$no_operation; else do; /* keep checking */ /* unlocking is treated passively, as far as synchronization is concerned */ passive_op = ^(rs_info.create_sw | rs_info.lock_sw | rs_info.inc_ref_count | rs_info.dec_ref_count); if (^passive_op | rs_info.unlock_sw) & is_read_only /* need write access */ then code = error_table_$no_operation; else do; if rs_info.create_sw then if max (rs_info.max_rec_len, rs_info.record_length) > max_record_size then code = error_table_$long_record; else if indx_cb.subset_selected = "10"b /* pure selection in effect */ then code = error_table_$no_record; else if rs_info.dec_ref_count & ^rs_info.inc_ref_count then code = error_table_$last_reference; /* error--ref count too small */ else if ^rs_info.lock_sw then if rs_info.unlock_sw then code = error_table_$lock_not_locked; else ; else if ^indx_cb.shared then if ^indx_cb.stat & ^rs_info.inc_ref_count & ^rs_info.dec_ref_count then do; recl = max (0, rs_info.record_length); capacity = max (min_max_rec_len, recl, rs_info.max_rec_len); if rs_info.max_rec_len <= 0 then capacity = max (capacity, indx_cb.min_cap, recl + indx_cb.min_res); if capacity - recl < 4 then code = error_table_$no_room_for_lock; end; else ; else ; else do; /* non-creation case */ if rs_info.locate_sw /* descriptor is input arg */ then if (addr (rs_info.descriptor) -> rs_desc.comp_num <= 0) /* invalid component number */ then code = error_table_$no_record; else /* use input descrip to set current record position */ call make_current (rs_info.descriptor); if rs_info.inc_ref_count then if rs_info.dec_ref_count then delta_ref_count = 0; else delta_ref_count = 1; else if rs_info.dec_ref_count then delta_ref_count = -1; else delta_ref_count = 0; end; end; end; dcl (recl, capacity) fixed (21); end check_rs_args; record_status: proc; /* routine supports record_status order except for arg checking */ if rs_info.create_sw /* create a new record */ then do; call initialize_substate; /* prepare file state block */ file_base.new_record_length = max (rs_info.record_length, 0); /* save args for crash recovery */ if rs_info.max_rec_len > 0 /* override default min_block_size settings */ then do; file_base.saved_min_cap = max (rs_info.max_rec_len, min_max_rec_len); file_base.saved_min_res = 0; end; else call save_min_blksz_inf; /* in case of crash */ file_base.out_of_index = rs_info.locate_sw; if rs_info.locate_sw & ^indx_cb.repeating /* new rec won't be entered into index with key */ then call set_add_rec_stats; else call set_add_ent_info ("1"b); /* prepare to add index entry and new record */ file_base.old_ref_count = fixed (rs_info.inc_ref_count) - fixed (rs_info.dec_ref_count) + fixed (^rs_info.locate_sw); /* initial ref count desired */ file_base.was_stat = indx_cb.stat | rs_info.inc_ref_count | rs_info.dec_ref_count; file_action = adding_record; /* necessary info saved, now alter file */ call change_record_list (iocb_ptr, insert_action, (null), abort_exit); /* create empty record */ file_base.change_count = file_base.old_file_ch_count + 1; if rs_info.locate_sw /* don't add index entry */ then call make_current (new_descriptor); /* set current position to new record */ else do; /* place entry into the index */ indx_cb.current_descrip = new_descriptor; call set_new_record_designator; call change_index (iocb_ptr, abort_exit); /* does the work */ pos_ptr = file_position_ptr; call set_post_write_pos; end; call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 0); /* no ref count change */ call set_rs_return_info; /* fills in info structure */ if (code = 0) | (code = error_table_$locked_by_this_process) /* in case of recovery--can't hurt */ | (code = error_table_$invalid_lock_reset) then if ^rs_info.lock_sw /* nothing more to do */ then go to switch_file_state; else if lock_ptr = null /* small non-stationary allocation */ then code = error_table_$no_room_for_lock; else if rs_info.unlock_sw /* also immediately unlock--silly request when creating */ then go to switch_file_state; else if indx_cb.trans /* TP case--leave locked, but no need to set flag */ then go to switch_file_state; else do; block_ptr -> record_block.lock_flag = "1"b; /* warn others about image change */ i_locked_rec = "0"b; /* suppress unlocking this record in unlock_exit */ go to switch_file_state; end; aborting = "1"b; /* unexpected error -- file will be adjusted later */ end; /* new record created and made current */ else do; /* non-creation case */ if ^rs_info.locate_sw then do; /* make sure current record is defined */ call check_current; /* may find next rec if not at current */ if code ^= 0 /* error--current record must be defined */ then return; end; if passive_op then call set_current_reclp (block_ptr, lock_ptr); else do; /* obtain record_ptr non-passively */ call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, delta_ref_count); /* may wait up to wait time limit */ if (code = 0) | (code = error_table_$locked_by_this_process) | (code = error_table_$invalid_lock_reset) /* no fatal errors occurred */ then do; if rs_info.lock_sw & ^rs_info.unlock_sw then if indx_cb.trans /* transaction case */ then if ind_desc = -2 /* means first modification--after=before */ then do; /* initialize after image as copy of before */ if indx_cb.shared then indx_cb.shared = ^indx_cb.leave_locked & ^i_locked_file; else saved_state.outside_index = indx_cb.outside_index; indx_cb.outside_index = "1"b; /* prevent rewrite from changing position */ call rewrite_indx_file (iocb_ptr, addrel (record_ptr, 1), record_len, er_code); /* should have internal procedure for efficiency */ indx_cb.outside_index = saved_state.outside_index; /* restore to prior state */ indx_cb.shared = saved_state.shared; if er_code ^= 0 then do; code = er_code; call set_rs_return_info; return; end; ind_des.comp = stat_struct.ind_comp; ind_des.offset = time_stamp_struct.ind_offset; record_ptr = addrel (get_ptr (ind_desc), 1); /* comp must be known */ end; else ; /* already have initialized after image */ else if lock_ptr = null /* allocation too small for lock in tail */ then code = error_table_$no_room_for_lock; else do; /* just locking, non-TP case */ block_ptr -> record_block.lock_flag = "1"b; /* warn others */ if block_ptr -> record_block.stationary /* record has time_stamp */ then time_stamp_struct.time_last_modified = clock (); else file_base_ptr -> file_base.change_count = file_base_ptr -> file_base.change_count + 1; i_locked_rec = "0"b; /* suppress unlocking */ end; if rs_info.inc_ref_count | rs_info.dec_ref_count then if ^block_ptr -> record_block.stationary then code = error_table_$no_room_for_lock; /* error really is that rec is non-stationary */ else if indx_cb.trans then block_ptr -> stat_struct.ref_count_after = ref_cnt; else block_ptr -> stat_struct.ref_count = ref_cnt; end; end; /* pointer obtained non-passively */ call set_rs_return_info; end; /* end of non-creation case logic */ set_rs_return_info: proc; /* fills in user-supplied info structure */ rs_info.record_length = record_len; rs_info.descriptor = indx_cb.current_descrip; if record_ptr = null /* no record allocation */ then do; rs_info.record_ptr = null; rs_info.max_rec_len = 0; end; else rs_info.record_ptr = addrel (record_ptr, 1); /* point to contents, not length word */ if block_ptr ^= null /* allocation exists */ then do; /* get info about block */ if block_ptr -> record_block.stationary then do; /* give stationary record info */ rs_info.ref_count = ref_cnt; if rs_info.version = rs_info_version_2 /* larger info structure than old one */ then do; rs_info.modifier = mod; rs_info.time_last_modified = time_stamp; rs_info.last_image_modifier = cur_mod; end; end; if rs_info.version = rs_info_version_2 /* see comment above */ then rs_info.block_ptr = block_ptr; rs_info.max_rec_len = 4 * max_rec_wds; end; end set_rs_return_info; dcl er_code fixed (35); end record_status; save_correct_pos: proc; /* routine remembers current info so positions can be restored */ if ^indx_cb.pos_incorrect & (string (indx_cb.at_eof_or_bof) = "00"b) & ^(indx_cb.next_record_position = 0) then do; pos_ptr = indx_cb.file_position_ptr; if branch_num = last_branch_num /* key may not exist */ then do; call find_this_entry; if pos_ptr = root_position_ptr /* at end of file */ then do; /* set position vars */ call set_at_eof; /* no need to actually descend now */ indx_cb.current_record_is_valid = indx_cb.outside_index; pos_incorrect = "1"b; return; end; end; indx_cb.new_key = substr (keys, key_pos (branch_num), key_length (branch_num)); indx_cb.saved_descrip = record_designator (branch_num); end; end save_correct_pos; make_current: proc (descrip); /* routine sets current pos outside index */ indx_cb.ready_to_write = "0"b; indx_cb.current_descrip = descrip; indx_cb.outside_index = "1"b; /* current record moves outside index */ indx_cb.current_record_is_valid = "1"b; dcl descrip fixed (35); end make_current; set_add_rec_stats: proc; /* prepares statistics indicating successful creation of new record */ if indx_cb.trans /* transaction case */ then return; /* stats not changed until checkpoint */ os_ptr -> number_of_records = number_of_records + 1; os_ptr -> total_record_length = total_record_length + new_record_length; end set_add_rec_stats; prepare_process: proc; /* used by passive shared operations to set up process vars and wait for opportunity to look at file */ if ^i_locked_file & ^leave_locked /* unlocked between operations */ then do; /* check for asynch activity */ call check_file_lock; /* waits till unlocked or time exhausted */ fault_ok = "1"b; /* fault may reasonably occur because of asynch changes */ if last_change_count ^= new_change_count /* asynch changes--restore process info */ then do; call initialize_ptrs; pos_incorrect = "1"b; /* will reseek before attempting index ref */ last_change_count = new_change_count; end; end; else code = 0; end prepare_process; check_file_lock: proc; /* waits for lock to be clear until time left is exhausted */ code = 0; if indx_cb.wait_time < 0 /* will wait indefinitely */ then timeout = eternity; /* may wait forever */ else timeout = clock () + indx_cb.wait_time; /* microseconds */ do while (code = 0); /* wait loop */ new_change_count = change_count; /* must save this before checking lock */ fs_ptr = addr (file_state_blocks (file_state)); if file_action = 0 /* not busy with alteration */ then if new_change_count = change_count /* in case state has flipped */ then return; lock_copy = file_base.lock_word; /* copy the lock--can't alter file itself */ call set_lock (addr (lock_copy), 0, code); if code = 0 then return; /* lock was clear */ mics_left = timeout - clock (); if (code = error_table_$lock_wait_time_exceeded) /* really busy */ & (mics_left > 0) /* OK to wait longer */ then do; call timer_manager_$sleep (min (50000, mics_left), "10"b); /* wait .05 seconds */ code = 0; end; else if (code = error_table_$invalid_lock_reset) & ^indx_cb.is_read_only then call adjust_file (iocb_ptr, code); else code = error_table_$file_busy; end; /* end of wait loop */ go to exit; /* abort */ dcl mics_left fixed (71); end check_file_lock; position_eof: proc; pos_ptr = root_position_ptr; call find_rightmost_descendent; set_at_eof: entry; /* avoids cost of descent when not needed */ indx_cb.next_record_position = 1; indx_cb.ready_to_write = "0"b; indx_cb.current_record_is_valid = "0"b; indx_cb.at_eof = "1"b; /* causes re-seek to eof if shared and asynch changes */ end; position_bof: proc; pos_ptr = root_position_ptr; call find_leftmost_descendent; indx_cb.next_record_position = 1; if last_branch_num > 1 then indx_cb.current_record_is_valid = "1"b; else indx_cb.current_record_is_valid = "0"b; indx_cb.ready_to_write = indx_cb.current_record_is_valid & dup_ok; indx_cb.at_bof = "1"b; /* shared re-seek will be to bof */ end; find_rightmost_descendent: proc; do while (branch (branch_num) ^= 0); son_position_ptr -> node = branch (branch_num); son_position_ptr -> node_ptr = get_ptr (branch (branch_num)); pos_ptr = son_position_ptr; branch_num = last_branch_num; end; file_position_ptr = pos_ptr; end; /* end find_rightmost_descendent */ find_leftmost_descendent: proc; do while (branch (branch_num) ^= 0); son_position_ptr -> node = branch (branch_num); son_position_ptr -> node_ptr = get_ptr (branch (branch_num)); pos_ptr = son_position_ptr; branch_num = 1; end; file_position_ptr = pos_ptr; end; /* end find_leftmost_descendent */ set_lock: proc (lockp, wtime, er_code); /* internal equivalent of system set_lock_$lock */ if stac (lockp, indx_cb.saved_lock_copy) /* sets if zero */ then er_code = 0; /* done */ else if lockp -> based_lock = indx_cb.saved_lock_copy then er_code = error_table_$locked_by_this_process; else call set_lock_$lock (lockp -> based_lock, wtime, er_code); /* must resort to expensive call */ dcl lockp ptr; dcl wtime fixed; dcl er_code fixed (35); end set_lock; compute_time_left: proc; (nosize): time_left = divide (fixed (timeout - clock () + 999999, 35, 0), 1000000, 17, 0); end compute_time_left; lock_file_check: proc; /* locks & re-seeks previously located position if file has changed */ pos_ptr = file_position_ptr; f_b_ptr = file_base_ptr; fs_ptr = indx_cb.file_state_ptr; if indx_cb.leave_locked | i_locked_file /* already locked */ then return; /* no need to lock again */ fault_ok = "0"b; /* no more asynch change errors allowed */ call compute_time_left; if (file_base.lock_word = indx_cb.saved_lock_copy) then i_locked_file = "0"b; /* this op is not first to lock */ else i_locked_file = "1"b; /* if lock becomes set, this op did it */ call set_lock (addr (file_base.lock_word), time_left, er_code); if er_code ^= 0 /* lock was non-zero */ then if er_code = error_table_$invalid_lock_reset then er_code = 0; else do; /* abort */ code = error_table_$file_busy; indx_cb.state_vars = saved_state; /* quick state restore */ go to unlock_exit; end; if change_count ^= last_change_count then call initialize_ptrs; if (file_action ^= 0) & (file_action ^= read_exclude) then do; call restart (iocb_ptr, er_code); /* try to complete interrupted operation */ fs_ptr = indx_cb.file_state_ptr; call check_code (er_code, "Unable to adjust a vfile_ operation in progress."); end; if change_count ^= last_change_count then pos_incorrect = "1"b; /* will force re-seek if index is referenced */ dcl er_code fixed (35); end lock_file_check; initialize_substate: proc; /* prepares recovery vars */ f_b_ptr = file_base_ptr; if indx_cb.shared then call lock_file_check; fs_ptr = indx_cb.file_state_ptr; os_ptr = indx_cb.o_s_ptr; if repeating /* recovery is in progress */ then if file_substate = 0 /* died before finishing first block */ then repeating = "0"b; /* switch to normal execution */ else next_substate = 0; /* this count will keep track of recovery execution */ else do; /* normal execution */ file_substate = 0; /* first block not yet completed */ file_base.old_file_ch_count = file_base.change_count; file_base.was_transaction = indx_cb.trans; os_ptr -> file_state_words = fs_ptr -> file_state_words; if indx_cb.read_exclu /* leave read lock set */ then os_ptr -> file_action = read_exclude; /* locks out readers */ else os_ptr -> file_action = 0; end; dcl 1 fsb based, /* file state block */ 2 word fixed, /* file action slot */ 2 file_state_words (9) fixed; /* avoids unused portion of fsb */ end initialize_substate; check_current: proc; /* routine aborts if current record is undefined */ pos_ptr = file_position_ptr; code = 0; if ^indx_cb.outside_index /* current record located via index */ then do; if pos_incorrect then do; call restore_position; if code ^= 0 then return; end; if indx_cb.current_record_is_valid then do; indx_cb.at_bof = "0"b; /* reposition to record now that reference has occurred */ indx_cb.current_descrip = record_designator (branch_num); return; end; else if indx_cb.next_record_position ^= 0 then do; /* current is next--find it */ call find_next_record; /* detects eof */ if indx_cb.subset_selected ^= "00"b /* may have to scan */ then if code = 0 /* index entry exists, but may be masked */ then call sh_scan; /* does subset checking and scanning */ end; end; if ^indx_cb.current_record_is_valid then code = error_table_$no_record; end check_current; save_min_blksz_inf: proc; /* save info set by "min_block_size" order, in case of crash while rewriting or inserting */ file_base.saved_min_res = indx_cb.min_res; file_base.saved_min_cap = indx_cb.min_cap; end save_min_blksz_inf; initialize_ptrs: proc; /* resets process vars invalidated by asynch changes */ if old_last_comp_num ^= last_comp_num then do; /* recreate seg_ptr_array */ call free_seg_ptrs (iocb_ptr); call create_seg_ptrs (iocb_ptr); end; else do; /* these initialized by createseg_ptrs */ if old_rover_comp_num ^= rover_comp_num then do; /* initialize rover */ rover_seg_ptr = get_seg_ptr (iocb_ptr, rover_comp_num); old_rover_comp_num = rover_comp_num; end; index_state_ptr = addr (index_state_blocks (index_state)); end; if old_index_height < index_state_ptr -> index_height /* no sweat if height decreases */ then do; /* recreate position stack */ call free_position_stack (indx_cb_ptr); call create_position_stack (indx_cb_ptr); pos_ptr = file_position_ptr; end; file_state_ptr = addr (file_state_blocks (file_state)); fs_ptr = indx_cb.file_state_ptr; o_s_ptr = addr (file_state_blocks (1 - file_state)); if ^indx_cb.dup_ok then if duplicate_keys ^= 0 then indx_cb.dup_ok = "1"b; end initialize_ptrs; restore_position: proc; /* re-establishes index position which may have become invalid because of asynch changes */ code = 0; if indx_cb.is_ks_out & indx_cb.ready_to_write /* must keep track of key order constraint */ then do; /* position to end of file and test order */ file_position_ptr = root_position_ptr; /* prepare for descent */ call find_rightmost_descendent; /* end of file */ call compare_last_key (indx_cb.new_key); /* sets code and key_is_dup */ if code ^= 0 /* not larger than last key in file */ then do; code = 0; /* don't flag key_order error now */ if ^key_is_dup /* no longer at last key */ then indx_cb.ready_to_write = "0"b; /* asynch insertions leave indx_cb.new_key out of order */ else if ^dup_ok /* key exists but no duplications allowed */ then do; indx_cb.ready_to_write = "0"b; /* stop illegal duplications */ if indx_cb.at_eof /* must have just done unsuccessful seek */ then code = error_table_$asynch_insertion; /* signal this error */ end; end; if indx_cb.at_eof /* position fully restored and checked */ then return; /* no more work necessary */ end; /* now indx_cb.ready_to_write reflects asynch changes if mode is kso */ if indx_cb.at_bof then call position_bof; else if indx_cb.at_eof then call position_eof; else if ^dup_ok /* no duplications allowed */ then do; file_position_ptr = root_position_ptr; call find_key (indx_cb_ptr, (addr (indx_cb.new_key)), search_code); pos_ptr = file_position_ptr; if search_code ^= 0 /* key found */ then do; call find_from_leaf; if indx_cb.ready_to_write /* key should be absent */ then do; code = error_table_$asynch_insertion; indx_cb.ready_to_write = "0"b; indx_cb.current_record_is_valid = "1"b; indx_cb.next_record_position = 1; end; end; else do; as_del: if (indx_cb.next_record_position ^= 0) | (indx_cb.current_record_is_valid & ^indx_cb.outside_index) then do; /* previously located record has been deleted by another process */ code = error_table_$asynch_deletion; indx_cb.ready_to_write = (^is_read_only & ^is_ks_out); indx_cb.current_record_is_valid = "0"b; indx_cb.next_record_position = 0; end; end; end; else do; call find_entry (indx_cb.new_key, indx_cb.saved_descrip); if search_code = 0 /* no asynch insertions when dup keys allowed */ then if first_code = 0 /* key not found */ then go to as_del; /* check for possible asynch deletion */ else if indx_cb.stat /* insist on same descriptor */ then go to as_del; else do; /* key was found, but not current descrip */ call find_prev_entry; /* set pos to last matching key */ branch_num = branch_num - 1; /* does the backspace */ end; end; pos_incorrect = "0"b; /* index position correctly restored */ end restore_position; find_entry: proc (key, descrip); /* routine finds pos for given key and record descriptor */ file_position_ptr = root_position_ptr; /* search starts at base of index */ call find_key (indx_cb_ptr, (addr (key)), search_code); pos_ptr = file_position_ptr; if search_code ^= 0 /* key found */ then call find_from_leaf; /* in case match is non-leaf */ first_code = search_code; /* will be non-zero if key was found */ key_is_dup = "0"b; /* will be set in loop if key is not unique */ do while (search_code ^= 0); /* advance until descrip is found or key changes */ if record_designator (branch_num) = descrip /* descrip found */ then return; /* done--position set properly */ branch_num = branch_num + 1; /* advance position */ call find_this_entry; /* takes care of exceptional cases */ if pos_ptr = root_position_ptr /* end of file */ then search_code = 0; /* stop searching */ else if substr (keys, key_pos (branch_num), key_length (branch_num)) = key then key_is_dup = "1"b; else search_code = 0; /* key has changed--stop searching */ end; dcl key char (256) var; dcl descrip fixed (35); end find_entry; abort_exit: code = error_table_$file_is_full; aborting = "1"b; file_base_ptr -> file_base.max_comp_num = true_max_comp_num + 2; go to unlock_exit; switch_file_state: file_state = 1 - file_state; file_state_ptr = os_ptr; o_s_ptr = fs_ptr; unlock_exit: if indx_cb.shared then if ^indx_cb.leave_locked & i_locked_file then if ^aborting then do; /* OK to clear the file lock */ call save_correct_pos; last_change_count = change_count; if stacq (lock_word, "0"b, indx_cb.saved_lock_copy) /* unlock */ then ; end; else do; call restore_state; if stacq (lock_word, (36)"1"b, indx_cb.saved_lock_copy) then ; /* invalidate the lock */ end; else if aborting then call restore_state; else call save_correct_pos; if i_locked_rec then call unlock_record (block_ptr, lock_ptr, old_passive_ref_mask); else if i_set_negmod & ^aborting & (block_ptr ^= null)/* modifier set to -1 */ then block_ptr -> stat_struct.modifier = 0; /* clear it */ if i_locked_new then call unlock_record (new_block_ptr, new_lock_ptr, new_passive_ref_mask); /* in case of reassign_key operation */ else if i_set_new_negmod & ^aborting & (new_block_ptr ^= null) then new_block_ptr -> stat_struct.modifier = 0; exit: return; /* external exit point */ rewrite_indx_file: entry (iocb_ptr, buff_ptr, buff_len, code); current_retry_loc = rew_retry; go to init_up_down; retry_loc (12): call check_buff_len; call check_current; if code ^= 0 then go to verify_done; call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 0); /* handles deleted record case */ if code ^= 0 then if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset) then go to verify_done; if indx_cb.outside_index /* not using index */ then if ^block_ptr -> record_block.stationary /* see if non-stationary */ then if buff_len + indx_cb.min_res > 4 * (block_ptr -> record_block.block_size - 2) then do; /* don't permit reallocation from outside index */ if code = error_table_$locked_by_this_process then i_locked_rec = "0"b; /* suppress unlocking of the record */ code = error_table_$long_record; go to unlock_exit; /* abort--no need to verify, since indx_cb.outside_index */ end; else ; else ; else if is_sequential_open then indx_cb.next_record_position = 2; else indx_cb.next_record_position = 0; /* OK to lock file now that record is locked */ call initialize_substate; /* prepare for file state change after locking file, if not already locked */ file_base.old_record_designator = indx_cb.current_descrip; if ^indx_cb.outside_index then do; /*Only need to save current node when using index.*/ first_branch = node; /* just a convenient place to save current node */ file_base.count = branch_num; /* convenient place to save current branch_num */ end; call save_min_blksz_inf; file_base.out_of_index = indx_cb.outside_index; /* remember in case of crash */ call save_old_record_length; new_record_length = max (0, buff_len); file_action = replace_action; if file_base.was_stat /* record is stationary type */ then do; if (new_record_length > 0) | (indx_cb.min_cap > 0) | (indx_cb.min_res > 0) then /* always save buffer contents before rewriting */ call change_record_list (iocb_ptr, allocate_action, buff_ptr, abort_exit); else file_base.new_descriptor = 0; /* no allocation required */ stat_struct.ind_comp = new_rec_des.comp; time_stamp_struct.ind_offset = new_rec_des.offset; change_count = file_base.old_file_ch_count + 1; /* must be bumped before body of operation */ if file_base.was_transaction /* in transaction mode */ then do; /* transaction case--retain before image */ if (file_base.old_ind_desc > 0) /* current allocation exists--replace it */ then call change_record_list (iocb_ptr, replace_action, buff_ptr, abort_exit); os_ptr -> number_of_allocated_records = number_of_allocated_records; /* this statistic not changed until checkpoint occurs */ end; /* done with rewrite for transaction case */ else do; /* non-TP case */ os_ptr -> total_record_length = total_record_length + buff_len - old_record_length; call change_record_list (iocb_ptr, replace_action, null, abort_exit); end; end; /* end of stationary replacement logic */ else do; /* non-stationary case */ file_base.change_count = file_base.old_file_ch_count + 1; os_ptr -> total_record_length = total_record_length + buff_len - old_record_length; if (new_record_length > 0) | (indx_cb.min_cap > 0) | (indx_cb.min_res > 0) then do; /* insert or replace record */ if old_record_designator ^= 0 then record_action = replace_action; else do; record_action = insert_action; i_locked_rec = "1"b; /* unlock when done */ end; call change_record_list (iocb_ptr, record_action, buff_ptr, abort_exit); if file_base.new_descriptor = file_base.old_record_designator /* allocation hasn't moved */ then if i_locked_rec /* lock set by this operation */ then block_ptr -> record_block.lock_flag = "0"b; /* not leaving locked, so clear the flag */ else if (code ^= 0) & (code = error_table_$locked_by_this_process) /* lock was already set by my process before rewriting */ then ; /* will leave lock set, if room remains */ else do; /* won't leave lock set */ block_ptr -> record_block.lock_flag = "0"b; go to end_ns_rew; /* didn't set lock anyway */ end; else if (code ^= 0) & (code = error_table_$locked_by_this_process) then do; /* leave new allocation locked, if room */ block_ptr = get_ptr (file_base.new_descriptor); block_ptr -> record_block.lock_flag = "1"b; end; else do; i_locked_rec = "0"b; /* suppress unlocking rec */ go to end_ns_rew; end; if block_ptr -> record_block.block_size > divide (file_base.new_record_length + 11, 4, 19, 0) then do; /* room for lock--be sure it is still set */ lock_ptr = addr (block_with_lock.record_lock); lock_ptr -> based_lock = indx_cb.saved_lock_copy; /* in case location of the lock has moved */ end; else do; /* no more room for record lock */ block_ptr -> record_block.lock_flag = "0"b; i_locked_rec = "0"b; /* suppress attempt to unlock */ end; end; /* done with new allocation case */ else do; /* don't create or leave a record */ if old_record_designator ^= 0 then /* delete the old record */ call change_record_list (iocb_ptr, delete_action, (null), abort_exit); new_descriptor = 0; i_locked_rec = "0"b; end; end_ns_rew: if ^indx_cb.outside_index /* index position being used */ then record_descrip (branch_num) = new_descriptor; /* put new record descriptor into current index position */ else indx_cb.current_descrip = new_descriptor; end; /* done with non-stationary logic */ go to switch_file_state; /* unlocks file and record--end of rewrite logic */ unlock_record: proc (block_ptr_arg, lock_ptr_arg, passive_ref_mask); /* by convention, the record is always unlocked last when independent synch levels are involved */ if block_ptr_arg = null /* no record allocation to unlock */ then return; if lock_ptr_arg = null then return; if aborting then do; /* invalidate the record lock, if room */ if indx_cb.trans then if block_ptr_arg -> record_block.stationary then if (block_ptr_arg -> stat_struct.modifier > 0) & (block_ptr_arg -> stat_struct.modifier = current_t_code) then return; /* leave locked -- refl entry must exist */ else if cleanup_flags & passive_ref_mask ^= "000000"b /* passive refl entry exists */ then return; /* don't invalidate if in ref list */ if lock_ptr_arg ^= null then if stacq (lock_ptr_arg -> based_lock, (36)"1"b, indx_cb.saved_lock_copy) then ; /* clobber record lock */ return; end; if block_ptr_arg -> record_block.stationary then if block_ptr_arg -> stat_struct.modifier > 0 then return; /* leave locked until checkpoint or rollback */ if ^(lock_ptr_arg -> based_lock = indx_cb.saved_lock_copy) then return; block_ptr_arg -> record_block.lock_flag = "0"b; if block_ptr_arg -> record_block.stationary then do; stat_struct.ind_comp = 0; time_stamp_struct.ind_offset = "0"b; stat_struct.modifier = 0; end; if stacq (lock_ptr_arg -> based_lock, "0"b, indx_cb.saved_lock_copy) then ; dcl (block_ptr_arg, lock_ptr_arg) ptr; dcl 1 time_stamp_struct like time_stamp_structure based (addr (stat_struct.time_stamp_words)); dcl passive_ref_mask bit (36) aligned; dcl 1 record_block like record_block_structure based (block_ptr_arg); dcl 1 stat_struct like stat_structure based (block_ptr_arg); end unlock_record; save_old_record_length: proc; if repeating then do; call check_file_substate; return; end; file_base.old_record_length = record_len; call save_stat_info; file_substate = file_substate + 1; end save_old_record_length; save_stat_info: proc; /* saves info about current record for recovery */ if file_base.old_record_designator <= 0 /* no allocated record */ then file_base.was_stat = "0"b; /* stationary record is always allocated */ else do; /* save info about record block */ file_base.prior_block_size = block_ptr -> record_block.block_size; file_base.was_stat = block_ptr -> record_block.stationary; file_base.was_ind = block_ptr -> record_block.indirect; file_base.old_prev_mod = block_ptr -> stat_struct.prev_mod; file_base.old_ind_desc = ind_desc; /* indirect descriptor */ file_base.old_modifier = max (0, stat_struct.modifier); end; end save_stat_info; prepare_key: proc (new_key); new_key_length = max (length (new_key), indx_cb.min_key_len); substr (new_key_string, 1, new_key_length) = new_key; dcl new_key char (256) varying; end; /* end prepare key */ write_indx_file: entry (iocb_ptr, buff_ptr, buff_len, code); /* ref6 */ current_retry_loc = write_retry; go to init_down_up; retry_loc (13): call check_buff_len; if indx_cb.subset_selected = "10"b /* pure selection */ then do; code = error_table_$no_record; go to unlock_exit; end; call initialize_substate; call save_min_blksz_inf; new_record_length = max (buff_len, 0); call set_add_ent_info ("1"b); /* prepare to add key and rec */ file_base.old_ref_count = 1; /* initial ref count will be for key entered with record, if -stat */ file_action = insert_action; if (file_base.new_record_length > 0) | file_base.was_stat | (indx_cb.min_cap > 0) | (indx_cb.min_res > 0) then do; /* allocate space for record and copy buffer */ call change_record_list (iocb_ptr, insert_action, buff_ptr, abort_exit); if file_base.was_transaction /* creating record in a transaction */ then do; /* mask presence to others until checkpoint */ indx_cb.current_descrip = file_base.new_descriptor; call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 0); /* also creates refl entry */ end; /* only my transaction will see this record */ end; else new_descriptor = 0; file_base.change_count = file_base.old_file_ch_count + 1; call set_new_record_designator; call change_index (iocb_ptr, abort_exit); pos_ptr = file_position_ptr; call set_post_write_pos; go to switch_file_state; /* end of write routine */ check_buff_len: proc; /* sets code non-zero if buffer is too big */ if buff_len > indx_cb.max_record_size then do; code = error_table_$long_record; go to unlock_exit; end; end check_buff_len; set_post_write_pos: proc; /* also used by record_status when creating with locate_sw clear */ indx_cb.current_record_is_valid = "1"b; indx_cb.at_bof, indx_cb.at_eof = "0"b; indx_cb.ready_to_write = dup_ok; indx_cb.skip_state = 0; if is_sequential_open then indx_cb.next_record_position = 2; else do; indx_cb.next_record_position = 0; indx_cb.saved_descrip = file_base.new_descriptor; /* save now because save correct pos logic won't handle next_rec_pos=0 case */ end; end set_post_write_pos; set_add_ent_info: proc (add_rec_sw); /* routine prepares for adding index entry and record if add_rec_sw="1"b */ is_ptr = indx_cb.index_state_ptr; if repeating /* recovery in progress */ then do; call check_file_substate; return; end; file_base.new_desc_val = 0; /* used by change_index */ file_base.saved_ks_out = indx_cb.is_ks_out; /* in case of crash */ if ^add_rec_sw /* add_key operation */ then do; /* will not create record */ if (block_ptr = null) then file_base.was_stat = "0"b; else if block_ptr -> record_block.stationary then do; file_base.was_stat = "1"b; file_base.new_ref_count = ref_cnt; end; else file_base.was_stat = "0"b; if ak_inf.input_key /* get new key from info structure */ then do; call prepare_key (ak_info_key); new_key_len = ak_inf.key_len; end; else call prepare_key_for_insertion; new_record_designator = indx_cb.current_descrip; file_base.new_descriptor = new_record_designator; end; else do; /* prepare for write_record or record_status(**10) */ file_base.was_stat = indx_cb.stat; /* -stat option used--default record type is stationary */ call check_key_for_insertion; call prepare_key_for_insertion; call set_add_rec_stats; end; os_ptr -> number_of_keys = number_of_keys + 1; os_ptr -> total_key_length = total_key_length + new_key_len; if key_is_dup then do; /* change duplicate key stats */ os_ptr -> duplicate_keys = duplicate_keys + 1; os_ptr -> dup_key_bytes = dup_key_bytes + new_key_len; call find_rightmost_descendent; /* sets pos properly in case at non-leaf entry */ end; change_position_ptr = pos_ptr; change_node = node; call save_position_info; new_branch = 0; index_action = insert_action; file_substate = file_substate + 1; return; /* end of main routine for set_add_ent_info */ prepare_key_for_insertion: proc; key_is_dup = indx_cb.current_record_is_valid; if key_is_dup then do; new_key_len = get_key_length (); /* length of current key */ new_key_length = key_length (branch_num); substr (new_key_string, 1, new_key_length) = substr (keys, key_pos (branch_num), key_length (branch_num)); /* set up key for insertion */ if ^add_rec_sw /* add_key operation */ then do; indx_cb.saved_descrip = record_designator (branch_num); /* remember current descriptor */ pos_incorrect = "1"b; end; call find_next_key; /* advance position beyond last dup key */ end; else do; call prepare_key (indx_cb.new_key); /* key for insertion */ new_key_len = length (indx_cb.new_key); end; end prepare_key_for_insertion; dcl new_key_len fixed; dcl add_rec_sw bit (1) aligned; end set_add_ent_info; check_key_for_insertion: proc; /* makes sure current key is defined */ do while ("1"b); /* may loop once */ if ^indx_cb.ready_to_write then if dup_ok & ^is_ks_out /* may be ready to write anyway */ then do; call check_current; /* sets code to zero if current really exists */ if code ^= 0 /* really is no key for insertion */ then do; /* forget the whole thing */ no_key: code = error_table_$no_key; /* set proper code */ go to verify_done; end; end; else go to no_key; if pos_incorrect then do; call restore_position; if code ^= 0 then go to verify_done; end; else do; pos_ptr = indx_cb.file_position_ptr; return; end; end; end check_key_for_insertion; find_next_key: proc; /* routine used to advance pos beyond set of dup keys */ init_key_len = key_length (branch_num); init_key_ptr = addr (node_ptr -> bytes (key_pos (branch_num))); /* keep track of prev key */ do while ("1"b); branch_num = branch_num + 1; call find_this_entry; /* takes care of exceptional cases */ if pos_ptr = root_position_ptr /* at eof */ then return; if substr (keys, key_pos (branch_num), key_length (branch_num)) ^= init_key_ptr -> initial_key /* key no longer matches */ then return; /* found different key--done */ end; dcl init_key_len fixed; dcl init_key_ptr ptr; dcl initial_key char (init_key_len) based (init_key_ptr); dcl bytes (1:4096) char (1) based; end find_next_key; set_new_record_designator: proc; if repeating then do; call check_file_substate; return; end; new_record_designator = new_descriptor; file_substate = file_substate + 1; end set_new_record_designator; delete_indx_file: entry (iocb_ptr, code); /* ref7 */ current_retry_loc = del_retry; go to init_up_down; retry_loc (14): del_cur = "1"b; call check_current; if code ^= 0 then go to verify_done; /* file may not be locked yet */ indx_cb.is_read_only = "1"b; /* to suppress recursive cleanup attempt */ call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 0); /* must restore read_only status if abort is made */ indx_cb.is_read_only = "0"b; if code ^= 0 then if code = error_table_$no_record & (block_ptr ^= null) then ; /* collect a garbage item--leave non-zero code as warning */ else if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset) then go to unlock_exit; /* abort */ call delete_entry ("1"b); /* delete index entry and current record */ return; adjust_record: entry (iocb_ptr, descrip_arg, modifier_arg, code); /* used by transaction_call_ to unlock a record */ current_retry_loc = adj_retry; go to init_down_up; retry_loc (15): call initialize_substate; /* prepare for file modification */ file_base.old_record_designator = descrip_arg; block_ptr = get_pointer (descrip_arg); lock_ptr = addr (block_ptr -> stat_struct.record_lock); i_locked_rec = "1"b; if indx_cb.repeating then do; rollback_sw = (file_action = rollback_action); if file_base.was_ind & (file_base.old_ind_desc > 0) then p = get_pointer (file_base.old_ind_desc); /* be sure initiated */ end; else do; if (block_ptr -> stat_struct.modifier <= 0) then go to unlock_exit; if ^(lock_ptr -> based_lock = indx_cb.saved_lock_copy) then go to unlock_exit; /* already adjusted */ if modifier_arg = block_ptr -> stat_struct.prev_mod then rollback_sw = "1"b; /* adjust to before image */ else if modifier_arg = block_ptr -> stat_struct.modifier then do; rollback_sw = "0"b; /* adjust to after image */ if block_ptr -> stat_struct.prev_mod = -3 /* pre-created record which previous to this transaction did not exist */ then do; /* use null before image */ record_len = 0; /* used only in following protected procedure */ ind_desc = -1; end; else if block_ptr -> record_block.indirect/* separate allocation of before */ then do; ind_desc = ind_struct.prev_desc; /* before image */ if ind_struct.prev_desc <= 0 /* no allocation--special case */ then record_len = 0; else record_len = length (get_pointer (ind_desc) -> record_block.record); end; else do; ind_desc = descrip_arg; record_len = length (stat_struct.record); /* compact case */ end; end; else rollback_sw = "1"b; /* roll back by default */ file_base.old_ref_count = block_ptr -> stat_struct.ref_count; end; if ^rollback_sw /* checkpoint case */ then do; /* retain after and discard before image */ call save_old_record_length; /* saves before-image info */ ind_des.comp = stat_struct.ind_comp; ind_des.offset = time_stamp_struct.ind_offset; call set_after_image_info; if file_base.old_prev_mod = -3 /* new record created this trans */ then os_ptr -> number_of_records = number_of_records + 1; else os_ptr -> number_of_records = number_of_records; /* note that this is only nec because of recovery */ if ind_desc = -1 /* deletion case */ then os_ptr -> number_of_records = os_ptr -> number_of_records - 1; os_ptr -> total_record_length = total_record_length + file_base.new_record_length - file_base.old_record_length; file_action = adjust_action; file_base.change_count = file_base.old_file_ch_count + 1; block_ptr -> stat_struct.ref_count = block_ptr -> stat_struct.ref_count_after; if ind_desc = -2 /* no change to the record image */ then do; block_ptr -> stat_struct.modifier = -1; /* allow unlocking */ file_action = o_s_ptr -> file_action; /* fast state switch */ go to unlock_exit; /* don't change time stamp */ end; if file_base.was_ind then do; time_stamp_struct.time_last_modified = clock (); ind_struct.prev_mod = file_base.old_modifier; ind_struct.prev_desc = file_base.after_desc; if file_base.old_ind_desc > 0 then do; file_base.new_descriptor = file_base.old_ind_desc; /* block to be freed */ call change_record_list (iocb_ptr, free_action, null, abort_exit); end; end; else if file_base.old_prev_mod ^= -3 /* old record */ then do; /* overrite tail or convert into an indirect record */ file_base.new_descriptor = file_base.after_desc; /* after image descriptor */ file_base.was_transaction = "0"b; call change_record_list (iocb_ptr, replace_action, null, abort_exit); /* tries to overrite in place if room */ end; else do; time_stamp_struct.time_last_modified = clock (); stat_struct.prev_mod = file_base.old_modifier; end; end; /* end of forward adjustment logic */ else do; /* rollback case */ ind_des.comp = stat_struct.ind_comp; /* after image info */ ind_des.offset = time_stamp_struct.ind_offset; call save_old_record_length; /* protected procedure for recovery */ file_base.new_descriptor = file_base.old_ind_desc; /* block to free */ file_base.was_transaction = "1"b; file_action = rollback_action; /* can't stop this operation now */ file_base.change_count = file_base.old_file_ch_count + 1; /* must bump since file's substate will be switched */ if file_base.old_prev_mod = -3 then do; if file_base.old_ref_count <= 0 then do; file_base.out_of_index = "1"b; /* not deleting key */ call change_record_list (iocb_ptr, delete_action, null, abort_exit); os_ptr -> number_of_allocated_records = number_of_allocated_records; i_locked_rec = "0"b; /* suppress unlocking */ go to switch_file_state; end; else do; if ^file_base.was_ind then do; file_base.new_descriptor = -1; call change_record_list (iocb_ptr, replace_action, null, abort_exit); /* leave only a logically deleted indirect header */ end; else do; if file_base.old_ind_desc > 0 then call change_record_list (iocb_ptr, free_action, null, abort_exit); ind_struct.prev_desc = -1; end; stat_struct.prev_mod = 0; end; end; else if file_base.old_ind_desc > 0 /* allocation exists */ then call change_record_list (iocb_ptr, free_action, null, abort_exit); end; os_ptr -> number_of_allocated_records = number_of_allocated_records; block_ptr -> stat_struct.modifier = -1; /* allow unlocking now */ go to switch_file_state; /* end of adjust_record logic */ adjust_file: entry (iocb_ptr, code); /* called if file found locked by dead process in passive file lock checking */ current_retry_loc = adj_file_retry; go to init_down_up; /* tries to lock the file */ retry_loc (25): go to unlock_exit; /* that's all there is to it */ set_after_image_info: proc; if indx_cb.repeating /* recovery in progress */ then do; if file_base.after_desc > 0 then p = get_pointer (file_base.after_desc); call check_file_substate; return; /* skip protected body of procedure */ end; file_base.after_desc = ind_desc; if ind_desc <= 0 then file_base.new_record_length = 0; else if (block_ptr -> stat_struct.prev_mod = -3) & ^block_ptr -> record_block.indirect /* new compact */ then file_base.new_record_length = length (stat_struct.record); else file_base.new_record_length = length (get_pointer (ind_desc) -> record_block.record); file_substate = file_substate + 1; /* mark completion of this step */ end set_after_image_info; delete_entry: proc (del_rec_sw); /* routine to delete index entry and rec if switch set */ call initialize_substate; file_base.out_of_index = indx_cb.outside_index; /* in case of crash */ call set_del_ent_info; if del_cur then if is_sequential_open then do; indx_cb.skip_state = 0; /* scanning of deletions is forward */ indx_cb.next_record_position = 1; end; else indx_cb.next_record_position = 0; if del_rec_sw /* delete_record operation */ then do; file_action = delete_action; if del_cur /* not delete_key case */ then do; indx_cb.current_record_is_valid = "0"b; /* in case at eof or direct opening */ indx_cb.ready_to_write = "0"b; /* may actually be ready if current exists */ end; else if saved_state.current_record_is_valid then indx_cb.current_descrip = saved_state.current_descrip; else indx_cb.current_descrip = indx_cb.saved_descrip; file_base.change_count = file_base.old_file_ch_count + 1; if file_base.was_stat then do; /* delete a stationary record */ if file_base.old_modifier > 0 /* TP case */ then do; file_base.new_descriptor = -1; if file_base.old_ind_desc > 0 /* non-null after image */ then call change_record_list (iocb_ptr, replace_action, null, abort_exit); /* discard indirect after image allocation */ indx_cb.outside_index = "0"b; if indx_cb.next_record_position = 1 then indx_cb.next_record_position = 2; /* skip over this key */ go to switch_file_state; /* nothing more to do until checkpoint */ end; call change_record_list (iocb_ptr, delete_action, null, abort_exit); if indx_cb.outside_index then do; indx_cb.outside_index = "0"b; go to switch_file_state; end; if file_base.is_partial_deletion then do; if indx_cb.next_record_position = 1 then indx_cb.next_record_position = 2; go to switch_file_state; /* don't delete last key */ end; if ^del_cur /* delete_key case */ then indx_cb.outside_index = saved_state.outside_index; end; else do; if old_record_designator ^= 0 then call change_record_list (iocb_ptr, delete_action, (null), abort_exit); if indx_cb.outside_index /* no key to delete */ then do; indx_cb.outside_index = "0"b; go to switch_file_state; /* just deleted the current record */ end; end; end; else do; /* operation is delete_key */ file_action = deleting_key; /* all info necessary for recovery is saved */ if del_cur /* key to delete is at the current file position */ & ^indx_cb.outside_index /* deleting key of current record */ then call make_current (old_record_designator); /* current pos moves out of index */ else if saved_state.current_record_is_valid then indx_cb.current_descrip = saved_state.current_descrip; else indx_cb.current_descrip = indx_cb.saved_descrip; file_base.change_count = file_base.old_file_ch_count + 1; if file_base.was_stat then do; block_ptr -> stat_struct.ref_count_after = file_base.old_ref_count; block_ptr -> stat_struct.ref_count = file_base.old_ref_count; end; end; if new_desc_val ^= 0 /* non-leaf node */ then do; /* replace key with highest preceding one */ call replace_non_leaf_key; call reset_change_position; if is_sequential_open & del_cur then indx_cb.next_record_position = 2; end; call change_index (iocb_ptr, abort_exit); /* deletes the key */ pos_ptr = file_position_ptr; if new_desc_val ^= 0 then if del_cur /* pos belongs upstairs */ then call find_from_leaf; /* climbs up tree */ go to switch_file_state; /* end of delete routine */ set_del_ent_info: proc; /* saves vars necessary for deletion */ is_ptr = indx_cb.index_state_ptr; if repeating then do; i_locked_rec = (file_action ^= delete_action) | ((file_action = delete_action) & file_base.was_stat & (file_base.is_partial_deletion | (file_base.old_modifier > 0) | (file_base.old_ref_count > fixed (^file_base.out_of_index)))); call check_file_substate; return; end; file_base.old_record_designator = indx_cb.current_descrip; if del_rec_sw /* delete_record operation */ then do; /* prepare to remove old record */ call save_stat_info; /* save more info if record is stationary */ file_base.is_partial_deletion = "0"b; if file_base.was_stat /* stationary record case */ then do; stat_struct.ind_comp = -1; time_stamp_struct.ind_offset = (18)"1"b; /* -1 */ file_base.old_ref_count = ref_cnt; if file_base.old_modifier > 0 /* won't alter index at this time */ then go to bump_substate; /* no more info to save for recoverability */ if indx_cb.shared then if ^indx_cb.outside_index /* key exists */ then if ref_cnt <= 1 /* at last reference */ then if time_stamp + indx_cb.collection_delay_time > clock () then file_base.is_partial_deletion = "1"b; else i_locked_rec, i_set_negmod = "0"b; /* suppress unlocking */ else ; /* will unlock record when done */ else if ref_cnt <= 0 /* no more refs--can collect */ then i_locked_rec, i_set_negmod = "0"b; /* block will be zeroed */ else ; /* won't collect entire block--unlock */ else if ref_cnt <= fixed (^indx_cb.outside_index) then i_locked_rec, i_set_negmod = "0"b; end; else i_locked_rec = "0"b; /* always collect storage completely */ if ^rec_deleted /* statistics must be adjusted */ then os_ptr -> number_of_records = number_of_records - 1; os_ptr -> total_record_length = total_record_length - record_len; if file_base.is_partial_deletion | indx_cb.outside_index then go to bump_substate; end; else if (block_ptr = null) then file_base.was_stat = "0"b; else if block_ptr -> record_block.stationary then do; file_base.was_stat = "1"b; file_base.old_ref_count = ref_cnt; end; else file_base.was_stat = "0"b; os_ptr -> number_of_keys = number_of_keys - 1; os_ptr -> total_key_length = total_key_length - get_key_length (); change_position_ptr = pos_ptr; change_node = node; file_base.new_desc_val = branch (branch_num + 1); if dup_ok then if deleting_dup () then do; /* duplicate key stats must change */ os_ptr -> duplicate_keys = duplicate_keys - 1; os_ptr -> dup_key_bytes = dup_key_bytes - get_key_length (); end; if new_desc_val ^= 0 /* non-leaf node */ then do; /* prepare to delete preceding key */ call find_rightmost_descendent; branch_num = branch_num - 1; call prepare_key (substr (keys, key_pos (branch_num), key_length (branch_num))); new_record_designator = record_designator (branch_num); index_action = replace_action; /* first replace key with copy of predecessor */ end; else index_action = delete_action; call save_position_info; /* remember index location */ bump_substate: file_substate = file_substate + 1; end set_del_ent_info; deleting_dup: proc returns (bit (1) aligned); /* routine checks whether key to delete is a duplicate */ change_branch = branch_num; /* remember current branch num */ return (next_is_dup () | prev_is_dup ()); /* compares key with neighbors */ next_is_dup: proc returns (bit (1) aligned); /* sees if next key matches current */ branch_num = branch_num + 1; /* advance position */ call find_this_entry; /* in case non-leaf or at last branch */ new_branch_num = branch_num; set_result: if pos_ptr = root_position_ptr /* end of file */ then keys_match = "0"b; /* no prev or next key exists */ else if ( substr (change_position_ptr -> node_ptr -> keys, change_position_ptr -> node_ptr -> key_pos (change_branch), change_position_ptr -> node_ptr -> key_length (change_branch)) = substr (keys, key_pos (branch_num), key_length (branch_num))) then keys_match = "1"b; else keys_match = "0"b; branch_num = new_branch_num; /* in case checking prev of first in node */ pos_ptr = change_position_ptr; /* restore file position */ file_position_ptr = pos_ptr; branch_num = change_branch; return (keys_match); /* return result */ prev_is_dup: entry returns (bit (1) aligned); /* sees if preceding key matches current */ call find_prev_entry; /* in case non-leaf or at first branch */ new_branch_num = branch_num; /* in case this node is parent */ branch_num = branch_num - 1; /* does the backspace */ go to set_result; /* finish up */ end next_is_dup; dcl keys_match bit (1) aligned; dcl new_branch_num fixed (35); dcl change_branch fixed (35); end deleting_dup; dcl del_rec_sw bit (1) aligned; end delete_entry; replace_non_leaf_key: proc; if repeating then do; next_substate = next_substate + 1; /* file_substate is bumped by change_index */ call check_file_substate; if file_substate >= next_substate then return; end; call change_index (iocb_ptr, abort_exit); pos_ptr = file_position_ptr; file_substate = file_substate + 1; end replace_non_leaf_key; reset_change_position: proc; is_ptr = indx_cb.index_state_ptr; if repeating then do; call check_file_substate; return; end; change_position_ptr = pos_ptr; change_node = node; index_action = delete_action; file_substate = file_substate + 1; end reset_change_position; save_position_info: proc; /* saves process variables required for recovery mechanism */ current_node = node; p = root_position_ptr; do i = 1 to index_height; p = p -> son_position_ptr; saved_node (i) = p -> node; saved_branch_num (i) = p -> branch_num; end; dcl i fixed; dcl p ptr; end save_position_info; add_key: /* routine adds specified key to current record */ if indx_cb.mode = 7 /* unkeyed update opening */ then do; /* abort */ code = error_table_$no_operation; go to exit; end; current_retry_loc = ak_retry; go to init_up_down; retry_loc (16): saved_state.current_record_is_valid = indx_cb.current_record_is_valid; saved_state.current_descrip = indx_cb.current_descrip; if ak_inf.input_key /* get new key from info structure */ then do; if ^ak_inf.input_desc /* using current record's descrip */ then do; call check_current; /* checks if current rec is not defined */ if code ^= 0 /* error */ then go to verify_done; /* abort or retry */ if ^indx_cb.shared | ^saved_state.current_record_is_valid then call save_correct_pos; end; else if ^indx_cb.shared then call save_correct_pos; pos_incorrect = "1"b; /* index position will not be current pos */ file_position_ptr = root_position_ptr; /* start search from root */ if ^is_ks_out /* update opening */ then do; call find_key$last (indx_cb_ptr, (addr (ak_info_key)), search_code); /* look for key */ pos_ptr = file_position_ptr; if search_code = 0 /* key not found */ then key_is_dup = "0"b; /* not a duplication */ else do; /* key already exists--set position properly */ key_is_dup = "1"b; call find_from_leaf; /* in case match was non-leaf */ /* call find_next_key; /* advance to beyond last duplication, */ end; end; else do; /* verify key order */ pos_ptr = indx_cb.file_position_ptr; call find_rightmost_descendent; /* position to end of file */ call compare_last_key (ak_info_key); /* test key order */ if code ^= 0 /* key not larger than last in file */ then if ^key_is_dup /* error--key out of order */ then go to verify_done; else code = 0; /* may be permitted */ end; if key_is_dup & ^dup_ok /* illegal key duplication */ then do; /* abort */ code = error_table_$key_duplication; go to verify_done; end; end; else if ^indx_cb.repeating then do; if ak_inf.input_desc then do; call check_current; if code ^= 0 then go to verify_done; end; call check_key_for_insertion; end; if ak_inf.input_desc /* descriptor in info structure */ then indx_cb.current_descrip = ak_inf.descrip; if indx_cb.stat /* record must be adjusted in this case */ then do; call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 1); /* bump the ref count */ if code ^= 0 then if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset) /* fatal */ then do; if saved_state.current_record_is_valid then indx_cb.current_descrip = saved_state.current_descrip; else indx_cb.current_descrip = indx_cb.saved_descrip; go to verify_done; end; else code = 0; end; else block_ptr = null; /* won't have to unlock the record */ call initialize_substate; call set_add_ent_info ("0"b); /* just add key, no record */ if saved_state.current_record_is_valid then indx_cb.current_descrip = saved_state.current_descrip; else indx_cb.current_descrip = indx_cb.saved_descrip; file_action = adding_key; /* no turning back now */ file_base.change_count = file_base.old_file_ch_count + 1; if file_base.was_stat then do; block_ptr -> stat_struct.ref_count_after = file_base.new_ref_count; block_ptr -> stat_struct.ref_count = file_base.new_ref_count; end; call change_index (iocb_ptr, abort_exit); /* inserts the new key */ pos_ptr = file_position_ptr; go to switch_file_state; /* end of add_key routine */ delete_key: /* contains logic for the delete_key control order */ call verify_keyed_update; /* check opening mode */ current_retry_loc = dk_retry; go to init_up_down; retry_loc (17): saved_state.current_record_is_valid = indx_cb.current_record_is_valid; saved_state.current_descrip = indx_cb.current_descrip; if info_ptr = null /* delete current entry for current rec */ then do; if indx_cb.outside_index /* no key is associated with current record */ then code = error_table_$no_key; else call check_current; /* sets code */ if code ^= 0 /* error has occurred--abort */ then go to verify_done; del_cur = "1"b; /* indicates deleted entry is at current file position */ end; else if ak_inf.input_key /* use key in info structure */ then do; if ^ak_inf.input_desc then do; /* use current record's descriptor */ call check_current; if code ^= 0 then go to verify_done; /* error */ if ^indx_cb.shared | ^saved_state.current_record_is_valid /* may not have saved current descriptor */ then call save_correct_pos; /* don't lose your place */ end; else do; if ^indx_cb.shared then call save_correct_pos; indx_cb.current_descrip = ak_inf.descrip; /* temporarily call this the current descriptor */ end; if ^indx_cb.at_bof & ^indx_cb.at_eof & ((indx_cb.next_record_position ^= 0) | (indx_cb.current_record_is_valid & ^indx_cb.outside_index)) & (indx_cb.current_descrip = indx_cb.saved_descrip) & (ak_info_key = indx_cb.new_key) then do; del_cur = "1"b; if indx_cb.pos_incorrect then go to find_input_key; else first_code, search_code = 1; /* fake successful finding--already there */ end; else do; del_cur = "0"b; indx_cb.pos_incorrect = "1"b; find_input_key: call find_entry (ak_info_key, indx_cb.current_descrip); /* look for old entry */ end; check_codes: if first_code = 0 /* key not found--error */ then code = error_table_$no_key; else if search_code = 0 /* old descrip not found--error */ then code = error_table_$no_record; if code ^= 0 /* error has occurred */ then do; if saved_state.current_record_is_valid then indx_cb.current_descrip = saved_state.current_descrip; else indx_cb.current_descrip = indx_cb.saved_descrip; go to verify_done; end; if del_cur /* deleting current_key */ then indx_cb.pos_incorrect = "0"b; /* save new current key */ end; else if indx_cb.outside_index /* no key for insertion */ then do; /* signal error */ code = error_table_$no_key; go to verify_done; end; else do; call check_current; /* need current record's key */ if code ^= 0 /* error */ then do; if ak_inf.input_desc & (code = error_table_$no_record) then code = error_table_$no_key; go to verify_done; end; if ^ak_inf.input_desc /* current key of current record */ then del_cur = "1"b; else do; if ^indx_cb.shared | ^saved_state.current_record_is_valid then call save_correct_pos; indx_cb.current_descrip = ak_inf.descrip; if indx_cb.current_descrip = indx_cb.saved_descrip then do; del_cur = "1"b; if indx_cb.pos_incorrect then go to find_cur_key; end; else do; del_cur = "0"b; indx_cb.pos_incorrect = "1"b; find_cur_key: call find_entry (indx_cb.new_key, indx_cb.current_descrip); go to check_codes; end; end; end; if indx_cb.stat then do; /* the ref count must be decremented */ indx_cb.is_read_only = "1"b; /* suppress recursive garbage collection */ call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, -1); /* decrement the ref count */ indx_cb.is_read_only = "0"b; /* restore opening state properly */ if code ^= 0 then if (code = error_table_$no_record) & (block_ptr ^= null) then do; /* handle logically deleted record */ if (ref_cnt <= 0) & (block_ptr -> stat_struct.modifier <= 0) then do; /* setup delete_record case */ saved_state.outside_index = indx_cb.outside_index; indx_cb.outside_index = "0"b; /* signal remove key with record */ ref_cnt = ref_cnt + 1; /* undo decrementing, not done by delete_record */ call delete_entry ("1"b); return; /* not supposed to get here */ end; end; else if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset) then do; if saved_state.current_record_is_valid then indx_cb.current_descrip = saved_state.current_descrip; else indx_cb.current_descrip = indx_cb.saved_descrip; go to verify_done; end; else code = 0; end; else block_ptr = null; /* don't unlock record */ call delete_entry ("0"b); /* don't delete the record, just the key */ return; /* end of delete_key */ verify_keyed_update: proc; /* makes sure opening is valid for delete_key or reassign_key */ if (mode ^= 10) & (mode ^= 13) /* not a valid mode */ then do; /* set error code and abort */ code = error_table_$no_operation; go to exit; end; end verify_keyed_update; select: /* selects specified subset of records in the file */ flag = select_flag; if ^common_sl_info.status_only /* current subset will be reset or changed */ then if common_sl_info.list_type = 0 /* no list specification--reselect given subset */ then do; if (common_sl_info.subset_no < 0) | (common_sl_info.subset_no > indx_cb.last_subset) then do; bad_arg: code = error_table_$bad_arg; /* invalid subset number */ go to exit; /* abort */ end; indx_cb.current_subset = common_sl_info.subset_no; if indx_cb.current_subset = 0 /* the identity subset */ then do; indx_cb.subset_selected = "00"b; /* convention means default subset */ if common_sl_info.output_descriptors /* must do more work */ then go to generate_subset; end; else indx_cb.subset_selected = "10"b; call count_subset; end; else go to generate_subset; else if common_sl_info.output_descriptors & (indx_cb.subset_selected = "00"b) then go to generate_subset; call get_subset_status; return; /* end of select routine */ exclude: /* creates temporary exclude list or removes entries from current subset */ flag = exclude_flag; if common_sl_info.list_type = 0 /* reset to previous subset */ then if (common_sl_info.subset_no <= 0) | (common_sl_info.subset_no > indx_cb.last_subset) then go to bad_arg; else do; indx_cb.current_subset = common_sl_info.subset_no; indx_cb.subset_selected = "01"b; /* pure exclusion */ call count_subset; /* return subset count to user */ end; else go to generate_subset; call get_subset_status; return; /* end of exclude routine */ get_subset_status: proc; /* returns subset info into common_sl_info structure */ if indx_cb.subset_selected = "00"b /* nothing excluded or explicitly selected */ then do; if ^(common_sl_info.status_only & common_sl_info.output_descriptors) then do; /* trust number of allocations as the count */ f_b_ptr = indx_cb.file_base_ptr; indx_cb.subset_count = addr (file_state_blocks (file_base.file_state)) -> number_of_allocated_records; end; common_sl_info.subset_no = 0; end; else if indx_cb.subset_selected = "10"b /* pure selection */ then common_sl_info.subset_no = indx_cb.current_subset; else common_sl_info.subset_no = -1 * indx_cb.current_subset; /* pure exclusion */ common_sl_info.count = indx_cb.subset_count; /* count of items in temporary file for this subset */ if common_sl_info.output_descriptors & ^(indx_cb.subset_selected = "00"b & flag = select_flag) then do; if common_sl_info.desc_arrayp = null & common_sl_info.count > 0 /* wants me to make allocation */ then do; if system_freep = null /* first time this process */ then system_freep = get_system_free_area_ (); allocate desc_array in (system_freep -> based_area) set (common_sl_info.desc_arrayp); end; call list_subset; end; end get_subset_status; count_subset: proc; /* sets subset_count for current subset */ if indx_cb.subset_selected = "00"b then do; /* treat identity subset as a special case */ f_b_ptr = indx_cb.file_base_ptr; indx_cb.subset_count = addr (file_state_blocks (file_base.file_state)) -> number_of_allocated_records; return; end; count = 0; unspec (zero_word_bytes) = "0"b; subset_key = current_subset_bytes || zero_word_bytes; /* head for desired portion of temp index */ indx_cb_ptr = indx_cb.temp_iocbp -> iocb.open_data_ptr; call seek_head (1, addr (subset_key), 8); /* position to start of range in temp file */ do while (pos_ptr ^= root_position_ptr); /* loop steps until beyond current subset's range */ if substr (subset_key, 1, 4) = substr (keys, key_pos (branch_num), 4) /* in current subset */ then do; count = count + 1; branch_num = branch_num + 1; call find_this_entry; /* in case last branch in node or non-leaf */ end; else pos_ptr = root_position_ptr; /* force exit from loop */ end; indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; pos_ptr = indx_cb.file_position_ptr; indx_cb.subset_count = count; return; /* end of count_subset logic */ list_subset: entry; /* fills descriptor array with entries for current subset */ unspec (zero_word_bytes) = "0"b; subset_key = current_subset_bytes || zero_word_bytes; count = indx_cb.subset_count; i = 0; indx_cb_ptr = indx_cb.temp_iocbp -> iocb.open_data_ptr; call seek_head (1, addr (subset_key), 8); /* find start of current subset in temp file */ do while ((i < count) & (pos_ptr ^= root_position_ptr)); i = i + 1; common_sl_info.desc_arrayp -> desc_array_bytes (i) = substr (keys, key_pos (branch_num) + 4, 4); /* descriptor in lower word of temp key */ branch_num = branch_num + 1; /* advance to next */ call find_this_entry; /* handles exceptions */ end; indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; /* restore stuff for current file */ pos_ptr = indx_cb.file_position_ptr; indx_cb.subset_count = i; common_sl_info.count = i; /* in case count was wrong */ return; /* end of list_subset logic */ dcl subset_key char (8) var; dcl desc_array_bytes (1:common_sl_info.count) char (4) based (common_sl_info.desc_arrayp); dcl current_subset_bytes char (4) based (addr (indx_cb.current_subset)); dcl zero_word_bytes char (4) aligned; dcl count fixed; dcl i fixed; end count_subset; generate_subset: /* flag indicates whether select or exclude */ if common_sl_info.list_type > max_list_type then go to bad_arg; else do; if flag = select_flag then next_subset = indx_cb.last_subset + 1; /* select creates a new subset */ else if indx_cb.subset_selected = "00"b then next_subset = indx_cb.last_subset + 1; else next_subset = indx_cb.current_subset; /* modify current subset */ if indx_cb.temp_iocbp = null /* have not yet used temp switch */ then call get_temp_switch; else if common_sl_info.delete_old_subsets then if indx_cb.current_subset = 0 then call delete_old_subsets (indx_cb.temp_iocbp); else do; code = error_table_$bad_arg; return; end; count = 0; /* will accumulate total count of descriptors */ temp_ak_inf.flags = "11"b; temp_ak_inf.descriptor = 0; temp_ak_inf.key_len = 8; if (common_sl_info.list_type = 1) | (common_sl_info.status_only) /* array of intervals */ then do; current_retry_loc = init_retry; saved_subset_selected = indx_cb.subset_selected; saved_current_subset = indx_cb.current_subset; go to initialize; retry_loc (18): call save_correct_pos; /* in order to restore initial position */ indx_cb.pos_incorrect = "1"b; if common_sl_info.status_only then n_int = 1; else n_int = common_sl_info.array_limit; pad_key_ptr = addr (gk_pad_key); last_info_ptr = addr (last_info_block (0)); last_info.new_last_info_ptr = addr (last_info_block (1)); new_last_info.new_last_info_ptr = last_info_ptr; do i = 1 to n_int; /* for each interval accumulate descriptors */ current_retry_loc = outer_retry; outer_loop: if common_sl_info.status_only then do; last_head = ""; call position_bof; if last_branch_num = 1 /* file is empty */ then go to next_interval; end; else do; if ((hi_sl_info.last_head.length (i) < 0) & (hi_sl_info.first_head.kptr (i) = hi_sl_info.last_head.kptr (i))) /* else exact match required */ then head_spec = "0"b; else head_spec = "1"b; if head_spec /* interval defined in terms of first and last head */ then do; pad_key_len = 256; /* must pad with zeroes for valid seek_head */ unspec ( substr (pad_key, hi_sl_info.first_head.length (i) + 1, 256 - hi_sl_info.first_head.length (i))) = "0"b; /* pad with zeroes */ substr (pad_key, 1, hi_sl_info.first_head.length (i)) = substr (hi_sl_info.first_head.kptr (i) -> bstring, 1, hi_sl_info.first_head.length (i)); call seek_head (1, addr (pad_key_info), hi_sl_info.first_head.length (i)); if pos_ptr = indx_cb.root_position_ptr /* head not found */ then go to next_interval; last_head = substr (hi_sl_info.last_head.kptr (i) -> bstring, 1, abs (hi_sl_info.last_head.length (i))); if (hi_sl_info.last_head.length (i) < 0) then open_ended = "1"b; else open_ended = "0"b; end; else do; /* force exact match with given key */ open_ended = "0"b; vpad_key = substr (hi_sl_info.first_head.kptr (i) -> bstring, 1, hi_sl_info.first_head.length (i)); file_position_ptr = root_position_ptr; /* prepare for descent */ call find_key (indx_cb_ptr, (addr (vpad_key)), search_code); pos_ptr = file_position_ptr; if search_code = 0 /* not found */ then go to next_interval; call find_from_leaf; /* in case match in upper node */ last_head_len = 256; substr (last_head, 1, length (vpad_key)) = vpad_key; substr (last_head, length (vpad_key) + 1, 256 - length (vpad_key)) = substr (blanks, 1, 256 - length (vpad_key)); end; end; last_key = substr (keys, key_pos (branch_num), key_length (branch_num)); last_descrip = record_designator (branch_num); inner_loop: do while (substr (last_key, 1, min (length (last_head), length (last_key))) <= last_head); /* pick up each index entry in this interval */ if substr (last_key, 1, min (length (last_head), length (last_key))) = last_head /* exact match of head */ then if open_ended then go to next_interval; /* done with this interval */ if indx_cb.shared & ^indx_cb.leave_locked /* may have undergone asynch changes */ then if file_base.change_count ^= indx_cb.last_change_count /* has changed */ then do; call note_last_subset; call prepare_process; if current_retry_loc ^= inner_retry then go to retry_loc (current_retry_loc); retry_loc (19): call find_entry (last_key, last_descrip); if search_code = 0 /* prev entry not found */ then do; /* abort--can't find previous position */ call note_last_subset; code = error_table_$asynch_deletion; go to verify_done; /* may retry again if another asynch change */ end; go to inner_loop; /* resume inner loop scan from last position */ end; else current_retry_loc = inner_retry; if indx_cb.subset_selected ^= "00"b then do; call check_subset (last_descrip); if rec_deleted /* this descriptor has been masked */ then go to next_entry; /* just skip to next */ end; temp_key_words (1) = next_subset; temp_key_words (2) = last_descrip; call enter_temp_key; next_entry: branch_num = branch_num + 1; call find_this_entry; new_last_key = substr (keys, key_pos (branch_num), key_length (branch_num)); new_last_descrip = record_designator (branch_num); last_info_ptr = last_info.new_last_info_ptr; if pos_ptr = root_position_ptr /* at eof */ then go to next_interval; /* done with this interval */ end; next_interval: if indx_cb.shared & ^indx_cb.leave_locked then if indx_cb.last_change_count ^= file_base.change_count then do; if current_retry_loc ^= outer_retry then go to retry_loc (current_retry_loc); retry_loc (20): call note_last_subset; call prepare_process; go to outer_loop; end; end; /* end of outer loop */ end; /* end of interval list case */ else if common_sl_info.list_type = 2 /* descriptor array specification */ then do i = 1 to common_sl_info.array_limit; /* use descriptors from list */ if indx_cb.subset_selected ^= "00"b then call check_subset (da_sl_info.desc_array (i)); else rec_deleted = "0"b; if ^rec_deleted then do; temp_key_words (1) = next_subset; temp_key_words (2) = da_sl_info.desc_array (i); call enter_temp_key; end; end; end; /* count is now known */ if count = 0 /* no records found */ then code = error_table_$no_record; else do; code = 0; if (flag = select_flag) | ((flag ^= select_flag) & (indx_cb.subset_selected = "00"b)) then indx_cb.subset_count = count; else if indx_cb.subset_selected = "10"b then indx_cb.subset_count = indx_cb.subset_count - count; /* entries removed from subset */ else indx_cb.subset_count = indx_cb.subset_count + count; /* entries added to exclude list */ indx_cb.current_subset = next_subset; call note_last_subset; if common_sl_info.status_only then go to get_status; if (flag = select_flag) | ((flag ^= select_flag) & (indx_cb.subset_selected = "10"b)) then indx_cb.subset_selected = "10"b; /* pure selection */ else indx_cb.subset_selected = "01"b; /* pure exclusion */ end; get_status: call get_subset_status; return; /* end of generate subset--done with select or exclude */ get_temp_switch: proc; /* obtains temp file for sorting descriptors */ unique_name = unique_chars_ ("0"b) || ".temp.vfile_"; proc_dir_string = get_pdir_ (); pd_path_len = index (proc_dir_string, " ") - 1; call iox_$attach_name (unique_name, iocbp, "vfile_ " || proc_dir_path || ">" || unique_name, null, code); call iox_$open (iocbp, 10, "0"b, code); call check_code (code, "Cannot open temporary subset file."); indx_cb.temp_iocbp = iocbp; dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl 1 proc_dirp_overlay, 2 pd_path_len fixed, 2 proc_dir_string char (168); dcl proc_dir_path char (168) var based (addr (pd_path_len)); dcl iocbp ptr; end get_temp_switch; enter_temp_key: proc; /* adds entry to temp file or removes entry and adjusts count */ if (flag = select_flag) | ((flag ^= select_flag) & (indx_cb.subset_selected ^= "10"b)) then do; call control_indx_file (indx_cb.temp_iocbp, "add_key", addr (temp_ak_inf), code); if code = 0 then count = count + 1; else if code ^= error_table_$key_duplication then do; call note_last_subset; call check_code (code, "Can't add descriptor into current subset."); end; end; else do; call control_indx_file (indx_cb.temp_iocbp, "delete_key", addr (temp_ak_inf), code); if code = 0 then count = count + 1; else if code ^= error_table_$no_key then do; call note_last_subset; call check_code (code, "Can't remove descriptor from current subset."); end; end; end enter_temp_key; note_last_subset: proc; /* keeps track of highest used subset number */ if count = 0 /* no entries in new subset */ then return; /* no adjustment needed */ indx_cb.last_subset = max (indx_cb.last_subset, next_subset); end note_last_subset; reassign_key: /* routine swaps record descrip for spec key */ call verify_keyed_update; /* checks opening mode */ current_retry_loc = rk_retry; go to init_up_down; retry_loc (21): saved_state.current_record_is_valid = indx_cb.current_record_is_valid; saved_state.current_descrip = indx_cb.current_descrip; pos_unchanged = "0"b; if ^rk_inf.input_key & indx_cb.outside_index /* error--no key associated with current rec */ then code = error_table_$no_key; else if ^rk_inf.input_old_desc | ^rk_inf.input_new_desc /* need current descrip */ then call check_current; else if ^rk_inf.input_key /* using current record's key */ then do; call check_current; /* need current record to be defined */ if code ^= 0 /* error */ then code = error_table_$no_key; /* set proper code */ end; if code ^= 0 then go to verify_done; /* abort on error */ if rk_inf.input_old_desc then old_des = rk_inf.old_descrip; else old_des = indx_cb.current_descrip; if rk_inf.input_new_desc then new_des = rk_inf.new_descrip; else new_des = indx_cb.current_descrip; if rk_inf.input_key then do; if ^indx_cb.shared | ^saved_state.current_record_is_valid then call save_correct_pos; if ^indx_cb.at_bof & ^indx_cb.at_eof & ((indx_cb.next_record_position ^= 0) | (indx_cb.current_record_is_valid & ^indx_cb.outside_index)) & (old_des = indx_cb.saved_descrip) & (indx_cb.new_key = key_to_reassign) then do; if indx_cb.pos_incorrect then do; call restore_position; if (code = 0) & (record_designator (branch_num) ^= indx_cb.saved_descrip) then code = error_table_$asynch_deletion; /* insist on same descriptor */ end; else pos_ptr = indx_cb.file_position_ptr; pos_unchanged = "1"b; first_code = 1; /* anything non-zero indicates key was found */ search_code = 1; /* indicates descriptor was found */ end; else call find_entry (key_to_reassign, old_des);/* look for entry */ end; else if rk_inf.input_old_desc /* key is same, but entry may be different */ then do; if ^indx_cb.shared | ^saved_state.current_record_is_valid then call save_correct_pos; if old_des = indx_cb.saved_descrip then do; pos_unchanged = "1"b; first_code = 1; search_code = 1; end; else call find_entry (indx_cb.new_key, old_des); end; else do; /* file position is already correct */ first_code = 1; search_code = 1; pos_unchanged = "1"b; end; if ^pos_unchanged then indx_cb.pos_incorrect = "1"b; if first_code = 0 /* key not found */ then code = error_table_$no_key; else if search_code = 0 /* key found, but not specified descrip */ then code = error_table_$no_record; if code ^= 0 then go to verify_done; indx_cb.current_descrip = old_des; if indx_cb.stat /* look for ref counts */ then do; saved_state.outside_index = indx_cb.outside_index; indx_cb.outside_index = "0"b; /* in case of garbage collection */ call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, -1); /* decrement old record ref count */ indx_cb.outside_index = saved_state.outside_index; /* restore */ if code ^= 0 then if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset) then do; if saved_state.current_record_is_valid then indx_cb.current_descrip = saved_state.current_descrip; else indx_cb.current_descrip = indx_cb.saved_descrip; go to verify_done; end; old_ref_cnt = ref_cnt; current_retry_loc = reass_key_retry_2; indx_cb.current_descrip = new_des; retry_loc (22): indx_cb.outside_index = "0"b; call lock_current_record (new_block_ptr, new_lock_ptr, i_locked_new_mask, 1); indx_cb.outside_index = saved_state.outside_index; if (code ^= 0) then if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset) then do; /* undo any change and abort */ if saved_state.current_record_is_valid then indx_cb.current_descrip = saved_state.current_descrip; else indx_cb.current_descrip = indx_cb.saved_descrip; go to unlock_exit; end; else code = 0; /* suppress non-fatal warning */ end; else do; block_ptr = null; new_block_ptr = null; end; if saved_state.current_record_is_valid then indx_cb.current_descrip = saved_state.current_descrip; else indx_cb.current_descrip = indx_cb.saved_descrip; call initialize_substate; call set_rk_info; /* saves info for recovery */ file_action = reassigning_key; file_base.change_count = file_base.old_file_ch_count + 1; if block_ptr ^= null then if block_ptr -> record_block.stationary then do; block_ptr -> stat_struct.ref_count_after = file_base.old_ref_count; block_ptr -> stat_struct.ref_count = file_base.old_ref_count; end; if new_block_ptr ^= null then if new_block_ptr -> record_block.stationary then do; new_block_ptr -> stat_struct.ref_count_after = file_base.new_ref_count; new_block_ptr -> stat_struct.ref_count = file_base.new_ref_count; end; record_descrip (branch_num) = file_base.new_descriptor; go to switch_file_state; /* end of reassign key routine */ set_rk_info: proc; /* saves reassign key info for recovery */ if repeating then do; pos_ptr = indx_cb.file_position_ptr; /* reconstruct during recovery */ call check_file_substate; return; end; if (block_ptr = null) then file_base.was_stat = "0"b; else if block_ptr -> record_block.stationary then do; file_base.was_stat = "1"b; file_base.old_ref_count = old_ref_cnt; end; else file_base.was_stat = "0"b; if (new_block_ptr ^= null) then if new_block_ptr -> record_block.stationary then do; file_base.was_stat = "1"b; file_base.new_ref_count = ref_cnt; end; file_base.new_descriptor = new_des; file_base.old_record_designator = old_des; /* now save index location in convenient header variables */ file_base.first_branch = node; /* same protected variable used by rewrite */ file_base.count = branch_num; file_substate = file_substate + 1; /* note this block of code has been completed */ end set_rk_info; set_lock_list_entry: proc (block_ptr_arg, passive_ref_mask); /* add non-passive reference list entry after verifying any prior reference */ passive = "0"b; must_verify = indx_cb.shared; go to main; add_lock_list_entry: entry (block_ptr_arg, passive_ref_mask); /* create entry for new record */ passive = "0"b; must_verify = "0"b; go to main; set_ref_list_entry: entry (block_ptr_arg); /* adds item to passive ref list */ passive = "1"b; /* not locking an item */ must_verify = "1"b; main: if indx_cb.tcfp -> iocb.open_data_ptr -> indx_cb.reflp = null then do; /* initialize ref list */ call transaction_call_$setup_ref_list (indx_cb.tcfp, er_code); call check_code (er_code, "Unable to initialize a transaction reference list."); end; refp = indx_cb.tcfp -> iocb.open_data_ptr -> indx_cb.reflp; if indx_cb.uid = "0"b /* comp 0 uid has not yet been obtained */ then call init_uid_info; /* gets uid--by now file will be an msf */ temp_key.transaction_number = current_t_code; temp_key.file_id = indx_cb.uid; /* for process independent record locator */ temp_key.rec_id = indx_cb.current_descrip; temp_key.blockp = block_ptr_arg; /* this shouldn't really be necessary when right */ if ^must_verify /* just add lock list entry for new record */ then do; /* don't bother to verify */ temp_ak_inf.flags = "11"b; temp_ak_inf.key_len = 16; /* short form */ temp_ak_inf.descrip = -1; /* non-passive reference */ call iox_$control (refp, "add_key", addr (temp_ak_inf), er_code); if (er_code ^= 0) & (er_code ^= error_table_$key_duplication) /* avoid cost of calling check_code if not needed */ then call check_code (er_code, "Can't create a ref list entry for the new record."); return; end; temp_key.time = 0; /* pad with 0's */ temp_rk_inf.key_len = 22; indx_cb_ptr = refp -> iocb.open_data_ptr; /* set up for seek_head */ call seek_head (0, addr (temp_rk_inf.key_len), 12); /* sets pos_ptr to root if fails */ if (passive & ((cur_mod = 0) | (cur_mod = -1))) /* modifier isn't enough to uniquely identify this record's image */ | (^passive & (block_ptr_arg -> stat_struct.prev_mod = 0)) /* prev image requires long form verification */ then do; temp_key.time = time_stamp; temp_rk_inf.old_descrip = ind_desc; if passive /* record modifier will be non-positive */ then temp_rk_inf.new_descrip = ind_desc; /* also setting add_key's descriptor in info structure */ else temp_rk_inf.new_descrip = -1; end; else do; /* short form ref list entry */ temp_rk_inf.key_len = 16; temp_rk_inf.old_descrip = cur_mod; /* current image id */ if ^passive then temp_rk_inf.new_descrip = -1; /* this value means ref is to lock */ else temp_rk_inf.new_descrip = cur_mod; end; if pos_ptr ^= indx_cb.root_position_ptr /* not first ref */ then if (record_designator (branch_num) = temp_rk_inf.old_descrip) & (substr (keys, key_pos (branch_num), key_length (branch_num)) = rk_key) then do; /* prev ref is verified */ indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; pos_ptr = indx_cb.file_position_ptr; /* restore local environment */ if ^passive /* verified ref was to lock */ then do; cleanup_flags = cleanup_flags | passive_ref_mask; /* remember that refl entry exists */ if temp_rk_inf.key_len = 16 /* old ref in short form */ then do; /* just reassign--already short form */ temp_rk_inf.flags = "111"b; /* input all params */ call iox_$control (refp, "reassign_key", addr (temp_rk_inf), er_code); if er_code ^= 0 /* optimization */ then call check_code (er_code, "Can't convert a short form passive ref list entry into a non-passive one."); end; /* end of simple reassignment case */ else do; /* convert long form passive entry into short form non-passive ref list entry */ temp_ak_inf.key_len = 16; temp_ak_inf.flags = "11"b; /* input key and desc */ call iox_$control (refp, "add_key", addr (temp_ak_inf), er_code); /* add new entry before removing old one */ if (er_code ^= 0) & (er_code ^= error_table_$key_duplication) then call check_code (er_code, "Can't add a non-passive ref list entry for a previous long form passive reference.") ; temp_ak_inf.key_len = 22; /* set up to delete long form entry */ temp_ak_inf.descrip = ind_desc; call iox_$control (refp, "delete_key", addr (temp_ak_inf), er_code); if er_code ^= 0 then call check_code (er_code, "Can't delete the old long form passive ref list entry for a subsequently modified item." ); end; end; end; /* end of verified ref case */ else do; /* error--prev reference invalid */ indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; pos_ptr = indx_cb.file_position_ptr; if key_length (branch_num) = 16 then if record_designator (branch_num) = -1/* thought I locked it--maybe interrupted */ then if block_ptr_arg -> stat_struct.record_lock = indx_cb.saved_lock_copy then return; /* suppress error message */ code = error_table_$asynch_change; end; else do; /* add a ref list entry for first ref this transaction */ indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; pos_ptr = indx_cb.file_position_ptr; temp_ak_inf.flags = "11"b; if ^passive then temp_ak_inf.key_len = 16; /* create short form entry */ call iox_$control (refp, "add_key", addr (temp_ak_inf), er_code); if er_code ^= 0 then call check_code (er_code, "Can't create a new ref list entry for this item."); end; /* end of no previous reference case */ return; /* done with ref list manipulation */ init_uid_info: proc; /* gets uid for this file from component 0 */ /* also may create a ref list entry to remember iocb_ptr, if no such entry already exists for this file in this process */ call hcs_$get_uid_seg (indx_cb.file_base_ptr, uid_val, er_code); call check_code (er_code, "Cannot get a uid for the file."); unspec (gk_inf.flags) = "0"b; gk_inf.input_key = "1"b; gk_inf.head_size = 12; gk_inf.key_len = 12; gk_key.zero = 0; gk_key.proc_id = indx_cb.saved_lock_copy; gk_key.file_id = uid_val; refp = indx_cb.tcfp -> iocb.open_data_ptr -> indx_cb.reflp; call iox_$control (refp, "get_key", addr (gk_inf), er_code); if er_code = 0 /* file is known to this ref list */ then if gk_desc = iocb_ptr /* this I/O switch */ then return; /* nothing more to do--refl entry is fine */ else do; /* set refl entry to use this iocb_ptr */ string (rk_inf.flags) = "111"b; rk_inf.old_descrip = rk_inf.new_descrip; /* set by gk */ gk_desc = iocb_ptr; /* new descrip for reassign_key */ call iox_$control (refp, "reassign_key", addr (rk_inf), er_code); call check_code (er_code, "Can't reset default iocb_ptr for this file in the transaction reference list."); end; else do; /* attempt to create new refl entry */ string (ak_inf.flags) = "11"b; /* input key and desc */ gk_desc = iocb_ptr; call iox_$control (refp, "add_key", addr (ak_inf), er_code); call check_code (er_code, "Can't save the iocb_ptr for this file in the transaction reference list."); end; indx_cb.uid = uid_val; dcl refp ptr; dcl uid_val bit (36) aligned; dcl er_code fixed (35); dcl 1 rk_inf, 2 header like rk_header, 2 key char (12); dcl 1 gk_inf based (addr (rk_inf.old_descrip)), 2 header like gk_header, 2 key char (12); dcl 1 ak_inf based (addr (rk_inf.old_descrip)), 2 header like ak_header, 2 key char (12); dcl gk_desc ptr unal based (addr (gk_inf.descrip)); dcl 1 gk_key based (addr (gk_inf.key)), 2 zero fixed (35), 2 proc_id bit (36) aligned, 2 file_id bit (36) aligned; end init_uid_info; dcl passive bit (1) aligned; dcl must_verify bit (1) aligned; dcl er_code fixed (35); dcl 1 temp_rk_inf, 2 flags bit (36) aligned, 2 old_descrip fixed (35), 2 new_descrip fixed (35), 2 key_len fixed, 2 key char (22); dcl 1 temp_ak_inf based (addr (temp_rk_inf.old_descrip)), 2 flags bit (36) aligned, 2 descrip fixed (35), 2 key_len fixed, 2 key char (22); dcl refp ptr; dcl 1 temp_key based (addr (temp_rk_inf.key)), 2 transaction_number fixed (35), 2 file_id bit (36) aligned, 2 rec_id fixed (35), 2 blockp ptr unal, /* should not be needed when done right */ 2 time fixed (53) unal; /* long form only */ dcl rk_key char (22) var based (addr (temp_rk_inf.key_len)); dcl block_ptr_arg ptr; dcl passive_ref_mask bit (36) aligned; end set_lock_list_entry; restore_abort: proc; /* cleans up after unusual abort */ indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; indx_cb.pos_incorrect = "1"b; /* restore indx_cb state */ call restore_state; if cleanup_flags = "000000"b then return; /* nothing to unlock */ aborting = "1"b; if i_locked_file then if stacq (file_base.lock_word, (36)"1"b, indx_cb.saved_lock_copy) then ; /* invalidate file lock */ if i_locked_rec & (block_ptr ^= null) & (lock_ptr ^= null) then if indx_cb.trans then if block_ptr -> record_block.stationary then if (block_ptr -> stat_struct.modifier > 0) & (block_ptr -> stat_struct.modifier = current_t_code) then ; /* leave old record locked--has a lock list entry */ else if old_passive_ref then ; else go to inv_old; else go to inv_old; else do; inv_old: if stacq (lock_ptr -> based_lock, (36)"1"b, indx_cb.saved_lock_copy) then ; end; if i_locked_new & (new_block_ptr ^= null) & (new_lock_ptr ^= null) then if indx_cb.trans then if new_block_ptr -> record_block.stationary then if (new_block_ptr -> stat_struct.modifier > 0) & (new_block_ptr -> stat_struct.modifier = current_t_code) then ; else if new_passive_ref then ; else go to inv_new; else go to inv_new; else do; inv_new: if stacq (new_lock_ptr -> based_lock, (36)"1"b, indx_cb.saved_lock_copy) then ; end; end restore_abort; restore_state: proc; /* re-establishes initial values of process vars which may have been clobbered */ indx_cb.mode = atb.opening_mode; indx_cb.is_sequential_open = (indx_cb.mode < 11); indx_cb.is_read_only = substr ("0001000100100"b, indx_cb.mode, 1); indx_cb.is_ks_out = (indx_cb.mode = 9); if current_retry_loc = skip_retry /* position skip attempt */ then indx_cb.error = saved_error_info; else if (current_retry_loc = init_retry) | (current_retry_loc = inner_retry) | (current_retry_loc = outer_retry) /* select or exclude */ then do; /* restore subset state */ indx_cb.subset_selected = saved_subset_selected; indx_cb.current_subset = saved_current_subset; end; indx_cb.state_vars = saved_state; end restore_state; open_file: call create_indx_cb; if is_new_file then call initialize_new_file; else if file_version ^= current_file_version then do; call check_file_version (indx_cb_ptr, code); /* checks for pre-crashproof version */ if code ^= 0 then do; saved_state.shared = indx_cb.shared; call free_cb_file (size (indx_cb), indx_cb_ptr); if ^substr ("0001000100100"b, atb.opening_mode, 1) & saved_state.shared then call set_lock_$unlock (lock_word, foo); return; end; end; else call check_comp_array_table; /* To catch bad tables produced by bug in */ /* check_file_version . */ call create_seg_ptrs (iocb_ptr); call create_position_stack (indx_cb_ptr); if (file_action ^= 0) & ^is_read_only & (file_action ^= read_exclude) then if file_base.program_version > current_program_version then do; code = error_table_$unimplemented_version; call sub_err_ (code, "vfile_", "c", null, code, "Can't adjust operation in progress with this version of vfile_."); end; else do; call restart (iocb_ptr, code); fs_ptr = indx_cb.file_state_ptr; end; if (file_base.program_version < current_program_version_2) & indx_cb.stat & ^indx_cb.is_read_only & (code = 0) then do; code = error_table_$unimplemented_version; call sub_err_ (code, "vfile_", "c", null, code, "Old version file does not support -stationary attach option."); end; foo = 0; /* in case of cleanup */ if code = 0 then call set_entries_and_positions; else go to cleanup_exit; if is_read_only then return; if indx_cb.read_exclu then file_action = read_exclude; cleanup_flags = "100000"b; /* just unlock the file */ current_retry_loc = cleanup_retry; /* initialize this variable */ go to unlock_exit; close_indx_file: entry (iocb_ptr); indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; f_b_ptr = file_base_ptr; indx_cb.file_state_ptr = addr (file_state_blocks (file_state)); fs_ptr = indx_cb.file_state_ptr; o_s_ptr = addr (file_state_blocks (1 - file_state)); os_ptr = o_s_ptr; foo = 0; on seg_fault_error begin; foo = error_table_$lock_wait_time_exceeded; go to cleanup_exit; end; if indx_cb.shared & ^is_read_only & ^leave_locked then do; /* prepare to set bit counts */ call set_lock (addr (file_base.lock_word), 0, foo); if foo = error_table_$lock_wait_time_exceeded then go to cleanup_exit; if old_last_comp_num ^= last_comp_num /* new component */ then do; /* recreate the seg_ptr_array */ call free_seg_ptrs (iocb_ptr); call create_seg_ptrs (iocb_ptr); end; end; if ^is_read_only then call set_bitcounts (iocb_ptr); retry_loc (23): cleanup_exit: revert seg_fault_error; call free_seg_ptrs (iocb_ptr); call free_position_stack (indx_cb_ptr); call discard_temp_file (indx_cb.temp_iocbp); /* subset file can be thrown away, if one exists */ call discard_temp_file (indx_cb.reflp); /* for transaction control file only--throw away temporary reference list */ lock_copy = indx_cb.saved_lock_copy; call free_cb_file (size (indx_cb), indx_cb_ptr); if substr ("0001000100100"b, atb.opening_mode, 1) | (foo = error_table_$locked_by_this_process) | (foo = error_table_$lock_wait_time_exceeded) then return; /* don't unlock in this case */ if file_action = read_exclude then file_action = 0; /* clear read lock */ if file_action = 0 then do; unspec (spare_node) = "0"b; /* free unneeded storage */ if stacq (file_base.lock_word, "0"b, lock_copy) /* unlock */ then ; end; else if stacq (file_base.lock_word, (36)"1"b, lock_copy) then ; /* make it look like I died */ return; /* end of close routine */ set_entries_and_positions: proc; close_x = close_indx_file; iocb_ptr -> iocb.control = control_indx_file; go to open_case (mode); open_case (4): /* sequential input */ indx_cb.at_bof = "1"b; iocb_ptr -> iocb.read_record = read_indx_file; iocb_ptr -> iocb.read_length = read_length_indx_file; iocb_ptr -> iocb.position = position_indx_file; return; open_case (7): /* sequential update */ indx_cb.at_bof = "1"b; iocb_ptr -> iocb.read_record = read_indx_file; iocb_ptr -> iocb.read_length = read_length_indx_file; iocb_ptr -> iocb.position = position_indx_file; iocb_ptr -> iocb.rewrite_record = rewrite_indx_file; iocb_ptr -> iocb.delete_record = delete_indx_file; return; open_case (8): /* keyed sequential input */ indx_cb.at_bof = "1"b; iocb_ptr -> iocb.read_record = read_indx_file; iocb_ptr -> iocb.read_length = read_length_indx_file; iocb_ptr -> iocb.read_key = read_key_indx_file; iocb_ptr -> iocb.position = position_indx_file; iocb_ptr -> iocb.seek_key = seek_key_indx_file; return; open_case (9): /* keyed sequential output */ indx_cb.at_eof = "1"b; iocb_ptr -> iocb.seek_key = seek_key_ks_out; iocb_ptr -> iocb.write_record = write_indx_file; return; open_case (10): /* keyed sequential update */ indx_cb.at_bof = "1"b; iocb_ptr -> iocb.read_record = read_indx_file; iocb_ptr -> iocb.read_length = read_length_indx_file; iocb_ptr -> iocb.read_key = read_key_indx_file; iocb_ptr -> iocb.position = position_indx_file; iocb_ptr -> iocb.seek_key = seek_key_indx_file; iocb_ptr -> iocb.control = control_indx_file; iocb_ptr -> iocb.write_record = write_indx_file; iocb_ptr -> iocb.rewrite_record = rewrite_indx_file; iocb_ptr -> iocb.delete_record = delete_indx_file; return; open_case (11): /* direct input */ iocb_ptr -> iocb.read_record = read_indx_file; iocb_ptr -> iocb.read_length = read_length_indx_file; iocb_ptr -> iocb.seek_key = seek_key_indx_file; return; open_case (12): /* direct output */ iocb_ptr -> iocb.seek_key = seek_key_indx_file; iocb_ptr -> iocb.write_record = write_indx_file; return; open_case (13): /* direct update */ iocb_ptr -> iocb.read_record = read_indx_file; iocb_ptr -> iocb.read_length = read_length_indx_file; iocb_ptr -> iocb.seek_key = seek_key_indx_file; iocb_ptr -> iocb.write_record = write_indx_file; iocb_ptr -> iocb.rewrite_record = rewrite_indx_file; iocb_ptr -> iocb.delete_record = delete_indx_file; end set_entries_and_positions; create_indx_cb: proc; /* creates open data structure */ code = 0; call alloc_cb_file (size (indx_cb), iocb_ptr -> iocb.open_data_ptr); indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; fcb_ptr = fcb_ptr_arg; file_base_ptr = first_seg_ptr; f_b_ptr = file_base_ptr; last_change_count = change_count; /* must be saved before referencing file_state */ mode = mode_arg; is_sequential_open = (mode < 11); is_read_only = substr ("0001000100100"b, mode, 1); is_ks_out = (mode = 9); indx_cb.next_record_position = 0; indx_cb.current_record_is_valid = "0"b; indx_cb.ready_to_write = "0"b; indx_cb.shared = atb.shared; indx_cb.wait_time = atb.wait_time; repeating = "0"b; file_state_ptr = addr (file_state_blocks (file_state)); fs_ptr = file_state_ptr; o_s_ptr = addr (file_state_blocks (1 - file_state)); indx_cb.error.type = 0; /* used by "error_status" control order */ indx_cb.at_bof = "0"b; /* used in shared openings for asynch re-seeks */ indx_cb.at_eof = "0"b; indx_cb.min_res = 0; /* default is no spare space allocated with records */ indx_cb.min_cap = 0; /* default is not to allocate null recs */ leave_locked = "0"b; /* if shared, will leave unlocked between operations */ indx_cb.outside_index = "0"b; /* may be set by "record_status" */ dup_ok = atb.dup_ok_sw | (duplicate_keys ^= 0); indx_cb.stat = atb.stat_sw; /* -stat option used */ indx_cb.read_exclu = atb.exclu_sw; /* may be set by "set_file_lock" order */ indx_cb.pos_incorrect = "1"b; /* may be set by "add_key", etc. */ indx_cb.saved_lock_copy = "0"b; /* in case happens to contain a valid lock */ call set_lock_$lock (indx_cb.saved_lock_copy, 0, foo); indx_cb.new_key = ""; file_position_ptr = null; indx_cb.min_key_len = file_base.minimum_key_length; /* non-zero for old files */ indx_cb.skip_state = 0; /* default is to scan forward over deletions */ indx_cb.current_subset = 0; indx_cb.last_subset = 0; indx_cb.subset_selected = "00"b; indx_cb.temp_iocbp = null; indx_cb.trans = atb.trans_sw; /* set if -transaction attachment */ if indx_cb.trans then indx_cb.tcfp = atb.tcf_iocbp; /* ptr to transaction control iocb */ else indx_cb.tcfp = null; indx_cb.transaction_code = 0; indx_cb.reflp = null; /* used in transaction control file only */ indx_cb.collection_delay_time = 0; end create_indx_cb; check_comp_array_table: proc; /* This looks through the comp_table comp_links for any component which is greater than the maximum component in use, identified by last_comp_num. Should such a bogus comp_link be found, sub_err_ is signaled and vfile_ is ground to an unrestartable stop. */ dcl table_idx fixed bin (35); do table_idx = lbound (comp_table, 1) to hbound (comp_table, 1); if comp_table.comp_link (table_idx) > file_base.last_comp_num then if is_read_only then call sub_err_ (error_table_$bad_file, "vfile_", "c", null, code, "Previous modifications to this file may have resulted in lost data, due to incorrect information in the file_base of this file. Type ""help damaged_keyed_files"" for more information. Processing will continue."); else do; if stacq (file_base.common_header.lock_word, "0"b, indx_cb.saved_lock_copy) then ; call sub_err_ (error_table_$bad_file, "vfile_", "s", null, error_table_$bad_file, "This file cannot safely be updated due to incorrect information in its file_base. Type ""help damaged_keyed_files"" for more information."); end; end; end; discard_temp_file: proc (iocbp); /* cleanup routine for subsets and ref lists */ if iocbp = null then return; /* nothing to discard */ call iox_$close (iocbp, foo); unique_name = substr (iocbp -> iocb.attach_descrip_ptr -> based_vstring, length (iocbp -> iocb.attach_descrip_ptr -> based_vstring) + 1 - length (unique_name), length (unique_name)); /* unique name of temp file from attach description */ call hcs_$delentry_file (get_pdir_ (), unique_name, foo); /* delete temporary index */ call iox_$detach_iocb (iocbp, foo); call iox_$destroy_iocb (iocbp, foo); iocbp = null; dcl iocbp ptr; dcl foo fixed (35); end discard_temp_file; initialize_new_file: proc; /* At this point all words except the common header are zero. This routine sets the nonzero values */ program_version = current_program_version; max_seg_limit = component_size_arg; minimum_block_size = minimum_block_size_val; node_size = node_size_val; last_branch_num_root = 1; do foo = 0, 1; addr (index_state_blocks (foo)) -> new_key_pos = node_head_length + branch_and_descrip_length + 1; end; max_comp_num = true_max_comp_num; seg_limit (0) = node_size * (1 + divide (size (file_base) + node_size - 1, node_size, 17, 0)); call hcs_$set_bc_seg (file_base_ptr, 36 * size (file_base), foo); file_version = current_file_version; /* creation is thus atomic */ return; dcl hcs_$set_bc_seg entry (ptr, /* pointer to seg, input */ fixed bin (24), /* bit count to be set */ fixed bin (35)); /* status code */ end initialize_new_file; check_file_substate: proc; /* keeps track of logical block during recovery execution */ next_substate = next_substate + 1; if file_substate = next_substate then repeating = "0"b; /* execution resumes normally */ end check_file_substate; check_code: proc (er_code, message); /* unusual abort detector */ if er_code = 0 then return; code = er_code; /* give code back to caller after warning */ call sub_err_ (code, "vfile_", "c", null, code, message); indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; indx_cb.pos_incorrect = "1"b; if cleanup_flags = "000000"b then go to passive_abort; aborting = "1"b; go to unlock_exit; dcl er_code fixed (35); dcl message char (*); end check_code; /* DECLARATIONS */ dcl i_locked_rec_mask static internal options (constant) bit (36) aligned init ("010101000000000000000000000000000000"b); dcl i_locked_new_mask static internal options (constant) bit (36) aligned init ("001010100000000000000000000000000000"b); dcl rec_lock_mask static internal options (constant) bit (36) aligned init ("011000000000000000000000000000000000"b); dcl negmod_mask static internal options (constant) bit (36) aligned init ("000001100000000000000000000000000000"b); dcl passive_ref_bit_mask static internal options (constant) bit (36) aligned init ("000110000000000000000000000000000000"b); dcl old_passive_ref_mask static internal options (constant) bit (36) aligned init ("000100000000000000000000000000000000"b); dcl new_passive_ref_mask static internal options (constant) bit (36) aligned init ("000010000000000000000000000000000000"b); dcl seek_kso_retry static internal options (constant) init (1); dcl seek_retry static internal options (constant) init (2); dcl read_len_retry static internal options (constant) init (3); dcl read_key_retry static internal options (constant) init (4); dcl read_retry static internal options (constant) init (5); dcl skip_retry static internal options (constant) init (6); dcl pos_bof_or_eof_retry static internal options (constant) init (7); dcl gk_retry static internal options (constant) init (8); dcl rs_retry_2 static internal options (constant) init (9); dcl rs_retry_1 static internal options (constant) init (10); dcl sh_retry static internal options (constant) init (11); dcl rew_retry static internal options (constant) init (12); dcl write_retry static internal options (constant) init (13); dcl del_retry static internal options (constant) init (14); dcl adj_retry static internal options (constant) init (15); dcl ak_retry static internal options (constant) init (16); dcl dk_retry static internal options (constant) init (17); dcl init_retry static internal options (constant) init (18); dcl inner_retry static internal options (constant) init (19); dcl outer_retry static internal options (constant) init (20); dcl rk_retry static internal options (constant) init (21); dcl reass_key_retry_2 static internal options (constant) init (22); dcl cleanup_retry static internal options (constant) init (23); dcl lock_file_retry static internal options (constant) init (24); dcl adj_file_retry static internal options (constant) init (25); dcl based_area area based; dcl system_freep ptr static internal init (null); dcl get_system_free_area_ entry returns (ptr); dcl delete_old_subsets entry (ptr); dcl rec_deleted bit (1) aligned; dcl (stacq, string, clock, addrel, hbound,index,lbound,stac) builtin; dcl len fixed; dcl 1 saved_state like indx_cb.state_vars; dcl saved_state_block char (length (current_state_block)) based (addr (saved_state)); dcl saved_subset_selected bit (2) aligned; dcl saved_current_subset fixed (34); dcl 1 saved_error_info like indx_cb.error; dcl current_state_block char (4 * size (fixed_state_block) + 4 + length (indx_cb.new_key)) based (addr (indx_cb.state_vars)); dcl 1 fixed_state_block like indx_cb.fixed_state_part based; dcl os_ptr ptr; dcl branches_left fixed; dcl count fixed (34); dcl chunk_size fixed (34); dcl first_code fixed (35); dcl key_is_dup bit (1) aligned; dcl passive_op bit (1) aligned; dcl del_cur bit (1) aligned; dcl fault_ok bit (1) aligned; dcl (any_other, seg_fault_error) condition; dcl cleanup condition; dcl current_retry_loc fixed; dcl need_pos fixed static options (constant) internal init (5); dcl time_left fixed; dcl timeout fixed (71); dcl eternity static internal options (constant) fixed (71) init (1f70b); dcl new_change_count fixed (35); dcl continue_to_signal_ entry (fixed (35)); dcl branch_and_descrip_length static options (constant) fixed init (12); dcl node_head_length static options (constant) fixed init (16); dcl restart entry (ptr, fixed (35)); dcl check_file_version entry (ptr, fixed (35)); dcl find_key entry (ptr, ptr, fixed (35)); dcl find_key$last entry (ptr, ptr, fixed bin (35)); dcl set_lock_$lock entry (bit (36) aligned, fixed, fixed (35)); dcl set_lock_$unlock entry (bit (36) aligned, fixed (35)); /* Arguments */ dcl buff_len fixed (21); dcl buff_ptr ptr; dcl close_x entry; dcl code fixed (35); dcl component_size_arg fixed (19); dcl fcb_ptr_arg ptr; dcl first_seg_bitcount fixed (24); dcl first_seg_ptr ptr; dcl iocb_ptr ptr; dcl is_new_file bit (1) aligned; dcl key char (256) varying; dcl mode_arg fixed; dcl pos_type fixed; dcl skip fixed; dcl rec_len fixed (21); /* Local Variables */ dcl 1 current_des like designator_struct aligned based (addr (indx_cb.current_descrip)); dcl record_action fixed; dcl record_len fixed (21); dcl record_ptr ptr; dcl foo fixed (35); dcl pos_ptr ptr; dcl buffer char (record_len) based (buff_ptr); dcl block_ptr ptr; dcl 1 block_with_lock based (block_ptr), 2 words (record_block.block_size - 1) fixed, /* body of block */ 2 record_lock bit (36) aligned; /* set/cleared by "record_status" order */ dcl 1 temp_ts_words aligned, 2 ind_offset bit (18) unal, 2 time_last_modified bit (54) unal; dcl 1 new_rec_des based (addr (file_base.new_descriptor)), 2 comp fixed (17) unal, 2 offset bit (18) unal; dcl lock_ptr ptr; dcl based_vstring char (1000000) var based; dcl bstring char (1000000) based; dcl based_lock bit (36) aligned based; dcl 1 ak_inf based (info_ptr), 2 header like ak_header, 2 key char (ak_inf.key_len); dcl 1 rk_inf based (info_ptr), 2 header like rk_header, 2 key char (rk_inf.key_len); dcl 1 gk_inf based (info_ptr), 2 header like gk_header, 2 key char (gk_inf.key_len); dcl ak_info_key char (256) var based (addr (ak_inf.key_len)); dcl key_to_reassign char (256) var based (addr (rk_inf.key_len)); /* File Parameter Values */ dcl current_file_version static options (constant) fixed init (40); dcl current_program_version static options (constant) fixed init (41); dcl current_program_version_1 static options (constant) fixed init (32); dcl current_program_version_2 static options (constant) fixed init (33); dcl node_size_val static options (constant) fixed init (1024); dcl minimum_block_size_val static options (constant) fixed init (8); dcl msf_manager_$get_ptr entry (ptr, fixed, bit (1), ptr, fixed (24), fixed (35)); dcl 1 record_block like record_block_structure based (block_ptr); dcl 1 stat_struct like stat_structure based (block_ptr); dcl 1 ind_struct like ind_structure based (block_ptr); dcl 1 time_stamp_struct like time_stamp_structure based (addr (stat_struct.time_stamp_words)); dcl 1 ind_des like ind_des_structure based (addr (ind_desc)); dcl hcs_$delentry_file entry (char (*), char (*), fixed (35)); dcl hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed (35)); dcl unique_name char (27); dcl get_pdir_ entry returns (char (168)); dcl lock_copy bit (36) aligned; dcl ind_desc fixed (35); dcl cur_mod fixed (35); dcl transaction_call_$assign entry (ptr, fixed (35), fixed (35)); dcl transaction_call_$setup_ref_list entry (ptr, fixed (35)); dcl descrip_arg fixed (35); dcl rollback_sw bit (1) aligned; dcl p ptr; dcl modifier_arg fixed (35); dcl time_stamp fixed (71) aligned; dcl mod fixed (35); dcl cleanup_flags bit (36) aligned; dcl 1 cleanup_flag_struct based (addr (cleanup_flags)), 2 i_locked_file bit (1) unal, 2 i_locked_rec bit (1) unal, 2 i_locked_new bit (1) unal, 2 old_passive_ref bit (1) unal, 2 new_passive_ref bit (1) unal, 2 i_set_negmod bit (1) unal, 2 i_set_new_negmod bit (1) unal, 2 aborting bit (1) unal, 2 pad bit (28) unal; dcl order char (*); dcl ( vfile_io_control, vfile_io_control$af ) entry (ptr, ptr, ptr, fixed (35)); dcl vfile_status_$seg entry (ptr, ptr, ptr, fixed (35)); dcl (info_ptr, info_ptr_arg) ptr; dcl blanks char (256) aligned static internal options (constant) init (""); dcl 1 gk_pad_key, 2 len fixed, 2 string char (256); dcl 1 pad_key_info based (pad_key_ptr), 2 pad_key_len fixed, 2 pad_key char (256); dcl pad_key_ptr ptr; dcl 1 info based (info_ptr), 2 rel_type fixed, 2 n fixed, 2 search_key char (0 refer (n)); dcl 1 mbs_info based (info_ptr), 2 min_residue fixed (21), /* min unused capacity in bytes */ 2 min_capacity fixed (21); /* minimum bytes which will be allocated */ dcl 1 error_info based (info_ptr), 2 version fixed bin (35), /* must =1 (Input) */ 2 type fixed bin (35), /* identifies type of error--only one currently exists */ 2 requested fixed bin (35), /* skip arg passed to vfile_ for positioning */ 2 received fixed bin (35); /* skips completed successfully */ dcl skip_error fixed static options (constant) internal init (1); dcl 1 set_lock_info based (info_ptr) aligned, 2 set_lock_flag bit (1) unal, /* "1"b means lock, "0"b means unlock */ 2 exclusive bit (1) unal; /* "1"b means lock out readers too */ dcl new_wait_time float based (info_ptr); dcl 1 wt_info based (info_ptr), 2 version float, /* -2 indicates collection delay, not new_wait_time */ 2 collection_delay_time float; dcl max_rec_wds fixed (19); dcl ref_cnt fixed; dcl delta_ref_count fixed; dcl new_block_ptr ptr; dcl new_lock_ptr ptr; dcl transaction defined indx_cb_ptr -> indx_cb.trans bit (1) aligned; dcl passive bit (1) aligned; dcl max_ref_count static internal options (constant) init (65535); /* 2**16 -1 */ dcl sub_err_ entry options (variable); dcl current_descrip fixed (35) defined indx_cb.current_descrip; dcl old_ref_cnt fixed; dcl new_des fixed (35); dcl old_des fixed (35); dcl pos_unchanged bit (1) aligned; dcl next_subset fixed (34); dcl i fixed; dcl last_head char (256) var; dcl last_head_len fixed based (addr (last_head)); dcl temp_key_words (1:2) fixed bin (35) based (addr (temp_key)); dcl vpad_key char (256) var based (addr (pad_key_info)); dcl 1 temp_ak_inf, 2 flags bit (36) aligned, 2 descriptor fixed (35), 2 key_len fixed, 2 temp_key char (8); dcl flag bit (1) aligned; dcl head_spec bit (1) aligned; dcl open_ended bit (1) aligned; dcl max_list_type static fixed options (constant) init (2) internal; dcl n_int fixed; dcl last_info_ptr ptr; dcl 1 last_info_block (0:1), 2 new_ptr ptr, 2 des fixed (35), 2 lkey char (256) var; dcl 1 last_info based (last_info_ptr), 2 new_last_info_ptr ptr, 2 last_descrip fixed (35), 2 last_key char (256) var; dcl 1 new_last_info based (last_info.new_last_info_ptr), 2 new_last_info_ptr ptr, 2 new_last_descrip fixed (35), 2 new_last_key char (256) var; dcl select_flag static internal bit (1) aligned init ("0"b) options (constant); dcl exclude_flag static internal bit (1) aligned init ("1"b) options (constant); dcl timer_manager_$sleep entry (fixed (71), bit (2)); dcl min_max_rec_len static options (constant) internal fixed (21) init (24); %page; %include vf_attach_block; %page; %include iox_entries; %page; %include rs_info; %page; %include ak_info; %page; %include select_info; %page; %include vfile_error_codes; %page; %include vfile_indx; %page; %include iocb; end /* end open_indx_file */;  open_seq_file.pl1 11/04/82 1940.0rew 11/04/82 1620.8 350262 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Modified 8/8/74 to correct bug. Declared header size increased by four words to retroactively justify declaration of first_record_pos as having vale 61. New file version number is 1.1. Only difference is that initial_descriptor now is (correctly) immediately before the first records descriptor. Version 1.0 files are ok except for backspacing past beginning of segment, which was the bug */ open_seq_file: proc (iocb_ptr, fcb_ptr_arg, first_seg_ptr, is_new_file, mode, close_x, first_seg_bitcount, max_component_size, code); call validate_initialize_file; if code = 0 then do; /* initialize cb, set iocb items */ call create_initialize_cb; if first_seg_ptr -> header.version < current_version then if mode > 4 /* OK to update file version */ then if (first_seg_ptr -> header.version = 12) & ^iocb_ptr -> iocb.attach_data_ptr -> atb.inv_lock_reset then call adjust_file_v12; /* needs end_desc */ else do; /* needs both end_pos and end_desc */ call adjust_file; /* sets end_pos */ if code = 0 then first_seg_ptr -> header.version = current_version; /* makes change */ end; else end_not_valid = (iocb_ptr -> iocb.attach_data_ptr -> atb.inv_lock_reset | first_seg_ptr -> header.version ^= 12); else do; /* new version file */ end_not_valid = "0"b; /* end_pos is valid */ if first_seg_ptr -> header.file_action ^= 0 /* not consistent */ then if first_seg_ptr -> header.file_action = must_rollback then if mode > 4 then do; call save_position; call rollback; call restore_position; end; else ; else if first_seg_ptr -> header.file_action = must_adjust then if mode > 4 then call adjust_file; /* skips forward */ else seq_cb.end_not_valid = "1"b; else code = error_table_$bad_file; end; if code = 0 then do; call set_entries_and_positions; if mode > 4 /* opening for modification */ then if seq_cb.checkpoint then first_seg_ptr -> header.file_action = must_rollback; else first_seg_ptr -> header.file_action = must_adjust; end; else call free_cb_file (size (seq_cb), open_data_ptr); end; return; /* end of opening routine */ control_seq_file: entry (iocb_ptr, order, info_ptr, code); code = 0; if order = "read_position" then do; if end_not_valid /* old version file -- must compute positions */ then call get_positions; info.end_position = seq_cb.end_pos; info.next_position = next_pos; return; end; if order = "record_status" then do; rs_info_ptr = info_ptr; if (rs_info.version < rs_info_version_1) | (rs_info.version > rs_info_version_2) then code = error_table_$unimplemented_version; else if substr (string (rs_info.flags), 1, 6) ^= "0"b then code = error_table_$bad_arg; /* flags not supported for seq files */ else do; if rs_info.locate_pos_sw then if (rs_info.descriptor = 0) | (rs_info.record_length < 0) | (^seq_cb.end_not_valid & (rs_info.record_length > seq_cb.end_pos)) then do; code = error_table_$bad_arg; return; /* abort */ end; else if seq_cb.opening_mode = 5 /* output */ then do; code = error_table_$no_operation; return; end; else do; /* set position as indicated */ if seq_cb.write_pos ^= beyond_limits /* in write state */ then call switch_to_read_state; call set_position (rs_info.descriptor); seq_cb.next_is_current = "1"b; seq_cb.next_pos = rs_info.record_length; seq_cb.current_record_ptr = null; end; call check_current; /* current record position required */ if code = 0 then do; /* fill in info structure */ dbytes = current_record_ptr -> descrip; rs_info.record_length = d; rs_info.record_ptr = addr (current_record_ptr -> record); /* get pointer to record contents */ packed_curp = current_record_ptr; /* get into packed format */ unspec (rs_info.descriptor) = unspec (packed_curp); seq_desc.comp_num = component; rs_info.max_rec_len = d; end; end; return; /* finished with record_status control order */ end; if (order = "checkpoint") & seq_cb.checkpoint & ^seq_cb.input_only then do; /* make note of present end of file position */ call checkpoint; return; /* end of file position now saved in file header */ end; /* end of checkpoint order */ if (order = "truncate") & ^input_only then do; /* truncate unless already at eof */ if read_pos ^= minus_one_pos /* not in write state */ then if seq_cb.checkpoint & (seq_cb.next_pos < seq_cb.header_end_pos /* below checkpoint */) then do; /* purely logical truncation */ pos = seq_cb.read_pos; call set_end_desc; /* note new eof location */ seq_cb.end_pos = seq_cb.next_pos; end; /* logically current eof precedes rollback eof */ else do; call truncate_file; return; end; seq_cb.current_record_ptr = null; seq_cb.next_is_current = "1"b; return; end; if (order = "rollback") & ^input_only & seq_cb.checkpoint then do; call rollback; return; end; else if order = "error_status" then do; if error_info.version ^= 1 then code = error_table_$bad_arg; else do; error_info.type = error.type; error_info.requested = error.requested; error_info.received = error.received; end; return; end; else if order = "file_status" then do; call vfile_status_$seg (iocb_ptr, file_base_ptr, info_ptr, code); return; end; else if order = "io_call" then call vfile_io_control (iocb_ptr, file_base_ptr, info_ptr, code); else code = error_table_$no_operation; return; /* end of control routine */ read_length_seq_file: entry (iocb_ptr, rec_len, code); call find_next_record; if code = 0 then do; /* record found */ rec_len = d; current_record_ptr = addr (descrip); /* becomes current record */ next_is_current = "1"b; /* unstaggerred */ end; return; /* end of read length routine */ read_seq_file: entry (iocb_ptr, buff_ptr, buff_len, rec_len, code); call find_next_record; if code = 0 then do; rec_len = d; if d > buff_len then do; code = error_table_$long_record; d = buff_len; end; if d > 0 then buffer = record; current_record_ptr = addr (descrip); next_pos = next_pos + 1; next_is_current = "0"b; /* staggerred */ read_pos = read_pos + 8 + rec_len; end; return; /* end read routine */ position_seq_file: entry (iocb_ptr, pos_type, skip, code); code = 0; pos = read_pos; dbytes = descrip; if pos_type = 0 then call position_skip; else if pos_type = 1 then do; /* position to eof */ if d ^= -1 /* not already at eof, therefore in read state */ then if seq_cb.write_pos = beyond_limits/* else must be checkpoint truncation case */ then call position_eof; read_pos = pos; end; else if pos_type = -1 then do; /* position to beginning */ call position_bof; code = er_code; end; else code = error_table_$bad_arg; return; /* end position routine */ write_seq_file: entry (iocb_ptr, buff_ptr, buff_len, code); if buff_len < 0 then do; code = error_table_$negative_nelem; return; end; write: pos = write_pos; write_pos = write_pos + 8 + buff_len; if write_pos > write_limit then call write_exception; else do; code = 0; d = buff_len; addr (seg (write_pos)) -> descrip = minus_one_descrip; trailer_descrip = dbytes; record = buffer; descrip = dbytes; next_is_current = "0"b; /* positions staggerred after write */ current_record_ptr = addr (descrip); seq_cb.end_pos = seq_cb.end_pos + 1; next_pos = seq_cb.end_pos; end; return; /* end write routine */ rewrite_seq_file: entry (iocb_ptr, buff_ptr, buff_len, code); call check_current; /* sets code */ if buff_len < 0 then code = error_table_$negative_nelem; if code = 0 /* current record is defined */ then if seq_cb.checkpoint then do; if seq_cb.next_is_current then cur_pos = seq_cb.next_pos; else cur_pos = seq_cb.next_pos - 1; if cur_pos < seq_cb.header_end_pos then code = error_table_$no_operation; else call replace_record; end; else call replace_record; return; /* end rewrite routine */ delete_seq_file: entry (iocb_ptr, code); call check_current; if code = 0 /* current record is defined */ then if seq_cb.checkpoint /* may be a purely logical deletion or disallowed */ then do; if seq_cb.next_is_current then cur_pos = seq_cb.next_pos; else cur_pos = seq_cb.next_pos - 1; if cur_pos < seq_cb.header_end_pos then if cur_pos < seq_cb.end_pos - 1 /* not supported */ then code = error_table_$no_operation; else if cur_pos = seq_cb.end_pos - 1 /* new low pos */ then do; /* adjust low end */ last_desc_ptr = current_record_ptr; last_desc.compno = seq_cb.component; go to set_positions;/* don't actually delete now */ end; end; if code = 0 then do; dbytes = current_record_ptr -> descrip; d = -(deleted_size_bias + d); current_record_ptr -> descrip = dbytes; set_positions: current_record_ptr = null; seq_cb.end_pos = seq_cb.end_pos - 1; /* decrement count of records in file */ if ^next_is_current /* next position moves back */ then do; next_pos = next_pos - 1; /* predecessor is deleted */ next_is_current = "1"b; /* current becomes next */ end; end; return; /* end delete routine */ close_seq_file: entry (iocb_ptr); pos = write_pos; if pos ^= beyond_limits then call switch_to_read_state; if ^seq_cb.input_only then if (unspec (seq_cb.header_end_info) = unspec (seq_cb.checkpoint_data)) then file_base_ptr -> header.file_action = 0; else if ^seq_cb.checkpoint then do; file_base_ptr -> header.checkpoint_data = seq_cb.checkpoint_data; file_base_ptr -> header.file_action = 0; end; call free_cb_file (size (seq_cb), open_data_ptr); return; /* end close routine */ find_next_record: proc; /* If read pos designates a record, this procedure sets pos and d and returns with code = 0. If read_pos designates eof, it sets current_record_ptr and code accordingly and returns. In other cases it advances read_pos to the first undeleted record or eof, setting pos, d, and code accordingly. */ code = 0; do while ("1"b); /* may cross msf component boundaries */ pos = read_pos; dbytes = descrip; if seq_cb.next_pos >= seq_cb.end_pos then d = -1; /* as if eof marker encountered */ if d >= 0 then return; do while (d < -2); /* skip deleted record */ pos = pos + 8 - d - deleted_size_bias; dbytes = descrip; end; read_pos = pos; if d = -1 /* end of file, applies in read or write state */ then do; if seq_cb.end_not_valid then do; /* note that we have found eof */ seq_cb.end_pos = seq_cb.next_pos; call set_end_desc; end; code = error_table_$end_of_info; end; else if d = -2 then call next_seg_read; if code ^= 0 then do; current_record_ptr = null; /* current position is undefined */ return; end; end; end; /* end find_next_record */ position_skip: proc; next_is_current = "1"b; /* positions always the same after a skip */ if skip > 0 then do; /* forward skip */ count = skip; do while (count > 0); seq_cb.current_record_ptr = null; call find_next_record; if code = 0 then do; read_pos = read_pos + 8 + d; next_pos = next_pos + 1; /* bump next record position */ count = count - 1; end; else count = -count; end; if code ^= 0 then do; error.type = skip_error; /* for "error_status" control order */ error.requested = skip; error.received = skip + count; end; end; else if skip < 0 then do; /* backwards skip */ if write_pos ^= beyond_limits then call switch_to_read_state; count = -skip; call backspace; read_pos = pos; current_record_ptr = addr (descrip); if code ^= 0 /* attempt to pass end of info */ then do; /* save error info */ error.type = skip_error; error.requested = skip; error.received = skip - count; end; end; else do; /* don't move next position, just set current */ call find_next_record; if code = 0 /* record found */ then current_record_ptr = addr (descrip); else code = 0; /* not error if at end of file */ end; backspace: proc; /* This position backspaces over count records setting pos. If there are less than count records code is set to end_of_info. */ do while (count > 0); pos = pos - 4; /* locate trailer descrip, prev record */ dbytes = descrip; if d >= 0 /* not beginning of segment */ then do; pos = pos - 4 - d; /* descrip for record */ dbytes = descrip; if d >= 0 /* not deleted record */ then do; /* decrement count and next_pos */ count = count - 1; next_pos = next_pos - 1; end; end; else if component = 0 /* beginning of file */ then do; code = error_table_$end_of_info; pos = pos + 4; /* reset to record descrip */ dbytes = descrip; count = -count; end; else do; /* get preceding segment */ next_comp = component - 1; call msf_manager_$get_ptr (fcb_ptr, next_comp, "0"b, next_seg_ptr, foo24, foo); if next_seg_ptr = null then do; code = error_table_$bad_file; pos = pos + 4; /* reset to record descrip */ dbytes = descrip; count = 0; end; else do; pos = end_prev_seg; component = next_comp; seg_ptr = next_seg_ptr; dbytes = descrip; /* Note count is not decremented. All that has happened is to position to the final descriptor of the preceding segment. A record must still be backspaced over. */ end; end; end; end; /* end backspace */ dcl count fixed bin; end; /* end position_skip */ check_current: proc; /* routines sets code to indicate whether current rec found */ if current_record_ptr = null /* may be valid if current is next */ then do; /* set current to next */ call find_next_record; /* sets code */ if code = 0 /* record found */ then current_record_ptr = addr (descrip); else code = error_table_$no_record; end; else code = 0; /* current defined since non-null */ end check_current; position_eof: proc; /* called in read state */ if seq_cb.end_not_valid /* must scan to find true eof */ then call set_end_pos; current_record_ptr = null; seq_cb.next_is_current = "1"b; next_pos = seq_cb.end_pos; if seq_cb.end_desc = 0 /* must be an old version file */ then do; /* handle first positioning to eof as special case */ call find_eof_v12; /* will set end_desc */ return; end; call set_position (seq_cb.end_desc); pos = seq_cb.read_pos; end position_eof; set_position: proc (descriptor); /* sets position to location specified by descriptor */ seq_cb.read_pos = 4 * fixed (ds.wordno) + divide (fixed (ds.bitno, 6, 0), 9, 17, 0) + 1; /* byte offset of descriptor */ if seq_cb.component ^= ds.compno then do; /* get another component */ seq_cb.component = ds.compno; call msf_manager_$get_ptr (fcb_ptr, seq_cb.component, "0"b, seq_cb.seg_ptr, foo24, foo); end; dcl descriptor fixed (35); dcl 1 ds based (addr (descriptor)), 2 bitno fixed (5) unal, 2 compno fixed (11) unal, 2 wordno bit (18) unal; end set_position; position_bof: proc; /* sets position to beginning of file */ er_code = 0; if component ^= 0 then call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, next_seg_ptr, foo24, foo); else next_seg_ptr = seg_ptr; if next_seg_ptr = null then er_code = error_table_$bad_file; else do; if write_pos ^= beyond_limits then call switch_to_read_state; seg_ptr = next_seg_ptr; component = 0; read_pos = first_record_pos; next_is_current = "1"b; next_pos = 0; /* beginning of file */ pos = read_pos; /* offset of first descriptor */ current_record_ptr = addr (descrip); end; end position_bof; replace_record: proc; /* tries to insert new rec at current position */ dbytes = current_record_ptr -> descrip; if buff_len = d then do; code = 0; if d ^= 0 then current_record_ptr -> record = buffer; if next_is_current /* positions not staggerred */ then do; /* advance next record position */ next_pos = next_pos + 1; next_is_current = "0"b; read_pos = read_pos + 8 + buff_len; /* skip over the current record */ end; end; else if buff_len < d then code = error_table_$short_record; else code = error_table_$long_record; end replace_record; checkpoint: proc; /* saves eof position in checkpoint data in file header */ if seq_cb.write_pos ^= beyond_limits /* write state */ then do; /* note eof position */ pos = seq_cb.write_pos; call set_seg_end; end; /* this already done if in read state */ file_base_ptr -> header.checkpoint_data = seq_cb.checkpoint_data; /* atomically changes eof setting */ if seq_cb.header_end_pos >= seq_cb.end_pos /* dispose of tail garbage */ then do; call save_position; /* must be able to leave user's pos unchanged */ call position_eof; /* locate last descriptor */ call truncate_file; /* zero tail contents */ call restore_position; /* like when we started */ end; seq_cb.header_end_info = seq_cb.checkpoint_data; /* if file is closed now the file_action can be cleared, since trunc is done and header end info is correct checkpoint value */ end checkpoint; save_position: proc; /* keeps track of file positions so they can be reset */ saved_seg_ptr = seg_ptr; saved_comp = component; saved_write_pos = write_pos; saved_read_pos = read_pos; saved_curr_ptr = current_record_ptr; saved_next_curr = next_is_current; saved_next_pos = seq_cb.next_pos; end save_position; restore_position: proc; seg_ptr = saved_seg_ptr; component = saved_comp; write_pos = saved_write_pos; read_pos = saved_read_pos; current_record_ptr = saved_curr_ptr; next_is_current = saved_next_curr; seq_cb.next_pos = saved_next_pos; end restore_position; switch_to_read_state: proc; pos = seq_cb.write_pos; if seq_cb.checkpoint then if seq_cb.end_pos <= seq_cb.header_end_pos /* don't alter file yet */ then call set_end_desc; /* note eof location */ else call set_seg_end; /* mark the file as well */ else call set_seg_end; /* change is immediate */ seq_cb.write_pos = beyond_limits; /* read state */ end switch_to_read_state; set_seg_end: proc; /* This procedure sets the current segment's bit count and the end_seg field in the header. It expects pos to be at the final descriptor. */ end_seg = pos; call hcs_$set_bc_seg (seg_ptr, 9 * (pos + 3), foo); set_end_desc: entry; /* notes eof location */ last_desc_ptr = addr (descrip); /* get packed ptr */ last_desc.compno = seq_cb.component; end set_seg_end; write_exception: proc; if pos = beyond_limits /* read state */ then do; if append_sw then if seq_cb.checkpoint /* may not append if already has truncated */ then if seq_cb.end_pos < seq_cb.header_end_pos then go to no_op; /* not supported at this time */ else call position_eof; else call position_eof; else if updating then do; /* replace or insert next record */ if seq_cb.checkpoint then if seq_cb.next_pos < seq_cb.header_end_pos then do; /* dissallow this case, because it can't be rolled back */ no_op: seq_cb.write_pos = pos; /* initial state */ code = error_table_$no_operation; return; /* abort */ end; call find_next_record; if code = 0 /* not at end of file */ then do; /* replace */ write_pos = beyond_limits; /* leave file in read state */ current_record_ptr = addr (descrip); next_is_current = "1"b; /* will be changed by replacement */ call replace_record;/* lengths must match */ return; end; end; else if seq_cb.checkpoint & (seq_cb.next_pos < seq_cb.header_end_pos) then go to no_op; else do; call truncate_file; go to write; end; pos = seq_cb.read_pos; seq_cb.read_pos = minus_one_pos; /* switch to write state */ seq_cb.write_pos = pos; go to write; /* appends to eof */ end; else if buff_len > max_record_size then do; write_pos = pos; code = error_table_$long_record; end; else do; /* end of segment case */ write_pos = pos; if ssf_sw /* no msf's allowed */ then do; /* flag the error */ code = error_table_$file_is_full; call set_seg_end; return; end; next_comp = component + 1; if ^is_msf /* first open msf */ then do; call msf_manager_$open (substr (attach_descrip_string, 8, dname_len), substr (attach_descrip_string, 9 + dname_len, ename_len), fcb_ptr, code); is_msf = "1"b; atb.fcbp = fcb_ptr; end; call msf_manager_$get_ptr (fcb_ptr, next_comp, "1"b, next_seg_ptr, foo24, code); if next_seg_ptr ^= null then do; prev_seg_ptr = seg_ptr; /* save ptr to base of seg */ code = 0; call set_seg_end; seg_ptr = next_seg_ptr; component = next_comp; header.version = 1; end_prev_seg = pos; minus_one = -1; addr (seg (header_size + 1)) -> descrip = minus_one_descrip; /* sets initial descriptor */ pos = first_record_pos; call set_seg_end; write_pos = first_record_pos; descrip = minus_one_descrip; /* first record descrip */ d = -2; addr (prev_seg_ptr -> seg (end_prev_seg)) -> descrip = dbytes; go to write; /* add record to end of file */ end; end; dcl prev_seg_ptr ptr; end; /* end write exception */ next_seg_read: proc; /* called in read state when another seg exists */ next_comp = component + 1; call msf_manager_$get_ptr (fcb_ptr, next_comp, "0"b, next_seg_ptr, foo24, foo); if next_seg_ptr = null then code = error_table_$bad_file; else do; component = next_comp; seg_ptr = next_seg_ptr; read_pos = first_record_pos; end; end; /* end next_seg_read */ truncate_file: proc; /* sets end of file to next record position */ pos = read_pos; read_pos = minus_one_pos; /* first change to write state */ write_pos = pos; seq_cb.current_record_ptr = null; seq_cb.next_is_current = "1"b; descrip = minus_one_descrip; call set_seg_end; seq_cb.end_pos = next_pos; if ^is_msf /* single segment */ then call hcs_$truncate_seg (seg_ptr, divide (pos + 6, 4, 18, 0), foo); else call msf_manager_$adjust (fcb_ptr, component, 9 * (pos + 3), "010"b, foo); /* truncate file */ end truncate_file; create_initialize_cb: proc; call alloc_cb_file (size (seq_cb), open_data_ptr); fcb_ptr = fcb_ptr_arg; seg_ptr = first_seg_ptr; component = 0; write_limit = 4 * max_component_size - 3; max_record_size = 4 * max_component_size - header_size - 12; beyond_limits = write_limit + 4; write_pos = beyond_limits; /* initialize to read state */ read_pos = first_record_pos; next_is_current = "1"b; /* positions initially not staggerred */ pos = read_pos; current_record_ptr = null; next_pos = 0; file_base_ptr = seg_ptr; seq_cb.checkpoint_data, seq_cb.header_end_info = file_base_ptr -> header.checkpoint_data; append_sw = (iocb_ptr -> iocb.attach_data_ptr -> atb.appending) & (mode = 6 /* input_output */); updating = (mode = 7 /* sequential_update */); input_only = (mode = 4); seq_cb.opening_mode = mode; is_msf = atb.msf; /* set if file is already an msf */ ssf_sw = atb.ssf; /* -ssf option indicates no msf's allowed */ minus_one_word = -1; seq_cb.checkpoint = atb.checkpoint_sw; end; /* end create_initialize_cb */ set_entries_and_positions: proc; /* sets iocb entries for valid operations and positions to end of file in some output modes */ close_x = close_seq_file; control = control_seq_file; /* supported in all modes */ if mode = 4 /* input */ then do; read_record = read_seq_file; read_length = read_length_seq_file; position = position_seq_file; end; else if mode = 5 /* output */ then write_record = write_seq_file; else if mode = 6 /* input_output */ then do; read_record = read_seq_file; read_length = read_length_seq_file; position = position_seq_file; write_record = write_seq_file; end; else do; /* update */ read_record = read_seq_file; read_length = read_length_seq_file; position = position_seq_file; write_record = write_seq_file; rewrite_record = rewrite_seq_file; delete_record = delete_seq_file; end; if (mode = 5) | ((mode = 6) & ^append_sw) /* output or input-output */ then do; /* change to write state */ call position_eof; write_pos = pos; read_pos = minus_one_pos; end; end set_entries_and_positions; validate_initialize_file: proc; code = 0; if is_new_file then do; /* initialize file */ first_seg_ptr -> end_prev_seg = 0; first_seg_ptr -> minus_one = -1; first_seg_ptr -> end_seg = first_record_pos; first_seg_ptr -> header.checkpoint_data.end_desc = initial_end_desc; addr (first_seg_ptr -> seg (header_size + 1)) -> descrip = addr (first_seg_ptr -> minus_one) -> descrip; /* this sets the initial descriptor */ addr (first_seg_ptr -> seg (first_record_pos)) -> descrip = addr (first_seg_ptr -> minus_one) -> descrip; /* this set the eof descriptor */ call hcs_$set_bc_seg (first_seg_ptr, 9 * (header_size + 8), foo); first_seg_ptr -> header.version = current_version; end; else do; /* validate header, init descriptor */ dbytes = addr (first_seg_ptr -> seg (header_size + 1)) -> descrip; if ((first_seg_ptr -> header.version < 10) | (first_seg_ptr -> header.version > current_version)) | (first_seg_ptr -> end_prev_seg ^= 0) | (first_seg_ptr -> minus_one ^= -1) | ((d ^= -1) & (first_seg_ptr -> header.version = 11)) then code = error_table_$bad_file; end; end; /* end validate_initialize_file */ rollback: proc; /* restores eof according to checkpoint data */ if seq_cb.write_pos ^= beyond_limits then call switch_to_read_state; if seq_cb.end_pos >= seq_cb.header_end_pos /* file was extended */ then do; /* rollback requires truncation */ seq_cb.next_pos = seq_cb.header_end_pos; call set_position (seq_cb.header_end_desc); call truncate_file; /* dispose of new stuff */ seq_cb.checkpoint_data = seq_cb.header_end_info; end; else do; /* un-truncate file */ seq_cb.checkpoint_data = seq_cb.header_end_info; call position_eof; end; end rollback; adjust_file: proc; /* truncates file after setting eof properly */ call save_position; seq_cb.end_pos = infinity; /* let find_next_rec scan for marker */ call set_end_pos; call set_seg_end; file_base_ptr -> header.checkpoint_data = seq_cb.checkpoint_data; if ^is_msf /* single segment */ then call hcs_$truncate_seg (seg_ptr, divide (pos + 6, 4, 18, 0), code); else call msf_manager_$adjust (fcb_ptr, component, 9 * (pos + 3), "010"b, code); /* truncate any garbage */ seq_cb.header_end_info = seq_cb.checkpoint_data; call restore_position; end adjust_file; /* file properly adjusted to last rec */ set_end_pos: proc; /* determines true record count */ do while (code = 0); /* advance position to true eof */ call find_next_record; /* may advance file position */ next_pos = next_pos + 1; read_pos = read_pos + 8 + d; /* skips the record */ end; seq_cb.end_pos = next_pos - 1; /* true end of file position */ call set_end_desc; end_not_valid = "0"b; /* remember end pos is now correct */ code = 0; end set_end_pos; find_eof_v12: proc; /* positions to end of file in version 12 or older files */ flag = "1"b; do while (flag); pos = end_seg; dbytes = descrip; read_pos = pos; if d = -2 /* another segment exists */ then do; call next_seg_read; if code ^= 0 then flag = "0"b; /* found file bad */ end; else flag = "0"b; /* this is the last seg */ end; call set_end_desc; dcl flag bit (1) aligned; end find_eof_v12; adjust_file_v12: proc; /* converts version 12 to current */ call save_position; call find_eof_v12; first_seg_ptr -> header.checkpoint_data.end_desc = seq_cb.end_desc; first_seg_ptr -> header.version = current_version; call restore_position; end adjust_file_v12; get_positions: proc; /* used on initial attempt to read positions in old version files */ call save_position; /* now find next and end positions */ ei_ptr = addr (ei_block); ei_ptr -> error_info.version = 1; call position_seq_file (iocb_ptr, 0, -infinity, foo); /* will produce error */ call control_seq_file (iocb_ptr, "error_status", ei_ptr, foo); next_pos = 0; call set_end_pos; next_pos = -ei_ptr -> error_info.received; call restore_position; dcl ei_ptr ptr; dcl 1 ei_block, 2 words (4) fixed; end get_positions; dcl (addr, divide) builtin; dcl infinity static options (constant) internal fixed (34) init (17179870); dcl (vfile_io_control, vfile_status_$seg) entry (ptr, ptr, ptr, fixed (35)); dcl order char (*); dcl info_ptr ptr; dcl alloc_cb_file entry (fixed bin, ptr); dcl buffer char (d) based (buff_ptr); dcl buff_ptr ptr; dcl buff_len fixed bin (21); dcl close_x entry; dcl code fixed bin (35); dcl 1 error_info based (info_ptr), /* used with "error_status" control order */ 2 version fixed, /* must =1 (Input) */ 2 type fixed, /* identifies type of error--only one currently exists */ 2 requested fixed, /* skip arg passed to vfile_ for positioning */ 2 received fixed; /* skips completed successfully */ dcl skip_error fixed static options (constant) internal init (1); dcl 1 complete_record based (addr (seg (pos))), 2 descrip char (4), /* descriptor for record, actually an integer, = length of record normally, = -(header_size + length) for deleted record */ 2 record char (d), 2 trailer_descrip char (4); /* always = record length */ dcl d fixed bin (21); /* value of descriptor, length of record */ dcl dbytes char (4) based (addr (d)); /* alias for assignment between d and descrip */ dcl deleted_size_bias static options (constant) internal fixed bin (21) init (40); /* this is added to the record size before commplementing it to get the descriptor for a deleted record. 40 is an arbitrary value >0. */ dcl error_table_$bad_file external fixed bin (35); dcl error_table_$negative_nelem external fixed (35); dcl error_table_$file_busy external fixed (35); dcl error_table_$unimplemented_version external fixed (35); dcl error_table_$file_is_full static external fixed (35); dcl error_table_$no_operation external fixed (35); dcl error_table_$no_record external fixed bin (35); dcl error_table_$long_record external fixed bin (35); dcl error_table_$short_record external fixed bin (35); dcl error_table_$end_of_info external fixed bin (35); dcl error_table_$bad_arg external fixed bin (35); dcl free_cb_file entry (fixed bin, ptr); dcl fcb_ptr_arg ptr; dcl first_record_pos static options (constant) internal fixed bin init (61); /* =header_size+4+1, 4 for initial descriptor */ dcl first_seg_ptr ptr; dcl first_seg_bitcount fixed bin (24); dcl foo fixed bin (35); /* used when status code is to be ignored */ dcl foo24 fixed bin (24); /* used when bit count is to be ignored */ dcl 1 header based (seg_ptr), 2 common_header_words (4) fixed bin, 2 version_word aligned, 3 file_action fixed (17) unal, 3 version fixed (17) unal, 2 end_prev_seg fixed bin (21), /* = 0 in first seg, otherwise = pos of final descrip in preceding segment */ 2 end_seg fixed bin (21), /* = pos of final descriptor in this segment except while in write state. In write state indicates end of seg when write state entered */ 2 minus_one fixed bin (21), /* always -1 */ 2 checkpoint_data, 3 end_pos fixed (34), 3 end_desc fixed (35), 2 reserved (4) fixed; dcl cur_pos fixed (34); dcl low_end_ptr ptr unal based (addr (seq_cb.low_end_desc)); dcl 1 low_ds_struct based (addr (seq_cb.low_end_desc)), 2 bitno bit (6) unal, 2 low_end_comp fixed (11) unal, 2 wordno bit (18) unal; dcl must_rollback static internal fixed options (constant) init (3); dcl must_adjust static internal fixed options (constant) init (2); dcl header_size static options (constant) internal fixed bin init (56); dcl checkpoint_info_words fixed (71); dcl 1 checkpoint_info based (addr (checkpoint_info_words)) aligned, 2 end_pos fixed (34), 2 end_desc fixed (35); dcl hcs_$truncate_seg entry (ptr, fixed (18), fixed (35)); dcl hcs_$terminate_noname entry (ptr, fixed (35)); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed (35)); dcl hcs_$set_bc_seg entry (ptr, /* pointer to seg, input */ fixed bin (24), /* bit count to be set */ fixed bin (35)); /* status code */ dcl iocb_ptr ptr; /* for open and close entries this points to the actual iocb. For other entries the iocb may be attached as a syn */ dcl is_new_file bit (1) aligned; dcl max_component_size fixed bin (19); dcl mode fixed bin; /* 4, 5, 6, or 7 */ dcl minus_one_pos static options (constant) internal fixed bin (21) init (29); /* 4*common_header_size+13 = position of header.minus_one */ dcl msf_manager_$adjust entry (ptr, /* fcb_ptr */ fixed bin, /* component number of segment to be made last segment */ fixed bin (24), /* bit count for that seg */ bit (3), /* "010" = dont set bit counts, truncate segment, dont terminate components */ fixed bin (35)); /* status code */ dcl msf_manager_$get_ptr entry (ptr, /* fcb_ptr */ fixed bin, /* component number of desired segment */ bit (1), /* create switch */ ptr, /* ptr to seg or null if error, output */ fixed bin (24), /* bitcount of segment, output */ fixed bin (35)); /* status code */ dcl next_comp fixed bin; dcl next_seg_ptr ptr; dcl null builtin; dcl rec_len fixed bin (21); dcl pos fixed bin (21); /* position of next descriptor */ dcl pos_type fixed bin; dcl seg (1048576) char (1) based (seg_ptr); dcl 1 info based (info_ptr), /* used for "read_position" order call */ 2 next_position fixed (34), 2 end_position fixed (34); dcl 1 seq_cb based (open_data_ptr), 2 seg_ptr ptr, /* ptr to current seg */ 2 fcb_ptr ptr, /* ptr to msf control block */ 2 component fixed bin, /* component number of current seg */ 2 write_limit fixed bin (21), /* set at open to max seg size + 1 */ 2 beyond_limits fixed bin (21), /* set at open to write_limit + 4 */ 2 max_record_size fixed bin (21), /* set at open to 4*max_component_size- header_size-12(i.e. 3 desciptor words */ 2 write_pos fixed bin (21), /* in write state = pos of final descriptor, in read state = beyond limits */ 2 read_pos fixed bin (21), /* in read state = pos of next descriptor, in write state = minus_one_pos */ 2 current_record_ptr ptr, 2 checkpoint_data, 3 end_pos fixed (34), 3 end_desc fixed (35), 2 next_pos fixed (34), /* next record number */ 2 next_is_current bit (1) aligned, /* "0"b if positions staggerred */ 2 updating bit (1) aligned, /* set if mode=7 (sequential_update) */ 2 append_sw bit (1) aligned, /* set if mode=6 (seq in out) and -append attachment */ 2 input_only bit (1) aligned, 2 ssf_sw bit (1) aligned, /* -ssf option indicator */ 2 is_msf bit (1) aligned, /* set when msf is opened */ 2 end_not_valid bit (1) aligned, /* used with old version files */ 2 error, /* used by "error_status" control order */ 3 type fixed, 3 requested fixed (34), 3 received fixed (34), 2 minus_one_word fixed, 2 file_base_ptr ptr, 2 header_end_info, 3 header_end_pos fixed (34), 3 header_end_desc fixed (35), 2 checkpoint bit (1) aligned, /* set if -checkpoint attachment */ 2 opening_mode fixed; dcl packed_curp ptr unal; dcl minus_one_descrip char (4) based (addr (minus_one_word)); dcl size builtin; dcl er_code fixed (35); dcl current_version fixed static options (constant) internal init (13); dcl initial_end_desc static fixed (35) internal options (constant) init (15); dcl 1 last_desc based (addr (seq_cb.end_desc)), 2 bitno fixed (5) unal, 2 compno fixed (11) unal, 2 wordno bit (18) unal; dcl last_desc_ptr ptr unal based (addr (seq_cb.end_desc)); dcl 1 eof_data based (addr (eof_data_word)), 2 end_pos fixed (34), 2 end_desc fixed (35); dcl eof_data_word fixed (71) aligned; %include vf_attach_block; %include rs_info; dcl skip fixed (34); dcl (saved_seg_ptr, saved_curr_ptr) ptr; dcl saved_comp fixed; dcl saved_next_pos fixed (34); dcl (saved_read_pos, saved_write_pos) fixed (21); dcl saved_next_curr bit (1) aligned; %include iocbv; end /* end of sequential file i-o program */;  open_uns_file.pl1 11/04/82 1940.0rew 11/04/82 1620.8 276543 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* changed October, 1978 by Jim Paradise to impliment the -no_end option (see end of source for comments) */ open_uns_file: proc (iocb_ptr, fcb_ptr_arg, first_seg_ptr, is_new_file, mode, close_x, first_seg_bitcount, max_component_size, code); code = 0; if atb.header_present /* -header attach option present */ then if is_new_file /* set header identifier in new file */ then do; /* initialize header */ call hcs_$set_bc_seg (first_seg_ptr, 36 * size (header), code); if code ^= 0 then return; /* shouldn't happen */ first_seg_ptr -> header.identifier = atb.header_id; end; else if (first_seg_ptr -> file_code ^= uns_code) | ((first_seg_ptr -> header.identifier ^= atb.header_id) & (atb.header_id ^= 0)) then do; /* signal error--identifiers must match */ code = error_table_$incompatible_attach; return; /* opening is unsuccessful */ end; call create_initialize_cb; close_x = close_uns_file; control = control_uns_file; if mode = 1 /* input */ then do; get_line = get_line_uns_file; get_chars = get_chars_uns_file; position = position_uns_file; end; else if mode = 2 /* output */ then do; put_chars = fast_put; end; else do; /* input - output */ get_line = get_line_uns_file; get_chars = get_chars_uns_file; position = position_uns_file; put_chars = fast_put; end; return; /* end open routine */ control_uns_file: entry (iocb_ptr, order, info_ptr, code); code = 0; call get_current_state; if order = "read_position" then if current_state = read_state then do; info.next_position = base_pos + read_pos - 1; /* essentially the defining relationship for absolute position in the read state */ info.end_position = end_pos; /* always valid in read state */ end; else if current_state = write_state then do; info.next_position = base_pos + write_pos - 1; /* -1 because byte offset starts with 1 at base of segment */ info.end_position = info.next_position; /* pos always at eof in write state */ end; else do; /* beyond eof */ info.next_position = base_pos + write_pos - 1; info.end_position = end_pos; end; /* for debugging else if order = "display_uns_cb" then call display_uns_cb; */ else if (order = "truncate") & (^input_only) then do; if current_state = read_state then do; /* might not be at eof so truncate */ call truncate_and_change_to_write; code = foo; /* what the hell */ end; else if current_state = beyond_eof_state then code = error_table_$no_operation; /* not allowed */ end; else if order = "file_status" then do; call vfile_status_$seg (iocb_ptr, file_base_ptr, info_ptr, code); return; end; else if order = "io_call" then call vfile_io_control (iocb_ptr, file_base_ptr, info_ptr, code); else code = error_table_$no_operation; return; /* end of control routine */ create_initialize_cb: proc; call alloc_cb_file (size (cb_uns_file), open_data_ptr); write_limit = 4 * max_component_size + 1; beyond_limits = 2 ** 34 - 1; fcb_ptr = fcb_ptr_arg; seg_ptr = first_seg_ptr; call hcs_$status_mins (seg_ptr, foo2, bitcount, foo35); component = 0; header_is_present = atb.header_present; /* -header option was used for attachment */ if header_is_present then base_pos = -4 * size (header); /* absolute byte position of file base is negative */ else base_pos = 0; /* no header--first byte is byte_0 */ if is_new_file & header_is_present then end_seg = 4 * size (header) + 1; else end_seg = divide (first_seg_bitcount + 8, 9, 21, 0) + 1; read_pos = 1 - base_pos; /* byte offset of zeroth position in file */ tail_len = end_seg - read_pos; /* bytes remaining beyond next_pos in this segment */ write_pos, old_write_pos = beyond_limits; /* start in read state */ input_only = (mode = 1); /* stream_input */ ssf_sw = atb.ssf; /* -ssf option indicates no msf's allowed */ noend = atb.noend_sw; /* -no_end attach option */ is_msf = atb.msf; /* on if already an msf */ append_sw = atb.appending; /* -append attachment */ no_trunc_sw = atb.no_trunc; /* -no_trunc attach option */ current_state = read_state; call set_end_pos; /* gets total byte count of file */ if (mode = 2) | (^append_sw & ^no_trunc_sw & (mode = 3)) /* start in write state */ then do; write_pos, old_write_pos = read_pos; /* tail_len already zero */ current_state = write_state; /* for completeness */ end; file_base_ptr = seg_ptr; end; /* end create_initialize_cb */ close_uns_file: entry (iocb_ptr); call get_current_state; call change_to_read_state; /* sets bit count of file */ call free_cb_file (size (cb_uns_file), open_data_ptr); return; /* end close routine */ get_chars_uns_file: entry (iocb_ptr, buff_ptr, buff_len, rec_len, code); call get_current_state; if current_state = beyond_eof_state then do; code = error_table_$end_of_info; rec_len = 0; /* no data */ return; end; len = min (tail_len, buff_len); if len > 0 then do; buffer = record_read; read_pos = read_pos + len; tail_len = tail_len - len; if buff_len = len /* all bytes moved */ then do; code = 0; rec_len = len; end; else do; /* exceptional case_end of segment */ call get_chars_uns_file (iocb_ptr, addr (buff_tail), buff_len - len, rec_len, code); rec_len = rec_len + len; if (code ^= 0) & (rec_len > 0) then code = error_table_$short_record; end; end; else if buff_len <= 0 then do; /* no move */ code = 0; rec_len = 0; end; else do; /* end of segment case */ call next_seg_read; if code ^= 0 & code ^= error_table_$end_of_info /* msf error */ then return; if code ^= 0 then rec_len = 0; else call get_chars_uns_file (iocb_ptr, buff_ptr, buff_len, rec_len, code); end; return; /* end get chars routine */ get_line_uns_file: entry (iocb_ptr, buff_ptr, buff_len, rec_len, code); call get_current_state; if current_state = beyond_eof_state then do; code = error_table_$end_of_info; rec_len = 0; /* no data */ return; end; len = min (tail_len, buff_len); if len > 0 then do; len2 = len; len = index (record_read, new_line); if len ^= 0 /* new line found */ then do; code = 0; buffer = record_read; rec_len = len; read_pos = read_pos + len; tail_len = tail_len - len; end; else do; /* new_line not found */ len = len2; buffer = record_read; /* move len bytes */ read_pos = read_pos + len; tail_len = tail_len - len; if buff_len = len then do; /* long record case */ rec_len = len; code = error_table_$long_record; end; else do; /* end of segment case */ call get_line_uns_file (iocb_ptr, addr (buff_tail), buff_len - len, rec_len, code); rec_len = rec_len + len; if (code ^= 0) & (rec_len > 0) then code = error_table_$short_record; end; end; end; else if buff_len <= 0 then do; /* no move */ code = error_table_$long_record; rec_len = 0; end; else do; /* end of segment case */ call next_seg_read; if code ^= 0 & code ^= error_table_$end_of_info /* msf error */ then return; if code ^= 0 then rec_len = 0; else call get_line_uns_file (iocb_ptr, buff_ptr, buff_len, rec_len, code); end; return; /* end of get_line routine */ skip_record: proc; /* skips one record and (as needed by read) increments len2 by length skipped, excluding new_line */ do while ("1"b); /* may cross boundaries of msf components */ len = tail_len; if len ^= 0 then do; len = index (record_read, new_line); if len ^= 0 then do; /* new line found */ code = 0; len2 = len2 + len - 1; read_pos = read_pos + len; tail_len = tail_len - len; return; end; else do; /* record extends to next seg */ len2 = len2 + tail_len; read_pos = read_pos + tail_len; tail_len = 0; end; end; else do; /* at end of seg */ call next_seg_read; if code ^= 0 then return; end; end; end; /* end skip record */ next_seg_read: proc; if current_state ^= read_state then code = error_table_$end_of_info; else do; foo = 0; if ^is_msf then next_seg_ptr = null; else do; call msf_manager_$get_ptr (fcb_ptr, component + 1, "0"b, next_seg_ptr, bitcount, foo); end; if next_seg_ptr = null then do; if foo ^= 0 /* msf error? */ then do; /* return a code back */ if foo = error_table_$noentry /* way to find eof */ then code = error_table_$end_of_info; else code = foo; /* return the code */ end; else code = error_table_$end_of_info; return; end; else do; base_pos = base_pos + end_seg - 1; /* absolute byte position of new seg base */ seg_ptr = next_seg_ptr; call hcs_$status_mins (seg_ptr, foo2, bitcount, foo35); component = component + 1; tail_len = divide (bitcount + 8, 9, 21, 0); end_seg = tail_len + 1; read_pos = 1; code = 0; end; end; end; /* end next seg read */ position_uns_file: entry (iocb_ptr, pos_type, skip, code); call get_current_state; if pos_type = 0 then call position_skip; else if pos_type = 2 /* direct positioning */ then call position_abs; else if pos_type = 1 then call position_eof; else if pos_type ^= -1 then code = error_table_$bad_arg; else call position_bof; return; /* end position routine */ change_to_read_state: proc; /* no effect if already in read state */ if current_state = read_state then return; if current_state = beyond_eof_state then write_pos, old_write_pos = beyond_limits; /* switch to read state no change, since the positioning absolute to beyond eof did a position_eof before everything */ else do; end_seg = write_pos; read_pos = write_pos; end_pos = base_pos + end_seg - 1; /* must be last comp since write state */ tail_len = 0; write_pos, old_write_pos = beyond_limits; call hcs_$set_bc_seg (seg_ptr, 9 * (end_seg - 1), foo); end; end; /* end change_to_read_state */ position_abs: proc; /* sets position directly to specified byte */ if skip < 0 /* negative absolute position is undefined */ then code = error_table_$negative_nelem; else do; call change_to_read_state; code = 0; if skip >= end_pos then do; call position_eof; if skip > end_pos /* attempt to pass eof */ then if ^noend /* not allowed by specifying -no_end */ then code = error_table_$end_of_info; else do; /* -no_end specified */ write_pos, old_write_pos = skip + 1 - base_pos; /* set the position beyond to the absolute position: */ current_state = beyond_eof_state; end; /* segment(s) may not be defined */ return; /* done processing in this case */ end; do while ((skip < base_pos) & (code = 0)); /* requested pos in previous component */ call prev_seg_read; end; do while ((skip >= base_pos + end_seg) & (code = 0)); /* requested pos in succeeding component */ call next_seg_read; end; if code ^= 0 & code ^= error_table_$end_of_info /* msf error */ then return; if code = 0 /* position lies within current segment */ then do; read_pos = skip + 1 - base_pos; /* set next byte offset for reading */ tail_len = end_seg - read_pos; /* bytes following next in this segment */ end; end; end position_abs; position_skip: proc; if skip > 0 then do; /* check if pos'ed after eof */ if current_state = beyond_eof_state then do; code = error_table_$end_of_info; return; end; else do; /* forwards skip */ code = 0; count = skip; do while (count > 0); len2 = 0; /* skip record increments this for read */ call skip_record; if code ^= 0 & code ^= error_table_$end_of_info /* msf error */ then return; if code ^= 0 then count = 0; else count = count - 1; end; end; end; else do; /* backwards skip */ count = -skip; code = 0; call change_to_read_state; do while (count > 0); call find_preceding_new_line; if code = 0 then count = count - 1; else count = 0; end; if code = 0 /* positioned at new_line character */ then do; call find_preceding_new_line; if code = 0 /* positioned at new_line character */ then call get_chars_uns_file (iocb_ptr, addr (dummy_buffer), 1, foo21, foo); /* skips over new line character */ code = 0; end; end; end position_skip; find_preceding_new_line: proc; /* this moves read_pos back to first preceding new_line character or beginning of file if there is none. In the latter case code is set to end_of_info */ do while (code = 0); /* may cross msf component boundaries */ flag = "1"b; k = read_pos; if header_is_present then if component = 0 then min_pos = 4 * size (header) + 1; /* can't position beneath header */ else min_pos = 1; else min_pos = 1; do while (flag); k = k - 1; if k < min_pos /* at base of segment */ then flag = "0"b; else if seg (k) = new_line then flag = "0"b; end; if k >= min_pos /* new_line found */ then do; code = 0; read_pos = k; tail_len = end_seg - k; return; end; else do; /* beginning of segment */ read_pos = min_pos; tail_len = end_seg - read_pos; if component = 0 /* beginning of file */ then do; code = error_table_$end_of_info; return; end; else call prev_seg_read; /* moves pos to end of prev seg */ end; end; dcl flag bit (1) aligned; dcl (k, min_pos) fixed bin (21); end; /* end_find_preceding_line */ dcl count fixed bin; dcl foo21 fixed bin (21); position_eof: proc; if current_state = beyond_eof_state then do; call change_to_read_state; end; code = 0; if current_state = read_state then do; do while (code = 0); call next_seg_read; end; if code ^= error_table_$end_of_info /* msf error */ then return; code = 0; read_pos = end_seg; tail_len = 0; end; end; /* end position_eof */ position_bof: proc; /* sets position to beginning of file */ code = 0; call change_to_read_state; if ^is_msf then do; /* current segment must be first */ read_pos = 1 - base_pos; tail_len = end_seg - read_pos; return; end; call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, next_seg_ptr, bitcount, foo); if next_seg_ptr ^= null then do; seg_ptr = next_seg_ptr; call hcs_$status_mins (seg_ptr, foo2, bitcount, foo35); component = 0; if header_is_present then base_pos = -4 * size (header); /* abs pos of first seg base is neg */ else base_pos = 0; /* first byte in seg is zeroth absolute byte position */ end_seg = divide (bitcount + 8, 9, 21, 0) + 1; read_pos = 1 - base_pos; tail_len = end_seg - read_pos; /* always holds in read state */ end; else code = foo; end position_bof; put_chars_uns_file: entry (iocb_ptr, buff_ptr, buff_len, code); code = 0; call get_current_state; len = max (buff_len, 0); old_pos = write_pos; write_pos, old_write_pos = write_pos + len; if write_pos <= write_limit /* normal case */ then do; record_write = buffer; end; else if old_pos < write_limit /* long record case */ then do; len = write_limit - old_pos; write_pos, old_write_pos = write_limit; record_write = buffer; call put_chars_uns_file (iocb_ptr, addr (buff_tail), buff_len - len, code); end; else do; /* end of seg or read state */ write_pos, old_write_pos = old_pos; code = 0; if write_pos = write_limit /* end of seg case */ then call new_seg_write; else if current_state = beyond_eof_state then do; /* spacing beyond eof */ do while ((write_pos > write_limit) & (code = 0)); /* space to proper component */ old_pos = write_pos; /* save position */ call new_seg_write; /* write out seg, and get new one */ write_pos, old_write_pos = old_pos - write_limit + 1; end_seg = write_pos; end; if code = 0 /* only continue if no errors */ then do; /* output the characters */ current_state = write_state; call put_chars_uns_file (iocb_ptr, buff_ptr, buff_len, code); /* output */ return; /* done */ end; end; else if append_sw /* -append attachment */ then do; /* go to end of file and change to write state */ call position_eof; /* sets tail_len to 0 */ write_pos, old_write_pos = end_seg; /* changes to write state */ current_state = write_state; end; else if ^no_trunc_sw /* did not use -no_trunc option */ then call truncate_and_change_to_write; else do; /* rewrite and possibly append */ if buff_len <= 0 then return; /* no-op in this case */ if tail_len > 0 /* not yet at end of seg */ then do; /* replace bytes in tail */ len = min (tail_len, buff_len); /* may need next comp */ old_pos = read_pos; /* start at read position */ record_write = buffer; /* move buffer contents */ read_pos = read_pos + len; /* advance next position */ tail_len = tail_len - len; /* fewer chars remain */ if buff_len > len /* part of buffer not moved */ then call put_chars_uns_file (iocb_ptr, addr (buff_tail), buff_len - len, code); /* move rest of buffer */ return; /* finished put operation */ end; else do; /* end of segment case */ call next_seg_read; /* looks for next component */ if code ^= 0 /* end of file */ then do; write_pos, old_write_pos = end_seg; /* change to write state */ current_state = write_state; code = 0; /* not an error */ end; end; end; if code = 0 then call put_chars_uns_file (iocb_ptr, buff_ptr, buff_len, code); end; current_state = write_state; return; /* end put chars routine */ prev_seg_read: proc; /* moves position to end of previous component */ call msf_manager_$get_ptr (fcb_ptr, component - 1, "0"b, next_seg_ptr, bitcount, foo); if next_seg_ptr = null then do; code = error_table_$bad_file; return; end; else do; seg_ptr = next_seg_ptr; component = component - 1; read_pos = divide (bitcount + 8, 9, 21, 0) + 1; /* position at end of seg */ end_seg = read_pos; tail_len = 0; if (header_is_present) & (component = 0) then base_pos = -4 * size (header); /* offsets header at file base */ else base_pos = base_pos - end_seg + 1; /* subtract contents of prev segment */ end; end prev_seg_read; new_seg_write: proc; if ssf_sw /* prevents adding new component */ then do; /* flag the error */ code = error_table_$file_is_full; return; end; if ^is_msf /* single segment */ then do; call msf_manager_$open (substr (attach_descrip_string, 8, dname_len), substr (attach_descrip_string, 9 + dname_len, ename_len), fcb_ptr, foo); is_msf = "1"b; atb.fcbp = fcb_ptr; end; call msf_manager_$get_ptr (fcb_ptr, component + 1, "1"b, next_seg_ptr, foo24, foo); if next_seg_ptr = null then code = foo; else do; call hcs_$set_bc_seg (seg_ptr, 9 * (write_limit - 1), foo); seg_ptr = next_seg_ptr; component = component + 1; write_pos, old_write_pos = 1; base_pos = base_pos + write_limit - 1; /* set base position of new comp */ end_seg = 1; read_pos = 1; code = 0; end; end; /* end new_seg_write */ set_end_pos: proc; /* determines number of bytes in file */ if is_new_file then end_pos = 0; /* file is empty */ else do; /* get last component, set end_pos , and reset position if necessary */ call position_eof; /* finds last component */ end_pos = base_pos + end_seg - 1; /* base pos was set by position_eof */ if (mode = 1) | ((mode = 3) & (append_sw | no_trunc_sw)) /* bof at open */ then call position_bof; /* resets positions */ end; end set_end_pos; truncate_and_change_to_write: proc; end_seg = read_pos; write_pos, old_write_pos = end_seg; current_state = write_state; tail_len = 0; call hcs_$set_bc_seg (seg_ptr, 9 * (end_seg - 1), foo); if ^is_msf then call hcs_$truncate_seg (seg_ptr, divide (end_seg + 2, 4, 18, 0), foo); else call msf_manager_$adjust (fcb_ptr, component, 9 * (end_seg - 1), "010"b, foo); end; /* end truncate_and_change_to_write */ get_current_state: proc; if write_pos = beyond_limits then do; current_state = read_state; return; end; if write_pos ^= old_write_pos /* fast_put has done some work */ then do; current_state = write_state; return; end; if current_state = beyond_eof_state then return; current_state = write_state; return; end get_current_state; /* for debugging display_uns_cb: proc; call ioa_ ( "uns_cb: ^p ^- current_state: ^d ^- write_limit: ^d ^- is_msf: ^b", open_data_ptr, current_state, write_limit, is_msf); call ioa_ ( "ptrs: ^-fcb: ^p ^-file_base: ^p ^-comp num: ^d ^-seg: ^p", fcb_ptr, file_base_ptr, component, seg_ptr ); call ioa_ ( "read_pos: ^d ^-tail_len: ^d ^-base_pos: ^d ^-end_pos: ^d", read_pos, tail_len, base_pos, end_pos ); call ioa_ ( "end_seg: ^d ^-write_pos: ^d ^-old_write_pos: ^d", end_seg, write_pos, old_write_pos ); return; end; */ /* DECLARATIONS FOR WHOLE PROGRAM */ dcl (vfile_io_control, vfile_status_$seg) entry (ptr, ptr, ptr, fixed (35)); dcl fast_put entry (ptr, ptr, fixed (21), fixed (35)); dcl max builtin; dcl addr builtin; dcl alloc_cb_file entry (fixed bin, ptr); dcl bitcount fixed bin (24); dcl buffer char (len) based (buff_ptr); /* len is length that will be used in data transfer */ dcl buff_len fixed bin (21); /* length as specified in call */ dcl buff_ptr ptr; dcl buff_tail char (buff_len - len) based (addr (buff_array (len + 1))); /* remainder of buffer after data transfer, its length is > 0 */ dcl buff_array (buff_len) char (1) based (buff_ptr); dcl 1 header based (seg_ptr), /* optional header for unstructured files */ 2 common_header_words, 3 file_code fixed, /* identifies file type */ 3 words (3) fixed, 2 identifier fixed (35), /* user defined field */ 2 words (11) fixed; /* for possible future use */ dcl uns_code static internal fixed init (31191); %include vf_attach_block; dcl order char (*); dcl info_ptr ptr; dcl 1 info based (info_ptr), /* used for "read_position" order */ 2 next_position fixed (34), /* absolute position of next byte */ 2 end_position fixed (34); /* total number of bytes in the file */ dcl 1 cb_uns_file based (open_data_ptr), 2 seg_ptr ptr, /* ptr to base of current segment in file */ 2 write_limit fixed bin (34), /* 1+(max size of first component) */ 2 beyond_limits fixed bin (34), /* max 34 bit number */ 2 fcb_ptr ptr, /* ptr to msf_manager control block */ 2 component fixed bin, /* component number for current seg */ 2 end_seg fixed bin (34), /* in read state = first byte beyond countents of current segment in write state is same for moment write state entered */ 2 read_pos fixed bin (34), /* in read state = next byte to be read, in write state is same as end_seg */ 2 tail_len fixed bin (34), /* in read state = number of bytes remaining in current seg, in write state = 0 */ 2 write_pos fixed bin (34), /* in read state = beyond_limits, in write state = next byte to be written. Hence write_pos = write_limit is end of segment condition for writing */ 2 base_pos fixed (34), /* absolute position of first byte in current seg */ 2 end_pos fixed (34), /* in read state gives total byte count of file */ 2 input_only bit (1) aligned, /* mode is stream_input */ 2 append_sw bit (1) aligned, /* -append attach option used */ 2 no_trunc_sw bit (1) aligned, /* -no_trunc option */ 2 header_is_present bit (1) aligned, /* -header option */ 2 ssf_sw bit (1) aligned, /* prevents growth to msf */ 2 is_msf bit (1) aligned, /* set when msf opened */ 2 file_base_ptr ptr, 2 noend bit (1) aligned, /* -no_end attach option */ 2 old_write_pos fixed (34), /* save of the previous write_pos to determine if fast_put did any writing */ 2 current_state fixed bin; /* what state the file is in at time of entry */ dcl close_x entry; dcl code fixed bin (35); dcl divide builtin; dcl dummy_buffer char (1); dcl error_table_$bad_file external fixed bin (35); dcl error_table_$short_record external fixed (35) static; dcl (error_table_$incompatible_attach, error_table_$file_is_full, error_table_$no_operation, error_table_$negative_nelem) fixed (35) external static; dcl error_table_$end_of_info external fixed bin (35); dcl error_table_$noentry external fixed bin (35); dcl error_table_$long_record external fixed bin (35); dcl error_table_$bad_arg external fixed bin (35); dcl fcb_ptr_arg ptr; dcl first_seg_ptr ptr; dcl first_seg_bitcount fixed bin (24); dcl foo fixed bin (35); dcl foo2 fixed bin (2); dcl foo24 fixed bin (24); dcl foo35 fixed bin (35); dcl free_cb_file entry (fixed bin, ptr); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed (35)); dcl hcs_$truncate_seg entry (ptr, fixed (18), fixed (35)); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed (35)); dcl hcs_$set_bc_seg entry (ptr, /* ptr to segment */ fixed bin (24), /* bitcount */ fixed bin (35)); /* status code */ dcl index builtin; dcl is_new_file bit (1) aligned; /* for debugging dcl ioa_ entry options (variable); */ dcl iocb_ptr ptr; /* for open and close entries this points to the actual iocb. for other entries it points to an iocb that may be syned */ dcl len fixed bin (21); /* length of string to be moved in one operation */ dcl len2 fixed bin (21); dcl max_component_size fixed bin (19); dcl min builtin; dcl mode fixed bin; /* = 1, 2, or 3 */ dcl msf_manager_$adjust entry (ptr, /* fcb_ptr */ fixed bin, /* component number of segment to be made last segment */ fixed bin (24), /* bitcount for that seg -- not reliable */ bit (3), /* "010" = don't set bit counts (use hcs_$set_bc_seg), truncate segment, dont terminate components */ fixed bin (35)); /* status code */ dcl msf_manager_$get_ptr entry (ptr, /* fcb_ptr */ fixed bin, /* component number of desired segment */ bit (1), /* create switch */ ptr, /* ptr to seg or null if error, output */ fixed bin (24), /* bitcount of segment, output */ fixed bin (35)); /* status code */ dcl null builtin; dcl next_seg_ptr ptr; dcl new_line static internal char (1) init (" "); dcl old_pos fixed bin (21); dcl pos_type fixed bin; dcl record_read char (len) based (addr (seg (read_pos))); dcl record_write char (len) based (addr (seg (old_pos))); dcl rec_len fixed bin (21); dcl seg (1048576) char (1) based (seg_ptr); dcl skip fixed (34); dcl size builtin; /* state variables */ dcl read_state fixed bin init (1); dcl beyond_eof_state fixed bin init (2); dcl write_state fixed bin init (3); %include iocbv; /* GENERAL COMMENTS This external procedure implements io to-from unstructured files. The entries open and close are called from open_file and close_file, see vfile_attach . They setup (respectively free) the control block, which the other entries access through open_data_ptr in the actual iocb. The other entries are called through the iocb. The code for each entry immediately follows the entry and terminates with a return statement. Before reading the code, familiarize yourself with the general conventions for implementing attachments (see the MPM), and the specs for the operations. At the beginning (and again at the end) of an operation (e.g. get_line), the control block is in either the read state or the write state. See the declaration of cb_uns_file for details. The two states are distinguished by the value of write_pos, but there are other differences as well. The general method for each operation is to test for the nonexceptional case, control block in the correct state and the buffer not too long for the remainder of the segment. In the exceptional cases some progress is made, i.e. some data is transferred, or the contro blocks state is changed, or a new segment is obtained. Then the operation is completed by a recursive call. */ /* changes due to implimenting of the -no_end option: 1. operations were changed to accept the idea of being beyond end-of-file (eof) 2. the positioning to allow the changing of write_pos to be greater than the end_pos 3. a way of identifying the state of the file 4. a new state of the file was added: beyond eof 5. the write_pos needed to be stored away in another place to be able to determine that fast_put had done some work, and therefore the file was in write state 6. mostly in need of determining if there was a problem in msf_manager_ changes were made to allow error codes other than expected to reflect through */ end /* end of open_uns_file program */;  record_stream_attach_.pl1 09/10/87 1507.0rew 09/10/87 1445.7 176031 /****^ *********************************************************** * * * 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(84-08-22,Ranzenbach), approve(), audit(), install(): Modified to call unique_chars_. 2) change(87-07-01,GWMay), approve(87-07-01,MCR7730), audit(87-09-10,GDixon), install(87-09-10,MR12.1-1104): Completely restructured the code. Added any_other handlers. Changed the close routine to always close the control block. Changed the detach routine to always detach the control block. Changed recursive call for -target attachment to a nonrecursive method. END HISTORY COMMENTS */ /* format: off */ %page; /* main program of record_stream_ io module */ record_stream_attach: proc (Piocb_ptr, /* (input) - control block pointer */ option_array, /* (input) - control arguments */ Pcom_err, /* (input) - ON = report errors */ Pcode); /* (output)- error status */ iocb_ptr = Piocb_ptr; Scom_err = Pcom_err; call initialize$attach(); if iocb.attach_descrip_ptr ^= null then call CHECK_CODE_return_on_error (error_table_$not_detached, ME, "^a", iocb.name); call get_args (); /* create and initialize rs attach block, with cleanup handler for block */ rsab_ptr = null; on cleanup call record_stream_detach_ (); EXIT = EXIT_WITH_DETACH; call alloc_cb_file (size (rs_attach_block), rsab_ptr); /* If the -target option is present. Attach the target descrip. */ if target_args ^= "" then do; rs_attach_desc.switch_name = "rs_" || unique_chars_ ("0"b); rs_attach_block.i_attached_target = TRUE; call iox_$attach_name (rs_attach_desc.switch_name, rs_attach_block.target_iocb_ptr, (target_args), null, code); call CHECK_CODE_return_on_error (code, ME, "Target attach description failed:^/^a", target_args); end; /* Otherwise, find target IOCB. */ else do; rs_attach_block.i_attached_target = FALSE; call iox_$find_iocb (rs_attach_desc.switch_name, rs_attach_block.target_iocb_ptr, code); call CHECK_CODE_return_on_error (code, ME, "Looking for target IOCB ^a", rs_attach_desc.switch_name); end; rs_attach_block.attach_descrip_string = rs_attach_desc.module_name || rtrim(rs_attach_desc.switch_name) || rtrim(rs_attach_desc.args); rs_attach_block.attach_descrip_len = length (rtrim (rs_attach_block.attach_descrip_string)); rs_attach_block.target_name = rs_attach_desc.switch_name; rs_attach_block.length_n = arg_record_length; rs_attach_block.open_descrip_len = 0; rs_attach_block.open_descrip_string = ""; rs_attach_block.mode = 0; rs_attach_block.i_opened_target = FALSE; rs_attach_block.base = 0; rs_attach_block.n_left = 0; /* Set the iocb to the attach state */ ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); iocb.attach_data_ptr = rsab_ptr; iocb.attach_descrip_ptr = addr (rs_attach_block.attach_descrip); iocb.detach_iocb = record_stream_detach; iocb.open = record_stream_open; iocb.modes = record_stream_modes; iocb.control = record_stream_control; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); EXIT_BY_RETURN: return; EXIT_WITH_DETACH: call record_stream_detach_(); return; %page; get_args: proc (); arg_record_length = 0; rs_attach_desc.module_name = ME; rs_attach_desc.switch_name = ""; rs_attach_desc.args = ""; target_args = ""; do i = 1 to hbound (option_array, 1); code = 0; if option_array (i) = "-no_newline" | option_array (i) = "-nnl" then arg_record_length = -1; else if option_array (i) = "-length" | option_array (i) = "-ln" then do; if i + 1 > hbound (option_array, 1) then call CHECK_CODE (error_table_$noarg, ME, "^/^a requires a positive integer value.", option_array (i)); else do; i = i + 1; arg_record_length = cv_dec_check_ ((option_array (i)), ercode); if ercode ^= 0 | arg_record_length <= 0 | arg_record_length > CHARS_PER_SEGMENT then call CHECK_CODE (error_table_$bad_arg, ME, "^/^a ^a. The value must be a positive integer less than ^d.", option_array (i - 1), option_array (i), CHARS_PER_SEGMENT+1); end; end; else if option_array (i) = "-target" then do; /* Build the attach description for the target I/O module. */ if i + 1 > hbound (option_array, 1) then call CHECK_CODE (error_table_$noarg, ME, "^a requires an attach description operand.", option_array(i)); else do; i = i + 1; target_args = target_args || option_array (i); do i = i + 1 to hbound (option_array, 1); target_args = target_args || " "; target_args = target_args || requote_string_ ((option_array (i))); end; end; end; else if i = 1 then do; /* switch name must be in position 1*/ if length (option_array (i)) > length(rs_attach_desc.switch_name) then call CHECK_CODE (error_table_$bigarg, ME, "^/Target switch name value is longer than ^a characters: ^a.", length(rs_attach_desc.switch_name), option_array (i)); else rs_attach_desc.switch_name = option_array (i); end; else if index (option_array(i), "-") = 1 then call CHECK_CODE (error_table_$bad_opt, ME, "^a", option_array (i)); else call CHECK_CODE (error_table_$bad_arg, ME, "^a", option_array (i)); end; if rs_attach_desc.switch_name = "" then do; if target_args = "" then call CHECK_CODE (error_table_$noarg, ME, "Target switch name"); end; else if target_args ^= "" then call CHECK_CODE (error_table_$bad_arg, ME, "^/Cannot give both a target switch name and -target attach description."); if Serror_occurred then go to EXIT; if arg_record_length < 0 then /* leading space separates switch */ rs_attach_desc.args = " -nnl";/* name from control args in attach */ else /* description. */ if arg_record_length > 0 then rs_attach_desc.args = " -length " || ltrim (char (arg_record_length)); return; end get_args; %page; record_stream_open: entry (Piocb_ptr, /* (input) - control block pointer */ open_mode, /* (input) - opening mode(sqi etc.) */ Sextend, /* (input) - ON = add to the file */ Pcode); /* (output)- error status */ dcl open_mode fixed bin parameter, Sextend bit (1) aligned parameter; call initialize; /* verify open args & set descript. */ if open_mode < lbound (iox_modes, 1) | open_mode > hbound(iox_modes, 1) | Sextend then call CHECK_CODE_return_on_error (error_table_$bad_arg, ME); else if open_mode = Stream_input_output | open_mode > Sequential_output then call CHECK_CODE_return_on_error (error_table_$bad_mode, ME); else if open_mode = Stream_output | open_mode = Sequential_input then do; if rs_attach_block.length_n < 0 then call CHECK_CODE_return_on_error ( error_table_$invalid_record_length, ME); end; else if open_mode = Sequential_output | open_mode = Stream_input then do; if rs_attach_block.length_n > 0 then call CHECK_CODE_return_on_error ( error_table_$invalid_record_length, ME); end; /* The open_mode is valid set the open description */ rs_attach_block.mode = open_mode; rs_attach_block.open_descrip_len = length (rtrim (iox_modes (open_mode))); rs_attach_block.open_descrip_string = iox_modes (open_mode); %page; /* If the target switch exists, find out how the targets was opened. */ if rs_attach_block.target_iocb_ptr = null then call CHECK_CODE_return_on_error (error_table_$no_iocb, ME); target_open_mode_ptr = rs_attach_block.target_iocb_ptr -> iocb.open_descrip_ptr; if target_open_mode_ptr ^= null then target_open_mode = before (target_open_mode, SPACE); /* If switch is its own target report the error -- looping attachment */ if iocb_ptr -> iocb.actual_iocb_ptr = rs_attach_block.target_iocb_ptr -> iocb.actual_iocb_ptr then call CHECK_CODE_return_on_error (error_table_$att_loop, ME); /* Set i_opened_target before the cleanup handler. */ if rs_attach_block.target_iocb_ptr -> iocb.open_descrip_ptr = null then rs_attach_block.i_opened_target = TRUE; on cleanup call record_stream_close_ (); EXIT = EXIT_WITH_CLOSE; /* If not open, open the target switch else check its current open mode. */ /* Open the target switch using the opposite mode of what was input. */ if rs_attach_block.i_opened_target then call iox_$open (rs_attach_block.target_iocb_ptr, (op_mode (rs_attach_block.mode)), "0"b, code); else /* target already opened */ if (target_open_mode ^= iox_modes (op_mode (rs_attach_block.mode))) & (target_open_mode ^= iox_modes (op_io_mode (rs_attach_block.mode))) then code = error_table_$incompatible_attach; call CHECK_CODE_return_on_error (code, ME); %page; /* Non-Sequential outputs require an internal buffer. */ if rs_attach_block.mode ^= Sequential_output then do; call get_temp_segment_ (ME, iocb.open_data_ptr, code); call CHECK_CODE_return_on_error (code, ME); end; /* call initialization routine appropriate to opening mode */ ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); if rs_attach_block.mode = Stream_input then call rs_open_str_in_ (iocb_ptr); else if rs_attach_block.mode = Stream_output then call rs_open_str_out_ (iocb_ptr); else if rs_attach_block.mode = Sequential_input then call rs_open_seq_in_ (iocb_ptr); else call rs_open_seq_out_ (iocb_ptr); /* Set up the iocb entries */ iocb.open_descrip_ptr = addr (rs_attach_block.open_descrip); iocb.close = record_stream_close; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); return; EXIT_WITH_CLOSE: call record_stream_close_(); return; %page; record_stream_close: entry (Piocb_ptr, /* (input) control block pointer */ Pcode); /* (output) error status */ call initialize; call record_stream_close_ (); call CHECK_CODE_return_on_error (code, ME); return; record_stream_close_: proc (); /* This is an internal procedure so that the open entry can use it in its cleanup handler. */ /* If Stream_output, the target is open for sequential output. Flush the temp work buffer. */ if rs_attach_block.mode ^= Sequential_output then do; if rs_attach_block.mode = Stream_output & rs_attach_block.n_left > 0 then call iox_$write_record (rs_attach_block.target_iocb_ptr, iocb.open_data_ptr, rs_attach_block.n_left, code); if iocb.open_data_ptr ^= null then call release_temp_segment_ (ME, iocb.open_data_ptr, ercode); end; if rs_attach_block.i_opened_target then do; call iox_$close (rs_attach_block.target_iocb_ptr, ercode); if code = 0 then code = ercode; end; ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); iocb.open_descrip_ptr = null; iocb.open_data_ptr = null; iocb.detach_iocb = record_stream_detach; iocb.open = record_stream_open; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); return; end record_stream_close_; %page; record_stream_detach: entry (Piocb_ptr, /* (input) - control block pointer */ Pcode); /* (output)- error status */ call initialize(); call record_stream_detach_ (); call CHECK_CODE_return_on_error (code, ME); return; record_stream_detach_: proc (); /* This is an internal procedure so that the attach entry can use it in its cleanup handler. */ /* detach target if it was attached with the -target option */ if rsab_ptr = null then return; if rs_attach_block.i_attached_target then do; call iox_$detach_iocb (rs_attach_block.target_iocb_ptr, code); call iox_$destroy_iocb (rs_attach_block.target_iocb_ptr, ercode); end; ips_mask = ""b; on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask); call hcs_$set_ips_mask ("0"b, ips_mask); iocb.attach_data_ptr = null; iocb.attach_descrip_ptr = null; call iox_$propagate (iocb_ptr); call hcs_$reset_ips_mask (ips_mask, ips_mask); call free_cb_file (size (rs_attach_block), rsab_ptr); rsab_ptr = null; return; end record_stream_detach_; %page; record_stream_modes: entry (Piocb_ptr, /* (input) - control block pointer */ new_modes, /* (input) - modes to set to */ old_modes, /* (output)- current modes */ Pcode); /* (output)- error status */ dcl new_modes char (*) parameter, old_modes char (*) parameter; call initialize; call iox_$modes (rs_attach_block.target_iocb_ptr, new_modes, old_modes, Pcode); /* pass call to target */ return; %page; record_stream_control: entry (Piocb_ptr,/* (input) - control block pointer */ order, /* (input) - requested order */ info_ptr, /* (input) - info for the control et*/ Pcode); /* (output)- error status */ dcl order char(*) parameter, info_ptr ptr parameter; call initialize; call iox_$control (rs_attach_block.target_iocb_ptr, order, info_ptr, Pcode); /* pass call to target */ return; %page; initialize: proc; /* internal procedure for initializing pointers and other variables */ iocb_ptr = Piocb_ptr -> iocb.actual_iocb_ptr; rsab_ptr = iocb.attach_data_ptr; Scom_err = FALSE; initialize$attach: entry; Pcode, code = 0; Serror_occurred = FALSE; EXIT = EXIT_BY_RETURN; return; end initialize; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This procedure examines its code parameter. If it is nonzero, it sets */ /* the code output parameter of the current external entrypoint. It */ /* optionally prints an error message. Execution stops (via nonlocal goto) */ /* for nonzero codes passed to CHECK_CODE_return_on_error. If code is 0, */ /* these programs do nothing but return to their caller. */ /* */ /* Syntax: call CHECK_CODE (code, program_name, ioa_ctl_str, ioa_args); */ /* call CHECK_CODE_return_on_error */ /* (code, program_name, ioa_ctl_str, ioa_args); */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ CHECK_CODE: proc options(variable); dcl error_code fixed bin(35) based (p_error_code), p_error_code ptr; dcl Sfatal bit (1) aligned; dcl cu_$arg_list_ptr entry returns(ptr), cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)), cu_$generate_call entry (entry, ptr); Sfatal = FALSE; go to ERROR_COMMON; CHECK_CODE_return_on_error: entry options (variable); Sfatal = TRUE; ERROR_COMMON: call cu_$arg_ptr (1, p_error_code, 0, 0); if error_code = 0 then return; if Pcode = 0 then /* set output code parameter if it */ Pcode = error_code; /* hasn't been set before. */ if Scom_err then call cu_$generate_call (com_err_, cu_$arg_list_ptr()); Serror_occurred = TRUE; if Sfatal then go to EXIT; return; end CHECK_CODE; %page; /* parameters */ dcl Piocb_ptr ptr parameter, Pcom_err bit (1) aligned parameter, Pcode fixed bin (35) parameter, option_array(*) char (*) varying parameter; /* automatic */ dcl EXIT label variable, Scom_err bit (1) aligned, Serror_occurred bit (1) aligned, arg_record_length fixed bin (35), code fixed bin(35), ercode fixed bin (35), i fixed bin, ips_mask bit(36) aligned, 1 rs_attach_desc aligned, 2 module_name char (15), 2 switch_name char (32) unal, 2 args char (20), target_args char (1024) varying; /* based */ dcl target_open_mode_ptr ptr, target_open_mode char (24) varying based (target_open_mode_ptr); /* entries */ dcl alloc_cb_file entry (fixed bin, ptr), cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35)), com_err_ entry() options(variable), get_temp_segment_ entry (char(*), ptr, fixed bin(35)), free_cb_file entry (fixed bin, ptr), hcs_$reset_ips_mask entry (bit(36) aligned, bit(36) aligned), hcs_$set_ips_mask entry (bit(36) aligned, bit(36) aligned), release_temp_segment_ entry (char(*), ptr, fixed bin(35)), requote_string_ entry (char(*)) returns(char(*)), rs_open_seq_in_ entry (ptr), rs_open_seq_out_ entry (ptr), rs_open_str_in_ entry (ptr), rs_open_str_out_ entry (ptr), unique_chars_ entry (bit(*)) returns(char(15)); /* external static */ dcl (error_table_$att_loop, error_table_$bad_arg, error_table_$bad_opt , error_table_$bad_mode, error_table_$bigarg, error_table_$incompatible_attach, error_table_$invalid_record_length, error_table_$no_iocb, error_table_$noarg, error_table_$not_detached) fixed bin(35) ext static; /* internal static */ dcl FALSE bit (1) aligned internal static options (constant) init ("0"b); dcl ME char (14) internal static options (constant) init ("record_stream_"); dcl TRUE bit (1) aligned internal static options (constant) init ("1"b); dcl SPACE char (1) aligned internal static options (constant) init (" "); dcl op_io_mode (5) fixed bin internal static options (constant) init (6, 6, 6, 3, 3); dcl op_mode (5) fixed bin internal static options (constant) init (4, 5, 6, 1, 2); /* builtins */ dcl (addr, before, char, hbound, index, lbound, length, ltrim, null, rtrim, size) builtin; /* conditions */ dcl (any_other, cleanup) condition; %page; %include rs_attach_block; %page; dcl iocb_ptr ptr; %include iocbv; %page; %include iox_dcls; %page; %include iox_modes; %page; %include system_constants; %page; %include sub_err_flags; end record_stream_attach;  restart.pl1 10/16/90 1526.9rew 10/16/90 1518.1 135540 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-10-12,Zimmerman), approve(90-10-12,MCR8216), audit(90-10-15,Zwick), install(90-10-16,MR12.4-1043): Data_Mgt 63 (phx21194): Raise the max number of components in an MSF to 1250. END HISTORY COMMENTS */ restart: proc (iocb_ptr, code); /* tries to complete interrupted operation */ indx_cb_ptr = open_data_ptr; f_b_ptr = file_base_ptr; fs_ptr = file_state_ptr; call save_restart_proc_info; on cleanup call restore_restart_proc_info; indx_cb.mode = 10; /* ksu */ indx_cb.min_res = saved_min_res; indx_cb.min_cap = saved_min_cap; indx_cb.outside_index = file_base.out_of_index; indx_cb.current_descrip = file_base.old_record_designator; indx_cb.stat = file_base.was_stat; indx_cb.trans = "0"b; repeating = "1"b; indx_cb.shared = "0"b; indx_cb.subset_selected = "00"b; indx_cb.current_record_is_valid = "1"b; pos_incorrect = "0"b; indx_cb.dup_ok = "1"b; indx_cb.next_record_position = 1; if (file_action = adjust_action) | (file_action = rollback_action) then do; if ^((file_action = rollback_action) & (file_base.old_prev_mod = -3) & (file_base.old_ref_count <= 0)) /* not total collection of storage */ then call lock_record (file_base.old_record_designator); call open_indx_file$adjust_record (iocb_ptr, file_base.old_record_designator, 0, code); end; else if file_action = replace_action then call restart_replacement; else if file_action = reassigning_key then call restart_reassignment; else do; call restore_old_proc_info; if file_action = insert_action then call restart_insertion; else if file_action = delete_action then do; if file_base.was_stat & (file_base.is_partial_deletion | (file_base.old_modifier > 0) | (file_base.old_ref_count > fixed (^file_base.out_of_index))) /* not case of total collection, including stationary header */ then call lock_record (file_base.old_record_designator); /* else protect this storage--don't clobber free list */ call open_indx_file$delete_indx_file (iocb_ptr, code); end; else if file_action = adding_key then call restart_add_key; else if file_action = deleting_key then do; indx_cb.outside_index = "0"b; if file_base.was_stat /* watch out for low level synch */ then call lock_record (file_base.old_record_designator); call open_indx_file$control_indx_file (iocb_ptr, "delete_key", null, code); end; else if file_action = adding_record then call restart_rs_create; else if file_action = bumping_count then do; file_base.change_count = file_base.old_file_ch_count + 1; file_action = 0; end; else code = error_table_$bad_file; end; call restore_restart_proc_info; if indx_cb.file_state_ptr -> file_action = 0 then code = 0; else if code = 0 then code = error_table_$bad_file; return; /* end of restart routine */ save_restart_proc_info: proc; saved_state = indx_cb.state_vars; saved_subset_selected = indx_cb.subset_selected; was_ks_out = is_ks_out; my_min_res = indx_cb.min_res; my_min_cap = indx_cb.min_cap; was_stat = indx_cb.stat; was_dup_ok = indx_cb.dup_ok; was_trans = indx_cb.trans; old_mode = indx_cb.mode; return; restore_restart_proc_info: entry; indx_cb.state_vars = saved_state; indx_cb.subset_selected = saved_subset_selected; repeating = "0"b; is_ks_out = was_ks_out; indx_cb.min_res = my_min_res; indx_cb.min_cap = my_min_cap; file_base.max_comp_num = true_max_comp_num; indx_cb.pos_incorrect = "1"b; indx_cb.stat = was_stat; indx_cb.dup_ok = was_dup_ok; indx_cb.trans = was_trans; indx_cb.mode = old_mode; end save_restart_proc_info; restore_old_proc_info: proc; if ^(indx_cb.outside_index & ((file_action = delete_action) | (file_action = adding_record))) then do; /* restore position stack */ is_ptr = index_state_ptr; p = root_position_ptr; file_position_ptr = p; change_position_ptr = p; do i = 1 to index_height; p = p -> son_position_ptr; p -> node = saved_node (i); p -> branch_num = saved_branch_num (i); p -> node_ptr = get_ptr (p -> node); if p -> node = current_node then file_position_ptr = p; if p -> node = change_node then change_position_ptr = p; end; end; is_ks_out = saved_ks_out; indx_cb.ready_to_write = "1"b; dcl p ptr; dcl i fixed; end restore_old_proc_info; restart_add_key: proc; /* recovers from interrupted add_key operation */ indx_cb.current_descrip = file_base.new_descriptor; if file_base.was_stat then call lock_record (indx_cb.current_descrip); indx_cb.outside_index = "0"b; string (ak_inf.flags) = "00"b; call open_indx_file$control_indx_file (iocb_ptr, "add_key", addr (ak_inf), code); end restart_add_key; restart_rs_create: proc; /* finish allocation, then delete */ if file_base.out_of_index /* no key with the record--always delete since user can't find this record */ then do; if file_substate = 0 then indx_cb.repeating = "0"b; else indx_cb.next_substate = 0; call change_record_list (iocb_ptr, allocate_action, null, abort_exit); file_base.old_record_designator = file_base.new_descriptor; file_base.old_ref_count = 0; file_base.change_count = file_base.old_file_ch_count + 1; call change_record_list (iocb_ptr, delete_action, null, abort_exit); file_action = 0; return; end; if file_base.was_stat then call lock_record (file_base.new_descriptor); rs_inf.record_length = new_record_length; rs_inf.max_rec_len = saved_min_cap; unspec (rs_inf.flags) = "0"b; rs_inf.inc_ref_count = (file_base.was_stat & (file_base.old_ref_count = 2)); rs_inf.create_sw = "1"b; rs_inf.locate_sw = out_of_index; rs_inf.version = rs_info_version_2; call open_indx_file$control_indx_file (iocb_ptr, "record_status", addr (rs_inf), code); end restart_rs_create; restart_replacement: proc; /* finish interrupted replace operation */ call reinit_rewrite_proc; if ^file_base.was_stat /* non-stationary type record rewritten */ then do; /* see if contents may be invalid */ old_rec_ptr = get_rec_ptr (old_record_designator); if (fixed (old_rec_des.offset) + 2 + divide (new_record_length + 3, 4, 21, 0)) > max_seg_limit then new_rec_ptr = file_base_ptr; /* avoids seg_fault */ else new_rec_ptr = old_rec_ptr; if ((old_record_length ^= new_record_length) | (file_substate > 1) | (old_record_designator ^= new_descriptor)) & (new_record_length > 0) then if ^indx_cb.outside_index then call sub_err_ (0, "vfile_", "c", null, code, "Record contents may be incorrect for key: ^a", substr (keys, key_pos (branch_num), key_length (branch_num))); else call sub_err_ (0, "vfile_", "c", null, code, "Record contents may be incorrect for record with descriptor: ^o", old_record_designator); end; else do; call lock_record (file_base.old_record_designator); if file_base.change_count = file_base.old_file_ch_count /* op will be undone */ then do; /* undo the rewrite--old stuff still is intact */ if file_base.new_record_length + indx_cb.min_res + indx_cb.min_cap > 0 then do; if file_substate = 1 then indx_cb.repeating = "0"b; else indx_cb.next_substate = 1; call change_record_list (iocb_ptr, allocate_action, f_b_ptr, abort_exit); call change_record_list (iocb_ptr, free_action, null, abort_exit); end; block_ptr -> stat_block.lock_flag = "0"b; block_ptr -> stat_structure.modifier = -1; file_action = bumping_count; file_base.change_count = file_base.old_file_ch_count + 1; file_action = 0; /* now just unlock the record */ block_ptr = get_pointer (file_base.old_record_designator); block_ptr -> stat_block.modifier = 0; if stacq (block_ptr -> stat_block.record_lock, "0"b, indx_cb.saved_lock_copy) /* clear record lock */ then ; return; end; else if file_base.new_descriptor > 0 then new_rec_ptr = get_rec_ptr (file_base.new_descriptor); else new_rec_ptr = null; end; call open_indx_file$rewrite_indx_file (iocb_ptr, new_rec_ptr, new_record_length, code); end restart_replacement; reinit_rewrite_proc: proc; /* set up position info */ file_position_ptr = root_position_ptr -> son_position_ptr; node = first_branch; branch_num = count; node_ptr = get_ptr (node); end reinit_rewrite_proc; restart_reassignment: proc; if file_base.was_stat then do; block_ptr = get_pointer (file_base.old_record_designator); if block_ptr ^= null then if block_ptr -> record_block_structure.stationary then call lock_record (file_base.old_record_designator); new_block_ptr = get_pointer (file_base.new_descriptor); if new_block_ptr ^= null then if new_block_ptr -> record_block_structure.stationary then call lock_record (file_base.new_descriptor); end; indx_cb.outside_index = "0"b; string (rk_inf.flags) = "001"b; /* input new descrip */ rk_inf.new_descrip = file_base.new_descriptor; call reinit_rewrite_proc; /* finds index position */ call open_indx_file$control_indx_file (iocb_ptr, "reassign_key", addr (rk_inf), code); end restart_reassignment; restart_insertion: proc; /* finish interrupted write operation */ if file_base.change_count = file_base.old_file_ch_count /* buffer may not be saved yet */ then do; /* undo any allocation */ if file_base.was_stat | (file_base.new_record_length + file_base.saved_min_cap + file_base.saved_min_res > 0) /* allocation was required */ then do; /* restart, then reverse */ if file_substate = 1 then indx_cb.repeating = "0"b; else indx_cb.next_substate = 1; /* tracking variable--set_add_ent_info routine must have been used */ call change_record_list (iocb_ptr, insert_action, null, abort_exit); file_base.old_record_designator = file_base.new_descriptor; file_base.out_of_index = "0"b; file_base.is_partial_deletion = "0"b; call change_record_list (iocb_ptr, delete_action, null, abort_exit); end; file_action = bumping_count; file_base.change_count = file_base.old_file_ch_count + 1; file_action = 0; return; end; if file_base.new_descriptor <= 0 then new_rec_ptr = null; else do; new_rec_ptr = get_rec_ptr (file_base.new_descriptor); if file_base.was_stat then new_rec_ptr = addrel (new_rec_ptr, 6); /* larger header */ end; call open_indx_file$write_indx_file (iocb_ptr, new_rec_ptr, new_record_length, code); end restart_insertion; get_ptr: proc (designator_arg) returns (ptr); return (addr (seg_ptr_array (des_arg.comp_num) -> seg_array (fixed (des_arg.offset)))); dcl designator_arg fixed (35); dcl 1 des_arg like designator_struct aligned based (addr (designator_arg)); end; get_rec_ptr: proc (designator_arg) returns (ptr); return (addrel (get_pointer (designator_arg), 2)); dcl designator_arg fixed (35); end get_rec_ptr; get_pointer: proc (designator_arg) returns (ptr); return (addr (get_seg_ptr (iocb_ptr, (des_arg.comp_num)) -> seg_array (fixed (des_arg.offset)))); dcl designator_arg fixed (35); dcl 1 des_arg like designator_struct aligned based (addr (designator_arg)); end get_pointer; lock_record: proc (designator_arg); if designator_arg <= 0 then return; blockp = get_pointer (designator_arg); if blockp = null then return; call set_lock_$lock (blockp -> stat_structure.record_lock, 0, code); if (code = 0) | (code = error_table_$invalid_lock_reset) | (code = error_table_$locked_by_this_process) then do; code = 0; return; end; if file_action = reassigning_key then if block_ptr ^= null then if block_ptr -> record_block_structure.stationary then if stacq (block_ptr -> stat_structure.record_lock, (36)"1"b, indx_cb.saved_lock_copy) then ; /* invalidate other lock, if I set it */ code = error_table_$file_busy; call restore_restart_proc_info; go to exit; dcl designator_arg fixed (35); dcl blockp ptr; end lock_record; abort_exit: code = error_table_$file_is_full; call restore_restart_proc_info; if (file_action ^= replace_action) then return; block_ptr = get_pointer (file_base.old_record_designator); if stacq (block_ptr -> stat_block.record_lock, (36)"1"b, indx_cb.saved_lock_copy) then ; /* invalidate record lock */ exit: return; /* abort with error code set */ dcl current_program_version static options (constant) internal fixed init (31); dcl block_ptr ptr; dcl new_block_ptr ptr; dcl 1 stat_block based (block_ptr), 2 pad bit (22) unal, 2 lock_flag bit (1) unal, 2 pad2 bit (13) unal, 2 word, 2 record_lock bit (36) aligned, 2 modifier fixed (35); %include rs_info; %include ak_info; dcl 1 rk_inf, 2 header like rk_header; dcl 1 ak_inf based (addr (rk_inf)), 2 header like ak_header; dcl 1 rs_inf like rs_info; dcl sub_err_ entry options (variable); %include vfile_error_codes; dcl pos_ptr ptr defined (file_position_ptr); dcl code fixed (35); dcl iocb_ptr ptr; dcl open_indx_file$rewrite_indx_file entry (ptr, ptr, fixed (21), fixed (35)); dcl open_indx_file$adjust_record entry (ptr, fixed (35), fixed (35), fixed (35)); dcl open_indx_file$write_indx_file entry (ptr, ptr, fixed (21), fixed (35)); dcl open_indx_file$delete_indx_file entry (ptr, fixed (35)); dcl open_indx_file$control_indx_file entry (ptr, char (*), ptr, fixed (35)); dcl (old_rec_ptr, new_rec_ptr) ptr; dcl 1 old_rec_des like designator_struct aligned based (addr (old_record_designator)); dcl was_ks_out bit (1) aligned; dcl saved_subset_selected bit (2) aligned; dcl my_min_res fixed (21); dcl my_min_cap fixed (19); dcl was_stat bit (1) aligned; dcl was_dup_ok bit (1) aligned; dcl was_trans bit (1) aligned; dcl 1 saved_state like indx_cb.state_vars; dcl old_mode fixed; %include iocbv; %include vfile_indx; dcl cleanup condition; dcl set_lock_$lock entry (bit (36) aligned, fixed, fixed (35)); dcl (addrel, stacq, string) builtin; end restart;  rs_open_seq_in_.pl1 09/10/87 1507.0r w 09/10/87 1448.2 56520 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* record_stream_ program for handling sequential input openings */ rs_open_seq_in_: proc (iocb_ptr_arg, code); iocb_ptr = iocb_ptr_arg; /* set entries in iocb for valid operations in this mode */ read_record = read_record_rs; read_length = read_length_rs; position = position_seq_rs; return; /* end of opening routine */ read_record_rs: entry (iocb_ptr_arg, buff_ptr_arg, buff_len, rec_len, code); call initialize; buff_ptr = buff_ptr_arg; if n_left ^= 0 then /* internal buffer contains a record */ do; /* get record from rs_buffer */ if n_left > 0 then rec_len = n_left; else rec_len = 0; n_left = 0; /* set rs_buffer empty */ if rec_len > buff_len then code = error_table_$long_record; n_moved = min (rec_len, buff_len); if n_moved > 0 then substr (buffer, 1, n_moved) = substr (rs_buffer, 1, n_moved); end; /* record moved between buffers */ else /* rs_buffer empty */ if length_n > 0 then do; /* -length n case */ rec_len = 0; n_asked = min (buff_len, length_n); get_data: call iox_$get_chars (target_iocb_ptr, buff_ptr, n_asked, n_read, code); rec_len = rec_len + n_read; if code ^= 0 then if code = error_table_$short_record then do; /* pick up more chars */ n_asked = n_asked - n_read; buff_ptr = addr (buff (n_read + 1)); go to get_data; end; else go to eof_exit; else /* no errors yet */ if length_n > buff_len then /* long record case unless we are at EOF */ do; /* munch past record tail */ n_extra = length_n - buff_len; call iox_$get_chars (target_iocb_ptr, rs_buff_ptr, n_extra, n_read, code); rec_len = rec_len + n_read; if n_read > 0 then code = error_table_$long_record; else if code = error_table_$end_of_info then code = 0; /* short last record is OK */ end; end; /* end of -length n case */ else do; /* default case */ call iox_$get_line (target_iocb_ptr, buff_ptr_arg, buff_len, rec_len, code); if code = 0 then rec_len = rec_len - 1; /* delete newline char */ else if code ^= error_table_$long_record then do; /* check for short record */ eof_exit: if rec_len > 0 then code = 0; end; /* done */ else do; /* line is longer than input buffer */ call iox_$get_chars (target_iocb_ptr, addr (next_char), 1, n_read, code); if code = 0 then if substr (next_char, 1, 1) = newline /* avoids compiler bug */ then return; /* normal return */ else do; /* munch record tail */ rec_len = rec_len + 1; call iox_$get_line (target_iocb_ptr, rs_buff_ptr, max_bufsize, n_read, code); rec_len = rec_len + n_read; end; code = error_table_$long_record; end; /* entire record processed */ end; /* end of default case */ return; /* end of read record routine */ read_length_rs: entry (iocb_ptr_arg, rec_len, code); call initialize; if n_left = 0 /* rs_buffer is empty */ then do; /* get a new record */ call read_record_rs (iocb_ptr, rs_buff_ptr, max_bufsize, n_left, code); if (n_left = 0) & (code = 0) then n_left = -1; end; if n_left > 0 then rec_len = n_left; else rec_len = 0; return; /* end of read length routine */ position_seq_rs: entry (iocb_ptr_arg, type, count, code); call initialize; n = count; if type ^= 0 then do; /* bof and eof cases */ n_left = 0; /* discard rs_buffer contents */ pass_call: call iox_$position (target_iocb_ptr, type, n, code); /* pass call to target */ end; else do; /* skip case */ if n ^= 0 then do; /* skip n records */ old_n_left = n_left; if n_left ^= 0 then do; /* skip record in rs_buffer */ n = n - 1; n_left = 0; end; if length_n = 0 /* default case */ then go to pass_call; else /* -length case */ if n < 0 then do; /* error: no backwards skips */ code = error_table_$negative_nelem; n_left = old_n_left;/* restore rs_buffer */ end; else /* read past n records */ do while ((n > 0) & (code = 0)); call read_record_rs (iocb_ptr, rs_buff_ptr, max_bufsize, n_read, code); n = n - 1; end; end; /* n records skipped */ end; /* end of skip case */ return; /* end of seq position routine */ /* internal procedure for initializing pointers upon entry */ initialize: proc; iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr; rsab_ptr = attach_data_ptr; rs_buff_ptr = open_data_ptr; code = 0; return; end initialize; /* declarations for entire program */ dcl (iocb_ptr_arg, iocb_ptr) ptr; dcl code fixed bin (35); %include iocbv; %include rs_attach_block; %include rs_buffer; dcl (buff_ptr_arg, buff_ptr) ptr; dcl (buff_len, rec_len, n_moved) fixed (21); dcl (substr, min, addr) builtin; dcl error_table_$long_record external fixed (35); dcl error_table_$short_record external fixed (35); dcl (n_asked, n_read) fixed (21); dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl buffer char (buff_len) based (buff_ptr); dcl buff (buff_len) char (1) based (buff_ptr); dcl n_extra fixed (21); dcl error_table_$end_of_info external fixed (35); dcl next_char char (2); dcl newline char (1) static internal aligned init (" "); dcl type fixed; dcl (count, n, old_n_left) fixed (21); dcl iox_$position entry (ptr, fixed, fixed (21), fixed (35)); dcl error_table_$negative_nelem external fixed (35); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); end rs_open_seq_in_;  rs_open_seq_out_.pl1 09/10/87 1507.0r w 09/10/87 1447.6 14607 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* record_stream_ program for handling sequential output openings */ rs_open_seq_out_: proc (iocb_ptr_arg); iocb_ptr = iocb_ptr_arg; /* set iocb entries for valid operations in this mode and return */ write_record = write_record_rs; return; /* end of opening routine */ write_record_rs: entry (iocb_ptr_arg, buff_ptr, buff_len, code); iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr; rsab_ptr = attach_data_ptr; call iox_$put_chars (target_iocb_ptr, buff_ptr, buff_len, code); if length_n = 0 /* then append newline character */ then call iox_$put_chars (target_iocb_ptr, addr (newline), 1, code); return; /* end of sequential write routine */ /* declarations for entire program */ dcl (iocb_ptr_arg, iocb_ptr) ptr; dcl code fixed bin (35); %include rs_attach_block; %include iocbv; dcl buff_ptr ptr; dcl buff_len fixed bin (21); dcl buffer char (buff_len) based (buff_ptr); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl newline char (1) static internal aligned init (" "); end rs_open_seq_out_;  rs_open_str_in_.pl1 09/10/87 1507.0r w 09/10/87 1447.6 53037 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* record_stream_ program for handling stream input openings */ rs_open_str_in_: proc (iocb_ptr_arg); iocb_ptr = iocb_ptr_arg; /* set entries for valid operations in this mode */ get_chars = get_chars_rs; get_line = get_line_rs; position = position_str_rs; return; /* end of open initialization routine */ get_chars_rs: entry (iocb_ptr_arg, buff_ptr_arg, buff_len_arg, n_read, code); call init_args; if buff_len < 0 then code = error_table_$negative_nelem; do while ((buff_len > 0) & (code = 0)); /* get buff_len characters */ if n_left > 0 then /* internal buffer is not empty */ do; /* move chars between buffers */ n_moved = min (buff_len, n_left); call move; if n_moved = buff_len then do; /* normal return */ exit: base = base + n_moved; return; end; else /* more characters to be moved */ do; /* advance through input buffer */ buff_len = buff_len - n_moved; buff_ptr = addr (buff (n_moved + 1)); end; end; call get_record; end; return; /* end of get_chars routine */ get_line_rs: entry (iocb_ptr_arg, buff_ptr_arg, buff_len_arg, n_read, code); call init_args; if buff_len <= 0 then code = error_table_$smallarg; do while ((buff_len > 0) & (code = 0)); /* pick up remainder of line */ if n_left > 0 then /* internal buffer is not empty */ do; /* move line between buffers */ line_len = index (substr (rs_buffer, base, n_left), newline); if line_len = 0 then length = n_left; else length = line_len; n_moved = min (length, buff_len); call move; /* transfer n_moved chars from rs_buff to input buff */ if length > buff_len then do; /* error: line too long */ code = error_table_$long_record; go to exit; end; else if line_len > 0 /* newline has been found */ then go to exit; else /* keep looking for end of line */ do; /* advance through input_buffer */ buff_len = buff_len - n_moved; buff_ptr = addr (buff (n_moved + 1)); end; end; call get_record; /* rs_buffer empty-- get another record */ end; return; /* end of get_line routine */ position_str_rs: entry (iocb_ptr_arg, type, count, code); call brief_init; if type ^= 0 then do; /* position to start or end of file */ n_left = 0; /* flush rs_buffer */ call iox_$position (target_iocb_ptr, type, count, code); /* pass call to target */ end; else /* skip case */ do; /* skip n lines */ if count < 0 /* no backward skips permitted */ then code = error_table_$negative_nelem; n = count; do while ((n > 0) & (code = 0)); /* skip n lines */ if n_left <= 0 then call get_record; /* if rs_buffer is empty--fill it */ else /* internal buffer is not empty */ do; /* find newline in rs_buffer */ line_len = index (substr (rs_buffer, base, n_left), newline); if line_len > 0 then /* newline found */ do; /* successful skip */ base = base + line_len; n_left = n_left - line_len; n = n - 1; end; else n_left = 0; /* crunch past this record */ end; end; end; /* n lines skipped */ return; /* end of stream position routine */ /* internal procedures */ init_args: proc; /* initialize upon entry */ buff_len = buff_len_arg; buff_ptr = buff_ptr_arg; n_read = 0; brief_init: entry; code = 0; iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr; rsab_ptr = attach_data_ptr; rs_buff_ptr = open_data_ptr; return; end init_args; get_record: proc; /* read a new record into the rs_buffer appending newline if default attachment */ call iox_$read_record (target_iocb_ptr, rs_buff_ptr, max_bufsize, n_left, code); if code = 0 then do; base = 1; if length_n = 0 then /* default attachment */ do; /* append newline */ n_left = n_left + 1; substr (rs_buffer, n_left, 1) = newline; end; end; return; end get_record; move: proc; /* take n_moved chars from rs_buffer and append to input buffer */ substr (buffer, 1, n_moved) = substr (rs_buffer, base, n_moved); n_read = n_read + n_moved; n_left = n_left - n_moved; return; end move; /* declarations for entire program */ dcl (iocb_ptr_arg, iocb_ptr, buff_ptr_arg, buff_ptr) ptr; dcl (buff_len_arg, buff_len, n_read) fixed (21); dcl code fixed (35); dcl error_table_$negative_nelem external fixed (35); %include iocbv; %include rs_attach_block; dcl n_moved fixed (21); dcl error_table_$smallarg external fixed (35); dcl line_len fixed (21); dcl (index, substr, min, addr) builtin; dcl length fixed (21); dcl error_table_$long_record external fixed (35); dcl type fixed; dcl count fixed (21); dcl iox_$position entry (ptr, fixed, fixed (21), fixed (35)); dcl n fixed (21); dcl newline char (1) aligned static internal init (" "); dcl iox_$read_record entry (ptr, ptr, fixed (21), fixed (21), fixed (35)); dcl error_table_$no_record external fixed (35); %include rs_buffer; dcl buffer char (buff_len) based (buff_ptr); dcl buff (buff_len) char (1) based (buff_ptr); end rs_open_str_in_;  rs_open_str_out_.pl1 09/10/87 1507.0r w 09/10/87 1447.6 36504 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* record_stream_ program for handling stream output mode of opening */ rs_open_str_out_: proc (iocb_ptr_arg); iocb_ptr = iocb_ptr_arg; /* set entry in iocb for valid operation */ put_chars = put_chars_rs; return; /* finished with opening routine */ put_chars_rs: entry (iocb_ptr_arg, buff_ptr_arg, buff_len_arg, code); iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr; rsab_ptr = attach_data_ptr; rs_buff_ptr = open_data_ptr; buff_len = buff_len_arg; buff_ptr = buff_ptr_arg; if buff_len_arg < 0 then code = error_table_$negative_nelem; else do; /* process characters in output buffer */ code = 0; if length_n <= 0 then /* default case */ do while ((buff_len > 0) & (code = 0)); line_len = index (buffer, newline) - 1; if line_len ^= 0 then /* non-null line in output buffer */ if line_len < 0 /* no newline found */ then go to append; /* append remaining chars to rs_buffer */ else /* newline found in output buffer */ if n_left > 0 then /* rs_buffer not empty */ do; /* append rest of line to rs_buffer and flush */ substr (rs_buffer, n_left + 1, line_len) = substr (buffer, 1, line_len); call iox_$write_record (target_iocb_ptr, rs_buff_ptr, line_len + n_left, code); n_left = 0; end; /* rs_buffer now empty */ else call iox_$write_record (target_iocb_ptr, buff_ptr, line_len, code); buff_len = buff_len - line_len - 1; buff_ptr = addr (buff (line_len + 2)); end; /* end of default case */ else do; /* -length n case */ if n_left > 0 then /* rs_buffer not empty */ if n_left + buff_len >= length_n then /* enough for full record */ do; /* append and write out record from rs_buffer */ tail_len = length_n - n_left; substr (rs_buffer, n_left + 1, tail_len) = substr (buffer, 1, tail_len); call iox_$write_record (target_iocb_ptr, rs_buff_ptr, length_n, code); buff_len = buff_len - tail_len; buff_ptr = addr (buff (tail_len + 1)); n_left = 0; /* rs_buffer mpty */ end; else go to append; /* not enough for full record to be written */ do while (buff_len >= length_n); call iox_$write_record (target_iocb_ptr, buff_ptr, length_n, code); buff_len = buff_len - length_n; buff_ptr = addr (buff (length_n + 1)); end; /* fewer than length_n characters remain */ append: if buff_len > 0 then /* characters remain, but not enough for a full record */ do; /* append remaining chars to rs_buffer */ substr (rs_buffer, n_left + 1, buff_len) = buffer; n_left = n_left + buff_len; end; end; /* end of -length n case */ end; /* no more characters to process */ return; /* end of put_chars routine */ /* declarations for entire program */ dcl (iocb_ptr_arg, iocb_ptr) ptr; dcl code fixed (35); %include rs_attach_block; %include iocbv; %include rs_buffer; dcl iox_$write_record entry (ptr, ptr, fixed (21), fixed (35)); dcl (buff_ptr_arg, buff_ptr) ptr; dcl buffer char (buff_len) based (buff_ptr); dcl (buff_len_arg, buff_len) fixed (21); dcl error_table_$negative_nelem external fixed (35); dcl line_len fixed (21); dcl (addr, index, size, substr) builtin; dcl newline char (1) static internal aligned init (" "); dcl buff (buff_len) char (1) based (buff_ptr); dcl tail_len fixed (21); end rs_open_str_out_;  transaction_call.pl1 11/04/82 1940.0rew 11/04/82 1620.4 124353 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Command Interface to transaction_call_. Rewritten 8-Mar-79 by M. N. Davidoff. */ transaction_call: trc: procedure; /* auotmatic */ declare arg_count fixed binary; declare arg_length fixed binary (21); declare arg_list_ptr pointer; declare arg_ptr pointer; declare argument_no fixed binary; declare argx fixed binary; declare code fixed binary (35); declare operation char (32); declare tcf_io_switch char (32); declare tcf_iocb_ptr pointer; declare transaction_no fixed binary (35); /* based */ declare arg_string char (arg_length) based (arg_ptr); /* builtin */ declare addr builtin; declare index builtin; declare length builtin; declare null builtin; declare rtrim builtin; declare string builtin; /* condition */ declare program_interrupt condition; declare transaction_failure condition; /* internal static */ declare command char (16) internal static options (constant) initial ("transaction_call"); /* external static */ declare error_table_$asynch_change fixed binary (35) external static; declare error_table_$badopt fixed binary (35) external static; /* entry */ declare com_err_ entry options (variable); declare com_err_$suppress_name entry options (variable); declare cu_$arg_count entry (fixed binary); declare cu_$arg_list_ptr entry (pointer); declare cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); declare cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer); declare cv_dec_check_ entry (char (*), fixed binary (35)) returns (fixed binary (35)); declare ioa_ entry options (variable); declare iox_$look_iocb entry (char (*), pointer, fixed binary (35)); declare transaction_call_$assign entry (pointer, fixed binary (35), fixed binary (35)); declare transaction_call_$change_current_transaction_no entry (pointer, fixed binary (35), fixed binary (35)); declare transaction_call_$commit entry (pointer, fixed binary (35), fixed binary (35)); declare transaction_call_$number entry (pointer, fixed binary (35), fixed binary (35)); declare transaction_call_$rollback entry (pointer, fixed binary (35), fixed binary (35)); declare transaction_call_$status entry (pointer, fixed binary (35), bit (36) aligned, pointer, fixed binary, fixed binary (35)); declare transaction_call_$transact entry (pointer, char (*), fixed binary (35), fixed binary (35)); %include transaction_call; /* program */ call cu_$arg_list_ptr (arg_list_ptr); call cu_$arg_count (arg_count); if arg_count < 2 then do; call com_err_$suppress_name (0, command, "Usage: ^a operation tcf_io_switch {args}", command); return; end; do argx = 1 to 2; call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; if index (arg_string, "-") = 1 then do; call com_err_ (error_table_$badopt, command, "^a", arg_string); return; end; else if argx = 1 then operation = arg_string; else tcf_io_switch = arg_string; end; call iox_$look_iocb (tcf_io_switch, tcf_iocb_ptr, code); if code ^= 0 then do; call com_err_ (code, command, "^a", tcf_io_switch); return; end; if operation = "assign" | operation = "a" then call assign; else if operation = "change_current_transaction_no" | operation = "cctn" then call change_current_transaction_no; else if operation = "commit" | operation = "c" then call commit; else if operation = "number" | operation = "n" then call number; else if operation = "rollback" | operation = "r" then call rollback; else if operation = "status" | operation = "s" then call status; else if operation = "transact" | operation = "t" then call transact; else do; call com_err_ (0, command, "Specified operation is not implemented by this command. ^a", operation); return; end; return; /* Get a new transaction number. */ assign: procedure; if arg_count ^= 2 then do; call com_err_$suppress_name (0, command, "Usage: ^a assign tcf_io_switch", command); return; end; call transaction_call_$assign (tcf_iocb_ptr, transaction_no, code); if code ^= 0 then do; call com_err_ (code, command, "Assigning a transaction number."); return; end; call ioa_ ("Transaction ^d.", transaction_no); end assign; /* Change to another transaction. */ change_current_transaction_no: procedure; argument_no = 0; do argx = 3 to arg_count; call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; if index (arg_string, "-") = 1 then do; call com_err_ (error_table_$badopt, command, "^a", arg_string); return; end; else do; argument_no = argument_no + 1; if argument_no = 1 then do; transaction_no = cv_dec_check_ (arg_string, code); if code ^= 0 then do; call com_err_ (0, command, "Transaction number expected. ^a", arg_string); return; end; end; end; end; if argument_no ^= 1 then do; call com_err_$suppress_name (0, command, "Usage: ^a change_current_transaction_no tcf_io_switch transaction_no", command); return; end; call transaction_call_$change_current_transaction_no (tcf_iocb_ptr, transaction_no, code); if code ^= 0 then do; call com_err_ (code, command, "Changing the current transaction number."); return; end; end change_current_transaction_no; /* Commit a transaction. */ commit: procedure; if arg_count ^= 2 then do; call com_err_$suppress_name (0, command, "Usage: ^a commit tcf_io_switch", command); return; end; call transaction_call_$commit (tcf_iocb_ptr, transaction_no, code); if code ^= 0 then do; call com_err_ (code, command, "Committing transaction ^d.", transaction_no); return; end; if transaction_no ^= 0 then call ioa_ ("Transaction ^d committed.", transaction_no); end commit; /* Get the current transaction number. */ number: procedure; if arg_count ^= 2 then do; call com_err_$suppress_name (0, command, "Usage: ^a number tcf_io_switch", command); return; end; call transaction_call_$number (tcf_iocb_ptr, transaction_no, code); if code ^= 0 then do; call com_err_ (code, command, "Getting current transaction number."); return; end; call ioa_ ("The current transaction number is ^d.", transaction_no); end number; /* Rollback a transaction. */ rollback: procedure; if arg_count ^= 2 then do; call com_err_$suppress_name (0, command, "Usage: ^a rollback tcf_io_switch", command); return; end; call transaction_call_$rollback (tcf_iocb_ptr, transaction_no, code); if code ^= 0 then do; call com_err_ (code, command, "Rolling back transaction ^d.", transaction_no); return; end; if transaction_no ^= 0 then call ioa_ ("Transaction ^d rolled back.", transaction_no); end rollback; /* Get a transaction's status. */ status: procedure; declare 1 status_s aligned like trc_status; declare 1 sw unaligned, 2 brief bit (1), 2 verify_refs bit (1), 2 list bit (1); declare transaction_status fixed binary; string (sw) = ""b; transaction_no = 0; argument_no = 0; do argx = 3 to arg_count; call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; if arg_string = "-brief" | arg_string = "-bf" then sw.brief = "1"b; else if arg_string = "-verify" | arg_string = "-vf" then sw.verify_refs = "1"b; else if arg_string = "-list" | arg_string = "-ls" then sw.list = "1"b; else if index (arg_string, "-") = 1 then do; call com_err_ (error_table_$badopt, command, "^a", arg_string); return; end; else do; argument_no = argument_no + 1; if argument_no = 1 then do; transaction_no = cv_dec_check_ (arg_string, code); if code ^= 0 then do; call com_err_ (0, command, "Transaction number expected. ^a", arg_string); return; end; end; end; end; if argument_no > 1 then do; call com_err_$suppress_name (0, command, "Usage: ^a status tcf_io_switch {transaction_no} {-control_args}", command); return; end; trc_flags = ""b; trc_flag_s.verify_refs = sw.verify_refs; trc_flag_s.list = sw.list; status_s.version = trc_status_version_1; if sw.brief then trc_status_ptr = null; else trc_status_ptr = addr (status_s); if sw.list then call ioa_ ("^/Reference list^[ until first asychronous change^]:", sw.verify_refs); call transaction_call_$status (tcf_iocb_ptr, transaction_no, trc_flags, trc_status_ptr, transaction_status, code); if code ^= 0 & code ^= error_table_$asynch_change then do; call com_err_ (code, command, "Getting the status of ^[the current transaction^s^;transaction ^d^].", transaction_no = 0, transaction_no); return; end; if transaction_no ^= 0 | ^sw.brief then call ioa_ ("^/transaction:^2-^[^d^s^;^s^d^]", sw.brief, transaction_no, status_s.transaction_no); call ioa_ ("status:^3-^[^[incomplete^;committed^;rolled back^;undefined^]^s^;^s^d^]", trc_INCOMPLETE <= transaction_status & transaction_status <= trc_UNDEFINED, transaction_status + 1, transaction_status); if transaction_status ^= trc_UNDEFINED & ^sw.brief then call ioa_ ("passive references:^2-^d^/non-passive references:^-^d", status_s.passive_refs, status_s.non_passive_refs); if code ^= 0 then call com_err_ (code, command); end status; /* Execute a command line as a transaction. */ transact: procedure; declare command_line_length fixed binary (21); declare first_command_line_arg fixed binary; declare retry_limit fixed binary; declare 1 sw unaligned, 2 signal bit (1), 2 no_signal bit (1); string (sw) = ""b; retry_limit = 0; first_command_line_arg = 0; argx = 3; do while (argx <= arg_count); call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; if first_command_line_arg > 0 then command_line_length = command_line_length + length (arg_string) + 1; else if arg_string = "-retry" then do; argx = argx + 1; if argx > arg_count then do; call com_err_ (0, command, "Missing retry limit after -retry."); return; end; call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; retry_limit = cv_dec_check_ (arg_string, code); if code ^= 0 then do; call com_err_ (0, command, "Retry limit expected. ^a", arg_string); return; end; end; else if arg_string = "-signal" then sw.signal = "1"b; else if arg_string = "-no_signal" then sw.no_signal = "1"b; else if index (arg_string, "-") = 1 then do; call com_err_ (error_table_$badopt, command, "^a", arg_string); return; end; else do; first_command_line_arg = argx; command_line_length = length (arg_string); end; argx = argx + 1; end; if first_command_line_arg = 0 then do; call com_err_$suppress_name (0, command, "Usage: ^a transact tcf_io_switch {-control_args} command_line", command); return; end; if sw.signal & sw.no_signal then do; call com_err_ (0, command, "The -signal and -no_signal control arguments are incompatible."); return; end; sw.signal = ^sw.no_signal; begin; declare command_line char (command_line_length); declare one_more_time bit (1); declare try fixed binary; do argx = first_command_line_arg to arg_count; call cu_$arg_ptr_rel (argx, arg_ptr, arg_length, code, arg_list_ptr); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; if argx = first_command_line_arg then command_line = arg_string; else command_line = rtrim (command_line) || " " || arg_string; end; if sw.signal then on program_interrupt goto execute_command_line; try = 0; execute_command_line: one_more_time = "1"b; do while (try <= retry_limit & code = error_table_$asynch_change | one_more_time); one_more_time = "0"b; try = try + 1; call transaction_call_$transact (tcf_iocb_ptr, command_line, transaction_no, code); end; if code = 0 then call ioa_ ("The transaction committed on try ^d with transaction number ^d.", try, transaction_no); else if code = error_table_$asynch_change then if sw.signal then signal transaction_failure; else call com_err_ (code, command, "On try ^d.", try); else call com_err_ (code, command, "On transaction ^d.", transaction_no); end; end transact; end transaction_call;  transaction_call_.pl1 11/04/82 1940.0rew 11/04/82 1621.0 207009 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Vfile_ Transaction Interfaces. Written by Mike Asherman. Modified: 03/02/79 by M. N. Davidoff to use better interfaces and cleaned up a little . 05/17/79 by Lindsey Spratt to interpret 22-byte reflist keys as non-passive references when gk_inf.descrip = -1. 07/06/79 by M. N. Davidoff to fix bug where transaction_call_$status was not verifying if P_trc_status_ptr = null. */ transaction_call_: procedure; /* parameter */ declare P_command_line char (*); declare P_status fixed binary; declare P_transaction_no fixed binary (35); declare P_trc_flags bit (36) aligned; declare P_trc_status_ptr pointer; declare code fixed binary (35); declare tcfp pointer; /* automatic */ declare adjust_mod fixed binary (35); declare block_ptr pointer; declare change_tcf bit (1) aligned; declare cur_mod fixed binary (35); declare cur_tcode fixed binary (35); declare current_descrip fixed binary (35); declare end_of_reference_list bit (1) aligned; declare entry_point char (32); declare 1 gk_inf, 2 header like gk_header, 2 key char (22); declare ind_desc fixed binary (35); declare iocb_ptr pointer; declare iocbp pointer; declare last_file_id fixed binary (35); declare mod fixed binary; declare pos_ptr pointer; declare ref_cnt fixed binary; declare refp pointer; declare rollback_sw bit (1) aligned; declare time_stamp fixed binary (71); declare timeout fixed binary (71); declare transaction bit (1) aligned; declare unique_name char (32); /* based */ /* Reference list and TCF key structure. The TCF has keys which are 4 bytes long. These keys are transaction entries. The reference list has keys which are 12, 16 or 22 bytes long. The 12 byte keys are I/O switch entries. The 16 and 22 byte keys are reference list entries. */ declare 1 gk_key aligned based (addr (gk_inf.key)), 2 number fixed binary (35), 2 file_id fixed binary (35), 2 rec_id fixed binary (35), 2 blockp pointer unaligned, 2 time fixed binary (53) unaligned; /* builtin */ declare binary builtin; declare codeptr builtin; declare clock builtin; declare rtrim builtin; declare stacq builtin; declare string builtin; /* condition */ declare cleanup condition; /* entry */ declare cu_$cp entry (pointer, fixed binary (21), fixed binary (35)); declare date_time_ entry (fixed binary (71), char (*)); declare get_pdir_ entry returns (char (168)); declare ioa_ entry options (variable); declare open_indx_file$adjust_record entry (pointer, fixed binary (35), fixed binary (35), fixed binary (35)); declare sub_err_ entry options (variable); declare unique_chars_ entry (bit (*)) returns (char (15)); /* Execute a Multics command line as a transaction. */ transact: entry (tcfp, P_command_line, P_transaction_no, code); /* tcfp (Input) pointer to the iocb for the TCF I/O switch P_command_line (Input) Multics command line to execute P_transaction_no (Output) transaction number of the transaction code (Output) standard status code */ entry_point = "transact"; code = 0; P_transaction_no = 0; call check_tcf_io_switch; on cleanup call rollback (tcfp, P_transaction_no, code); call cu_$cp (addr (P_command_line), length (P_command_line), code); call commit (tcfp, P_transaction_no, code); if code ^= error_table_$asynch_change then return; call rollback (tcfp, P_transaction_no, code); code = error_table_$asynch_change; return; /* Obtain the status of a transaction. */ status: entry (tcfp, P_transaction_no, P_trc_flags, P_trc_status_ptr, P_status, code); /* tcfp (Input) pointer to the iocb for the TCF I/O switch P_transaction_no (Input) transaction to find the status of. Zero means the current transaction. P_trc_flags (Input) what actions to perform P_trc_status_ptr (Input) pointer to a trc_status structure or null P_status (Output) status of the transaction code (Output) standard status code */ entry_point = "status"; trc_flags = P_trc_flags; trc_status_ptr = P_trc_status_ptr; P_status = trc_UNDEFINED; code = 0; call check_tcf_io_switch; if P_transaction_no = 0 then cur_tcode = tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code; else cur_tcode = P_transaction_no; if cur_tcode ^= 0 then do; unspec (gk_inf.flags) = ""b; gk_inf.input_key = "1"b; gk_inf.head_size = 4; gk_inf.key_len = 4; gk_key.number = cur_tcode; call iox_$control (tcfp, "get_key", addr (gk_inf), code); if code = 0 then P_status = -gk_inf.descrip; else if code = error_table_$no_key | code = error_table_$no_record then code = 0; else call check_code ("Can't get TCF entry."); end; /* Return more detailed information only if requested. */ if trc_status_ptr ^= null then do; if trc_status.version ^= trc_status_version_1 then do; code = error_table_$unimplemented_version; return; end; trc_status.transaction_no = cur_tcode; trc_status.transaction_status = P_status; trc_status.passive_refs = 0; trc_status.non_passive_refs = 0; end; if P_status = trc_UNDEFINED then return; /* There are no asynchronous changes or references if there is no reference list. */ refp = tcfp -> iocb.open_data_ptr -> indx_cb.reflp; if refp = null then return; call verification ("1"b, trc_flag_s.verify_refs); code = 0; return; /* Clean up after aborting a transaction. */ rollback: entry (tcfp, P_transaction_no, code); /* tcfp (Input) pointer to the iocb for the TCF I/O switch P_transaction_no (Output) transaction number of the aborted transaction code (Output) standard status code */ entry_point = "rollback"; rollback_sw = "1"b; goto join; /* Start a new transaction and finish an old one. */ checkpoint: /* TEMPORARY -- This entry point should be deleted. */ commit: entry (tcfp, P_transaction_no, code); /* tcfp (Input) pointer to the iocb for the TCF I/O switch P_transaction_no (Output) transaction number of the completed transaction code (Output) standard status code */ entry_point = "commit"; rollback_sw = "0"b; join: P_transaction_no = 0; code = 0; call check_tcf_io_switch; cur_tcode = tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code; P_transaction_no = cur_tcode; /* Return if there is no transaction in progress. */ if cur_tcode = 0 then return; /* Get the reference list. It's an error if there isn't one because a transaction is in progress. */ refp = tcfp -> iocb.open_data_ptr -> indx_cb.reflp; if refp = null then do; code = error_table_$no_operation; call check_code ("No reference list."); end; /* Indicate roll back or roll forward to adjust_record logic. Perform passive verification before the commitment. */ if rollback_sw then adjust_mod = 0; else do; adjust_mod = cur_tcode; call verification ("0"b, "1"b); end; /* Go through non-passive references and indicate the status of the transaction. */ call find_first_ref; if code ^= 0 then do; code = error_table_$no_operation; call check_code ("No reference list entries after passive verification."); end; call get_next_non_passive_ref (end_of_reference_list); change_tcf = "1"b; last_file_id = 0; do while (gk_key.number = cur_tcode & ^end_of_reference_list); if gk_key.file_id ^= last_file_id /* must set iocbp for this file */ then do; call set_iocbp (gk_key.file_id); /* gets information from start of reference list */ last_file_id = gk_key.file_id; end; /* Prepare to alter the TCF entry. A commitment or rollback is irreversible once the TCF has been changed. */ if change_tcf then begin; declare 1 rk_inf, 2 header like rk_header, 2 key char (4); declare transaction_status fixed binary; tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code = 0; string (rk_inf.flags) = "111"b; rk_inf.old_descrip = -trc_INCOMPLETE; rk_inf.key_len = length (rk_inf.key); unspec (rk_inf.key) = unspec (cur_tcode); if rollback_sw then rk_inf.new_descrip = -trc_ROLLED_BACK; else rk_inf.new_descrip = -trc_COMMITTED; call iox_$control (tcfp, "reassign_key", addr (rk_inf), code); if code ^= 0 then if code = error_table_$no_key then call check_code ("No TCF entry for transaction."); else if code ^= error_table_$no_record then call check_code ("Can't change TCF entry."); else do; /* see if already did operation */ call status (tcfp, cur_tcode, ""b, null, transaction_status, code); call check_code ("Couldn't change TCF entry. Can't get transaction's status."); if transaction_status = trc_UNDEFINED then do; code = error_table_$no_operation; call check_code ("Couldn't change TCF entry. Transaction's entry is gone.") ; end; if rollback_sw then if transaction_status = trc_COMMITTED then do; code = error_table_$no_operation; call check_code ("Transaction already committed."); end; else if transaction_status ^= trc_ROLLED_BACK then do; code = error_table_$no_operation; call check_code ("Invalid TCF status code found during rollback."); end; else ; else if transaction_status = trc_ROLLED_BACK then do; code = error_table_$no_operation; call check_code ("Transaction already rolled back."); end; else if transaction_status ^= trc_COMMITTED then do; code = error_table_$no_operation; call check_code ("Invalid TCF status code found during commitment."); end; end; change_tcf = "0"b; end; call open_indx_file$adjust_record (iocbp, gk_key.rec_id, adjust_mod, code); call check_code ("Can't adjust a modified record."); gk_inf.descrip = 0; /* move onto the next non-passive reference */ call get_next_non_passive_ref (end_of_reference_list); end; code = 0; tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code = 0; return_from_transaction_call_: return; /* Reserve a transaction number for the next transaction. */ assign: entry (tcfp, P_transaction_no, code); /* tcfp (Input) pointer to the iocb for the TCF I/O switch P_transaction_no (Output) new transaction number code (Output) standard status code */ entry_point = "assign"; P_transaction_no = 0; call check_tcf_io_switch; if tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code ^= 0 then do; code = error_table_$no_operation; return; end; /* This loop will try again if there is an asynchronous insertion. */ code = 1; do while (code ^= 0); call iox_$position (tcfp, 1, 0, code); /* eof */ call check_code ("Can't position to end of TCF to find last entry."); call iox_$position (tcfp, 0, -1, code); /* backspace */ if code = 0 then do; /* get last used transaction number */ unspec (gk_inf.flags) = ""b; call iox_$control (tcfp, "get_key", addr (gk_inf), code); call check_code ("Can't get last key of TCF."); cur_tcode = gk_key.number + 1; end; else if code = error_table_$end_of_info then cur_tcode = 1; /* first TCF entry */ else call check_code ("Can't backspace from end of TCF."); call create_tcf_entry (cur_tcode); if code ^= 0 then if code ^= error_table_$key_duplication then call check_code ("Can't add a new key to the TCF."); end; P_transaction_no = cur_tcode; return; /* Get the current transaction number. */ number: entry (tcfp, P_transaction_no, code); /* tcfp (Input) pointer to the iocb for the TCF I/O switch P_transaction_no (Output) current transaction number code (Output) standard status code */ entry_point = "number"; P_transaction_no = 0; code = 0; call check_tcf_io_switch; P_transaction_no = tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code; return; /* Change the current transaction number. This should be used with caution. */ change_current_transaction_no: entry (tcfp, P_transaction_no, code); /* tcfp (Input) pointer to the iocb for the TCF I/O switch P_transaction_no (Input) new current transaction number code (Output) standard status code */ entry_point = "change_current_transaction_no"; code = 0; call check_tcf_io_switch; if P_transaction_no < 0 then do; code = error_table_$bad_arg; return; end; tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code = P_transaction_no; return; /* Create a reference list. */ setup_ref_list: entry (tcfp, code); /* tcfp (Input) pointer to the iocb for the TCF I/O switch code (Output) standard status code */ entry_point = "setup_ref_list"; code = 0; call check_tcf_io_switch; unique_name = unique_chars_ (""b) || ".refl.vfile_"; call iox_$attach_name (unique_name, iocbp, "vfile_ " || rtrim (get_pdir_ ()) || ">" || unique_name, codeptr (transaction_call_), code); call check_code ("Can't attach reference list."); call iox_$open (iocbp, Keyed_sequential_update, "0"b, code); call check_code ("Can't open reference list."); tcfp -> iocb.open_data_ptr -> indx_cb.reflp = iocbp; return; /* Make sure the TCF I/O switch is open. */ check_tcf_io_switch: procedure; if tcfp -> iocb.open_descrip_ptr ^= null then return; code = error_table_$not_open; goto return_from_transaction_call_; end check_tcf_io_switch; /* Perform passive verification. */ verification: procedure (verify_only, check_asynch_changes); declare verify_only bit (1) aligned; /* (Input) on if only obtaining a transaction's status */ declare check_asynch_changes bit (1); /* (Input) on to check for asychronous changes */ declare end_of_reference_list bit (1) aligned; declare my_lock_id bit (36) aligned; call find_first_ref; if code ^= 0 then if verify_only then return; else do; code = error_table_$no_operation; call check_code ("No reference list entries."); end; my_lock_id = tcfp -> iocb.open_data_ptr -> indx_cb.saved_lock_copy; transaction = "1"b; timeout = 0; /* no point waiting to verify */ end_of_reference_list = "0"b; do while (gk_key.number = cur_tcode & ^end_of_reference_list); block_ptr = gk_key.blockp; /* pointer to stat record header */ /* If the record is locked, then we have a non-passive reference, otherwise if the record is not locked, the reference is passive. For non-passive references before a commitment (^verify_only) make sure record_block.lock_flag is on. All flags will then be set before the commitment starts. This will force users to examine the TCF to determine which record image currently applies. When record_block.lock_flag is off, the before image is guaranteed to be valid. */ if gk_inf.descrip = -1 then if verify_only then do; if trc_status_ptr ^= null then trc_status.non_passive_refs = trc_status.non_passive_refs + 1; if trc_flag_s.list then if gk_inf.key_len = 16 then call ioa_ ("File: ^o, Descriptor: ^o Locked.", gk_key.file_id, gk_key.rec_id); else begin; declare date_time_string char (24); call date_time_ ((gk_key.time), date_time_string); call ioa_ ("File: ^o, Descriptor: ^o, Last modified: ^a, Locked.", gk_key.file_id, gk_key.rec_id, date_time_string); end; end; else if stacq (block_ptr -> stat_struct.record_lock, my_lock_id, my_lock_id) /* be sure under own lock */ then if ^block_ptr -> record_block.lock_flag & stat_struct.modifier = cur_tcode then block_ptr -> record_block.lock_flag = "1"b; else ; else ; else do; /* Verify a passive reference. */ if verify_only then do; if trc_status_ptr ^= null then trc_status.passive_refs = trc_status.passive_refs + 1; if trc_flag_s.list then if gk_inf.key_len = 16 then call ioa_ ("File: ^o, Descriptor: ^o, Last modifier: ^d.", gk_key.file_id, gk_key.rec_id, gk_inf.descrip); else begin; declare date_time_string char (24); call date_time_ ((gk_key.time), date_time_string); call ioa_ ("File: ^o, Descriptor: ^o, Last modified: ^a, Image descriptor: ^o.", gk_key.file_id, gk_key.rec_id, date_time_string, gk_inf.descrip); end; end; if check_asynch_changes then begin; declare asynch_change bit (1) aligned; current_descrip = gk_key.rec_id; call set_current_image_info; /* Long form verification uses the time_stamp and the indirect descriptor. */ if cur_mod = 0 | cur_mod = -1 then if gk_inf.key_len = 16 then asynch_change = gk_inf.descrip ^= -3 | time_stamp ^= 0 | ind_desc ^= -1; else if gk_inf.key_len > 16 /* A key_len of >16 occurs when: passive & ((cur_mod = 0) | (cur_mod = -1)) or; not passive & (stat_struct.prev_mod = 0). (This latter implies cur_mod = 0.) and; this reference must be the first to this record in the reflist by this transaction. If not passive then gk_inf.descrip = -1, and the converse. If gk_inf.descrip is not = -1, then the old check for inequality with ind_desc is used. */ then if gk_inf.descrip ^= -1 then asynch_change = gk_key.time ^= time_stamp | gk_inf.descrip ^= ind_desc; else asynch_change = gk_key.time ^= time_stamp; else asynch_change = "0"b; else asynch_change = gk_inf.key_len > 16 | cur_mod ^= gk_inf.descrip; if asynch_change then do; code = error_table_$asynch_change; goto return_from_transaction_call_; end; end; end; /* Move on to the next reference for this transaction. */ call iox_$position (refp, 0, 1, code); call check_code ("Can't position to next reference list entry."); call iox_$control (refp, "get_key", addr (gk_inf), code); if code ^= 0 then if code = error_table_$end_of_info then end_of_reference_list = "1"b; else call check_code ("Can't get next reference list entry for verification."); end; end verification; /* Locate first item in reference list for this transaction. */ find_first_ref: procedure; unspec (gk_inf.flags) = ""b; gk_inf.input_key = "1"b; gk_inf.head_size = 4; gk_inf.key_len = 4; gk_key.number = cur_tcode; call iox_$control (refp, "get_key", addr (gk_inf), code); if code ^= 0 then if code ^= error_table_$no_record & code ^= error_table_$no_key then call check_code ("Can't find first reference list entry."); gk_inf.input_key = "0"b; /* suppress seeking on next get_key */ end find_first_ref; /* Get the next locked item in the reference list. */ get_next_non_passive_ref: procedure (end_of_reference_list); declare end_of_reference_list bit (1) aligned; /* (Output) on if no more items in reference list */ /* Skip over the passive references. */ end_of_reference_list = "0"b; do while ((gk_inf.descrip >= 0 | gk_inf.descrip = -3) & ^end_of_reference_list); call iox_$position (refp, 0, 1, code); call check_code ("Can't position to next non-passive reference list entry."); call iox_$control (refp, "get_key", addr (gk_inf), code); if code ^= 0 then if code = error_table_$no_record | code = error_table_$end_of_info then end_of_reference_list = "1"b; else call check_code ("Can't get next non-passive reference list entry."); end; end get_next_non_passive_ref; /* Create an entry in the TCF for a new transaction. */ create_tcf_entry: procedure (mod_arg); declare mod_arg fixed binary (35); /* (Input) transaction to create a TCF entry for */ unspec (gk_inf.flags) = "11"b; gk_inf.descrip = -trc_INCOMPLETE; gk_inf.key_len = 4; gk_key.number = mod_arg; call iox_$control (tcfp, "add_key", addr (gk_inf), code); if code = 0 then tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code = mod_arg; end create_tcf_entry; /* Obtain a file's iocb pointer. */ set_iocbp: procedure (uid_arg); declare uid_arg fixed binary (35); /* (Input) file_id of the iocb to find */ declare 1 gk_inf, 2 header like gk_header, 2 key char (12); declare gk_desc pointer unaligned based (addr (gk_inf.descrip)); declare 1 gk_key aligned based (addr (gk_inf.key)), 2 zero fixed binary (35), 2 lock_id bit (36), 2 file_id fixed binary (35); unspec (gk_inf.flags) = ""b; gk_inf.input_key = "1"b; gk_inf.reset_pos = "1"b; /* don't lose place in reference list */ gk_inf.head_size = length (gk_inf.key); gk_inf.key_len = length (gk_inf.key); gk_key.zero = 0; gk_key.lock_id = refp -> iocb.open_data_ptr -> indx_cb.saved_lock_copy; gk_key.file_id = uid_arg; call iox_$control (refp, "get_key", addr (gk_inf), code); call check_code ("Can't get I/O switch reference list entry."); iocbp = gk_desc; end set_iocbp; /* Error reporting routine. */ check_code: procedure (message); declare message char (*); /* (Input) error message */ declare sub_code fixed binary (35); if code = 0 then return; sub_code = 0; call sub_err_ (code, "transaction_call_$" || entry_point, "c", null, sub_code, message); goto return_from_transaction_call_; end check_code; /* The set_current_image_info procedure uses the following global variables as arguments: (Who knows, it may also use some more.) block_ptr (Input/Output) pointer to stat record header code (Output) standard status code cur_mod (Output) The transaction number of the current modifier. Zero and negative numbers are special. -1 means the current modifier is outside the transaction system. current_descrip (Input) the current record's descriptor ind_desc (Output) The indirect descriptor. Component and offset of where the record is. -1 is special. mod (Output) Some kind of modifier's transaction number. ref_cnt (Output) reference count timeout (Output) when the information becomes invalid? time_stamp (Output) when the record was last modified. transaction (Input) whether or not this opening is in transaction mode */ %include set_current_image_info; %include transaction_call; %include vfile_indx; %include ak_info; %include iocbv; %include iox_entries; %include vfile_error_codes; %include iox_modes; end transaction_call_;  vfile_adjust.pl1 11/04/82 1940.0rew 11/04/82 1621.0 115488 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* This command is used to restore storage system files to a consistent state after detecting an interrupted operation */ vfa: vfile_adjust: proc (pathname_arg); seg_ptr, fcb_ptr, iocb_ptr = null; call cu_$arg_count (n_args); /* number of args with which command was invoked */ if n_args <= 0 /* must specify at least the pathname */ then code = error_table_$noarg; else if n_args > 3 /* limit of permissible args */ then code = error_table_$too_many_args; else code = 0; call check_code; /* aborts if error detected */ call get_file_base; /* gets first seg ptr */ if (seg_ptr -> header.file_code ^= seq_code) & (seg_ptr -> header.file_code ^= blk_code) & (seg_ptr -> header.file_code ^= indx_code) then call adj_uns_file; /* makes the adjustment */ else call adj_struc_file; /* takes care of structured files */ call check_code; cleanup: if fcb_ptr ^= null /* free the msf control block */ then call msf_manager_$close (fcb_ptr); else if seg_ptr ^= null /* was single segment file */ then call hcs_$terminate_noname (seg_ptr, code); if iocb_ptr ^= null /* file was opened for adjustment */ then do; /* close file and free I/O switch */ call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); end; return; /* end of main file adjustment routine */ check_code: proc; /* aborts if error detected */ if code = 0 then return; call com_err_ (code, "vfile_adjust"); /* signal the error */ go to cleanup; /* don't leave a mess */ end check_code; get_file_base: proc; /* finds first file component and sets seg_ptr */ call expand_path_ (addr (pathname_arg), length (pathname_arg), addr (d_name), addr (e_name), code); /* separate directory and entry names */ call check_code; call hcs_$status_long (d_name, e_name, 1, addr (branch_info), null, code); call check_code; if branch_info.type = "10"b /* directory or msf */ then if branch_info.bit_count = "0"b /* directory */ then code = error_table_$dirseg; else do; /* get ptr to base of msf */ call msf_manager_$open ((d_name), (e_name), fcb_ptr, code); /* creates control block */ call check_code; /* abort on error */ call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, seg_ptr, bc, code); /* pointer to base of file */ if seg_ptr ^= null then code = 0; /* reset spurious code */ end; else do; /* get ptr to base of segment */ call hcs_$initiate (d_name, e_name, "", 0, 1, seg_ptr, code); if seg_ptr ^= null then code = 0; /* no error if pointer returned */ end; call check_code; end get_file_base; adj_struc_file: proc; /* adjusts all structured files */ if n_args > 1 /* no args permitted for structured files */ then code = error_table_$too_many_args; call check_code; call check_file_lock; /* may unlock file */ call attach_unique_sw; /* need I/O switch to open and close */ call iox_$open (iocb_ptr, 7 /* sequential_update */, "0"b, code); /* adjustment will automatically be made if necessary */ end adj_struc_file; adj_uns_file: proc; /* handles adjustments to unstructured files */ if n_args <= 1 /* a control option must be specified */ then code = error_table_$noarg; call cu_$arg_ptr (2, opt1_ptr, opt1_len, code); call check_code; if n_args > 2 then do; /* pick up second optional arg */ call cu_$arg_ptr (3, opt2_ptr, opt2_len, code); call check_code; end; if n_args = 2 then if opt1_arg = "-set_bc" /* indicates setting to last non-zero byte */ then call adjust_bit_count_ (d_name, e_name, "1"b /* last byte */, bc, code); /* does the work */ else if opt1_arg = "-use_nl" /* indic trunc after last complete line */ then call trunc_at_line; else if opt1_arg = "-set_nl" /* indic newline to be appended if not there */ then call append_line; else call get_use_bc; /* option must be "-use_bc" */ else call get_use_bc; /* use existing bit count to truncate */ return; /* unstructured file has been adjusted */ trunc_at_line: proc; /* truncates file after last new-line char */ call prep_uns_file; /* positions to last line */ call iox_$put_chars (iocb_ptr, (null), 0, code); /* truncates the file */ end trunc_at_line; prep_uns_file: proc; /* sets position to last line of file or eof */ call adjust_bit_count_ (d_name, e_name, "1"b, bc, code); /* first set bit count to last non-zero byte */ call check_code; call attach_unique_sw; /* attaches uniquely named I/O switch with "-extend" option */ call iox_$open (iocb_ptr, 3 /* stream_input_output */, "0"b, code); /* file must be opened */ call check_code; call iox_$position (iocb_ptr, 0, 0, code); /* positions just past last newline char */ end prep_uns_file; append_line: proc; /* puts newline char at eof if none already there */ call prep_uns_file; /* position past last newline */ call iox_$get_chars (iocb_ptr, addr (dummy_buffer), 1, rec_len, code); /* get next character */ if code ^= error_table_$end_of_info then do; /* must append a newline char */ call iox_$position (iocb_ptr, 1, 0, code); /* go to end of file */ call iox_$put_chars (iocb_ptr, addr (newline), 1, code); end; else code = 0; /* already ends in newline */ end append_line; get_use_bc: proc; /* checks option and truncates at existing bitcount */ if opt1_arg ^= "-use_bc" /* no other option will do */ then code = error_table_$bad_arg; else if branch_info.type ^= "10"b /* single segment case */ then do; if n_args > 2 /* msf component number specified */ then if opt2_arg ^= "0" then code = error_table_$bad_arg; else call hcs_$truncate_seg (seg_ptr, divide (fixed (bit_count) + 35, 36, 18, 0), code); end; else do; /* get tail num and truncate */ if n_args = 2 /* n not given--default is last non-zero component */ then call get_last_nz_comp; else call get_comp_n; /* picks up specified component-num arg */ call check_code; call msf_manager_$adjust (fcb_ptr, n_tail, bc, "011"b, code); /* does the truncation */ end; return; /* end main routine for handling "-use_bc" option */ get_last_nz_comp: proc; /* finds last non-empty msf component or comp 0 if none */ do n_tail = 1 repeat n_tail + 1 while (code = 0); /* find last msf comp */ call msf_manager_$get_ptr (fcb_ptr, n_tail, "0"b, seg_ptr, bc, code); /* pointer to next component */ end; n_recs = 0; /* last comp+1 has no recs */ do n_tail = n_tail - 2 to 0 by -1 while (n_recs = 0); /* find last non-empty comp */ call msf_manager_$get_ptr (fcb_ptr, n_tail, "0"b, seg_ptr, bc, code); /* ptr to preceding comp */ call hcs_$fs_get_path_name (seg_ptr, d_name, d_len, e_name, code); /* need path for hcs_$status_ */ call hcs_$status_ (d_name, e_name, 0, addr (branch_info), null /* no names */, code); /* gets n_recs */ end; n_tail = n_tail + 1; /* loop decrements once too often */ end get_last_nz_comp; get_comp_n: proc; /* sets n_tail to specified component number */ n_tail = cv_dec_check_ (opt2_arg, code); /* validates conversion */ call check_code; call msf_manager_$get_ptr (fcb_ptr, n_tail, "0"b, seg_ptr, bc, code); /* n'th comp info */ end get_comp_n; end get_use_bc; end adj_uns_file; attach_unique_sw: proc; /* attaches I/O switch with "-extend" control option */ call iox_$attach_ioname (unique_chars_ ("0"b), iocb_ptr, "vfile_ " || pathname_arg || " -extend", code); call check_code; end attach_unique_sw; check_file_lock: proc; /* may reset file lock */ lock_word = seg_ptr -> header.lock_word; /* copy the file lock to examine it */ call set_lock_$lock (lock_word, 0, code); if code ^= 0 then if code = error_table_$locked_by_this_process then do; /* warn user about danger of recursive use of vfile_ */ call command_query_ (addr (query_info), answer, "vfile_adjust", "Warning--file locked by this process. Resuming a previous invocation of vfile_ after adjustment may produce unpredictable errors. Close the I/O switch or issue a new_proc to be safe. Do you still wish to adjust the file?" ); /* let user decide */ if answer = "no" then go to cleanup; /* forget the whole thing */ seg_ptr -> header.lock_word = bit (-1); /* lock becomes invalid */ end; end check_file_lock; /* declarations for entire program */ dcl hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed (1), ptr, ptr, fixed (35)); dcl hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed (1), fixed (2), ptr, fixed (35)); dcl hcs_$terminate_noname entry (ptr, fixed (35)); dcl lock_word bit (36) aligned; dcl seq_code static internal fixed init (83711); dcl blk_code static internal fixed init (22513); dcl indx_code static internal fixed init (7129); dcl hcs_$truncate_seg entry (ptr, fixed (18), fixed (35)); dcl error_table_$end_of_info external fixed (35); dcl iox_$put_chars entry (ptr, ptr, fixed (21), fixed (35)); dcl iox_$position entry (ptr, fixed, fixed, fixed (35)); dcl iox_$get_chars entry (ptr, ptr, fixed (21), fixed (21), fixed (35)); dcl rec_len fixed (21); dcl newline char (1) aligned static internal init (" "); dcl dummy_buffer char (1) aligned; dcl pathname_arg char (*); dcl opt1_arg char (opt1_len) based (opt1_ptr); dcl opt2_arg char (opt2_len) based (opt2_ptr); dcl (opt1_len, opt2_len) fixed; dcl (opt1_ptr, opt2_ptr) ptr; dcl cu_$arg_ptr entry (fixed, ptr, fixed, fixed (35)); dcl (fcb_ptr, iocb_ptr) ptr; dcl cu_$arg_count entry (fixed); dcl n_args fixed; dcl code fixed (35); dcl (error_table_$noarg, error_table_$dirseg, error_table_$too_many_args, error_table_$bad_arg, error_table_$locked_by_this_process) external fixed (35); dcl (null, fixed, bit, divide, addr) builtin; dcl msf_manager_$close entry (ptr); dcl iox_$close entry (ptr, fixed (35)); dcl iox_$open entry (ptr, fixed, bit (1) aligned, fixed (35)); dcl iox_$detach_iocb entry (ptr, fixed (35)); dcl com_err_ entry options (variable); dcl expand_path_ entry (ptr, fixed, ptr, ptr, fixed (35)); dcl msf_manager_$open entry (char (*) aligned, char (*) aligned, ptr, fixed (35)); dcl msf_manager_$get_ptr entry (ptr, fixed, bit (1), ptr, fixed (24), fixed (35)); dcl d_name char (168) aligned; dcl e_name char (32) aligned; dcl seg_ptr ptr; dcl bc fixed (24); dcl 1 header based (seg_ptr), 2 file_code fixed (35), 2 lock_word bit (36) aligned; dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed (24), fixed (35)); dcl n_tail fixed; dcl msf_manager_$adjust entry (ptr, fixed, fixed (24), bit (3), fixed (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*) aligned, fixed, char (*) aligned, fixed (35)); dcl hcs_$status_ entry (char (*) aligned, char (*) aligned, fixed (1), ptr, ptr, fixed (35)); dcl d_len fixed; dcl 1 branch_info aligned, ( 2 type bit (2), 2 nnames fixed (15), 2 nrp bit (18), 2 dtm bit (36), 2 dtu bit (36), 2 mode bit (5), 2 pad bit (13), 2 n_recs fixed (17) ) unaligned, 2 words1 (3) fixed, 2 pad1 bit (12) unal, 2 bit_count bit (24) unal, 2 words2 (2) fixed; dcl cv_dec_check_ entry (char (*), fixed (35)) returns (fixed (35)); dcl set_lock_$lock entry (bit (36) aligned, fixed, fixed (35)); dcl command_query_ entry options (variable); dcl 1 query_info aligned, 2 version fixed init (2), 2 yes_or_no_sw bit (1) unal init ("1"b), 2 suppress_name_sw bit (1) unal init ("0"b), 2 code fixed (35), 2 query_code fixed (35); dcl answer char (12) var; dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); end vfile_adjust;  vfile_attach.pl1 09/10/87 1507.0rew 09/10/87 1445.1 272412 /****^ *********************************************************** * * * 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-07-01,GWMay), approve(87-07-01,MCR7730), audit(87-08-10,JRGray), install(87-09-10,MR12.1-1104): Added the -truncate, -tc argument so that the -extend arg can be overriden. END HISTORY COMMENTS */ /* format: style2,ind3 */ vfile_attach: proc (iocb_ptr_arg, option_array, command_switch, code); /* Modified: 04/05/82 by Lindsey Spratt: Changed to correctly report the blocking value, the wait-time for the share option, and the identifier for the unstructured header. If more than one of these was present in the attach options, the values for all of them would be reported as being the same as the value for the last one given. Also, changed "-exclu" to "-exclusive" in the attach description, as -exclu is not a valid attach option. */ /* Declarations and general comments are at the end of the program. */ iocb_ptr = iocb_ptr_arg; call verify_and_interpret_args; if trans_opt & (code = 0) /* -transaction attachment */ then do; call iox_$look_iocb ((tcf_name), tcf_ptr, code); if code = 0 then if tcf_ptr -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr ^= null then if index (tcf_ptr -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr -> attach_descrip_string, "-stationary") ^= 0 then do; /* complain */ code = error_table_$incompatible_attach; call sub_err_ (code, "vfile_", "c", null, "The tcf switch must not be attached with the -stationary option."); end; end; if code = 0 then call create_attach_block; if code = 0 then do; /* set pointers, entries in iocb */ attach_data_ptr = attach_block_ptr; attach_descrip_ptr = addr (attach_descrip); open = open_file; control = control_file; /* file_status supported with switch closed */ detach_iocb = detach_file; call iox_$propagate (iocb_ptr); end; else if command_switch then call com_err_ (code, "vfile_", "^a", name); return; verify_and_interpret_args: proc; if attach_descrip_ptr ^= null then code = error_table_$not_detached; else if length (option_array (1)) > 168 then code = error_table_$pathlong; else do; code = 0; n_opts = hbound (option_array, 1); if n_opts > 10 then code = error_table_$bad_arg; else do i = 2 to n_opts while (code = 0); if option_array (i) = "-extend" then extend_attach_option = "1"b; else if option_array (i) = "-truncate" | option_array (i) = "-tc" then extend_attach_option = "0"b; else if option_array (i) = "-share" then do; /* pick up wait_time */ shared_option = "1"b; call get_n_opt (wait_time_option); /* pick up number */ if wait_time_option < -1 then code = error_table_$bad_arg; end; else if option_array (i) = "-blocked" /* blocked file */ then do; /* pick up max_rec_len if given */ blocked_option = "1"b; call get_n_opt (max_recl); /* get optional number */ if max_recl < 0 then code = error_table_$negative_nelem; end; else if option_array (i) = "-append" then append_option = "1"b; else if option_array (i) = "-no_trunc" then no_trunc_option = "1"b; else if option_array (i) = "-header" then do; /* set header info */ header_option = "1"b; call get_n_opt (identifier); /* pick up optional ident number */ end; else if option_array (i) = "-old" then old_option = "1"b; /* prevents creation */ else if option_array (i) = "-ssf" then ssf_option = "1"b; else if option_array (i) = "-dup_ok" then dup_ok_opt = "1"b; else if (option_array (i) = "-stationary") | (option_array (i) = "-stat") then stat_opt = "1"b; else if option_array (i) = "-no_end" then noend_option = "1"b; /* allows positioning beyond eof */ else if option_array (i) = "-exclusive" then exclu_option = "1"b; else if (option_array (i) = "-transaction") | (option_array (i) = "-trans") then if i >= n_opts /* no more args */ then code = error_table_$noarg; else do; /* get tcf switch name */ i = i + 1; /* skip over next arg */ tcf_name = option_array (i); trans_opt = "1"b; end; else if (option_array (i) = "-checkpoint") then checkpoint_opt = "1"b; else code = error_table_$bad_arg; end; end; if code = 0 then do; rel_pathname = option_array (1); rel_pathname_length = length (option_array (1)); if ((extend_attach_option & (append_option | no_trunc_option)) | (append_option & no_trunc_option) | (header_option & (checkpoint_opt | blocked_option | exclu_option | shared_option)) | (blocked_option & (checkpoint_opt | no_trunc_option)) | ((dup_ok_opt | stat_opt | trans_opt) & (checkpoint_opt | ssf_option | blocked_option | no_trunc_option | append_option | noend_option)) | (shared_option & (no_trunc_option | exclu_option))) then code = error_table_$bad_arg; end; return; end; /* end verify args */ get_n_opt: proc (n); /* used to pick up optional numerical argument */ if i < n_opts then do; /* another option exists--look at it */ num = cv_dec_check_ ((option_array (i + 1)), er_code); if er_code = 0 /* valid integer */ then do; /* grab next option */ i = i + 1; /* advance option_array index */ saved_i = i; /* save element number */ n = num; /* set the argument */ end; end; dcl (n, num) fixed (35); end get_n_opt; create_attach_block: proc; dname, ename = " "; call expand_path_ (addr (rel_pathname), rel_pathname_length, addr (dname), addr (ename), code); if code = 0 then do; call alloc_cb_file (size (attach_block), attach_block_ptr); dup_ok_sw = dup_ok_opt; noend_sw = noend_option; exclu_sw = exclu_option; stat_sw = stat_opt; trans_sw = trans_opt; checkpoint_sw = checkpoint_opt; ssf = ssf_option; old = old_option; blocked = blocked_option; max_rec_len = max_recl; header_present = header_option; header_id = identifier; no_trunc = no_trunc_option; appending = append_option; extend_attach = extend_attach_option | appending | no_trunc | old; shared = shared_option; wait_time = 1000000 * wait_time_option; interp = 0; /* this option may be supported in future */ dname_len = length (dname) + 1 - verify (reverse (dname), " "); ename_len = length (ename) + 1 - verify (reverse (ename), " "); string = "vfile_ " || substr (dname, 1, dname_len) || ">"; string = string || substr (ename, 1, ename_len); if no_trunc then string = string || " -no_trunc"; if appending then string = string || " -append"; if extend_attach_option then string = string || " -extend"; if noend_sw then string = string || " -no_end"; if interp = 1 then string = string || " -raw"; if old then string = string || " -old"; if ssf /* limited to single-segment files */ then string = string || " -ssf"; if dup_ok_sw then string = string || " -dup_ok"; if stat_sw then string = string || " -stationary"; if trans_sw then do; string = string || " -transaction " || tcf_name; attach_block.tcf_iocbp = tcf_ptr; end; if checkpoint_sw then string = string || " -checkpoint"; if header_present then do; string = string || " -header"; string = string || " " || ltrim (char (identifier)); end; if blocked then do; string = string || " -blocked"; string = string || " " || ltrim (char (max_rec_len)); end; if exclu_sw then string = string || " -exclusive"; if shared then do; string = string || " -share "; string = string || ltrim (char (wait_time_option)); end; attach_descrip_len = length (string); attach_descrip_string = string; end; dcl ename char (32) aligned; dcl expand_path_ external entry (ptr, /* ptr to relative pathname */ fixed bin, /* length of relative pathname */ ptr, /* ptr to char(l68) aligned to hold expanded directory name */ ptr, /* ptr to char(32) aligned to hold expanded entry name */ fixed bin (35)); /* status code */ dcl dname char (168) aligned; dcl string char (256) varying; end; /* end create_attach_block */ open_file: entry (iocb_ptr_arg, mode_arg, extend_arg, code); begin; iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr; attach_block_ptr = attach_data_ptr; was_msf = "0"b; i_set_lock = "0"b; /* will unlock file only if I locked it */ fcb_ptr, first_seg_ptr = null; /* will cleanup if non-null */ mode = mode_arg; call verify_open_args_set_descrip; if code = 0 then call get_file_base; if code = 0 then call check_set_file_type; if code = 0 then call check_set_file_already_open; if (code = 0) & (^is_msf) & (file_type = 2 /* indexed */) then call open_msf; /* always use msf_manager with indexed files */ if code = 0 then do; if file_type = 0 then open_x = open_uns_file; else if file_type = 1 then open_x = open_seq_file; else if file_type = 2 then open_x = open_indx_file; else if file_type = 3 then open_x = open_blk_file; call open_x (iocb_ptr, fcb_ptr, first_seg_ptr, is_new_file, mode, close_x, first_seg_bitcount, max_component_size, code); end; if code = 0 then do; close = close_file; open_descrip_ptr = addr (open_descrip); call iox_$propagate (iocb_ptr); end; else do; if first_seg_ptr ^= null then if i_set_lock then call set_lock_$unlock (open_lock, foo); call cleanup; end; return; /* end of opening main routine */ verify_open_args_set_descrip: proc; if (mode <= 0) | (mode > 13) then code = error_table_$bad_arg; else if (interp = 1) & (mode ^= 1) then code = error_table_$incompatible_attach; else if (((blocked | checkpoint_sw) & ((mode < 4) | (mode > 7))) | ((ssf | noend_sw) & (mode > 7)) | (exclu_sw & is_input_only_mode (mode)) | ((trans_sw | shared | exclu_sw | dup_ok_sw | stat_sw) & ((mode < 4) | (^(extend_arg | extend_attach) & ((mode = 5) | (mode = 6))))) | ((no_trunc | header_present) & (mode > 3))) then code = error_table_$incompatible_attach; else do; code = 0; open_descrip_len = length (mode_descrip (mode)); open_descrip_string = mode_descrip (mode); end; dcl string char (32) varying; end; /* end verify_open_args_set_descrip */ get_file_base: proc; branch_info.bit_count = "0"b; is_msf = "0"b; attach_block.last_comp = 0; call hcs_$status_long (substr (attach_descrip_string, 8, dname_len), substr (attach_descrip_string, 9 + dname_len, ename_len), 1, addr (branch_info), null, foo); if foo ^= 0 then if foo = error_table_$no_s_permission then foo = 0; /* we don't need any missing info */ if (type = "10"b) & (bit_count = "0"b) & (foo = 0) then do; /* entry is a directory--flag the error */ code = error_table_$dirseg; return; /* unsuccessfulopening */ end; else if (type = "10"b) & (foo = 0) /* must be an msf */ then if ssf /* -ssf option was specified--no msf's allowed */ then do; /* flag the error */ code = error_table_$incompatible_attach; return; end; else do; was_msf = "1"b; attach_block.last_comp = fixed (bit_count) - 1; call open_msf; call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, first_seg_ptr, first_seg_bitcount, foo); end; is_new_file = (is_output_mode (mode) & ^extend_attach & ^extend_arg) | ((branch_info.bit_count = "0"b) & ^is_input_only_mode (mode) & ^old); if ^is_msf then do; /* get pointer to base of single segment file */ first_seg_bitcount = fixed (branch_info.bit_count, 24, 0); if is_new_file then call hcs_$make_seg (substr (attach_descrip_string, 8, dname_len), substr (attach_descrip_string, 9 + dname_len, ename_len), "", 01010b /* rw access */, first_seg_ptr, foo); else call hcs_$initiate (substr (attach_descrip_string, 8, dname_len), substr (attach_descrip_string, 9 + dname_len, ename_len), "", 0, 1, first_seg_ptr, foo); end; if first_seg_ptr = null then code = foo; if code = 0 then do; /* check access */ access_mode = 0; call hcs_$fs_get_mode (first_seg_ptr, access_mode, foo); if (access_required (mode) & ^bit (access_mode)) ^= "0"b then code = error_table_$moderr; end; if code = 0 then do; call hcs_$get_max_length_seg (first_seg_ptr, max_component_size, foo); if is_new_file then do; if ^is_msf /* single segment */ then call hcs_$truncate_seg (first_seg_ptr, 0, foo); else call msf_manager_$adjust (fcb_ptr, 0, 0, "010"b, foo); /* truncate file, which leaves first page set to zero */ call hcs_$set_bc_seg (first_seg_ptr, 0, foo); first_seg_bitcount = 0; end; end; dcl access_mode fixed bin (5); dcl hcs_$fs_get_mode external entry (ptr, fixed bin (5), fixed bin (35)); /* second arg interpreted as bit(5), second bit = read access, fourth bit is write access, other bits irrelevant here */ dcl hcs_$get_max_length_seg entry (ptr, /* ptr to seg */ fixed bin (19), /* max length in words */ fixed bin (35)); /* code */ dcl hcs_$set_bc_seg entry (ptr, /* ptr to segment */ fixed bin (24), /* bitcount */ fixed bin (35)); /* status code */ end get_file_base; check_set_file_type: proc; if mode < 4 then do; file_type = 0; if is_new_file & header_present then file_code = file_code_table (0); end; else if is_new_file then do; if mode < 8 then if blocked then file_type = 3; else file_type = 1; /* normal sequential file */ else file_type = 2; call check_type; if code = 0 then file_code = file_code_table (file_type); end; else do; if file_code = file_code_table (1) then file_type = 1; else if file_code = file_code_table (2) then file_type = 2; else if file_code = file_code_table (3) then file_type = 3; else code = error_table_$bad_file; if code = 0 then call check_type; end; return; /* end of check_set_file_type main routine */ check_type: proc; if ^substr (compatible_types (mode), file_type, 1) | ((file_type = 2) & ssf) | (((file_type = 1) | (file_type = 2)) & noend_sw) | (checkpoint_sw & ^(file_type = 1)) | ((dup_ok_sw | stat_sw | trans_sw) & (file_type ^= 2)) | ((shared | exclu_sw) & (file_type < 2)) then code = error_table_$incompatible_attach; end check_type; dcl compatible_types (4:13) bit (3) static init ("111"b, "101"b, "101"b, "111"b, "010"b, "010"b, "010"b, "010"b, "010"b, "010"b) ; dcl file_code_table (0:3) static internal fixed bin init (31191, 83711, 7129, 22513); end; /* end check_set_file_type */ open_msf: proc; /* opens ssf as msf for indexed file */ is_msf = "1"b; call msf_manager_$open (substr (attach_descrip_string, 8, dname_len), substr (attach_descrip_string, 9 + dname_len, ename_len), fcb_ptr, foo); /* creates msf control block */ if (fcb_ptr = null) & (foo ^= 0) then code = foo; /* unexpected error */ end open_msf; check_set_file_already_open: proc; if file_type ^= 0 then do; if is_input_only_mode (mode) then do; if ^shared & (open_lock ^= "0"b) then code = error_table_$file_busy; end; else do; call set_lock_$lock (open_lock, divide (wait_time + 500000, 1000000, 35, 0), foo); if foo ^= 0 then if foo = error_table_$invalid_lock_reset /* locked by dead proc */ then do; inv_lock_reset = "1"b; i_set_lock = "1"b; end; else code = error_table_$file_busy; else do; inv_lock_reset = "0"b; i_set_lock = "1"b; end; end; end; end; /* end check_set_file_already_open */ dcl i_set_lock bit (1) aligned; dcl first_seg_bitcount fixed bin (24); dcl is_new_file bit (1) aligned; dcl open_x variable entry (ptr,/* iocb_ptr, input */ ptr, /* fcb_ptr, input */ ptr, /* first_seg_ptr, input */ bit (1) aligned, /* is_new_file, input */ fixed bin, /* mode */ entry, /* close_x, output */ fixed bin (24), /* first seg bitcount */ fixed bin (19), /* max_component_size */ fixed bin (35)); /* code, if not 0, open_x leaves iocb as is */ dcl open_uns_file entry external; dcl open_seq_file entry external; dcl open_blk_file entry external; dcl open_indx_file entry external; end; /* end of open_file routine */ cleanup: proc; if fcb_ptr ^= null then call msf_manager_$close (fcb_ptr); if (^was_msf) & (first_seg_ptr ^= null) then call hcs_$terminate_noname (first_seg_ptr, foo); end cleanup; control_file: entry (iocb_ptr_arg, order, info_ptr, code); iocb_ptr = iocb_ptr_arg -> iocb.actual_iocb_ptr; if order = "file_status" then call vfile_status_$seg (iocb_ptr, (null), info_ptr, code); else if order = "io_call" then call vfile_io_control (iocb_ptr, (null), info_ptr, code); else code = error_table_$no_operation; return; /* end of control operation supported with switch closed */ close_file: entry (iocb_ptr_arg, code); code = 0; iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr; attach_block_ptr = attach_data_ptr; call close_x (iocb_ptr); if (file_type = 1 /* seq */) & (^is_input_only_mode (mode)) then call set_lock_$unlock (open_lock, foo); iocb.control = control_file; open_descrip_ptr = null; open = open_file; detach_iocb = detach_file; call iox_$propagate (iocb_ptr); call cleanup; return; /* end of close routine */ detach_file: entry (iocb_ptr_arg, code); begin; iocb_ptr = iocb_ptr_arg; attach_block_ptr = attach_data_ptr; code = 0; attach_descrip_ptr = null; call iox_$propagate (iocb_ptr); call free_cb_file (size (attach_block), attach_block_ptr); end; return; /* end detach routine */ /* DECLARATIONS FOR COMPLETE PROGRAM */ dcl sub_err_ entry options (variable); dcl info_ptr ptr; dcl order char (*); dcl vfile_status_$seg entry (ptr, ptr, ptr, fixed (35)); dcl vfile_io_control entry (ptr, ptr, ptr, fixed (35)); dcl 1 branch_info aligned, /* info returned by hcs_$status_long */ 2 type bit (2) unal, 2 pad0 bit (34) unal, 2 words1 (6) fixed, /* of no interest */ 2 pad1 bit (12) unal, 2 bit_count bit (24) unal, /* distinguishes msf and dir */ 2 words2 (2); dcl hcs_$status_long entry (char (*), char (*), fixed (1), ptr, ptr, fixed (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35)); dcl hcs_$terminate_noname entry (ptr, fixed (35)); dcl hcs_$truncate_seg entry (ptr, fixed (18), fixed (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed (5), ptr, fixed (35)); dcl msf_manager_$close external entry (ptr); /* This entry frees the msf file control block and terminates all initiated components */ dcl msf_manager_$adjust external entry (ptr, /* fcb_ptr input */ fixed bin, /* component number, input */ fixed bin (24), /* bit count, input */ bit (3), /* "010"b implies don't set bit counts (use hcs_$set_bc_seg), truncate seg, don't terminate seg */ fixed bin (35)); /* code, output */ dcl msf_manager_$get_ptr external entry (ptr, /* fcb_ptr, input */ fixed bin, /* create switch, input */ bit (1), /* create switch, input */ ptr, /* pointer to seg., output, null if error */ fixed bin (24), /* bit count, output */ fixed bin (35)); /* code, output */ dcl msf_manager_$open external entry (char (*), /* directory pathname, input */ char (*), /* entry name, input */ ptr, /* fcb_ptr, output, good unless code is error_table_$dirseg */ fixed bin (35)); /* code, output */ dcl (extend_attach_option, shared_option, blocked_option, append_option, old_option, dup_ok_opt, exclu_option, noend_option, stat_opt, trans_opt, checkpoint_opt) bit (1) aligned init ("0"b); dcl tcf_name char (32) var; dcl tcf_ptr ptr; dcl (no_trunc_option, ssf_option, header_option) bit (1) aligned init ("0"b); dcl wait_time_option fixed (35) init (1); dcl identifier fixed (35) init (0); dcl max_recl fixed (35) init (0); dcl (n, i, n_opts, er_code); dcl saved_i fixed init (0); dcl cv_dec_check_ entry (char (*), fixed) returns (fixed (35)); dcl access_required (13) bit (5) static internal init ("01000"b, "00010"b, "01010"b, "01000"b, "01010"b, "01010"b, "01010"b, "01000"b, "01010"b, "01010"b, "01000"b, "01010"b, "01010"b); /* second bit is r access, fourth bit is w access */ dcl addr builtin; dcl alloc_cb_file external entry (fixed bin, /* size of block in words, input */ ptr); /* pointer to block, output */ dcl 1 attach_block based (attach_block_ptr), /* the following are set by attach_file */ 2 flags aligned, 3 (extend_attach, appending, no_trunc, old, ssf, header_present, blocked, shared, was_msf, is_msf, inv_lock_reset, dup_ok_sw, trans_sw, noend_sw, exclu_sw, stat_sw, checkpoint_sw) bit (1) unal, 3 pad bit (19) unal, 2 wait_time fixed (35), 2 interp fixed, 2 max_rec_len fixed (35), 2 header_id fixed (35), 2 attach_descrip, 3 attach_descrip_len fixed bin (35), /* < = 256 */ 3 attach_descrip_string char (256), /* "-pn " (4 chars), the directory pathname (dname_len chars), ">", the entry name (ename_len chars), " -extend" (optional 8 chars), and " -raw" or " -extend"(optional 8 chars) */ 2 dname_len fixed bin, /* < = l68 */ 2 ename_len fixed bin, /* < = 32 */ /* The following are set by open_file */ 2 open_descrip, 3 open_descrip_len fixed bin (35), /* < = 31 */ 3 open_descrip_string char (32), /* The string contains the opening mode, e.g., "stream output", (< = 23 chars) and " -extend" (8chars optional) */ 2 mode fixed bin, /* opening mode 1 <= 13 */ 2 file_type fixed bin, /* 0 = uns, 1 = seq, 2 = indx, 3 = blk */ 2 fcb_ptr ptr, /* pointer to msf_manager control block */ 2 first_seg_ptr ptr, /* pointer to first component of the file. Thie pointer is valid throughout the file opening */ 2 close_x entry (ptr), /* routine to perform operations required for closing specific type of file obtained from open_x see open_file */ 2 last_comp fixed, /* msf component number at open */ 2 tcf_iocbp ptr; /* iocb ptr for transaction control switch */ dcl attach_block_ptr ptr; dcl bit builtin; dcl code fixed bin (35); /* status code argument */ dcl com_err_ entry options (variable); dcl command_switch bit (1) aligned; dcl 1 common_header based (first_seg_ptr), /* This header is used for all seq and indx files. Its contents are manipulated by open_file and close_file but not by the specific access methods. Its size is 4 words */ 2 file_code fixed bin (35), 2 open_lock bit (36) aligned, /* nonzero if file open unless shared */ 2 reserved (2) fixed bin; dcl extend_arg bit (1) aligned; dcl foo fixed bin (35); /* used when output parameters value is to beignored */ dcl hbound builtin; dcl iocb_ptr ptr; dcl iocb_ptr_arg ptr; dcl is_input_only_mode (13) static internal bit (1) init ("1"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "1"b, "0"b, "0"b); dcl is_output_mode (13) static internal bit (1) init ("0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b, "0"b, "0"b, "1"b, "0"b); dcl length builtin; dcl max_component_size fixed bin (19); dcl mode_arg fixed bin; dcl mode_descrip (13) char (24) varying static internal init ("stream_input", "stream_output", "stream_input_output", "sequential_input", "sequential_output", "sequential_input_output", "sequential_update", "keyed_sequential_input", "keyed_sequential_output", "keyed_sequential_update", "direct_input", "direct_output", "direct_update"); dcl null builtin; dcl option_array (*) char (*) varying; dcl iox_$propagate entry (ptr); dcl iox_$look_iocb entry (char (*), ptr, fixed (35)); dcl rel_pathname char (168); dcl rel_pathname_length fixed bin; dcl reverse builtin; dcl set_lock_$lock entry (bit (36) aligned, /* lock word */ fixed bin, /* num of seconds to wait */ fixed bin (35)); /* code=0 or et_$invalid_lock_reset are success codes */ dcl set_lock_$unlock entry (bit (36) aligned, /* lock word */ fixed bin (35)); /* code */ dcl size builtin; dcl substr builtin; dcl verify builtin; dcl error_table_$negative_nelem external fixed (35); dcl error_table_$noarg external fixed (35); dcl error_table_$no_s_permission external fixed (35); dcl error_table_$no_operation fixed (35) external; dcl error_table_$bad_arg external fixed bin (35); dcl error_table_$pathlong external fixed bin (35); dcl error_table_$moderr external fixed bin (35); dcl error_table_$dirseg external fixed bin (35); dcl error_table_$not_detached external fixed bin (35); dcl error_table_$bad_file external fixed bin (35); dcl error_table_$file_busy external fixed bin (35); dcl error_table_$incompatible_attach external fixed bin (35); dcl error_table_$invalid_lock_reset external fixed bin (35); dcl free_cb_file external entry (fixed bin, /* size of block in words, input */ ptr); /* pointer to block); input */ %include iocbv; /* GENERAL COMMENTS This external procedure implements file attachment and the i-o operations open, close and detach for this attachment (entries: open_file, close_file, detach_file). The code for each entry immediately follows the entry and terminates with a return statement. Before reading the code familiarize yourself with the general conventions for implementing attachments (see the MPM) and read the declarations of attach_block and common header. The whole thing can be considered a single program in which attach, open, close, and detach are done in that order. The difficult operation is open. It does that which is common to the various types of files. The specific access method is called (via open_x) to set up its control block and perform any special file initialization. open_file will have to be changed when file types are put in the directory branches. */ end /* end of vfile_attach program */;  vfile_copy_opening_.pl1 11/04/82 1940.0rew 11/04/82 1607.2 83088 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: style2,ind3 */ vfile_copy_opening_: proc (p_source_iocb_ptr, p_target_sw_name, p_target_iocb_ptr, p_code); /* This module makes an iocb (at p_target_iocb_ptr) with the same attributes as the source iocb. The target iocb is positioned "outside" of the index and has the pos_incorrect bit set. This iocb, then, has basically the same appearance as (and is indistinguishable from) an iocb which has just been attached and opened in the normal fashion. As much as possible, the copied opening is made by actually copying the data structures. For the seg_ptr_array and the position_stack, the vfile_ utilities are used to do the copying, as various protocols must be followed in filling in these structures and some data must be unique to each iocb (hence cant just be copied). In the case of the seg_ptr_array, there must be one initiation per opening per segment and create_seg_ptrs takes care of setting this up. In the case of the position_stack, various pointers in the stack must be set to point elsewhere in the same stack and some pointers in the indx_cb have to be set to point to the position_stack. This is done by create_position_stack. Written 03/01/81 by Lindsey Spratt. Modified: 06/22/81 by Lindsey Spratt: Replace call to msf_manager_$open with direct copy of the fcb. The initiated_components portion of the structure must be set to 0 to indicate that this new fcb opening has no initiated segments associated with it. The following msf_get_ptr adds the first one, and successive calls by create_seg_ptrs finishes this processes. 06/30/81 by Lindsey Spratt: Changed to use vfile_attach_block.incl.pl1, iocb.incl.pl1 instead of iocbv.incl.pl1, deleted position_stack declaration. */ /* START OF DECLARATIONS */ /* Parameter */ dcl p_source_iocb_ptr ptr; dcl p_target_sw_name char (*); dcl p_target_iocb_ptr ptr; dcl p_code fixed bin (35); /* Automatic */ dcl iocb_ptr ptr; dcl pos_ptr ptr; dcl fcbp ptr; /* The msf_manager_ File Control Block, fcb, is based on this variable. */ dcl bead_idx fixed bin; dcl source_fcb_ptr ptr; dcl old_target_ibp ptr; dcl target_ibp ptr; dcl source_ibp ptr; /* Based */ dcl free_area area (sys_info$max_seg_size - 1) based (system_areap); dcl 1 fcb based (fcbp) aligned, /* the multi-segment file control block */ 2 version fixed bin, /* version of this structure - 0 now */ 2 type fixed bin, /* form of msf - ssf, msf, or not_exists */ 2 max_components fixed bin, /* maximum number of components (same as bitcount) */ 2 max_len fixed bin (19), /* Max number of words in each component. */ 2 pad (1) fixed bin, 2 pathnames, /* dirnname, ename, and combined of the file */ 3 dname char (168), 3 ename char (32), 3 path char (168), 2 initiated_components, /* information about the initiated components in the file */ 3 number fixed bin, /* how many are initiated */ 3 highest_value fixed bin, /* the highest component value of those inited */ 3 listp ptr, /* ptr to head of the list of inited segs */ 2 rbs (3) fixed bin (3), /* save ring bracks */ 2 upgrade_sw bit (1) aligned, /* if components are multiclass segments */ 2 access_class bit (72) aligned; /* acc if upgrade_sw ON */ /* DRV - add volume backup switch to FCB here */ dcl 1 initiation_bead based aligned, /* one for each initiated component of the msf */ 2 component fixed bin, /* which component it is */ 2 bitcount fixed bin (24), /* its bitcount */ 2 segptr ptr, /* a ptr to it */ 2 next ptr; /* next bead in list or null */ /* Builtin */ /* Controlled */ /* Constant */ /* Entry */ dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); /* External */ dcl error_table_$badcall fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin (35) ext; /* Static */ dcl system_areap ptr internal static init (null); /* END OF DECLARATIONS */ /* Validate the source opening for being copied. It must be an index sequential opening, must not be opened for exclusive operations. It must be opened in shared mode, and it must be an msf. */ iocb_ptr = null; attach_block_ptr = p_source_iocb_ptr -> iocb.attach_data_ptr; if attach_block.mode ^= Keyed_sequential_update & attach_block.mode ^= Keyed_sequential_output & attach_block.mode ^= Keyed_sequential_input then do; p_code = error_table_$badcall; return; end; if attach_block.exclu_sw | ^attach_block.shared | ^attach_block.is_msf then do; p_code = error_table_$badcall; return; end; /* Find and/or create the target iocb. */ call iox_$find_iocb (p_target_sw_name, p_target_iocb_ptr, p_code); if p_code ^= 0 then return; p_target_iocb_ptr -> iocb = p_source_iocb_ptr -> iocb; p_target_iocb_ptr -> iocb.actual_iocb_ptr = p_target_iocb_ptr; p_target_iocb_ptr -> iocb.name = p_target_sw_name; call alloc_cb_file (size (attach_block), attach_block_ptr); attach_block = p_source_iocb_ptr -> iocb.attach_data_ptr -> attach_block; p_target_iocb_ptr -> iocb.attach_data_ptr = attach_block_ptr; p_target_iocb_ptr -> iocb.attach_descrip_ptr = addr (attach_block.attach_descrip); p_target_iocb_ptr -> iocb.open_descrip_ptr = addr (attach_block.open_descrip); call alloc_cb_file (size (indx_cb), indx_cb_ptr); indx_cb = p_source_iocb_ptr -> iocb.open_data_ptr -> indx_cb; p_target_iocb_ptr -> iocb.open_data_ptr = indx_cb_ptr; indx_cb.pos_incorrect = "1"b; indx_cb.next_record_position = 0; indx_cb.current_record_is_valid = "0"b; indx_cb.ready_to_write = "0"b; indx_cb.repeating = "0"b; indx_cb.error.type = 0; indx_cb.at_bof = "0"b; indx_cb.at_eof = "0"b; indx_cb.min_res = 0; indx_cb.min_cap = 0; indx_cb.leave_locked = "0"b; indx_cb.outside_index = "0"b; indx_cb.new_key = ""; indx_cb.skip_state = 0; indx_cb.transaction_code = 0; indx_cb.reflp = null; indx_cb.collection_delay_time = 0; /* The subsetting information must be set to indicate that no subsetting has been done yet on this opening. */ indx_cb.current_subset = 0; indx_cb.last_subset = 0; indx_cb.subset_count = 0; indx_cb.temp_iocbp = null; /* It is necessary for each opening to have its own MSF fcb to point at. */ if system_areap = null then system_areap = get_system_free_area_ (); alloc fcb in (free_area) set (fcbp); fcb = p_source_iocb_ptr -> iocb.attach_data_ptr -> attach_block.fcb_ptr -> fcb; indx_cb.fcb_ptr = fcbp; fcb.initiated_components.number = 0; fcb.initiated_components.highest_value = 0; fcb.initiated_components.listp = null; attach_block.fcb_ptr = indx_cb.fcb_ptr; /* The attach_block fcb_ptr is used when closing. */ call msf_manager_$get_ptr (indx_cb.fcb_ptr, 0, "0"b, indx_cb.file_base_ptr, 0, p_code); if p_code ^= 0 then return; /* create_seg_ptrs is called to set up the seg_ptr_array and initiate all of the segments in the msf. It does this by doing msf_manager_$get_ptr. The end result of this is to have an fcb identical to the fcb of the opening being copied. The reason it is necessary to go through all of the mechanism of create_seg_ptrs and msf_manager_$get_ptr is to have the hcs_$initiate calls made on all of the segments, since (at close time) hcs_$terminate_noname is called. The other approach, to allocate and copy data explicitly to build the fcb and seg_ptr_array structures without invoking other routines, works fine except that the segments are terminated out from under the iocbs which are copies of the iocb being closed and detached. */ call create_seg_ptrs (p_target_iocb_ptr); /* The position stack and some data in the indx_cb must be initialized. For this it is necessary to call create_position_stack. */ call create_position_stack (indx_cb_ptr); attach_block.was_msf = (indx_cb.file_base_ptr -> file_base.max_comp_num > 1); return; %include iocb; %include iox_entries; %include vfile_indx; %include vfile_attach_block; %include iox_modes; end vfile_copy_opening_;  vfile_io_control.pl1 11/04/82 1940.0rew 11/04/82 1620.4 242937 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* this routine is used by io_call to support control orders issued to vfile_ from command level */ /* format: style2 */ vfile_io_control: proc (iocb_ptr, file_base_ptr, io_call_infop, code); is_af = "0"b; /* not active function entry */ mainline: brief_sw = "0"b; info_ptr = addr (info); if (io_call_info.order_name = "get_key") | (io_call_info.order_name = "gk") then do; substr_sw = "0"b; gk_info_ptr = info_ptr; unspec (gk_info.flags) = "0"b; gk_info.version = gk_info_version_0; do i = 1 to nargs; /* pick up optional args */ if (io_call_info.args (i) = "-substr") | (io_call_info.args (i) = "-su") then if io_call_info.nargs < i + 1 then go to noarg; else do; i = i + 1; comma_off = index (io_call_info.args (i), ","); substr_sw = "1"b; if comma_off = 0 /* whole tail wanted */ then substr_off = fixed (io_call_info.args (i)); else do; substr_off = fixed (substr (io_call_info.args (i), 1, comma_off - 1)); substr_len = fixed (substr (io_call_info.args (i), comma_off + 1)); end; end; else if io_call_info.args (i) = "-head" /* next arg is head */ then if io_call_info.nargs <= i /* not enough args */ then do; noarg: code = error_table_$noarg; return; /* abort */ end; else do; i = i + 1; handle_head: gk_info.input_key = "1"b; if gk_info.current then go to badarg; /* -cur_pos and -head conflict */ gk_info.key_len = length (io_call_info.args (i)); gk_info.head_size = gk_info.key_len; gk_info.key = io_call_info.args (i); end; else if (io_call_info.args (i) = "-desc") | (io_call_info.args (i) = "-ds") then if i = io_call_info.nargs then go to noarg; else do; i = i + 1; if gk_info.desc_code = 1 /* -current descriptor specified */ then go to badarg; /* conflicts with given descriptor */ gk_info.input_desc = "1"b; gk_info.descrip = cv_oct_ ((io_call_info.args (i))); end; else if (io_call_info.args (i) = "-reset") | (io_call_info.args (i) = "-rs") then gk_info.reset_pos = "1"b; else if (io_call_info.args (i) = "-current") | (io_call_info.args (i) = "-cur") then if gk_info.input_desc then go to badarg; /* conflicting options */ else gk_info.desc_code = 1; else if (io_call_info.args (i) = "-rel_type") | (io_call_info.args (i) = "-rel") then if io_call_info.nargs = i then go to noarg; else do; if gk_info.current /* -cur_pos specified */ then go to badarg; /* conflicts */ i = i + 1; gk_info.rel_type = fixed (io_call_info.args (i)); if (gk_info.rel_type < 0) | (gk_info.rel_type > 2) then go to badarg; end; else if io_call_info.args (i) = "-cur_pos" then if gk_info.input_key | (gk_info.rel_type ^= 0) then go to badarg; else gk_info.current = "1"b; else if (io_call_info.args (i) = "-brief") | (io_call_info.args (i) = "-bf") then brief_sw = "1"b; else if gk_info.input_key /* head already given */ then do; /* must be an invalid arg */ badarg: code = error_table_$bad_arg; return; end; else go to handle_head; end; call control ("get_key"); if substr_sw then if comma_off = 0 then substr_len = gk_info.key_len + 1 - substr_off; else ; else do; substr_off = 1; substr_len = gk_info.key_len; end; substr_len = min (substr_len, gk_info.key_len + 1 - substr_off); if is_af then if code = 0 then do; io_call_af_ret = substr (gk_info.key, substr_off, min (af_returnl, substr_len)); return; end; else do; io_call_af_ret = ""; if brief_sw then do; brief_ret: if code = 0 then return; if (code ^= error_table_$no_operation) & (code ^= error_table_$bad_arg) then code = 0; return; end; end; if brief_sw then go to brief_ret; if code = 0 then if substr_sw then call io_call_info.report (substr (gk_info.key, substr_off, substr_len)); else call io_call_info.report ("key: ^a descrip: ^o", gk_info.key, gk_info.descrip); return; end; if ((io_call_info.order_name = "read_position") | (io_call_info.order_name = "rp")) & ^is_af then do; /* no input args--just print results */ call control ("read_position"); if code = 0 then call io_call_info.report ("next pos: ^d end pos: ^d", rp_info.next_pos, rp_info.end_pos); end; else if ((io_call_info.order_name = "record_status") | (io_call_info.order_name = "rs") | (io_call_info.order_name = "rsb")) & ^is_af then do; brief_sw = (io_call_info.order_name = "rsb"); i = 0; if io_call_info.nargs > 0 then if (io_call_info.args (1) = "-brief") | (io_call_info.args (1) = "-bf") then do; i = 1; brief_sw = "1"b; end; rs_info_ptr = info_ptr; rs_info.version = rs_info_version_2; rs_info.record_ptr = null; rs_info.ref_count = -1; rs_info.modifier = 0; rs_info.last_image_modifier = 0; if io_call_info.nargs - i >= 1 /* more optional argument given */ then if io_call_info.args (1 + i) = "-pos" then string (rs_info.flags) = "0000001"b; /* locate_pos_sw */ else string (rs_info.flags) = substr (bit (io_call_info.args (1 + i)), 1, 7); else string (rs_info.flags) = "0"b; if rs_info.create_sw /* two more args required */ then do; /* get rec_len and block_size */ if io_call_info.nargs - i < 2 then do; code = error_table_$noarg; return; /* abort */ end; rs_info.record_length = fixed (io_call_info.args (2 + i), 21, 0); /* length in bytes */ if nargs = 2 + i /* max_rec_len not specified, use default */ then rs_info.max_rec_len = rs_info.record_length; else rs_info.max_rec_len = fixed (io_call_info.args (3 + i), 19, 0); /* max rec len in bytes */ end; else if rs_info.locate_sw /* one additional arg required */ then if io_call_info.nargs < 2 + i then do; code = error_table_$noarg; return; end; else rs_info.descriptor = cv_oct_ ((io_call_info.args (2 + i))); else if rs_info.locate_pos_sw then if io_call_info.nargs < 2 + i then go to noarg; /* pos specification required */ else do; rs_info.record_length = fixed (io_call_info.args (2 + i)); if io_call_info.nargs < 3 + i then rs_info.descriptor = 0; else rs_info.descriptor = cv_oct_ ((io_call_info.args (3 + i))); end; if rs_info.lock_sw /* modifier code may be supplied */ then if rs_info.create_sw & (io_call_info.nargs > 3 + i) then rs_info.modifier = fixed (io_call_info.args (4 + i), 35, 0); else if rs_info.locate_sw & (io_call_info.nargs > 2 + i) then rs_info.modifier = fixed (io_call_info.args (3 + i), 35, 0); else if io_call_info.nargs > 1 + i then rs_info.modifier = fixed (io_call_info.args (2 + i), 35, 0); call control ("record_status"); if brief_sw then go to brief_ret; if (code ^= 0) & (rs_info.record_ptr = null) & (rs_info.ref_count = -1) /* no info returned */ then return; /* don't print out a bunch of garbage */ call io_call_info.report ("record bytes: ^d max rec bytes: ^d", rs_info.record_length, rs_info.max_rec_len); if rs_info.max_rec_len ^= 0 /* block has been allocated */ then call io_call_info.report ("record ptr: ^p descriptor: ^o", rs_info.record_ptr, rs_info.descriptor); if rs_info.ref_count >= 0 /* more stats to print */ then do; call date_time_ (rs_info.time_last_modified, date_time); call io_call_info.report ("ref count: ^d last changed: ^a", rs_info.ref_count, date_time); if rs_info.modifier ^= 0 then call io_call_info.report ("modifier: ^d", rs_info.modifier); if rs_info.last_image_modifier ^= 0 then call io_call_info.report ("last modifier: ^d", rs_info.last_image_modifier); end; end; else if ((io_call_info.order_name = "seek_head") | (io_call_info.order_name = "sh")) & ^is_af then if io_call_info.nargs < 1 /* one or two are required */ then code = error_table_$noarg; else if io_call_info.nargs > 3 then code = error_table_$too_many_args; else do; /* set up info structure */ i = 0; if (io_call_info.args (1) = "-brief") | (io_call_info.args (1) = "-bf") then do; i = 1; brief_sw = "1"b; end; if io_call_info.nargs = 1 + i /* use default rel_type=0 */ then sh_info.rel_type = 0; else sh_info.rel_type = fixed (io_call_info.args (1 + i), 17, 0); /* 0,1, or 2 to indicate =,>=, or > */ if (io_call_info.nargs = 3) & ^brief_sw then code = error_table_$bad_arg; else do; sh_info.key_len = length (io_call_info.args (io_call_info.nargs)); /* length of search key */ sh_info.key = io_call_info.args (io_call_info.nargs); /* for comparison with key heads */ call control ("seek_head"); end; if brief_sw then go to brief_ret; return; end; else if ((io_call_info.order_name = "add_key") | (io_call_info.order_name = "ak")) & ^is_af then if io_call_info.nargs < 1 /* one arg required */ then code = error_table_$noarg; else do; call get_ak_args; call control ("add_key"); end; else if ((io_call_info.order_name = "delete_key") | (io_call_info.order_name = "dk")) & ^is_af then if io_call_info.nargs >= 1 /* args are optional */ then do; call get_ak_args; call control ("delete_key"); end; else call iox_$control (iocb_ptr, "delete_key", (null), code); else if ((io_call_info.order_name = "reassign_key") | (io_call_info.order_name = "rk")) & ^is_af then if io_call_info.nargs < 2 /* two args required */ then code = error_table_$noarg; else do; call get_rk_args; call control ("reassign_key"); /* make given key point to current rec */ end; else if (io_call_info.order_name = "select") | (io_call_info.order_name = "sl") then do; unspec (common_sl_info.flags) = "0"b; common_sl_info.version = sl_info_version_0; common_sl_info.desc_arrayp = null; if nargs = 0 /* just return status of current subset */ then do; common_sl_info.array_limit = 0; /* without tail structure */ common_sl_info.status_only = "1"b; end; else do; call process_select_args; if code ^= 0 then go to exit; call build_select_info; end; call control ("select"); if is_af then do; /* handle active function reference */ if (code ^= 0) & (code = error_table_$no_record) /* seletion of null set */ then io_call_af_ret = "-0"; /* special notation for the null set */ else io_call_af_ret = char (common_sl_info.subset_no); /* return the subset number */ if brief_sw then go to brief_ret; /* see if code should be cleared */ return; /* finished with active function evaluation */ end; if (code = 0) & ^brief_sw then call report_subset_status; if common_sl_info.output_descriptors & (code = 0) then call list_descriptors; /* frees temporary descriptor array */ if brief_sw then go to brief_ret; end; else if (io_call_info.order_name = "exclude") | (io_call_info.order_name = "ex") then if io_call_info.nargs < 1 /* arg required */ then code = error_table_$noarg; else do; unspec (common_sl_info.flags) = "0"b; common_sl_info.version = sl_info_version_0; common_sl_info.desc_arrayp = null; call process_select_args; if code ^= 0 then go to exit; call build_select_info; call control ("exclude"); if is_af then do; if (code ^= 0) & (code = error_table_$no_record) /* seletion of null set */ then io_call_af_ret = "-0"; /* special notation for the null set */ else io_call_af_ret = char (common_sl_info.subset_no); /* return the subset number */ if brief_sw then go to brief_ret; return; end; if (code = 0) & ^brief_sw then call report_subset_status; if common_sl_info.output_descriptors & (code = 0) then call list_descriptors; if brief_sw then go to brief_ret; end; else if is_af /* called as an active function */ then do; /* error -- not permitted for any of the following orders */ code = error_table_$no_operation; return; end; else if (io_call_info.order_name = "tr") /* no info struc required */ | (io_call_info.order_name = "tc") then call control ("truncate"); else if (io_call_info.order_name = "max_rec_len") | (io_call_info.order_name = "mx") then do; /* takes one optional arg */ if io_call_info.nargs >= 1 /* arg present */ then mx_info.new_max_recl = fixed (io_call_info.args (1), 21, 0); else mx_info.new_max_recl = 0; /* indicates no chanfge */ call control ("max_rec_len"); if code = 0 then call io_call_info.report ("old max recl: ^d", mx_info.old_max_recl); end; else if (io_call_info.order_name = "error_status") | (io_call_info.order_name = "er") then do; /* no inputs--print results */ er_info.version = 1; /* only version supported */ call control ("error_status"); if code = 0 then if er_info.error_type = 0 then call io_call_info.error (0, io_call_info.caller_name, "no errors"); else call io_call_info.report ("requested: ^d received: ^d", er_info.requested, er_info.received); end; else if (io_call_info.order_name = "min_block_size") | (io_call_info.order_name = "mb") then do; if io_call_info.nargs < 1 then do; mb_info.min_cap = 0; mb_info.min_res = 0; end; else mb_info.min_res = fixed (io_call_info.args (1), 17, 0); if io_call_info.nargs < 2 then mb_info.min_cap = 0; else mb_info.min_cap = fixed (io_call_info.args (2), 21, 0); call control ("min_block_size"); end; else if (io_call_info.order_name = "set_wait_time") | (io_call_info.order_name = "sw") then if io_call_info.nargs < 1 then code = error_table_$noarg; else do; if io_call_info.nargs = 1 then new_wait_time = float (io_call_info.args (1)); else if (io_call_info.args (1) = "-cdtm") | (io_call_info.args (1) = "-collection_delay_time") then do; wt_info.version = -2; wt_info.collection_delay_time = float (io_call_info.args (2)); end; else do; code = error_table_$too_many_args; return; end; call control ("set_wait_time"); end; else if (io_call_info.order_name = "set_file_lock") | (io_call_info.order_name = "sf") then if io_call_info.nargs < 1 then code = error_table_$noarg; else do; set_lock_flag = bit (io_call_info.args (1), 2); call control ("set_file_lock"); end; else if (io_call_info.order_name = "file_status") | (io_call_info.order_name = "fs") then call vfile_status$print_ (iocb_ptr, file_base_ptr, io_call_info.report, code); else call control ((io_call_info.order_name)); /* no info struc */ return; /* end of vfile_io_control main routine */ af: entry (iocb_ptr, file_base_ptr, io_call_infop, code); is_af = "1"b; go to mainline; /* let each order do it's thing */ control: proc (order_arg); /* passes order call through iox_ */ call iox_$control (iocb_ptr, (order_arg), addr (info), code); dcl order_arg char (24) var; end control; get_ak_args: proc; /* picks up optional key and descrip */ ak_info_ptr = info_ptr; if nargs = 1 then do; /* use default switch settings--adding key to current */ string (ak_info.flags) = "10"b; /* just input key */ ak_info.key_len = length (io_call_info.args (1)); ak_info.key = io_call_info.args (1); return; end; string (ak_info.flags) = bit (io_call_info.args (1)); if ak_info.input_key & ak_info.input_desc & (io_call_info.nargs < 3) then do; /* error */ noarg: code = error_table_$noarg; go to exit; end; if ak_info.input_key then do; /* pick up key arg */ ak_info.key_len = length (io_call_info.args (2)); ak_info.key = io_call_info.args (2); if ak_info.input_desc /* descrip also given */ then ak_info.descrip = cv_oct_ ((io_call_info.args (3))); end; else ak_info.descrip = cv_oct_ ((io_call_info.args (2))); return; /* end of get_ak_args routine */ get_rk_args: entry; /* picks up optional args for "reassign_key" order */ rk_info_ptr = info_ptr; string (rk_info.flags) = bit (io_call_info.args (1)); if rk_info.input_key then do; /* pick up key arg */ rk_info.key_len = length (io_call_info.args (2)); rk_info.key = io_call_info.args (2); if io_call_info.nargs < 3 /* at least one more arg required */ then go to noarg; /* error */ if rk_info.input_old_desc then do; /* may be two more args */ rk_info.old_descrip = cv_oct_ ((io_call_info.args (3))); if rk_info.input_new_desc /* yes--there is another arg */ then if io_call_info.nargs < 4 then go to noarg; else rk_info.new_descrip = cv_oct_ ((io_call_info.args (4))); end; else rk_info.new_descrip = cv_oct_ ((io_call_info.args (3))); end; else if rk_info.input_old_desc then do; rk_info.old_descrip = cv_oct_ ((io_call_info.args (2))); if rk_info.input_new_desc then if io_call_info.nargs < 3 then go to noarg; else rk_info.new_descrip = cv_oct_ ((io_call_info.args (3))); end; else rk_info.new_descrip = cv_oct_ ((io_call_info.args (2))); return; /* end of get_rk_args routine */ end get_ak_args; process_select_args: proc; /* builds info structure elements for "select" order */ sl_array_limit = 0; i = 1; if is_bf_or_ls_opt () then do; i = 2; if io_call_info.nargs = 1 then do; common_sl_info.status_only = "1"b; return; end; end; common_sl_info.status_only = "0"b; if (io_call_info.args (i) = "-reset") | (io_call_info.args (i) = "-rs") then do; common_sl_info.list_type = 0; /* indicates re-selection */ if nargs > i then common_sl_info.subset_no = fixed (io_call_info.args (i + 1)); else common_sl_info.subset_no = 0; /* default is identity subset */ common_sl_info.array_limit = 0; /* smallest info structure supported */ return; /* done processing args */ end; common_sl_info.list_type = 1; if io_call_info.args (io_call_info.nargs) = "-delete_old_subsets" | io_call_info.args (io_call_info.nargs) = "-dos" then common_sl_info.delete_old_subsets = "1"b; if (io_call_info.args (i) = "-or") | /* wants default delimiter */ (io_call_info.args (i) = "-or_key") | (io_call_info.args (i) = "-ork") then do; default_delim = io_call_info.args (i); if default_delim = "-or_key" then default_delim = "-ork"; i = i + 1; if i > nargs then go to no_arg; end; else default_delim = ""; if (default_delim = "") & ((io_call_info.args (i) = "-desc") | (io_call_info.args (i) = "-ds")) then do; call build_array; return; end; if (default_delim = "") | (default_delim = "-or") then if io_call_info.args (i) = "-head" then do; i = i + 1; /* advance to next arg */ head = "1"b; /* list of intervals representation */ end; else if io_call_info.args (i) = "-key" then do; i = i + 1; head = "0"b; /* first interval must match key exactly */ end; else head = "1"b; else head = "0"b; do int = 1 to max_int; /* for each index interval specified */ len = length (io_call_info.args (i)); f_head.length (int) = len; f_head.kptr (int) = addrel (addr (io_call_info.args (i)), 1); i = i + 1; if i > nargs - bin (common_sl_info.delete_old_subsets) then do; if head then l_head.length (int) = len; else l_head.length (int) = -1; /* by convention, indicates exact key match */ l_head.kptr (int) = f_head.kptr (int); return; end; if (default_delim = "") & ((io_call_info.args (i) = "-or") | (io_call_info.args (i) = "-ork") | (io_call_info.args (i) = "-or_key")) then do; i = i + 1; new_int: if head then l_head.length (int) = len; else l_head.length (int) = -1; l_head.kptr (int) = f_head.kptr (int); if (default_delim = "-or") | ((default_delim ^= "-ork") & (io_call_info.args (i - 1) = "-or")) then head = "1"b; else head = "0"b; if i > nargs then do; no_arg: code = error_table_$noarg; return; end; end; else if (default_delim ^= "-ork") & ((io_call_info.args (i) = "-thru") | (io_call_info.args (i) = "-to")) then if ^head then do; /* error-- "-thru" not allowed with key match spec */ bad_arg: code = error_table_$bad_arg; return; /* abort */ end; else do; i = i + 1; if i > nargs then go to no_arg; len = length (io_call_info.args (i)); if io_call_info.args (i - 1) = "-to" /* open ended interval */ then l_head.length (int) = -len; /* convention for indicating open interval */ else l_head.length (int) = len; /* inclusive interval */ l_head.kptr (int) = addrel (addr (io_call_info.args (i)), 1); i = i + 1; if i > nargs then return; if (default_delim = "") & ((io_call_info.args (i) ^= "-or") & (io_call_info.args (i) ^= "-ork") & (io_call_info.args (i) ^= "-or_key")) then go to bad_arg; if default_delim = "" then i = i + 1; if i > nargs then go to no_arg; end; else if default_delim = "" then go to bad_arg; else go to new_int; end; /* end of arg pick-up loop */ code = error_table_$too_many_args; end process_select_args; report_subset_status: proc; call io_call_info.report ("subset: ^d ,records: ^d", common_sl_info.subset_no, common_sl_info.count); end report_subset_status; list_descriptors: proc; /* prints list of octal descriptors and frees list allocation */ do i = 1 to common_sl_info.count; /* loop through array elements */ call io_call_info.report ("^o", common_sl_info.desc_arrayp -> desc_array (i)); end; free common_sl_info.desc_arrayp -> desc_array; end list_descriptors; is_bf_or_ls_opt: proc returns (bit (1) aligned); if (io_call_info.args (i) = "-brief") | (io_call_info.args (i) = "-bf") then do; brief_sw = "1"b; return ("1"b); end; if (io_call_info.args (i) = "-list") | (io_call_info.args (i) = "-ls") then do; common_sl_info.output_descriptors = "1"b; return ("1"b); end; return ("0"b); end is_bf_or_ls_opt; build_select_info: proc; /* prepares info structure for select or exclude */ if common_sl_info.list_type ^= 1 then return; /* no tail structure required */ common_sl_info.array_limit = int; if size (hi_sl_info) > max_info_size then do; /* implementation limit */ code = error_table_$too_many_args; go to exit; end; do i = 1 to int; hi_sl_info.interval (i) = temp_int (i); end; dcl i fixed; end build_select_info; build_array: proc; /* prepares info structure for descriptor list */ common_sl_info.list_type = 2; /* code for descriptor array specification */ common_sl_info.array_limit = nargs - i; /* prev arg was -ds or -desc */ if size (da_sl_info) > max_info_size /* implementation limit--should do allocation if necessary */ then do; /* cop out solution--eventually do this better */ code = error_table_$too_many_args; go to exit; /* abort */ end; do n = i + 1 to nargs; /* pick up descriptor args */ da_sl_info.desc_array (n - i) = cv_oct_ ((io_call_info.args (n))); end; dcl n fixed; end build_array; exit: return; /* external exit */ dcl iocb_ptr ptr; dcl is_af bit (1) aligned; dcl brief_sw bit (1) aligned; dcl (i, len) fixed; dcl info_ptr ptr; dcl vfile_status$print_ entry (ptr, ptr, entry options (variable), fixed (35)); dcl date_time_ entry (fixed (71), char (*)); dcl date_time char (24); dcl file_base_ptr ptr; %include rs_info; %include io_call_info; dcl code fixed (35); dcl (char, fixed, unspec, string, length, addr, null, size) builtin; %include vfile_error_codes; dcl iox_$control entry (ptr, char (*), ptr, fixed (35)); dcl max_info_size static fixed internal options (constant) init (200); dcl 1 wt_info based (addr (info)), 2 version float, 2 collection_delay_time float; dcl 1 info, /* large enough for any vfile_ supported info struc */ 2 words (max_info_size) fixed; /* largest info structure */ dcl 1 sh_info based (addr (info)), /* for "seek_head" */ 2 rel_type fixed, /* 0,1, or 2 for =,>=, or > */ 2 key_len fixed, /* length of search key below */ 2 key char (256); /* compared with key heads in file */ dcl 1 rp_info based (addr (info)), /* for "read_position" */ 2 next_pos fixed (34), /* abs position of next byte or record */ 2 end_pos fixed (34); /* total count of bytes or records in file */ dcl 1 mx_info based (addr (info)), /* for "max_rec_len" */ 2 old_max_recl fixed (21), /* output */ 2 new_max_recl fixed (21); /* input--zero indicates no change */ dcl 1 er_info based (addr (info)), /* for "error_status" */ 2 version fixed, /* (Input) must=1 */ 2 error_type fixed, /* only one currently supported */ 2 requested fixed (34), /* position skip arg issued on call */ 2 received fixed (34); /* successful skips actually made */ dcl 1 mb_info based (addr (info)), /* for "min_block_size" */ 2 min_res fixed (21), 2 min_cap fixed (21); /* minimum allocation for record block */ dcl new_wait_time float based (addr (info)); dcl set_lock_flag bit (2) aligned based (addr (info)); dcl cv_oct_ entry (char (*)) returns (fixed (35)); %include ak_info; %include select_info; dcl int fixed; dcl 1 temp_int (1:max_int), 2 f_head, 3 length fixed, 3 kptr ptr, 2 l_head, 3 length fixed, 3 kptr ptr; dcl max_int static fixed options (constant) init (50); dcl head bit (1) aligned; dcl default_delim char (8) aligned; dcl comma_off fixed; dcl substr_off fixed; dcl substr_len fixed; dcl substr_sw bit (1) aligned; end vfile_io_control;  vfile_status.pl1 11/04/82 1940.0rew 11/04/82 1621.3 99162 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* This routine prints information about storage system files given a pathname (star convention permitted). Info provided includes the file's apparent type and various statistics */ vfs: vfile_status: proc (pathname_arg); command_entry = "1"b; report = ioa_; /* differs for subroutine entry */ e_ptr = null; /* won't free unless non-null */ call cu_$arg_count (n_args); /* args with which command was invoked */ if n_args <= 0 then code = error_table_$noarg; else if n_args > 1 then code = error_table_$too_many_args; else code = 0; call check_code; /* aborts on error */ call get_star_names; /* interprets pathname_arg */ status_loop: info.info_version = vfs_version_1; do i = 1 to e_count; /* check each entry matching star_name */ if is_real_file () /* don't consider directories */ then if info.type = 1 /* unstructured */ then call proc_uns_file; else if info.type = 2 /* sequential */ then call proc_seq_file; else if info.type = 3 /* blocked */ then call proc_blk_file; else if info.type = 4 /* indexed */ then call proc_indx_file; /* must be indexed */ end; if command_entry & ^file_found /* only directories or empty files found */ then call com_err_ (0, "vfile_status", "No file found for given pathname."); else do; cleanup: if ^command_entry /* set return code */ then code_arg = code; end; if e_ptr ^= null then free entries, names in (a); return; /* end of main file status routine */ print_: entry (iocb_ptr, file_base_ptr, report_arg, code_arg); report = report_arg; /* set by io_call */ command_entry = "0"b; e_count = 1; /* one file only */ is_star_name = "0"b; e_ptr = null; /* prevents attempt to cleanup */ go to status_loop; /* print status of file */ get_star_names: proc; /* expands argument in star convention */ file_found = "0"b; /* will be set if non-null, non-dir seg is found */ call expand_path_ (addr (pathname_arg), length (pathname_arg), addr (d_name), addr (e_name), code); /* gets full path and ent names */ call check_code; /* aborts on non-zero error code */ if index (e_name, "*") = 0 /* not a star name */ then do; e_count = 1; /* only one entry to consider */ is_star_name = "0"b; /* suppresses printout of pathname */ return; end; else is_star_name = "1"b; area_ptr = get_system_free_area_ (); /* temp space for star_name info */ call hcs_$star_ (d_name, e_name, 3 /* all types of entries */, area_ptr, e_count, e_ptr, n_ptr, code); /* finds matching entries */ call check_code; d_len = length (d_name) + 1 - verify (reverse (d_name), " "); /* directory pathname length */ tot_names = 0; /* will be set in following loop */ do i = 1 to e_count; /* get total extent of names structure allocated */ tot_names = tot_names + fixed (n_names (i)); end; end get_star_names; check_code: proc; /* aborts if nonzero error code detected */ if code = 0 then return; if command_entry /* first print message */ then call com_err_ (code, "vfile_status"); /* prints error info */ go to cleanup; /* frees allocated system storage and closes msf */ end check_code; is_real_file: proc returns (bit (1) aligned); /* non-dir seg */ if is_star_name /* get an entry name */ then e_name = n_ptr -> names (fixed (e_ptr -> entries.n_index (i))); /* the i'th entry name */ if command_entry then call vfile_status_ (d_name, e_name, addr (info), code); /* gets file info */ else call vfile_status_$seg (iocb_ptr, file_base_ptr, addr (info), code); if (code = error_table_$dirseg) | (code = error_table_$noentry) then if command_entry then return ("0"b); /* ignore directories and non-existing entries */ call check_code; if is_star_name /* print pathname */ then call report ("^a", substr (d_name, 1, d_len) || ">" || e_name); file_found = "1"b; return ("1"b); /* indicates real data file found for i'th entry */ end is_real_file; proc_uns_file: proc; /* prints info about unstructured files */ call report ("type: unstructured bytes: ^d", uns_info.end_pos); if uns_info.header_present /* header is optional */ then call report ("header: ^d", uns_info.header_id); end proc_uns_file; proc_seq_file: proc; /* prints info about sequential files */ call report ("type: sequential"); call print_common_info; if seq_info.version < 12 then call report ("version: old (no record count)"); else if seq_info.version < current_seq_version then call report ("version: old (pre-MR6.0)"); call report_action (seq_info.action); end proc_seq_file; proc_blk_file: proc; /* prints info about blocked files */ call report ("type: blocked"); call print_common_info; if blk_info.version < current_blk_version then call report ("version: old (pre-MR6.0)"); else do; /* version supports time_stamp */ call date_time_ (blk_info.time_last_modified, date_time); call report ("last changed: ^a", date_time); end; call report_action (blk_info.action); call report ("max recl: ^d bytes", blk_info.max_rec_len); end proc_blk_file; report_action: proc (action_code); /* routine deciphers action codes for updates in progress */ if (action_code < -14) | (action_code > 3) /* unknown code */ then call report ("action: unknown operation in progress"); else if action_code ^= 0 /* operation in progress */ then call report ("action: ^a in progress", operation (-1 * (action_code))); dcl operation (-3:14) char (24) var static options (constant) init ("checkpoint", "non-checkpoint opening", "truncate", "", "write_record", "rewrite_record", "delete_record", "add_key", "delete_key", "record_status(create)", "exclusive opening", "reassign_key", "write_record (truncate)", "delete_record (non-eof)", "unshared opening", "adjust_record", "adjust_record (rollback)", "recovery"); dcl action_code fixed; end report_action; print_common_info: proc; /* if file is locked, info is printed out; also record count */ if ^((info.type = 2 /* sequential */) & (seq_info.version < 12)) then call report ("records: ^d", info.records); /* end pos in same loc for all struc files */ if info.lock_status ^= "00"b /* file is locked */ then if info.lock_status = "01"b /* busy in another process */ then call report ("state: locked by another process"); else if info.lock_status = "10"b then call report ("state: locked by this process"); else call report ("state: locked by dead process"); end print_common_info; proc_indx_file: proc; /* prints info about indexed files */ call report ("type: indexed"); call print_common_info; /* record count and lock status */ if (indx_info.program_version < 33) then if ((indx_info.program_version = 21) | ((indx_info.program_version < 21) & (indx_info.file_version = 20))) then call report ( "version: Warning--total record length statistic is bad because of vfile_ bug. Use the vfile_adjust command to correct the problem." ); /* opening the file for modification also will automatically adjust the bad statistic */ else call report ("version: old version--does not support even-word aligned records."); call report_action (indx_info.action); /* prints if file inconsistent */ if (indx_info.non_null_recs ^= indx_info.records) & ((indx_info.program_version >= 23) | (indx_info.file_version = 10)) then call report ("alloc recs: ^d", indx_info.non_null_recs); if (indx_info.records ^= 0) | (indx_info.record_bytes ^= 0) then call report ("record bytes: ^d", indx_info.record_bytes); if (indx_info.records ^= 0) | (indx_info.free_blocks ^= 0) then call report ("free blocks: ^d", indx_info.free_blocks); if (indx_info.num_keys ^= 0) | (indx_info.nodes ^= 0) | (indx_info.index_height ^= 0) | (indx_info.key_bytes ^= 0) then call report ("index height: ^d nodes: ^d key bytes: ^d", indx_info.index_height, indx_info.nodes, indx_info.key_bytes); if indx_info.num_keys ^= indx_info.records then call report ("keys: ^d", indx_info.num_keys); if indx_info.dup_keys ^= 0 then call report ("dup keys: ^d dup key bytes: ^d", indx_info.dup_keys, indx_info.dup_key_bytes); end proc_indx_file; /* declarations for entire program */ dcl code_arg fixed (35); dcl is_star_name bit (1) aligned; dcl command_entry bit (1) aligned; dcl file_base_ptr ptr; dcl iocb_ptr ptr; dcl vfile_status_ entry (char (*) aligned, char (*) aligned, ptr, fixed (35)); dcl vfile_status_$seg entry (ptr, ptr, ptr, fixed (35)); dcl a area based (area_ptr); dcl cu_$arg_count entry (fixed); dcl n_args fixed; dcl (error_table_$noarg, error_table_$noentry, error_table_$too_many_args) external fixed (35); dcl pathname_arg char (*); dcl (i, e_count) fixed; dcl report entry variable options (variable); dcl (ioa_, report_arg) entry options (variable); dcl code fixed (35); dcl (null, index, fixed) builtin; dcl file_found bit (1) aligned; dcl (e_ptr, n_ptr) ptr; dcl expand_path_ entry (ptr, fixed, ptr, ptr, fixed (35)); dcl (addr, length) builtin; dcl d_name char (168) aligned; dcl e_name char (32) aligned; dcl area_ptr ptr; dcl get_system_free_area_ entry returns (ptr); dcl hcs_$star_ entry (char (*) aligned, char (*) aligned, fixed (2), ptr, fixed, ptr, ptr, fixed (35)); dcl d_len fixed; dcl (verify, reverse) builtin; dcl com_err_ entry options (variable); dcl names (tot_names) char (32) aligned based (n_ptr); dcl tot_names fixed; dcl 1 entries (e_count) aligned based (e_ptr), ( 2 type bit (2), 2 n_names bit (16), 2 n_index bit (18) ) unal; dcl error_table_$dirseg external fixed (35); dcl substr builtin; dcl current_indx_version static options (constant) internal fixed init (40); dcl current_blk_version static options (constant) internal fixed init (1); dcl current_seq_version static options (constant) internal fixed init (13); dcl abs builtin; dcl truncating fixed static options (constant) internal init (1); dcl 1 info like indx_info; dcl date_time_ entry (fixed (71), char (*)); dcl date_time char (24); %include vfs_info; end vfile_status;  vfile_status_.pl1 09/26/83 1121.8re 09/26/83 1117.4 195408 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* DESCRIPTION: This routine supplies information about a storage system file given its pathname. Information includes the file's type and various appropriate statistics. */ /* HISTORY: Written by Mike Asherman. Modified: 05/16/83 by Lindsey Spratt: Fixed to destroy the temporary iocb. */ /* format: style2 */ vfile_status_: proc (d_name_arg, e_name_arg, info_ptr, code); seg_ptr_entry = "0"b; /* this is the pathname entry */ d_name = d_name_arg; e_name = e_name_arg; iocb_ptr = null; /* indicates no I/O switch */ call get_file_base; /* finds first seg and gets pointer */ call check_access; /* verifies that user has read access */ get_status: if info_ptr -> info.version ^= vfs_version_1 then do; code = error_table_$bad_arg; return; end; if seg_ptr -> common_header.file_code = seq_code /* file is sequential */ then call proc_seq_file; else if seg_ptr -> common_header.file_code = blk_code /* file is blocked */ then call proc_blk_file; else if seg_ptr -> common_header.file_code = indx_code /* indexed file */ then call proc_indx_file; else call proc_uns_file; /* must be unstructured */ cleanup: if seg_ptr_entry & ^not_open /* no cleanup necessary */ then return; if fcb_ptr ^= null then call msf_manager_$close (fcb_ptr); /* frees the control block */ else if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, foo); if iocb_ptr ^= null /* I/O switch may be attached and open */ then do; /* close and detach */ call iox_$close (iocb_ptr, foo); if ^seg_ptr_entry then do; call iox_$detach_iocb (iocb_ptr, foo); call iox_$destroy_iocb (iocb_ptr, foo); end; end; return; /* end of main vfile_status_ routine */ seg: entry (iocb_ptr_arg, seg_ptr_arg, info_ptr, code); seg_ptr_entry = "1"b; iocb_ptr = iocb_ptr_arg; not_open = (iocb_ptr -> iocb.open_descrip_ptr = null); if not_open /* seg pointer not yet obtained */ then do; d_name = substr (atb.attach_descrip_string, 8, atb.dname_len); e_name = substr (atb.attach_descrip_string, 9 + dname_len, ename_len); call get_file_base; call check_access; go to get_status; end; seg_ptr = seg_ptr_arg; code = 0; go to get_status; check_code: proc; /* aborts if non-zero error code */ if code ^= 0 then go to cleanup; /* don't leave a mess */ end check_code; get_file_base: proc; /* finds first file component and sets seg_ptr */ seg_ptr = null; /* segment not initiated */ fcb_ptr = null; /* will be non-null if msf opened */ call hcs_$status_long (d_name, e_name, 1, addr (branch_info), null, code); if code ^= 0 then if code = error_table_$no_s_permission then code = 0; /* not really an error */ else go to cleanup; /* error--abort */ if branch_info.type = "10"b /* directory or msf */ then if branch_info.bit_count = "0"b /* directory */ then code = error_table_$dirseg; else do; /* get ptr to base of msf */ call msf_manager_$open ((d_name), (e_name), fcb_ptr, code); /* creates control block */ call check_code; /* abort on error */ call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, seg_ptr, bc, code); /* pointer to base of file */ if seg_ptr ^= null then code = 0; /* reset spurious code */ end; else do; /* get ptr to base of segment */ call hcs_$initiate (d_name, e_name, "", 0, 1, seg_ptr, code); if seg_ptr ^= null then code = 0; /* no error if pointer returned */ end; call check_code; end get_file_base; check_access: proc; /* checks for read access to segment */ mode = 0; /* read bit will be set if access OK */ call hcs_$fs_get_mode (seg_ptr, mode, code); /* gets access mode */ if ^substr (bit (mode), 2, 1) /* read bit not set */ then code = error_table_$moderr; call check_code; end check_access; get_lock_status: proc; /* finds state of file lock */ lock_word = seg_ptr -> common_header.file_lock; /* copy the file's lock */ call set_lock_$lock (lock_word, 0, foo); /* returned code (foo) reveals status */ if foo = 0 /* not locked */ then info_ptr -> seq_info.lock_status = "00"b; /* all structured files have this in the same place */ else if foo = error_table_$lock_wait_time_exceeded then info_ptr -> seq_info.lock_status = "01"b; /* locked by another process */ else if foo = error_table_$locked_by_this_process then info_ptr -> seq_info.lock_status = "10"b; /* busy in caller's process */ else info_ptr -> seq_info.lock_status = "11"b; /* locked by defunct process */ end get_lock_status; proc_uns_file: proc; /* gets info for unstructured files */ info_ptr -> uns_info.type = 1; /* identifies file as unstructured */ info_ptr -> uns_info.header_present = (seg_ptr -> common_header.file_code = uns_code); /* no header unless code */ if info_ptr -> uns_info.header_present /* pick up identifier from header */ then info_ptr -> uns_info.header_id = seg_ptr -> uns_header.identifier; if ^seg_ptr_entry /* don't already have an I/O switch */ then do; d_len = length (d_name) + 1 - verify (reverse (d_name), " "); /* don't count trailing blanks */ atd = "vfile_ " || substr (d_name, 1, d_len) || ">" || e_name; if info_ptr -> uns_info.header_present then atd = atd || " -header"; call iox_$attach_ioname (unique_chars_ ("0"b), iocb_ptr, atd, code); /* attach uniquely named switch */ call check_code; open_it: call iox_$open (iocb_ptr, 1 /* stream_input */, "0"b, code); /* open file for input */ call check_code; end; else if not_open /* switch already attached */ then go to open_it; call iox_$control (iocb_ptr, "read_position", addr (rp_info), code); /* gets byte count of file */ call check_code; info_ptr -> uns_info.end_pos = rp_info.end_pos; dcl d_len fixed; end proc_uns_file; proc_seq_file: proc; /* sets info for unstructured files */ info_ptr -> seq_info.type = 2; /* identifies file type */ call get_lock_status; /* looks at file lock */ info_ptr -> seq_info.version = seg_ptr -> seq_header.version; /* file version */ info_ptr -> seq_info.action = seg_ptr -> seq_header.file_state; if seg_ptr_entry & ^not_open then if ^iocb_ptr -> iocb.open_data_ptr -> seq_cb.input_only /* modify opening */ then do; /* use open data stats */ info_ptr -> seq_info.end_pos = iocb_ptr -> iocb.open_data_ptr -> seq_cb.end_pos; /* latest end pos */ return; end; info_ptr -> seq_info.end_pos = seg_ptr -> seq_header.end_pos; /* record count--only valid if version is current */ end proc_seq_file; proc_blk_file: proc; /* gets info for blocked files */ info_ptr -> blk_info.type = 3; /* identifies blocked file info struc */ call get_lock_status; info_ptr -> blk_info.version = seg_ptr -> blk_header.version; info_ptr -> blk_info.action = seg_ptr -> blk_header.action; /* non-zero if update is in progress */ info_ptr -> blk_info.max_rec_len = seg_ptr -> blk_header.max_rec_len; /* maximum record length associated with file (bytes) */ if seg_ptr_entry & ^not_open /* we have an iocb */ then if (iocb_ptr -> iocb.open_data_ptr -> blk_cb.mode > 4 /* modify opening */) & ^iocb_ptr -> iocb.open_data_ptr -> blk_cb.shared then do; info_ptr -> blk_info.end_pos = iocb_ptr -> iocb.open_data_ptr -> blk_cb.end_pos; /* latest end pos */ go to get_time_stamp; end; info_ptr -> blk_info.end_pos = seg_ptr -> blk_header.end_pos; /* record count */ get_time_stamp: info_ptr -> blk_info.time_last_modified = seg_ptr -> common_header.time_last_modified; end proc_blk_file; proc_indx_file: proc; /* gets info for indexed files */ info_ptr -> indx_info.type = 4; /* identifies indexed file info struc */ call get_lock_status; info_ptr -> indx_info.file_version = seg_ptr -> indx_header.file_version; info_ptr -> indx_info.program_version = seg_ptr -> indx_header.program_version; /* if old this may indicate file has bugs */ state = seg_ptr -> indx_header.file_state; /* selects valid block of stats */ if (info_ptr -> indx_info.file_version = 30 /* file is latest version */) | (info_ptr -> indx_info.file_version = 40) then call get_latest_indx_stats; else if info_ptr -> indx_info.file_version = 20 then call get_new_stats; else if info_ptr -> indx_info.file_version = 10 then call get_old_stats; /* old version header is differently organized */ else code = error_table_$bad_file; return; /* end of routine for handling indexed files */ get_latest_indx_stats: proc; /* routine gets statistics for version 4.0 files */ call get_common_indx_stats; /* change count and index state */ f_s_ptr = addr (seg_ptr -> new_indx_header.file_state_blocks (state)); info_ptr -> indx_info.action = f_s_ptr -> new_fs_block.file_action; /* ^=0 if operation in progress */ info_ptr -> indx_info.records = f_s_ptr -> new_fs_block.number_of_records; info_ptr -> indx_info.record_bytes = f_s_ptr -> new_fs_block.total_record_length; info_ptr -> indx_info.non_null_recs = f_s_ptr -> new_fs_block.number_of_allocated_records; info_ptr -> indx_info.free_blocks = f_s_ptr -> new_fs_block.number_of_free_blocks; info_ptr -> indx_info.num_keys = f_s_ptr -> new_fs_block.number_of_keys; info_ptr -> indx_info.key_bytes = f_s_ptr -> new_fs_block.total_key_length; info_ptr -> indx_info.dup_keys = f_s_ptr -> new_fs_block.duplicate_keys; info_ptr -> indx_info.dup_key_bytes = f_s_ptr -> new_fs_block.dup_key_bytes; end get_latest_indx_stats; get_common_indx_stats: proc; /* routine used with latest two file versions */ info_ptr -> indx_info.change_count = seg_ptr -> indx_header.change_count; i_state = seg_ptr -> indx_header.index_state; /* locates proper index state block */ i_s_ptr = addr (seg_ptr -> indx_header.index_state_blocks (i_state)); /* pointer to index state block */ info_ptr -> indx_info.index_height = i_s_ptr -> index_state_block.index_height; info_ptr -> indx_info.nodes = i_s_ptr -> index_state_block.number_of_nodes; end get_common_indx_stats; set_default_stats: proc; /* used with old version indexed files */ info_ptr -> indx_info.num_keys = info_ptr -> indx_info.records; info_ptr -> indx_info.dup_keys = 0; info_ptr -> indx_info.dup_key_bytes = 0; end set_default_stats; get_new_stats: proc; /* gets file statistics for MR3.0 version indexed files */ call get_common_indx_stats; f_s_ptr = addr (seg_ptr -> indx_header.file_state_blocks (state)); /* pointer to file state block */ info_ptr -> indx_info.action = f_s_ptr -> file_state_block.file_action; /* ^=0 if operation in progress */ info_ptr -> indx_info.records = f_s_ptr -> file_state_block.number_of_records; info_ptr -> indx_info.record_bytes = f_s_ptr -> file_state_block.total_record_length; info_ptr -> indx_info.non_null_recs = f_s_ptr -> file_state_block.number_of_allocated_records; info_ptr -> indx_info.free_blocks = f_s_ptr -> file_state_block.number_of_free_blocks; info_ptr -> indx_info.key_bytes = f_s_ptr -> file_state_block.total_key_length; call set_default_stats; end get_new_stats; get_old_stats: proc; /* gets statistics for old version indexed files */ info_ptr -> indx_info.change_count = 0; /* not supported */ old_f_s_ptr = addr (seg_ptr -> old_indx_header.old_file_state_blocks (state)); /* pointer to old version file state block */ info_ptr -> indx_info.action = old_f_s_ptr -> old_f_s_block.file_action; /* if ^=0 file cannot be restored */ info_ptr -> indx_info.records = old_f_s_ptr -> old_f_s_block.number_of_records; info_ptr -> indx_info.record_bytes = old_f_s_ptr -> old_f_s_block.total_record_length; info_ptr -> indx_info.key_bytes = old_f_s_ptr -> old_f_s_block.total_key_length; r_state = seg_ptr -> old_indx_header.record_state;/* selects a record_state_block */ r_s_ptr = addr (seg_ptr -> old_indx_header.record_state_blocks (r_state)); /* points to record state block--part of file state block in new version files */ info_ptr -> indx_info.non_null_recs = r_s_ptr -> r_s_block.number_of_allocated_records; info_ptr -> indx_info.free_blocks = r_s_ptr -> r_s_block.number_of_free_blocks; info_ptr -> indx_info.index_height = seg_ptr -> old_indx_header.old_version_index_height; info_ptr -> indx_info.nodes = seg_ptr -> old_indx_header.old_version_number_of_nodes; call set_default_stats; end get_old_stats; end proc_indx_file; /* declarations for entire program */ dcl seg_ptr_entry bit (1) aligned; dcl seg_ptr_arg ptr; dcl iocb_ptr_arg ptr; dcl 1 branch_info aligned, /* info returned by hcs_$status_long */ 2 type bit (2) unal, 2 pad0 bit (34) unal, 2 words1 (6) fixed, /* of no interest */ 2 pad1 bit (12) unal, 2 bit_count bit (24) unal, /* distinguishes msf and dir */ 2 words2 (2); dcl hcs_$status_long entry (char (*), char (*), fixed (1), ptr, ptr, fixed (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35)); dcl hcs_$terminate_noname entry (ptr, fixed (35)); dcl hcs_$fs_get_mode entry (ptr, fixed (5), fixed (35)); dcl mode fixed (5); dcl iocb_ptr ptr; dcl iox_$close entry (ptr, fixed (35)); dcl iox_$detach_iocb entry (ptr, fixed (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed (35)); dcl iox_$open entry (ptr, fixed, bit (1) aligned, fixed (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl iox_$control entry (ptr, char (*), ptr, fixed (35)); dcl state fixed; dcl ( error_table_$lock_wait_time_exceeded, error_table_$no_s_permission, error_table_$bad_file, error_table_$bad_arg, error_table_$moderr, error_table_$dirseg, error_table_$locked_by_this_process ) external fixed (35); dcl set_lock_$lock entry (bit (36) aligned, fixed, fixed (35)); dcl lock_word bit (36) aligned; dcl seg_ptr ptr; dcl 1 rp_info, /* used in "read_position" control order */ 2 next_pos fixed (34), /* of no interest in this routine */ 2 end_pos fixed (34); /* used to get byte count of uns files */ dcl 1 uns_header based (seg_ptr), /* optional header for unstructured files */ 2 common_header_words (4) fixed, 2 identifier fixed (35); /* set and interpreted by user */ dcl 1 seq_header based (seg_ptr), /* standard header for sequential files */ 2 common_header_words (4) fixed, 2 version_word aligned, 3 file_state fixed (17) unal, 3 version fixed (17) unal, 2 words (3) fixed, /* not of interest to this program */ 2 end_pos fixed (34), /* record count */ 2 end_desc fixed (35); dcl 1 common_header based (seg_ptr), /* common header for structured files */ 2 file_code fixed (35), 2 file_lock bit (36) aligned, 2 time_last_modified fixed (71); dcl (code, foo) fixed (35); dcl fcb_ptr ptr; dcl (null, bit, substr, length, verify, reverse, addr, fixed) builtin; dcl msf_manager_$close entry (ptr); dcl (d_name_arg, e_name_arg) char (*); dcl d_name char (168); dcl e_name char (32); dcl atd char (256); dcl not_open bit (1) aligned; dcl msf_manager_$open entry (char (*) aligned, char (*) aligned, ptr, fixed (35)); dcl msf_manager_$get_ptr entry (ptr, fixed, bit (1), ptr, fixed (24), fixed (35)); dcl bc fixed (24); dcl uns_code static internal fixed init (31191); dcl seq_code static internal fixed init (83711); dcl blk_code static internal fixed init (22513); dcl indx_code static internal fixed init (7129); dcl 1 indx_header aligned based (seg_ptr), /* current version */ 2 words1 (4), 2 file_version fixed, 2 program_version fixed, 2 words2 (8), 2 file_state fixed, 2 change_count fixed (35), 2 words3 (46), 2 file_state_blocks (0:1), 3 words (7) fixed, 2 index_state fixed, 2 index_state_blocks (0:1), 3 words (104); dcl 1 new_indx_header aligned based (seg_ptr), /* version 4.0 indexed file header */ 2 words (361) fixed, 2 file_state_blocks (0:1), 3 words (12) fixed; dcl 1 new_fs_block based (f_s_ptr), /* version 4.0 file state block */ 2 file_action fixed, 2 file_substate fixed, 2 number_of_keys fixed (34), 2 duplicate_keys fixed (34), /* 0 if no duplications */ 2 dup_key_bytes fixed (34), 2 total_key_length fixed (34), 2 number_of_records fixed (34), 2 total_record_length fixed (34), 2 number_of_allocated_records fixed (34), 2 number_of_free_blocks fixed (34), 2 words (2) fixed; dcl (f_s_ptr, i_s_ptr, old_f_s_ptr, r_s_ptr) ptr; dcl (i_state, r_state) fixed; dcl 1 file_state_block based (f_s_ptr), 2 file_action fixed, 2 word1, 2 number_of_records fixed, 2 total_key_length fixed (34), 2 total_record_length fixed (34), 2 number_of_allocated_records fixed (34), 2 number_of_free_blocks fixed (34); dcl 1 index_state_block based (i_s_ptr), 2 number_of_nodes fixed (34), 2 words1 (2), 2 index_height fixed; dcl 1 old_indx_header based (seg_ptr), /* old version indexed file header */ 2 words1 (15), 2 old_file_state_blocks (0:1), 3 words (5), 2 words2 (7), 2 record_state fixed, 2 record_state_blocks (0:1), 3 words (4), 2 words3 (14), 2 old_version_index_height fixed, 2 old_version_number_of_nodes fixed (34); dcl 1 old_f_s_block based (old_f_s_ptr), 2 file_action fixed, 2 word, 2 number_of_records fixed (34), 2 total_key_length fixed (34), 2 total_record_length fixed (34); dcl 1 r_s_block based (r_s_ptr), 2 word, 2 number_of_allocated_records fixed (34), 2 number_of_free_blocks fixed (34); dcl 1 blk_header aligned based, /* standard header for blocked files */ 2 words1 (4) fixed, /* of no interest here */ 2 version fixed, 2 words2 (3) fixed, 2 max_rec_len fixed (21), 2 end_pos fixed (34), 2 action fixed; /* non-zero indicates operation in progress */ dcl 1 seq_cb aligned based, /* open data block for sequential files */ 2 seg_ptr ptr, /* ptr to current seg */ 2 fcb_ptr ptr, /* ptr to msf control block */ 2 component fixed bin, /* component number of current seg */ 2 write_limit fixed bin (21), /* set at open to max seg size + 1 */ 2 beyond_limits fixed bin (21), /* set at open to write_limit + 4 */ 2 max_record_size fixed bin (21), /* set at open to 4*max_component_size- header_size-12(i.e. 3 desciptor words */ 2 write_pos fixed bin (21), /* in write state = pos of final descriptor, in read state = beyond limits */ 2 read_pos fixed bin (21), /* in read state = pos of next descriptor, in write state = minus_one_pos */ 2 current_record_ptr ptr, 2 end_pos fixed (34), /* number of records in file */ 2 end_desc fixed (35), 2 next_pos fixed (34), /* next record number */ 2 next_is_current bit (1) aligned, /* "0"b if positions staggerred */ 2 updating bit (1) aligned, /* set if mode=7 (sequential_update) */ 2 append_sw bit (1) aligned, /* set if mode=6 (seq in out) and -append attachment */ 2 input_only bit (1) aligned, 2 ssf_sw bit (1) aligned, /* -ssf option indicator */ 2 is_msf bit (1) aligned, /* set when msf is opened */ 2 end_not_valid bit (1) aligned, /* used with old version files */ 2 error, /* used by "error_status" control order */ 3 type fixed, 3 requested fixed (34), 3 received fixed (34), 2 minus_one_word fixed, 2 file_base_ptr ptr; dcl 1 blk_cb aligned based, /* open data block for blocked files */ 2 file_base_ptr ptr, /* points to base of segment */ 2 seg_ptr_array_ptr ptr, 2 fcb_ptr ptr, 2 mode fixed, /* opening mode (=4,5,6, or 7) */ 2 appending bit (1) aligned, /* -append option */ 2 max_comp_size fixed (19), /* determines capacity of file */ 2 max_rec_len fixed (21), /* determines block size */ 2 block_size fixed (19), /* words, including header */ 2 capacity fixed (19), /* max number of records per comp */ 2 current_pos fixed (34), /* current record number */ 2 next_pos fixed (34), /* next record position (0,1,2,...) */ 2 end_pos fixed (34), /* number of records in file */ 2 last_comp_num fixed, 2 is_msf bit (1) aligned, 2 ssf_sw bit (1) aligned, 2 seg_ptr_array_limit fixed, 2 words (3) fixed, 2 shared bit (1) aligned; dcl cb_ptr ptr; dcl info_ptr ptr; dcl 1 info based (info_ptr), /* structure to receive file information */ 2 version fixed, /* must =1 */ 2 words (size (indx_info) - 1) fixed; %include vfs_info; %include vf_attach_block; %include iocbv; end vfile_status_; 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