mseg_.alm 05/10/85 0907.3r w 05/06/85 1617.7 15462 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** " The Message Segment Primitives " Created: April 1985 by G. Palter name mseg_ macro transfer segdef &1 &1: getlp tra &2$&1 &end transfer add_acl_entries_seg,mseg_fs_interface_ transfer add_message,mseg_message_ transfer chname_seg,mseg_fs_interface_ transfer close_seg,mseg_index_ transfer compact_seg,mseg_segment_ transfer copy_seg,mseg_segment_ transfer count_messages,mseg_message_ transfer create_seg,mseg_fs_interface_ transfer delete_acl_entries_seg,mseg_fs_interface_ transfer delete_message,mseg_message_ transfer delete_seg,mseg_fs_interface_ transfer get_salvaged_flag_seg,mseg_segment_ transfer get_wakeup_state_seg,mseg_segment_ transfer initiate_seg,mseg_index_ transfer list_acl_seg,mseg_fs_interface_ transfer list_acl_entries_seg,mseg_fs_interface_ transfer open_seg,mseg_index_ transfer read_message,mseg_message_ transfer replace_acl_seg,mseg_fs_interface_ transfer reset_salvaged_flag_seg,mseg_segment_ transfer reset_wakeup_state_seg,mseg_segment_ transfer set_max_length_seg,mseg_segment_ transfer set_safety_switch_seg,mseg_fs_interface_ transfer set_wakeup_state_seg,mseg_segment_ transfer update_message,mseg_message_ " A first reference trap to insure that mseg_data_ is properly initialized segdef initialize_caller initialize_caller: getlp tra mseg_utils_$initialize firstref <*text>|initialize_caller end  mseg_access_operations_.cds 08/05/87 0812.1r 08/04/87 1539.1 84897 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: style3,idind30,linecom */ mseg_access_operations_: procedure (); /**** this data segment defines a named constant for each message segment operation that can be called from the outer rings. constants are used to identify the operation and define the type of access required for each operation. written January 1985 by M. Pandolf modified March 1985 by M. Pandolf to eliminate check_name and add audit_this_operation to leave caller validation intact when getting UID modified April 1985 by M. Pandolf to eliminate restore_caller_validation Modified 1985-04-16, BIM: group ms/mbx parallel operations. audit get_count. */ /**** NOTE: If you modify any of the access_operations_ referenced by this program, you must recompile this program with the new version of access_operations_ to actually make the changes take effect. */ /**** This segment would work better if it wrote its own program which called cds, and compiled and executed it. However, there is no time. So the structure below must match the suboutine calls below it. */ /**** Note that we assume that some gate entries will have to make two calls to mseg_check_access_ to audit both sides of an hybrid operation. That's life in MR11 */ declare 1 mops aligned, 2 data aligned, 3 (d_create_seg, d_delete_seg, d_acl_modify_seg, d_acl_list_seg, d_open_seg, d_close_seg, d_compact_seg, d_get_count_seg, d_read_message, d_read_own_message, d_read_delete_message, d_delete_message, d_update_message, d_add_message, d_accept_wakeups_seg, d_send_normal_wakeup, d_send_urgent_wakeup, d_read_attr_seg, d_modify_attr_seg, d_read_fs_attr_seg, d_modify_fs_attr_seg, d_copy_seg, d_admin_add_message, d_read_delete_own_message, d_reset_salvage_bit_seg) aligned like mseg_access_operation, 2 ( create_seg init (1), delete_seg init (2), acl_modify_seg init (3), acl_list_seg init (4), open_seg init (5), close_seg init (6), compact_seg init (7), get_count_seg init (8), read_message init (9), read_own_message init (10), read_delete_message init (11), delete_message init (12), update_message init (13), add_message init (14), accept_wakeups_seg init (15), send_normal_wakeup init (16), send_urgent_wakeup init (17), read_attr_seg init (18), modify_attr_seg init (19), read_fs_attr_seg init (20), modify_fs_attr_seg init (21), copy_seg init (22), admin_add_message init (23), read_delete_own_message init (24), reset_salvage_bit_seg init (25) ) fixed bin; %include mseg_access_operation; declare ( DONT_AUDIT init ("1"b), DONT_AUDIT_SUCCESS init ("01"b), NON_NULL_MODES init ("001"b), NO_MODES init ("0001"b), O_FOR_R init ("00001"b), O_FOR_D init ("000001"b), ADMIN init ("0000001"b), DIR_MODES init ("00000001"b), DIR_MODES_OR_EX_MODES init ("000000001"b) ) bit (36) aligned int static options (constant); op: procedure (op_ptr, a_op, flags, modes, index, dir_modes); declare op_ptr pointer; declare a_op bit (36) aligned; declare modes bit (36) aligned; declare flags bit (36) aligned; declare index fixed bin (9); declare dir_modes bit (3); declare 1 maop aligned like mseg_access_operation based (op_ptr); unspec (maop) = ""b; maop.access_operation = a_op; maop.required_modes = modes; string (maop.flags) = flags; maop.mseg_access_op_index = index; maop.required_dir_modes = dir_modes; return; end op; call op (addr (mops.d_create_seg), access_operations_$mseg_create, NO_MODES | DIR_MODES, ""b, MSEG_CREATE_SEG, M_ACCESS | A_ACCESS); call op (addr (mops.d_delete_seg), access_operations_$mseg_delete, NO_MODES | DIR_MODES, ""b, MSEG_MODIFY_SEG_ATTR, M_ACCESS); call op (addr (mops.d_acl_modify_seg), access_operations_$mseg_access_mod, NO_MODES | DIR_MODES, ""b, MSEG_MODIFY_SEG_ATTR, M_ACCESS); call op (addr (mops.d_acl_list_seg), access_operations_$mseg_access_read, NO_MODES | DIR_MODES, ""b, MSEG_READ_SEG_ATTR, S_ACCESS); call op (addr (mops.d_open_seg), access_operations_$mseg_open, NON_NULL_MODES, ""b, MSEG_READ_SEG_ATTR, ""b); call op (addr (mops.d_close_seg), access_operations_$mseg_close, NO_MODES, ""b, 0, ""b); call op (addr (mops.d_compact_seg), access_operations_$mseg_compact, ""b, MSEG_D_ACCESS, MSEG_MODIFY_SEG_ATTR, ""b); call op (addr (mops.d_get_count_seg), access_operations_$mseg_get_count, ""b, MSEG_S_ACCESS, MSEG_READ_SEG_ATTR, ""b); call op (addr (mops.d_read_message), access_operations_$mseg_read_message, DONT_AUDIT_SUCCESS, MSEG_R_ACCESS, MSEG_READ_MESSAGE, ""b); call op (addr (mops.d_read_own_message), access_operations_$mseg_read_message, O_FOR_R | DONT_AUDIT_SUCCESS, MSEG_R_ACCESS, MSEG_READ_MESSAGE, ""b); call op (addr (mops.d_read_delete_message), access_operations_$mseg_read_delete_message, DONT_AUDIT_SUCCESS, MSEG_R_ACCESS | MSEG_D_ACCESS, MSEG_MODIFY_MESSAGE, ""b); call op (addr (mops.d_delete_message), access_operations_$mseg_delete_message, DONT_AUDIT_SUCCESS | O_FOR_D, MSEG_D_ACCESS, MSEG_MODIFY_MESSAGE, ""b); call op (addr (mops.d_update_message), access_operations_$mseg_update_message, DONT_AUDIT_SUCCESS, MSEG_D_ACCESS, MSEG_MODIFY_MESSAGE, ""b); call op (addr (mops.d_add_message), access_operations_$mseg_add_message, ""b, MSEG_A_ACCESS, MSEG_ADD_MESSAGE, ""b); call op (addr (mops.d_admin_add_message), access_operations_$mseg_add_message, ADMIN, MSEG_A_ACCESS, MSEG_ADD_MESSAGE, ""b); call op (addr (mops.d_accept_wakeups_seg), access_operations_$mseg_accept_wakeups, ""b, MSEG_D_ACCESS, MSEG_ACCEPT_WAKEUPS, ""b); call op (addr (mops.d_send_normal_wakeup), access_operations_$mseg_wakeup_send, ""b, MSEG_W_ACCESS, 0, ""b); call op (addr (mops.d_send_urgent_wakeup), access_operations_$mseg_wakeup_send, ""b, MSEG_U_ACCESS, 0, ""b); call op (addr (mops.d_read_attr_seg), access_operations_$mseg_attr_read, ""b, MSEG_S_ACCESS, MSEG_READ_SEG_ATTR, ""b); call op (addr (mops.d_modify_attr_seg), access_operations_$mseg_attr_mod, ""b, MSEG_D_ACCESS, MSEG_MODIFY_SEG_ATTR, ""b); call op (addr (mops.d_read_fs_attr_seg), access_operations_$mseg_attr_read, NON_NULL_MODES | DIR_MODES_OR_EX_MODES, ""b, MSEG_READ_SEG_ATTR, S_ACCESS); call op (addr (mops.d_modify_fs_attr_seg), access_operations_$mseg_attr_mod, NO_MODES | DIR_MODES, ""b, MSEG_MODIFY_SEG_ATTR, M_ACCESS); call op (addr (mops.d_copy_seg), access_operations_$mseg_read_message, ""b, MSEG_R_ACCESS, MSEG_COPY_SEG, ""b); call op (addr (mops.d_read_delete_own_message), access_operations_$mseg_read_delete_message, O_FOR_R | O_FOR_D | DONT_AUDIT_SUCCESS, MSEG_R_ACCESS | MSEG_D_ACCESS, MSEG_MODIFY_MESSAGE, ""b); /**** The next one, reset_salv_bit_seg, is strange. Since the salvage bit is set automatically, resetting it is not strictly a write-down. We permit it to be reset by any process with D access that is greater_or_equal to the segment parent access class. Thus "READ_SEG_ATTR", since the AIM check is the same for reading the salvage bit. The covert channel here is covered by explicit code in mseg_$reset_salvaged_flag_seg. */ call op (addr (mops.d_reset_salvage_bit_seg), access_operations_$mseg_attr_mod, ""b, MSEG_D_ACCESS, MSEG_READ_SEG_ATTR, ""b); dcl code fixed bin (35); dcl 1 local_cds_args aligned like cds_args; dcl exclude_array (1) char (32) init ("pad*"); dcl create_data_segment_ entry (ptr, fixed bin (35)); dcl com_err_ entry () options (variable); /** begin generation of data segment */ unspec (local_cds_args) = ""b; local_cds_args.sections (1).p = addr (mops); local_cds_args.sections (1).len = size (mops); local_cds_args.sections (1).struct_name = "mops"; local_cds_args.seg_name = "mseg_access_operations_"; local_cds_args.exclude_array_ptr = addr (exclude_array); local_cds_args.num_exclude_names = hbound (exclude_array, 1); local_cds_args.switches.have_text = "1"b; call create_data_segment_ (addr (local_cds_args), code); if code ^= 0 then call com_err_ (code, "mseg_access_operations_"); return; declare ( access_operations_$mseg_add_message, access_operations_$mseg_create, access_operations_$mseg_delete, access_operations_$mseg_open, access_operations_$mseg_close, access_operations_$mseg_attr_read, access_operations_$mseg_attr_mod, access_operations_$mseg_access_read, access_operations_$mseg_access_mod, access_operations_$mseg_compact, access_operations_$mseg_copy, access_operations_$mseg_get_count, access_operations_$mseg_read_message, access_operations_$mseg_delete_message, access_operations_$mseg_read_delete_message, access_operations_$mseg_update_message, access_operations_$mseg_accept_wakeups, access_operations_$mseg_wakeup_send ) bit (36) aligned ext static; %page; %include cds_args; %include mseg_access_mode_values; %include access_mode_values; end mseg_access_operations_;  mseg_check_access_.pl1 08/09/88 1517.4rew 08/09/88 1516.1 345105 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-07-19,Palter), approve(86-02-20,MCR7345), audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092): Changed to not turn error_table_$noentry into error_table_$no_info if the directory name given to the file entrypoint is a link to a directory to which the user has status permission. 2) change(85-07-24,Palter), approve(86-02-20,MCR7345), audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092): Return the new error code error_table_$not_own_message when asked to read or read&delete a message through an own gate which is not an own message and the user has sufficient access to perform the operation if a non-own gate were used. 3) change(86-06-11,Lippard), approve(86-07-10,MCR7441), audit(86-08-05,GDixon), install(86-08-06,MR12.0-1118): Modified by Jim Lippard to allow courtesy upgrades of messages to recipient's access class. 4) change(86-10-29,Lippard), approve(86-11-24,MCR7578), audit(87-07-13,Dickson), install(87-08-06,MR12.1-1067): Modified to use error_table_$bad_file_name instead of $badstar and to call access_audit_r1_$(check log)_general when there is no valid mseg ptr. 5) change(88-08-08,Lippard), approve(88-05-02,PBF7881), audit(88-08-09,Farley), install(88-09-88,MR12.2-1084): Corrected fix for when to call (check log)_general entrypoints. (phx20094) Also changed to generate audit messages when an entry's audit switch is on. END HISTORY COMMENTS */ /* mseg_check_access_ - procedure to calculate validity of access to a given message segment and to log the query appropriately. written February 1985 by M. Pandolf modified March 1985 by M. Pandolf to remove name checking to use seg ptrs as a rule to save access_info per ring 1 call modified April 1985 by M. Pandolf for misc bug fixes Modified 1985-04-16, BIM: restructure. Modified: 6 May 1985 by G Palter to censor error codes properly */ /* format: style3,idind30 */ mseg_check_access_: procedure (p_mseg_operation_ptr, p_status); return; /* not an entrypoint */ /* Parameters */ dcl p_mseg_operation_ptr pointer parameter; dcl p_status fixed bin (35) parameter; /* Automatic */ dcl initiate_failure bit (1) aligned; dcl 1 parent_access_info aligned like entry_access_info; dcl parent_access_info_valid bit (1) aligned; dcl link_dir_name character (168); dcl link_entryname character (32); dcl entry_type fixed bin; dcl status fixed bin (35); dcl used_privilege bit (1) aligned; dcl use_ai_restricted bit (1) aligned; /* Constants */ declare ( SEGMENT init (1), MESSAGE init (2), CHECK init (3) ) fixed bin int static options (constant); declare ( DONT_CHASE initial (0), CHASE initial (1) ) fixed binary (1) static options (constant); /* Static, External */ dcl ( error_table_$ai_restricted, error_table_$bad_file_name, error_table_$incorrect_access, error_table_$invalid_lock_reset, error_table_$moderr, error_table_$no_info, error_table_$no_message, error_table_$noentry, error_table_$not_own_message, error_table_$not_seg_type, error_table_$oosw ) fixed binary (35) external; dcl ( sys_info$dir_privilege, sys_info$ring1_privilege ) bit (36) aligned external; /* Entries */ dcl access_audit_r1_$check_general entry () options (variable) returns (bit (1) aligned); dcl access_audit_r1_$check_obj_class entry () options (variable) returns (bit (1) aligned); dcl access_audit_r1_$check_obj_path entry () options (variable) returns (bit (1) aligned); dcl access_audit_r1_$check_obj_ptr entry () options (variable) returns (bit (1) aligned); dcl access_audit_r1_$log_general entry () options (variable); dcl access_audit_r1_$log_obj_class entry () options (variable); dcl access_audit_r1_$log_obj_path entry () options (variable); dcl access_audit_r1_$log_obj_ptr entry () options (variable); dcl admin_gate_$admin_level_no_fs_audit entry (fixed binary (3)); dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35)); dcl hcs_$get_access_info entry (char (*), char (*), fixed bin (1), ptr, fixed bin (35)); dcl hcs_$get_access_info_seg entry (ptr, ptr, fixed bin (35)); dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$level_set entry (fixed bin (3)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl read_allowed_ entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl read_write_allowed_ entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl write_allowed_ entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl set_lock_$lock entry (bit (36) aligned, fixed binary, fixed binary (35)); dcl sub_err_ entry () options (variable); /* Builtins */ dcl (addr, after, before, index, length, null, reverse, size, string, substr) builtin; %page; /**** This entrypoint is called when we have an actual message that we propose to delete, read, or update */ message: entry (p_mseg_operation_ptr, p_status); entry_type = MESSAGE; initiate_failure = "0"b; /**** We do this work in-line here since it has little or nothing to do with the segment/check entrypoints. */ status = 0; mseg_operation_ptr = p_mseg_operation_ptr; mseg_access_operation_ptr = addr (mseg_access_operations_$data (mseg_operation.access_operation)); used_privilege = "0"b; use_ai_restricted = "0"b; /* ON => audit as AIM restricted but return no_message */ call check_message_access (); if mseg_operation.suppress_access_checks = "0"b /* only audit if we actually made access checks ... */ then if use_ai_restricted then call audit_operation (error_table_$ai_restricted); else call audit_operation (status); go to exit; check_message_access: procedure (); declare aim_code fixed bin (35); declare owner_code fixed bin (35); aim_code, owner_code = 0; md_ptr = mseg_operation.md_ptr; if (mseg_operation.access_operation = mseg_access_operations_$read_own_message) | (mseg_operation.access_operation = mseg_access_operations_$read_delete_own_message) then /*** The user has asked to only operate on his own messages */ if owner_matches () then owner_code = 0; else if mseg_operation.access_info_valid & ((mseg_operation.access_info.extended_access_modes & MSEG_R_ACCESS) ^= ""b) then /*** The user has read access and, therefore, is allowed to find out the he did specify a real message. */ owner_code = error_table_$not_own_message; else owner_code = error_table_$no_message; else if mseg_operation.only_own_access then /*** We had to substitute own access for read and/or delete access in order to allow this operation to get this far. */ if owner_matches () then owner_code = 0; else if mseg_operation.access_info_valid & ((mseg_operation.access_info.extended_access_modes & MSEG_R_ACCESS) ^= ""b) then /*** We substituted own for delete as the user has read access -- Therefore we can tell the user that he lacks the appropriate access to modify the message as he does have enough access to find out it exists. */ owner_code = error_table_$moderr; else owner_code = error_table_$no_message; else owner_code = 0; if mseg_operation.suppress_access_checks /* all we are doing is checking owner-ness */ then do; if owner_code ^= 0 then status = error_table_$no_message; return; end; if mseg_access_operation.mseg_access_op_index = MSEG_READ_MESSAGE then do; if ^aim_check_$greater_or_equal (mseg_operation.caller.authorization, message_descriptor.ms_access_class) then if ((mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b) then used_privilege = "1"b; else do; aim_code = error_table_$no_message; use_ai_restricted = "1"b; end; else ; /* authorization is OK */ end; else if mseg_access_operation.mseg_access_op_index = MSEG_MODIFY_MESSAGE then do; if ^aim_check_$equal (mseg_operation.caller.authorization, message_descriptor.ms_access_class) then if ((mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b) then used_privilege = "1"b; else if aim_check_$greater (mseg_operation.caller.authorization, message_descriptor.ms_access_class) then aim_code = error_table_$ai_restricted; else do; aim_code = error_table_$no_message; use_ai_restricted = "1"b; end; end; /**** Now invent the correct status code. If we were willing to return ai_restricted, then we are willing to inform the user that the message exists, and so we return the owner code (if any). If the aim code was no_message, meaning that we are not willing to reveal the existence of the message, then we must return that. */ if aim_code = error_table_$ai_restricted & owner_code ^= 0 then status = owner_code; else if aim_code ^= 0 then status = aim_code; else status = owner_code; return; owner_matches: procedure returns (bit (1) aligned); declare name char (32) varying; declare message_name char (32) varying; name = before (mseg_operation.caller.group_id, "."); /* assume user name is relevant to begin with */ message_name = before (message_descriptor.sender_id, "."); if message_name = "anonymous" then if name ^= "anonymous" then return ("0"b); /* only anon can own anon */ if name = "anonymous" /* nope, project is important */ then do; name = before (after (mseg_operation.caller.group_id, "."), "."); /* PROJECT */ message_name = before (after (message_descriptor.sender_id, "."), "."); /* PROJECT */ end; return (name = message_name); end owner_matches; end check_message_access; %page; /**** This entrypoint is called for segment-level access checks. It respects mseg_access_operation.dont_audit_success. Those operations are audited when the $message entrypoint is called */ segment: entry (p_mseg_operation_ptr, p_status); entry_type = SEGMENT; initiate_failure = "0"b; go to COMMON; /**** This entrypoint is called for a few cases where the situation is so intricate that the caller takes responsibility for the audit situation. */ check: entry (p_mseg_operation_ptr, p_status); entry_type = CHECK; initiate_failure = "0"b; COMMON: p_status = 0; mseg_operation_ptr = p_mseg_operation_ptr; if mseg_operation.suppress_access_checks then return; if ^mseg_operation.mseg_ptr_valid & ^mseg_operation.mseg_pathname_valid then call sub_err_ (0, "mseg_check_access_", ACTION_CANT_RESTART, null (), (0), "Neither a pathname nor a segment pointer was supplied."); used_privilege = "0"b; mseg_access_operation_ptr = addr (mseg_access_operations_$data (mseg_operation.access_operation)); /**** Obtain access information needed to validate the user's access. As our validation level is now lower than the user's, we can learn things about the segment that the user isn't allowed to know. We must be sure to translate any error codes obtain through this knowlege into error_table_$no_info. */ parent_access_info_valid = "0"b; if mseg_access_operation.mseg_access_op_index = MSEG_CREATE_SEG then do; /**** Creation is different from the other operations in that we expect that the segment doesn't exist. Therefore, we must find the true pathname of the segment by chasing the link ourself and, as the segment is assumed to not exist, we need only check that it will have a proper name. We chase the link using the user's validation rather than our own to insure that get_link_target returns the status code that the user would see. */ call hcs_$level_set (mseg_operation.caller.validation_level); call hcs_$get_link_target (mseg_operation.dir_name, mseg_operation.entryname, link_dir_name, link_entryname, status); if mseg_operation.call_admin_gate then call admin_gate_$admin_level_no_fs_audit ((0)); else call hcs_$level_set (mseg_data_$execution_ring); if (status ^= 0) & (status ^= error_table_$noentry) then go to audit_and_exit; /* it's already the proper code */ mseg_operation.dir_name = link_dir_name;/* be sure to use the "chased" pathname */ mseg_operation.entryname = link_entryname; mseg_operation.access_info.extended_access_modes = MSEG_NULL_ACCESS; /* above will force censor_if_neeed into action */ if ^valid_name (mseg_operation.entryname) then do; status = censor_if_needed (error_table_$bad_file_name); go to audit_and_exit; end; end; else if mseg_operation.access_info_valid = "0"b then do; if mseg_operation.mseg_ptr_valid then call hcs_$get_access_info_seg (mseg_operation.mseg_ptr, addr (mseg_operation.access_info), status); else call hcs_$get_access_info (mseg_operation.dir_name, mseg_operation.entryname, 1 /* chase */, addr (mseg_operation.access_info), status); if status ^= 0 then do; status = censor_if_needed (status); go to audit_and_exit; end; mseg_operation.access_info_valid = "1"b; if ^valid_segment () then do; status = censor_if_needed (error_table_$not_seg_type); go to audit_and_exit; end; end; /**** Check access based upon discretionary and mandatory controls. As message segments do not yet have extended ring brackets, the only ring bracket check that must be made is when the user does not have the proper discretionary access (i.e., extended modes). In this case, while we may be able to tell the exact error in our ring, the branch's parent's ring brackets may prohibit us from telling the user and we must then return error_table_$no_info. */ status = 0; if acl_ok_for_operation (status) then if aim_ok_for_operation () then ; else status = error_table_$ai_restricted; /*** acl_ok_for_operation will set status to proper value */ /**** Audit the success/failure of the operation if appropriate */ audit_and_exit: call audit_operation (status); exit: p_status = status; return; %page; /**** This entrypoint is called by mseg_mbx_ms_gate_target_ if its call to mseg_$initiate_seg fails. The purpose of this entrypoint is to audit the failure of the operation being attempted by the gate target. Further, this entrypoint is responsible for censoring the error code returned to the user of the gate because, as we are normally at a lower validation level than the user, we can determine more about the failure to initiate the segment than the user should be allowed to know. */ audit_initiate_failure: entry (p_mseg_operation_ptr, p_status); entry_type = SEGMENT; /* we want the audit */ initiate_failure = "1"b; mseg_operation_ptr = p_mseg_operation_ptr; mseg_access_operation_ptr = addr (mseg_access_operations_$data (mseg_operation.access_operation)); parent_access_info_valid = "0"b; /* censor_if_needed must find the parent's access */ mseg_operation.access_info.extended_access_modes = MSEG_NULL_ACCESS; status = censor_if_needed (p_status); used_privilege = ((mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b); call audit_operation (status); p_status = status; /* be sure the gate returns the right code */ return; %page; valid_segment: procedure () returns (bit (1) aligned); dcl bracket fixed bin; if mseg_operation.access_info.type ^= 1 /* seg */ then return ("0"b); do bracket = 1 to 3; if mseg_operation.access_info.ring_brackets (bracket) ^= mseg_data_$execution_ring then return ("0"b); end; return (valid_name (mseg_operation.access_info.entryname)); end valid_segment; valid_name: procedure (p_entryname) returns (bit (1) aligned); dcl p_entryname character (32) parameter; dcl xiffus_index fixed bin; dcl name_length fixed bin; name_length = length (p_entryname); xiffus_index = index (reverse (p_entryname), ".");/* suffix backwards, silly */ if xiffus_index = 0 then return ("0"b); if mseg_operation.type = MSEG_TYPE_MBX then if substr (p_entryname, name_length - xiffus_index + 2) ^= "mbx" then return ("0"b); if mseg_operation.type = MSEG_TYPE_MS then if substr (p_entryname, name_length - xiffus_index + 2) ^= "ms" then return ("0"b); return ("1"b); end valid_name; %page; /**** Censor the status code we want to return to the user if appropriate -- As we are usually running with a lower validation level than the user, we can often determine certain things about the segment that the user can not determine on his own. In particular, if the user were to make one of the calls which we made from his validation level, where his real effective access to the segment would be null, ring 0 will return error_table_$no_info unless the user has non-null effective access to the segment's parent. Therefore, we must do the same. We do this by changing any code to be returned into error_table_$no_info if the user has both null extended access to the segment and null effective access to the parent. We use the extended access to the segment rather than the real access to decide when we should censor as the extended access is what the user considers to be his real access to the segment. */ censor_if_needed: procedure (p_return_status) returns (fixed binary (35)); dcl p_return_status fixed binary (35); dcl parent_dir_name character (168); dcl chase_the_parent fixed binary (1); dcl code fixed binary (35); if (p_return_status ^= error_table_$bad_file_name) & (p_return_status ^= error_table_$incorrect_access) & (p_return_status ^= error_table_$moderr) & (p_return_status ^= error_table_$noentry) & (p_return_status ^= error_table_$not_seg_type) then return (p_return_status); /* only censor codes that user may not be able to determine */ if parent_access_info_valid = "0"b then do; /**** We need to determine the parent's effective access. First we must get the pathname. As this procedure can be called before the access_info of the segment has been determined, we may have to look in several places to find the parent's name. */ if mseg_operation.access_info_valid then do; parent_dir_name = mseg_operation.access_info.dir_name; chase_the_parent = DONT_CHASE; end; else if mseg_operation.mseg_pathname_valid then do; parent_dir_name = mseg_operation.dir_name; chase_the_parent = CHASE; end; else /*** if mseg_operation.mseg_ptr_valid then */ do; call hcs_$fs_get_path_name (mseg_operation.mseg_ptr, parent_dir_name, (0), ((32)" "), code); if code ^= 0 /* only fails if parent and segment access both null */ then return (error_table_$no_info); chase_the_parent = DONT_CHASE; end; parent_access_info.version = ENTRY_ACCESS_INFO_VERSION_1; call hcs_$get_access_info (parent_dir_name, "", chase_the_parent, addr (parent_access_info), code); if code ^= 0 /* failure implies no access on the parent */ then return (error_table_$no_info); /**** As our execution ring is always lower (or equal) to our caller's validation level, we must factor the directory ring brackets into our effective access on the parent ourselves. */ if mseg_operation.caller.validation_level > parent_access_info.ring_brackets (1) then /*** outside of modify bracket -- remove M and A access */ parent_access_info.effective_access_modes = parent_access_info.effective_access_modes & ^(A_ACCESS | M_ACCESS); if mseg_operation.caller.validation_level > parent_access_info.ring_brackets (2) then /*** outside of status bracket -- remove S access */ parent_access_info.effective_access_modes = parent_access_info.effective_access_modes & ^(S_ACCESS); parent_access_info_valid = "1"b; end; /**** Now that we have the parent's effective access based on the user's validation, we can properly censor the status code we want to return. */ if ((mseg_operation.access_info.extended_access_modes & MSEG_FULL_ACCESS) = ""b) & ((parent_access_info.effective_access_modes & SMA_ACCESS) = ""b) then return (error_table_$no_info); else return (p_return_status); end censor_if_needed; %page; acl_ok_for_operation: procedure (return_status) returns (bit (1) aligned); declare return_status fixed bin (35); declare grant_on_ex_access bit (1) aligned; grant_on_ex_access = ex_acl_ok (); /* check if extended access is OK */ if mseg_access_operation.flags.dir_modes_or_ex_modes then if grant_on_ex_access then return ("1"b); else return (parent_access_ok ()); if ^grant_on_ex_access then do; return_status = censor_if_needed (error_table_$moderr); return ("0"b); end; if mseg_access_operation.flags.dir_modes then return (parent_access_ok ()); else return ("1"b); ex_acl_ok: procedure returns (bit (1) aligned); declare test_mode bit (36) aligned; if mseg_access_operation.flags.no_modes then return ("1"b); if mseg_access_operation.flags.non_null_modes then return ((mseg_operation.access_info.extended_access_modes & MSEG_FULL_ACCESS) ^= ""b); /**** O mode is handled as follows: if all the requested x modes are present, then we are fine. Otherwise, check the O substitution flags. */ if (mseg_operation.access_info.extended_access_modes & mseg_access_operation.required_modes) = mseg_access_operation.required_modes then return ("1"b); if (mseg_operation.access_info.extended_access_modes & MSEG_O_ACCESS) = ""b then return ("0"b); /* if no own mode, then give up */ if ^(mseg_access_operation.flags.o_for_r | mseg_access_operation.flags.o_for_d) then return ("0"b); test_mode = mseg_access_operation.required_modes; /* start with the full set */ if mseg_access_operation.flags.o_for_r then test_mode = (test_mode & ^MSEG_R_ACCESS); /* remove R from the st */ if mseg_access_operation.flags.o_for_d then test_mode = (test_mode & ^MSEG_D_ACCESS); /* Remove D from the set */ if (test_mode & mseg_operation.access_info.extended_access_modes) = test_mode then do; /* Do we have enough ? */ mseg_operation.only_own_access = "1"b; /* yes, but note that we used O */ return ("1"b); end; else return ("0"b); end ex_acl_ok; parent_access_ok: procedure returns (bit (1) aligned); declare code fixed bin (35); parent_access_info.version = ENTRY_ACCESS_INFO_VERSION_1; if mseg_operation.access_info_valid /* access_info isn't valid for create operation */ then call hcs_$get_access_info (mseg_operation.access_info.dir_name, "", (0), addr (parent_access_info), code); else call hcs_$get_access_info (mseg_operation.dir_name, "", (0), addr (parent_access_info), code); if code ^= 0 then do; return_status = error_table_$no_info; return ("0"b); end; /**** As our execution ring is always lower (or equal) to our caller's validation level, we must factor the directory ring brackets into our effective access on the parent ourselves. */ if mseg_operation.caller.validation_level > parent_access_info.ring_brackets (1) then /*** outside of modify bracket -- remove M and A access */ parent_access_info.effective_access_modes = parent_access_info.effective_access_modes & ^(A_ACCESS | M_ACCESS); if mseg_operation.caller.validation_level > parent_access_info.ring_brackets (2) then /*** outside of status bracket -- remove S access */ parent_access_info.effective_access_modes = parent_access_info.effective_access_modes & ^(S_ACCESS); parent_access_info_valid = "1"b; /* stop censor_if_needed from making the call twice */ /**** The directory ring brackets are now properly factored into our access. We can now check if we have the access we need. */ if (mseg_access_operation.required_dir_modes & parent_access_info.effective_access_modes) = mseg_access_operation.required_dir_modes then return ("1"b); /* enough access */ /**** We don't have the required access to the branch's parent -- We want to return error_table_$incorrect_access unless the user isn't allowed to determine that from his validation level. Therefore, we'll simply allow censor_if_needed to make the decision on which code to return. */ return_status = censor_if_needed (error_table_$incorrect_access); return ("0"b); end parent_access_ok; end acl_ok_for_operation; %page; aim_ok_for_operation: procedure returns (bit (1) aligned); dcl code fixed bin (35); /****^ There are some standard AIM tests, and some peculiar ones. the standard ones are keyed off of the READ/APPEND/MODIFY classification. The per-segment checks are these: READ-SEGMENT-INFO -- auth >= segment-min-auth MODIFY-SEGMENT-INFO -- auth = segment-min-auth COPY-SEGMENT -- max-auth >= segment-max-auth (insures new container will hold all messages) auth = segment-min-auth Special checks: ADD-MESSAGE -- segment-min <= message-acc <= segment-max auth <= message-acc OR ring1 priv ACCEPT-MESSAGES -- MODIFY-SEGMENT-INFO + various additional checks below. */ if mseg_access_operation.mseg_access_op_index = MSEG_READ_SEG_ATTR then return (read_attr_ok ()); else if mseg_access_operation.mseg_access_op_index = MSEG_MODIFY_SEG_ATTR then return (modify_attr_ok ()); else if mseg_access_operation.mseg_access_op_index = MSEG_COPY_SEG then return (copy_ok ()); else if mseg_access_operation.mseg_access_op_index = MSEG_ADD_MESSAGE then return (add_message_ok ()); else if mseg_access_operation.mseg_access_op_index = MSEG_MODIFY_MESSAGE then return (modify_message_ok ()); else if mseg_access_operation.mseg_access_op_index = MSEG_ACCEPT_WAKEUPS then return (accept_wakeups_ok ()); else if mseg_access_operation.mseg_access_op_index = MSEG_READ_MESSAGE then return (read_message_ok ()); else return ("1"b); /* no check defined */ read_attr_ok: procedure returns (bit (1) aligned); if read_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class) then return ("1"b); else return (priv_ok ()); end read_attr_ok; modify_attr_ok: procedure returns (bit (1) aligned); if read_write_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class) then return ("1"b); else return (priv_ok ()); end modify_attr_ok; copy_ok: procedure returns (bit (1) aligned); if aim_check_$greater_or_equal (mseg_operation.caller.max_authorization, mseg_operation.access_info.access_class) & read_write_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class) then return ("1"b); return (priv_ok () & ((mseg_operation.caller.privileges & sys_info$dir_privilege) ^= ""b)); /* the caller cannot append the new message segment with the appropriate characteristics without dir priv */ end copy_ok; add_message_ok: procedure returns (bit (1) aligned); if ^(aim_check_$greater_or_equal (mseg_operation.message_info.ms_access_class, mseg_operation.access_info.parent_access_class) & aim_check_$greater_or_equal (mseg_operation.access_info.access_class, mseg_operation.message_info.ms_access_class)) then return ("0"b); /* Message not permitted in segment, no-how */ if priv_ok () then return ("1"b); /* no need for user checks */ if ^aim_check_$greater_or_equal (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class) then return ("0"b); /* not allowed to write in here */ if ^aim_check_$greater_or_equal (mseg_operation.message_info.ms_access_class, mseg_operation.caller.authorization) then return ("0"b); /* must mark information >= to self */ /* Reject if message access class is greater than the sender's maximum authorization except in the case of courtesy upgrades, when the message access class is the same as the authorization of the recipient. */ if ^aim_check_$greater_or_equal (mseg_operation.caller.max_authorization, mseg_operation.message_info.ms_access_class) then if mseg_operation.wakeup_state_valid then if ^aim_check_$equal (mseg_operation.message_info.ms_access_class, mseg_operation.wakeup_state.access_class) then return ("0"b); else; else return ("0"b); /* must mark information <= to max */ return ("1"b); /**** If message>=user, and message<=segment_max, then user <=segment_max, so no seperate check is needed for that. */ end add_message_ok; modify_message_ok: procedure returns (bit (1) aligned); /**** This is just the initial segment check */ /**** Can we possibly modify anything in this segment? */ if read_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class) & write_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.access_class) then return ("1"b); else return (priv_ok ()); end modify_message_ok; read_message_ok: procedure returns (bit (1) aligned); /**** This is just the initial segment check */ if read_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.parent_access_class) then return ("1"b); else return (priv_ok ()); end read_message_ok; priv_ok: procedure returns (bit (1) aligned); if (mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b then do; used_privilege = "1"b; return ("1"b); end; else return ("0"b); end priv_ok; accept_wakeups_ok: procedure () returns (bit (1) aligned); declare test_lock_id bit (36) aligned; if ^basic_accept_ok () then return ("0"b); /**** Now check for the covert channel ... */ if ^mseg_operation.wakeup_state_valid then return ("1"b); /* no message implies that all is fine */ if aim_check_$greater_or_equal (mseg_operation.caller.authorization, mseg_operation.wakeup_state.access_class) then return ("1"b); test_lock_id = mseg_operation.wakeup_state.lock_id; call set_lock_$lock (test_lock_id, 0, code); if (code = 0) | (code = error_table_$invalid_lock_reset) then return ("1"b); else return ("0"b); basic_accept_ok: procedure returns (bit (1) aligned); return (modify_message_ok ()); /* Same check */ end basic_accept_ok; end accept_wakeups_ok; end aim_ok_for_operation; %page; audit_operation: procedure (code); dcl code fixed bin (35) parameter; declare 1 event_flags unaligned like audit_event_flags; declare do_audit bit (1) aligned; declare 1 a_audit_mseg_msg aligned like audit_mseg_msg_info; if entry_type = CHECK then return; if mseg_access_operation.dont_audit then return; if ^mseg_operation.call_admin_gate then return; if code = 0 & entry_type = SEGMENT & mseg_access_operation.flags.dont_audit_success then return; /* This will be audited on the second pass */ if (code ^= 0) & (code ^= error_table_$ai_restricted) & (code ^= error_table_$incorrect_access) & (code ^= error_table_$moderr) & (code ^= error_table_$no_info) & (code ^= error_table_$oosw) then return; /* only audit success or access violations */ string (event_flags) = ""b; if code = 0 then event_flags.grant = "1"b; if mseg_access_operation.admin then event_flags.admin_op = "1"b; if used_privilege then event_flags.priv_op = "1"b; /**** Now for a puzzle. Audit the message, or audit the segment? We check based on the message, if any, and then log the segment. */ /* Checks for the case where the audit switch is on. These need to be reached before such checks as the one below for the case where mseg_access_operation.access_info_valid is on, as that doesn't reference the mailbox entry itself. */ if mseg_operation.mseg_ptr_valid then do_audit = access_audit_r1_$check_obj_ptr (string (event_flags), mseg_access_operation.access_operation, mseg_operation.mseg_ptr); else if mseg_operation.mseg_pathname_valid then do_audit = access_audit_r1_$check_obj_path (string (event_flags), mseg_access_operation.access_operation, pathname_ (mseg_operation.dir_name, mseg_operation.entryname)); if do_audit then goto DO_THE_AUDIT; /* Now check for the other conditions. */ if mseg_operation.md_ptr_valid = "1"b then do_audit = access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation, mseg_operation.md_ptr -> message_descriptor.ms_access_class); else if mseg_access_operation.mseg_access_op_index = MSEG_ADD_MESSAGE then do_audit = access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation, mseg_operation.message_info.ms_access_class); else if mseg_access_operation.mseg_access_op_index = MSEG_CREATE_SEG then do_audit = access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation, mseg_operation.caller.max_authorization); else if mseg_operation.access_info_valid then if mseg_access_operation.mseg_access_op_index = MSEG_COPY_SEG then do_audit = access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation, mseg_operation.access_info.access_class); /* we are copying all of those message, possibly up to the max */ else do_audit = access_audit_r1_$check_obj_class (string (event_flags), mseg_access_operation.access_operation, mseg_operation.access_info.parent_access_class); /* The mseg information is controlled at the base access class, not the MAX */ else if mseg_operation.mseg_ptr_valid then do_audit = access_audit_r1_$check_obj_ptr (string (event_flags), mseg_access_operation.access_operation, mseg_operation.mseg_ptr); else if initiate_failure then do_audit = access_audit_r1_$check_general (string (event_flags), mseg_access_operation.access_operation); else if mseg_operation.mseg_pathname_valid then do_audit = access_audit_r1_$check_obj_path (string (event_flags), mseg_access_operation.access_operation, pathname_ (mseg_operation.dir_name, mseg_operation.entryname)); else call sub_err_ (0, "mseg_check_access_", ACTION_CANT_RESTART, null (), (0), "Attempt to audit an mseg operation without a valid mseg_operation."); if ^do_audit then return; DO_THE_AUDIT: audit_mseg_msg_ptr = null (); if mseg_operation.md_ptr_valid then do; audit_mseg_msg_ptr = addr (a_audit_mseg_msg); audit_mseg_msg_info.info_type = AAB_mseg_msg; audit_mseg_msg_info.version = AUDIT_MSEG_MSG_INFO_VERSION_5; audit_mseg_msg_info.descriptor = mseg_operation.md_ptr -> message_descriptor, by name; end; if mseg_access_operation.mseg_access_op_index = MSEG_CREATE_SEG then call access_audit_r1_$log_obj_class ("mseg_check_access_", mseg_operation.caller.validation_level, string (event_flags), mseg_access_operation.access_operation, mseg_operation.caller.max_authorization, pathname_ (mseg_operation.dir_name, mseg_operation.entryname), code, audit_mseg_msg_ptr, size (audit_mseg_msg_info)); else if mseg_operation.mseg_ptr_valid then call access_audit_r1_$log_obj_ptr ("mseg_check_access_", mseg_operation.caller.validation_level, string (event_flags), mseg_access_operation.access_operation, mseg_operation.mseg_ptr, code, audit_mseg_msg_ptr, size (audit_mseg_msg_info)); else if initiate_failure then call access_audit_r1_$log_general ("mseg_check_access_", mseg_operation.caller.validation_level, string (event_flags), mseg_access_operation.access_operation, pathname_ (mseg_operation.dir_name, mseg_operation.entryname), code, audit_mseg_msg_ptr, size (audit_mseg_msg_info)); else call access_audit_r1_$log_obj_path ("mseg_check_access_", mseg_operation.caller.validation_level, string (event_flags), mseg_access_operation.access_operation, pathname_ (mseg_operation.dir_name, mseg_operation.entryname), code, audit_mseg_msg_ptr, size (audit_mseg_msg_info)); return; end audit_operation; /* format: off */ %page; %include access_audit_binary_def; %page; %include access_audit_mseg_info; %page; %include mseg_access_mode_values; %page; %include mseg_access_operation; %page; %include mseg_data_; %page; %include mseg_message_info; %page; %include mseg_operation; %page; %include mseg_segment; %page; %include mseg_message; %page; %include access_mode_values; %page; %include access_audit_eventflags; %page; %include entry_access_info; %page; %include mseg_wakeup_state; %page; %include sub_err_flags; %page; %include mseg_access_operations_; %page; /* BEGIN MESSAGE DOCUMENTATION Message: Audit (mseg_check_access_): [GRANTED | DENIED] OPERATION_DESCRIPTION ADDED_INFO S: $access_audit T: $run M: An access control decision has been made by the mseg_ primitives. The OPERATION_DESCRIPTION specifies the operation requested by the user. GRANTED or DENIED indicates whether access was granted or not. the ADDED_INFO describes the user and the message segment or mailbox. The associated binary info describes the message in the segment if a specific message was involved. A: $notify_ssa END MESSAGE DOCUMENTATION */ /* format: on */ end mseg_check_access_;  mseg_data_.cds 05/13/85 1556.3r w 05/13/85 1541.1 24525 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* mseg_data_.cds -- static and text data for the message segment primitives */ /* format: style3,idind30 */ mseg_data_: procedure; declare 1 mseg_text aligned, 2 template_operation aligned like mseg_operation, 2 max_message_size fixed bin (35) init (262110), 2 block_size fixed bin (35) init (32), 2 admin_ring fixed binary (3) initial (1); declare 1 mseg_static aligned, 2 lock_id bit (36) aligned init (""b), 2 process_max_authorization bit (72) aligned init (""b), 2 group_id char (32) unaligned, 2 execution_ring fixed bin (3) aligned; declare 1 cdsa aligned like cds_args; declare create_data_segment_ entry (pointer, fixed binary (35)); declare com_err_ entry () options (variable); declare code fixed bin (35); mseg_operation_ptr = addr (mseg_text.template_operation); unspec (mseg_operation) = ""b; mseg_operation.version = MSEG_OPERATION_VERSION_1; mseg_operation.operation = ""b; mseg_operation.access_operation = 0; mseg_operation.caller.validation_level = -1; mseg_operation.caller.authorization = ""b; mseg_operation.caller.max_authorization = ""b; mseg_operation.caller.group_id = ""; string (mseg_operation.flags) = ""b; mseg_operation.dir_name = ""; mseg_operation.entryname = ""; mseg_operation.mseg_ptr = null (); mseg_operation.md_ptr = null (); mseg_operation.access_info.version = ENTRY_ACCESS_INFO_VERSION_1; mseg_operation.access_info.type = 0; mseg_operation.access_info.dir_name = ""; mseg_operation.access_info.entryname = ""; mseg_operation.message_info.version = MSEG_MESSAGE_INFO_V1; mseg_operation.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1; unspec (cdsa) = ""b; cdsa.sections (1) /* text */ .p = addr (mseg_text); cdsa.sections (1).len = currentsize (mseg_text); cdsa.sections (1).struct_name = "mseg_text"; cdsa.sections (2) /* static */ .p = addr (mseg_static); cdsa.sections (2).len = currentsize (mseg_static); cdsa.sections (2).struct_name = "mseg_static"; cdsa.seg_name = "mseg_data_"; cdsa.num_exclude_names = 0; cdsa.exclude_array_ptr = null (); cdsa.switches.have_text, cdsa.switches.have_static = "1"b; call create_data_segment_ (addr (cdsa), code); if code ^= 0 then call com_err_ (code, "mseg_data_"); return; %include cds_args; %include mseg_operation; %include entry_access_info; %include mseg_message_info; %include mseg_wakeup_state; end mseg_data_;  mseg_format_errors_.alm 11/05/86 1242.0r w 11/04/86 1038.1 20115 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** " Standard system status codes corresponding to the possible errors which the message " segment primitives may detect in the format of a message segment " Created: April 1985 by G. Palter name mseg_format_errors_ include et_macros et mseg_format_errors_ ec bad_descriptor_sentinel,none, (Message contains a descriptor of unknown format.) ec bad_mseg_sentinel,none, (Message segment has an unknown format.) ec bad_mseg_version,none, (Message segment has an unsupported format.) ec circular_hash_chain,none, (Circular hash chain found in segment.) ec circular_message_blocks,none, (Circular block chain found in a message.) ec circular_message_chain,none, (Circular chronological message chain found in segment.) ec descriptor_in_other_block,none, (Descriptor found in the middle of a message.) ec inconsistent_backward_chain,none, (Segment reverse chronological message chain inconsistent.) ec inconsistent_block_map,none, (Free block count and block map do not agree.) ec inconsistent_forward_chain,none, (Segment chronological message chain inconsistent.) ec inconsistent_hash_chain,none, (Segment contains one or more inconsistent hash chains.) ec inconsistent_message_count,none, (Message count is inconsistent with chronological message chains.) ec inconsistent_message_length,none, (Message size in descriptor does not agree with actual data.) ec invalid_message_block_offset,none, (Offset of message is outside segment bounds or not on a block boundary.) ec modification_in_progress,none, (Previous operation was abnormally terminated.) ec negative_message_count,none, (Message count is negative.) ec no_descriptor_in_first_block,none, (Message does not contain a descriptor.) ec salvage_in_progress,none, (Previous salvage was abnormally terminated.) ec unused_block_in_message,none, (Free block found in message chain.) end  mseg_fs_interface_.pl1 03/15/89 0844.0r w 03/15/89 0800.0 282951 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-05-28,Palter), approve(86-02-20,MCR7345), audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092): Fix delete_acl_entries_seg to not always return error_table_$argerr. 2) change(85-06-12,Palter), approve(86-02-20,MCR7345), audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092): Fix list_acl_seg to not return error_table_$noalloc for an empty ring 0 ACL. 3) change(86-10-29,Lippard), approve(86-11-24,MCR7578), audit(87-07-13,Dickson), install(87-08-06,MR12.1-1067): Modified to enforce restrictions on extended ACLs. 4) change(88-03-09,Lippard), approve(88-03-28,MCR7869), audit(88-04-26,Parisek), install(88-05-03,MR12.2-1044): Modified to return specific error codes for inconsistent ACL modes. END HISTORY COMMENTS */ /* Message segment primitive operations (mseg_) which interface with the ring-0 file system */ /* Created: April 1985 by G. Palter based upon mseg_, mseg_create_, mseg_access_, and mseg_chname_ */ /* format: style3,linecom */ mseg_fs_interface_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_mseg_operation_ptr pointer parameter; dcl P_code fixed binary (35) parameter; dcl P_acl_ptr pointer parameter; /* add_acl_entries_seg: -> ACL entries to add/update (I); create_seg: -> initial ACL for the segment (if any) (I); delete_acl_entries_seg: -> ACL entries to be deleted (I); list_acl_seg: set -> the segment's ACL (O); list_acl_entries_seg: -> ACL entries to be listed (I); replace_acl_seg: -> the segment's new ACL (I) */ dcl P_old_name character (*) parameter; /* chname_seg: old name to be removed (I) */ dcl P_new_name character (*) parameter; /* chname_seg: new name to be added (I) */ dcl P_mseg_index_table_ptr /* delete_seg: -> caller's table of user ring indeces (I) */ pointer parameter; dcl P_safety_switch bit (1) aligned parameter; /* set_safety_switch_seg: the new value of the switch (I) */ /* Local copies of parameters */ dcl code fixed binary (35); /* Remaining declarations */ dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl 1 ring0_acl aligned based (ring0_acl_ptr), 2 entries (ring0_acl_count) aligned like segment_acl_entry; dcl 1 ring0_delete_acl aligned based (ring0_acl_ptr), 2 entries (ring0_acl_count) aligned like delete_acl_entry; dcl ring0_acl_ptr pointer; dcl ring0_acl_count fixed binary; dcl 1 default_initial_acl /* general_extended_acl can not be used with like */ aligned, 2 version character (8) aligned, 2 count fixed binary, 2 entries (3) like general_extended_acl_entry; dcl 1 cbi aligned like create_branch_info; dcl 1 delete_all_others_acl aligned like delete_acl_entry; dcl delete_all_others_access bit (1) aligned; dcl delete_all_others_code fixed binary (35); dcl ext_mode bit (36) aligned; dcl operation_specific_return entry (fixed binary (35)) variable; dcl operation_specific_abort entry () variable; dcl operation_name character (64); dcl mseg_dir_name character (168); dcl mseg_entryname character (32); dcl rqo_detected bit (1) aligned; dcl lock_code fixed binary (35); dcl acl_idx fixed binary; dcl 1 EMPTY_ACL aligned static options (constant), 2 version character (8) initial ("gxacl001"), 2 count fixed binary initial (0); dcl ( SYSDAEMONS initial ("*.SysDaemon.*"), ALL_OTHERS initial ("*.*.*") ) character (32) static options (constant); dcl DONT_ADD_SYSDAEMONS bit (1) static options (constant) initial ("1"b); dcl ( error_table_$action_not_performed, error_table_$argerr, error_table_$bad_acl_mode, error_table_$bad_mbx_acl_rs, error_table_$bad_mbx_acl_awu, error_table_$bad_subr_arg, error_table_$invalid_lock_reset, error_table_$locked_by_this_process, error_table_$lock_wait_time_exceeded, error_table_$noalloc, error_table_$null_info_ptr, error_table_$unimplemented_version, error_table_$user_not_found ) fixed binary (35) external; dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$add_acl_entries entry (character (*), character (*), pointer, fixed binary, fixed binary (35)); dcl hcs_$chname_file entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl hcs_$chname_seg entry (pointer, character (*), character (*), fixed binary (35)); dcl hcs_$create_branch_ entry (character (*), character (*), pointer, fixed binary (35)); dcl hcs_$delentry_seg entry (pointer, fixed binary (35)); dcl hcs_$delete_acl_entries entry (character (*), character (*), pointer, fixed binary, fixed binary (35)); dcl hcs_$list_acl entry (character (*), character (*), pointer, pointer, pointer, fixed binary, fixed binary (35)); dcl hcs_$replace_acl entry (character (*), character (*), pointer, fixed binary, bit (1), fixed binary (35)); dcl hcs_$set_safety_sw entry (character (*), character (*), bit (1), fixed binary (35)); dcl hcs_$set_safety_sw_seg entry (pointer, bit (1), fixed binary (35)); dcl mseg_index_$delete entry (pointer, pointer); dcl mseg_utils_$abort_operation entry (pointer); dcl mseg_utils_$begin_operation entry (bit (36) aligned, pointer, character (*), character (*), character (*), pointer, bit (1) aligned, fixed binary (35)); dcl mseg_utils_$finish_operation entry (pointer); dcl mseg_utils_$request_unlock_on_finish entry (pointer); dcl mseg_utils_$salvage_for_cause entry (pointer, fixed binary (35)) options (variable); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl sub_err_ entry () options (variable); dcl (addr, after, before, bool, dimension, null, reverse, string) builtin; dcl (area, cleanup) condition; %page; /* Add (or update) ACL entries */ mseg_fs_interface_$add_acl_entries_seg: entry (P_mseg_operation_ptr, P_acl_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$add_acl_entries_seg); if code ^= 0 then call return_from_operation (code); call validate_acl (); call hcs_$add_acl_entries (mseg_dir_name, mseg_entryname, addr (general_extended_acl.entries), general_extended_acl.count, code); call return_from_operation (code); %page; /* Change the names -- This entrypoint assumes that the caller has validated the suffix on the new name if necessary. */ mseg_fs_interface_$chname_seg: entry (P_mseg_operation_ptr, P_old_name, P_new_name, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$chname_seg); if code ^= 0 then call return_from_operation (code); if mseg_ptr ^= null () /* use the pointer interface whenever possible */ then call hcs_$chname_seg (mseg_ptr, P_old_name, P_new_name, code); else call hcs_$chname_file (mseg_dir_name, mseg_entryname, P_old_name, P_new_name, code); call return_from_operation (code); %page; /* Create the segment -- This entrypoint assumes that our caller has already chased any links in order to validate the user has access to create the branch and that it will have the proper suffix. If we are called with the pathname of a link, we will fail with error_table_$namedup. */ mseg_fs_interface_$create_seg: entry (P_mseg_operation_ptr, P_acl_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$create_seg); if code ^= 0 then call return_from_operation (code); /*** Validate the initial ACL for the new segment -- If we are creating a mailbox or queue message segment, we will supply a standard initial ACL if the caller doesn't provide one. If we are creating any other type of message segment, the caller must supply the initial ACL as we have no idea what would be proper for that type of segment. */ if P_acl_ptr = null () /* we are to provide the default initial ACL */ then if (mseg_operation.type = MSEG_TYPE_MBX) | (mseg_operation.type = MSEG_TYPE_MS) then do; acl_ptr = addr (default_initial_acl); default_initial_acl.version = GENERAL_EXTENDED_ACL_VERSION_1; default_initial_acl.count = dimension (default_initial_acl.entries, 1); if before (mseg_operation.caller.group_id, ".") = "anonymous" then default_initial_acl.entries (1).access_name = reverse (after (reverse (mseg_operation.caller.group_id), ".")) || ".*"; else default_initial_acl.entries (1).access_name = before (mseg_operation.caller.group_id, ".") || ".*.*"; default_initial_acl.entries (2).access_name = SYSDAEMONS; default_initial_acl.entries (3).access_name = ALL_OTHERS; default_initial_acl.entries (*).mode = RW_ACCESS; if mseg_operation.type = MSEG_TYPE_MBX then default_initial_acl.entries (*).extended_mode = MSEG_MBX_INITIAL_ACL (*); else /*** if mseg_operation.type = MSEG_TYPE_MS then */ default_initial_acl.entries (*).extended_mode = MSEG_QUEUE_INITIAL_ACL (*); end; else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, 0, null (), "No initial ACL supplied for ^a which is not a mailbox or queue message segment.", pathname_ (mseg_dir_name, mseg_entryname)); else call validate_acl (); /* caller has supplied the initial ACL */ /*** Create the segment */ cbi.version = create_branch_version_2; string (cbi.switches) = ""b; cbi.mbz2 = ""b; cbi.bitcnt, cbi.quota, cbi.dir_quota = 0; cbi.userid = "*.*.*"; /* give everyone real read/write access ... */ cbi.mode = RW_ACCESS; cbi.rings (*) = mseg_data_$execution_ring; /* ... but only in the current ring or below */ if mseg_operation.call_admin_gate then do; /* only make it a multiclass segment if running in ring 1 */ cbi.priv_upgrade_sw = "1"b; cbi.access_class = mseg_operation.caller.max_authorization; end; else do; /* create an ordinary segment if outside ring 1 */ cbi.parent_ac_sw = "1"b; cbi.access_class = ""b; /* ... this is ignored if parent_ac_sw is set */ end; call hcs_$create_branch_ (mseg_dir_name, mseg_entryname, addr (cbi), code); if code ^= 0 then call return_from_operation (code); /*** We have succesfully created the segment -- Set its initial ACL. We must use our replace_acl_seg primitive rather than calling hcs_$replace_acl directly in case the caller has supplied an initial ACL without a "*.*.*" term. Proper operation of the primitives require that all users have read/write real access to any message segment. */ on area call return_noalloc_from_operation (); call replace_acl_seg (); /* it does the return_from_operation for us */ %page; /* Delete ACL entries */ mseg_fs_interface_$delete_acl_entries_seg: entry (P_mseg_operation_ptr, P_acl_ptr, P_code); call setup_operation (); /* for cleanup handler */ ring0_acl_ptr = null (); operation_specific_return = return_from_delete_acl_entries_seg; operation_specific_abort = abort_delete_acl_entries_seg; on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$delete_acl_entries_seg); acl_ptr = P_acl_ptr; if acl_ptr = null () then do; /*** An empty general_delete_acl is translated into a request to delete the entire ACL. */ acl_ptr = addr (EMPTY_ACL); on area call return_noalloc_from_operation (); call replace_acl_seg (); /* it does return_from_operation for us */ end; if general_delete_acl.version ^= GENERAL_DELETE_ACL_VERSION_1 then /*** Our caller, as opposed to the user's application, is responsible for creating the ACL structure. Therefore, an incorrect version indicates a programming error in our caller. */ call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0, "general_delete_acl.version = ""^a"".", general_delete_acl.version); /*** Examine the ACL entries to be deleted -- If the caller asks to delete the ACL term for "*.*.*", we will actually not delete it. Instead, we will change its extended access to null as we must insure that all users always have read/write real access to all message segments. */ system_area_ptr = get_system_free_area_ (); ring0_acl_count = general_delete_acl.count; on area call return_noalloc_from_operation (); allocate ring0_delete_acl in (system_area) set (ring0_acl_ptr); revert area; ring0_acl_count = 0; /* no entries in the ACL yet */ delete_all_others_access = "0"b; do acl_idx = 1 to general_delete_acl.count; if general_delete_acl.entries (acl_idx).access_name = ALL_OTHERS then delete_all_others_access = "1"b; else do; ring0_acl_count = ring0_acl_count + 1; ring0_delete_acl.entries (ring0_acl_count).access_name = general_delete_acl.entries (acl_idx).access_name; end; end; /*** Delete the requested non "*.*.*" ACL entries */ if ring0_acl_count ^= 0 then call hcs_$delete_acl_entries (mseg_dir_name, mseg_entryname, addr (ring0_delete_acl), ring0_acl_count, code); else code = 0; /* no non "*.*.*" terms to delete */ /*** Remove the extended access for "*.*.*" if requested */ if delete_all_others_access & ((code = 0) | (code = error_table_$argerr)) then do; /* don't bother if ring 0 will complain */ delete_all_others_acl.access_name = ALL_OTHERS; call hcs_$delete_acl_entries (mseg_dir_name, mseg_entryname, addr (delete_all_others_acl), 1, delete_all_others_code); if delete_all_others_code = error_table_$argerr then delete_all_others_code = delete_all_others_acl.status_code; end; else delete_all_others_code = error_table_$action_not_performed; /*** Return the results of the above actions to our caller */ ring0_acl_count = 0; do acl_idx = 1 to general_delete_acl.count; if general_delete_acl.entries (acl_idx).access_name = ALL_OTHERS then general_delete_acl.entries (acl_idx).status_code = delete_all_others_code; else do; ring0_acl_count = ring0_acl_count + 1; general_delete_acl.entries (acl_idx).status_code = ring0_delete_acl.entries (ring0_acl_count).status_code; end; end; if code = 0 /* all non "*.*.*" terms were deleted ... */ then if delete_all_others_access & (delete_all_others_code ^= 0) then code = error_table_$argerr; /* ... but the "*.*.*" deletion failed: let the caller know */ call return_from_operation (code); /* Special processing required upon the completion of a delete_acl_entries_seg operation */ return_from_delete_acl_entries_seg: procedure (p_code); dcl p_code fixed binary (35) parameter; if ring0_acl_ptr ^= null () then do; free ring0_delete_acl in (system_area); ring0_acl_ptr = null (); end; return; end return_from_delete_acl_entries_seg; /* Special processing required upon abnormal termination of a delete_acl_entries_seg operation */ abort_delete_acl_entries_seg: procedure (); if ring0_acl_ptr ^= null () then do; free ring0_delete_acl in (system_area); ring0_acl_ptr = null (); end; return; end abort_delete_acl_entries_seg; %page; /* Delete the segment -- We must try to delete even if we can't lock the segment due to RQO or connection failures. Therefore, we only request mseg_utils_ to try to lock the segment but not to check the results. If, however, we do lock the segment but can't delete it, we must be certain to unlock the segment before returning to our caller. */ mseg_fs_interface_$delete_seg: entry (P_mseg_operation_ptr, P_mseg_index_table_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$delete_seg); if code = error_table_$lock_wait_time_exceeded /* someone's still using it */ then call return_from_operation (code); lock_code = code; /* we'll need this later in case we can't delete it */ call hcs_$delentry_seg (mseg_ptr, code); if code = 0 /* it's deleted: flush it from the caller's index table */ then call mseg_index_$delete (mseg_operation_ptr, P_mseg_index_table_ptr); else if ^rqo_detected /* couldn't delete it but we might have locked it */ then do; if lock_code = 0 /* ... we did lock it: be sure it get's unlocked */ then call mseg_utils_$request_unlock_on_finish (mseg_operation_ptr); else if (lock_code = error_table_$invalid_lock_reset) | (lock_code = error_table_$locked_by_this_process) then do; /* ... we locked it but it should have been salvaged */ call mseg_utils_$salvage_for_cause (mseg_operation_ptr, lock_code); call mseg_utils_$request_unlock_on_finish (mseg_operation_ptr); end; end; call return_from_operation (code); %page; /* List the entire ACL */ mseg_fs_interface_$list_acl_seg: entry (P_mseg_operation_ptr, P_acl_ptr, P_code); call setup_operation (); /* for cleanup handler */ acl_ptr, ring0_acl_ptr = null (); operation_specific_return = return_from_list_acl_seg; operation_specific_abort = abort_list_acl_seg; on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$list_acl_seg); system_area_ptr = get_system_free_area_ (); call hcs_$list_acl (mseg_dir_name, mseg_entryname, system_area_ptr, ring0_acl_ptr, null (), ring0_acl_count, code); if code ^= 0 then call return_from_operation (code); /*** If the ACL term for "*.*.*" has null extended access, we will not return that term to our caller. */ acl_count = ring0_acl_count; /* we'll usually return the entire ACL */ if ring0_acl_count > 0 then if (ring0_acl.entries (ring0_acl_count).access_name = ALL_OTHERS) & (ring0_acl.entries (ring0_acl_count).extended_mode = MSEG_NULL_ACCESS) then acl_count = ring0_acl_count - 1; /*** Copy the ring0 ACL into a general_extended_acl structure as expected by our caller */ on area call return_noalloc_from_operation (); allocate general_extended_acl in (system_area) set (acl_ptr); revert area; general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1; do acl_idx = 1 to acl_count; general_extended_acl.entries (acl_idx) = ring0_acl.entries (acl_idx); end; P_acl_ptr = acl_ptr; /* ... and give it to our caller */ call return_from_operation (0); /* Special processing required upon the completion of a list_acl_seg operation */ return_from_list_acl_seg: procedure (p_code); dcl p_code fixed binary (35) parameter; if ring0_acl_ptr ^= null () then do; free ring0_acl in (system_area); ring0_acl_ptr = null (); end; if (acl_ptr ^= null ()) & (p_code ^= 0) then do; /* we aren't going to return this ACL because of errors */ free general_extended_acl in (system_area); acl_ptr = null (); end; return; end return_from_list_acl_seg; /* Special processing required upon abnormal termination of a list_acl_seg operation */ abort_list_acl_seg: procedure (); if ring0_acl_ptr ^= null () then do; free ring0_acl in (system_area); ring0_acl_ptr = null (); end; if acl_ptr ^= null () then do; free general_extended_acl in (system_area); acl_ptr = null (); end; return; end abort_list_acl_seg; %page; /* List individual ACL entries */ mseg_fs_interface_$list_acl_entries_seg: entry (P_mseg_operation_ptr, P_acl_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$list_acl_entries_seg); /*** Our caller, as opposed to the user's application, is responsible for creating the ACL structure supplied to all mseg_ entrypoints. Therefore, a missing structure or an incorrect version indicates a programming error in our caller. */ acl_ptr = P_acl_ptr; if acl_ptr = null () then call sub_err_ (error_table_$null_info_ptr, operation_name, ACTION_CANT_RESTART, null (), 0, "general_extended_acl_ptr"); if general_extended_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1 then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0, "general_extended_acl.version = ""^a"".", general_extended_acl.version); /*** List the individual ACL entries -- If the caller asks to list the ACL term for "*.*.*" and its extended mode is null, we will claim that "*.*.*" has no ACL term. We do this to hide from our caller the fact that we must always insure that all users have read/write real access to all message segments. */ call hcs_$list_acl (mseg_dir_name, mseg_entryname, null (), (null ()), addr (general_extended_acl.entries), general_extended_acl.count, code); if (code = 0) | (code = error_table_$argerr) then do; /* only if ring 0 actually returned something */ do acl_idx = 1 to general_extended_acl.count; if (general_extended_acl.entries (acl_idx).access_name = ALL_OTHERS) & (general_extended_acl.entries (acl_idx).extended_mode = MSEG_NULL_ACCESS) then do; general_extended_acl.entries (acl_idx).status_code = error_table_$user_not_found; code = error_table_$argerr; end; end; end; call return_from_operation (code); %page; /* Replace the ACL */ mseg_fs_interface_$replace_acl_seg: entry (P_mseg_operation_ptr, P_acl_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$replace_acl_seg); if P_acl_ptr = null () then acl_ptr = addr (EMPTY_ACL); /* we must have an ACL structure for proper operation */ else call validate_acl (); /* insure the caller's ACL is OK */ on area call return_noalloc_from_operation (); call replace_acl_seg (); /* it does the return_from_operation for us */ /* Actually replace the ACL -- This internal procedure is also used by create_seg and delete_acl_entries_seg. */ replace_acl_seg: procedure (); dcl original_acl_ptr pointer; dcl add_all_others_acl bit (1) aligned; /*** Examine the new ACL -- If the new ACL does not contain an entry for "*.*.*", we will supply one with null extended access. We do this to insure that we always have read/write access to all message segments. */ add_all_others_acl = "1"b; /* until proven otherwise */ do acl_idx = 1 to general_extended_acl.count while (add_all_others_acl); if general_extended_acl.entries (acl_idx).access_name = ALL_OTHERS then add_all_others_acl = "0"b; end; if add_all_others_acl then do; system_area_ptr = get_system_free_area_ (); original_acl_ptr = acl_ptr; /* remember where our caller's ACL resides */ acl_ptr = null (); /* for cleanup handler */ operation_specific_return = return_from_replace_acl_seg; operation_specific_abort = abort_replace_acl_seg; acl_count = original_acl_ptr -> general_extended_acl.count + 1; allocate general_extended_acl in (system_area) set (acl_ptr); do acl_idx = 1 to original_acl_ptr -> general_extended_acl.count; general_extended_acl.entries (acl_idx) = original_acl_ptr -> general_extended_acl.entries (acl_idx); end; general_extended_acl.entries (acl_count).access_name = ALL_OTHERS; general_extended_acl.entries (acl_count).mode = RW_ACCESS; general_extended_acl.entries (acl_count).extended_mode = MSEG_NULL_ACCESS; end; /*** Replace the ACL */ call hcs_$replace_acl (mseg_dir_name, mseg_entryname, addr (general_extended_acl.entries), general_extended_acl.count, DONT_ADD_SYSDAEMONS, code); call return_from_operation (code); /* Special processing required upon the completion of a replace_acl_seg operation -- This entrypoint will only be invoked if we created a copy of the caller's ACL with an extra entry for "*.*.*". This entrypoint will copy the per-ACL status codes back into the caller's structure and free the copy. */ return_from_replace_acl_seg: procedure (p_code); dcl p_code fixed binary (35) parameter; do acl_idx = 1 to original_acl_ptr -> general_extended_acl.count; original_acl_ptr -> general_extended_acl.entries (acl_idx).status_code = general_extended_acl.entries (acl_idx).status_code; end; free general_extended_acl in (system_area); acl_ptr = null (); return; end return_from_replace_acl_seg; /* Special processing required upon abnormal termination of a replace_acl_seg operation -- This entrypoint will only be invoked if we created a copy of the caller's ACL which we must now free. */ abort_replace_acl_seg: procedure (); if acl_ptr ^= null () then do; free general_extended_acl in (system_area); acl_ptr = null (); end; return; end abort_replace_acl_seg; end replace_acl_seg; %page; /* Set the safety switch */ mseg_fs_interface_$set_safety_switch_seg: entry (P_mseg_operation_ptr, P_safety_switch, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$set_safety_switch_seg); if code ^= 0 then call return_from_operation (code); if mseg_ptr ^= null () /* use the pointer interface whenever possible */ then call hcs_$set_safety_sw_seg (mseg_ptr, (P_safety_switch), code); else call hcs_$set_safety_sw (mseg_dir_name, mseg_entryname, (P_safety_switch), code); call return_from_operation (code); %page; /* Common initialization for all operations */ setup_operation: procedure (); code = 0; operation_specific_abort = nulle; /* nothing special when we abort or return (yet) */ operation_specific_return = nulle; mseg_operation_ptr = null (); return; end setup_operation; /* Begin the operation -- This procedure isn't part of setup_operation so that we can be certain to have a cleanup handler available at all times that the message segment may be in use. */ begin_operation: procedure (p_mseg_operation_id); dcl p_mseg_operation_id bit (36) aligned parameter; mseg_operation_ptr = P_mseg_operation_ptr; call mseg_utils_$begin_operation (p_mseg_operation_id, mseg_operation_ptr, operation_name, mseg_dir_name, mseg_entryname, mseg_ptr, rqo_detected, code); return; end begin_operation; /* The "null" entry which indicates that there's no special abort/return processing for an operation */ nulle: procedure (); return; end nulle; %page; /* Return after completion of an operation */ return_from_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; if operation_specific_return ^= nulle /* let the operation do anything special */ then call operation_specific_return (p_code); if mseg_operation_ptr ^= null () /* may be invoked before we've called begin_operation */ then call mseg_utils_$finish_operation (mseg_operation_ptr); P_code = p_code; /* set our caller's status code */ go to RETURN_FROM_OPERATION; end return_from_operation; RETURN_FROM_OPERATION: return; /* Return error_table$_noalloc to our caller after an allocation failure */ return_noalloc_from_operation: procedure (); if operation_specific_return ^= nulle /* let the operation do anything special */ then call operation_specific_return (error_table_$noalloc); call mseg_utils_$finish_operation (mseg_operation_ptr); P_code = error_table_$noalloc; /* set our caller's status code */ go to RETURN_FROM_OPERATION; end return_noalloc_from_operation; /* Abort an operation */ operation_was_aborted: procedure (); if operation_specific_abort ^= nulle /* let the operation do anything special */ then call operation_specific_abort (); call mseg_utils_$abort_operation (mseg_operation_ptr); return; end operation_was_aborted; %page; /* Validate the ACL structure -- We force the real modes in the structure to RW_ACCESS as that access is required for proper operation of the primitives. We also verify that the extended modes do not request any unused modes. */ validate_acl: procedure (); dcl found_invalid_mode bit (1) aligned; acl_ptr = P_acl_ptr; /*** Our caller, as opposed to the user's application, is responsible for creating the ACL structure supplied to all mseg_ entrypoints. Therefore, a missing structure or an incorrect version indicates a programming error in our caller. */ if acl_ptr = null () then call sub_err_ (error_table_$null_info_ptr, operation_name, ACTION_CANT_RESTART, null (), 0, "general_extended_acl_ptr"); if general_extended_acl.version ^= GENERAL_EXTENDED_ACL_VERSION_1 then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0, "general_extended_acl.version = ""^a"".", general_extended_acl.version); /* Check for invalid extended modes. The following requirements are enforced: 1. No bits outside of MSEG_FULL_ACCESS may be on. 2. If r permission is given, s permission must be given. 3. If w permission is given, a permission must be given. 4. If u permission is given, a permission must be given. */ found_invalid_mode = "0"b; do acl_idx = 1 to general_extended_acl.count; general_extended_acl.entries (acl_idx).mode = RW_ACCESS; ext_mode = general_extended_acl.entries (acl_idx).extended_mode; if bool (ext_mode, MSEG_FULL_ACCESS, "0010"b) = ""b & ^(((ext_mode & MSEG_R_ACCESS) ^= ""b) & ^((ext_mode & MSEG_S_ACCESS) ^= ""b)) & ^(((ext_mode & MSEG_W_ACCESS) ^= ""b) & ^((ext_mode & MSEG_A_ACCESS) ^= ""b)) & ^(((ext_mode & MSEG_U_ACCESS) ^= ""b) & ^((ext_mode & MSEG_A_ACCESS) ^= ""b)) then general_extended_acl.entries (acl_idx).status_code = 0; else do; if (((ext_mode & MSEG_R_ACCESS) ^= ""b) & ^((ext_mode & MSEG_S_ACCESS) ^= ""b)) then general_extended_acl.entries (acl_idx).status_code = error_table_$bad_mbx_acl_rs; else if (((ext_mode & MSEG_W_ACCESS) ^= ""b) & ^((ext_mode & MSEG_A_ACCESS) ^= ""b)) | (((ext_mode & MSEG_U_ACCESS) ^= ""b) & ^((ext_mode & MSEG_A_ACCESS) ^= ""b)) then general_extended_acl.entries (acl_idx).status_code = error_table_$bad_mbx_acl_awu; else general_extended_acl.entries (acl_idx).status_code = error_table_$bad_acl_mode; found_invalid_mode = "1"b; end; end; if found_invalid_mode /* error_table_$argerr => check the individual status_codes */ then call return_from_operation (error_table_$argerr); return; end validate_acl; /* format: off */ %page; %include mseg_data_; %page; %include mseg_operation; %page; %include mseg_message_info; %page; %include mseg_wakeup_state; %page; %include entry_access_info; %page; %include mseg_operations_; %page; %include acl_structures; %page; %include access_mode_values; %page; %include mseg_access_mode_values; %page; %include create_branch_info; %page; %include sub_err_flags; /* format: on */ end mseg_fs_interface_;  mseg_index_.pl1 07/11/86 0926.0rew 07/11/86 0914.1 123021 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-05-30,Palter), approve(86-02-20,MCR7345), audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092): Verify proper real access to the segment as this particular check can`t be postponed to the access kernel. Without this check, a process whose authorization is greater than the access class of a message segment would take a no_write_permission fault when trying to perform most any operation on the segment. Also set mseg_operation.mseg_(index ptr)_valid to ""b inside mseg_index_$close_seg upon removing the entry from the mseg_table and termination of the segment. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ mseg_index_: procedure; /* Module of the primitive message segment facility which initiates and terminates a message segment in the administrative ring, matching the pointer to the message segment with a unique index which is passed to and from the user ring. */ /* Modified for version 3 message segments by J. Stern, 10/29/74 */ /* Modified by Benson Margulies for conversion to unaligned character strings */ /* Modified 1984-10-11 BIM to stop calling the admin gate. */ /* Modified February 1985 by M. Pandolf to move access checking to kernel. */ /* Modified 1985-04-17, BIM: return pointer for speed. */ /* DECLARATIONS */ /* ------------ */ /* fixed bin */ dcl ( i, mseg_index, /* index to a given message segment (internal) */ a_mseg_index /* used by close */ ) fixed bin aligned; dcl ( a_code, /* error code (argument) */ code init (0), /* error code (internal) */ code2, /* another error code */ error_table_$ai_restricted external, error_table_$bad_subr_arg external, error_table_$dirseg external, error_table_$not_seg_type external, error_table_$notalloc ext, error_table_$segknown ext, error_table_$seg_unknown ext ) fixed bin (35) aligned; /* pointers */ dcl ( a_table_ptr, /* ptr to mseg_ptr array (argument) */ new_table_ptr, /* ptr for re-allocating table */ temp_mseg_ptr, /* pointer to specific message segment */ a_op_ptr ) ptr aligned; dcl area_ptr ptr int static init (null); dcl linker_area area based (area_ptr); /* character strings */ dcl dn char (168); dcl en char (32); /* bit strings */ dcl effective_access bit (36) aligned; dcl sys_info$ring1_privilege ext bit (36) aligned; /* built in functions */ dcl (addr, bit, null) builtin; /* external entries */ dcl admin_gate_$syserr entry (/* fixed binary, character (*) */) options (variable); dcl get_user_free_area_ entry returns (ptr); dcl hcs_$get_access_info_seg entry (ptr, ptr, fixed bin (35)); dcl hcs_$get_user_access_modes_seg entry (ptr, char (*), fixed bin (3), bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname ext entry (ptr aligned, fixed bin (35) aligned); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl sub_err_ entry () options (variable); dcl system_privilege_$initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); /* conditions */ dcl area condition; %page; /**** This entrypoint is called to get a pointer, but not to record in the table of open segments. That recording only happens if the user has access. */ mseg_index_$initiate_seg: entry (a_op_ptr, a_code); mseg_operation_ptr = a_op_ptr; if ^mseg_operation.mseg_pathname_valid then call sub_err_ (error_table_$bad_subr_arg, "mseg_$initiate_seg", ACTION_CANT_RESTART, null (), (0), "The mseg_operation does not include a valid pathname."); dn = mseg_operation.dir_name; en = mseg_operation.entryname; if mseg_operation.caller.privileges & sys_info$ring1_privilege then call system_privilege_$initiate (dn, en, "", 0, 1, temp_mseg_ptr, code2); else call hcs_$initiate (dn, en, "", 0, 1, temp_mseg_ptr, code2); /* initiate message segment */ if temp_mseg_ptr = null then do; /* did not get back a pointer */ if code2 = error_table_$dirseg then code = error_table_$not_seg_type; else code = code2; go to RETURN; end; mseg_operation.mseg_ptr = temp_mseg_ptr; mseg_operation.mseg_ptr_valid = "1"b; if mseg_operation.suppress_access_checks then go to RETURN; /**** We must fetch the segment's access_info here in order to validate that we have RW real effective access to the segment. We can't delay this check to the mseg_check_access_ kernal as there is at least one gate target (mailbox_$accept_wakeups_index) which performs an mseg_ operation before calling mseg_check_access_. Since the mseg_ operation has to lock the segment, if we don't have the proper real access, we would take a fault in ring 1 which isn't very nice. If the user doesn't have RW effective access, we must determine the appropriate error code to return. If the segment's ring brackets are incorrect, we'll return error_table_$not_seg_type. If we lack the needed access due to AIM, we'll return error_table_$ai_restricted. If, however, we lack the access due to an incorrect real mode in the ACL, we enter a SYSERR message and stop the user dead by calling sub_err_. In truth, we would prefer to invoke an ACL salvager in this case but, as one does not exist, we stop our caller as any error code we might return would be misleading. */ call hcs_$get_access_info_seg (temp_mseg_ptr, addr (mseg_operation.access_info), code); if code ^= 0 then do; ACCESS_CHECK_FAILED: call hcs_$terminate_noname (temp_mseg_ptr, (0)); mseg_operation.mseg_ptr_valid = "0"b; /* the pointer's not usefull if the access isn't right */ go to RETURN; end; mseg_operation.access_info_valid = "1"b; if (mseg_operation.access_info.effective_access_modes & RW_ACCESS) ^= RW_ACCESS then do; do i = 1 to 3; /* check that the ring brackets are OK */ if mseg_operation.access_info.ring_brackets (i) ^= mseg_data_$execution_ring then do; code = error_table_$not_seg_type; go to ACCESS_CHECK_FAILED; end; end; call hcs_$get_user_access_modes_seg (temp_mseg_ptr, "" /* ourself */, -1 /* this ring */, effective_access, ((36)"0"b), code); if code ^= 0 then go to ACCESS_CHECK_FAILED; if (effective_access & RW_ACCESS) ^= RW_ACCESS then do; /*** The ACL term by which the user received his access to the segment does not grant RW access. */ if mseg_operation.call_admin_gate then call admin_gate_$syserr ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), "mseg_$initiate_seg: The ACL for ^a is inconsistent -- ^a does not have ""rw"" access.", pathname_ (mseg_operation.access_info.dir_name, mseg_operation.access_info.entryname), mseg_operation.caller.group_id); call sub_err_ (0, "mseg_$initiate_seg", ACTION_CANT_RESTART, null (), 0, "The ACL for ^a is inconsistent -- you do not have ""rw"" access.", pathname_ (mseg_operation.access_info.dir_name, mseg_operation.access_info.entryname)); end; /*** Control arrives here only when the reason we lack proper access is due to AIM as, when AIM was ignored, we had the necessary access. */ code = error_table_$ai_restricted; go to ACCESS_CHECK_FAILED; end; code = 0; /* success */ go to RETURN; %page; /**** This is called only for the real gate open entrypoint to insert the segment in the table. */ mseg_index_$open_seg: entry (a_op_ptr, a_table_ptr, a_code); mseg_operation_ptr = a_op_ptr; table_ptr = a_table_ptr; if ^mseg_operation.mseg_ptr_valid then call sub_err_ (error_table_$bad_subr_arg, "mseg_$open_seg", ACTION_CANT_RESTART, null (), (0), "The mseg_operation does not include a valid mseg_ptr."); on condition (area) begin; code = error_table_$notalloc; go to RETURN; end; if table_ptr = null then do; call allocate_table; a_table_ptr = table_ptr; end; temp_mseg_ptr = mseg_operation.mseg_ptr; /* See if already open */ do mseg_index = 1 to mseg_table.table_length while (mseg_table.mseg_ptr (mseg_index) ^= temp_mseg_ptr); end; if mseg_index <= mseg_table.table_length then go to FOUND_INDEX; /* Find an unused slot in the table */ do mseg_index = 1 to mseg_table.table_length while (mseg_table.mseg_ptr (mseg_index) ^= null); end; if mseg_index > mseg_table.table_length then do; /* table full */ call grow_table; a_table_ptr = table_ptr; end; FOUND_INDEX: mseg_table.mseg_ptr (mseg_index) = temp_mseg_ptr; /* remember pointer */ mseg_table.ref_count (mseg_index) = mseg_table.ref_count (mseg_index) + 1; /* increment reference count */ mseg_operation.mseg_index = mseg_index; mseg_operation.mseg_index_valid = "1"b; go to RETURN; %page; /**** This entrypoint both removes the index from the table and terminates the segment. Since there is a null ref name added per index ref count, we always terminate off a name. For convienience, this will also operate correctly when the index is invalid, indicating that the segment just needs terminating */ mseg_index_$close_seg: entry (a_op_ptr, a_table_ptr, a_code); mseg_operation_ptr = a_op_ptr; code = 0; if mseg_operation.mseg_index_valid then do; mseg_index = mseg_operation.mseg_index; table_ptr = a_table_ptr; if table_ptr = null then do; UNKNOWN: code = error_table_$seg_unknown; go to RETURN; end; if mseg_index < 1 | mseg_index > mseg_table.table_length then go to UNKNOWN; if mseg_table.mseg_ptr (mseg_index) = null then go to UNKNOWN; mseg_table.ref_count (mseg_index) = mseg_table.ref_count (mseg_index) - 1; /* decrement reference count */ if mseg_table.ref_count (mseg_index) = 0 then mseg_table.mseg_ptr (mseg_index) = null; /* remove ptr from table */ mseg_operation.mseg_index_valid = "0"b; end; if mseg_operation.mseg_ptr_valid then do; temp_mseg_ptr = mseg_operation.mseg_ptr; call hcs_$terminate_noname (temp_mseg_ptr, code2); /* terminate the message segment */ mseg_operation.mseg_ptr_valid = "0"b; end; RETURN: a_code = code; /* return error code */ return; %page; mseg_index_$delete: entry (a_op_ptr, a_table_ptr); mseg_operation_ptr = a_op_ptr; if mseg_operation.mseg_ptr_valid then do; temp_mseg_ptr = mseg_operation.mseg_ptr; table_ptr = a_table_ptr; if table_ptr = null then return; do mseg_index = 1 to mseg_table.table_length; if mseg_table.mseg_ptr (mseg_index) = temp_mseg_ptr then do; mseg_table.mseg_ptr (mseg_index) = null (); mseg_table.ref_count (mseg_index) = 0; return; end; end; end; return; %page; allocate_table: proc; /* This internal procedure allocates mseg_table in the ring 1 linker area segment. */ if area_ptr = null () then area_ptr = get_user_free_area_ (); tlength = 100; allocate mseg_table in (linker_area) set (table_ptr); do i = 1 to tlength; mseg_table.mseg_ptr (i) = null; mseg_table.ref_count (i) = 0; end; end allocate_table; grow_table: procedure; /* This internal procedure doubles mseg_table's size, changing table_ptr and setting mseg_index to the next available slot. */ mseg_index = mseg_table.table_length + 1; tlength = mseg_table.table_length * 2; allocate mseg_table in (linker_area) set (new_table_ptr); do i = 1 to mseg_index - 1; new_table_ptr -> mseg_table.mseg_ptr (i) = table_ptr -> mseg_table.mseg_ptr (i); new_table_ptr -> mseg_table.ref_count (i) = table_ptr -> mseg_table.ref_count (i); end; free table_ptr -> mseg_table in (linker_area); table_ptr = new_table_ptr; do i = mseg_index to mseg_table.table_length; mseg_table.mseg_ptr (i) = null; mseg_table.ref_count (i) = 0; end; end grow_table; /* format: off */ %page; %include mseg_index_table; %page; %include mseg_operation; %page; %include mseg_message_info; %page; %include entry_access_info; %page; %include sub_err_flags; %page; %include mseg_wakeup_state; %page; %include syserr_constants; %page; %include access_mode_values; %page; %include mseg_data_; %page; /* BEGIN MESSAGE DOCUMENTATION Message: mseg_$initiate_seg: The ACL for PATH is inconsistent -- USER_ID does not have "rw" access. S: $log T: $run M: $err For proper operation of the message segment primitives, all ACL terms of a message segment or mailbox must specify "rw" access to the segment when running in ring 1. One or more ACL terms for the segment PATH do not provide the required access. USER_ID identifies one of the user whose access to the segment is incorrect. A: $inform END MESSAGE DOCUMENTATION */ /* format: on */ end mseg_index_;  mseg_mbx_ms_gate_target_.pl1 08/06/87 1022.8rew 08/06/87 1020.1 490959 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-05-29,Palter), approve(86-02-20,MCR7345), audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092): Changed to not call mseg_$delete_seg after calling mseg_$close_seg on the target of the copy operation. Said call would cause fatal process errors if the copy operation failed because the user did not have sufficient access to create the target. 2) change(85-06-12,Palter), approve(86-02-20,MCR7345), audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092): Fix the bug in ex_acl_list which would trash the user's area when the mseg's ACL is empty and the user asks to list the entire ACL. 3) change(85-07-19,Palter), approve(86-02-20,MCR7345), audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092): Fix wakeup_add_index and wakeup_aim_add_index to properly censor the results of sending the wakeup and to return the message ID whenever the message is added regardless of the success/failure of sending the wakeup. 4) change(85-07-24,Palter), approve(86-02-20,MCR7345), audit(86-02-21,MSharpe), install(86-07-11,MR12.0-1092): Fix the old style read entrypoints to not change the caller's mseg_return_args structure if an appropriate message is not found. 5) change(86-03-21,MSharpe), approve(86-05-12,MCR7403), audit(86-08-04,Lippard), install(86-08-06,MR12.0-1118): Fixed ms_acl_list entry to return the acl terms for caller-specified user_ids (when area_ptr = null). If the caller has specified a null user_acl_ptr or a user_acl_count < 1, error_table_$argerr is returned. 6) change(86-09-10,Dickson), approve(86-09-10,MCR7480), audit(86-09-12,Lippard), install(86-09-15,MR12.0-1156): Moved some initialization lines to before the clean_up handler is set in the $copy entrypoint so that the variable error_on_target gets set upon an early exit. 7) change(86-09-30,Lippard), approve(86-11-24,MCR7578), audit(87-07-13,Dickson), install(87-08-06,MR12.1-1067): Changed to correctly diagnose entry names without valid suffixes and to use error_table_$bad_file_name instead of $badstar. END HISTORY COMMENTS */ /* format: style3,idind30,linecom */ mseg_mbx_ms_gate_target_: procedure; /* Modified for version 3 message segments by J. Stern, 11/01/74 */ /* Modified to add mbx_wakeup_add_index and mbx_accept_wakeups_index and mbx_set_max_length entries by Steve Herbst on 2/16/76 */ /* Modified 5/77 for the installation of version 4 message segments */ /* MCR 4171 Change default access on new mailboxes 12/14/79 S. Herbst */ /* Modified by Benson Margulies for conversion to unaligned character strings */ /* Modified 4/82 by E. N. Kittlitz to not delete through links */ /* Modified: February 1983 by G. Palter to add validation, copy and compaction entrypoints */ /* Modified: October 1983 by G. Palter to add get_uid_file and get_uid_index entrypoints */ /* Modified: November 1983 by G. Palter to make get_mode_file use hcs_$get_user_access_modes */ /* Modified: 84-05-07 BIM for get_process_access_class_ versus authorization */ /* Modified: August 1984 by G. Palter to fix the following errors from the message segment error list: #0001 -- mailbox_$create and message_segment_$create will add the ring-1 IACL to the ACL of the newly created mailbox/message segment. The entries from the IACL will have null extended access. These gates should ignore the ring-1 IACL; #0003 -- mailbox_$get_uid_file, mailbox_$get_mode_file, mailbox_$set_safety_switch, and mesage_segment_$set_safety_switch do not validate that their target is a mailbox or message segment as appropriate; #0005 -- When given a new ACL count of -1 or zero, mailbox_$mbx_acl_replace and message_segment_$ms_acl_replace will incorrectly attempt to allocate a local copy of the input ACL array using the new ACL count as the size for the array. This attempted allocation causes an area condition and, eventually, a fatal process error; and #0006 -- mailbox_$copy and message_segment_$copy will create the target mailbox/message segment before validating that the user has sufficient access to copy the segment */ /* Modified 1984-10-11 BIM for new entrypoints, V5 */ /* Modified February 1985 by M. Pandolf to add calls to mseg_check_access_ */ /* Modified March 1985 by M. Pandolf to get mseg_ptr as soon as possible due to undependability of pathnames */ /* Modified April 1985 by M. Pandolf to get and hold access information */ /* Modified 1985-04-16, BIM: simplify get_mode, reduce use of validation level setting. MERGE MBX_MSEG_ with QUEUE_MSEG_ */ /****^ Gate target procedure for the mailbox_ and message_segment_ gates. This procedure is responsible for: argument copying access checking except for per-message AIM checks validation level management (for now) BASIC STRATEGY One procedure, "entry_common", is responsible for: copying standard arguments. calling mseg_check_access_ to check access for the operation. setting the validation level down (and suppressing audit). A single entrypoint serves both gates. The callerptr builtin is used to distinguish the calling gate and select accordingly. The entrypoints are classed into four groups: INDEX_ENTRY called with an opening index FILE_ENTRY called with a pathname which is initiated FILE_BRIEF_ENTRY called with a pathname which is passed to mseg_check_access_ and then to mseg_. All neccessary data is returned in the access_info substructure of the mseg_operation structure. FILE_TEMP_ENTRY called with a pathname, only because there is no underlying ring 0 primitive that will accept a pointer. These entries all have windows that allow benign hoaxing. entry_common is called as follows: call entry_common (entry_type, base_operation); entry_common set up the mseg_operation structure and calls mseg_check_access_. After that, the individual entrypoint is on its own. */ declare ( INDEX_ENTRY init (1), FILE_ENTRY init (2), FILE_BRIEF_ENTRY init (3), FILE_TEMP_ENTRY init (4) ) int static fixed bin options (constant); declare SUFFIX (2) char (8) aligned varying init (".mbx", ".ms") int static options (constant); dcl ( a_user_acl_count, /* acl count */ user_acl_count, a_ms_count, /* message count */ ms_count, a_mseg_index, /* message segment index */ i, read_entry_type ) fixed bin; dcl (a_max_length, max_length) fixed bin (19); dcl a_ms_len fixed bin (24); /* bit length of message */ dcl ( a_code, /* error code (argument) */ code, /* error code (internal) */ error_table_$argerr ext, error_table_$noalloc ext, error_table_$no_append ext, error_table_$null_info_ptr ext, error_table_$unimplemented_version ext, error_table_$ai_restricted ext, error_table_$action_not_performed ext, error_table_$bad_file_name ext, error_table_$dirseg ext, error_table_$inconsistent ext, error_table_$invalid_lock_reset ext, error_table_$messages_deferred ext, error_table_$messages_off ext, error_table_$moderr ext, error_table_$no_info ext, error_table_$not_seg_type ext, error_table_$wakeup_denied ext, error_table_$seg_unknown ext ) fixed bin (35); dcl (a_event_channel, user_event_channel, event_message) fixed bin (71); /* float bin */ dcl a_compact_ratio float bin; /* % of garbage in mailbox to force compaction */ /* pointers */ dcl ( a_area_ptr, /* pointer to user area */ area_ptr, a_arg_ptr, /* pointer to argument structure */ arg_ptr, a_user_acl_ptr, /* pointer to acl structures */ user_acl_ptr, a_ms_ptr, /* pointer to message */ internal_acl_ptr, static_table_ptr (2) int static init ((2) null ()) /* ptr to mseg_table */ ) ptr; /* bit strings */ dcl ( error_on_target, copy_entry, /* ON if mailbox copying entrypoint */ a_error_on_target, /* set ON/OFF depending on where copy failed */ file_sw, /* ON if file entry called */ a_ms_wanted, /* which incremental message wanted */ ms_wanted, a_salv_bit, /* salvaged bit */ salv_bit, a_safety_switch, safety_switch, a_turn_off, /* ON if to turn off, salvaged bit */ turn_off, return_count, validation_set ) bit (1) aligned; dcl ( a_dir, /* direction of incremental read */ dir ) bit (2) aligned; dcl ( a_mode aligned, /* extended access mode */ a_sw, /* wakeup control arg */ test_lock_id aligned, /* to test for valid lock id */ sys_info$ring1_privilege aligned external, sys_info$ipc_privilege aligned external ) bit (36); dcl a_uid /* mailbox UID */ bit (36) aligned; dcl ( a_access_class, a_ms_id, /* message uid */ ms_id ) bit (72) aligned; /* character strings */ dcl ( a_dn, /* directory name */ a_en, /* message segment name */ a_target_dn, /* for copying */ a_target_en, /* for copying */ a_new_en, /* for renaming */ a_old_en /* for renaming */ ) char (*); dcl (new_en, old_en) char (32); /* structures */ dcl 1 operation aligned like mseg_operation; dcl 1 target_operation aligned like mseg_operation; /* spare for copy */ declare 1 old_read_flags unaligned, 2 incremental bit (1), 2 incremental_direction bit (2), /* valid if incremental = "1"b */ 2 first_or_last bit (1), /* valid if incremental is "0"b */ 2 own bit (1), 2 delete bit (1), 2 pad bit (30); /* builtins */ dcl (addr, index, length, null, reverse, rtrim, setwordno, string, substr, unspec) builtin; /* conditions */ dcl area condition; dcl cleanup condition; /* area */ dcl system_area area based (get_system_free_area_ ()); dcl user_area area based (area_ptr); /* external entries */ dcl admin_gate_$admin_level_no_fs_audit entry (fixed bin (3) aligned); dcl aim_util_$get_access_class entry (bit (72) aligned) returns (bit (72) aligned); dcl aim_util_$get_privileges entry (bit (72) aligned) returns (bit (36) aligned); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl cu_$caller_ptr entry returns (ptr); dcl get_process_authorization_ entry () returns (bit (72) aligned); dcl get_system_free_area_ ext entry returns (ptr); dcl hcs_$level_get entry returns (fixed binary (3)); dcl hcs_$level_set entry (fixed binary (3)); dcl hcs_$wakeup ext entry (bit (36), fixed bin (71), fixed bin (71), fixed bin (35)); dcl mseg_check_access_$audit_initiate_failure entry (pointer, fixed binary (35)); dcl mseg_check_access_$check ext entry (ptr, fixed bin (35)); dcl mseg_check_access_$segment ext entry (ptr, fixed bin (35)); dcl set_lock_$lock ext entry (bit (36) aligned, fixed bin (17), fixed bin (35)); dcl sub_err_ entry () options (variable); mseg_mbx_ms_gate_target_$validate: entry (a_dn, a_en, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_BRIEF_ENTRY, mseg_access_operations_$read_fs_attr_seg); call RETURN (code); mseg_mbx_ms_gate_target_$create: entry (a_dn, a_en, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_BRIEF_ENTRY, mseg_access_operations_$create_seg); call mseg_$create_seg (addr (operation), null (), code); call RETURN (code); mseg_mbx_ms_gate_target_$delete_mseg: entry (a_dn, a_en, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$delete_seg); file_sw = "0"b; /* no need to clean this up */ call mseg_$delete_seg (addr (operation), static_table_ptr (operation.type), code); /* it removes from the table, etc. */ call RETURN (code); mseg_mbx_ms_gate_target_$copy: entry (a_dn, a_en, a_target_dn, a_target_en, a_error_on_target, a_code); call entry_setup; target_operation = addr (mseg_data_$template_operation) -> mseg_operation; copy_entry = "1"b; /* Set so that when general_clean_up */ /* gets called, error_on_target gets copied */ error_on_target = "0"b; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$copy_seg); error_on_target = "1"b; /* any problem now is with the target */ target_operation.caller = operation.caller; /* copy all fields that apply ... the caller */ target_operation.call_admin_gate = operation.call_admin_gate; /* whether to use multi-class */ target_operation.type = operation.type; /* The type of segment */ target_operation.dir_name = a_target_dn; target_operation.entryname = a_target_en; target_operation.mseg_pathname_valid = "1"b; target_operation.access_operation = mseg_access_operations_$create_seg; call mseg_check_access_$segment (addr (target_operation), code); /* Test those target dir RB's ! */ /* and chase those links */ if code ^= 0 then call RETURN (code); call mseg_$create_seg (addr (target_operation), null (), code); if code ^= 0 then call RETURN (code); call mseg_$initiate_seg (addr (target_operation), code); /* mseg_create_ does not initiate since an empty mseg is EMPTY */ if code ^= 0 then call RETURN (code); call mseg_$copy_seg (addr (operation), addr (target_operation), a_error_on_target, code); call RETURN (code); %page; mseg_mbx_ms_gate_target_$chname: entry (a_dn, a_en, a_old_en, a_new_en, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$modify_fs_attr_seg); old_en = a_old_en; new_en = a_new_en; if old_en ^= "" then do; call check_name (old_en, code); if code ^= 0 then call RETURN (code); end; if new_en ^= "" then do; call check_name (new_en, code); if code ^= 0 then call RETURN (code); end; call mseg_$chname_seg (addr (operation), old_en, new_en, code); call RETURN (code); mseg_mbx_ms_gate_target_$get_uid_file: entry (a_dn, a_en, a_uid, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_BRIEF_ENTRY, mseg_access_operations_$read_fs_attr_seg); a_uid = operation.access_info.uid; /* got the UID */ call RETURN (code); mseg_mbx_ms_gate_target_$get_uid_index: entry (a_mseg_index, a_uid, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$read_fs_attr_seg); a_uid = operation.access_info.uid; /* got the UID */ call RETURN (code); mseg_mbx_ms_gate_target_$set_max_length_file: entry (a_dn, a_en, a_max_length, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$modify_fs_attr_seg); max_length = a_max_length; call mseg_$set_max_length_seg (addr (operation), max_length, code); a_max_length = max_length; call RETURN (code); mseg_mbx_ms_gate_target_$set_safety_switch: entry (a_dn, a_en, a_safety_switch, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$modify_fs_attr_seg); safety_switch = a_safety_switch; call mseg_$set_safety_switch_seg (addr (operation), safety_switch, code); call RETURN (code); mseg_mbx_ms_gate_target_$compact_file: entry (a_dn, a_en, a_compact_ratio, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$compact_seg); compact: call mseg_$compact_seg (addr (operation), a_compact_ratio, code); call RETURN (code); mseg_mbx_ms_gate_target_$compact_index: entry (a_mseg_index, a_compact_ratio, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$compact_seg); go to compact; mseg_mbx_ms_gate_target_$open_if_full: entry (a_dn, a_en, a_salv_bit, a_ms_count, a_mseg_index, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$return_error (FILE_ENTRY, mseg_access_operations_$get_count_seg); /* error codes analyzed here .... */ /**** NOTE If the code is zero, we can return the count and the salv bit and only open if there is a non-zero count. If the code is moderr then we open the mseg and return 0 for the count and salv bit, and error_table_$moderr for the code. If the code is anything else we punt. */ if code ^= 0 & code ^= error_table_$moderr then call RETURN (code); return_count = (code = 0); salv_bit = "0"b; ms_count = 0; if return_count then do; call mseg_$get_salvaged_flag_seg (addr (operation), salv_bit, (0)); a_salv_bit = salv_bit; call mseg_$count_messages (addr (operation), ms_count, (0)); a_ms_count = ms_count; if ms_count = 0 then call RETURN (code); /* which will terminate the mseg */ end; if ^return_count /* we haven't seen any access yet */ then do; operation.access_operation = mseg_access_operations_$open_seg; call mseg_check_access_$segment (addr (operation), code); if code ^= 0 then call RETURN (code); end; call mseg_$open_seg (addr (operation), static_table_ptr (operation.type), code); if code ^= 0 then call RETURN (code); /* no room at the inn, probably */ file_sw = "0"b; /* don't terminate that pointer! */ a_mseg_index = operation.mseg_index; if ^return_count then code = error_table_$moderr; /* no report if the salv bit fails */ call RETURN (code); mseg_mbx_ms_gate_target_$open: entry (a_dn, a_en, a_mseg_index, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$open_seg); call mseg_$open_seg (addr (operation), static_table_ptr (operation.type), code); if code ^= 0 then call RETURN (code); file_sw = "0"b; /* don't terminate that pointer */ a_mseg_index = operation.mseg_index; call RETURN (code); mseg_mbx_ms_gate_target_$close: entry (a_mseg_index, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$close_seg); if (operation.access_info.extended_access_modes & D_MBX_ACCESS) ^= ""b then call mseg_$compact_seg (addr (operation), 0.25e0, (0)); call mseg_$close_seg (addr (operation), static_table_ptr (operation.type), code); call RETURN (code); mseg_mbx_ms_gate_target_$ex_acl_add: entry (a_dn, a_en, a_user_acl_ptr, a_user_acl_count, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_TEMP_ENTRY, mseg_access_operations_$acl_modify_seg); user_acl_ptr = a_user_acl_ptr; user_acl_count = a_user_acl_count; call copy_acl (user_acl_ptr, user_acl_count); call mseg_$add_acl_entries_seg (addr (operation), acl_ptr, code); call RETURN (code); mseg_mbx_ms_gate_target_$ex_acl_delete: entry (a_dn, a_en, a_user_acl_ptr, a_user_acl_count, a_area_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_TEMP_ENTRY, mseg_access_operations_$acl_modify_seg); user_acl_ptr = a_user_acl_ptr; user_acl_count = a_user_acl_count; call copy_acl$$delete (user_acl_ptr, user_acl_count); call mseg_$delete_acl_entries_seg (addr (operation), acl_ptr, code); call RETURN (code); mseg_mbx_ms_gate_target_$ex_acl_list: entry (a_dn, a_en, a_user_acl_ptr, a_user_acl_count, a_area_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_TEMP_ENTRY, mseg_access_operations_$acl_list_seg); user_acl_ptr = a_user_acl_ptr; user_acl_count = a_user_acl_count; area_ptr = a_area_ptr; if area_ptr = null () then do; if (user_acl_ptr = null ()) | (user_acl_count < 1) then call RETURN (error_table_$argerr); call copy_acl (user_acl_ptr, user_acl_count); call mseg_$list_acl_entries_seg (addr (operation), acl_ptr, code); user_acl_ptr -> segment_acl_array = general_extended_acl.entries; end; else do; call mseg_$list_acl_seg (addr (operation), acl_ptr, code); if code ^= 0 then call RETURN (code); acl_count = general_extended_acl.count; on area begin; code = error_table_$noalloc; call RETURN (code); end; allocate segment_acl_array in (user_area) set (user_acl_ptr); revert area; do i = 1 to acl_count; /* PL/I always copies at least 1 even if acl_count = 0 */ user_acl_ptr -> segment_acl_array (i) = general_extended_acl.entries (i); end; a_user_acl_ptr = user_acl_ptr; a_user_acl_count = acl_count; end; call RETURN (code); mseg_mbx_ms_gate_target_$ex_acl_replace: entry (a_dn, a_en, a_user_acl_ptr, a_user_acl_count, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_TEMP_ENTRY, mseg_access_operations_$acl_modify_seg); user_acl_ptr = a_user_acl_ptr; user_acl_count = a_user_acl_count; if user_acl_count > 0 then call copy_acl (user_acl_ptr, user_acl_count); else acl_ptr = null (); call mseg_$replace_acl_seg (addr (operation), acl_ptr, code); if acl_ptr ^= null () then user_acl_ptr -> segment_acl_array (*).status_code = general_extended_acl.entries (*).status_code; call RETURN (code); mseg_mbx_ms_gate_target_$read_index: entry (a_mseg_index, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$read_message); old_read: area_ptr = a_area_ptr; arg_ptr = a_arg_ptr; ms_wanted = a_ms_wanted; ms_id = ""b; string (old_read_flags) = "0"b; old_read_flags.first_or_last = ms_wanted; call read_for_old_entrypoint (ms_id); call RETURN (code); mseg_mbx_ms_gate_target_$delete_index: entry (a_mseg_index, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$delete_message); delete: operation.message_info.ms_id = a_ms_id; operation.message_info_valid = "1"b; call mseg_$delete_message (addr (operation), code); call RETURN (code); mseg_mbx_ms_gate_target_$read_delete_index: entry (a_mseg_index, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$read_delete_message); old_read_delete: area_ptr = a_area_ptr; ms_wanted = a_ms_wanted; arg_ptr = a_arg_ptr; string (old_read_flags) = ""b; ms_id = ""b; old_read_flags.first_or_last = ms_wanted; old_read_flags.delete = "1"b; call read_for_old_entrypoint (ms_id); call RETURN (code); mseg_mbx_ms_gate_target_$admin_add_index: entry (a_mseg_index, a_arg_ptr, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$admin_add_message); /* access check needs message access class */ /* This entry point, available through the privileged gate queue_admin_, adds a message with attributes specified in the mseg_message_info structure. */ admin_add: mseg_message_info_ptr = a_arg_ptr; operation.message_info = mseg_message_info; operation.message_info_valid = "1"b; operation.add_message_info_all_valid = "1"b; /* This makes mseg_ respect all the fields as input */ if operation.message_info.version ^= MSEG_MESSAGE_INFO_V1 then call RETURN (error_table_$unimplemented_version); call mseg_check_access_$segment (addr (operation), code); if code ^= 0 then call RETURN (code); call mseg_$add_message (addr (operation), code); if code = 0 then do; a_ms_id = operation.message_info.ms_id; mseg_message_info = operation.message_info; end; call RETURN (code); mseg_mbx_ms_gate_target_$admin_add_file: entry (a_dn, a_en, a_arg_ptr, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$admin_add_message); /* access check needs message access class */ go to admin_add; mseg_mbx_ms_gate_target_$add_index: entry (a_mseg_index, a_ms_ptr, a_ms_len, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$add_message); operation.message_info.ms_access_class = aim_util_$get_access_class (operation.caller.authorization); add: call mseg_check_access_$segment (addr (operation), code); if code ^= 0 then call RETURN (code); operation.message_info.ms_ptr = a_ms_ptr; operation.message_info.ms_len = a_ms_len; operation.message_info_valid = "1"b; call mseg_$add_message (addr (operation), code); if code ^= 0 then call RETURN (code); a_ms_id = operation.message_info.ms_id; call RETURN (code); /**** WAKEUP entrypoints */ /****^ Error codes returned by these entry point: error_table_$ai_restricted an attempt to write down a message or write a message into an AIM inappropriate mseg. error_table_$action_not_performed normals not accepted, by urgents are. error_table_$no_append insufficient access to add a message. error_table_$wakeup_denied insufficient access to send a wakeup. error_table_$messages_deferred recipient has deferred messages. error_table_$messages_off recipient has not initialized for accepting messages. error_table_$no_info no information can be returned because recipient has higher authorization. */ mseg_mbx_ms_gate_target_$wakeup_add_index: entry (a_mseg_index, a_ms_ptr, a_ms_len, a_sw, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$add_message); operation.message_info.ms_access_class = aim_util_$get_access_class (operation.caller.authorization); operation.message_info_valid = "1"b; call wakeup_add; mseg_mbx_ms_gate_target_$wakeup_aim_add_index: entry (a_mseg_index, a_ms_ptr, a_ms_len, a_sw, a_access_class, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$add_message); operation.message_info.ms_access_class = a_access_class; operation.message_info_valid = "1"b; call wakeup_add; mseg_mbx_ms_gate_target_$wakeup_add_file: entry (a_dn, a_en, a_ms_ptr, a_ms_len, a_sw, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$add_message); operation.message_info.ms_access_class = aim_util_$get_access_class (operation.caller.authorization); operation.message_info_valid = "1"b; call wakeup_add; mseg_mbx_ms_gate_target_$wakeup_aim_add_file: entry (a_dn, a_en, a_ms_ptr, a_ms_len, a_sw, a_access_class, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$add_message); operation.message_info.ms_access_class = a_access_class; operation.message_info_valid = "1"b; call wakeup_add; wakeup_add: procedure (); declare user_accepting bit (1) aligned; declare censor_wakeup_code bit (1) aligned; declare wakeup bit (1) aligned; declare wakeup_code fixed bin (35); dcl 1 switch aligned, /* wakeup control switches */ 2 normal_wakeup bit (1) unaligned, 2 urgent_wakeup bit (1) unaligned, 2 always_add bit (1) unaligned, 2 never_add bit (1) unaligned, 2 pad bit (32) unaligned; operation.message_info.ms_ptr = a_ms_ptr; operation.message_info.ms_len = a_ms_len; unspec (switch) = a_sw; wakeup = switch.normal_wakeup | switch.urgent_wakeup; if wakeup then call investigate_acceptance (user_accepting); else user_accepting = "0"b; if user_accepting then /* implies that wakeup is set */ if aim_check_$greater_or_equal (operation.wakeup_state.access_class, operation.message_info.ms_access_class) /* acceptor is higher than planned access class of message */ then operation.message_info.ms_access_class = operation.wakeup_state.access_class; /* Upgrade, over-riding any user-specified access class */ /**** Now we are ready to check access. The user is requesting that we add a message. 1) Test to see if the message can be added. 2) If it cannot be added, quit. 3) If a wakeup is required, test to see if the wakeup can be sent. 4) If it cannot be sent, and always_add is not enabled, then quit. 5) Add the message. 6) If a wakeup can be sent, send it. */ /**** Has the user "a" access and is the AIM situation plausible ? */ operation.access_operation = mseg_access_operations_$add_message; call mseg_check_access_$check (addr (operation), code); if code ^= 0 then do; if ^switch.never_add then do; /* Never add --> don't do anthing, so we shouldn't audit it. */ call mseg_check_access_$segment (addr (operation), (0)); /* Okay, audit */ end; if code = error_table_$moderr then code = error_table_$no_append; call RETURN (code); /* and punt */ end; /**** Now, can we send a wakeup? */ if wakeup then do; wakeup_code = 0; if switch.normal_wakeup then operation.access_operation = mseg_access_operations_$send_normal_wakeup; else operation.access_operation = mseg_access_operations_$send_urgent_wakeup; /**** This just makes the w/u mode checks. It makes NO aim checks */ if switch.never_add then call mseg_check_access_$check (addr (operation), code); else call mseg_check_access_$segment (addr (operation), code); if code ^= 0 then if switch.always_add then wakeup_code = error_table_$wakeup_denied; else call RETURN (error_table_$wakeup_denied); /**** If the user lacks w/u, that lack governs the error code, as calculated above. If the user has w/u, then the user is entitled to hear that there is noone accepting by getting messages_off. */ if ^user_accepting & wakeup_code = 0 then if switch.always_add then wakeup_code = error_table_$messages_off; else call RETURN (error_table_$messages_off); /**** Now we have a little problem. We cannot tell if we will succeed at sending a wakeup on AIM grounds, since it will depend on the receiver's privilege situation. (and, or course, that cannot be investigated via admin gate, and could change at any time.) So we pretend that receiver IPC privilege don't exist, and demand either that we have ipc priv, that no priv is needed, or that always_add be on. This check does NOT audit. Turning off always add means "if I could send without an AIM error, send. If you cannot tell me that, then don't send and return ai_restricted" Note that if always_add is on, and we DO call hcs_$wakeup, it might return 0 due to target IPC priv. */ if user_accepting & ^switch.always_add then if ((operation.caller.privileges & sys_info$ipc_privilege) = ""b) then if ^aim_check_$greater_or_equal (operation.wakeup_state.access_class, operation.caller.authorization) then call RETURN (error_table_$ai_restricted); /**** From now on, if the acceptor is aim-greater than us, we censor all results to no-info. Why isn't this in the access kernel? Because it's just too hard to arrange. */ if user_accepting then censor_wakeup_code = ((operation.caller.privileges & sys_info$ring1_privilege) = ""b) & aim_check_$greater (operation.wakeup_state.access_class, operation.caller.authorization); else censor_wakeup_code = "0"b; /**** Okay, now we have passed the per-se access control checks. Now we see if the acceptor of messages is willing to accept a message from this process. */ if wakeup_code = 0 & user_accepting then do; if (switch.urgent_wakeup & ^operation.wakeup_state.accepting_urgent_wakeups) then if switch.always_add then wakeup_code = error_table_$messages_deferred; else call WAKEUP_RETURN (error_table_$messages_deferred); if (switch.normal_wakeup & ^operation.wakeup_state.accepting_normal_wakeups) then do; if operation.wakeup_state.accepting_urgent_wakeups then wakeup_code = error_table_$action_not_performed; else wakeup_code = error_table_$messages_deferred; if ^switch.always_add then call WAKEUP_RETURN (wakeup_code); end; end; end; /**** Okay, we are ready to actually do something. If we cannot send the wakeup, wakeup_code has the reason why, subject to censorship */ if switch.never_add then do; operation.message_info.ms_id = ""b; code = 0; end; else do; /* add message */ operation.access_operation = mseg_access_operations_$add_message; call mseg_check_access_$segment (addr (operation), (0)); /* audit the add now */ call mseg_$add_message (addr (operation), code); /* send wakeup */ if wakeup & code = 0 & wakeup_code = 0 & user_accepting then do; unspec (event_message) = operation.message_info.ms_id; call hcs_$wakeup ((operation.wakeup_state.process_id), operation.wakeup_state.event_channel, event_message, wakeup_code); if wakeup_code ^= 0 & wakeup_code ^= error_table_$wakeup_denied then wakeup_code = error_table_$messages_off; end; end; if code = 0 then do; /* the message was added */ a_ms_id = operation.message_info.ms_id; if wakeup then call WAKEUP_RETURN (wakeup_code); /* ... tell the caller what happened to the wakeup (maybe) */ else call RETURN (0); end; else call RETURN (code); investigate_acceptance: procedure (accepting); declare accepting bit (1) aligned; accepting = "0"b; /* until proven otherwise */ call mseg_$get_wakeup_state_seg (addr (operation), code); if (code ^= 0) & (code ^= error_table_$messages_off) then call RETURN (code); /* message segment kaboom */ if code = 0 then do; test_lock_id = operation.wakeup_state.lock_id; call set_lock_$lock (test_lock_id, 0, code); if code = 0 | code = error_table_$invalid_lock_reset then code = error_table_$messages_off; else code = 0; end; if code = 0 then do; accepting = "1"b; operation.wakeup_state_valid = "1"b; /* used inside check-access later */ end; return; end investigate_acceptance; WAKEUP_RETURN: procedure (w_code); declare w_code fixed bin (35); if censor_wakeup_code then call RETURN (error_table_$no_info); else call RETURN (w_code); end WAKEUP_RETURN; end wakeup_add; mseg_mbx_ms_gate_target_$accept_wakeups_index: entry (a_mseg_index, a_event_channel, a_sw, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (INDEX_ENTRY, mseg_access_operations_$accept_wakeups_seg); /* access check requires the segment's wakeup state */ call accept_wakeups; call RETURN (code); accept_wakeups: procedure (); dcl 1 switch aligned, /* wakeup control switches */ 2 normal_wakeup bit (1) unaligned, 2 urgent_wakeup bit (1) unaligned; user_event_channel = a_event_channel; unspec (switch) = substr(a_sw,1,length(unspec(switch))); call mseg_$get_wakeup_state_seg (addr (operation), code); if (code ^= 0) & (code ^= error_table_$messages_off) then return; operation.wakeup_state_valid = (code = 0); call mseg_check_access_$segment (addr (operation), code); if code ^= 0 then return; operation.wakeup_state.accepting_normal_wakeups = switch.normal_wakeup; operation.wakeup_state.accepting_urgent_wakeups = switch.urgent_wakeup; operation.wakeup_state.event_channel = user_event_channel; operation.wakeup_state_valid = "1"b; call mseg_$set_wakeup_state_seg (addr (operation), code); return; end accept_wakeups; mseg_mbx_ms_gate_target_$incremental_read_index: entry (a_mseg_index, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$read_message); old_incremental_read: area_ptr = a_area_ptr; dir = a_dir; ms_id = a_ms_id; arg_ptr = a_arg_ptr; string (old_read_flags) = ""b; old_read_flags.incremental = "1"b; old_read_flags.incremental_direction = dir; call read_for_old_entrypoint (ms_id); call RETURN (code); mseg_mbx_ms_gate_target_$get_message_count_index: entry (a_mseg_index, a_ms_count, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$get_count_seg); get_message_count: call mseg_$count_messages (addr (operation), ms_count, code); a_ms_count = ms_count; call RETURN (code); mseg_mbx_ms_gate_target_$get_mode_index: entry (a_mseg_index, a_mode, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$read_fs_attr_seg); get_mode: a_mode = operation.access_info.extended_access_modes; call RETURN (code); mseg_mbx_ms_gate_target_$check_salv_bit_index: entry (a_mseg_index, a_turn_off, a_salv_bit, a_code); call entry_setup; on cleanup call general_clean_up; turn_off = a_turn_off; if ^turn_off then call entry_common (INDEX_ENTRY, mseg_access_operations_$read_attr_seg); else call entry_common (INDEX_ENTRY, mseg_access_operations_$reset_salvage_bit_seg); check_salv_bit: call mseg_$get_salvaged_flag_seg (addr (operation), salv_bit, code); if code ^= 0 then call RETURN (code); if turn_off then call mseg_$reset_salvaged_flag_seg (addr (operation), code); a_salv_bit = salv_bit; call RETURN (code); mseg_mbx_ms_gate_target_$update_message_index: entry (a_mseg_index, a_ms_len, a_ms_id, a_ms_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$update_message); update_message: operation.message_info.ms_len = a_ms_len; operation.message_info.ms_id = a_ms_id; operation.message_info.ms_ptr = a_ms_ptr; operation.message_info_valid = "1"b; call mseg_$update_message (addr (operation), code); call RETURN (code); mseg_mbx_ms_gate_target_$read_file: entry (a_dn, a_en, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$read_message); go to old_read; mseg_mbx_ms_gate_target_$delete_file: entry (a_dn, a_en, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$delete_message); go to delete; mseg_mbx_ms_gate_target_$read_delete_file: entry (a_dn, a_en, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$read_delete_message); go to old_read_delete; mseg_mbx_ms_gate_target_$add_file: entry (a_dn, a_en, a_ms_ptr, a_ms_len, a_ms_id, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$add_message); operation.message_info.ms_access_class = aim_util_$get_access_class (operation.caller.authorization); go to add; mseg_mbx_ms_gate_target_$accept_wakeups_file: entry (a_dn, a_en, a_event_channel, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common$$no_access_check (FILE_ENTRY, mseg_access_operations_$accept_wakeups_seg); /* access check requires segment's wakeup state */ call accept_wakeups; call RETURN (code); mseg_mbx_ms_gate_target_$incremental_read_file: entry (a_dn, a_en, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$read_message); go to old_incremental_read; mseg_mbx_ms_gate_target_$get_message_count_file: entry (a_dn, a_en, a_ms_count, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$get_count_seg); go to get_message_count; mseg_mbx_ms_gate_target_$get_mode_file: entry (a_dn, a_en, a_mode, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_BRIEF_ENTRY, mseg_access_operations_$read_fs_attr_seg); go to get_mode; mseg_mbx_ms_gate_target_$check_salv_bit_file: entry (a_dn, a_en, a_turn_off, a_salv_bit, a_code); turn_off = a_turn_off; call entry_setup; on cleanup call general_clean_up; if ^turn_off then call entry_common (FILE_ENTRY, mseg_access_operations_$read_attr_seg); else call entry_common (FILE_ENTRY, mseg_access_operations_$reset_salvage_bit_seg); go to check_salv_bit; mseg_mbx_ms_gate_target_$update_message_file: entry (a_dn, a_en, a_ms_len, a_ms_id, a_ms_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$update_message); go to update_message; mseg_mbx_ms_gate_target_$o_read_index: entry (a_mseg_index, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$read_own_message); old_o_read: area_ptr = a_area_ptr; ms_wanted = a_ms_wanted; arg_ptr = a_arg_ptr; string (old_read_flags) = ""b; old_read_flags.first_or_last = ms_wanted; old_read_flags.own = "1"b; ms_id = ""b; call read_for_old_entrypoint (ms_id); call RETURN (code); mseg_mbx_ms_gate_target_$o_incremental_read_index: entry (a_mseg_index, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (INDEX_ENTRY, mseg_access_operations_$read_own_message); old_o_incremental_read: area_ptr = a_area_ptr; dir = a_dir; ms_id = a_ms_id; arg_ptr = a_arg_ptr; string (old_read_flags) = ""b; old_read_flags.incremental = "1"b; old_read_flags.incremental_direction = dir; old_read_flags.own = "1"b; call read_for_old_entrypoint (ms_id); call RETURN (code); mseg_mbx_ms_gate_target_$o_read_file: entry (a_dn, a_en, a_area_ptr, a_ms_wanted, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$read_own_message); go to old_o_read; mseg_mbx_ms_gate_target_$o_incremental_read_file: entry (a_dn, a_en, a_area_ptr, a_dir, a_ms_id, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; call entry_common (FILE_ENTRY, mseg_access_operations_$read_own_message); go to old_o_incremental_read; mseg_mbx_ms_gate_target_$general_read_index: entry (a_mseg_index, a_area_ptr, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; read_entry_type = INDEX_ENTRY; read: area_ptr = a_area_ptr; mseg_message_info_ptr = a_arg_ptr; operation.message_info = mseg_message_info; if operation.message_info.version ^= MSEG_MESSAGE_INFO_V1 then do; code = error_table_$unimplemented_version; call RETURN (code); end; if operation.message_info.delete & operation.message_info.own then call entry_common (read_entry_type, mseg_access_operations_$read_delete_own_message); else if operation.message_info.delete then call entry_common (read_entry_type, mseg_access_operations_$read_delete_message); else if operation.message_info.own then call entry_common (read_entry_type, mseg_access_operations_$read_own_message); else call entry_common (read_entry_type, mseg_access_operations_$read_message); operation.message_info_valid = "1"b; call mseg_$read_message (addr (operation), area_ptr, code); mseg_message_info = operation.message_info; call RETURN (code); mseg_mbx_ms_gate_target_$general_read_file: entry (a_dn, a_en, a_area_ptr, a_arg_ptr, a_code); call entry_setup; on cleanup call general_clean_up; read_entry_type = FILE_ENTRY; go to read; check_name: proc (entryname, code); dcl entryname char (32); dcl code fixed bin (35); dcl slength fixed bin; dcl sindex fixed bin; code = 0; slength = length (rtrim (entryname)); sindex = index (reverse (rtrim (entryname)), "."); if sindex ^= 0 then if substr (entryname, slength - sindex + 1) = SUFFIX (operation.type) then; else code = error_table_$bad_file_name; else code = error_table_$bad_file_name; return; end check_name; copy_acl: proc (p_acl_ptr, p_acl_count); dcl p_acl_ptr ptr; dcl p_acl_count fixed bin; if p_acl_count = 0 | p_acl_ptr = null () then do; acl_count = 0; acl_ptr = null (); end; acl_count = p_acl_count; allocate general_extended_acl set (internal_acl_ptr); acl_ptr = internal_acl_ptr; general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1; general_extended_acl.entries = p_acl_ptr -> segment_acl_array; return; copy_acl$$delete: entry (p_acl_ptr, p_acl_count); if p_acl_ptr = null () | p_acl_count = 0 then call RETURN (error_table_$null_info_ptr); if p_acl_count = -1 then do; acl_ptr, internal_acl_ptr = null (); /* null to the primitive means "delete all" */ acl_count = 0; /* never looked at */ return; end; acl_count = p_acl_count; allocate general_delete_acl set (internal_acl_ptr); acl_ptr = internal_acl_ptr; general_delete_acl.version = GENERAL_DELETE_ACL_VERSION_1; general_delete_acl.entries = p_acl_ptr -> delete_acl_array; return; end copy_acl; free: procedure; if internal_acl_ptr ^= null then free internal_acl_ptr -> general_extended_acl in (system_area); return; end free; set_admin_level: procedure; validation_set = "1"b; if operation.call_admin_gate then call admin_gate_$admin_level_no_fs_audit ((0)); /* we already stored the caller level */ else call hcs_$level_set (mseg_data_$execution_ring); return; end set_admin_level; reset_admin_level: procedure; if validation_set then call hcs_$level_set (operation.caller.validation_level); validation_set = "0"b; return; end reset_admin_level; general_clean_up: procedure; if file_sw then call mseg_$close_seg (addr (operation), table_ptr, (0)); if copy_entry then call clean_up_copy; if internal_acl_ptr ^= null () then do; if general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1 then user_acl_ptr -> segment_acl_array (*).status_code = general_extended_acl.entries (*).status_code; else if general_delete_acl.version = GENERAL_DELETE_ACL_VERSION_1 then user_acl_ptr -> delete_acl_array (*).status_code = general_delete_acl.entries (*).status_code; call free; end; call reset_admin_level (); clean_up_copy: procedure; call mseg_$close_seg (addr (target_operation), table_ptr, (0)); a_error_on_target = error_on_target; return; end clean_up_copy; end general_clean_up; RETURN_: call general_clean_up; if code = error_table_$dirseg then code = error_table_$not_seg_type; a_code = code; return; EARLY_RETURN: if code = error_table_$dirseg then code = error_table_$not_seg_type; a_code = code; return; read_for_old_entrypoint: procedure (a_ms_id); declare 1 mra aligned like mseg_return_args; declare a_ms_id bit (72) aligned; operation.message_info.ms_id = a_ms_id; if ^old_read_flags.incremental then do; if old_read_flags.first_or_last then operation.message_info.message_code = MSEG_READ_LAST; else operation.message_info.message_code = MSEG_READ_FIRST; end; else if old_read_flags.incremental_direction = "00"b then operation.message_info.message_code = MSEG_READ_SPECIFIED; else if old_read_flags.incremental_direction = "10"b then operation.message_info.message_code = MSEG_READ_BEFORE_SPECIFIED; else if old_read_flags.incremental_direction = "01"b then operation.message_info.message_code = MSEG_READ_AFTER_SPECIFIED; else call RETURN (error_table_$inconsistent); /* incr with bad direction */ operation.message_info.own = old_read_flags.own; operation.message_info.delete = old_read_flags.delete; operation.message_info_valid = "1"b; call mseg_$read_message (addr (operation), area_ptr, code); if code = 0 then do; mra.ms_ptr = operation.message_info.ms_ptr; mra.ms_len = operation.message_info.ms_len; mra.sender_id = operation.message_info.sender_id; mra.level = operation.message_info.sender_level; mra.ms_id = operation.message_info.ms_id; mra.sender_authorization = operation.message_info.sender_authorization; mra.access_class = operation.message_info.ms_access_class; arg_ptr -> mseg_return_args = mra; end; return; end read_for_old_entrypoint; entry_setup: procedure; declare ( message_segment_$, mailbox_$, queue_admin_$ ) bit (36) aligned ext static; operation = addr (mseg_data_$template_operation) -> mseg_operation; /**** Callers may not have access to queue_admin_, so the following avoids touching it unneccessarily. */ if setwordno (cu_$caller_ptr (), 0) = addr (mailbox_$) then operation.type = MSEG_TYPE_MBX; else if setwordno (cu_$caller_ptr (), 0) = addr (message_segment_$) then operation.type = MSEG_TYPE_MS; else if setwordno (cu_$caller_ptr (), 0) = addr (queue_admin_$) then operation.type = MSEG_TYPE_MS; else call sub_err_ (0, "mseg_mbx_ms_gate_target_", ACTION_CANT_RESTART, null (), (0), "Caller was not mailbox_, message_segment_, or queue_admin_"); operation.caller.validation_level = hcs_$level_get (); operation.caller.authorization = get_process_authorization_ (); operation.caller.max_authorization = mseg_data_$process_max_authorization; operation.caller.privileges = substr(aim_util_$get_privileges (operation.caller.authorization),1,length(operation.caller.privileges)); operation.caller.group_id = mseg_data_$group_id; validation_set = "0"b; /* no need to reset the level */ operation.call_admin_gate = (mseg_data_$execution_ring = mseg_data_$admin_ring); copy_entry = "0"b; internal_acl_ptr = null (); file_sw = "0"b; return; end entry_setup; entry_common: procedure (entry_type, base_operation); declare entry_type fixed bin; declare base_operation fixed bin; declare (return_code, dont_call_mca) bit (1) aligned; dont_call_mca = "0"b; return_code = "0"b; go to COMMON; entry_common$$no_access_check: entry (entry_type, base_operation); dont_call_mca = "1"b; return_code = "0"b; /* not that it will ever be used */ go to COMMON; entry_common$$return_error: entry (entry_type, base_operation); dont_call_mca = "0"b; return_code = "1"b; COMMON: operation.access_operation = base_operation; /**** This next line sets the validation level to the ring of execution. If the ring of execution is 1, it also suppresses ring zero file system auditing. It would be better coding practice to reduce the scope of this to the minimum neccessary. However, this entire subsystem would need to be restructured to support that. */ call set_admin_level (); if entry_type = INDEX_ENTRY then call index_setup; else if entry_type = FILE_ENTRY then call file_setup; else if entry_type = FILE_BRIEF_ENTRY then call file_brief_setup; else if entry_type = FILE_TEMP_ENTRY then call file_temp_setup; if dont_call_mca /* caller isn't ready for mseg_check_access_ yet */ then return; call mseg_check_access_$segment (addr (operation), code); if code ^= 0 then if return_code then return; else call RETURN (code); return; index_setup: procedure (); operation.mseg_index = a_mseg_index; /* copy the parameter, all such gates have it */ table_ptr = static_table_ptr (operation.type); if table_ptr = null () then call RETURN (error_table_$seg_unknown); if operation.mseg_index < 1 | operation.mseg_index > mseg_table.table_length then call RETURN (error_table_$seg_unknown); operation.mseg_ptr = mseg_table.mseg_ptr (operation.mseg_index); if operation.mseg_ptr = null () then call RETURN (error_table_$seg_unknown); operation.mseg_ptr_valid = "1"b; operation.mseg_index_valid = "1"b; return; end index_setup; file_setup: procedure (); file_sw = "1"b; operation.dir_name = a_dn; /* copy the parameters */ operation.entryname = a_en; operation.mseg_pathname_valid = "1"b; call check_name (operation.entryname, code); if code ^= 0 then call RETURN (code); call mseg_$initiate_seg (addr (operation), code); if code ^= 0 then do; call mseg_check_access_$audit_initiate_failure (addr (operation), code); call RETURN (code); /* must be sure to audit failure and censor code if needed */ end; return; end file_setup; file_brief_setup: procedure (); operation.dir_name = a_dn; /* copy the parameters */ operation.entryname = a_en; operation.mseg_pathname_valid = "1"b; call check_name (operation.entryname, code); if code ^= 0 then call RETURN (code); return; end file_brief_setup; file_temp_setup: procedure (); operation.dir_name = a_dn; /* copy the parameters */ operation.entryname = a_en; operation.mseg_pathname_valid = "1"b; call check_name (operation.entryname, code); if code ^= 0 then call RETURN (code); return; end file_temp_setup; end entry_common; RETURN: procedure (return_error_code); declare return_error_code fixed bin (35); code = return_error_code; go to RETURN_; end RETURN; /* format: off */ %page; %include mseg_data_; %page; %include mseg_return_args; %page; %include mseg_message_info; %page; %include mseg_operation; %page; %include mseg_wakeup_state; %page; %include entry_access_info; %page; %include mseg_access_operations_; %page; %include mlsys_mailbox_modes; %page; %include mseg_index_table; %page; %include sub_err_flags; %page; %include mseg_entries; %page; %include acl_structures; end mseg_mbx_ms_gate_target_;  mseg_message_.pl1 08/06/87 1022.8rew 08/06/87 1019.6 396045 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-04-01,Palter), approve(), audit(), install(): Pre-hcom comments. Created: April 1985 by G. Palter based upon mseg_, mseg_add_, and mseg_util_ 2) change(86-09-30,Lippard), approve(86-11-24,MCR7578), audit(87-07-13,Dickson), install(87-08-06,MR12.1-1067): Modified to always give new message IDs. END HISTORY COMMENTS */ /* Message segment primitive operations (mseg_) which manipulate the individual messages within the segment */ /* format: style3,linecom */ mseg_message_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_mseg_operation_ptr /* -> description of this operation (I) */ pointer parameter; dcl P_code fixed binary (35) parameter; dcl P_operation_name character (*) parameter; /* *_for_mseg: the actual operation performing this act (I) */ dcl P_ms_count fixed binary parameter; /* count_messages: set to # of accessible messages (O) */ dcl P_users_area_ptr pointer parameter; /* read_message*: -> area in which to allocate message (I) */ /* Local copies of parameters */ dcl users_area area based (users_area_ptr); dcl users_area_ptr pointer; dcl code fixed binary (35); /* Remaining declarations */ dcl 1 local_md aligned like message_descriptor; dcl 1 mseg_message_bits aligned based (mseg_message_info.ms_ptr), 2 data bit (mseg_message_info.ms_len) unaligned; dcl 1 local_aef aligned like audit_event_flags; dcl local_message_block (32) bit (36) aligned; dcl operation_specific_return entry (fixed binary (35)) variable; dcl operation_specific_abort entry () variable; dcl operation_name character (64); dcl operation_started_locally bit (1) aligned; dcl mseg_dir_name character (168); dcl mseg_entryname character (32); dcl (first_mb_ptr, prev_mb_ptr, next_mb_ptr) pointer; dcl (prev_md_ptr, next_md_ptr) pointer; dcl next_message_in_hash_chain pointer; dcl rqo_detected bit (1) aligned; dcl do_owner_check bit (1) aligned; dcl now fixed binary (71); dcl (n_bits_remaining, n_bits_copied, n_bits_to_copy) fixed binary (24); dcl message_offset fixed binary (18) unaligned unsigned; dcl (n_blocks_needed, block_no, block_id, last_block_allocated) fixed binary (18); dcl hash_idx fixed binary (9); dcl ( error_table_$bad_segment, error_table_$bad_subr_arg, error_table_$bigarg, error_table_$noalloc, error_table_$notalloc, error_table_$no_message, error_table_$null_info_ptr, error_table_$rqover, error_table_$smallarg, error_table_$unimplemented_version ) fixed binary (35) external; dcl access_operations_$mseg_add_message bit (36) aligned external; dcl sys_info$ring1_privilege bit (36) aligned external; dcl access_audit_r1_$get_audit_flags entry () returns (bit (36) aligned); dcl access_audit_r1_$log_obj_ptr entry () options (variable); dcl get_process_id_ entry () returns (bit (36)); dcl mseg_check_access_$message entry (pointer, fixed binary (35)); dcl mseg_utils_$abort_operation entry (pointer); dcl mseg_utils_$begin_operation entry (bit (36) aligned, pointer, character (*), character (*), character (*), pointer, bit (1) aligned, fixed binary (35)); dcl mseg_utils_$finish_operation entry (pointer); dcl mseg_utils_$salvage_for_cause entry (pointer, fixed binary (35)) options (variable); dcl read_allowed_ entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl (addr, after, before, clock, currentsize, divide, fixed, index, length, min, mod, null, rtrim, setwordno, string, substr, unspec, wordno) builtin; dcl (area, cleanup) condition; %page; /* Add a message */ mseg_message_$add_message: entry (P_mseg_operation_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$add_message); if rqo_detected then call return_from_operation (error_table_$rqover); else if code ^= 0 then call return_from_operation (code); ADD_MESSAGE: mseg_message_info_ptr = addr (mseg_operation.message_info); if (mseg_message_info.ms_ptr = null ()) & (mseg_message_info.ms_len ^= 0) then call return_from_operation (error_table_$null_info_ptr); else if mseg_message_info.ms_len < 0 then call return_from_operation (error_table_$smallarg); else if mseg_message_info.ms_len > (36 * mseg_data_$max_message_size) then call return_from_operation (error_table_$bigarg); /*** Set that portion of the message descriptor which we already know */ unspec (local_md) = ""b; if mseg_operation.add_message_info_all_valid then do; /*** Admin Add -- Caller has supplied the message and all required data about its sender */ local_md = mseg_message_info, by name; if rtrim (operation_name) = "mseg_$add_message" then local_md.ms_id = ""b; end; else do; /*** Ordinary Add -- Caller has supplied only ms_ptr, ms_len, and ms_access_class */ local_md.ms_id = ""b; /* generate one presently */ local_md.ms_len = mseg_message_info.ms_len; local_md.ms_access_class = mseg_message_info.ms_access_class; local_md.sender_id = mseg_operation.group_id; local_md.sender_process_id = get_process_id_ (); local_md.sender_level = mseg_operation.validation_level; local_md.sender_authorization = mseg_operation.authorization; local_md.sender_max_authorization = mseg_operation.max_authorization; if mseg_operation.call_admin_gate then local_md.sender_audit = access_audit_r1_$get_audit_flags (); else local_md.sender_audit = ""b; end; if local_md.ms_id = ""b /* we must generate a message ID */ then do; now = clock (); /* ... IDs for now are simply clock readings */ local_md.ms_id = unspec (now); end; /*** Compute the number of blocks needed to hold the message */ mb_ptr = addr (local_message_block); /* to allow PL/I to compute block sizes for us */ md_ptr = addr (local_md); message_block_header.data_lth = 0; n_blocks_needed = 1 /* ... the first block which includes the descriptor */ + divide ((local_md.ms_len - length (first_message_block.pad) + length (other_message_block.pad) - 1), length (other_message_block.pad), 18, 0); if n_blocks_needed > mseg_segment.n_blocks_unused then do; /* not enough room in the segment */ call check_block_map_consistency (); /* ... be sure the segment's not damanged */ if mseg_operation.call_admin_gate & ^mseg_operation.suppress_access_checks then do; /* ... audit the covert channel */ string (local_aef) = ""b; local_aef.cc_10_100 = "1"b; call access_audit_r1_$log_obj_ptr (operation_name, mseg_operation.validation_level, string (local_aef), access_operations_$mseg_add_message, mseg_ptr, error_table_$notalloc, null (), 0, "Message segment is full."); end; call return_from_operation (error_table_$notalloc); end; mseg_segment.modification_in_progress = "1"b; /* a fault now will cause the segment to be salvaged */ /*** Pre-allocate the blocks for the message and thread them together */ last_block_allocated = 0; do block_no = 1 to n_blocks_needed; begin; dcl rest_of_block_map bit (mseg_segment.n_blocks_allocated - last_block_allocated) unaligned defined (mseg_segment.block_map.map) position (last_block_allocated + 1); block_id = index (rest_of_block_map, "0"b); if block_id = 0 /* ... not as many free blocks as the header claimed */ then call salvage_and_return (mseg_format_errors_$inconsistent_block_map); block_id, last_block_allocated = block_id + last_block_allocated; end; substr (mseg_segment.block_map.map, block_id, 1) = "1"b; mb_ptr = setwordno (mseg_ptr, mseg_segment.block_size * (block_id - 1)); if block_no = 1 then do; /* first block of the message */ first_mb_ptr = mb_ptr; message_block_header.descriptor_present = "1"b; md_ptr = addr (first_message_block.descriptor); end; else prev_mb_ptr -> message_block_header.next_block = wordno (mb_ptr); prev_mb_ptr = mb_ptr; end; message_block_header.next_block = 0; /* indicate end of chain for the last block */ /*** Fill in the real message descriptor in the first block */ message_descriptor = local_md; /* copy info we've already gathered */ message_descriptor.sentinel = MESSAGE_DESCRIPTOR_SENTINEL; message_descriptor.message_chain.next_message = 0;/* this will be the last message in the segment */ message_descriptor.message_chain.prev_message = mseg_segment.message_chain.last_message; hash_idx = fixed (substr (local_md.ms_id, 64, 9), 9, 0); message_descriptor.prev_message_in_hash_chain = mseg_segment.hash_table.last_message (hash_idx); /*** Copy the user's message into the segment */ n_bits_remaining = mseg_message_info.ms_len; /* haven't copied anything yet */ n_bits_copied = 0; mb_ptr = first_mb_ptr; do block_no = 1 to n_blocks_needed; message_block_header.data_lth = 0; /* allows PL/I to compute # of bits available in the block */ if block_no = 1 then n_bits_to_copy = min (n_bits_remaining, length (first_message_block.pad)); else n_bits_to_copy = min (n_bits_remaining, length (other_message_block.pad)); message_block_header.data_lth = n_bits_to_copy; if n_bits_to_copy > 0 /* there's something to put in this block */ then begin; dcl source_bits bit (n_bits_to_copy) unaligned defined (mseg_message_bits.data) position (n_bits_copied + 1); if block_no = 1 then first_message_block.data = source_bits; else other_message_block.data = source_bits; n_bits_remaining = n_bits_remaining - n_bits_to_copy; n_bits_copied = n_bits_copied + n_bits_to_copy; end; mb_ptr = setwordno (mseg_ptr, message_block_header.next_block); end; /*** Thread the message into the appropriate chains */ if mseg_segment.n_messages = 0 /* it's the first message */ then mseg_segment.message_chain.first_message = wordno (first_mb_ptr); else do; /* it's not the first message */ call set_message_ptrs (mseg_segment.message_chain.last_message, prev_mb_ptr, prev_md_ptr); prev_md_ptr -> message_descriptor.message_chain.next_message = wordno (first_mb_ptr); end; mseg_segment.message_chain.last_message = wordno (first_mb_ptr); mseg_segment.hash_table.last_message (hash_idx) = wordno (first_mb_ptr); mseg_segment.n_blocks_unused = mseg_segment.n_blocks_unused - n_blocks_needed; mseg_segment.n_messages = mseg_segment.n_messages + 1; mseg_segment.modification_in_progress = "0"b; /* all done */ if mseg_message_info.ms_id = ""b then mseg_message_info.ms_id = local_md.ms_id; /* return the message ID to our caller */ call return_from_operation (0); %page; /* Add a message on behalf of another message primitive operation -- This entrypoint is identical to add_message, above, except that it does not invoke mseg_utils_$begin_operation. */ mseg_message_$add_message_for_mseg: entry (P_mseg_operation_ptr, P_operation_name, P_code); call setup_operation (); /* for cleanup handler */ operation_started_locally = "0"b; on cleanup call operation_was_aborted (); mseg_operation_ptr = P_mseg_operation_ptr; operation_name = P_operation_name; mseg_ptr = mseg_operation.mseg_ptr; go to ADD_MESSAGE; %page; /* Count the accessible messages */ mseg_message_$count_messages: entry (P_mseg_operation_ptr, P_ms_count, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$count_messages); if rqo_detected then do; /* couldn't even lock the segment: it must be empty */ P_ms_count = 0; call return_from_operation (0); end; else if code ^= 0 then call return_from_operation (code); if mseg_segment.n_messages = 0 then P_ms_count = 0; /* the segment is empty */ else if mseg_operation.suppress_access_checks then P_ms_count = mseg_segment.n_messages; /* the caller doesn't want us to worry about access */ else if ring1_privilege () | read_allowed_ (mseg_operation.caller.authorization, mseg_operation.access_info.access_class) then P_ms_count = mseg_segment.n_messages; /* the user has access to see everything in the segment */ else do; /* we have to count the messages */ do_owner_check = "0"b; /* ... we must have "s" so we don't need to check owner */ P_ms_count = 0; do message_offset = mseg_segment.message_chain.first_message repeat (message_descriptor.message_chain.next_message) while (message_offset ^= 0); call set_message_ptrs (message_offset, mb_ptr, md_ptr); if is_accessible_message () then P_ms_count = P_ms_count + 1; end; end; call return_from_operation (0); %page; /* Delete a message */ mseg_message_$delete_message: entry (P_mseg_operation_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$delete_message); if rqo_detected then call return_from_operation (error_table_$no_message); else if code ^= 0 then call return_from_operation (code); if mseg_segment.n_messages = 0 /* can't delete if there's nothing there */ then call return_from_operation (error_table_$no_message); mseg_message_info_ptr = addr (mseg_operation.message_info); call find_message (mseg_message_info.ms_id); if mb_ptr = null () /* the given ID doesn't identify a real message */ then call return_from_operation (error_table_$no_message); mseg_operation.md_ptr_valid = "1"b; mseg_operation.md_ptr = md_ptr; call mseg_check_access_$message (mseg_operation_ptr, code); if code ^= 0 /* the message can't be deleted */ then call return_from_operation (code); local_md = message_descriptor; /* will need these later to unthread the message */ message_offset = wordno (mb_ptr); mseg_segment.modification_in_progress = "1"b; /* a fault now will cause the segment to be salvaged */ call process_message (mb_ptr, "0"b, "0"b, "1"b); /* does most of the dirty work */ call unchain_message (); /* remove it from the various chains */ mseg_segment.modification_in_progress = "0"b; /* all done */ call return_from_operation (0); %page; /* Read (and optionally delete) a message */ mseg_message_$read_message: entry (P_mseg_operation_ptr, P_users_area_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); if P_users_area_ptr ^= null () /* the user must supply an area */ then users_area_ptr = P_users_area_ptr; else call return_from_operation (error_table_$bad_subr_arg); call begin_operation (mseg_operations_$read_message); if rqo_detected then call return_from_operation (error_table_$no_message); else if code ^= 0 then call return_from_operation (code); READ_MESSAGE: if mseg_segment.n_messages = 0 /* can't read something if there's nothing there */ then call return_from_operation (error_table_$no_message); mseg_message_info_ptr = addr (mseg_operation.message_info); if mseg_message_info.version ^= MSEG_MESSAGE_INFO_V1 then call return_from_operation (error_table_$unimplemented_version); do_owner_check = mseg_operation.only_own_access | mseg_message_info.own; /*** Find the desired message and check the user's access to same */ if mseg_message_info.message_code = MSEG_READ_SPECIFIED then call find_message (mseg_message_info.ms_id); else if mseg_message_info.message_code = MSEG_READ_FIRST then do; call set_message_ptrs (mseg_segment.message_chain.first_message, mb_ptr, md_ptr); call find_next_accessible_message ((72)"0"b); end; else if mseg_message_info.message_code = MSEG_READ_LAST then do; call set_message_ptrs (mseg_segment.message_chain.last_message, mb_ptr, md_ptr); call find_previous_accessible_message ((72)"1"b); end; else if mseg_message_info.message_code = MSEG_READ_BEFORE_SPECIFIED then do; call find_message (mseg_message_info.ms_id); if mb_ptr = null () then do; /* given ID doesn't exist: search the entire backward chain */ call set_message_ptrs (mseg_segment.message_chain.last_message, mb_ptr, md_ptr); call find_previous_accessible_message (mseg_message_info.ms_id); end; else if message_descriptor.message_chain.prev_message ^= 0 then do; /* it exists: search from its previous message */ call set_message_ptrs (message_descriptor.message_chain.prev_message, mb_ptr, md_ptr); call find_previous_accessible_message (mseg_message_info.ms_id); end; else call return_from_operation (error_table_$no_message); end; else if mseg_message_info.message_code = MSEG_READ_AFTER_SPECIFIED then do; call find_message (mseg_message_info.ms_id); if mb_ptr = null () then do; /* given ID doesn't exist: search the entire forward chain */ call set_message_ptrs (mseg_segment.message_chain.first_message, mb_ptr, md_ptr); call find_next_accessible_message (mseg_message_info.ms_id); end; else if message_descriptor.message_chain.next_message ^= 0 then do; /* it exists: search from its next message */ call set_message_ptrs (message_descriptor.message_chain.next_message, mb_ptr, md_ptr); call find_next_accessible_message (mseg_message_info.ms_id); end; else call return_from_operation (error_table_$no_message); end; else call return_from_operation (error_table_$bad_subr_arg); if mb_ptr = null () /* didn't find a message to read */ then call return_from_operation (error_table_$no_message); mseg_operation.md_ptr_valid = "1"b; mseg_operation.md_ptr = md_ptr; call mseg_check_access_$message (mseg_operation_ptr, code); if code ^= 0 /* insufficient access to read the message */ then call return_from_operation (code); /*** Allocate space in the user's storage for the message and copy it from the segment */ mseg_message_info.ms_ptr = null (); /* for cleanup handler */ operation_specific_abort = abort_read_operation; operation_specific_return = return_from_read_operation; mseg_message_info.ms_len = message_descriptor.ms_len; on area begin; code = error_table_$noalloc; go to RETURN_FROM_READ_OPERATION; /* avoids making return_from_operation non-quick */ end; allocate mseg_message_bits in (users_area) set (mseg_message_info.ms_ptr); /*** We can now copy the relevant data directly from the message descriptor into our caller's mseg_message_info structure. However, we must not reveal the sender's audit flags unless the caller could obtain them itself (via access_audit_r1_$get_audit_flags) or the process has ring-1 privilege. Otherwise, if we always returned the sender's audit flags, a user could determine his audit flags by adding and then reading a message from any message segment. (A user isn't allowed to know his audit flags to prevent him from only trying certain "incorrect" acts when he knows he won't be audited.) */ mseg_message_info = message_descriptor, by name; if operation_started_locally /* never censor if read was initiated directly by mseg_ */ then if ^(ring1_privilege () | (mseg_operation.caller.validation_level = mseg_data_$admin_ring)) then mseg_message_info.sender_audit = ""b; /*** Copy the message from the segment and, if requested, delete it */ local_md = message_descriptor; if mseg_message_info.delete then do; /* stash data that will be needed later to finish deletion */ message_offset = wordno (mb_ptr); mseg_segment.modification_in_progress = "1"b; end; call process_message (mb_ptr, "1"b, "0"b, (mseg_message_info.delete)); /* does most of the dirty work */ if mseg_message_info.delete then do; call unchain_message (); mseg_segment.modification_in_progress = "0"b; end; code = 0; /* success */ RETURN_FROM_READ_OPERATION: call return_from_operation (code); /* Special processing required upon completion of a read operation */ return_from_read_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; if p_code ^= 0 /* the read failed ... */ then if mseg_message_info.ms_ptr ^= null () /* ... so we must eliminate whatever we did manage to read */ then do; free mseg_message_bits in (users_area); mseg_message_info.ms_ptr = null (); end; return; end return_from_read_operation; /* Special processing required upon abnormal termination of a read operation */ abort_read_operation: procedure (); if mseg_message_info.ms_ptr ^= null () then do; free mseg_message_bits in (users_area); mseg_message_info.ms_ptr = null (); end; return; end abort_read_operation; %page; /* Read (and optionally delete) a message on behalf of another message primitive operation -- This entrypoint is identical to read_message, above, except that it does not invoke mseg_utils_$begin_operation. */ mseg_message_$read_message_for_mseg: entry (P_mseg_operation_ptr, P_operation_name, P_users_area_ptr, P_code); call setup_operation (); /* for cleanup handler */ operation_started_locally = "0"b; on cleanup call operation_was_aborted (); mseg_operation_ptr = P_mseg_operation_ptr; operation_name = P_operation_name; users_area_ptr = P_users_area_ptr; /* guaranteed non-null by our caller */ mseg_ptr = mseg_operation.mseg_ptr; go to READ_MESSAGE; %page; /* Update a message -- The data stored in the message are replaced by the data supplied by the caller. If the caller provides less data than are presently in the message, this operation will only replace the first part of the data and leave the remaining data intact. Thus, this operation can be used to update the application header in a message without actually having to first read the message from the segment. */ mseg_message_$update_message: entry (P_mseg_operation_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$update_message); if rqo_detected then call return_from_operation (error_table_$no_message); else if code ^= 0 then call return_from_operation (code); if mseg_segment.n_messages = 0 /* can't update if there's nothing there */ then call return_from_operation (error_table_$no_message); mseg_message_info_ptr = addr (mseg_operation.message_info); call find_message (mseg_message_info.ms_id); if mb_ptr = null () /* the given ID doesn't identify a real message */ then call return_from_operation (error_table_$no_message); mseg_operation.md_ptr_valid = "1"b; mseg_operation.md_ptr = md_ptr; call mseg_check_access_$message (mseg_operation_ptr, code); if code ^= 0 /* the message can't be updated */ then call return_from_operation (code); if mseg_message_info.ms_len > message_descriptor.ms_len then call return_from_operation (error_table_$bigarg); local_md = message_descriptor; call process_message (mb_ptr, "0"b, "1"b, "0"b); /* does the real dirty work */ call return_from_operation (0); %page; /* Common initialization for all operations */ setup_operation: procedure (); code = 0; operation_specific_abort = nulle; /* nothing special when we abort or return (yet) */ operation_specific_return = nulle; mseg_operation_ptr = null (); operation_started_locally = "1"b; /* abort/return must invoke mseg_utils_ */ return; end setup_operation; /* Begin the operation -- This procedure isn't part of setup_operation so that we can be certain to have a cleanup handler available at all times that the message segment may be in use. */ begin_operation: procedure (p_mseg_operation_id); dcl p_mseg_operation_id bit (36) aligned parameter; mseg_operation_ptr = P_mseg_operation_ptr; call mseg_utils_$begin_operation (p_mseg_operation_id, mseg_operation_ptr, operation_name, mseg_dir_name, mseg_entryname, mseg_ptr, rqo_detected, code); return; end begin_operation; /* The "null" entry which indicates that there's no special abort/return processing for an operation */ nulle: procedure (); return; end nulle; %page; /* Return after completion of an operation */ return_from_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; if operation_specific_return ^= nulle /* let the operation do anything special */ then call operation_specific_return (p_code); if operation_started_locally & (mseg_operation_ptr ^= null ()) then call mseg_utils_$finish_operation (mseg_operation_ptr); /* may be invoked before we've called begin_operation */ P_code = p_code; /* set our caller's status code */ go to RETURN_FROM_OPERATION; end return_from_operation; RETURN_FROM_OPERATION: return; /* Abort an operation */ operation_was_aborted: procedure (); if operation_specific_abort ^= nulle /* let the operation do anything special */ then call operation_specific_abort (); if operation_started_locally then call mseg_utils_$abort_operation (mseg_operation_ptr); return; end operation_was_aborted; /* Salvage the message segment due to internal inconsistencies and return error_table_$bad_segment to our caller */ salvage_and_return: procedure (p_format_error); dcl p_format_error fixed binary (35) parameter; call mseg_utils_$salvage_for_cause (mseg_operation_ptr, p_format_error); call return_from_operation (error_table_$bad_segment); end salvage_and_return; %page; /* Set the supplied message block and descriptor pointers from the given offset */ set_message_ptrs: procedure (p_message_offset, p_mb_ptr, p_md_ptr); dcl p_message_offset fixed binary (18) unaligned unsigned parameter; dcl (p_mb_ptr, p_md_ptr) pointer parameter; dcl block_id fixed binary (18); if (p_message_offset <= (wordno (addr (mseg_segment.block_map)) + divide (mseg_segment.n_blocks_allocated + 35, 36, 18, 0))) | (p_message_offset > (mseg_segment.block_size * (mseg_segment.n_blocks_allocated - 1))) then call salvage_and_return (mseg_format_errors_$invalid_message_block_offset); if mod (p_message_offset, mseg_segment.block_size) ^= 0 then call salvage_and_return (mseg_format_errors_$invalid_message_block_offset); block_id = divide (p_message_offset, mseg_segment.block_size, 18, 0) + 1; if substr (mseg_segment.block_map.map, block_id, 1) = "0"b then call salvage_and_return (mseg_format_errors_$unused_block_in_message); p_mb_ptr = setwordno (mseg_ptr, p_message_offset); if p_mb_ptr -> message_block_header.descriptor_present then do; begin; dcl saved_mb_ptr bit (72) aligned; /*** The following code fragment is a replacement for the statement p_md_ptr = addr (p_mb_ptr -> first_message_block_descriptor); That statement will not work as PL/I must reference through mb_ptr in order to compute the size of first_message_block.data_space.pad. Additionally, we can't use normal assignment statements to save/restore the value of mb_ptr as it is sometimes legimately unitialized when this procedure is invoked. */ unspec (saved_mb_ptr) = unspec (mb_ptr); mb_ptr = p_mb_ptr; p_md_ptr = addr (first_message_block.descriptor); unspec (mb_ptr) = unspec (saved_mb_ptr); end; if p_md_ptr -> message_descriptor.sentinel ^= MESSAGE_DESCRIPTOR_SENTINEL then call salvage_and_return (mseg_format_errors_$bad_descriptor_sentinel); end; else call salvage_and_return (mseg_format_errors_$no_descriptor_in_first_block); return; /* executed iff the message looks OK so far */ end set_message_ptrs; %page; /* Determine if the user has ring1 privilege */ ring1_privilege: procedure () returns (bit (1) aligned); return ((mseg_operation.caller.privileges & sys_info$ring1_privilege) ^= ""b); end ring1_privilege; /* Determine if the current message (mb_ptr, md_ptr) is accessible to (i.e., readable by) the user */ is_accessible_message: procedure () returns (bit (1) aligned); if do_owner_check /* we have to checks that it's our message */ then if owner_doesnt_match () then return ("0"b); /* ... and it isn't */ if mseg_operation.suppress_access_checks then return ("1"b); /* our caller doesn't want us to worry about AIM, etc. */ return (ring1_privilege () | read_allowed_ (mseg_operation.caller.authorization, message_descriptor.ms_access_class)); /* Determine if the user doesn't own this message */ owner_doesnt_match: procedure () returns (bit (1) aligned); declare name character (32) varying; declare message_name character (32) varying; name = before (mseg_operation.caller.group_id, "."); message_name = before (message_descriptor.sender_id, "."); if (name ^= "anonymous") & (message_name ^= "anonymous") then /*** The user isn't anonymous and the message wasn't written by an anonymous user. We can simply test the Person_ids to see if the user owns this message. */ return (name ^= message_name); else if (name = "anonymous") & (message_name = "anonymous") then do; /*** The user is an anonymous user and the message was written by an anonymous user. We must test the Project_ids to see if the user owns this message. */ name = before (after (mseg_operation.caller.group_id, "."), "."); message_name = before (after (message_descriptor.sender_id, "."), "."); return (name ^= message_name); end; else /*** Either the user is an anonymous user and the message wsn't written by one or vice-versa. By definition, the user can not possibly own this message. */ return ("1"b); end owner_doesnt_match; end is_accessible_message; %page; /* Search the message hash table with the given message ID */ find_message: procedure (p_ms_id); dcl p_ms_id bit (72) aligned parameter; dcl message_offset fixed binary (18) unaligned unsigned; dcl n_messages_checked fixed binary (18); hash_idx = fixed (substr (p_ms_id, 64, 9), 9, 0); next_message_in_hash_chain = null (); /* hash chain isn't doubly linked (sigh) */ n_messages_checked = 0; do message_offset = mseg_segment.hash_table.last_message (hash_idx) repeat (message_descriptor.prev_message_in_hash_chain) while (message_offset ^= 0); call set_message_ptrs (message_offset, mb_ptr, md_ptr); if message_descriptor.ms_id = p_ms_id /* found it! */ then return; else next_message_in_hash_chain = md_ptr; n_messages_checked = n_messages_checked + 1; if n_messages_checked > mseg_segment.n_messages then call salvage_and_return (mseg_format_errors_$circular_hash_chain); end; /*** Control arrives here iff the given ID isn't in the hash table */ mb_ptr, md_ptr = null (); return; end find_message; %page; /* Find the first accessible message in the specified direction along the chronological message chain whose message ID is greater than (if forward) or less than (if backward) the specified value. If the current message (mb_ptr, md_ptr) satisfies the criteria, it is selected. */ find_accessible_message: procedure (p_ms_id_key); return; /* not used */ dcl p_ms_id_key bit (72) aligned parameter; dcl (hash_mb_ptr, hash_md_ptr) pointer; dcl (scan_forward, scan_backward) bit (1) aligned; dcl message_offset fixed binary (18) unaligned unsigned; dcl n_messages_checked fixed binary (18); find_next_accessible_message: /* ... using the forward chain and ID > KEY */ entry (p_ms_id_key); scan_forward = "1"b; scan_backward = "0"b; go to FIND_THE_MESSAGE; find_previous_accessible_message: /* ... using the backward chain and ID < KEY */ entry (p_ms_id_key); scan_backward = "1"b; scan_forward = "0"b; go to FIND_THE_MESSAGE; FIND_THE_MESSAGE: n_messages_checked = 0; do while (mb_ptr ^= null ()); if is_accessible_message () /* the user can see this message */ then if scan_forward then if message_descriptor.ms_id > p_ms_id_key then go to FOUND_THE_MESSAGE; else ; else if scan_backward then if message_descriptor.ms_id < p_ms_id_key then go to FOUND_THE_MESSAGE; else ; n_messages_checked = n_messages_checked + 1; if n_messages_checked > mseg_segment.n_messages then call salvage_and_return (mseg_format_errors_$circular_message_chain); if scan_forward then message_offset = message_descriptor.message_chain.next_message; else message_offset = message_descriptor.message_chain.prev_message; if message_offset ^= 0 /* there are more candidates */ then call set_message_ptrs (message_offset, mb_ptr, md_ptr); else mb_ptr = null (); end; /*** Control arrives here iff an appropriate message is not found */ md_ptr = null (); /* be sure both message pointers are null */ return; /*** Control arrives here when an appropriate message has been found. If we are going to delete the message, we must find its successor in its hash chain so we can later relink said chain. This is necessary as the hash chains are not doubly linked. (In version 6 message segments, we will doubly link the hash chain). */ FOUND_THE_MESSAGE: if mseg_message_info.delete then do; hash_idx = fixed (substr (message_descriptor.ms_id, 64, 9), 9, 0); next_message_in_hash_chain = null (); n_messages_checked = 0; do message_offset = mseg_segment.hash_table.last_message (hash_idx) repeat (hash_md_ptr -> message_descriptor.prev_message_in_hash_chain) while (message_offset ^= 0); call set_message_ptrs (message_offset, hash_mb_ptr, hash_md_ptr); if hash_md_ptr -> message_descriptor.ms_id = message_descriptor.ms_id then return; /* found it: next_message_in_hash_chain is now properly set */ else next_message_in_hash_chain = hash_md_ptr; n_messages_checked = n_messages_checked + 1; if n_messages_checked > mseg_segment.n_messages then call salvage_and_return (mseg_format_errors_$circular_hash_chain); end; /*** Control arrives here iff the message doesn't appear in its hash chain which means that the message segment is inconsistent. */ call salvage_and_return (mseg_format_errors_$inconsistent_hash_chain); end; return; end find_accessible_message; %page; /* Process an already extant message for reading, updating, or deletion -- The major portion of the processing for each of these operations consists of walking the chain of blocks which comprise the message and validating that it is a properly formed message. Only a small fraction of the work involves the actual reading, updating, or deleting. */ process_message: procedure (p_first_mb_ptr, p_read, p_update, p_delete); dcl p_first_mb_ptr pointer parameter; dcl (p_read, p_update, p_delete) bit (1) aligned parameter; dcl next_mb_ptr pointer; dcl first_block bit (1) aligned; dcl (actual_ms_len, n_bits_remaining, n_bits_copied, n_bits_to_copy) fixed binary (24); dcl (n_actual_blocks, block_id) fixed binary (18); actual_ms_len = 0; /* check actual length and # of blocks for inconsistencies */ n_actual_blocks = 0; n_bits_copied = 0; if p_update then n_bits_remaining = mseg_message_info.ms_len; first_block = "1"b; /* we are called with the first block in the message */ do mb_ptr = p_first_mb_ptr repeat (next_mb_ptr) while (mb_ptr ^= null ()); block_id = divide (wordno (mb_ptr), mseg_segment.block_size, 18, 0) + 1; if substr (mseg_segment.block_map.map, block_id, 1) = "0"b then call salvage_and_return (mseg_format_errors_$unused_block_in_message); actual_ms_len = actual_ms_len + message_block_header.data_lth; if actual_ms_len > local_md.ms_len /* check that the message length is OK */ then call salvage_and_return (mseg_format_errors_$inconsistent_message_length); n_actual_blocks = n_actual_blocks + 1; /* check that the block chain is OK */ if n_actual_blocks > mseg_segment.n_blocks_allocated then call salvage_and_return (mseg_format_errors_$circular_message_blocks); if message_block_header.next_block = 0 /* find the next block now as deleting will zero the header */ then next_mb_ptr = null (); else next_mb_ptr = setwordno (mseg_ptr, message_block_header.next_block); if ^first_block /* only the first block should have a descriptor */ then if message_block_header.descriptor_present then call salvage_and_return (mseg_format_errors_$descriptor_in_other_block); if p_read then do; /*** Copy the message from the segment to the storage previously allocated in the user's area */ n_bits_to_copy = message_block_header.data_lth; if n_bits_to_copy > 0 then begin; /* if there's something to get from this block */ dcl target_bits bit (n_bits_to_copy) unaligned defined (mseg_message_bits.data) position (n_bits_copied + 1); if first_block then target_bits = first_message_block.data; else target_bits = other_message_block.data; n_bits_copied = n_bits_copied + n_bits_to_copy; end; end; else if p_update then do; /*** Copy the updated portion of the message from the user's storage */ n_bits_to_copy = min (n_bits_remaining, message_block_header.data_lth); if n_bits_to_copy > 0 /* there's something to put into this block */ then begin; dcl source_bits bit (n_bits_to_copy) unaligned defined (mseg_message_bits.data) position (n_bits_copied + 1); dcl target_bits bit (n_bits_to_copy) unaligned defined (other_message_block.data) position (1); target_bits = source_bits; n_bits_remaining = n_bits_remaining - n_bits_to_copy; n_bits_copied = n_bits_copied + n_bits_to_copy; end; end; if p_delete then do; /*** Delete this block */ substr (mseg_segment.block_map.map, block_id, 1) = "0"b; if first_block then unspec (first_message_block) = ""b; else unspec (other_message_block) = ""b; mseg_segment.n_blocks_unused = mseg_segment.n_blocks_unused + 1; end; first_block = "0"b; end; if actual_ms_len < local_md.ms_len /* the descriptor says it should be longer */ then call salvage_and_return (mseg_format_errors_$inconsistent_message_length); return; end process_message; %page; /* Remove the now-deleted message that was located at message_offset and whose descriptor is in local_md from the various message chains in the segment */ unchain_message: procedure (); if local_md.message_chain.prev_message = 0 then do; /* it was the first message in the segment */ if mseg_segment.message_chain.first_message ^= message_offset then call salvage_and_return (mseg_format_errors_$inconsistent_forward_chain); mseg_segment.message_chain.first_message = local_md.message_chain.next_message; end; else do; /* it wasn't first */ call set_message_ptrs (local_md.message_chain.prev_message, prev_mb_ptr, prev_md_ptr); if prev_md_ptr -> message_descriptor.message_chain.next_message ^= message_offset then call salvage_and_return (mseg_format_errors_$inconsistent_forward_chain); prev_md_ptr -> message_descriptor.message_chain.next_message = local_md.message_chain.next_message; end; if local_md.message_chain.next_message = 0 then do; /* it was the last message in the segment */ if mseg_segment.message_chain.last_message ^= message_offset then call salvage_and_return (mseg_format_errors_$inconsistent_backward_chain); mseg_segment.message_chain.last_message = local_md.message_chain.prev_message; end; else do; /* it wasn't last */ call set_message_ptrs (local_md.message_chain.next_message, next_mb_ptr, next_md_ptr); if next_md_ptr -> message_descriptor.message_chain.prev_message ^= message_offset then call salvage_and_return (mseg_format_errors_$inconsistent_backward_chain); next_md_ptr -> message_descriptor.message_chain.prev_message = local_md.message_chain.prev_message; end; if next_message_in_hash_chain = null () then do; /* it was the last message in its hash chain */ if mseg_segment.hash_table.last_message (hash_idx) ^= message_offset then call salvage_and_return (mseg_format_errors_$inconsistent_hash_chain); mseg_segment.hash_table.last_message (hash_idx) = local_md.prev_message_in_hash_chain; end; else do; /* it wasn't last */ if next_message_in_hash_chain -> message_descriptor.prev_message_in_hash_chain ^= message_offset then call salvage_and_return (mseg_format_errors_$inconsistent_hash_chain); next_message_in_hash_chain -> message_descriptor.prev_message_in_hash_chain = local_md.prev_message_in_hash_chain; end; mseg_segment.n_messages = mseg_segment.n_messages - 1; return; end unchain_message; %page; /* Check that the block map and unused block count are consistent */ check_block_map_consistency: procedure (); dcl (actual_n_blocks_unused, last_block_checked, next_unused_block, next_used_block) fixed binary (18); actual_n_blocks_unused = 0; last_block_checked = 0; do while (last_block_checked < mseg_segment.n_blocks_allocated); begin; /* find the next unused block (if any) */ dcl rest_of_block_map bit (mseg_segment.n_blocks_allocated - last_block_checked) unaligned defined (mseg_segment.block_map.map) position (last_block_checked + 1); next_unused_block = index (rest_of_block_map, "0"b); end; if next_unused_block = 0 /* all the remaining blocks are in use */ then last_block_checked = mseg_segment.n_blocks_allocated; else do; /* at least one more unused block */ last_block_checked = last_block_checked + next_unused_block - 1; begin; /* find the first used block after this unused block */ dcl rest_of_block_map bit (mseg_segment.n_blocks_allocated - last_block_checked) unaligned defined (mseg_segment.block_map.map) position (last_block_checked + 1); next_used_block = index (rest_of_block_map, "1"b); if next_used_block = 0 /* ... the rest of the blocks are unused */ then next_used_block = length (rest_of_block_map) + 1; end; actual_n_blocks_unused = actual_n_blocks_unused + next_used_block - 1; last_block_checked = last_block_checked + next_used_block - 1; end; end; if actual_n_blocks_unused ^= mseg_segment.n_blocks_unused then call salvage_and_return (mseg_format_errors_$inconsistent_block_map); return; end check_block_map_consistency; /* format: off */ %page; %include mseg_data_; %page; %include mseg_segment; %page; %include mseg_wakeup_state; %page; %include mseg_message; %page; %include mseg_operation; %page; %include mseg_message_info; %page; %include entry_access_info; %page; %include mseg_operations_; %page; %include mseg_format_errors_; %page; %include access_audit_eventflags; %page; /* BEGIN MESSAGE DOCUMENTATION Message: Audit (mseg_$add_message): DENIED addition of a message to a message segment ADDED_INFO S: $access_audit T: $run M: A message was not added to a mailbox or message segment because there is not enough room for the message in the segment. Repeated occurences of this event over a short period of time could indicate an attempt to exploit a moderate bandwidth covert channel. ADDED_INFO will identify the user and segment in question. A: $notify_ssa END MESSAGE DOCUMENTATION */ /* format: on */ end mseg_message_;  mseg_operations_.cds 05/10/85 0907.4r w 05/06/85 1617.7 73431 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* Definition of the message segment primitive operations (mseg_) */ /* Created: April 1985 by G. Palter */ /* format: style3,linecom */ mseg_operations_: procedure () options (variable); declare 1 mops aligned, 2 (add_acl_entries_seg, add_message, chname_seg, close_seg, compact_seg, copy_seg_source, copy_seg_target, count_messages, create_seg, delete_acl_entries_seg, delete_message, delete_seg, get_salvaged_flag_seg, get_wakeup_state_seg, initiate_seg, list_acl_seg, list_acl_entries_seg, open_seg, read_message, replace_acl_seg, reset_salvaged_flag_seg, reset_wakeup_state_seg, set_max_length_seg, set_safety_switch_seg, set_wakeup_state_seg, update_message) bit (36) aligned, 2 names (26) character (64) varying; dcl 1 cds_data aligned like cds_args; dcl code fixed binary (35); dcl last_operation_id fixed binary (9); dcl MSEG_OPERATIONS_ character (32) static options (constant) initial ("mseg_operations_"); dcl error_table_$bigarg fixed binary (35) external; dcl error_table_$out_of_bounds fixed binary (35) external; dcl com_err_ entry () options (variable); dcl create_data_segment_ entry (pointer, fixed binary (35)); dcl (addr, currentsize, hbound, length, maxlength, null, string) builtin; %page; /* Define the mseg_operations_$OPERATION and mseg_operations_$names constants */ last_operation_id = 0; call operation (mops.add_acl_entries_seg, "mseg_$add_acl_entries_seg", MSEG_REQUIRED_FOR_FS_INTERFACE, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.add_message, "mseg_$add_message", MSEG_REQUIRED_FOR_MESSAGE, MSEG_BEGIN_FOR_MESSAGE | MSEG_INITIALIZE_HEADER, MSEG_FINISH_FOR_MESSAGE); call operation (mops.chname_seg, "mseg_$chname_seg", MSEG_REQUIRE_PATHNAME | MSEG_REQUIRE_MSEG_PTR, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.close_seg, "mseg_$close_seg", MSEG_REQUIRE_MSEG_PTR | MSEG_REQUIRE_MSEG_INDEX, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.compact_seg, "mseg_$compact_seg", MSEG_REQUIRED_FOR_SEGMENT, MSEG_BEGIN_FOR_MESSAGE, MSEG_FINISH_FOR_MESSAGE); /* compaction requires working with the individual messages */ call operation (mops.copy_seg_source, "mseg_$copy_seg", MSEG_REQUIRED_FOR_SEGMENT, MSEG_BEGIN_FOR_MESSAGE, MSEG_FINISH_FOR_MESSAGE); /* copying requires working with the individual messages */ call operation (mops.copy_seg_target, "mseg_$copy_seg", MSEG_REQUIRED_FOR_SEGMENT, MSEG_LOCK_SEGMENT, MSEG_FINISH_FOR_SEGMENT); call operation (mops.count_messages, "mseg_$count_messages", MSEG_REQUIRE_MSEG_PTR | MSEG_REQUIRE_ACCESS_INFO, MSEG_BEGIN_FOR_MESSAGE, MSEG_FINISH_FOR_MESSAGE); /* there's no individual message for which we'd need info */ call operation (mops.create_seg, "mseg_$create_seg", MSEG_REQUIRED_FOR_FS_INTERFACE, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.delete_acl_entries_seg, "mseg_$delete_acl_entries_seg", MSEG_REQUIRED_FOR_FS_INTERFACE, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.delete_message, "mseg_$delete_message", MSEG_REQUIRED_FOR_MESSAGE, MSEG_BEGIN_FOR_MESSAGE, MSEG_FINISH_FOR_MESSAGE); call operation (mops.delete_seg, "mseg_$delete_seg", MSEG_REQUIRE_MSEG_PTR, MSEG_LOCK_SEGMENT | MSEG_DONT_CHECK_LOCK_RESULTS, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.get_salvaged_flag_seg, "mseg_$get_salvaged_flag_seg", MSEG_REQUIRED_FOR_SEGMENT, MSEG_BEGIN_FOR_SEGMENT, MSEG_FINISH_FOR_SEGMENT); call operation (mops.get_wakeup_state_seg, "mseg_$get_wakeup_state_seg", MSEG_REQUIRED_FOR_SEGMENT | MSEG_REQUIRE_WAKEUP_STATE_VERSION, MSEG_BEGIN_FOR_SEGMENT, MSEG_FINISH_FOR_SEGMENT); call operation (mops.initiate_seg, "mseg_$initiate_seg", MSEG_REQUIRED_FOR_FS_INTERFACE, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.list_acl_seg, "mseg_$list_acl_seg", MSEG_REQUIRED_FOR_FS_INTERFACE, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.list_acl_entries_seg, "mseg_$list_acl_entries_seg", MSEG_REQUIRED_FOR_FS_INTERFACE, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.open_seg, "mseg_$open_seg", MSEG_REQUIRE_MSEG_PTR, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.read_message, "mseg_$read_message", MSEG_REQUIRED_FOR_MESSAGE, MSEG_BEGIN_FOR_MESSAGE, MSEG_FINISH_FOR_MESSAGE); call operation (mops.replace_acl_seg, "mseg_$replace_acl_seg", MSEG_REQUIRED_FOR_FS_INTERFACE, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.reset_salvaged_flag_seg, "mseg_$reset_salvaged_flag_seg", MSEG_REQUIRED_FOR_SEGMENT | MSEG_REQUIRE_ACCESS_INFO, MSEG_BEGIN_FOR_SEGMENT, MSEG_FINISH_FOR_SEGMENT); call operation (mops.reset_wakeup_state_seg, "mseg_$reset_wakeup_state_seg", MSEG_REQUIRED_FOR_SEGMENT, MSEG_BEGIN_FOR_SEGMENT, MSEG_FINISH_FOR_SEGMENT); call operation (mops.set_max_length_seg, "mseg_$set_max_length_seg", MSEG_REQUIRED_FOR_SEGMENT, MSEG_BEGIN_FOR_SEGMENT | MSEG_CHECK_COUNT_CONSISTENCY, MSEG_FINISH_FOR_SEGMENT); call operation (mops.set_safety_switch_seg, "mseg_$set_safety_switch_seg", MSEG_REQUIRE_PATHNAME | MSEG_REQUIRE_MSEG_PTR, MSEG_BEGIN_FOR_FS_INTERFACE, MSEG_FINISH_FOR_FS_INTERFACE); call operation (mops.set_wakeup_state_seg, "mseg_$set_wakeup_state_seg", MSEG_REQUIRED_FOR_SEGMENT | MSEG_REQUIRE_WAKEUP_STATE, MSEG_BEGIN_FOR_SEGMENT, MSEG_FINISH_FOR_SEGMENT); call operation (mops.update_message, "mseg_$update_message", MSEG_REQUIRED_FOR_MESSAGE, MSEG_BEGIN_FOR_MESSAGE, MSEG_FINISH_FOR_MESSAGE); /* Create the data segment */ cds_data.sections (1).p = addr (mops); cds_data.sections (1).len = currentsize (mops); cds_data.sections (1).struct_name = "mops"; cds_data.seg_name = MSEG_OPERATIONS_; cds_data.num_exclude_names = 0; cds_data.exclude_array_ptr = null (); string (cds_data.switches) = ""b; cds_data.have_text = "1"b; call create_data_segment_ (addr (cds_data), code); if code ^= 0 then call com_err_ (code, MSEG_OPERATIONS_); RETURN_FROM_MSEG_OPERATIONS_: return; %page; /* Define a single operation */ operation: procedure (p_operation_value, p_operation_name, p_required_for_operation, p_begin_for_operation, p_finish_for_operation); dcl p_operation_value bit (36) aligned parameter; dcl p_operation_name character (*) parameter; dcl (p_required_for_operation, p_begin_for_operation, p_finish_for_operation) bit (9) aligned parameter; if last_operation_id >= hbound (mops.names, 1) then do; call com_err_ (error_table_$out_of_bounds, MSEG_OPERATIONS_, "^/^5xIncrease the dimension of the mops.names array and recompile."); go to RETURN_FROM_MSEG_OPERATIONS_; end; last_operation_id = last_operation_id + 1; mseg_operation_data_ptr = addr (p_operation_value); mseg_operation_data.operation_id = last_operation_id; string (mseg_operation_data.required_data) = p_required_for_operation; string (mseg_operation_data.begin_flags) = p_begin_for_operation; string (mseg_operation_data.finish_flags) = p_finish_for_operation; if length (p_operation_name) > maxlength (mops.names (last_operation_id)) then do; call com_err_ (error_table_$bigarg, MSEG_OPERATIONS_, "Operation name ""^a"".^/^5xIncrease the maxlength of mops.names and recompile.", p_operation_name); go to RETURN_FROM_MSEG_OPERATIONS_; end; mops.names (last_operation_id) = p_operation_name; return; end operation; /* format: off */ %page; %include mseg_operation_data; %page; %include cds_args; /* format: on */ end mseg_operations_;  mseg_segment_.pl1 10/21/92 1059.9rew 10/21/92 1058.8 309996 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1992 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(92-09-03,WAAnderson), approve(92-09-03,MECR0016), audit(92-09-17,Vu), install(92-09-24,MR12.5-1017): During message segment compaction the message segment gets truncated to a length of 0. This action overwrites the lockword held by the calling process. The fix ensures the lockword (which is the first word in the segment) does not get set to 0. 2) change(92-10-02,WAAnderson), approve(92-10-02,MCR8271), audit(92-10-13,Vu), install(92-10-21,MR12.5-1032): This MCR closes MECR0016. END HISTORY COMMENTS */ /* Message segment primitive operations (mseg_) which manipulate the entire message segment as a whole */ /* Created: April 1985 by G. Palter based upon mseg_ and mseg_compact_ */ /* format: style3,linecom */ mseg_segment_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_mseg_operation_ptr pointer parameter; dcl P_code fixed binary (35) parameter; dcl P_compaction_ratio float binary parameter; /* compact_seg: %'age of waste to cause compaction (I) */ dcl P_source_mseg_operation_ptr /* copy_seg: -> description of segment to copy (I) */ pointer parameter; dcl P_target_mseg_operation_ptr /* copy_seg: -> description of target segment (I) */ pointer parameter; dcl P_error_on_target bit (1) aligned parameter; /* copy_seg: set ON => target in error (O) */ dcl P_salvaged_flag bit (1) aligned parameter; /* get_salvage_flag_seg: set ON => segment was salvaged (O) */ dcl P_max_length fixed binary (19) parameter; /* set_max_length_seg: the segment's new max length (I) */ /* Local copies of parameters */ dcl 1 source_mseg_operation aligned based (source_mseg_operation_ptr) like mseg_operation; dcl source_mseg_operation_ptr pointer; dcl 1 target_mseg_operation aligned based (target_mseg_operation_ptr) like mseg_operation; dcl target_mseg_operation_ptr pointer; dcl segment_in_error fixed binary; dcl ( SOURCE initial (1), TARGET initial (2) ) fixed binary static options (constant); dcl code fixed binary (35); /* Remaining declartions */ dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl 1 target_mseg_segment_header aligned based (target_mseg_ptr) like mseg_segment.header; dcl target_mseg_ptr pointer; dcl target_mseg_dir_name character (168); dcl target_mseg_entryname character (32); dcl source_mseg_ptr pointer; dcl source_mseg_dir_name character (168); dcl source_mseg_entryname character (32); dcl source_mseg_message_bits bit (source_mseg_operation.ms_len) aligned based (source_mseg_operation.ms_ptr); dcl compacted_segment (compacted_size) bit (36) aligned based; dcl compacted_size fixed binary (19); dcl 1 local_mseg_segment_header aligned like mseg_segment.header; dcl initialize_block_map bit (1) aligned; dcl 1 an_operation aligned like mseg_operation; dcl 1 local_aef aligned like audit_event_flags; dcl operation_name character (64); dcl operation_specific_return entry (fixed binary (35)) variable; dcl operation_specific_abort entry () variable; dcl mseg_dir_name character (168); dcl mseg_entryname character (32); dcl (rqo_detected, salvage_if_errors, free_source_message_bits) bit (1) aligned; dcl (source_max_length, target_max_length) fixed binary (19); dcl (n_new_blocks, n_new_header_blocks, n_virgin_blocks, n_used_or_wasted_blocks, n_wasted_blocks) fixed binary (18); dcl TRUNCATE_ALL_BUT_THE_LOCKWORD fixed bin (19) int static options (constant) init (1); dcl access_operations_$mseg_attr_mod bit (36) aligned external; dcl ( error_table_$action_not_performed, error_table_$bad_segment, error_table_$clnzero, error_table_$invalid_max_length, error_table_$messages_off, error_table_$no_message, error_table_$rqover ) fixed binary (35) external; dcl access_audit_r1_$log_obj_ptr entry () options (variable); dcl aim_util_$get_access_class entry (bit (72) aligned) returns (bit (72) aligned); dcl get_process_id_ entry () returns (bit (36)); dcl get_system_free_area_ entry () returns (pointer); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl hcs_$get_max_length_seg entry (pointer, fixed binary (19), fixed binary (35)); dcl hcs_$set_max_length_seg entry (pointer, fixed binary (19), fixed binary (35)); dcl hcs_$truncate_seg entry (pointer, fixed binary (19), fixed binary (35)); dcl mseg_message_$add_message_for_mseg entry (pointer, character (*), fixed binary (35)); dcl mseg_message_$read_message_for_mseg entry (pointer, character (*), pointer, fixed binary (35)); dcl mseg_utils_$abort_operation entry (pointer); dcl mseg_utils_$begin_operation entry (bit (36) aligned, pointer, character (*), character (*), character (*), pointer, bit (1) aligned, fixed binary (35)); dcl mseg_utils_$finish_operation entry (pointer); dcl mseg_utils_$salvage_for_cause entry (pointer, fixed binary (35)) options (variable); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl (addr, copy, currentsize, divide, float, length, low, mod, null, rtrim, string, substr, unspec) builtin; dcl (cleanup, record_quota_overflow) condition; %page; /* Compact the segment */ mseg_segment_$compact_seg: entry (P_mseg_operation_ptr, P_compaction_ratio, P_code); call setup_operation (); /* for cleanup handler */ target_mseg_ptr = null (); salvage_if_errors, free_source_message_bits = "0"b; operation_specific_return = return_from_compact_seg; operation_specific_abort = abort_compact_seg; on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$compact_seg); if rqo_detected then call return_from_operation (0); else if code ^= 0 then call return_from_operation (code); if mseg_segment.n_messages = 0 /* can't be any waste unless there's something present */ then call return_from_operation (0); /*** When deciding whether to compact, the ratio of unused blocks to the "size" of the segment is checked against the caller's compaction ratio. If the unused ratio exceeds the compaction ratio and there is at least one page of unused blocks, the segment is compacted. However, if the caller's compaction ratio is negative, the compaction is always performed regardless of the amount of space it may (or may not) recover. In order to make the unused block ratio useful, the unused blocks after the last used block are not counted when computing either the size of the segment or the number of unused blocks. */ if P_compaction_ratio >= 0.0e0 then do; n_virgin_blocks = mseg_segment.n_blocks_allocated - find_last_one_bit (mseg_segment.block_map.map); n_used_or_wasted_blocks = mseg_segment.n_blocks_allocated - n_virgin_blocks; n_wasted_blocks = mseg_segment.n_blocks_unused - n_virgin_blocks; if n_wasted_blocks = 0 /* there's no waste at all */ then call return_from_operation (0); if (float (n_wasted_blocks) / float (n_used_or_wasted_blocks)) < P_compaction_ratio then call return_from_operation (0); /* there isn't enough waste to satisfy our caller */ if (mseg_segment.block_size * n_wasted_blocks) < mod ((mseg_segment.block_size * n_used_or_wasted_blocks), 1024) then call return_from_operation (0); /* we won't recover any pages so why bother */ end; /*** Control arrives here only if we are going to compact the segment -- We compact the segment by copying its messages into a "message segment" in the process directory. This so-called message segment is actually just a temporary segment with an associated mseg_operation structure containing the necessary information to satisfy mseg_message_$add_message_for_mseg. */ /*** Finish preparation of the source -- Save the segment's wakeup state in its mseg_operation so we can store it in the target segment while initalizing the target's header. Also, to insure that the target's block map is the proper length, we claim that the target's max length is equal to the source even though, as a temporary segment, its max length may indeed be larger. */ source_mseg_operation_ptr = mseg_operation_ptr; source_mseg_ptr = mseg_ptr; if mseg_segment.wakeup_state_set then call get_wakeup_state_seg (); else mseg_operation.wakeup_state_valid = "0"b; call hcs_$get_max_length_seg (mseg_ptr, target_max_length, code); if code ^= 0 then call return_from_operation (code); /*** Prepare the target -- Create an mseg_operation which will satisfy mseg_message_$add_message_for_mseg and then get a temporary segment to serve as the target. */ an_operation = source_mseg_operation; an_operation.mseg_ptr_valid, /* the source segment is never the target ... */ an_operation.access_info_valid = "0"b; /* ... and its access info doesn't apply to the target */ an_operation.suppress_access_checks = "1"b; /* must be able to copy all messages */ call get_temp_segment_ (operation_name, target_mseg_ptr, code); if code ^= 0 then call return_from_operation (code); an_operation.mseg_ptr = target_mseg_ptr; an_operation.mseg_ptr_valid = "1"b; target_mseg_operation_ptr = addr (an_operation); call mseg_utils_$begin_operation (mseg_operations_$copy_seg_target, target_mseg_operation_ptr, ((64)" "), target_mseg_dir_name, target_mseg_entryname, target_mseg_ptr, rqo_detected, code); if rqo_detected then call return_from_operation (error_table_$rqover); else if code ^= 0 then call return_from_operation (code); /*** Copy the source segment to its "target" which actually performs the compaction */ salvage_if_errors = "1"b; /* if we RQO reading from the segment, it's busted */ on record_quota_overflow call return_rqover_from_operation (); call initialize_target_header ("1"b); /* put in the saved wakeup state */ call copy_messages (); /*** Move the target back into the real segment which will complete this operation -- As the compacted segment is guaranteed to not use more pages than its original, we can pratically guarantee that an RQO will not occur on pages that had been zero in the original by first truncating the segment. If, however, an RQO does occur while copying into the segment, we will stop the copy and salvage what's there as our handler for record_quota_overflow will prevent an automatic salvage by mseg_utils_$abort_operation. */ segment_in_error = SOURCE; call hcs_$truncate_seg (source_mseg_ptr, TRUNCATE_ALL_BUT_THE_LOCKWORD, (0)); compacted_size = target_mseg_segment_header.block_size * (target_mseg_segment_header.n_blocks_allocated - target_mseg_segment_header.n_blocks_unused); source_mseg_ptr -> compacted_segment = target_mseg_ptr -> compacted_segment; revert record_quota_overflow; /* success! */ call return_from_operation (0); /* Special processing required upon completion of a compact_seg operation */ return_from_compact_seg: procedure (p_code); dcl p_code fixed binary (35) parameter; if target_mseg_ptr ^= null () then do; call release_temp_segment_ (operation_name, target_mseg_ptr, (0)); target_mseg_ptr = null (); end; if salvage_if_errors & (p_code ^= 0) /* the flag is only set while actually copying */ then if segment_in_error = SOURCE then if p_code = error_table_$rqover then call mseg_utils_$salvage_for_cause (source_mseg_operation_ptr, error_table_$rqover); if free_source_message_bits /* this flag is also only set while acutally copying */ then if source_mseg_operation.message_info.ms_ptr ^= null () then do; free source_mseg_message_bits in (system_area); source_mseg_operation.message_info.ms_ptr = null (); end; return; end return_from_compact_seg; /* Special processing required upon abnormal termination of a compact_seg operation */ abort_compact_seg: procedure (); if free_source_message_bits /* this flag is only set while acutally copying */ then if source_mseg_operation.message_info.ms_ptr ^= null () then do; free source_mseg_message_bits in (system_area); source_mseg_operation.message_info.ms_ptr = null (); end; if target_mseg_ptr ^= null () then do; call release_temp_segment_ (operation_name, target_mseg_ptr, (0)); target_mseg_ptr = null (); end; return; end abort_compact_seg; %page; /* Copy the segment -- This entrypoint doesn't use mseg_operation_ptr as we are invoked with two message segments which must be given equal treatment in terms of begin/finish/abort operation actions. */ mseg_segment_$copy_seg: entry (P_source_mseg_operation_ptr, P_target_mseg_operation_ptr, P_error_on_target, P_code); call setup_operation (); /* for cleanup handler */ source_mseg_operation_ptr, target_mseg_operation_ptr = null (); salvage_if_errors, free_source_message_bits = "0"b; operation_specific_return = return_from_copy_seg; operation_specific_abort = abort_copy_seg; on cleanup call operation_was_aborted (); /*** Lock the target segment and verify that it is, in fact, empty */ segment_in_error = TARGET; target_mseg_operation_ptr = P_target_mseg_operation_ptr; call mseg_utils_$begin_operation (mseg_operations_$copy_seg_target, target_mseg_operation_ptr, operation_name, target_mseg_dir_name, target_mseg_entryname, target_mseg_ptr, rqo_detected, code); if rqo_detected then call return_from_operation (error_table_$rqover); else if code ^= 0 then call return_from_operation (code); if (target_mseg_segment_header.n_messages ^= 0) | target_mseg_segment_header.wakeup_state_set then call return_from_operation (error_table_$clnzero); /*** Lock the source segment -- If it's empty, we're done. */ segment_in_error = SOURCE; source_mseg_operation_ptr = P_source_mseg_operation_ptr; call mseg_utils_$begin_operation (mseg_operations_$copy_seg_source, source_mseg_operation_ptr, operation_name, source_mseg_dir_name, source_mseg_entryname, source_mseg_ptr, rqo_detected, code); if rqo_detected /* couldn't even lock the source: there's nothing to copy */ then call return_from_operation (0); else if code ^= 0 then call return_from_operation (code); /*** Verify that the max length of the target is, at least, as large as the source */ segment_in_error = SOURCE; call hcs_$get_max_length_seg (source_mseg_ptr, source_max_length, code); if code ^= 0 then call return_from_operation (code); segment_in_error = TARGET; call hcs_$get_max_length_seg (target_mseg_ptr, target_max_length, code); if code ^= 0 then call return_from_operation (code); if target_max_length < source_max_length /* it may not all fit */ then call return_from_operation (error_table_$invalid_max_length); /*** Everything looks OK -- Copy the segment */ salvage_if_errors = "1"b; /* RQO on source or any error on target should salvage */ on record_quota_overflow call return_rqover_from_operation (); call initialize_target_header ("0"b); /* do not copy the source's wakeup state */ call copy_messages (); revert record_quota_overflow; call return_from_operation (0); /* success! */ /* Return after completion of the copy_seg operation -- If an RQO occured while accessing the source segment, we will salvage it because a properly formed message segment should never have message block offsets which reference an all zero page and, as we are handling RQO ourselves, the standard abort_operation salvage will not occur. On the other hand, if any error is detected while accessing the target segment, we will salvage it because we shouldn't get an error adding messages. */ return_from_copy_seg: procedure (p_code); dcl p_code fixed binary (35) parameter; if salvage_if_errors & (p_code ^= 0) /* the flag is only set while actually copying */ then if segment_in_error = SOURCE then if p_code = error_table_$rqover then call mseg_utils_$salvage_for_cause (source_mseg_operation_ptr, error_table_$rqover); else ; else if segment_in_error = TARGET then if p_code ^= error_table_$bad_segment then do; /* only salvage if mseg_message_ hasn't already done so */ call mseg_utils_$salvage_for_cause (target_mseg_operation_ptr, p_code); if p_code ^= error_table_$rqover then p_code = error_table_$bad_segment; end; if free_source_message_bits /* this flag is also only set while acutally copying */ then if source_mseg_operation.message_info.ms_ptr ^= null () then do; free source_mseg_message_bits in (system_area); source_mseg_operation.message_info.ms_ptr = null (); end; if target_mseg_operation_ptr ^= null () then call mseg_utils_$finish_operation (target_mseg_operation_ptr); if source_mseg_operation_ptr ^= null () then call mseg_utils_$finish_operation (source_mseg_operation_ptr); P_error_on_target = (segment_in_error = TARGET); /* tell caller where (if anywhere) the error occured */ return; end return_from_copy_seg; /* Abort the copy_seg operation */ abort_copy_seg: procedure (); if free_source_message_bits /* this flag is only set while acutally copying */ then if source_mseg_operation.message_info.ms_ptr ^= null () then do; free source_mseg_message_bits in (system_area); source_mseg_operation.message_info.ms_ptr = null (); end; call mseg_utils_$abort_operation (source_mseg_operation_ptr); call mseg_utils_$abort_operation (target_mseg_operation_ptr); return; end abort_copy_seg; %page; /* Get the salvaged flag -- The salvaged indicator is set whenever the message segment is salvaged and remains set until it explicitly reset by someone with "d" extended access to the segment. */ mseg_segment_$get_salvaged_flag_seg: entry (P_mseg_operation_ptr, P_salvaged_flag, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$get_salvaged_flag_seg); if rqo_detected /* the header is zero and accessing it causes RQOs, */ then P_salvaged_flag = "0"b; /* ... so we know the flag is off without actually looking */ else if code = 0 /* we can look at the header without trouble */ then P_salvaged_flag = mseg_segment.flags.salvaged; call return_from_operation (code); %page; /* Get the wakeup acceptance state */ mseg_segment_$get_wakeup_state_seg: entry (P_mseg_operation_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$get_wakeup_state_seg); if rqo_detected /* header's empty so no one is accepting wakeups here */ then call return_from_operation (error_table_$messages_off); else if code ^= 0 then call return_from_operation (code); if ^mseg_segment.wakeup_state_set then call return_from_operation (error_table_$messages_off); call get_wakeup_state_seg (); call return_from_operation (0); /* Actually get the wakeup state -- This internal procedure is only invoked if the message segment's header claims that the wakeup state is actually present. In earlier version 5 message segments, the wakeup state was actually stored in several pieces throughout the header. This internal procedure is also used by compact_seg. */ get_wakeup_state_seg: procedure (); /** format: idind30 */ dcl 1 old_wakeup_state aligned, 2 state, 3 switches aligned, 4 allow_normal bit (1) unaligned, 4 allow_urgent bit (1) unaligned, 4 pad bit (34) unaligned, 3 lock_id bit (36) aligned, 3 event_channel fixed bin (71), 3 process_id bit (36) aligned, 2 pad (64 - 5) bit (36) aligned; /* format: idind20 */ if mseg_segment.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1 then mseg_operation.wakeup_state = mseg_segment.wakeup_state.state; else do; /* early version 5 message segment */ unspec (old_wakeup_state) = unspec (header_msg); mseg_operation.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1; string (mseg_operation.wakeup_state.flags) = string (old_wakeup_state.switches); mseg_operation.wakeup_state.event_channel = old_wakeup_state.event_channel; mseg_operation.wakeup_state.access_class = header_msg_access_class; mseg_operation.wakeup_state.process_id = old_wakeup_state.process_id; mseg_operation.wakeup_state.lock_id = old_wakeup_state.lock_id; end; mseg_operation.wakeup_state_valid = "1"b; /* it's very definitely OK now */ return; end get_wakeup_state_seg; %page; /* Reset the salvaged flag */ mseg_segment_$reset_salvaged_flag_seg: entry (P_mseg_operation_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$reset_salvaged_flag_seg); if rqo_detected /* header's empty so the salvaged flag is already reset */ then call return_from_operation (0); else if code ^= 0 then call return_from_operation (code); if mseg_segment.flags.salvaged then do; mseg_segment.flags.salvaged = "0"b; /* actually reset the flag */ if mseg_operation.call_admin_gate & ^mseg_operation.suppress_access_checks & mseg_operation.access_info.multiclass then do; /* audit the covert channel */ string (local_aef) = ""b; local_aef.grant = "1"b; local_aef.cc_10_100 = "1"b; call access_audit_r1_$log_obj_ptr (operation_name, mseg_operation.validation_level, string (local_aef), access_operations_$mseg_attr_mod, mseg_ptr, 0, null (), 0, "Message segment salvage flag reset."); end; end; call return_from_operation (0); %page; /* Reset the wakeup acceptance state (i.e., turn it off) */ mseg_segment_$reset_wakeup_state_seg: entry (P_mseg_operation_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$reset_wakeup_state_seg); if rqo_detected /* header's empty so the wakeup state is already reset */ then call return_from_operation (0); else if code ^= 0 then call return_from_operation (code); mseg_segment.wakeup_state_set = "0"b; unspec (mseg_segment.wakeup_state) = ""b; call return_from_operation (0); %page; /* Set the max length */ mseg_segment_$set_max_length_seg: entry (P_mseg_operation_ptr, P_max_length, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$set_max_length_seg); if rqo_detected then do; /*** The header is empty and any attempts to access it cause an RQO. We can still try to set the max length, however, by using a local copy of the header while being careful not to reference its block map which doesn't exist. */ mseg_ptr = addr (local_mseg_segment_header); mseg_segment.n_messages = 0; mseg_segment.block_size = mseg_data_$block_size; initialize_block_map = "0"b; end; else if code = 0 then do; /*** We can access the header without problems. */ if mseg_segment.block_size = 0 then mseg_segment.block_size = mseg_data_$block_size; initialize_block_map = "1"b; end; else call return_from_operation (code); /* couldn't get to the segment at all */ if mseg_segment.n_messages > 0 then call return_from_operation (error_table_$action_not_performed); /*** The new max length must be large enough to hold the header and a single zero length message. */ if P_max_length <= 0 then call return_from_operation (error_table_$invalid_max_length); n_new_blocks = divide (P_max_length, mseg_segment.block_size, 18, 0); /* format: off */ n_new_header_blocks = divide ((currentsize (local_mseg_segment_header) + divide ((n_new_blocks + 35), 36, 18, 0) + mseg_segment.block_size - 1), mseg_segment.block_size, 18, 0); /* format: on */ if n_new_blocks <= n_new_header_blocks then call return_from_operation (error_table_$invalid_max_length); /*** The new max length is OK -- set it */ call hcs_$set_max_length_seg (mseg_operation.mseg_ptr, P_max_length, code); if (code = 0) & initialize_block_map then do; /*** We set the max length and can access the actual header -- Initialize the block map. */ mseg_segment.n_blocks_allocated = n_new_blocks; mseg_segment.n_blocks_unused = n_new_blocks - n_new_header_blocks; mseg_segment.block_map.map = copy ("1"b, n_new_header_blocks); end; call return_from_operation (code); %page; /* Set the wakeup acceptance state */ mseg_segment_$set_wakeup_state_seg: entry (P_mseg_operation_ptr, P_code); call setup_operation (); /* for cleanup handler */ on cleanup call operation_was_aborted (); call begin_operation (mseg_operations_$set_wakeup_state_seg); if rqo_detected then call return_from_operation (error_table_$rqover); else if code ^= 0 then call return_from_operation (code); mseg_segment.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1; mseg_segment.wakeup_state.flags = mseg_operation.wakeup_state.flags; mseg_segment.wakeup_state.event_channel = mseg_operation.wakeup_state.event_channel; mseg_segment.wakeup_state.access_class = aim_util_$get_access_class (mseg_operation.caller.authorization); mseg_segment.wakeup_state.process_id = get_process_id_ (); mseg_segment.wakeup_state.lock_id = mseg_data_$lock_id; unspec (mseg_segment.header.wakeup_state.pad) = ""b; mseg_segment.wakeup_state_set = "1"b; /* it's now set */ call return_from_operation (0); %page; /* Common initialization for all operations */ setup_operation: procedure (); code = 0; operation_specific_abort = nulle; /* nothing special when we abort or return (yet) */ operation_specific_return = nulle; mseg_operation_ptr = null (); return; end setup_operation; /* Begin the operation -- This procedure isn't part of setup_operation so that we can be certain to have a cleanup handler available at all times that the message segment may be in use. */ begin_operation: procedure (p_mseg_operation_id); dcl p_mseg_operation_id bit (36) aligned parameter; mseg_operation_ptr = P_mseg_operation_ptr; call mseg_utils_$begin_operation (p_mseg_operation_id, mseg_operation_ptr, operation_name, mseg_dir_name, mseg_entryname, mseg_ptr, rqo_detected, code); return; end begin_operation; /* The "null" entry which indicates that there's no special abort/return processing for an operation */ nulle: procedure (); return; end nulle; %page; /* Return after completion of an operation */ return_from_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; if operation_specific_return ^= nulle /* let the operation do anything special */ then call operation_specific_return (p_code); if mseg_operation_ptr ^= null () /* may be invoked before we've called begin_operation */ then call mseg_utils_$finish_operation (mseg_operation_ptr); P_code = p_code; /* set our caller's status code */ go to RETURN_FROM_OPERATION; end return_from_operation; RETURN_FROM_OPERATION: return; /* Return error_table_$rqover to our caller after an RQO is detected */ return_rqover_from_operation: procedure (); if operation_specific_return ^= nulle /* let the operation do anything special */ then call operation_specific_return (error_table_$rqover); if mseg_operation_ptr ^= null () /* may be invoked by copy_seg which doesn't use this value */ then call mseg_utils_$finish_operation (mseg_operation_ptr); P_code = error_table_$rqover; /* set our caller's status code */ go to RETURN_FROM_OPERATION; end return_rqover_from_operation; /* Abort an operation */ operation_was_aborted: procedure (); if operation_specific_abort ^= nulle /* let the operation do anything special */ then call operation_specific_abort (); call mseg_utils_$abort_operation (mseg_operation_ptr); return; end operation_was_aborted; %page; /* Finds the last one bit in a bit string as index (reverse (bit_string), "1"b) is too slow */ find_last_one_bit: procedure (p_bit_string) returns (fixed binary (24)); dcl p_bit_string bit (*) unaligned parameter; dcl the_bits_as_chars character (n_chars) aligned based (addr (p_bit_string)); dcl the_char character (1) aligned; dcl the_char_as_bits bit (9) aligned based (addr (the_char)); dcl (n_bits, bit_idx) fixed binary (24); dcl (n_chars, char_idx) fixed binary (21); n_bits = length (p_bit_string); if mod (n_bits, 9) ^= 0 then do; /* must check the last bits by hand */ do bit_idx = 0 to (mod (n_bits, 9) - 1); if substr (p_bit_string, (n_bits - bit_idx), 1) then return ((n_bits - bit_idx)); end; n_bits = n_bits - mod (n_bits, 9); /* ... they were all zero */ end; n_chars = divide (n_bits, 9, 21, 0); char_idx = length (rtrim (the_bits_as_chars, low (1))); if char_idx = 0 then return (0); /* no one bits at all */ the_char = substr (the_bits_as_chars, char_idx, 1); do bit_idx = 9 to 1 by -1; if substr (the_char_as_bits, bit_idx) then return ((9 * (char_idx - 1)) + bit_idx); end; return ((9 * (char_idx - 1))); /* won't get here, but ... */ end find_last_one_bit; %page; /* Initialize the copy target's header -- Our caller has already locked the segment and determined its max length. */ initialize_target_header: procedure (p_copy_source_wakeup_state); dcl p_copy_source_wakeup_state bit (1) aligned parameter; target_mseg_segment_header.n_messages, target_mseg_segment_header.date_time_last_salvaged = 0; unspec (target_mseg_segment_header.message_chain) = ""b; string (target_mseg_segment_header.flags) = ""b; unspec (target_mseg_segment_header.wakeup_state) = ""b; unspec (target_mseg_segment_header.hash_table) = ""b; target_mseg_segment_header.sentinel = MSEG_SEGMENT_SENTINEL; target_mseg_segment_header.version = MSEG_SEGMENT_VERSION_5; target_mseg_segment_header.block_size = mseg_data_$block_size; target_mseg_segment_header.n_blocks_allocated = divide (target_max_length, target_mseg_segment_header.block_size, 18, 0); /* format: off */ n_new_header_blocks = divide ((currentsize (target_mseg_segment_header) + divide ((target_mseg_segment_header.n_blocks_allocated + 35), 36, 18, 0) + target_mseg_segment_header.block_size - 1), target_mseg_segment_header.block_size, 18, 0); /* format: on */ target_mseg_segment_header.n_blocks_unused = target_mseg_segment_header.n_blocks_allocated - n_new_header_blocks; target_mseg_ptr -> mseg_segment.block_map.map = copy ("1"b, n_new_header_blocks); if p_copy_source_wakeup_state then do; if source_mseg_operation.wakeup_state_valid then target_mseg_segment_header.wakeup_state.state = source_mseg_operation.wakeup_state; target_mseg_segment_header.wakeup_state_set = source_mseg_operation.wakeup_state_valid; end; return; end initialize_target_header; %page; /* Copy all messages in the source message segment to the target -- We call mseg_message_$read_message_for_mseg and mseg_message_$add_message_for_mseg to do the actuall reading/writing. These special entrypoints are implemented knowing that they are invoked with the message segment's already locked. */ copy_messages: procedure (); source_mseg_operation.suppress_access_checks, /* insure mseg_message_ copies all the messages */ target_mseg_operation.suppress_access_checks = "1"b; target_mseg_operation.add_message_info_all_valid = "1"b; source_mseg_operation.message_info.version = MSEG_MESSAGE_INFO_V1; string (source_mseg_operation.message_info.control_flags) = ""b; source_mseg_operation.message_info.ms_ptr = null (); system_area_ptr = get_system_free_area_ (); free_source_message_bits = "1"b; /* force cleanup handlers to get rid of leftovers */ segment_in_error = SOURCE; source_mseg_operation.message_info.message_code = MSEG_READ_FIRST; call mseg_message_$read_message_for_mseg (source_mseg_operation_ptr, operation_name, system_area_ptr, code); do while (code = 0); segment_in_error = TARGET; target_mseg_operation.message_info = source_mseg_operation.message_info; call mseg_message_$add_message_for_mseg (target_mseg_operation_ptr, operation_name, code); if code ^= 0 then call return_from_operation (code); if source_mseg_operation.message_info.ms_ptr ^= null () then do; free source_mseg_message_bits in (system_area); source_mseg_operation.message_info.ms_ptr = null (); end; segment_in_error = SOURCE; source_mseg_operation.message_info.message_code = MSEG_READ_AFTER_SPECIFIED; call mseg_message_$read_message_for_mseg (source_mseg_operation_ptr, operation_name, system_area_ptr, code) ; end; if code ^= error_table_$no_message /* we were unable to read a message */ then call return_from_operation (code); free_source_message_bits = "0"b; return; end copy_messages; /* format: off */ %page; %include mseg_data_; %page; %include mseg_segment; %page; %include mseg_wakeup_state; %page; %include mseg_operation; %page; %include mseg_message_info; %page; %include entry_access_info; %page; %include mseg_operations_; %page; %include access_audit_eventflags; %page; /* BEGIN MESSAGE DOCUMENTATION Message: Audit (mseg_$reset_salvaged_flag_seg): GRANTED modifying message segment attributes ADDED_INFO S: $access_audit T: $run M: The salvaged indicator of a message segment or mailbox was reset at the user's request. Repeated occurences of this event over a short period of time could indicate an attempt to exploit a moderate bandwidth covert channel. ADDED_INFO will identify the user and segment in question. A: $notify_ssa END MESSAGE DOCUMENTATION */ /* format: on */ end mseg_segment_;  mseg_utils_.pl1 05/22/85 0725.7r w 05/22/85 0649.2 637308 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* Utilities used by the message segment primitive operations (mseg_) */ /* Created: April 1985 by G. Palter based upon mseg_, mseg_error_, mseg_convert_, ms_salvager_, and ms_salv_util_ */ /* Modified: 20 May 1985 by G. Palter to avoid spurious RQOs while salvaging */ /* format: style3,linecom */ mseg_utils_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_mseg_operation_ptr pointer parameter; dcl P_code fixed binary (35) parameter; /* begin_operation: indicates whether we setup OK (Output); salvage_for_cause: why we must salvage (Input) */ dcl P_operation_id bit (36) aligned parameter; /* begin_operation: the operation to be started */ dcl P_operation_name character (*) parameter; /* begin_operation: set to the name of the operation */ dcl P_mseg_dir_name character (*) parameter; /* begin_operation: set to segment's parent if known */ dcl P_mseg_entryname character (*) parameter; /* begin_operation: set to segment' entryname if known */ dcl P_mseg_ptr pointer parameter; /* begin_operation: set -> the segment if available */ dcl P_rqo_detected bit (1) aligned parameter; /* begin_operation: set ON => an RQO occured while locking */ /* Local copies of parameters */ dcl operation_name character (64); dcl mseg_dir_name character (168); dcl mseg_entryname character (32); dcl rqo_detected bit (1) aligned; dcl code fixed binary (35); /* Remaining declarations */ dcl 1 mseg_segment_header aligned based (mseg_ptr) like mseg_segment.header; dcl 1 long_status aligned like status_branch; dcl test_lock bit (36) aligned; dcl salvage_for_cause_arguments pointer; dcl path_code fixed binary (35); dcl (salvage_report_text_lth, callers_report_text_lth) fixed binary (21); dcl (mseg_max_length, mseg_cur_length) fixed binary (19); dcl (n_header_blocks, n_possible_messages, n_messages_recovered) fixed binary (18); dcl (n_arguments, prefix_lth) fixed binary; dcl MSEG_UTILS_ character (32) static options (constant) initial ("mseg_utils_"); /* format: off */ dcl SALVAGER_AND_UPGRADING_ACTIONS (0:9) character (64) varying static options (constant) initial ("", "Call to hcs_$get_access_info_seg failed", "Call to hcs_$get_max_length_seg failed", "Unable to compute size for allocating message blocks", "Trying to locate upgrade support procedure", "Unable to salvage the segment prior to upgrading it", "Initializing the temporary upgraded segment in [pd]", "Copying messages into the temporary upgraded segment in [pd]", "Call to hcs_$status_long failed", "Rebuilding the contents of the message segment"); dcl (CALL_GET_ACCESS_INFO initial (1), CALL_GET_MAX_LENGTH initial (2), COMPUTING_BLOCK_SIZE initial (3), FINDING_SUPPORT_PROCEDURE initial (4), SALVAGING_ORIGINAL_SEGMENT initial (5), PREPARING_UPGRADED_TEMPORARY initial (6), CREATING_UPGRADED_TEMPORARY initial (7), CALL_STATUS_LONG initial (8), REBUILDING_SEGMENT initial (9) ) fixed binary static options (constant); dcl (error_table_$bad_segment, error_table_$bad_subr_arg, error_table_$bigarg, error_table_$improper_data_format, error_table_$invalid_max_length, error_table_$lock_wait_time_exceeded, error_table_$no_message, error_table_$no_s_permission, error_table_$not_seg_type, error_table_$notalloc, error_table_$null_info_ptr, error_table_$rqover, error_table_$seg_busted, error_table_$segfault, error_table_$unimplemented_version) fixed binary (35) external; /* format: on */ dcl sys_info$ring1_privilege bit (36) aligned external; dcl admin_gate_$guaranteed_eligibility_off entry (); dcl admin_gate_$guaranteed_eligibility_on entry (); dcl admin_gate_$syserr_error_code entry (/* fixed binary, fixed binary (35), character (*) */) options (variable); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl aim_check_$in_range entry (bit (72) aligned, (2) bit (72) aligned) returns (bit (1) aligned); dcl aim_util_$get_privileges entry (bit (72) aligned) returns (bit (36) aligned); dcl cu_$arg_count entry (fixed binary, fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl find_condition_info_ entry (pointer, pointer, fixed binary (35)); dcl get_group_id_ entry () returns (character (32)); dcl get_lock_id_ entry () returns (bit (36) aligned); dcl get_process_max_authorization_ entry () returns (bit (72) aligned); dcl get_ring_ entry () returns (fixed binary (3)); dcl get_system_free_area_ entry () returns (pointer); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35)); dcl hcs_$get_access_info_seg entry (pointer, pointer, fixed binary (35)); dcl hcs_$get_max_length_seg entry (pointer, fixed binary (19), fixed binary (35)); dcl hcs_$make_entry entry (pointer, character (*), character (*), entry, fixed binary (35)); dcl hcs_$set_damaged_sw_seg entry (pointer, bit (1) aligned, fixed binary (35)); dcl hcs_$status_long entry (character (*), character (*), fixed binary (1), pointer, pointer, fixed binary (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1) aligned, bit (1) aligned); dcl ioa_$rsnpnnl entry () options (variable); dcl mseg_message_$add_message_for_mseg entry (pointer, character (*), fixed binary (35)); dcl mseg_utils_$salvage_for_cause entry (/* pointer, fixed binary (35) */) options (variable); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl set_lock_$lock entry (bit (36) aligned, fixed binary, fixed binary (35)); dcl set_lock_$unlock entry (bit (36) aligned, fixed binary (35)); dcl sort_items_indirect_$bit entry (pointer, pointer, fixed binary (24)); dcl sub_err_ entry () options (variable); dcl (addr, clock, codeptr, copy, convert, currentsize, divide, fixed, hbound, index, lbound, length, max, mod, null, rtrim, setwordno, stacq, string, substr, unspec, wordno) builtin; dcl (cleanup, record_quota_overflow, seg_fault_error) condition; %page; /* Initialize the perprocess values in mseg_data_ */ mseg_utils_$initialize: entry (); mseg_data_$group_id = get_group_id_ (); mseg_data_$lock_id = get_lock_id_ (); mseg_data_$process_max_authorization = get_process_max_authorization_ (); mseg_data_$execution_ring = get_ring_ (); /* this is OK as static data is per ring ... */ return; %page; /* Begin an operation -- First, we verify that the supplied mseg_operation includes the fields required for the operation. We then guarantee elibility, if possible, and perform the actions requested by the operation's begin flags, if any. */ mseg_utils_$begin_operation: entry (P_operation_id, P_mseg_operation_ptr, P_operation_name, P_mseg_dir_name, P_mseg_entryname, P_mseg_ptr, P_rqo_detected, P_code); mseg_operation_data_ptr = addr (P_operation_id); if (mseg_operation_data.operation_id < lbound (mseg_operations_$names, 1)) | (mseg_operation_data.operation_id > hbound (mseg_operations_$names, 1)) then call sub_err_ (error_table_$bad_subr_arg, MSEG_UTILS_, ACTION_CANT_RESTART, null (), 0, "Operation ID = ^12.3b", P_operation_id); operation_name = mseg_operations_$names (mseg_operation_data.operation_id); mseg_operation_ptr = P_mseg_operation_ptr; if mseg_operation_ptr = null () then call sub_err_ (error_table_$null_info_ptr, operation_name, ACTION_CANT_RESTART, null (), 0); if mseg_operation.version ^= MSEG_OPERATION_VERSION_1 then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0, "mseg_operation.version = ^d.", mseg_operation.version); mseg_operation.operation = P_operation_id; /* set the operation code */ mseg_operation_data_ptr = addr (mseg_operation.operation); mseg_dir_name = ""; /* initialize output values */ mseg_entryname = ""; mseg_ptr = null (); rqo_detected = "0"b; code = 0; mseg_operation_data.already_salvaged, /* for cleanup handlers and the like */ mseg_operation_data.unlock_segment = "0"b; /*** Check that required data is present -- In the current implementation, all operations require either the pathname or mseg_ptr. Of the remaining fields in an mseg_operation, the primitives will only occasionally use the access_info, message_info, and wakeup_state structures. */ if mseg_operation_data.required_data.pathname & mseg_operation_data.required_data.mseg_ptr then do; /*** Either the pathname or mseg_ptr or both may be used */ if ^mseg_operation.mseg_pathname_valid & ^mseg_operation.mseg_ptr_valid then call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0, "The mseg_operation does not include either a valid pathname or a valid mseg_ptr."); if mseg_operation.access_info_valid then do; /* always give preference to the pathname derived in ring 0 */ mseg_dir_name = mseg_operation.access_info.dir_name; mseg_entryname = mseg_operation.access_info.entryname; end; else if mseg_operation.mseg_pathname_valid then do; /* caller has supplied the pathname */ mseg_dir_name = mseg_operation.dir_name; mseg_entryname = mseg_operation.entryname; end; if mseg_operation.mseg_ptr_valid /* caller has also supplied an mseg_ptr */ then mseg_ptr = mseg_operation.mseg_ptr; end; else if mseg_operation_data.required_data.pathname then /*** This operation requires a valid pathname */ if mseg_operation.access_info_valid then do; /* always give preference to the pathname derived in ring 0 */ mseg_dir_name = mseg_operation.access_info.dir_name; mseg_entryname = mseg_operation.access_info.entryname; end; else if mseg_operation.mseg_pathname_valid then do; /* caller has supplied the pathname */ mseg_dir_name = mseg_operation.dir_name; mseg_entryname = mseg_operation.entryname; end; else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0, "The mseg_operation does not include a valid pathname."); else if mseg_operation_data.required_data.mseg_ptr then /*** This operation requires a valid mseg_ptr */ if mseg_operation.mseg_ptr_valid then mseg_ptr = mseg_operation.mseg_ptr; else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0, "The mseg_operation does not include a valid mseg_ptr."); else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0, "mseg_operation.operation does not request either the pathname or mseg_ptr."); if mseg_operation_data.required_data.access_info then if ^mseg_operation.suppress_access_checks /* we'll only actually need it if checking access */ then if mseg_operation.access_info_valid then if mseg_operation.access_info.version ^= ENTRY_ACCESS_INFO_VERSION_1 then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0, "mseg_operation.access_info.version = ""^a"".", mseg_operation.access_info.version); else ; else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0, "The mseg_operation does not include a valid access_info structure."); if mseg_operation_data.required_data.message_info then if mseg_operation.message_info_valid then if mseg_operation.message_info.version ^= MSEG_MESSAGE_INFO_V1 then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0, "mseg_operation.message_info.version = ""^a"".", mseg_operation.message_info.version); else ; else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0, "The mseg_operation does not include a valid message_info structure."); if mseg_operation_data.required_data.wakeup_state then if mseg_operation.wakeup_state_valid then if mseg_operation.wakeup_state.version ^= MSEG_WAKEUP_STATE_VERSION_1 then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0, "mseg_operation.wakeup_state.version = ""^a"".", mseg_operation.message_info.version); else ; else call sub_err_ (error_table_$bad_subr_arg, operation_name, ACTION_CANT_RESTART, null (), 0, "The mseg_operation does not include a valid wakeup_state structure."); if mseg_operation_data.required_data.wakeup_state_version then if mseg_operation.wakeup_state.version ^= MSEG_WAKEUP_STATE_VERSION_1 then call sub_err_ (error_table_$unimplemented_version, operation_name, ACTION_CANT_RESTART, null (), 0, "mseg_operation.wakeup_state.version = ""^a"".", mseg_operation.message_info.version); /*** Guarantee eligibility if running in the admin ring (ring 1) */ if mseg_operation.call_admin_gate then call admin_gate_$guaranteed_eligibility_on (); /*** Lock the segment if requested */ if mseg_operation_data.begin_flags.lock_segment then do; on seg_fault_error call seg_fault_handler (); on record_quota_overflow begin; rqo_detected = "1"b; /* let the caller handle RQOs */ go to RETURN_FROM_BEGIN_OPERATION; end; /* ... avoids making return_from_begin_operation nonquick */ if stacq (mseg_segment.lock, mseg_data_$lock_id, (36)"0"b) then code = 0; else call set_lock_$lock (mseg_segment.lock, 20, code); revert record_quota_overflow; revert seg_fault_error; if mseg_operation_data.begin_flags.dont_check_lock_results then call return_from_begin_operation (code); /* our caller handles the lock non-standardly */ else if code = 0 /* we've locked it */ then mseg_operation_data.finish_flags.unlock_segment = "1"b; else if code = error_table_$lock_wait_time_exceeded then call return_from_begin_operation (code); /* some other process is using the segment */ else call salvage_and_return_from_begin (code); end; /* invalid_lock_reset or locked_by_this_process */ else call return_from_begin_operation (0); /* don't try anything else if we can't lock the segment */ /*** Check the header for consistency and initialize it if requested */ if mseg_operation_data.begin_flags.check_header_consistency then if (mseg_segment.sentinel = ""b) & (mseg_segment.header.version = 0) then if mseg_operation_data.begin_flags.initialize_header then do; /*** This segment does not have a header -- However, the operation about to be performed needs the header to behave properly. Therefore, we must initialize the header now. */ mseg_segment.sentinel = MSEG_SEGMENT_SENTINEL; mseg_segment.header.version = MSEG_SEGMENT_VERSION_5; call hcs_$get_max_length_seg (mseg_ptr, mseg_max_length, code); if code ^= 0 then call return_from_begin_operation (code); /*** Compute the number of available blocks in the segment based on its max length. */ mseg_segment.block_size = mseg_data_$block_size; mseg_segment.n_blocks_allocated = divide (mseg_max_length, mseg_segment.block_size, 18, 0); /* format: off */ n_header_blocks = divide ((currentsize (mseg_segment_header) + divide ((mseg_segment.n_blocks_allocated + 35), 36, 18, 0) + mseg_segment.block_size - 1), mseg_segment.block_size, 18, 0); /* format: on */ if mseg_segment.n_blocks_allocated <= n_header_blocks then /*** The segment doesn't have room for any messages. */ call return_from_begin_operation (error_table_$invalid_max_length); mseg_segment.n_blocks_unused = mseg_segment.n_blocks_allocated - n_header_blocks; /*** Record that the header has been allocated. */ mseg_segment.block_map.map = copy ("1"b, n_header_blocks); end; else /*** This segment does not have a header -- Fortunately, the operation about to be performed doesn't require the header for to behave properly so we needn't do anything more. */ ; else do; /*** This segment appears to have a header -- Perform automatic conversion if necessary and then make the minimal consistency checks on the header. */ if mseg_segment.header.version ^= MSEG_SEGMENT_VERSION_5 then if (mseg_segment.header.version >= 2) & (mseg_segment.header.version < MSEG_SEGMENT_VERSION_5) then call upgrade_seg (); else call salvage_and_return_from_begin (mseg_format_errors_$bad_mseg_version); if mseg_segment.sentinel ^= MSEG_SEGMENT_SENTINEL then call salvage_and_return_from_begin (mseg_format_errors_$bad_mseg_sentinel); if mseg_segment.modification_in_progress then call salvage_and_return_from_begin (mseg_format_errors_$modification_in_progress); if mseg_segment.salvage_in_progress then call salvage_and_return_from_begin (mseg_format_errors_$salvage_in_progress); end; else call return_from_begin_operation (0); /* don't check count&chains without checking the header */ /*** Check the message count and message chain for consistency if requested */ if mseg_operation_data.begin_flags.check_count_consistency then if mseg_segment.n_messages = 0 then if (mseg_segment.message_chain.first_message ^= 0) | (mseg_segment.message_chain.last_message ^= 0) then call salvage_and_return_from_begin (mseg_format_errors_$inconsistent_message_count); else ; /* no messages and no message chain */ else if mseg_segment.n_messages < 0 then call salvage_and_return_from_begin (mseg_format_errors_$negative_message_count); else /*** if mseg_segment.n_messages > 0 then */ if (mseg_segment.message_chain.first_message = 0) | (mseg_segment.message_chain.last_message = 0) then call salvage_and_return_from_begin (mseg_format_errors_$inconsistent_message_count); /*** All done */ RETURN_FROM_BEGIN_OPERATION: P_operation_name = operation_name; P_mseg_dir_name = mseg_dir_name; P_mseg_entryname = mseg_entryname; P_mseg_ptr = mseg_ptr; P_rqo_detected = rqo_detected; P_code = code; return; /* Return upon completion of the begin_operation entrypoint */ return_from_begin_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; code = p_code; /* set the result code */ go to RETURN_FROM_BEGIN_OPERATION; end return_from_begin_operation; /* Salvage the message segment due to internal inconsistencies and return error_table_$bad_segment to our caller */ salvage_and_return_from_begin: procedure (p_format_error); dcl p_format_error fixed binary (35) parameter; call mseg_utils_$salvage_for_cause (mseg_operation_ptr, p_format_error); call return_from_begin_operation (error_table_$bad_segment); end salvage_and_return_from_begin; %page; /* Finish an operation -- This entrypoint completes the normal processing of an operation whether or not said operation will return a non-zero status code to its caller. This entrypoint will, under control of the finish flags embedded in mseg_operation.operation, truncate the segment if its empty and then unlock it. However, if this operation doesn't hold the lock on the segment, this entrypoint will not even perform these actions as some other process may be using the segment or it may have been deleted if this is the delete_seg operation. In any case, however, we turn off guaranteed eligibility if we had turned it on earlier. WARNING -- Do not call this entrypoint in a cleanup handler. A cleanup handler must call abort_operation, instead. */ mseg_utils_$finish_operation: entry (P_mseg_operation_ptr); mseg_operation_ptr = P_mseg_operation_ptr; mseg_operation_data_ptr = addr (mseg_operation.operation); if ^mseg_operation_data.finish_flags.unlock_segment then return; mseg_ptr = mseg_operation.mseg_ptr; if mseg_operation_data.finish_flags.truncate_if_possible then if (mseg_segment.n_messages = 0) /* truncate only if no messages ... */ & ^mseg_segment.flags.wakeup_state_set /* ... and no one is accepting wakeups ... */ & ^mseg_segment.flags.salvaged /* ... and it wasn't salvaged */ then call hcs_$truncate_seg (mseg_ptr, 1, (0)); if ^stacq (mseg_segment.lock, (36)"0"b, mseg_data_$lock_id) then call set_lock_$unlock (mseg_segment.lock, (0)); mseg_operation_data.finish_flags.unlock_segment = "0"b; if mseg_operation.call_admin_gate then call admin_gate_$guaranteed_eligibility_off (); return; %page; /* Abort an operation -- This entrypoint aborts the currently running operation. If the operation had locked the message segment, this entrypoint will salvage and unlock the segment as it is possible that it has been left in an inconsistent state by whatever event has caused the operation to be unwound. However, this entrypoint will not take these actions unless the current operation actually locked the segment; otherwise, we might salvage the segment while it was being used by another process. In any case, however, we turn off guaranteed eligibility if we had turned it on earlier. WARNING -- Do not call this entrypoint except in a cleanup handler. Use finish_operation, instead, for all other circumstances. */ mseg_utils_$abort_operation: entry (P_mseg_operation_ptr); mseg_operation_ptr = P_mseg_operation_ptr; if mseg_operation_ptr = null () /* caller hasn't even got an mseg_operation yet */ then return; if ^mseg_operation.mseg_ptr_valid /* no mseg_ptr -- a file system operation, no doubt */ then return; if mseg_operation.mseg_ptr = null () /* delete_seg operation will null pointer if successful */ then return; mseg_ptr = mseg_operation.mseg_ptr; mseg_operation_data_ptr = addr (mseg_operation.operation); if ^mseg_operation_data.finish_flags.unlock_segment then return; /* we dare not do anything if we don't have it locked */ if ^mseg_operation_data.finish_flags.already_salvaged then call mseg_utils_$salvage_for_cause (mseg_operation_ptr, 0, "The operation was terminated abnormally."); if ^stacq (mseg_segment.lock, (36)"0"b, mseg_data_$lock_id) then call set_lock_$unlock (mseg_segment.lock, (0)); mseg_operation_data.finish_flags.unlock_segment = "0"b; if mseg_operation.call_admin_gate then call admin_gate_$guaranteed_eligibility_off (); return; %page; /* "Queue" to unlock the segment -- This entrypoint is used by those operations which manage the message segment's lock on their own when said operation determines that it has locked the segment and that it should, therefore, be unlocked when the operation finishes. (At present, the only operation which uses this protocol is delete_seg.) */ mseg_utils_$request_unlock_on_finish: entry (P_mseg_operation_ptr); mseg_operation_ptr = P_mseg_operation_ptr; mseg_operation_data_ptr = addr (mseg_operation.operation); if mseg_operation_data.finish_flags.unlock_segment then return; /* it's already going to be unlocked */ mseg_ptr = mseg_operation.mseg_ptr; /*** Don't bother to "queue" to unlock the segment unless we already hold the lock */ test_lock = mseg_segment.lock; if stacq (test_lock, (36)"0"b, mseg_data_$lock_id) then mseg_operation_data.finish_flags.unlock_segment = "1"b; return; %page; /* Salvage a message segment due to inconsistencies detected by our caller -- Before salvaging, an error report is constructed from our caller's error code and, optional, ioa_ control string and arguments. If we are running in the adminitrative ring (ring 1), the report is placed in the SYSERR log; otherwise, it is displayed via sub_err_. */ mseg_utils_$salvage_for_cause: entry (P_mseg_operation_ptr, P_code) options (variable); mseg_operation_ptr = P_mseg_operation_ptr; mseg_operation_data_ptr = addr (mseg_operation.operation); if mseg_operation_data.finish_flags.already_salvaged then return; /* don't try to salvage more than once per operation */ mseg_operation_data.finish_flags.already_salvaged = "1"b; mseg_ptr = mseg_operation.mseg_ptr; if (mseg_operation_data.operation_id < lbound (mseg_operations_$names, 1)) | (mseg_operation_data.operation_id > hbound (mseg_operations_$names, 1)) then operation_name = "mseg_$unknown_operation"; else operation_name = mseg_operations_$names (mseg_operation_data.operation_id); /*** Determine the segment's pathname, minimum and maximum access classes, max length, and current length -- These data are required for proper operation of the salvager. (Actually, the pathname isn't required but is determined by the same call used to get the access classes.) */ if mseg_operation.access_info_valid then do; /* we already have the pathname and access classes */ mseg_dir_name = mseg_operation.access_info.dir_name; mseg_entryname = mseg_operation.access_info.entryname; end; else do; /* we must get the pathname and access classes from ring-0 */ mseg_operation.access_info.version = ENTRY_ACCESS_INFO_VERSION_1; call hcs_$get_access_info_seg (mseg_ptr, addr (mseg_operation.access_info), code); if code ^= 0 /* can't get the info we need: try for pathname for error */ then do; call hcs_$fs_get_path_name (mseg_ptr, mseg_dir_name, (0), mseg_entryname, path_code); call abort_salvage_for_cause ((path_code = 0), CALL_GET_ACCESS_INFO); end; mseg_operation.access_info_valid = "1"b; mseg_dir_name = mseg_operation.access_info.dir_name; mseg_entryname = mseg_operation.access_info.entryname; end; call hcs_$get_max_length_seg (mseg_ptr, mseg_max_length, code); if code ^= 0 then call abort_salvage_for_cause ("1"b, CALL_GET_MAX_LENGTH); call hcs_$status_long (mseg_dir_name, mseg_entryname, 0b, addr (long_status), null (), code); if (code ^= 0) & (code ^= error_table_$no_s_permission) then call abort_salvage_for_cause ("1"b, CALL_STATUS_LONG); if long_status.type ^= Segment then do; code = error_table_$not_seg_type; call abort_salvage_for_cause ("1"b, CALL_STATUS_LONG); end; mseg_cur_length = min ((1024 * long_status.current_length), mseg_max_length); /*** Format and log/print the error report */ prefix_lth = length (rtrim (operation_name)) + length (": "); call cu_$arg_count (n_arguments, (0)); salvage_for_cause_arguments = cu_$arg_list_ptr (); begin options (non_quick); dcl 1 salvage_report unaligned, 2 prefix character (prefix_lth) unaligned, 2 text character (1024 - prefix_lth) unaligned; salvage_report.prefix = rtrim (operation_name) || ": "; call ioa_$rsnpnnl ("Beginning salvage of ^a for ^a.^[^/^5x^]", salvage_report.text, salvage_report_text_lth, pathname_ (mseg_dir_name, mseg_entryname), mseg_operation.caller.group_id, (n_arguments > 2)); if n_arguments > 2 /* caller has supplied additional information */ then do; begin; dcl rest_of_salvage_report_text character (length (salvage_report.text) - salvage_report_text_lth) unaligned defined (salvage_report.text) position (salvage_report_text_lth + 1); call ioa_$general_rs (salvage_for_cause_arguments, 3, 4, rest_of_salvage_report_text, callers_report_text_lth, "0"b, "0"b); end; salvage_report_text_lth = salvage_report_text_lth + callers_report_text_lth; end; if mseg_operation.call_admin_gate then begin; /* report via SYSERR -- include entrypoint name in the text */ dcl salvage_report_text character (prefix_lth + salvage_report_text_lth) unaligned defined (salvage_report) position (1); call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), P_code, "^a^[^/^5x^]", salvage_report_text, (P_code ^= 0)); end; else begin; dcl salvage_report_text character (salvage_report_text_lth) unaligned defined (salvage_report.text); call sub_err_ (P_code, operation_name, ACTION_DEFAULT_RESTART, null (), 0, "^[^/^]^a", (P_code ^= 0), salvage_report_text); end; end; /*** Actually salvage the segment and report the results */ code = 0; call salvage_seg (n_possible_messages, n_messages_recovered); if mseg_operation.call_admin_gate then call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), 0, "^a: Completed salvage of ^a for ^a.^/^5x^d^[ out of ^d possible^;^s^] message^[s^] recovered.", operation_name, pathname_ (mseg_dir_name, mseg_entryname), mseg_operation.caller.group_id, n_messages_recovered, (n_messages_recovered ^= n_possible_messages), n_possible_messages, ((n_messages_recovered ^= 1) | (n_possible_messages ^= 1))); else call sub_err_ (0, operation_name, ACTION_DEFAULT_RESTART, null (), 0, "Completed salvage of ^a for ^a.^/^5x^d^[ out of ^d possible^;^s^] message^[s^] recovered.", pathname_ (mseg_dir_name, mseg_entryname), mseg_operation.caller.group_id, n_messages_recovered, (n_messages_recovered ^= n_possible_messages), n_possible_messages, ((n_messages_recovered ^= 1) | (n_possible_messages ^= 1))); RETURN_FROM_SALVAGE_FOR_CAUSE: return; /* Report our failure to salvage the segment and return to our caller */ abort_salvage_for_cause: procedure (p_have_pathname, p_failed_action); dcl p_have_pathname bit (1) aligned parameter; dcl p_failed_action fixed binary parameter; if mseg_operation.call_admin_gate then call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), code, "^a: Unable to salvage ^[^a^s^;^s^p (pathname unknown)^] for ^a.^/^5x^a^[ --^/^5x^]", operation_name, p_have_pathname, pathname_ (mseg_dir_name, mseg_entryname), mseg_ptr, mseg_operation.caller.group_id, SALVAGER_AND_UPGRADING_ACTIONS (p_failed_action), (code ^= 0)); else call sub_err_ (code, operation_name, ACTION_DEFAULT_RESTART, null (), 0, "^[^/^5x^]^a.^/^5xUnable to salvage ^[^a^s^;^s^p (pathname unknown)^] for ^a.", (code ^= 0), SALVAGER_AND_UPGRADING_ACTIONS (p_failed_action), p_have_pathname, pathname_ (mseg_dir_name, mseg_entryname), mseg_ptr, mseg_operation.caller.group_id); go to RETURN_FROM_SALVAGE_FOR_CAUSE; end abort_salvage_for_cause; %page; /* Handle a segment fault while trying to lock the message segment -- If the fault occured because the segment is damaged, reset the damaged switch, salvage, and retry the locking operation. If the fault occured for some other reason (e.g., a connection failure), simply abort the attempt to lock the segment and return the reason to our caller. */ seg_fault_handler: procedure (); dcl 1 local_ci aligned like condition_info; dcl local_code fixed binary (35); code = error_table_$segfault; /* in case we can't determine the actual reason */ unspec (local_ci) = ""b; local_ci.version = condition_info_version_1; call find_condition_info_ (null (), addr (local_ci), local_code); if local_code = 0 /* found the fault frame ... */ then if local_ci.mc_ptr ^= null () /* ... and the machine conditions ... */ then if local_ci.mc_ptr -> mc.errcode ^= 0 /* ... and they provide specific details */ then code = local_ci.mc_ptr -> mc.errcode; if (code = error_table_$seg_busted) & ^mseg_operation_data.begin_flags.dont_check_lock_results & ^mseg_operation_data.finish_flags.already_salvaged then do; /*** The segment is damaged and we haven't already tried to salvage it. */ call hcs_$set_damaged_sw_seg (mseg_ptr, "0"b, (0)); call mseg_utils_$salvage_for_cause (mseg_operation_ptr, code); if ^stacq (mseg_segment.lock, (36)"0"b, mseg_data_$lock_id) then call set_lock_$unlock (mseg_segment.lock, (0)); return; /* retry */ end; else do; /*** Either it's some other form of segfault or we've already tried to fix it once -- Inform the user that we can't access the segment. He can either try to fix the segment or delete it. */ mseg_operation_data.unlock_segment = "0"b; mseg_operation_data.truncate_if_possible = "0"b; go to RETURN_FROM_BEGIN_OPERATION; end; end seg_fault_handler; %page; /* Upgrade an old format message segment to the current format -- We are always called with the segment locked. */ upgrade_seg: procedure () options (non_quick); dcl 1 original_mseg_segment_header aligned based (original_mseg_ptr) like mseg_segment.header; dcl original_mseg_ptr pointer; dcl 1 upgraded_mseg_segment_header aligned based (upgraded_mseg_ptr) like mseg_segment.header; dcl upgraded_mseg_ptr pointer; dcl original_mseg_message_bits bit (original_operation.message_info.ms_len) aligned based (original_operation.message_info.ms_ptr); dcl upgraded_segment (upgraded_size) bit (36) aligned based; dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl 1 original_operation aligned like mseg_operation; dcl 1 upgraded_operation aligned like mseg_operation; dcl upgrade_procedure_name character (32); dcl salvage_old_segment entry (pointer, bit (1) aligned) variable; dcl get_old_wakeup_state entry (pointer) variable; dcl read_old_message entry (pointer, pointer, fixed binary (35)) variable; dcl (original_mseg_dir_name, upgraded_mseg_dir_name) character (168); dcl (original_mseg_entryname, upgraded_mseg_entryname) character (32); dcl original_version_picture picture "9"; dcl (salvage_completed, rqo_detected) bit (1) aligned; dcl path_code fixed binary (35); dcl upgraded_size fixed binary (19); dcl (n_upgraded_blocks_allocated, n_upgraded_header_blocks, n_messages_discarded) fixed binary (18); dcl original_version fixed binary; mseg_operation_data.finish_flags.already_salvaged = "1"b; /* prevent the current salvager from destroying the segment */ original_operation.message_info.ms_ptr, /* for cleanup handler */ upgraded_mseg_ptr = null (); on cleanup call cleanup_after_upgrade_seg (); code = 0; /*** Determine the segment's pathname, minimum and maximum access classes, and max length -- These data are required for proper upgrading of the segment. (Actually, the pathname isn't required but is determined by the same call used to get the access classes.) */ original_operation = mseg_operation; /* we dare not change our caller's operation */ original_mseg_ptr = original_operation.mseg_ptr; if original_operation.access_info_valid then do; /* we already have the pathname and access classes */ original_mseg_dir_name = original_operation.access_info.dir_name; original_mseg_entryname = original_operation.access_info.entryname; end; else do; /* we must get the pathname and access classes from ring-0 */ original_operation.access_info.version = ENTRY_ACCESS_INFO_VERSION_1; call hcs_$get_access_info_seg (original_mseg_ptr, addr (original_operation.access_info), code); if code ^= 0 /* can't get the info we need: try for pathname for error */ then do; call hcs_$fs_get_path_name (original_mseg_ptr, original_mseg_dir_name, (0), original_mseg_entryname, path_code); call abort_upgrade_seg ((path_code = 0), CALL_GET_ACCESS_INFO); end; original_operation.access_info_valid = "1"b; original_mseg_dir_name = original_operation.access_info.dir_name; original_mseg_entryname = original_operation.access_info.entryname; end; call hcs_$get_max_length_seg (original_mseg_ptr, mseg_max_length, code); if code ^= 0 then call abort_upgrade_seg ("1"b, CALL_GET_MAX_LENGTH); /*** Compute the size of the upgraded segment's header and block map and verify that there will be room in the segment for at least one message */ n_upgraded_blocks_allocated = divide (mseg_max_length, mseg_data_$block_size, 18, 0); n_upgraded_header_blocks = divide ((currentsize (upgraded_mseg_segment_header) + divide ((n_upgraded_blocks_allocated + 35), 36, 18, 0) + mseg_data_$block_size - 1), mseg_data_$block_size, 18, 0); if n_upgraded_blocks_allocated < n_upgraded_header_blocks then do; code = error_table_$invalid_max_length; call abort_upgrade_seg ("1"b, 0); end; /*** Find the proper support procedure -- A procedure named "mseg_upgrade_from_vN_", where N is a version number, exists for any older version of message segment which can be upgraded to the current version. This procedure contains the three entrypoints which are required to upgrade that version of message segment -- salvage, get_wakeup_state, and read_message. */ original_version = original_mseg_segment_header.version; upgrade_procedure_name = "mseg_upgrade_from_v" || convert (original_version_picture, original_version) || "_"; call hcs_$make_entry (codeptr (upgrade_seg), upgrade_procedure_name, "salvage", salvage_old_segment, code); if code ^= 0 then call abort_upgrade_seg ("1"b, FINDING_SUPPORT_PROCEDURE); call hcs_$make_entry (codeptr (upgrade_seg), upgrade_procedure_name, "get_wakeup_state", get_old_wakeup_state, code); if code ^= 0 then call abort_upgrade_seg ("1"b, FINDING_SUPPORT_PROCEDURE); call hcs_$make_entry (codeptr (upgrade_seg), upgrade_procedure_name, "read_message", read_old_message, code); if code ^= 0 then call abort_upgrade_seg ("1"b, FINDING_SUPPORT_PROCEDURE); /*** Salvage the segment using its version's salvager */ call salvage_old_segment (addr (original_operation), salvage_completed); if ^salvage_completed then do; code = 0; /* the salvager hasalready given a detailed accouting ... */ call abort_upgrade_seg ("1"b, SALVAGING_ORIGINAL_SEGMENT); end; /*** Initialize the upgraded message segment -- This message segment is actually a temporary in the process directory with an associated mseg_operation that will satisfy mseg_message_$add_message_for_mseg. */ on record_quota_overflow begin; /*** Any RQO that occurs between now and the completion of the message copying loop is considered fatal to the conversion process. This decision is proper as the only possible RQOs are either while reading the original segment or writing into the upgraded segment. As the upgraded segment is in the process directory, an RQO writing into it is clearly fatal. An RQO while reading the original segment is fatal as, after the above salvaging, the original can not contain any message which tries to reference a block which is in a page of zeroes because only a zero page can cause an RQO while reading. */ code = error_table_$rqover; call abort_upgrade_seg ("1"b, CREATING_UPGRADED_TEMPORARY); end; upgraded_operation = original_operation; upgraded_operation.mseg_ptr_valid, /* the original segment is never the upgraded one ... */ upgraded_operation.access_info_valid = "0"b; /* ... and its access info doesn't apply either */ upgraded_operation.suppress_access_checks = "1"b; /* must be able to copy all messages */ call get_temp_segment_ (operation_name, upgraded_mseg_ptr, code); if code ^= 0 then call abort_upgrade_seg ("1"b, PREPARING_UPGRADED_TEMPORARY); upgraded_operation.mseg_ptr = upgraded_mseg_ptr; upgraded_operation.mseg_ptr_valid = "1"b; call mseg_utils_$begin_operation (mseg_operations_$copy_seg_target, addr (upgraded_operation), ((64)" "), upgraded_mseg_dir_name, upgraded_mseg_entryname, upgraded_mseg_ptr, rqo_detected, code); if rqo_detected then code = error_table_$rqover; if code ^= 0 then call abort_upgrade_seg ("1"b, PREPARING_UPGRADED_TEMPORARY); upgraded_mseg_segment_header.n_messages, upgraded_mseg_segment_header.date_time_last_salvaged = 0; unspec (upgraded_mseg_segment_header.message_chain) = ""b; string (upgraded_mseg_segment_header.flags) = ""b; unspec (upgraded_mseg_segment_header.hash_table) = ""b; upgraded_mseg_segment_header.sentinel = MSEG_SEGMENT_SENTINEL; upgraded_mseg_segment_header.version = MSEG_SEGMENT_VERSION_5; upgraded_mseg_segment_header.block_size = mseg_data_$block_size; upgraded_mseg_segment_header.n_blocks_allocated = n_upgraded_blocks_allocated; upgraded_mseg_segment_header.n_blocks_unused = n_upgraded_blocks_allocated - n_upgraded_header_blocks; upgraded_mseg_ptr -> mseg_segment.block_map.map = copy ("1"b, n_upgraded_header_blocks); /*** Upgrade the segment's wakeup acceptance state */ unspec (upgraded_mseg_segment_header.wakeup_state) = ""b; call get_old_wakeup_state (addr (original_operation)); if original_operation.wakeup_state_valid then do; upgraded_mseg_segment_header.wakeup_state_set = "1"b; upgraded_mseg_segment_header.wakeup_state.state = original_operation.wakeup_state; end; /*** Upgrade the messages -- A message is upgraded by reading it from the original segment and adding it to the upgraded segment in the process directory. If we can't read a message, we consider this to be a fatal error in the conversion process. If we can't add a message because it's too large, we remember the event but continue copying. We must continue copying because subsequent messages may be small enough to fit in the upgraded segment. Our final report when the upgrade is complete will report any lost messages. */ original_operation.suppress_access_checks, /* insure that all messages are copied */ upgraded_operation.suppress_access_checks = "1"b; upgraded_operation.add_message_info_all_valid = "1"b; n_messages_discarded = 0; original_operation.message_info.version = MSEG_MESSAGE_INFO_V1; string (original_operation.message_info.control_flags) = ""b; original_operation.message_info.ms_ptr = null (); system_area_ptr = get_system_free_area_ (); original_operation.message_info.message_code = MSEG_READ_FIRST; call read_old_message (addr (original_operation), system_area_ptr, code); do while (code = 0); upgraded_operation.message_info = original_operation.message_info; substr (upgraded_operation.message_info.ms_id, 1, 18) = ""b; call mseg_message_$add_message_for_mseg (addr (upgraded_operation), operation_name, code); if (code = error_table_$bigarg) | (code = error_table_$notalloc) then n_messages_discarded = n_messages_discarded + 1; else if code ^= 0 then call abort_upgrade_seg ("1"b, CREATING_UPGRADED_TEMPORARY); if original_operation.message_info.ms_ptr ^= null () then do; free original_mseg_message_bits in (system_area); original_operation.message_info.ms_ptr = null (); end; original_operation.message_info.message_code = MSEG_READ_AFTER_SPECIFIED; call read_old_message (addr (original_operation), system_area_ptr, code); end; if code ^= error_table_$no_message /* we were unable to read a message */ then call abort_upgrade_seg ("1"b, CREATING_UPGRADED_TEMPORARY); revert record_quota_overflow; code = 0; /* message copying succeeded! */ /*** Copy the upgraded segment into place -- If an RQO occurs while moving the segment back into place, we will consider the conversion completed but we will also salvage the segment with the current salvager to discard any incomplete messages. */ upgraded_size = upgraded_mseg_segment_header.block_size * (upgraded_mseg_segment_header.n_blocks_allocated - upgraded_mseg_segment_header.n_blocks_unused); call hcs_$truncate_seg (original_mseg_ptr, upgraded_size, (0)); on record_quota_overflow begin; mseg_operation_data.finish_flags.already_salvaged = "0"b; call mseg_utils_$salvage_for_cause (mseg_operation_ptr, error_table_$rqover, "Some messages will be lost as a result of upgrading this segment."); go to COMPLETE_UPGRADE_AFTER_RQO; end; original_mseg_ptr -> upgraded_segment = upgraded_mseg_ptr -> upgraded_segment; revert record_quota_overflow; COMPLETE_UPGRADE_AFTER_RQO: call cleanup_after_upgrade_seg (); /*** The segment has been upgraded -- Display a report only if we were forced to discard any messages */ if n_messages_discarded > 0 then if original_operation.call_admin_gate then call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), 0, "^a: Upgraded ^a from version ^d to version ^d for ^a.^/^5x^d message^[s^] were deleted.", operation_name, pathname_ (original_mseg_dir_name, original_mseg_entryname), original_version, MSEG_SEGMENT_VERSION_5, original_operation.caller.group_id, n_messages_discarded, (n_messages_discarded ^= 1)); else call sub_err_ (0, operation_name, ACTION_DEFAULT_RESTART, null (), 0, "Upgraded ^a from version ^d to version ^d for ^a.^/^5x^d message^[s^] were deleted.", pathname_ (original_mseg_dir_name, original_mseg_entryname), original_version, MSEG_SEGMENT_VERSION_5, original_operation.caller.group_id, n_messages_discarded, (n_messages_discarded ^= 1)); mseg_operation_data.finish_flags.already_salvaged = "0"b; /* new problems during the operation should force a salvage */ return; /* Cleanup after upgrading a message segment */ cleanup_after_upgrade_seg: procedure (); if original_operation.message_info.ms_ptr ^= null () then do; free original_mseg_message_bits in (system_area); original_operation.message_info.ms_ptr = null (); end; if upgraded_mseg_ptr ^= null () then do; call release_temp_segment_ (operation_name, upgraded_mseg_ptr, (0)); upgraded_mseg_ptr = null (); end; return; end cleanup_after_upgrade_seg; /* Abort the attempt to upgrade a message segment -- We must report the failure and then return error_table_$improper_data_format to the caller of mseg_utils_$begin_operation. */ abort_upgrade_seg: procedure (p_have_pathname, p_failed_action); dcl p_have_pathname bit (1) aligned parameter; dcl p_failed_action fixed binary parameter; if original_operation.call_admin_gate then call admin_gate_$syserr_error_code ((SYSERR_LOG_OR_DISCARD + SYSERR_RING1_ERROR), code, "^a: Unable to upgrade ^[^a^s^;^s^p (pathname unknown)^] from version ^d to version ^d for ^a.^/^5x^[^a^[ --^/^5x^]^;^s^[^/^5x^]^]", operation_name, p_have_pathname, pathname_ (original_mseg_dir_name, original_mseg_entryname), original_mseg_ptr, original_version, MSEG_SEGMENT_VERSION_5, original_operation.caller.group_id, (p_failed_action ^= 0), SALVAGER_AND_UPGRADING_ACTIONS (p_failed_action), (code ^= 0)); else call sub_err_ (code, operation_name, ACTION_DEFAULT_RESTART, null (), 0, "^[^[^/^5x^]^a.^;^s^s^]^/^5xUnable to upgrade ^[^a^s^;^s^p (pathname unknown)^] from version ^d to version ^d for ^a.", (p_failed_action ^= 0), (code ^= 0), SALVAGER_AND_UPGRADING_ACTIONS (p_failed_action), p_have_pathname, pathname_ (original_mseg_dir_name, original_mseg_entryname), original_mseg_ptr, original_version, MSEG_SEGMENT_VERSION_5, original_operation.caller.group_id); code = error_table_$improper_data_format; go to RETURN_FROM_BEGIN_OPERATION; end abort_upgrade_seg; end upgrade_seg; %page; /* Salvage a message segment */ salvage_seg: procedure (p_n_possible_messages, p_n_messages_recovered) options (non_quick); dcl (p_n_possible_messages, p_n_messages_recovered) fixed binary (18); dcl (n_possible_messages, n_messages_recovered) fixed binary (18); /* format: idind30 */ dcl 1 local_mseg_segment_header aligned like mseg_segment.header; dcl 1 local_message_block aligned, 2 header aligned like message_block_header, 2 data_space, 3 data bit (324) unaligned, 2 descriptor aligned like message_descriptor; dcl 1 local_wakeup_state aligned like mseg_wakeup_state; dcl 1 old_wakeup_state aligned, 2 state, 3 switches aligned, 4 allow_normal bit (1) unaligned, 4 allow_urgent bit (1) unaligned, 4 pad bit (34) unaligned, 3 lock_id bit (36) aligned, 3 event_channel fixed bin (71), 3 process_id bit (36) aligned, 2 pad (64 - 5) bit (36) aligned; /* format: idind20 */ dcl mseg_segment_blocks (n_blocks_available) bit (36 * probable_block_size) aligned based (mseg_ptr); dcl prev_md_ptr pointer; dcl mseg_segment_aim_range (2) bit (72) aligned; dcl block_size_unknown bit (1) aligned; dcl (probable_block_size, n_blocks_available, n_header_blocks, last_used_block, max_blocks_per_message, n_blocks_recovered, last_recovered_block, block_id, n_message_blocks, message_block_idx, message_block_id, last_block_checked, next_unused_block, message_index) fixed binary (18); dcl (max_bits_in_first_block, max_bits_in_other_blocks) fixed binary; dcl hash_idx fixed binary (9); /*** All RQOs are fatal -- Clearly any RQO while touching a page with data in it will prevent us from successully salvaging the segment. Further, if we touch a zero page that causes an RQO, we will have increased the records used value and, as a result, we'll loop with an RQO until that page is flushed which may be a very long time. Therefore, we'll abort the salvage rather than loop. */ on record_quota_overflow begin; code = error_table_$rqover; call abort_salvage_for_cause ("1"b, REBUILDING_SEGMENT); end; /*** Force the segment lock to insure that no one can get at the segment while we salvage it */ mseg_segment.lock = mseg_data_$lock_id; mseg_operation_data.finish_flags.unlock_segment = "1"b; mseg_segment.salvage_in_progress = "1"b; mseg_segment_aim_range (1) = mseg_operation.access_info.parent_access_class; mseg_segment_aim_range (2) = mseg_operation.access_info.access_class; /*** Determine the block size used for this segment -- If the block size in the header does not yield the correct number of available blocks (i.e., more blocks than are occupied by the header and block map), we will assume that the segment uses the default block size. If the default block size also fails, we will abort our attempts at salvaging the segment. */ block_size_unknown = "1"b; /* ... really need do until */ do probable_block_size = mseg_segment.block_size repeat (mseg_data_$block_size) while (block_size_unknown); if (probable_block_size > (currentsize (message_block_header) + currentsize (message_descriptor))) & (probable_block_size < mseg_max_length) then do; /* this block size is large enough for proper operation */ n_blocks_available = divide (mseg_max_length, probable_block_size, 18, 0); /* format: off */ n_header_blocks = divide ((currentsize (mseg_segment_header) + divide ((n_blocks_available + 35), 36, 18, 0) + probable_block_size - 1), probable_block_size, 18, 0); /* format: on */ if (n_blocks_available > n_header_blocks) | (probable_block_size = mseg_data_$block_size) then block_size_unknown = "0"b; /* stop when the blocksize is OK or the default */ end; end; if n_blocks_available <= n_header_blocks /* couldn't get a workable block size */ then call abort_salvage_for_cause ("1"b, COMPUTING_BLOCK_SIZE); max_blocks_per_message = divide (mseg_data_$max_message_size, probable_block_size, 18, 0); /*** Find the last non-zero block in the segment -- By definition, the messages in a correctly formatted message segment will never contain a block which is entirely zeroes. Therefore, the last non-zero block in the segment is the upper bound of the blocks which we must examine for valid messages. (The lower bound, of course, is the first block after the block map.) */ last_used_block = divide (mseg_cur_length, probable_block_size, 18, 0); /* hcs_$status_long has told us in which page to find it */ /*** Compute the maximum amount of data which will fit into the first block and all subsequent blocks of a message -- PL/I can perform this computation for us provided that we have valid values for mseg_segment.block_size and message_block_header.data_lth. Because we don't want to actually change the segment until we've completed recovering messages, we temporarily use automatic copies of a message segment header and a message block to perform these computations. */ mseg_ptr = addr (local_mseg_segment_header); mseg_segment.block_size = probable_block_size; mb_ptr = addr (local_message_block); message_block_header.data_lth = 0; max_bits_in_first_block = length (first_message_block.pad); max_bits_in_other_blocks = length (other_message_block.pad); mseg_ptr = mseg_operation.mseg_ptr; /* Begin the actual reconstruction of the segment */ RECONSTRUCT_THE_SEGMENT: begin; dcl 1 new_block_map aligned, 2 map bit (n_blocks_available) unaligned; dcl 1 nonzero_block_map aligned, 2 map bit (n_blocks_available) unaligned; dcl 1 message_id_ptrs aligned, 2 n_ptrs fixed binary (18), 2 ptrs (n_blocks_available) pointer unaligned; dcl 1 sorted_message_indeces aligned, 2 n_indeces fixed binary (18), 2 indeces (n_blocks_available) fixed binary (18); dcl message_offsets (n_blocks_available) fixed binary (18) unsigned; dcl message_ids (n_blocks_available) bit (72) aligned; dcl block_offsets (max_blocks_per_message) fixed binary (18) unsigned; new_block_map.map = copy ("1"b, n_header_blocks); nonzero_block_map.map = copy ("1"b, n_header_blocks); n_blocks_recovered, last_recovered_block = n_header_blocks; /*** Examine the message blocks -- We check each message block individually to see if it might be the first block of a message. If it passes the preliminary test, we assume it is the beginning of a message and we then carefully check the entire possible message for validity. If it passes all of our checks, we record it as a recovered message and mark all of its blocks allocated. */ n_possible_messages, n_messages_recovered = 0; do block_id = (n_header_blocks + 1) to last_used_block; substr (nonzero_block_map.map, block_id, 1) = (mseg_segment_blocks (block_id) ^= ""b); if possible_message (block_id) then do; n_possible_messages = n_possible_messages + 1; if valid_message (block_id) then do; n_messages_recovered = n_messages_recovered + 1; message_offsets (n_messages_recovered) = block_offsets (1); message_ids (n_messages_recovered) = message_descriptor.ms_id; do message_block_idx = 1 to n_message_blocks; message_block_id = divide (block_offsets (message_block_idx), probable_block_size, 18, 0) + 1; substr (new_block_map.map, message_block_id, 1) = "1"b; n_blocks_recovered = n_blocks_recovered + 1; last_recovered_block = max (last_recovered_block, message_block_id); end; end; end; end; /*** Zero the unused blocks -- We can easily zero those unused blocks beyond the last block recovered by truncation. The intervening unused blocks, however, must be zeroed individually. */ call hcs_$truncate_seg (mseg_ptr, (last_recovered_block * probable_block_size), (0)); last_block_checked = n_header_blocks; /* nothing in the header/block map is unused */ do while (last_block_checked < last_recovered_block); begin; dcl rest_of_block_map bit (last_recovered_block - last_block_checked) unaligned defined (new_block_map.map) position (last_block_checked + 1); next_unused_block = index (rest_of_block_map, "0"b); end; if next_unused_block = 0 then last_block_checked = last_recovered_block; else do; last_block_checked = last_block_checked + next_unused_block; begin; dcl nonzero_indicator bit (1) unaligned defined (nonzero_block_map.map) position (last_block_checked); dcl the_block bit (36 * probable_block_size) aligned defined (mseg_segment_blocks (last_block_checked)); if nonzero_indicator then the_block = ""b; end; end; end; /*** Reconstruct the message chains -- Sort the recovered messages by their IDs before building the chains to insure that reading forward/backward will work properly. */ message_id_ptrs.n_ptrs, sorted_message_indeces.n_indeces = n_messages_recovered; do message_index = 1 to n_messages_recovered; message_id_ptrs.ptrs (message_index) = addr (message_ids (message_index)); sorted_message_indeces.indeces (message_index) = message_index; end; call sort_items_indirect_$bit (addr (message_id_ptrs), addr (sorted_message_indeces), length (message_ids (1))); unspec (mseg_segment.message_chain) = ""b; unspec (mseg_segment.hash_table) = ""b; prev_md_ptr = null (); do message_index = 1 to n_messages_recovered; mb_ptr = setwordno (mseg_ptr, message_offsets (sorted_message_indeces.indeces (message_index))); md_ptr = addr (first_message_block.descriptor); message_descriptor.message_chain.prev_message = mseg_segment.message_chain.last_message; message_descriptor.message_chain.next_message = 0; if mseg_segment.message_chain.first_message = 0 then mseg_segment.message_chain.first_message = wordno (mb_ptr); else prev_md_ptr -> message_descriptor.message_chain.next_message = wordno (mb_ptr); mseg_segment.message_chain.last_message = wordno (mb_ptr); hash_idx = fixed (substr (message_descriptor.ms_id, 64, 9), 9, 0); message_descriptor.prev_message_in_hash_chain = mseg_segment.hash_table.last_message (hash_idx); mseg_segment.hash_table.last_message (hash_idx) = wordno (mb_ptr); prev_md_ptr = md_ptr; end; /*** Reconstruct the wakeup state */ if mseg_segment.wakeup_state_set /* segment claims to have a wakeup state */ then if mseg_segment.wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1 then /* ... which appears to be the new style */ local_wakeup_state = mseg_segment.wakeup_state.state; else do; /* ... which appears to be the old style */ unspec (old_wakeup_state) = unspec (header_msg); local_wakeup_state.version = MSEG_WAKEUP_STATE_VERSION_1; string (local_wakeup_state.flags) = string (old_wakeup_state.switches); local_wakeup_state.event_channel = old_wakeup_state.event_channel; local_wakeup_state.access_class = header_msg_access_class; local_wakeup_state.process_id = old_wakeup_state.process_id; local_wakeup_state.lock_id = old_wakeup_state.lock_id; end; else local_wakeup_state.version = ""; /* no wakeup state is present */ if local_wakeup_state.version ^= MSEG_WAKEUP_STATE_VERSION_1 then do; RESET_SEGMENT_WAKEUP_STATE: mseg_segment.wakeup_state_set = "0"b; unspec (mseg_segment.wakeup_state) = ""b; end; else if (local_wakeup_state.process_id = ""b) | (local_wakeup_state.lock_id = ""b) then go to RESET_SEGMENT_WAKEUP_STATE; else if ^aim_check_$in_range (local_wakeup_state.access_class, mseg_segment_aim_range) then go to RESET_SEGMENT_WAKEUP_STATE; else do; /* wakeup state looks OK: put it back into the segment */ mseg_segment.wakeup_state_set = "1"b; mseg_segment.wakeup_state.state = local_wakeup_state; mseg_segment.header.wakeup_state.pad = ""b; end; /* Complete reconstruction of the header and block map and then return to our caller */ p_n_possible_messages = max (n_possible_messages, mseg_segment.n_messages); p_n_messages_recovered = n_messages_recovered; mseg_segment.n_messages = n_messages_recovered; mseg_segment.block_size = probable_block_size; mseg_segment.n_blocks_allocated = n_blocks_available; mseg_segment.n_blocks_unused = n_blocks_available - n_blocks_recovered; mseg_segment.block_map.map = new_block_map.map; mseg_segment.modification_in_progress, mseg_segment.salvage_in_progress = "0"b; mseg_segment.salvaged = "1"b; mseg_segment.sentinel = MSEG_SEGMENT_SENTINEL; mseg_segment.header.version = MSEG_SEGMENT_VERSION_5; mseg_segment.date_time_last_salvaged = clock (); return; %page; /* Determine if the specified block might be the first block of a message */ possible_message: procedure (p_block_id) returns (bit (1) aligned); dcl p_block_id fixed binary (18) parameter; if substr (new_block_map.map, p_block_id, 1) = "1"b then call not_a_message (); /* this block is already used by another message */ mb_ptr = setwordno (mseg_ptr, (p_block_id - 1) * probable_block_size); if ^first_message_block.descriptor_present /* there's no descriptor in this block */ then call not_a_message (); md_ptr = addr (first_message_block.descriptor); if message_descriptor.sentinel ^= MESSAGE_DESCRIPTOR_SENTINEL then call not_a_message (); /* the descriptor isn't properly formatted */ if message_descriptor.ms_id = ""b /* the "message" doesn't have a valid message ID */ then call not_a_message (); do message_index = 1 to n_messages_recovered; if message_ids (message_index) = message_descriptor.ms_id then call not_a_message (); /* the "message" has a duplicate message ID */ end; if (message_descriptor.ms_len < 0) | (message_descriptor.ms_len > (36 * mseg_data_$max_message_size)) then call not_a_message (); /* the "message" is too small or too large to be real */ if ^aim_check_$in_range (message_descriptor.ms_access_class, mseg_segment_aim_range) then call not_a_message (); /* message with this access class can't be in this segment */ if ^aim_check_$greater_or_equal (message_descriptor.ms_access_class, message_descriptor.sender_authorization) then if (aim_util_$get_privileges (message_descriptor.sender_authorization) & sys_info$ring1_privilege) = ""b then call not_a_message (); /* sender couldn't add it without privileges he didn't have */ /*** Control arrives here only if this block contains a plausible message */ return ("1"b); /* Control arrives here if the block does not contain a plausible message */ not_a_message: procedure (); go to RETURN_NOT_A_MESSAGE; end not_a_message; RETURN_NOT_A_MESSAGE: return ("0"b); end possible_message; %page; /* Validate that a probable message is, in fact, a real message -- We must check all the blocks which are claimed to be part of this message for validity. We don't have to check the message descriptor itself, however, as that has already been done for us by the possible_message internal procedure and, in fact, md_ptr still locates the descriptor. */ valid_message: procedure (p_block_id) returns (bit (1) aligned); dcl p_block_id fixed binary (18) parameter; dcl first_block bit (1) aligned; dcl actual_ms_len fixed binary (24); dcl block_offset fixed binary (18) unsigned; block_offset = (p_block_id - 1) * probable_block_size; first_block = "1"b; /* this is the first block */ n_message_blocks = 0; /* nothing valid yet */ actual_ms_len = 0; do while (block_offset ^= 0); if mod (block_offset, probable_block_size) ^= 0 then call not_a_message (); /* it's not a valid block offset */ message_block_id = divide (block_offset, probable_block_size, 18, 0) + 1; if (message_block_id <= n_header_blocks) | (message_block_id > n_blocks_available) then call not_a_message (); /* this block is not within the segment */ if substr (new_block_map.map, message_block_id, 1) = "1"b then call not_a_message (); /* this block is already in use in another message */ do message_block_idx = 1 to n_message_blocks; if block_offsets (message_block_idx) = block_offset then call not_a_message (); /* this block is already in this message */ end; if n_message_blocks = max_blocks_per_message then call not_a_message (); /* this "message" has too many blocks */ n_message_blocks = n_message_blocks + 1; block_offsets (n_message_blocks) = block_offset; mb_ptr = setwordno (mseg_ptr, block_offset); if message_block_header.data_lth < 0 /* a block can't have a negative length! */ then call not_a_message (); if first_block then do; /* the first block -- just check its length */ if message_block_header.data_lth > max_bits_in_first_block then call not_a_message (); /* too many bits to fit in the block */ if message_block_header.next_block ^= 0 then if message_block_header.data_lth ^= max_bits_in_first_block then call not_a_message (); /* there's more to come but this block's not full */ end; else do; /* all other blocks ... */ if message_block_header.descriptor_present then call not_a_message (); /* a descriptor when there shouldn't be one */ if message_block_header.data_lth > max_bits_in_other_blocks then call not_a_message (); /* too many bits to fit in the block */ if message_block_header.next_block ^= 0 then if message_block_header.data_lth ^= max_bits_in_other_blocks then call not_a_message (); /* there's more to come but this block's not full */ end; actual_ms_len = actual_ms_len + message_block_header.data_lth; if actual_ms_len > message_descriptor.ms_len then call not_a_message (); /* we've found more bits than supposedly are in the message */ block_offset = message_block_header.next_block; first_block = "0"b; end; if actual_ms_len < message_descriptor.ms_len then call not_a_message (); /* the message isn't as long as it should be */ /*** Control arrives here only if the message is valid */ return ("1"b); /* Control arrives here if the message is not valid */ not_a_message: procedure (); go to RETURN_NOT_A_MESSAGE; end not_a_message; RETURN_NOT_A_MESSAGE: return ("0"b); end valid_message; end RECONSTRUCT_THE_SEGMENT; /* format: off */ %page; %include mseg_message; /* format: on */ end salvage_seg; /* format: off */ %page; %include mseg_data_; %page; %include mseg_segment; %page; %include mseg_wakeup_state; %page; %include mseg_operation; %page; %include mseg_operation_data; %page; %include mseg_operations_; %page; %include mseg_message_info; %page; %include entry_access_info; %page; %include mseg_format_errors_; %page; %include sub_err_flags; %page; %include syserr_constants; %page; %include condition_info; %skip; %include mc; %page; %include status_structures; %page; /* BEGIN MESSAGE DOCUMENTATION Message: mseg_$OPERATION: Beginning salvage of PATH for USER_ID. REASON S: $log T: $run M: The message segment primitives operation OPERATION detected an internal inconsistency in the message segment or mailbox PATH and has requested that the segment be salvaged. REASON provides an explanation of why the operation invoked the salvager. A: $ignore Message: mseg_$OPERATION: Completed salvage of PATH for USER_ID. N {out of M possible} messages recovered. S: $log T: $run M: The salvage of the message segment or mailbox PATH requested by the message segment primitives operation OPERATION has been completed. Of the M messages which might have been in the segment, only N could be recovered; the others have been deleted. If all possible messages were recovered, the "out of M possible" phrase is omitted from the message. A: $inform_sa The administrator may wish to notify the owner of the segment that some of his messages have been lost. Message: mseg_$OPERATION: Unable to salvage PTR (pathname unknown) for USER_ID. Call to hcs_$get_access_info_seg failed. REASON S: $log T: $run M: $err OPERATION identifies the message segment primitives operation which provoked the attempted salvage. PTR is USER_ID's pointer to the message segment or mailbox which could not be salvaged. REASON provides additional information about the failure of the call to hcs_$get_access_info_seg. A: $inform Message: mseg_$OPERATION: Unable to salvage PATH for USER_ID. Rebuilding the contents of the message segment -- Record quota overflow. S: $log T: $run M: The salvage of the message segment or mailbox PATH requested by the message segment primitives operation OPERATION failed due to a lack of quota. The segment in question will remain inaccessible until the salvage can be successfully completed. A: $inform_sa In order to make the message segment or mailbox accessible again, the administrator must increase the quota available to the segment to any value greater than the current length of the segment. The administrator should then attempt to use the segment to allow the salvager to be run to completion. Message: mseg_$OPERATION: Unable to salvage PATH for USER_ID. REASON S: $log T: $run M: $err OPERATION identifies the message segment primitives operation which provoked the attempted salvage. PATH is the pathname of the message segment or mailbox which could not be salvaged. REASON provides additional information about the failure of the attempted salvage. A: $inform Message: mseg_$OPERATION: Upgraded PATH from version N to version 5 for USER_ID. M messages were deleted. S: $log T: $run M: The format of the message segment or mailbox PATH was upgraded from the old format known as "version N" to the latest format. However, M messages in the segment could not be upgraded to the current format because there was no room for them in the segment. As a consequence, these messages were deleted. OPERATION identifies the message segment primitives operation which required that the segment be upgraded. A: $inform_sa The administrator may wish to notify the owner of the segment that some of his messages have been lost. Message: mseg_$OPERATION: Unable to upgrade PTR (pathname unknown) from version N to version 5 for USER_ID. Call to hcs_$get_access_info_seg failed. REASON S: $log T: $run M: $err OPERATION identifies the message segment primitives operation which required that the segment be upgraded. PTR is USER_ID's pointer to the message segment or mailbox which could not be upgraded. REASON provides additional information about the failure of the call to hcs_$get_access_info_seg. A: $inform Message: mseg_$OPERATION: Unable to upgrade PATH from version N to version 5 for USER_ID. REASON S: $log T: $run M: $err OPERATION identifies the message segment primitives operation which required that the segment be upgraded. PATH is the pathname of the message segment or mailbox which could not be upgraded. REASON provides additional information about the failure of the attempted upgrade. A: $inform END MESSAGE DOCUMENTATION */ /* format: on */ end mseg_utils_;  suffix_mbx_.pl1 08/05/87 0812.1r 08/04/87 1539.2 175815 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * ************************************************************** */ /* format: style2,idind30,indcomtxt */ /* Typed-segment primitives for mailboxes */ /* Created: January 1983 by G. Palter */ /* Modified 2/18/83 Jay Pattin to add lots more entrypoints */ /* 830922 BIM for fixed up extended objects. */ /* 1984.08.28 MAP to respecify include file mail_system_mbx_modes */ /* 1984.10.05 MAP to fix empty ACL blowouts */ /* 1985-05-02, BIM: use mseg_access_mode_values instead of the old mlsys file */ /* 1985-05-06, BIM: always free old_acl_array and return codes on specific acl listing. */ suffix_mbx_: procedure (); /* Common Parameters */ dcl P_desired_version character (*) parameter; dcl P_dirname character (*) parameter; /* directory containing the mailbox */ dcl P_ename character (*) parameter; /* name of the mailbox */ dcl P_code fixed binary (35) parameter; /* suffix_info and list_switches Parameters */ dcl P_suffix_info_ptr ptr parameter; dcl P_switch_list_ptr ptr parameter; /* chname_file Parameters */ dcl P_old_name character (*) parameter; /* name to be deleted */ dcl P_new_name character (*) parameter; /* name to be added */ /* copy parameter */ dcl P_copy_options_ptr pointer parameter; /* Parameters used by most ACL entries */ dcl P_acl_ptr pointer parameter; /* -> an ACL array structure */ /* list_acl Parameters */ dcl P_user_area_ptr pointer parameter; /* -> area where to allocate listed_acl if non-null */ /* replace_acl Parameters */ dcl P_no_sysdaemon bit (1) parameter; /* ON => do not add explicit *.SysDaemon.* term */ /* switch Parameters */ dcl P_switch_name char (*) parameter; dcl P_value bit (1) aligned parameter; /* (get set)_max_length and bit_count parameters */ dcl P_max_length fixed bin (19) parameter; /* get_user_access_modes parameters */ dcl (P_modes, P_exmodes) bit (36) aligned; dcl P_ring fixed bin; dcl P_user_name char (*); /* Remaining declarations */ dcl old_acl_ptr pointer; dcl user_area_ptr pointer; dcl user_area area based (P_user_area_ptr); dcl system_free_area area based (get_system_free_area_ ()); dcl idx fixed binary; dcl rings (3) fixed bin (3); dcl value bit (1); dcl err_switch bit (1) aligned; dcl error_table_$argerr fixed bin (35) ext static; dcl error_table_$unsupported_operation fixed binary (35) external; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl get_system_free_area_ entry () returns (pointer); dcl get_user_free_area_ entry () returns (pointer); dcl hcs_$get_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl hcs_$get_safety_sw entry (char (*), char (*), bit (1), fixed bin (35)); dcl hcs_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl mailbox_$copy entry (character (*), character (*), character (*), character (*), bit (1) aligned, fixed binary (35)); dcl mailbox_$chname_file entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl mailbox_$delete entry (character (*), character (*), fixed binary (35)); dcl mailbox_$mbx_acl_add entry (character (*), character (*), pointer, fixed binary, fixed binary (35)); dcl mailbox_$mbx_acl_delete entry (character (*), character (*), pointer, fixed binary, pointer, fixed binary (35)); dcl mailbox_$mbx_acl_list entry (character (*), character (*), pointer, fixed binary, pointer, fixed binary (35)); dcl mailbox_$mbx_acl_replace entry (character (*), character (*), pointer, fixed binary, fixed binary (35)); dcl mailbox_$set_max_length_file entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl mailbox_$set_safety_switch entry (char (*), char (*), bit (1) aligned, fixed bin (35)); dcl mailbox_$validate entry (character (*), character (*), fixed binary (35)); dcl cleanup condition; dcl null builtin; /* format: off */ %page; %include acl_structures; %page; %include access_mode_values; %page; %include mseg_access_mode_values; %page; %include suffix_info; %page; %include copy_options; %page; %include copy_flags; /* format: on */ /* Deletes a mailbox */ delentry_file: entry (P_dirname, P_ename, P_code); call mailbox_$delete (P_dirname, P_ename, P_code); return; /* Changes the names on a mailbox */ chname_file: entry (P_dirname, P_ename, P_old_name, P_new_name, P_code); call mailbox_$chname_file (P_dirname, P_ename, P_old_name, P_new_name, P_code); return; /* copies a mailbox */ copy: entry (P_copy_options_ptr, P_code); copy_options_ptr = P_copy_options_ptr; if copy_options.extend | copy_options.update then do; P_code = error_table_$unsupported_operation; return; end; call mailbox_$copy (copy_options.source_dir, copy_options.source_name, copy_options.target_dir, copy_options.target_name, err_switch, P_code); copy_options.target_err_switch = err_switch; return; /* validates that an entry is a mailbox */ validate: entry (P_dirname, P_ename, P_code); call mailbox_$validate (P_dirname, P_ename, P_code); return; /* Returns information about mailboxes */ suffix_info: entry (P_suffix_info_ptr); suffix_info_ptr = P_suffix_info_ptr; suffix_info.version = SUFFIX_INFO_VERSION_1; suffix_info.type = "mbx"; suffix_info.type_name = "mailbox"; suffix_info.plural_name = "mailboxes"; string (suffix_info.flags) = ""b; suffix_info.extended_acl = "0"b; /* only one set of meaningful modes */ suffix_info.has_switches = "1"b; suffix_info.modes = "adroswu"; suffix_info.max_mode_len = 7; suffix_info.num_ring_brackets = 0; /* Don't display them */ string (suffix_info.copy_flags) = ""b; suffix_info.copy_flags.names, suffix_info.copy_flags.acl, suffix_info.copy_flags.max_length, suffix_info.copy_flags.safety_switch = "1"b; suffix_info.info_pathname = "extended_access.gi.info"; return; /* returns names of non-standard switches */ list_switches: entry (P_desired_version, P_user_area_ptr, P_switch_list_ptr, P_code); if P_desired_version ^= SWITCH_LIST_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; user_area_ptr = P_user_area_ptr; if user_area_ptr = null () then user_area_ptr = get_user_free_area_ (); alloc_switch_count, alloc_switch_name_count = 1; allocate switch_list in (user_area); switch_list.version = SWITCH_LIST_VERSION_1; switch_list.switches (1).name_index = 1; switch_list.switches (1).name_count = 1; switch_list.switches (1).default_value = "0"b; switch_list.names (1) = "safety"; P_switch_list_ptr = switch_list_ptr; return; %page; /* Adds ACL entries to a mailbox */ add_acl_entries: entry (P_dirname, P_ename, P_acl_ptr, P_code); old_acl_ptr = null (); on cleanup begin; if old_acl_ptr ^= null () then free old_acl_ptr -> segment_acl_array; old_acl_ptr = null (); end; acl_ptr = P_acl_ptr; acl_count = general_acl.count; allocate segment_acl_array in (system_free_area) set (old_acl_ptr); do idx = 1 to acl_count; old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx).access_name; old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx).mode; old_acl_ptr -> segment_acl_array (idx).status_code = 0; end; call mailbox_$mbx_acl_add (P_dirname, P_ename, old_acl_ptr, acl_count, P_code); general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code; free old_acl_ptr -> segment_acl_array; return; /* Lists ACL entries on a mailbox */ list_acl: entry (P_dirname, P_ename, P_desired_version, P_user_area_ptr, P_acl_ptr, P_code); old_acl_ptr = null (); on cleanup begin; if old_acl_ptr ^= null () then do; free old_acl_ptr -> segment_acl_array; old_acl_ptr = null (); end; end; acl_ptr = P_acl_ptr; if acl_ptr ^= null () then do; /* wants to list specific entries */ if general_acl.version ^= GENERAL_ACL_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; acl_count = general_acl.count; allocate segment_acl_array in (system_free_area) set (old_acl_ptr); /* only access_name is interesting */ old_acl_ptr -> segment_acl_array (*).access_name = general_acl.entries (*).access_name; call mailbox_$mbx_acl_list (P_dirname, P_ename, old_acl_ptr, acl_count, null (), P_code); general_acl.entries (*).mode = old_acl_ptr -> segment_acl_array (*).extended_mode; general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code; free old_acl_ptr -> segment_acl_array; end; else do; /* wants to list an acl entirely */ if P_desired_version ^= GENERAL_ACL_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if user_area_ptr = null () then user_area_ptr = get_user_free_area_ (); call mailbox_$mbx_acl_list (P_dirname, P_ename, old_acl_ptr, acl_count, get_system_free_area_ (), P_code); /* caller wants the entire ACL */ if P_code ^= 0 then return; if acl_count = 0 then do; P_acl_ptr = null (); return; end; allocate general_acl in (user_area); P_acl_ptr = acl_ptr; general_acl.version = GENERAL_ACL_VERSION_1; do idx = 1 to acl_count; general_acl.entries (idx).access_name = old_acl_ptr -> segment_acl_array (idx).access_name; general_acl.entries (idx).mode = old_acl_ptr -> segment_acl_array (idx).extended_mode; general_acl.entries (*).status_code = 0; end; free old_acl_ptr -> segment_acl_array; P_acl_ptr = acl_ptr; end; return; %page; /* Deletes ACL entries from a message segment */ delete_acl_entries: entry (P_dirname, P_ename, P_acl_ptr, P_code); old_acl_ptr = null (); on cleanup begin; if old_acl_ptr ^= null () then do; free old_acl_ptr -> segment_acl_array; old_acl_ptr = null (); end; end; acl_ptr = P_acl_ptr; acl_count = general_delete_acl.count; allocate segment_acl_array in (system_free_area) set (old_acl_ptr); segment_acl_array (*).access_name = general_delete_acl.entries (*).access_name; call mailbox_$mbx_acl_delete (P_dirname, P_ename, old_acl_ptr, acl_count, null (), P_code); general_delete_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code; free old_acl_ptr -> segment_acl_array; return; %page; /* Replaces the ACL of a message segment */ replace_acl: entry (P_dirname, P_ename, P_acl_ptr, P_no_sysdaemon, P_code); old_acl_ptr = null (); on cleanup begin; if old_acl_ptr ^= null () then do; free old_acl_ptr -> segment_acl_array; old_acl_ptr = null (); end; end; acl_ptr = P_acl_ptr; acl_count = general_acl.count; if ^P_no_sysdaemon then acl_count = acl_count + 1; /* add aow *.SysDaemon.* */ if acl_count = 0 /* cannot have no_sysdaemon */ then do; call mailbox_$mbx_acl_replace (P_dirname, P_ename, null (), -1, P_code); return; end; allocate segment_acl_array in (system_free_area) set (old_acl_ptr); if ^P_no_sysdaemon then do; old_acl_ptr -> segment_acl_array (1).access_name = "*.SysDaemon.*"; old_acl_ptr -> segment_acl_array (1).extended_mode = MSEG_A_ACCESS | MSEG_O_ACCESS | MSEG_W_ACCESS; old_acl_ptr -> segment_acl_array (1).status_code = 0; do idx = 2 to acl_count; old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx-1).access_name; old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx-1).mode; old_acl_ptr -> segment_acl_array (idx).mode = ""b; old_acl_ptr -> segment_acl_array (idx).status_code = 0; end; end; else do idx = 1 to acl_count; /* no need to splice in funny acl */ old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx).access_name; old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx).mode; old_acl_ptr -> segment_acl_array (idx).mode = ""b; old_acl_ptr -> segment_acl_array (idx).status_code = 0; end; call mailbox_$mbx_acl_replace (P_dirname, P_ename, old_acl_ptr, acl_count, P_code); if ^P_no_sysdaemon /* have to skip sysdaemon acl entry */ then /* copy back status codes */ do idx = 1 to acl_count; general_acl.entries (idx).status_code = old_acl_ptr -> segment_acl_array (idx + 1).status_code; end; else general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code; free old_acl_ptr -> segment_acl_array; return; %page; get_switch: entry (P_dirname, P_ename, P_switch_name, P_value, P_code); call mailbox_$validate (P_dirname, P_ename, P_code); if P_code = 0 then do; if P_switch_name = "safety" then do; call hcs_$get_safety_sw (P_dirname, P_ename, value, P_code); P_value = value; end; else P_code = error_table_$argerr; end; return; set_switch: entry (P_dirname, P_ename, P_switch_name, P_value, P_code); call mailbox_$validate (P_dirname, P_ename, P_code); if P_code = 0 then do; if P_switch_name = "safety" then call mailbox_$set_safety_switch (P_dirname, P_ename, P_value, P_code); else P_code = error_table_$argerr; end; return; %page; get_max_length: entry (P_dirname, P_ename, P_max_length, P_code); call mailbox_$validate (P_dirname, P_ename, P_code); if P_code = 0 then call hcs_$get_max_length (P_dirname, P_ename, P_max_length, P_code); return; set_max_length: entry (P_dirname, P_ename, P_max_length, P_code); call mailbox_$set_max_length_file (P_dirname, P_ename, P_max_length, P_code); return; get_user_access_modes: entry (P_dirname, P_ename, P_user_name, P_ring, P_modes, P_exmodes, P_code); P_exmodes = ""b; call mailbox_$validate (P_dirname, P_ename, P_code); if P_code = 0 then call hcs_$get_user_access_modes (P_dirname, P_ename, P_user_name, P_ring, ((36)"0"b), P_modes, P_code); return; end suffix_mbx_;  suffix_ms_.pl1 05/09/85 1151.8r w 05/06/85 1617.7 173160 /* ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1983 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * ************************************************************** */ /* format: style2,idind30,indcomtxt */ /* Typed-segment primitives for message segments */ /* Created: January 1983 by G. Palter */ /* Modified: 2/20/83 Jay Pattin to add lots more entries */ /* 830922 BIM for new calling sequences for acls */ /* 1984.08.28 MAP to set user_area_ptr when list_acl is invoked */ /* 1985-05-02, BIM: remove unneeded include of access_mode_values */ /* 1985-05-06, BIM: check code on exit from message_segment_$acl_list */ suffix_ms_: procedure (); /* Common Parameters */ dcl P_desired_version character (*) parameter; dcl P_dirname character (*) parameter; /* directory containing the message segment */ dcl P_ename character (*) parameter; /* name of the message segment */ dcl P_code fixed binary (35) parameter; /* suffix_info and list_switches Parameters */ dcl P_suffix_info_ptr ptr parameter; dcl P_switch_list_ptr ptr parameter; /* chname_file Parameters */ dcl P_old_name character (*) parameter; /* name to be deleted */ dcl P_new_name character (*) parameter; /* name to be added */ /* copy parameters */ dcl P_copy_options_ptr ptr parameter; /* Parameters used by most ACL entries */ dcl P_acl_ptr pointer parameter; /* -> an ACL array structure */ /* list_acl Parameters */ dcl P_user_area_ptr pointer parameter; /* -> area where to allocate listed_acl if non-null */ /* replace_acl Parameters */ dcl P_no_sysdaemon bit (1) parameter; /* ON => do not add explicit *.SysDaemon.* term */ /* switch Parameters */ dcl P_switch_name char (*) parameter; dcl P_value bit (1) aligned parameter; /* (get set)_max_length and bit_count parameters */ dcl P_max_length fixed bin (19) parameter; /* get_user_access_modes parameters */ dcl (P_modes, P_exmodes) bit (36) aligned; dcl P_ring fixed bin; dcl P_user_name char (*); /* Remaining declarations */ dcl old_acl_ptr pointer; dcl user_area_ptr pointer; dcl user_area area based (user_area_ptr); dcl system_free_area area based (get_system_free_area_ ()); dcl idx fixed binary; dcl rings (3) fixed bin (3); dcl value bit (1); dcl err_switch bit (1) aligned; dcl error_table_$argerr fixed binary (35) external; dcl error_table_$unsupported_operation fixed binary (35) external; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl (get_system_free_area_, get_user_free_area_) entry () returns (pointer); dcl hcs_$get_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl hcs_$get_safety_sw entry (char (*), char (*), bit (1), fixed bin (35)); dcl hcs_$get_user_access_modes entry (char (*), char (*), char (*), fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35)); dcl message_segment_$copy entry (character (*), character (*), character (*), character (*), bit (1) aligned, fixed binary (35)); dcl message_segment_$chname_file entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl message_segment_$delete entry (character (*), character (*), fixed binary (35)); dcl message_segment_$ms_acl_add entry (character (*), character (*), pointer, fixed binary, fixed binary (35)); dcl message_segment_$ms_acl_delete entry (character (*), character (*), pointer, fixed binary, pointer, fixed binary (35)); dcl message_segment_$ms_acl_list entry (character (*), character (*), pointer, fixed binary, pointer, fixed binary (35)); dcl message_segment_$ms_acl_replace entry (character (*), character (*), pointer, fixed binary, fixed binary (35)); dcl message_segment_$set_max_length_file entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl message_segment_$set_safety_switch entry (char (*), char (*), bit (1) aligned, fixed bin (35)); dcl message_segment_$validate entry (character (*), character (*), fixed binary (35)); dcl sub_err_ entry () options (variable); dcl cleanup condition; dcl null builtin; /* format: off */ %page; %include suffix_info; %page; %include copy_options; %page; %include copy_flags; %page; %include acl_structures; %include sub_err_flags; /* format: on */ /* Deletes a message segment */ delentry_file: entry (P_dirname, P_ename, P_code); call message_segment_$delete (P_dirname, P_ename, P_code); return; /* Changes the names on a message segment */ chname_file: entry (P_dirname, P_ename, P_old_name, P_new_name, P_code); call message_segment_$chname_file (P_dirname, P_ename, P_old_name, P_new_name, P_code); return; /* copies a message segment */ copy: entry (P_copy_options_ptr, P_code); copy_options_ptr = P_copy_options_ptr; if copy_options.extend | copy_options.update then do; P_code = error_table_$unsupported_operation; return; end; call message_segment_$copy (copy_options.source_dir, copy_options.source_name, copy_options.target_dir, copy_options.target_name, err_switch, P_code); copy_options.target_err_switch = err_switch; return; /* validates that an entry is a message segment */ validate: entry (P_dirname, P_ename, P_code); call message_segment_$validate (P_dirname, P_ename, P_code); return; /* Returns information about message segments */ suffix_info: entry (P_suffix_info_ptr); suffix_info_ptr = P_suffix_info_ptr; if suffix_info.version ^= SUFFIX_INFO_VERSION_1 then call sub_err_ (error_table_$unimplemented_version, "bad suffix info version", ACTION_CANT_RESTART, null (), (0), "Invalid version ^a in call to suffix_ms_$suffix_info.", suffix_info.version); suffix_info.type = "ms"; suffix_info.type_name = "message segment"; suffix_info.plural_name = "message segments"; string (suffix_info.flags) = ""b; suffix_info.extended_acl = "0"b; suffix_info.has_switches = "1"b; suffix_info.modes = "adros"; suffix_info.max_mode_len = 5; suffix_info.num_ring_brackets = 0; /* Don't display them */ string (suffix_info.copy_flags) = ""b; suffix_info.copy_flags.names, suffix_info.copy_flags.acl, suffix_info.copy_flags.max_length, suffix_info.copy_flags.safety_switch = "1"b; suffix_info.info_pathname = "extended_access.gi.info"; return; /* returns names of non-standard switches */ list_switches: entry (P_desired_version, P_user_area_ptr, P_switch_list_ptr, P_code); if P_desired_version ^= SWITCH_LIST_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; alloc_switch_count, alloc_switch_name_count = 1; user_area_ptr = P_user_area_ptr; if user_area_ptr = null () then user_area_ptr = get_user_free_area_ (); allocate switch_list in (user_area); switch_list.version = SWITCH_LIST_VERSION_1; switch_list.switches (1).name_index = 1; switch_list.switches (1).name_count = 1; switch_list.switches (1).default_value = "0"b; switch_list.names (1) = "safety"; P_switch_list_ptr = switch_list_ptr; return; %page; /* Adds ACL entries to a message segment */ /**** This has to convert structures from the new interface to the old one. */ add_acl_entries: entry (P_dirname, P_ename, P_acl_ptr, P_code); old_acl_ptr = null (); on cleanup begin; if old_acl_ptr ^= null () then do; free old_acl_ptr -> segment_acl_array; old_acl_ptr = null (); end; end; acl_ptr = P_acl_ptr; acl_count = general_acl.count; allocate segment_acl_array in (system_free_area) set (old_acl_ptr); do idx = 1 to acl_count; /* no aggregate, since we rearrange */ old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx).access_name; old_acl_ptr -> segment_acl_array (idx).mode = ""b; old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx).mode; old_acl_ptr -> segment_acl_array (idx).status_code = 0; end; call message_segment_$ms_acl_add (P_dirname, P_ename, old_acl_ptr, acl_count, P_code); general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code; free old_acl_ptr -> segment_acl_array; return; /* Lists ACL entries on a message segment */ list_acl: entry (P_dirname, P_ename, P_desired_version, P_user_area_ptr, P_acl_ptr, P_code); old_acl_ptr = null (); on cleanup begin; if old_acl_ptr ^= null () then do; free old_acl_ptr -> segment_acl_array; old_acl_ptr = null (); end; end; user_area_ptr = P_user_area_ptr; acl_ptr = P_acl_ptr; if acl_ptr ^= null () then do; /* wants to list specific entries */ if general_acl.version ^= GENERAL_ACL_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; acl_count = general_acl.count; allocate segment_acl_array in (system_free_area) set (old_acl_ptr); /* only access_name is interesting */ old_acl_ptr -> segment_acl_array (*).access_name = general_acl.entries (*).access_name; call message_segment_$ms_acl_list (P_dirname, P_ename, old_acl_ptr, acl_count, null (), P_code); general_acl.entries (*).mode = old_acl_ptr -> segment_acl_array (*).extended_mode; general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code; free old_acl_ptr -> segment_acl_array; end; else do; /* wants to list an acl entirely */ if P_desired_version ^= GENERAL_ACL_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if user_area_ptr = null () then user_area_ptr = get_user_free_area_ (); call message_segment_$ms_acl_list (P_dirname, P_ename, old_acl_ptr, acl_count, get_system_free_area_ (), P_code); /* caller wants the entire ACL */ if P_code ^= 0 then return; if acl_count = 0 then do; P_acl_ptr = null (); return; end; allocate general_acl in (user_area); P_acl_ptr = acl_ptr; general_acl.version = GENERAL_ACL_VERSION_1; do idx = 1 to acl_count; general_acl.entries (idx).access_name = old_acl_ptr -> segment_acl_array (idx).access_name; general_acl.entries (idx).mode = old_acl_ptr -> segment_acl_array (idx).extended_mode; general_acl.entries (*).status_code = 0; end; free old_acl_ptr -> segment_acl_array; P_acl_ptr = acl_ptr; end; return; %page; /* Deletes ACL entries from a message segment */ delete_acl_entries: entry (P_dirname, P_ename, P_acl_ptr, P_code); old_acl_ptr = null (); on cleanup begin; if old_acl_ptr ^= null () then do; free old_acl_ptr -> segment_acl_array; old_acl_ptr = null (); end; end; acl_ptr = P_acl_ptr; acl_count = general_delete_acl.count; allocate segment_acl_array in (system_free_area) set (old_acl_ptr); segment_acl_array (*).access_name = general_delete_acl.entries (*).access_name; call message_segment_$ms_acl_delete (P_dirname, P_ename, old_acl_ptr, acl_count, null (), P_code); general_delete_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code; free old_acl_ptr -> segment_acl_array; return; %page; /* Replaces the ACL of a message segment */ /**** NOTE -- the default SysDaemon access for an mseg is NULL. Therefore, the no_sysdaemon switch is a noop. */ replace_acl: entry (P_dirname, P_ename, P_acl_ptr, P_no_sysdaemon, P_code); old_acl_ptr = null (); on cleanup begin; if old_acl_ptr ^= null () then do; free old_acl_ptr -> segment_acl_array; old_acl_ptr = null (); end; end; acl_ptr = P_acl_ptr; acl_count = general_acl.count; if acl_count = 0 /* cannot have no_sysdaemon */ then do; call message_segment_$ms_acl_replace (P_dirname, P_ename, null (), -1, P_code); return; end; allocate segment_acl_array in (system_free_area) set (old_acl_ptr); do idx = 1 to acl_count; /* no need to splice in funny acl */ old_acl_ptr -> segment_acl_array (idx).access_name = general_acl.entries (idx).access_name; old_acl_ptr -> segment_acl_array (idx).extended_mode = general_acl.entries (idx).mode; old_acl_ptr -> segment_acl_array (idx).mode = ""b; old_acl_ptr -> segment_acl_array (idx).status_code = 0; end; call message_segment_$ms_acl_replace (P_dirname, P_ename, old_acl_ptr, acl_count, P_code); general_acl.entries (*).status_code = old_acl_ptr -> segment_acl_array (*).status_code; free old_acl_ptr -> segment_acl_array; return; %page; get_switch: entry (P_dirname, P_ename, P_switch_name, P_value, P_code); call message_segment_$validate (P_dirname, P_ename, P_code); if P_code = 0 then do; if P_switch_name = "safety" then do; call hcs_$get_safety_sw (P_dirname, P_ename, value, P_code); P_value = value; end; else P_code = error_table_$argerr; end; return; set_switch: entry (P_dirname, P_ename, P_switch_name, P_value, P_code); call message_segment_$validate (P_dirname, P_ename, P_code); if P_code = 0 then do; if P_switch_name = "safety" then call message_segment_$set_safety_switch (P_dirname, P_ename, P_value, P_code); else P_code = error_table_$argerr; end; return; %page; get_max_length: entry (P_dirname, P_ename, P_max_length, P_code); call message_segment_$validate (P_dirname, P_ename, P_code); if P_code = 0 then call hcs_$get_max_length (P_dirname, P_ename, P_max_length, P_code); return; set_max_length: entry (P_dirname, P_ename, P_max_length, P_code); call message_segment_$set_max_length_file (P_dirname, P_ename, P_max_length, P_code); return; get_user_access_modes: entry (P_dirname, P_ename, P_user_name, P_ring, P_modes, P_exmodes, P_code); P_exmodes = ""b; /* msegs, like dirs, have only modes, no exmodes */ call message_segment_$validate (P_dirname, P_ename, P_code); if P_code = 0 then call hcs_$get_user_access_modes (P_dirname, P_ename, P_user_name, P_ring, ((36)"0"b), P_modes, P_code); return; end suffix_ms_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved