as_user_message_.alm 03/19/85 1108.7rew 03/19/85 0929.9 7389 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** " Transfer vector for as user message entrypoints " " Written 1985-02-16 by BIM name as_user_message_ macro tv entry &1 &1: call6 &2 &end tv priv_system_init,(user_message_priv_$system_init) tv priv_add_message,(user_message_priv_$add_message) tv priv_delete_message_id,(user_message_priv_$delete_message_id) tv priv_delete_process_messages,(user_message_priv_$delete_process_messages) tv user_read_message,(user_message_$read_message) tv admin_read_message,(user_message_admin_$read_message) end  asum_.pl1 08/04/87 1446.2rew 08/04/87 1221.5 21987 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /**** asum_.pl1 -- Gate target for as_user_message_ subsystem */ /* format: style2 */ /**** Written 1985-02-20 by BIM */ /****^ HISTORY COMMENTS: 1) change(87-06-24,GDixon), approve(87-07-07,MCR7719), audit(87-06-25,Hartogs), install(87-08-04,MR12.1-1055): Change declaration of asum_read_delete_ops_$priv_delete_process_id to match the actual subroutine. END HISTORY COMMENTS */ asum_: procedure; declare asum_inner_ring_caller_ entry (entry, pointer); declare asum_inner_ring_caller_$initial entry (entry, pointer); declare asum_add_message_ entry (pointer, fixed binary (35)); declare asum_read_delete_ops_$user_read_message entry (pointer, pointer, fixed binary (35)); declare asum_read_delete_ops_$priv_delete_message_id entry (bit (72) aligned, fixed binary (35)); declare asum_read_delete_ops_$priv_delete_process_id entry (bit (36) aligned, fixed binary (35)); declare asum_read_delete_ops_$admin_read entry (pointer, pointer, pointer, fixed binary (35)); declare asum_system_init_ entry (fixed binary (35)); declare cu_$arg_list_ptr entry returns (pointer); priv_add: entry; call asum_inner_ring_caller_ (asum_add_message_, cu_$arg_list_ptr ()); return; user_read: entry; call asum_inner_ring_caller_ (asum_read_delete_ops_$user_read_message, cu_$arg_list_ptr ()); return; priv_delete_process_messages: entry; call asum_inner_ring_caller_ (asum_read_delete_ops_$priv_delete_process_id, cu_$arg_list_ptr ()); return; priv_delete_message_id: entry; call asum_inner_ring_caller_ (asum_read_delete_ops_$priv_delete_message_id, cu_$arg_list_ptr ()); return; admin_read: entry; call asum_inner_ring_caller_ (asum_read_delete_ops_$admin_read, cu_$arg_list_ptr ()); return; system_init: entry; call asum_inner_ring_caller_$initial (asum_system_init_, cu_$arg_list_ptr ()); end asum_;  asum_add_message_.pl1 09/04/86 1451.3rew 09/04/86 1441.5 71568 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-05-31,Swenson), approve(86-07-25,MCR7302), audit(86-08-13,EJSharpe), install(86-09-04,MR12.0-1147): Fixed to ensure all sending process security-relevant information is set in message segment entry. END HISTORY COMMENTS */ /* asum_add_message_ -- procedure that appends a message to the database for delivery. This is the gate target, effectively */ /* format: style2,indcomtxt */ asum_add_message_: procedure (P_add_info_ptr, P_code); /* Written 2/20/85 BIM */ /* Modified 1985-04, BIM: changed for new mseg_ calling sequences. */ /**** NOTE: this implements the initial strategy of keeping all the destination information in the _system segment. This limits to 16K messages outstanding. For volume applications, something better is needed. Also, note that this locks the database for the entire operation, making no use of the potential lockless update. */ declare P_add_info_ptr pointer; declare P_code fixed bin (35); declare 1 add_info aligned like as_user_message_add_info; declare code fixed bin (35); declare message_added bit (1) aligned; declare hx fixed bin; declare ms_ptr pointer; declare start_n_segments fixed bin; declare sx fixed bin; /* Entries */ declare asum_error_ entry options (variable); declare asum_find_segment_ entry (fixed binary, pointer); declare asum_create_segment_ entry (fixed binary, pointer); declare get_group_id_ entry () returns (char (32)); declare get_process_authorization_ entry () returns (bit (72) aligned); declare get_process_max_authorization_ entry () returns (bit (72) aligned); declare set_lock_$lock entry (bit (36) aligned, fixed binary, fixed binary (35)); declare set_lock_$unlock entry (bit (36) aligned, fixed binary (35)); declare error_table_$bad_arg fixed bin (35) ext static; declare error_table_$notalloc fixed bin (35) ext static; dcl addr builtin; dcl bin builtin; dcl bit builtin; dcl hbound builtin; dcl stacq builtin; dcl unspec builtin; %include as_user_message_system; %include as_user_message_add; %include asum_data_; %include mseg_entries; %include mseg_data_; %include mseg_operation; %include mseg_access_operation; %include mseg_wakeup_state; %include mseg_message_info; %include entry_access_info; as_user_message_add_info_ptr = P_add_info_ptr; add_info = as_user_message_add_info; /* Copy the parm. We will copy back out */ as_user_message_system_info_ptr = asum_data_$system_info_ptr; as_user_message_perprocess_info_ptr = asum_data_$process_info_ptr; if add_info.process_id = ""b | add_info.handle = ""b then call RETURN_ERROR (error_table_$bad_arg); call lock_database; do hx = 1 to hbound (as_user_message_system_info.destination_am, 1); if stacq (as_user_message_system_info.destination_am (hx).process_id, add_info.process_id, ""b) then go to HAVE_HX; end; call asum_error_ (0, "asum_add_message_", "destination AM full."); HAVE_HX: if hx > as_user_message_system_info.highest_in_use then begin; declare his bit (36) aligned based (his_ptr); declare his_ptr pointer; declare new_his bit (36) aligned; declare old_his bit (36) aligned; old_his = unspec (as_user_message_system_info.highest_in_use); new_his = bit (bin (hx, 36), 36); his_ptr = addr (as_user_message_system_info.highest_in_use); do while (^stacq (his, new_his, old_his) & hx > bin (old_his, 36)); /* use old_his to assure same comparison as stacq */ old_his = unspec (as_user_message_system_info.highest_in_use); end; end; message_added = "0"b; do while (^message_added); start_n_segments = as_user_message_system_info.n_segments; do sx = 0 to start_n_segments - 1; call asum_find_segment_ (sx, ms_ptr); /* in PP data or the hard way */ call TRY_ADD_MESSAGE (hx, ms_ptr); end; if ^message_added then call ADD_SEGMENT; /* but start at the beginning again */ end; call unlock_database; /**** Arrive here on success */ P_code = 0; as_user_message_add_info = add_info; /* Copy parm back out */ return; RETURN_ERROR: procedure (code); declare code fixed bin (35); P_code = code; go to ERROR_RETURN; end RETURN_ERROR; ERROR_RETURN: return; ADD_SEGMENT: procedure; if start_n_segments ^= as_user_message_system_info.n_segments then return; /**** So readers don't have to lock, create before bumping the count. readers won't try to look at an uninitialized segment, and writers will wait on the lock and then discover that we have added one. */ call asum_create_segment_ (as_user_message_system_info.n_segments, ms_ptr); as_user_message_system_info.n_segments = as_user_message_system_info.n_segments + 1; return; end ADD_SEGMENT; lock_database: procedure; if ^stacq (as_user_message_system_info.lock, asum_data_$lock_id, ""b) then call set_lock_$lock (as_user_message_system_info.lock, -1, (0)); asum_data_$db_locked = "1"b; return; end lock_database; unlock_database: procedure; if ^stacq (as_user_message_system_info.lock, ""b, asum_data_$lock_id) then call set_lock_$unlock (as_user_message_system_info.lock, (0)); asum_data_$db_locked = "0"b; return; end unlock_database; TRY_ADD_MESSAGE: procedure (hx, a_mseg_ptr); declare hx fixed bin; declare a_mseg_ptr pointer; declare l_message_id bit (72) aligned; declare 1 am_entry aligned like as_user_message_system_info.destination_am based (amep); declare amep pointer; declare 1 mop aligned like mseg_operation; amep = addr (as_user_message_system_info.destination_am (hx)); mop = addr (mseg_data_$template_operation) -> mseg_operation; mop.suppress_access_checks = "1"b; mop.mseg_ptr = a_mseg_ptr; mop.mseg_ptr_valid = "1"b; mop.message_info.ms_ptr = add_info.message_ptr; mop.message_info.ms_len = 36 * add_info.message_length; mop.message_info.ms_id = ""b; /* let mseg generate it */ mop.message_info.ms_access_class = add_info.message_access_class; mop.message_info.sender_id = get_group_id_ (); mop.message_info.sender_process_id = asum_data_$process_id; mop.message_info.sender_level = asum_data_$entry_ring; mop.message_info.sender_authorization = get_process_authorization_ (); mop.message_info.sender_max_authorization = get_process_max_authorization_ (); mop.message_info.sender_audit = ""b; mop.message_info_valid = "1"b; mop.add_message_info_all_valid = "1"b; call mseg_$add_message (addr (mop), code); l_message_id = mop.message_info.ms_id; if code ^= 0 & code ^= error_table_$notalloc then do; do while ( ^stacq (as_user_message_system_info.destination_am (hx).process_id, ""b, add_info.process_id)); end; call asum_error_ (code, "asum_add_message_", "Failed to add message to message segment."); end; if code = error_table_$notalloc then return; if code = 0 then do; unspec (as_user_message_id) = l_message_id; as_user_message_id.segment_index = sx; l_message_id = unspec (as_user_message_id); add_info.message_id = l_message_id; am_entry.handle = add_info.destination_info.handle; am_entry.message_id = l_message_id; am_entry.ring = add_info.destination_info.ring; am_entry.group_id = add_info.destination_info.group_id; am_entry.reader_deletes = add_info.destination_info.reader_deletes; am_entry.access_class = add_info.message_access_class; message_added = "1"b; end; return; end TRY_ADD_MESSAGE; end asum_add_message_;  asum_create_segment_.pl1 04/09/85 1435.7r w 04/08/85 1128.1 52389 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* asum_create_segment_ -- program to create (if needed) and initialize one segment of the as_user_message. Note that this program is NOT used by a process reading that wants to initiate a new segment, only by a process that KNOWS that the segment in question has not yet been used in the current session. Thus it cheerfully truncates segments that already exist. */ /* format: style5,indcomtxt */ /* Written 2/20/85, BIM */ asum_create_segment_: procedure (P_segment_index, P_segment_ptr); declare P_segment_index fixed bin; /* Which segment do we create ? */ declare P_segment_ptr pointer; %include asum_data_; %include as_user_message_system; %include access_mode_values; %page; declare code fixed bin (35); declare saved_privileges bit (36) aligned; declare segment_entryname char (32); declare seg_ptr pointer; declare first bit (1) aligned; declare admin_gate_$set_privileges entry (bit (36) aligned, bit (36) aligned); declare admin_gate_$reset_privileges entry (bit (36) aligned); declare asum_error_ entry options (variable); /* signals a condition, unwinding */ declare delete_$path entry (character (*), character (*), bit (36) aligned, character (*), fixed binary (35)); declare hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35)); declare hcs_$replace_acl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35)); declare hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35)); declare initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); declare pathname_ entry (character (*), character (*)) returns (character (168)); declare error_table_$noentry fixed bin (35) ext static; declare ( sys_info$seg_privilege, sys_info$dir_privilege ) bit (36) aligned external; declare cleanup condition; dcl addr builtin; dcl string builtin; dcl substr builtin; %page; first = "0"b; go to COMMON; first: entry (P_segment_ptr); first = "1"b; COMMON: /**** Assume caller is at validation level 1 */ saved_privileges = ""b; on cleanup begin; if substr (saved_privileges, 36, 1) = "1"b then call admin_gate_$reset_privileges (saved_privileges); end; if ^first then do; as_user_message_segment_name.constant = AS_USER_MESSAGE_SEGMENT_NAME_CONSTANT; as_user_message_segment_name.index = P_segment_index; segment_entryname = string (as_user_message_segment_name); end; else segment_entryname = AS_USER_MESSAGE_SYSTEM_NAME; RETRY_INITIATE: call initiate_file_ (asum_data_$db_dir, segment_entryname, RW_ACCESS, seg_ptr, (0), code); if code ^= error_table_$noentry & code ^= 0 /* Something is busted */ then call PROBLEM_SEGMENT; /* ACL, or seg-fault, or ?dir? */ if code = error_table_$noentry then call CREATE_SEGMENT; /**** We get here with the segment initiated. */ call hcs_$truncate_seg (seg_ptr, 0, code); if code ^= 0 then call asum_error_ (code, "asum_create_segment_", "Failed to truncate segment ^a", pathname_ (asum_data_$db_dir, segment_entryname)); /**** The segment now exists and is empty. The message segment primitives provide no entrypoint to initialize an empty segment. They initialize it when you add something. So at this point we hand the segment up to our caller, who has the data to write the first message. */ P_segment_ptr = seg_ptr; return; %page; PROBLEM_SEGMENT: procedure; if asum_data_$db_multiclass then call admin_gate_$set_privileges (sys_info$seg_privilege | sys_info$dir_privilege, saved_privileges); call delete_$path (asum_data_$db_dir, segment_entryname, "101110"b, "", code); if code ^= 0 then call asum_error_ (code, "asum_create_segment_", "Segment ^a exists, but cannot be initiated or deleted.", pathname_ (asum_data_$db_dir, segment_entryname)); end PROBLEM_SEGMENT; %page; CREATE_SEGMENT: procedure; if asum_data_$db_multiclass & ^substr (saved_privileges, 36, 1) /* might be already set */ then call admin_gate_$set_privileges (sys_info$seg_privilege | sys_info$dir_privilege, saved_privileges); call hcs_$create_branch_ (asum_data_$db_dir, segment_entryname, addr (asum_data_$db_cbi), code); if code ^= 0 then call asum_error_ (code, "asum_create_segment_", "Failed to append ^a", pathname_ (asum_data_$db_dir, segment_entryname)); code = 0; if asum_data_$db_multiclass then call hcs_$replace_acl (asum_data_$db_dir, segment_entryname, addr (asum_data_$acl_entries), asum_data_$n_acl_entries, "1"b, code); if code ^= 0 then call asum_error_ (code, "asum_create_segment_", "Failed to replace the ACL of ^a", pathname_ (asum_data_$db_dir, segment_entryname)); if substr (saved_privileges, 36, 1) = "1"b then call admin_gate_$reset_privileges (saved_privileges); go to RETRY_INITIATE; /* Okay, its there now */ end CREATE_SEGMENT; end asum_create_segment_;  asum_data_.cds 03/15/89 0851.9r w 03/15/89 0800.6 35199 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* asum_data_ -- static information for the as_user_message facility */ /* format: style2,indcomtxt */ asum_data_: procedure; /* Created 1985-01, BIM */ /* Automatic */ dcl 1 cdsa aligned like cds_args; dcl code fixed bin (35); /* Constants */ dcl NAME char (32) int static init ("asum_data_") options (constant); dcl EXCLUDE_PAD (1) char (32) aligned static options (constant) init ("pad*"); /* Entries */ dcl com_err_ entry options (variable); dcl create_data_segment_ entry (ptr, fixed bin (35)); declare sys_info$access_class_ceiling bit (72) aligned ext; /* The structure */ dcl static_ptr pointer; dcl 1 asum_data_static aligned based (static_ptr), 2 db_dir char (168) unaligned, /* Where ? */ 2 db_dir_rb (2) fixed bin (3), 2 db_rb (3) fixed bin (3), /* What RB's? */ 2 db_multiclass bit (1) aligned, /* Multiclass */ 2 db_cbi aligned like create_branch_info, /* The whole story */ 2 db_dir_cbi aligned like create_branch_info, 2 system_info_ptr pointer init (null ()), 2 process_info_ptr pointer init (null ()), 2 entry_ring fixed bin (3), /* perprocess, for auditing purposes */ 2 lock_id bit (36) aligned, 2 process_id bit (36) aligned, /* cheapify locking */ 2 db_locked bit (1) aligned, /* for cleanup handlers */ 2 n_acl_entries fixed bin, 2 acl_entries (static_n_acl_entries refer (asum_data_static.n_acl_entries)) aligned like general_extended_acl_entry; declare static_n_acl_entries fixed bin; %page; %include acl_structures; %include access_mode_values; %include create_branch_info; %include cds_args; %page; static_n_acl_entries = 1; allocate asum_data_static; asum_data_static.db_dir = ">system_control_1>user_messages"; asum_data_static.db_rb (*) = 1; asum_data_static.db_dir_rb (*) = 1; asum_data_static.db_multiclass = "1"b; asum_data_static.acl_entries (1).access_name = "*.*.*"; asum_data_static.acl_entries (1).mode = RW_ACCESS; asum_data_static.acl_entries (1).extended_mode = "11111"b; /* just in case */ asum_data_static.acl_entries (1).status_code = 0; begin; declare cbip pointer; declare 1 CBI aligned like create_branch_info based (cbip); cbip = addr (asum_data_static.db_cbi); unspec (CBI) = ""b; CBI.version = create_branch_version_2; CBI.priv_upgrade_sw = asum_data_static.db_multiclass; CBI.parent_ac_sw = ^CBI.priv_upgrade_sw; CBI.mode = ""b; /* ACL set seperately */ CBI.rings = asum_data_static.db_rb; CBI.userid = "*.*.*"; CBI.bitcnt = 0; CBI.quota = 0; if CBI.priv_upgrade_sw then CBI.access_class = sys_info$access_class_ceiling; else ; /* ignored */ CBI.dir_quota = 0; addr (asum_data_static.db_dir_cbi) -> CBI = CBI; cbip = addr (asum_data_static.db_dir_cbi); CBI.dir_sw = "1"b; CBI.parent_ac_sw = "1"b; CBI.priv_upgrade_sw = "0"b; CBI.rings (1) = 1; CBI.rings (2) = 1; CBI.mode = SMA_ACCESS; CBI.userid = "*.*.*"; end; /* Now set up call to create data base */ cdsa.sections (2).p = addr (asum_data_static); cdsa.sections (2).len = size (asum_data_static); cdsa.sections (2).struct_name = "asum_data_static"; cdsa.seg_name = NAME; cdsa.num_exclude_names = 1; cdsa.exclude_array_ptr = addr (EXCLUDE_PAD); string (cdsa.switches) = "0"b; cdsa.switches.have_static = "1"b; call create_data_segment_ (addr (cdsa), code); if code ^= 0 then call com_err_ (code, NAME); return; end asum_data_;  asum_error_.pl1 05/09/85 1151.3rew 05/07/85 1544.3 17829 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* asum_error_ -- general error trap */ /* format: style2 */ /**** Written 1985-02-20 by BIM */ asum_error_: procedure options (variable); declare error_switch bit (1) aligned; declare as_user_message_error_ condition; declare admin_gate_$syserr entry options (variable); declare cu_$arg_list_ptr entry returns (ptr); declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); declare convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned); declare ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1) aligned, bit (1) aligned); declare ioa_ entry () options (variable); %include asum_data_; %include syserr_constants; declare code_ptr pointer; declare code fixed bin (35) based (code_ptr); declare error_message char (100) aligned; declare message_1 char (1000); declare name_ptr ptr; declare name_length fixed bin (21); declare name char (name_length) based (name_ptr); error_switch = "1"b; go to COMMON; log: entry; error_switch = "0"b; COMMON: call cu_$arg_ptr (1, code_ptr, (0), (0)); if code ^= 0 then call convert_status_code_ (code, "", error_message); else error_message = ""; call cu_$arg_ptr (2, name_ptr, name_length, (0)); message_1 = ""; call ioa_$general_rs (cu_$arg_list_ptr (), 3, 4, message_1, (0), "0"b, "0"b); if asum_data_$db_multiclass then call admin_gate_$syserr (LOG, "^a: ^a ^a", name, error_message, message_1); else call ioa_ ("^a: ^a ^a", name, error_message, message_1); if error_switch then signal as_user_message_error_; end asum_error_;  asum_find_segment_.pl1 04/09/85 1435.7r w 04/08/85 1128.1 28305 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* asum_find_segment_ -- per-process finder of existing segments. assumes that asum_data_$system_info_ptr is set. tolerates asum_data_$process_info_ptr = null (); */ /* format: style5,indcomtxt */ /**** Written 1985-02-20 by BIM */ asum_find_segment_: procedure (P_segment_index, P_segment_ptr); declare P_segment_index fixed bin; /* Which segment do we create ? */ declare P_segment_ptr pointer; dcl null builtin; dcl string builtin; %include asum_data_; %include as_user_message_system; %include access_mode_values; %page; declare code fixed bin (35); declare segment_entryname char (32); declare seg_ptr pointer; declare first bit (1) aligned; declare asum_error_ entry options (variable); /* signals a condition, unwinding */ declare initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); declare pathname_ entry (character (*), character (*)) returns (character (168)); %page; first = "0"b; go to COMMON; first: entry; first = "1"b; COMMON: as_user_message_perprocess_info_ptr = asum_data_$process_info_ptr; as_user_message_system_info_ptr = asum_data_$system_info_ptr; if ^first then do; as_user_message_segment_name.constant = AS_USER_MESSAGE_SEGMENT_NAME_CONSTANT; as_user_message_segment_name.index = P_segment_index; segment_entryname = string (as_user_message_segment_name); end; else segment_entryname = AS_USER_MESSAGE_SYSTEM_NAME; seg_ptr = null (); if ^first then if asum_data_$process_info_ptr ^= null () then call look_in_perprocess_info; if seg_ptr = null () then do; call initiate_file_ (asum_data_$db_dir, segment_entryname, RW_ACCESS, seg_ptr, (0), code); if code ^= 0 then if ^first then call asum_error_ (code, "asum_find_segment_", "Missing segment index ^d", P_segment_index) ; else call asum_error_ (code, "asum_find_segment_", "Missing as_user_message_system_data"); if asum_data_$process_info_ptr ^= null () then if ^first then as_user_message_perprocess_info .mseg_ptr (P_segment_index) = seg_ptr; else asum_data_$system_info_ptr = seg_ptr; end; if ^first then P_segment_ptr = seg_ptr; return; look_in_perprocess_info: procedure; if as_user_message_perprocess_info.mseg_ptr (P_segment_index) ^= null () then seg_ptr = as_user_message_perprocess_info.mseg_ptr (P_segment_index); return; end look_in_perprocess_info; end asum_find_segment_;  asum_inner_ring_caller_.pl1 05/17/85 1652.7rew 05/17/85 1644.7 53253 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* asum_inner_ring_caller_ -- sets up an error handler and cleanup handler, sets up perprocess info, find the first segment, and calls the real target. The system info ptr and perprocess info per are set in static to avoid massively complicated arg list manipulation. */ /* format: style2,indcomtxt */ /**** Written 1985-02-20 by BIM Modified 1985-05-17 by E. Swenson: Added check for locked database. */ asum_inner_ring_caller_: procedure (P_target, P_arg_list_ptr); /* Parameters */ declare P_target entry variable; declare P_arg_list_ptr pointer; /* Entries */ declare admin_gate_$syserr entry options (variable); declare asum_error_ entry options (variable); declare asum_find_segment_$first entry; declare cu_$generate_call entry (entry, ptr); declare cu_$level_get entry returns (fixed bin (3)); declare cu_$level_set entry (fixed bin (3)); declare get_process_id_ entry () returns (bit (36)); declare get_lock_id_ entry () returns (bit (36)); declare get_group_id_ entry() returns(char(32)); declare get_ring_ entry () returns (fixed bin (3)); declare get_system_free_area_ entry () returns (ptr); declare ioa_ entry options (variable); declare set_lock_$unlock entry (bit (36) aligned, fixed binary (35)); declare sub_err_ entry options (variable); /* External */ declare error_table_$fatal_error fixed bin (35) external; declare sys_info$time_of_bootload fixed bin (71) aligned external; /* Constant */ dcl ME char (32) initial ("asum_inner_ring_caller_") internal static options (constant); /* Conditions */ declare cleanup condition; declare as_user_message_error_ condition; /* Misc */ declare system_area area based (get_system_free_area_ ()); declare initial_switch bit (1) aligned; dcl null builtin; %page; initial_switch = "0"b; as_user_message_system_info_ptr = asum_data_$system_info_ptr; go to COMMON; initial: entry (P_target, P_arg_list_ptr); initial_switch = "1"b; COMMON: asum_data_$entry_ring = cu_$level_get (); on cleanup begin; call cu_$level_set (asum_data_$entry_ring); if ^initial_switch then if asum_data_$db_locked then do; call set_lock_$unlock (as_user_message_system_info.lock, (0)); asum_data_$db_locked = "0"b; end; end; on as_user_message_error_ /* message is already written */ goto NON_LOCAL_ABORT; /* will cause cleanup handlers to run */ call cu_$level_set (get_ring_ ()); if ^initial_switch then call get_static_pointers; /* insures that we have the neccessary pointers */ call cu_$generate_call (P_target, P_arg_list_ptr); if ^initial_switch then if asum_data_$db_locked then do; call set_lock_$unlock (as_user_message_system_info.lock, (0)); asum_data_$db_locked = "0"b; if asum_data_$db_multiclass then call admin_gate_$syserr (LOG, "^a: ASUM database found locked after return from call by ^a.", ME, get_group_id_ ()); else call ioa_ ("^a: ASUM database found locked after return from call by ^a.", ME, get_group_id_ ()); end; call cu_$level_set (asum_data_$entry_ring); return; /**** The following code is executed upon any ASUM program signalling the as_user_message_error_ condition. The non-local goto will cause cleanup handlers to run. Then we will check to see if the database is locked, and unlock it if necessary. We will also reset the validation level. */ NON_LOCAL_ABORT: if ^initial_switch then if asum_data_$db_locked then do; call set_lock_$unlock (as_user_message_system_info.lock, (0)); asum_data_$db_locked = "0"b; end; call cu_$level_set (asum_data_$entry_ring); call sub_err_ (error_table_$fatal_error, ME, ACTION_CANT_RESTART, null (), (0), "An unexpected error has occured during the execution of an as user message facility program. See the syserr log for details." ); return; get_static_pointers: procedure; if asum_data_$process_info_ptr = null () then do; asum_data_$process_id = get_process_id_ (); asum_data_$lock_id = get_lock_id_ (); allocate as_user_message_perprocess_info in (system_area); as_user_message_perprocess_info.sentinel = AS_USER_MESSAGE_PROCESS_SENTINEL; as_user_message_perprocess_info.mseg_ptr (*) = null (); asum_data_$process_info_ptr = as_user_message_perprocess_info_ptr; end; if asum_data_$system_info_ptr = null () then do; call asum_find_segment_$first; as_user_message_system_info_ptr = asum_data_$system_info_ptr; if as_user_message_system_info.time_of_bootload ^= sys_info$time_of_bootload then call asum_error_ (0, "asum_inner_ring_caller_", "as_user_message facility not initialized."); end; return; end get_static_pointers; /* format: off */ %page; %include as_user_message_system; %page; %include asum_data_; %page; %include sub_err_flags; %page; %include syserr_constants; %page; /* BEGIN MESSAGE DOCUMENTATION Message: asum_inner_ring_caller_: ASUM database found locked after return from call by GROUP_ID S: $info T: $run M: $err The AS user message facility was called and upon return from the call the transfer routine asum_inner_ring_caller_ detected that the ASUM database (>sc1>user_messages>as_user_message_system) was left locked. The lock has been unlocked but the database may be inconsistent. This should never happen and if it does, indicates a coding error in the AS user message facility. A: $contact END MESSAGE DOCUMENTATION */ end asum_inner_ring_caller_;  asum_read_delete_ops_.pl1 08/04/87 1446.2rew 08/04/87 1221.5 186426 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-06-12,Swenson), approve(86-07-25,MCR7302), audit(86-08-13,EJSharpe), install(86-09-04,MR12.0-1147): Fixed setting of highest_in_use counter when messages are deleted from db. 2) change(85-08-01,Swenson), approve(86-07-25,MCR7302), audit(86-08-13,EJSharpe), install(86-09-04,MR12.0-1147): Fixed to correctly perform access checks for unprivileged read entries. 3) change(87-05-31,GDixon), approve(87-07-07,MCR7719), audit(87-06-24,Hartogs), install(87-08-04,MR12.1-1055): Sort destination_am entries by message_id in admin_search, so that entries can be read out in successive calls by message_id. 4) change(87-06-24,GDixon), approve(87-07-07,MCR7719), audit(87-06-24,Hartogs), install(87-08-04,MR12.1-1055): Change calling sequence of priv_delete_process_id to properly declare the process_id as bit(36) aligned. END HISTORY COMMENTS */ /* asum_read_delete_ops_.pl1 -- all entries that read and/or delete messages. */ /* format: style2 */ asum_read_delete_ops_: procedure; /***** Modification history: Created 1985-02-11, BIM Modified 1985-04, BIM: new mseg_ calling sequence Modified 1985-05-17, EJS: Fixed failure to unlock when no message is found for a user. */ /**** This procedure contains all the entries that have to search the database. They are collected here to share internal procedures that search the handle/pid associative memory. */ /**** ENTRIES HERE ARE GATE TARGETS! */ %include asum_data_; declare aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); declare aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); declare asum_find_segment_ entry (fixed binary, pointer); declare asum_error_ entry () options (variable); declare match_star_name_ entry (character (*), character (*), fixed binary (35)); declare get_group_id_ entry () returns (char (32)); declare get_process_authorization_ entry () returns (bit (72) aligned); declare get_privileges_ entry () returns (bit (36) aligned); declare set_lock_$lock entry (bit (36) aligned, fixed binary, fixed binary (35)); declare set_lock_$unlock entry (bit (36) aligned, fixed binary (35)); declare 1 admin_read_info aligned like as_user_message_admin_read_info; declare 1 read_info aligned like as_user_message_info; declare 1 search aligned, 2 process_id bit (36) aligned, /** 777777777777 for ANY */ 2 ring fixed bin (3) aligned, /** -1 for ANY */ 2 handle bit (72) aligned, /** zero for ANY */ 2 message_id bit (72) aligned, 2 read_this_one bit (1) aligned, 2 read_the_next_one bit (1) aligned, 2 aim_privileged bit (1) aligned, 2 authorization bit (72) aligned, 2 delete bit (1) aligned, 2 group_id char (32) unaligned; declare 1 mop aligned like mseg_operation; declare g_message_id bit (72) aligned; declare g_process_id bit (36) aligned; declare delete_the_message bit (1) aligned; declare P_area_ptr pointer; declare P_admin_read_info_ptr pointer; declare area_ptr pointer; declare P_read_info_ptr pointer; declare read_info_ptr pointer; declare P_message_id bit (72) aligned; declare P_process_id bit (36) aligned; declare P_code fixed bin (35); declare code fixed bin (35); declare sys_info$ring1_privilege bit (36) aligned ext; declare error_table_$notalloc fixed bin (35) ext static; declare error_table_$unimplemented_version fixed bin (35) ext static; declare error_table_$bad_arg fixed bin (35) ext static; declare error_table_$no_message fixed bin (35) ext static; dcl addr builtin; dcl divide builtin; dcl max builtin; dcl stacq builtin; dcl unspec builtin; user_read_message: entry (P_area_ptr, P_read_info_ptr, P_code); code = 0; /**** COPY PARAMETERS IN */ area_ptr = P_area_ptr; read_info_ptr = P_read_info_ptr; read_info = read_info_ptr -> as_user_message_info; as_user_message_system_info_ptr = asum_data_$system_info_ptr; if read_info.version ^= AS_USER_MESSAGE_INFO_VERSION_1 then call error_return (error_table_$unimplemented_version, USER_READ_ERROR); /****+ What search criteria do we have? Process_id --- this process Handle --- as given (if any) Prev_message_id --- as given (if any) Ring --- as given (if any) */ /**** The structure "search" is used as an implicit parameter by search table to describe the search information. */ unspec (search) = ""b; search.process_id = asum_data_$process_id; search.group_id = get_group_id_ (); if read_info.no_handle_given then search.handle = ""b; else if read_info.message_handle = ""b then call error_return (error_table_$bad_arg, USER_READ_ERROR); else search.handle = read_info.message_handle; if read_info.read_message_id & read_info.read_after_message_id then call error_return (error_table_$bad_arg, USER_READ_ERROR); if read_info.read_message_id then do; search.message_id = read_info.message_id; search.read_this_one = "1"b; end; if read_info.read_after_message_id then do; search.message_id = read_info.message_id; search.read_the_next_one = "1"b; end; search.delete = ^read_info.dont_delete; /* if message is to be deleted, take it out of the list NOW */ if read_info.ring_given then search.ring = max (asum_data_$entry_ring, read_info.message_ring); else search.ring = asum_data_$entry_ring; /* so that only one process can read it */ search.authorization = get_process_authorization_ (); search.aim_privileged = ((get_privileges_ () & sys_info$ring1_privilege) ^= ""b); call lock_database; /* This could all be done locklessly, but that efficiency is */ /* not neccessary for MR11 */ g_message_id = search_table (); /* Look for a message; delete_message is also set to the index in the table */ if g_message_id = ""b then do; call unlock_database; call error_return (error_table_$no_message, USER_READ_ERROR); end; /**** we know which message we want by ID. It has not been deleted from the mseg yet, even if it is to be. */ call read_out_message (g_message_id, code); /* sets fields in read_info, allocates in area, deletes as needed */ if code ^= 0 & code ^= error_table_$notalloc then call asum_error_ (code, "asum_read_delete_ops_", "Message ^.3b missing.", g_message_id); call unlock_database; P_code = code; read_info_ptr -> as_user_message_info = read_info; return; USER_READ_ERROR: return; priv_delete_message_id: entry (P_message_id, P_code); code = 0; g_message_id = P_message_id; as_user_message_system_info_ptr = asum_data_$system_info_ptr; call lock_database; call delete$$message_id (code); call unlock_database; P_code = code; return; priv_delete_process_id: entry (P_process_id, P_code); code = 0; g_process_id = P_process_id; as_user_message_system_info_ptr = asum_data_$system_info_ptr; call lock_database; call delete$$process_id (code); call unlock_database; code = P_code; return; admin_read: entry (P_admin_read_info_ptr, P_read_info_ptr, P_area_ptr, P_code); code = 0; as_user_message_admin_read_info_ptr = P_admin_read_info_ptr; as_user_message_info_ptr = P_read_info_ptr; area_ptr = P_area_ptr; admin_read_info = as_user_message_admin_read_info; read_info = as_user_message_info; as_user_message_system_info_ptr = asum_data_$system_info_ptr; if admin_read_info.version ^= AS_USER_MESSAGE_ADMIN_READ_INFO_VERSION_1 | read_info.version ^= AS_USER_MESSAGE_INFO_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; call lock_database; call admin_search; call unlock_database; P_code = code; as_user_message_info = read_info; return; delete$$message_id: procedure (code); declare code fixed bin (35); declare delete_by fixed bin (1); declare ( MID init (0), PID init (1) ) fixed bin int static options (constant); declare 1 am aligned like as_user_message_system_info.destination_am based (amep); declare amep pointer; declare hx fixed bin; delete_by = MID; go to COMMON; delete$$process_id: entry (code); delete_by = PID; COMMON: code = error_table_$no_message; do hx = 1 to as_user_message_system_info.highest_in_use; amep = addr (as_user_message_system_info.destination_am (hx)); if am.process_id = ""b then ; else if delete_by = PID then do; if am.process_id = g_process_id then do; call delete_mseg_msg (am.message_id); call delete_am_entry (hx); code = 0; /* got one */ end; end; else if delete_by = MID then do; if am.message_id = g_message_id then do; call delete_mseg_msg (am.message_id); call delete_am_entry (hx); code = 0; /* got one */ return; /* only one per */ end; end; end; return; /* no_message */ end delete$$message_id; search_table: procedure returns (bit (72) aligned); /**** This procedure searches for destination matches, looking for the oldest message that matches. Since this implementation keeps the table locked for the duration, this can assume that nothing will change. */ declare youngest_message_id bit (72) aligned; declare amep pointer; declare 1 am aligned like as_user_message_system_info.destination_am based (amep); declare am_real_message_id bit (72) aligned; declare search_real_message_id bit (72) aligned; declare x fixed bin; declare message_x fixed bin; youngest_message_id = (72)"1"b; delete_the_message = "0"b; unspec (as_user_message_id) = search.message_id; as_user_message_id.segment_index = 0; search_real_message_id = unspec (as_user_message_id); do x = 1 to as_user_message_system_info.highest_in_use; amep = addr (as_user_message_system_info.destination_am (x)); if am.process_id = ""b then go to TRY_NEXT; if (am.process_id ^= (36)"1"b) & (search.process_id ^= am.process_id) then go to TRY_NEXT; if (am.process_id = (36)"1"b) & ^group_match (am.group_id, search.group_id) then go to TRY_NEXT; if (search.ring >= 0) & (search.ring ^= am.ring) then go to TRY_NEXT; if (search.handle ^= ""b) & (search.handle ^= am.handle) then go to TRY_NEXT; if ^check_aim () then goto TRY_NEXT; else if search.read_this_one then /* No other matching required */ if am.message_id = search.message_id then return (SET_RETURN_INFO_AND_MAYBE_DELETE (x)); else ; else do; unspec (as_user_message_id) = am.message_id; as_user_message_id.segment_index = 0; am_real_message_id = unspec (as_user_message_id); if (search.read_the_next_one & am_real_message_id > search_real_message_id) | ^search.read_the_next_one then if am_real_message_id < youngest_message_id then do; youngest_message_id = am_real_message_id; message_x = x; end; end; TRY_NEXT: end; if youngest_message_id = (72)"1"b then return (""b); else return (SET_RETURN_INFO_AND_MAYBE_DELETE (message_x)); %page; check_aim: procedure returns (bit (1) aligned); if search.aim_privileged then return ("1"b); if aim_check_$greater_or_equal (search.authorization, am.access_class) then return ("1"b); /* Deletion AIM later on */ return ("0"b); end check_aim; SET_RETURN_INFO_AND_MAYBE_DELETE: procedure (P_message_index) returns (bit (72) aligned); dcl P_message_index fixed bin parameter; dcl message_id bit (72) aligned automatic; amep = addr (as_user_message_system_info.destination_am (P_message_index)); read_info.destination_info.group_id = am.group_id; read_info.destination_info.process_id = am.process_id; read_info.destination_info.ring = am.ring; read_info.message_info.message_handle = am.handle; message_id = am.message_id; if am.reader_deletes & search.delete then do; if search.aim_privileged | aim_check_$equal (search.authorization, am.access_class) then do; call delete_am_entry (P_message_index); delete_the_message = "1"b; end; end; return (message_id); end SET_RETURN_INFO_AND_MAYBE_DELETE; end search_table; group_match: procedure (star, try) returns (bit (1) aligned); declare (star, try) char (32); declare code fixed bin (35); if star = "" then return ("1"b); call match_star_name_ (try, star, code); return (code = 0); end group_match; read_out_message: procedure (a_mid, code); declare a_mid bit (72) aligned; declare code fixed bin (35); declare fx fixed bin; declare mseg_ptr pointer; unspec (as_user_message_id) = a_mid; fx = as_user_message_id.segment_index; as_user_message_id.segment_index = 0; mop = addr (mseg_data_$template_operation) -> mseg_operation; mop.message_info.message_code = MSEG_READ_SPECIFIED; mop.message_info.control_flags = ""b; mop.message_info.delete = delete_the_message; mop.message_info.ms_id = unspec (as_user_message_id); mop.suppress_access_checks = "1"b; mop.message_info_valid = "1"b; call asum_find_segment_ (fx, mseg_ptr); mop.mseg_ptr = mseg_ptr; mop.mseg_ptr_valid = "1"b; call mseg_$read_message (addr (mop), area_ptr, code); read_info.message_ptr = mop.message_info.ms_ptr; read_info.message_length = divide (mop.message_info.ms_len, 36, 18, 0); read_info.message_id = mop.message_info.ms_id; read_info.message_info.message_access_class = mop.message_info.ms_access_class; read_info.message_info.message_ring = mop.message_info.sender_level; /* messages don't have rings */ read_info.sender_info.group_id = mop.message_info.sender_id; read_info.sender_info.process_id = mop.message_info.sender_process_id; return; end read_out_message; delete_mseg_msg: procedure (a_mid); declare a_mid bit (72) aligned; declare code fixed bin (35); declare fx fixed bin; declare mseg_ptr pointer; unspec (as_user_message_id) = a_mid; fx = as_user_message_id.segment_index; as_user_message_id.segment_index = 0; call asum_find_segment_ (fx, mseg_ptr); mop = addr (mseg_data_$template_operation) -> mseg_operation; mop.message_info.ms_id = unspec (as_user_message_id); mop.message_info_valid = "1"b; mop.suppress_access_checks = "1"b; call asum_find_segment_ (fx, mseg_ptr); mop.mseg_ptr = mseg_ptr; mop.mseg_ptr_valid = "1"b; call mseg_$delete_message (addr (mop), code); if code ^= 0 then call asum_error_ (code, "asum_read_delete_ops_", "Failed to delete message ^.3b from message segment ^d.", a_mid, fx); return; end delete_mseg_msg; error_return: procedure (code, return_label); declare code fixed bin (35); declare return_label label; P_code = code; go to return_label; end error_return; admin_search: procedure; /**** DUMB program to search against the admin_search data structure */ declare 1 am aligned based (amep) like as_user_message_system_info.destination_am; declare amep pointer; declare hx fixed bin; declare mid_mask bit (72) aligned init ("000777777777777777777777"b3) int static options (constant); declare 1 min_am aligned based (min_amep) like as_user_message_system_info.destination_am; declare min_amep pointer; declare minx fixed bin; declare 1 temp_am aligned like as_user_message_system_info.destination_am automatic; if as_user_message_system_info.highest_in_use = 0 then code = error_table_$no_message; /**** This algorithm depends upon the destination_am being sorted in message_id order, so we can step through from one id to the next in successive admin_read calls. */ do minx = 1 to as_user_message_system_info.highest_in_use-1; min_amep = addr (as_user_message_system_info.destination_am (minx)); do hx = minx to as_user_message_system_info.highest_in_use; amep = addr (as_user_message_system_info.destination_am (hx)); if min_am.message_id > am.message_id then do; temp_am = am; am = min_am; min_am = temp_am; end; end; end; search.authorization = get_process_authorization_ (); search.aim_privileged = ((get_privileges_ () & sys_info$ring1_privilege) ^= ""b); do hx = 1 to as_user_message_system_info.highest_in_use; amep = addr (as_user_message_system_info.destination_am (hx)); if am.process_id = ""b then go to TRY_NEXT; if admin_read_info.after_message_id ^= ""b then if (am.message_id & mid_mask) <= (admin_read_info.after_message_id & mid_mask) then go to TRY_NEXT; if admin_read_info.target_handle ^= ""b then if am.handle ^= admin_read_info.target_handle then go to TRY_NEXT; if admin_read_info.target_process_id ^= ""b then if am.process_id ^= admin_read_info.target_process_id then go to TRY_NEXT; if admin_read_info.target_group_id ^= "" then if ^group_match (admin_read_info.target_group_id, am.group_id) then go to TRY_NEXT; if ^search.aim_privileged then if ^aim_check_$greater_or_equal (search.authorization, am.access_class) then go to TRY_NEXT; /**** Well, the target spec matches. If there is a source spec, we have to read the message out to see who sent it. Pain, as they say, in the ass. */ delete_the_message = "0"b; call read_out_message (am.message_id, code); if code ^= 0 & code ^= error_table_$notalloc then call asum_error_ (code, "asum_read_delete_ops_", "Failed to read out message ^.3b", am.message_id); if code ^= 0 then return; /* Caller area too small */ if (admin_read_info.source_group_id ^= "" & ^group_match (admin_read_info.source_group_id, mop.message_info.sender_id)) | (admin_read_info.source_process_id ^= ""b & admin_read_info.source_process_id ^= mop.message_info.sender_process_id) then begin; declare to_free bit (mop.message_info.ms_len) based (mop.message_info.ms_ptr); free to_free; go to TRY_NEXT; end; read_info.destination_info.group_id = am.group_id; read_info.destination_info.process_id = am.process_id; read_info.destination_info.ring = am.ring; read_info.sender_info.group_id = mop.message_info.sender_id; read_info.sender_info.process_id = mop.message_info.sender_process_id; read_info.message_handle = am.handle; read_info.dont_delete = ^am.reader_deletes; return; TRY_NEXT: end; code = error_table_$no_message; return; end admin_search; %page; delete_am_entry: procedure (amx); declare amx fixed bin; declare hx fixed bin; declare q bit (1) aligned; q = stacq (as_user_message_system_info.destination_am (amx).process_id, ""b, (as_user_message_system_info.destination_am (amx).process_id)); if amx = as_user_message_system_info.highest_in_use then do; do hx = amx to 1 by -1 while (as_user_message_system_info.destination_am (hx).process_id = ""b); end; /* hx is 0 or index of last in use */ as_user_message_system_info.highest_in_use = hx; end; return; end delete_am_entry; lock_database: procedure; if ^stacq (as_user_message_system_info.lock, asum_data_$lock_id, ""b) then call set_lock_$lock (as_user_message_system_info.lock, -1, (0)); asum_data_$db_locked = "1"b; return; end lock_database; unlock_database: procedure; if ^stacq (as_user_message_system_info.lock, ""b, asum_data_$lock_id) then call set_lock_$unlock (as_user_message_system_info.lock, (0)); asum_data_$db_locked = "0"b; return; end unlock_database; /* format: off */ %page; %include as_user_message_system; %page; %include mseg_message_info; %page; %include as_user_message_info; %page; %include as_user_message_aread; %page; %include mseg_operation; %page; %include mseg_access_operation; %page; %include mseg_wakeup_state; %page; %include entry_access_info; %page; %include mseg_entries; %page; %include mseg_data_; end asum_read_delete_ops_;  asum_system_init_.pl1 08/04/87 1446.2rew 08/04/87 1221.6 70101 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-03-28,Swenson), approve(87-07-07,MCR7719), audit(87-06-24,Hartogs), install(87-08-04,MR12.1-1055): Fixed so that the Initializer process can use the UM facility. END HISTORY COMMENTS */ /* asum_system_init_.pl1 -- program called by the initializer to set up as_user_messages */ /* format: style5,indcomtxt */ asum_system_init_: procedure (P_error_code); /* Full complaint registered via syserr */ /**** Created: 1985-02-01, BIM */ declare P_error_code fixed bin (35); declare asum_error_$log entry options (variable); declare asum_create_segment_ entry (fixed binary, pointer); declare asum_create_segment_$first entry (pointer); declare expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl get_process_id_ entry () returns (bit (36) aligned); dcl get_lock_id_ entry () returns (bit (36) aligned); declare get_system_free_area_ entry () returns (ptr); declare hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); declare hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); declare hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35)); declare hphcs_$delentry_file entry (char (*), char (*), fixed bin (35)); declare hphcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); declare hcs_$replace_inacl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (3), fixed bin (35)); declare pathname_ entry (character (*), character (*)) returns (character (168)); declare unique_chars_ entry (bit (*)) returns (char (15)); declare code fixed bin (35); declare error_table_$noentry fixed bin (35) ext static; declare sys_info$time_of_bootload fixed bin (71) ext; dcl addr builtin; dcl null builtin; dcl sum builtin; dcl unspec builtin; %page; %include as_user_message_system; %include asum_data_; P_error_code = 0; call find_or_create_db_dir; call clean_out_db_dir; call initialize_first_segment; return; ERROR: P_error_code = -1; return; find_or_create_db_dir: procedure; declare type fixed bin (2); call hcs_$status_minf (asum_data_$db_dir, "", (0), type, (0), code); if code = error_table_$noentry then call create_db_dir; else if code ^= 0 then do; call remove_old_entry; call create_db_dir; end; else if type ^= 2 /* Directory */ then do; call rename_old_entry; call create_db_dir; end; return; remove_old_entry: procedure; call asum_error_$log (0, "asum_system_init_", "Cannot get status of ^a. It will be deleted.", asum_data_$db_dir); call hphcs_$delentry_file (asum_data_$db_dir, "", code); if code ^= 0 then do; call asum_error_$log (code, "asum_system_init_", "Failed to delete old db_dir ^a", asum_data_$db_dir); go to ERROR; end; return; end remove_old_entry; rename_old_entry: procedure; declare shriek char (15); declare entryname char (32); shriek = unique_chars_ (""b); call expand_pathname_ (asum_data_$db_dir, (""), entryname, (0)); call asum_error_$log (0, "asum_system_init_", "^a is not a directory. It will be renamed to ^a.", asum_data_$db_dir, shriek); call hphcs_$chname_file (asum_data_$db_dir, "", entryname, shriek, code) ; if code ^= 0 then do; call asum_error_$log (code, "asum_system_init_", "Failed to rename ", asum_data_$db_dir); go to ERROR; end; return; end rename_old_entry; create_db_dir: procedure; declare dir_name char (168); declare entryname char (32); call asum_error_$log (0, "asum_system_init_", "Creating directory ^a", asum_data_$db_dir); call expand_pathname_ (asum_data_$db_dir, dir_name, entryname, (0)); call hcs_$create_branch_ (dir_name, entryname, addr (asum_data_$db_dir_cbi), code); if code ^= 0 then do; call asum_error_$log (code, "asum_system_init_", "Failed to create ^a", asum_data_$db_dir); go to ERROR; end; call hcs_$replace_inacl (asum_data_$db_dir, "", addr (asum_data_$acl_entries), asum_data_$n_acl_entries, "1"b, (asum_data_$db_rb (1)), code); if code ^= 0 then do; call asum_error_$log (code, "asum_system_init_", "Failed to set inital acl of ^a", asum_data_$db_dir); go to ERROR; end; return; end create_db_dir; end find_or_create_db_dir; clean_out_db_dir: procedure; declare sx fixed bin; call hcs_$star_ (asum_data_$db_dir, "**", star_ALL_ENTRIES, get_system_free_area_ (), star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then return; do sx = 1 to star_entry_count; call hphcs_$delentry_file (asum_data_$db_dir, star_names (star_entries (sx).nindex), code); if code ^= 0 then call asum_error_$log (code, "asum_system_init_", "Failed to delete ^a", pathname_ (asum_data_$db_dir, star_names (star_entries (sx).nindex))); end; free star_names; free star_entries; return; %include star_structures; end clean_out_db_dir; initialize_first_segment: procedure; declare first_segment_ptr pointer; declare sys_area area based (get_system_free_area_ ()); allocate as_user_message_perprocess_info in (sys_area); asum_data_$process_info_ptr = as_user_message_perprocess_info_ptr; /**** Be sure to set these values, or else the process which calls this entry will never be able to use the ASUM facility itself. */ asum_data_$process_id = get_process_id_ (); asum_data_$lock_id = get_lock_id_ (); as_user_message_perprocess_info.sentinel = AS_USER_MESSAGE_PROCESS_SENTINEL; as_user_message_perprocess_info.mseg_ptr (*) = null (); call asum_create_segment_$first (first_segment_ptr); as_user_message_system_info_ptr = first_segment_ptr; asum_data_$system_info_ptr = first_segment_ptr; as_user_message_system_info.sentinel = AS_USER_MESSAGE_SYSTEM_SENTINEL; as_user_message_system_info.time_of_bootload = sys_info$time_of_bootload; as_user_message_system_info.lock = ""b; as_user_message_system_info.n_segments = 1; as_user_message_system_info.highest_in_use = 0; unspec (as_user_message_system_info.destination_am) = ""b; call asum_create_segment_ (0, first_segment_ptr); as_user_message_perprocess_info.mseg_ptr (0) = first_segment_ptr; return; end initialize_first_segment; end asum_system_init_;  display_user_messages.pl1 07/13/88 1243.4r w 07/13/88 0937.9 396855 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * ******************************************** */ /****^ HISTORY COMMENTS: 1) change(87-05-28,GDixon), approve(87-07-07,MCR7719), audit(87-07-08,Hartogs), install(87-08-04,MR12.1-1055): A) Initial coding, cribbed from display_connection_list. 2) change(87-07-07,GDixon), approve(87-07-07,MCR7719), audit(87-07-08,Hartogs), install(87-08-04,MR12.1-1055): A) Remove magic numbers in several places. B) Correct coding error in matching_entry subroutine. END HISTORY COMMENTS */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* display_user_messages: a utility to display contents of the */ /* active_connection_list table, maintained by the connection_list_manager_ */ /* subsystem. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ display_user_messages: proc; /* AUTOMATIC */ dcl brief_sw bit(1) aligned automatic; dcl code fixed bin(35) automatic; dcl entry_var entry variable; dcl (exclude, match) char(100) varying automatic; dcl message_handle bit(72) aligned automatic; dcl message_id bit(72) aligned automatic; dcl octal_sw bit(1) aligned automatic; dcl 1 source aligned automatic, 2 id char(32), 2 person char(24), 2 project char(12), 2 tag char(1) unal, 2 tag_pad char(3) unal; dcl source_id bit(36) aligned automatic; dcl system_area_ptr ptr automatic; dcl 1 target aligned automatic like source; dcl target_id bit(36) aligned automatic; /* BASED */ dcl system_area area based (system_area_ptr); /* ENTRIES */ dcl date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var); dcl dump_segment_ entry (ptr, ptr, fixed bin, fixed bin(18), fixed bin(18), bit(*)); dcl get_system_free_area_ entry() returns(ptr); dcl ioa_ entry() options(variable); dcl user_message_admin_$read_message entry (ptr, ptr, ptr, fixed bin(35)); /* BUILTINS AND CONDITIONS */ dcl (addr, after, before, char, dimension, index, hbound, lbound, length, ltrim, max, null, rtrim, size, string, substr, unspec) builtin; dcl (cleanup, linkage_error) condition; /* INTERNAL STATIC */ dcl COMMAND_VERSION char(3) int static options(constant) init("1.0"); dcl CONTINUATION_LINE char(8) int static options(constant) init(" "); dcl DO_NOT_BLOCK fixed bin int static options(constant) init(-1); dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant); dcl ME char (21) int static options (constant) init ("display_user_messages"); dcl ZERO_OFFSET fixed bin(18) int static options(constant) init(0); /* EXTERNAL STATIC */ dcl (error_table_$bad_arg, error_table_$bad_opt, error_table_$no_message) fixed bin(35) ext static; dcl iox_$user_output ptr ext static; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* INVOCATION TYPE AND ARGUMENTS: */ /* 1) Initialize variables, and establish cleanup handler. */ /* 2) Create standalone ssu_ invocation for argument processing. */ /* 3) Initialize argument handling routines. */ /* 4) Process input arguments, reporting any errors as they are encountered. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ call initialize_args(); on cleanup call cleanup_invocation(); call ssu_$standalone_invocation (sci_ptr, ME, COMMAND_VERSION, cu_$arg_list_ptr(),exit_proc, code); call check_invocation_type (ALLOW_COMMAND); call process_args(); call scan_messages(); /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* REVOCATION AND EXIT: */ /* This point is reached when normal processing completes successfully, */ /* or when the error$fatal routine is called to abnormally end processing. */ /* */ /* 1) Cleanup the standalone invocation. */ /* 2) Return to command processor. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ EXIT: call cleanup_invocation(); return; exit_proc: proc; go to EXIT; end exit_proc; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* alloc_aumi: get next aumi structure from array. Handle array overflow */ /* gracefully. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl 1 aumi_struct structure aligned based (aumi_struct_ptr), 2 count fixed bin, 2 max_count fixed bin, 2 array (aumi_struct_count refer (aumi_struct.max_count)) like as_user_message_info; dcl aumi_struct_count fixed bin; dcl (aumi_struct_ptr, temp_struct_ptr) ptr; dcl 1 auto_aumi_struct structure aligned automatic, 2 count fixed bin, 2 max_count fixed bin, 2 array (50) like as_user_message_info; dcl 1 aumi aligned based(aumi_ptr) like as_user_message_info; dcl aumi_ptr ptr; dcl aumi_message_time fixed bin(71) based(addr(aumi.message_id)); dcl aumi_message (aumi.message_length) fixed bin(35) based (aumi.message_ptr); dcl ax fixed bin; dcl AUMI_ARRAY_INCREMENT fixed bin int static options(constant) init(50); alloc_aumi: procedure; if aumi_struct.count = aumi_struct.max_count then do; aumi_struct_count = aumi_struct.max_count + AUMI_ARRAY_INCREMENT; allocate aumi_struct in (system_area) set (temp_struct_ptr); temp_struct_ptr -> aumi_struct.max_count = aumi_struct.max_count; temp_struct_ptr -> aumi_struct = aumi_struct; temp_struct_ptr -> aumi_struct.max_count = aumi_struct.max_count + AUMI_ARRAY_INCREMENT; if aumi_struct_ptr ^= addr (auto_aumi_struct) then free aumi_struct in (system_area); aumi_struct_ptr = temp_struct_ptr; temp_struct_ptr = null; end; ax = aumi_struct.count + 1; aumi_ptr = addr(aumi_struct.array(ax)); aumi.version = AS_USER_MESSAGE_INFO_VERSION_1; aumi.flags = FALSE; aumi.flags.no_handle_given = TRUE; aumi.flags.dont_delete = TRUE; aumi.message_info.message_ptr = null; aumi.message_info.message_length = 0; aumi_struct.count = ax; return; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ alloc_aumi$init: entry; auto_aumi_struct.count = 0; auto_aumi_struct.max_count = dimension(auto_aumi_struct.array,1); aumi_struct_ptr = addr (auto_aumi_struct); temp_struct_ptr = null; return; /* * * * * * * * * * * * * * * * * * * * * * * * * */ alloc_aumi$term: entry; if temp_struct_ptr = aumi_struct_ptr then temp_struct_ptr = null; if temp_struct_ptr ^= null then free temp_struct_ptr -> aumi_struct in (system_area); do ax = 1 to aumi_struct.count; if aumi_struct.message_ptr(ax) ^= null then do; aumi_ptr = addr(aumi_struct.array(ax)); free aumi_message in (system_area); aumi.message_ptr = null; end; end; if aumi_struct_ptr ^= addr (auto_aumi_struct) then free aumi_struct in (system_area); return; end alloc_aumi; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ARGUMENT PROCESSING: */ /* Declare variables and subroutines needed for argument processing. */ /* */ /* CHECK INVOCATION TYPE: */ /* 1) Initialize error handling subroutines. */ /* 2) Determine whether invoked as command or af. */ /* 3) Is this type of invocation allowed? */ /* 4) Initialize af return argument, and index of current argument. */ /* */ /* SEE OTHER ARGUMENT PROCESSING PROGRAMS: */ /* get_arg, get_ctl_arg, get_bit36_opt, get_bit72_opt */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl af_sw bit(1) aligned, /* on: active fnc*/ arg char(argl) based(argp), argl fixed bin(21), /* current arg */ argp ptr, argn fixed bin, /* arg count */ argx fixed bin, /* arg index */ bit_opt bit(72) var aligned,/* 1-2 word octal*/ opt char(optl) based(optp), optl fixed bin(21), /* current option*/ optp ptr, ret char(retl) varying based(retp), retl fixed bin(21), /* af return val */ retp ptr, sci_ptr ptr; /* ssu_ info ptr */ dcl cu_$arg_list_ptr entry returns(ptr), ssu_$abort_subsystem entry() options(variable), ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)), ssu_$destroy_invocation entry (ptr), ssu_$print_message entry() options(variable), ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)), ssu_$standalone_invocation entry (ptr, char(*), char(*), ptr, entry, fixed bin(35)); dcl (ALLOW_COMMAND init(1), ALLOW_AF init(2), ALLOW_COMMAND_AF init(3)) fixed bin int static options(constant); check_invocation_type: proc (allowed); dcl allowed fixed bin; dcl (error_table_$active_function, error_table_$not_act_fnc) fixed bin(35) ext static; call error$init(); call ssu_$return_arg (sci_ptr, argn, af_sw, retp, retl); if allowed = ALLOW_COMMAND & af_sw then call error$fatal (sci_ptr, error_table_$active_function); else if allowed = ALLOW_AF & ^af_sw then call error$fatal (sci_ptr, error_table_$not_act_fnc); else if allowed = ALLOW_COMMAND_AF then; if af_sw then ret = ""; argx = 0; end check_invocation_type; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* CLEANUP: */ /* 1) Destroy the ssu_ invocation (releasing temp segs obtained thru ssu_). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ cleanup_invocation: proc; call alloc_aumi$term(); if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr); end cleanup_invocation; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ cv_access_class: procedure (class) returns (char(256) varying); dcl class bit(72) aligned parameter; dcl class_str char(256) automatic, code fixed bin(35); dcl convert_access_class_$to_string_short entry (bit(72) aligned, char(*), fixed bin(35)); dcl error_table_$smallarg fixed bin(35) ext static; call convert_access_class_$to_string_short (class, class_str, code); if code ^= 0 then do; if code = error_table_$smallarg then; else class_str = "Unknown"; end; return (rtrim(class_str)); end cv_access_class; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ cv_message_type: procedure (source, target, handle, message) returns (char(256) varying); dcl (source, target) char(32) parameter; dcl handle bit(72) aligned parameter; dcl message (*) fixed bin(35) parameter; dcl type char(256) varying; if handle = SYSTEM_MESSAGE_HANDLE then do; type = "system message: "; if addr(message) ^= null then do; system_message_ptr = addr(message); if system_message.header.version = SYSTEM_MESSAGE_VERSION_1 then do; if lbound(SYSTEM_MESSAGE_TYPES,1) <= system_message.header.type & system_message.header.type <= hbound(SYSTEM_MESSAGE_TYPES,1) then do; type = type || SYSTEM_MESSAGE_TYPES(system_message.header.type); if ^brief_sw then do; type = type || ": "; type = type || rtrim(warn_system_message.caller); type = type || CONTINUATION_LINE; type = type || warn_system_message.text; end; end; else do; type = type || "UNKNOWN TYPE ("; type = type || ltrim(char(system_message.header.type)); type = type || ")"; end; end; else do; type = type || "UNKNOWN VERSION ("; type = type || rtrim(system_message.header.version); type = type || ")"; end; end; else type = type || "NULL MESSAGE POINTER"; end; else if handle = USER_MESSAGE_LS_CONNECTION_INFO_HANDLE then do; type = "ls "; LS_DIAL: if addr(message) ^= null then do; ls_connection_message_ptr = addr(message); if ls_connection_message.version = LS_CONNECTION_MESSAGE_V1 then do; if ls_connection_message.reason = LS_MSG_CONNECTED then type = type || "connected: "; else if ls_connection_message.reason = LS_MSG_DISCONNECTED then type = type || "disconnected: "; else do; type = type || "unknown operation"; type = type || cv_octal(unspec(ls_connection_message.reason)); type = type || " "; end; type = type || rtrim (ls_connection_message.io_module_name); type = type || " "; type = type || rtrim (ls_connection_message.connection_name); end; else do; type = type || "connection: "; type = type || "UNKNOWN VERSION ("; type = type || rtrim (ls_connection_message.version); type = type || ")"; end; end; else do; type = type || "connection: "; type = type || "NULL MESSAGE POINTER"; end; end; else if substr(handle, length(handle) - length (USER_MESSAGE_LS_CONNECTION_INFO_HANDLE_LOWER_18) + 1, length (USER_MESSAGE_LS_CONNECTION_INFO_HANDLE_LOWER_18)) = USER_MESSAGE_LS_CONNECTION_INFO_HANDLE_LOWER_18 then do; type = "ls dial "; go to LS_DIAL; end; else do; if addr(message) = null then type = "UNKNOWN MESSAGE: NULL POINTER"; else do; as_com_channel_info_ptr, ls_response_ptr = addr(message); if lbound (LS_RESPONSE_TYPES, 1) <= login_server_response_header.message_type & login_server_response_header.message_type <= hbound (LS_RESPONSE_TYPES, 1) then do; type = "ls "; type = type || LS_RESPONSE_TYPES (login_server_response_header.message_type); type = type || "response"; if login_server_response_header.message_type = LS_UNKNOWN_RESPONSE then; else if login_server_response_header.message_type = LS_VALIDATE_RESPONSE then do; if login_server_response_header.version ^= LS_VALIDATE_RESPONSE_VERSION_1 then do; type = type || ": UNKNOWN VERSION ("; type = type || rtrim (login_server_response_header.version); type = type || ")"; end; else do; type = type || ": "; type = type || rtrim (login_server_validate_response.person_id); type = type || "."; type = type || rtrim (login_server_validate_response.project_id); if ^brief_sw then type = type || cv_status_code ( login_server_validate_response.status_code); end; end; else if login_server_response_header.message_type = LS_PROCESS_RESPONSE then do; if login_server_response_header.version ^= LOGIN_SERVER_PROCESS_RESPONSE_VERSION_1 then do; type = type || ": UNKNOWN VERSION ("; type = type || rtrim (login_server_response_header.version); type = type || ")"; end; else do; type = type || ": "; type = type || rtrim (login_server_process_response.process_group_id); if ^brief_sw then do; type = type || CONTINUATION_LINE; if login_server_process_response.flags. message_coordinator then type = type || "MESSAGE COORD"; else if login_server_process_response.flags.created then type = type || "CREATE"; else if login_server_process_response.flags.connected then type = type || "CONNECT"; else if login_server_process_response.flags.new_proc then type = type || "NEW_PROC"; else if login_server_process_response.flags.destroyed then type = type || "DESTROY"; if login_server_process_response.process_id ^= ""b then type = type || cv_octal ( login_server_process_response.process_id); type = type || cv_status_code ( login_server_process_response.status_code); if login_server_process_response. accounting_message_length > 0 then do; type = type || ": "; type = type || login_server_process_response.accounting_message; end; end; end; end; else if login_server_response_header.message_type = LS_LIST_RESPONSE then do; if login_server_response_header.version ^= LOGIN_SERVER_LIST_RESPONSE_VERSION_1 then do; type = type || ": UNKNOWN VERSION ("; type = type || rtrim (login_server_response_header.version); type = type || ")"; end; end; else if login_server_response_header.message_type = LS_DIAL_RESPONSE then do; if login_server_response_header.version ^= LOGIN_SERVER_DIAL_RESPONSE_VERSION_1 then do; type = type || ": UNKNOWN VERSION ("; type = type || rtrim (login_server_response_header.version); type = type || ")"; end; else do; type = type || ": "; type = type || rtrim (login_server_dial_response.process_group_id); if ^brief_sw then type = type || cv_octal ( login_server_dial_response.process_id); end; end; else if login_server_response_header.message_type = LS_TERMINATION_RESPONSE then do; if login_server_response_header.version ^= LOGIN_SERVER_TERMINATION_RESPONSE_VERSION_1 then do; type = type || ": UNKNOWN VERSION ("; type = type || rtrim (login_server_response_header.version); type = type || ")"; end; else do; type = type || ": "; type = type || rtrim ( login_server_termination_response.process_group_id); if ^brief_sw then do; type = type || cv_octal ( login_server_termination_response.process_id); type = type || CONTINUATION_LINE; if login_server_termination_response.flags.new_proc then type = type || "new_proc"; else if login_server_termination_response. flags.fatal_error then type = type || "fatal error"; else type = type || "logout"; type = type || cv_status_code ( login_server_termination_response.status_code); end; end; end; else if login_server_response_header.message_type = LS_NEW_PROC_RESPONSE then do; if login_server_response_header.version ^= LOGIN_SERVER_NEW_PROC_RESPONSE_VERSION_1 then do; type = type || ": UNKNOWN VERSION ("; type = type || rtrim (login_server_response_header.version); type = type || ")"; end; else type = type || cv_octal ( login_server_new_proc_response.new_process_id); end; else if login_server_response_header.message_type = LS_OPERATOR_RESPONSE then do; if login_server_response_header.version ^= LOGIN_SERVER_OPERATOR_RESPONSE_VERSION_1 then do; type = type || ": UNKNOWN VERSION ("; type = type || rtrim (login_server_response_header.version); type = type || ")"; end; else do; type = type || ": "; type = type || rtrim (login_server_operator_response.process_group_id); if ^brief_sw then do; if login_server_operator_response.process_id ^= ""b then type = type || cv_octal ( login_server_operator_response.process_id); type = type || cv_status_code ( login_server_operator_response.status_code); end; end; end; end; else if dimension(message,1) = size(as_com_channel_info) & as_com_channel_info.version = AS_COM_CHANNEL_INFO_VERSION_1 then do; type = "com channel info"; if ^brief_sw then do; type = type || " for "; type = type || rtrim(as_com_channel_info.channel_name); end; end; else type = "UNKNOWN MESSAGE TYPE"; end; end; return (type); end cv_message_type; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* cv_octal: return octal representation of a word. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ cv_octal: procedure (word) returns (char(13)); dcl word bit(36) aligned parameter; dcl octal_id char(13); dcl ioa_$rsnnl entry() options(variable); call ioa_$rsnnl (" ^12.3b", octal_id, 0, word); return (octal_id); end cv_octal; /* * * * * * * * * * * * * * * * * * * * * * * * * */ cv_status_code: procedure (code) returns (char(100) varying); dcl code fixed bin(35) parameter; dcl long char(100) aligned, short char(8) aligned; dcl convert_status_code_ entry (fixed bin(35), char(8) aligned, char(100) aligned); if code = 0 then return (""); call convert_status_code_ (code, short, long); if short ^= "" then return (" (" || rtrim(short) || ")"); else return (" (" || rtrim(long) || ")"); end cv_status_code; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ cv_target: procedure (target) returns (char(32) varying); dcl 1 target aligned parameter like as_user_message_info.destination_info; dcl code fixed bin(35), group char(32) varying, pers char(24), proj char(12), tag char(1); dcl get_userid_$info entry (bit(36) aligned, char(*), char(*), char(*), fixed bin, fixed bin, fixed bin, fixed bin(35)); if target.process_id = ""b then return (rtrim (target.group_id)); else if target.group_id ^= "" & target.group_id ^= "*.*.*" then return (rtrim (target.group_id)); else do; call get_userid_$info (target.process_id, pers, proj, tag, 0, 0, 0, code); if code = 0 then do; group = rtrim(pers); group = group || "."; group = group || rtrim(proj); group = group || "."; group = group || tag; return (group); end; else do; return (cv_octal (target.process_id)); end; end; end cv_target; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* display_message: Display one matching user message. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl 1 begin aligned automatic, 2 (target, type) fixed bin; dcl matching_entries fixed bin; dcl need_heading bit(1) aligned automatic; dcl 1 width aligned automatic, 2 (source, target, type) fixed bin; display_message: procedure; matching_entries = matching_entries + 1; if brief_sw then do; if need_heading then do; call ioa_ ( "^/SOURCE^vtTARGET^vtMESSAGE", begin.target, begin.type); need_heading = "0"b; end; call ioa_ ("^a^vt^a^vt^a", before(aumi.sender_info.group_id, "."), begin.target, before (cv_target (aumi.destination_info), "."), begin.type, cv_message_type (aumi.sender_info.group_id, aumi.destination_info.group_id, aumi.message_handle, aumi_message)); end; else do; call ioa_ (""); call ioa_ ("Source name: ^32a pid: ^12.3b", aumi.sender_info.group_id, aumi.sender_info.process_id); call ioa_ ("Target name: ^32a pid: ^12.3b ring: ^d", cv_target(aumi.destination_info), aumi.destination_info.process_id, aumi.destination_info.ring); call ioa_ ("Message handle: ^24.3b^8x id: ^24.3b", aumi.message_handle, aumi.message_id); call ioa_ ("Message time: ^a", date_time_$format ("clock", aumi_message_time, "", "")); if aumi.message_access_class ^= ""b then call ioa_ ("Message class: ^a", cv_access_class (aumi.message_access_class)); if aumi.message_ring ^= 4 then call ioa_ ("Message ring: ^d", aumi.message_ring); call ioa_ ("Message length: ^d words", aumi.message_length); call ioa_ ("Message type: ^a", cv_message_type (aumi.sender_info.group_id, aumi.destination_info.group_id, aumi.message_handle, aumi_message)); if octal_sw & aumi.message_length > 0 then do; call ioa_ (""); string(dump_segment_format_structure) = ""b; dump_segment_format_structure.offset = TRUE; dump_segment_format_structure.ascii = TRUE; dump_segment_format_structure.raw_data = TRUE; dump_segment_format_structure.interpreted_data = TRUE; dump_segment_format_structure.suppress_duplicates = TRUE; call dump_segment_ (iox_$user_output, addr(aumi_message), DO_NOT_BLOCK, ZERO_OFFSET, dimension(aumi_message,1), dump_segment_format); end; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * */ display_message$init: entry; matching_entries = 0; need_heading = TRUE; width.source = length("SOURCE"); width.target = length("TARGET"); width.type = length("TYPE"); begin = 0; return; /* * * * * * * * * * * * * * * * * * * * * * * * * */ display_message$matching_entry_count: entry returns (fixed bin); return (matching_entries); /* * * * * * * * * * * * * * * * * * * * * * * * * */ display_message$set_widths: entry; dcl (COLUMN_1 init(1), COLUMN_GUTTER init(2)) fixed bin int static options(constant); width.source = max (width.source, length (before (rtrim (aumi.sender_info.group_id), "."))); width.target = max (width.target, length (before (cv_target (aumi.destination_info), "."))); width.type = max (width.type, length (cv_message_type (aumi.sender_info.group_id, aumi.destination_info.group_id, aumi.message_handle, aumi_message))); begin.target = COLUMN_1 + width.source + COLUMN_GUTTER; begin.type = begin.target + width.target + COLUMN_GUTTER; end display_message; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ERROR REPORTING ROUTINES: */ /* 1) Nonfatal errors set a switch, which can be tested via error_occurred */ /* function. */ /* 2) Fatal errors abort the subsystem by calling the exit_proc, which */ /* branches to the EXIT label to exit the command. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl error_occurred_sw bit(1); error: proc options (variable); dcl code fixed bin(35) based (codep), codep ptr; dcl cu_$arg_list_ptr entry returns(ptr), cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)), cu_$generate_call entry (entry, ptr); dcl CODE_ARG fixed bin int static options(constant) init(2), (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant); call cu_$arg_ptr (CODE_ARG, codep, 0, 0); if code = 0 then return; if code = -1 then code = 0; error_occurred_sw = TRUE; call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr()); return; error$init: entry; error_occurred_sw = FALSE; return; error$occurred: entry returns (bit(1)); return (error_occurred_sw); error$fatal: entry options(variable); call cu_$arg_ptr (CODE_ARG, codep, 0, 0); if code = 0 then return; if code = -1 then code = 0; error_occurred_sw = TRUE; call ioa_ (""); call cu_$generate_call (ssu_$abort_subsystem, cu_$arg_list_ptr()); end error; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ARGUMENT GETTING FUNCTIONS: */ /* get_arg: Get next argument. */ /* get_arg_count: Get number of arguments. */ /* get_ctl_arg: Get next argument, which must be a control argument. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ get_arg: proc returns (bit(1)); dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant); if argx < argn then do; argx = argx + 1; call ssu_$arg_ptr (sci_ptr, argx, argp, argl); return (TRUE); end; else return (FALSE); end get_arg; get_ctl_arg: proc returns (bit(1)); dcl index builtin; dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), error_table_$bad_arg fixed bin(35) ext static; if get_arg() then if index(arg, "-") = 1 then return (TRUE); else call error$fatal (sci_ptr, error_table_$bad_arg, "^a.^/A control argument was expected.", arg); return (FALSE); end get_ctl_arg; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* CONTROL ARG OPERAND GETTING FUNCTIONS: */ /* get_bit36_opt: Gets next arg, treats it as an octal integer operand. */ /* get_bit72_opt: Gets next arg, treats it as 2-word octal integer operand.*/ /* get_opt: Gets next arg. */ /* */ /* Both allow the caller to specify whether the operand is required (an */ /* opt_desc is provided) or optional (opt_desc=""). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ get_bit36_opt: proc (arg_name, opt_desc) returns (bit(1)); dcl arg_name char(*), opt_desc char(*); dcl code fixed bin(35); dcl max_bits fixed bin; dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), (error_table_$bad_arg, error_table_$noarg) fixed bin(35) ext static; max_bits = 36; go to GET_BIT_COMMON; get_bit72_opt: entry (arg_name, opt_desc) returns (bit(1)); max_bits = 72; GET_BIT_COMMON: if argx < argn then do; argx = argx + 1; call ssu_$arg_ptr (sci_ptr, argx, optp, optl); bit_opt = oct_to_bit (opt, max_bits, code); if code ^= 0 then do; call error (sci_ptr, error_table_$bad_arg, "^a ^a ^a must be followed by a^[n^] ^a.", arg_name, opt, arg_name, vowel(opt_desc), opt_desc); return (FALSE); end; else return (TRUE); end; else if opt_desc ^= "" then do; call error (sci_ptr, error_table_$noarg, "^/^a must be followed by a^[n^] ^a.", arg_name, vowel(opt_desc), opt_desc); return (FALSE); end; else return (FALSE); end get_bit36_opt; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ get_opt: proc (arg_name, opt_desc) returns (bit(1)); dcl arg_name char(*), opt_desc char(*); dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), error_table_$noarg fixed bin(35) ext static; if argx < argn then do; argx = argx + 1; call ssu_$arg_ptr (sci_ptr, argx, optp, optl); if index(opt, "-") = 1 then do; /* options cannot*/ argx = argx - 1; /* look like */ go to NO_OPT; /* control args */ end; else return (TRUE); end; else NO_OPT: if opt_desc ^= "" then do; call error (sci_ptr, error_table_$noarg, "^/^a must be followed by a^[n^] ^a.", arg_name, vowel(opt_desc), opt_desc); return (FALSE); end; return (FALSE); end get_opt; /* * * * * * * * * * * * * * * * * * * * * * * * * */ vowel: proc (str) returns (bit(1)); /* does opt_desc */ /* begin with a */ /* vowel? */ dcl str char(*); dcl (search, substr) builtin; dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant); if search ("aeiouAEIO", substr(str,1,1)) > 0 then return (TRUE); else return (FALSE); end vowel; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ group_id: procedure (arg) returns (1 like source); dcl arg char(*); dcl 1 group aligned automatic like source; group.id = arg; group.person = before(arg,"."); if group.person = "" then group.person = "*"; group.project = before(after(arg,"."),"."); if group.project = "" then group.project = "*"; group.tag = after(after(arg,"."),"."); if group.tag = "" then group.tag = "*"; return (group); end group_id; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* INITIALIZATION. */ /* 1) Initialize variables holding argument values. */ /* 2) Initialize ssu_ info pointer. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ initialize_args: proc; sci_ptr = null; brief_sw = TRUE; octal_sw = FALSE; exclude, match, source, target = ""; source_id, target_id, message_id, message_handle = ""b; call alloc_aumi$init(); aumari.version = AS_USER_MESSAGE_ADMIN_READ_INFO_VERSION_1; aumari.source_group_id = ""; aumari.source_process_id = ""b; aumari.target_group_id = ""; aumari.target_process_id = ""b; aumari.target_handle = ""b; aumari.after_message_id = ""b; call display_message$init(); system_area_ptr = get_system_free_area_ (); end initialize_args; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* matching_entry: return TRUE if active_connection_list entry match the */ /* criteria given in input control args. Otherwise, return FALSE. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ matching_entry: procedure returns (bit(1)); dcl ok_so_far bit(1); ok_so_far = TRUE; if message_id ^= ""b & ok_so_far then ok_so_far = (aumi.message_id = message_id); if message_handle ^= ""b & ok_so_far then ok_so_far = (aumi.message_handle = message_handle); if source_id ^= ""b & ok_so_far then ok_so_far = (aumi.sender_info.process_id = source_id); if target_id ^= ""b & ok_so_far then ok_so_far = (aumi.destination_info.process_id = target_id); if source.id ^= "" & ok_so_far then do; if source.person ^= "*" then ok_so_far = (source.person = before(aumi.sender_info.group_id,".")); if source.project ^= "*" & ok_so_far then ok_so_far = (source.project = before(after(aumi.sender_info.group_id,"."),".")); if source.tag ^= "*" & ok_so_far then ok_so_far = (source.tag = after(after(aumi.sender_info.group_id,"."),".")); end; if target.id ^= "" & ok_so_far then do; if aumi.destination_info.group_id = "" | aumi.destination_info.group_id = "*.*.*" then aumi.destination_info.group_id = cv_target (aumi.destination_info); if target.person ^= "*" then ok_so_far = (target.person = before(aumi.destination_info.group_id,".")); if target.project ^= "*" & ok_so_far then ok_so_far = (target.project = before(after(aumi.destination_info.group_id,"."),".")); if target.tag ^= "*" & ok_so_far then ok_so_far = (target.tag = after(after(aumi.destination_info.group_id,"."),".")); end; if match ^= "" & ok_so_far then do; ok_so_far = index (cv_message_type (aumi.sender_info.group_id, aumi.destination_info.group_id, aumi.message_handle, aumi_message), match) > 0; end; if exclude ^= "" & ok_so_far then do; ok_so_far = index (cv_message_type (aumi.sender_info.group_id, aumi.destination_info.group_id, aumi.message_handle, aumi_message), exclude) = 0; end; return (ok_so_far); end matching_entry; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* oct_to_bit: converts octal integer to bit(36) or bit(72) string. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ oct_to_bit: procedure (integer, max_bits, code) returns (bit(72) varying aligned); dcl integer char(*) parameter; dcl max_bits fixed bin; dcl code fixed bin(35) parameter; dcl bits bit(73) varying; dcl digit fixed bin; dcl oct_bits (48:55 /* = 060:067 octal = "0":"7" */) bit(3) int static options(constant) init("0"b3, "1"b3, "2"b3, "3"b3, "4"b3, "5"b3, "6"b3, "7"b3); dcl (length, rank, substr, verify) builtin; dcl ZERO_BITS bit(72) aligned int static options(constant) init("0"b); dcl (error_table_$bad_conversion, error_table_$size_error) fixed bin(35) ext static; code = 0; if verify (integer, "01234567") > 0 then do; /* check for */ code = error_table_$bad_conversion; /* nonoctal */ return (""b); /* digits */ end; bits = ""b; /* convert octal */ do digit = 1 to length(integer); /* digits to bits*/ bits = bits || oct_bits(rank(substr(integer,digit,1))); end; if length(bits) > max_bits then do; /* check for too */ code = error_table_$size_error; /* many digits */ return (""b); end; bits = substr(ZERO_BITS, 1, max_bits - length(bits)) || bits; /* right adjust */ return (bits); end oct_to_bit; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* PROCESS ARGUMENTS */ /* 1) Match argument to ctl_arg name and operands. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ process_args: proc; CTL_ARG_LOOP: do while (get_ctl_arg ()); if arg = "-brief" | arg = "-bf" then brief_sw = TRUE; else if arg = "-long" | arg = "-lg" then brief_sw = FALSE; else if arg = "-octal" | arg = "-oc" then octal_sw = TRUE; else if arg = "-no_octal" | arg = "-noc" then octal_sw = FALSE; else if arg = "-source" | arg = "-sc" then do; if get_opt (arg, "source group id") then source = group_id (opt); end; else if arg = "-target" | arg = "-tgt" then do; if get_opt (arg, "target group id") then target = group_id (opt); end; else if arg = "-source_id" | arg = "-scid" | arg = "-sid" then do; if get_bit36_opt (arg, "octal source process id") then source_id = bit_opt; end; else if arg = "-target_id" | arg = "-tgtid" | arg = "-tid" | arg = "-process_id" | arg = "-processid" | arg = "-pid" then do; if get_bit36_opt (arg, "octal target process id") then target_id = bit_opt; end; else if arg = "-message_id" | arg = "-mid" then do; if get_bit72_opt (arg, "octal message identifier") then message_id = bit_opt; end; else if arg = "-handle" | arg = "-hdl" then do; if get_bit72_opt (arg, "octal message handle") then message_handle = bit_opt; end; else if arg = "-match_data" | arg = "-match" then do; if get_opt (arg, "match string") then match = opt; end; else if arg = "-exclude_data" | arg = "-exclude" | arg = "-ex" then do; if get_opt ( arg, "exclude string") then exclude = opt; end; else if index (arg, "-") ^= 1 then call error (sci_ptr, error_table_$bad_arg, "^a Usage: ^a {-control_args}", arg, ME); else call error (sci_ptr, error_table_$bad_opt, "^a", arg); end CTL_ARG_LOOP; if octal_sw then /* -octal implies*/ brief_sw = FALSE; /* -brief. */ if error$occurred() then /* stop now if */ call error$fatal (sci_ptr, -1); /* ctl arg errs */ end process_args; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* scan_messages: Walk through user message entries, displaying */ /* those that match the user's criteria. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ scan_messages: procedure; on linkage_error begin; call error$fatal (sci_ptr, -1, "Incorrect access to the user_message_admin_ gate."); end; entry_var = user_message_admin_$read_message; /* force linkage */ revert linkage_error; /* error now. */ aumari.after_message_id = "0"b; /* get 1st entry */ code = 0; do while (code = 0); call alloc_aumi(); call user_message_admin_$read_message (addr(aumari), addr(aumi), addr(system_area), code); if code ^= 0 then aumi_struct.count = aumi_struct.count - 1; else aumari.after_message_id = aumi.message_id; /* get next entry*/ end; if brief_sw then do ax = 1 to aumi_struct.count; aumi_ptr = addr (aumi_struct.array(ax)); if matching_entry() then call display_message$set_widths(); end; do ax = 1 to aumi_struct.count; aumi_ptr = addr (aumi_struct.array(ax)); if matching_entry() then call display_message(); end; if code ^= error_table_$no_message then call error$fatal (sci_ptr, code, "Getting user messages."); if display_message$matching_entry_count() = 0 then call error$fatal (sci_ptr, -1, "No matching user messages were found."); end scan_messages; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %include as_com_channel_info; %include as_user_message_aread; dcl 1 aumari aligned automatic like as_user_message_admin_read_info; %include as_user_message_info; %include dialup_values; %include dump_segment_format; %include login_server_messages; %include ls_connection_message; %include system_message; %include user_message_handles; %include user_attributes; %include user_table_entry; end display_user_messages; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved