cmcs_create_queues_.pl1 05/24/89 1047.9rew 05/24/89 0833.9 96957 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_create_queues_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/28/81 by FCH, [4.4-1], once per process initialization, BUG468 */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_create_queues_: proc (a_code); /* This COBOL MCS subroutine is used by cobol_mcs_admin to do the actual work of creating the CMCS queues, cmcs_wait_ctl.control, cmcs_system_ctl.control, and cmcs_queue_ctl.control. */ /* Bob May, 6/30/77 */ dcl a_code fixed bin (35); dcl vt_count fixed bin, pic_value pic "9999", /* to build switch names */ (q_name, sw_name) char (32), iocbp ptr, (hdr_len_21, constant_hdr_len) fixed bin (21); dcl (i, j, k) fixed bin, temp_ctl_ptr ptr, /* for use with make_seg */ my_name char (19) init ("cmcs_create_queues_"); dcl get_pdir_ entry () returns (char (168)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*) aligned, char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)); dcl ( error_table_$namedup, error_table_$segknown, error_table_$action_not_performed, error_table_$no_record ) fixed bin (35) external; dcl ( sub_err_, ioa_, ioa_$rsnnl ) entry options (variable); dcl sub_err_retval fixed bin (35); /* dummy for sub_err_ */ dcl (addr, index, null, size, string, substr, truncate) builtin; dcl cleanup condition; dcl vfile_table_ptr ptr int static init (null); dcl vt_index fixed bin; /* manual index into vfile_table when being built */ dcl 1 vfile_table (vt_count) based (vfile_table_ptr), 2 switch_name char (32), 2 queue_name char (32), 2 tree_ctl_eindex fixed bin, 2 iocb_ptr ptr, 2 error_flag bit (1); dcl var_cmcs_dir char (256) varying; /* temp to build vfile_ attach descr */ dcl attach_descr char (256); dcl 1 vfile_rs1 like vfile_rs; dcl zero_overlay_len fixed bin, zero_overlay (zero_overlay_len) fixed bin (35) based; /* to zero space in stack or pre-used structure entries */ /* */ %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_iox_processing; %include cmcs_key_dcls; %include cmcs_queue_ctl; %include cmcs_system_ctl; %include cmcs_tree_ctl; %include cmcs_user_ctl; %include cmcs_vfile_rs; %include cmcs_wait_ctl; /* */ /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.create_queues) then call setup; var_cmcs_dir = substr (user_ctl.cmcs_dir, 1, index (user_ctl.cmcs_dir, " ") - 1); /* we'll always find blanks */ vt_count = tree_ctl.queue_count; allocate vfile_table; vt_index = 0; do i = 1 to tree_ctl.current_size; if ^tree_ctl.entries (i).inactive_sw then if tree_ctl.entries (i).subtree_count = 0 /* absolute tree path */ then do; vt_index = vt_index + 1; vfile_table (vt_index).tree_ctl_eindex = i; /* to copy tree entry stuff into queue entry later */ vfile_table (vt_index).queue_name = tree_ctl.entries (i).queue_name; vfile_table (vt_index).iocb_ptr = null (); vfile_table (vt_index).error_flag = "1"b; /* reset only if completely successful */ end; end; on cleanup go to free_vt; /* first create the other control segs */ call make_seg ("cmcs_system_ctl.control", system_ctl_ptr); if a_code ^= 0 then go to free_vt; call cmcs_fillin_hdr_ (system_ctl_ptr, system_ctl_version, system_ctl_hdr_len, system_ctl_entry_len, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Fillin hdr for system_ctl."); go to free_vt; end; user_ctl.system_ctl_ptr = system_ctl_ptr; system_ctl.password = "cobol_mcs"; /* garbage until set with set_cmcs_password */ system_ctl.lock_wait_time = 300; /* seconds, maybe made variable later */ call make_seg ("cmcs_queue_ctl.control", queue_ctl_ptr); if a_code ^= 0 then go to free_vt; call cmcs_fillin_hdr_ (queue_ctl_ptr, queue_ctl_version, queue_ctl_hdr_len, queue_ctl_entry_len, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Fillin hdr for queue_ctl."); go to free_vt; end; user_ctl.queue_ctl_ptr = queue_ctl_ptr; call make_seg ("cmcs_wait_ctl.control", wait_ctl_ptr); if a_code ^= 0 then go to free_vt; call cmcs_fillin_hdr_ (wait_ctl_ptr, wait_ctl_version, wait_ctl_hdr_len, wait_ctl_entry_len, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Fillin hdr for wait_ctl."); go to free_vt; end; user_ctl.wait_ctl_ptr = wait_ctl_ptr; /* The following a_code will create the CMCS message queues and set the queue control record (0/1) header data. Any existing message file will be truncated. */ /* init info structure for vfile_ record_status order call */ vfile_rs_ptr = addr (vfile_rs1); zero_overlay_len = size (vfile_rs1); vfile_rs_ptr -> zero_overlay (*) = 0; vfile_rs.version = 1; vfile_rs.create_sw = "1"b; /* easier than writing a dummy record */ vfile_rs.rec_len, vfile_rs.max_rec_len = 128; /* (32 * 4) */ /* Init key structure with constants */ key_struc.msg_no = 0; /* the header rcd is always 0/1 */ key_struc.seg_no = 1; key_struc.key_len = 8; key = based_key; /* strictly for iox_ */ constant_hdr_len = control_hdr_len; /* to reinit hdr len for seek_key */ do i = 1 to vt_count; pic_value = i; sw_name = "cmcs_queue_" || pic_value; /* unique for this run only */ q_name = vfile_table (i).queue_name; if i ^= 1 then do j = 1 to i - 1; /* don't duplicate previous queue names */ if q_name = vfile_table (j).queue_name then go to loop_end; end; vfile_table.switch_name = sw_name; call ioa_$rsnnl ("vfile_ ^a>^a.cmcs_queue", attach_descr, j, var_cmcs_dir, q_name); call iox_$attach_name (sw_name, iocbp, substr (attach_descr, 1, j), null (), a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to attach ""^a"".", q_name); go to loop_end; end; vfile_table (i).iocb_ptr = iocbp; call iox_$open (iocbp, 12, "0"b, a_code); /* for direct_output to force truncate */ if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to open ""^a"".", q_name); go to loop_end; end; hdr_len_21 = constant_hdr_len + 4; /* restore proper value + 4 chars for lockword */ call iox_$seek_key (iocbp, key, hdr_len_21, a_code); if a_code ^= 0 then if a_code ^= error_table_$no_record then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to seek_key ""^a"".", q_name); go to loop_end; end; call iox_$control (iocbp, "record_status", vfile_rs_ptr, a_code); if a_code ^= 0 then if a_code ^= error_table_$no_record /* NOT SURE ABOUT ALL POSSIBLE CODES */ then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to perform a record_status control order ""^a"".", q_name); go to close; end; control_hdr_ptr = vfile_rs.rec_ptr; /* for based variable */ call cmcs_fillin_hdr_ (control_hdr_ptr, 1, 0, 0, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to set the msg hdr data ""^a"".", q_name); end; close: call iox_$close (iocbp, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to close ""^a"".", q_name); end; call iox_$detach_iocb (iocbp, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to detach ""^a"".", q_name); end; vfile_table (i).error_flag = "0"b; /* we made it through this one */ /* Set up info in queue_ctl_entry */ queue_ctl.current_size, queue_ctl.entry_count = queue_ctl.current_size + 1; /* index to new entry and current size */ queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl.current_size)); j = vfile_table (i).tree_ctl_eindex; tree_ctl_eptr = addr (tree_ctl.entries (j)); if queue_ctl.current_size ^= tree_ctl_entry.queue_ctl_eindex then do; a_code = error_table_$action_not_performed; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Mismatch found between queue_ctl_eindex in the tree_ctl_entry and the current location (^d vs ^d).", tree_ctl_entry.queue_ctl_eindex, queue_ctl.current_size); return; end; queue_ctl_entry.queue_name = ""; /* rsnnl doesn't blank fill */ call ioa_$rsnnl ("^a.cmcs_queue", queue_ctl_entry.queue_name, k, tree_ctl_entry.queue_name); string (queue_ctl_entry.tree_path) = string (tree_ctl_entry.tree_path); queue_ctl_entry.tree_ctl_eindex = j; queue_ctl_entry.cmd_sw = tree_ctl_entry.cmd_sw; queue_ctl_entry.mp_sw = tree_ctl_entry.mp_sw; loop_end: end; /* closes initial do loop */ free_vt: if vfile_table_ptr ^= null () then do; free vfile_table; vfile_table_ptr = null (); end; return; make_seg: proc (a_name, a_ptr); dcl a_name char (*), a_ptr ptr; call hcs_$make_seg (user_ctl.cmcs_dir, a_name, a_name, 1010b, a_ptr, a_code); if a_code ^= 0 then if a_code = error_table_$namedup | a_code = error_table_$segknown /* already exists */ then call hcs_$truncate_seg (a_ptr, 0, a_code); /* reset to zero */ if a_ptr = null () then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to create the segment ""^a"".", a_name); /* DEBUG */ return; end /* make_seg */; setup: proc; user_ctl_ptr = external_user_ctl_ptr; tree_ctl_ptr = user_ctl.tree_ctl_ptr; user_ctl.init_sw.create_queues = "1"b; return; end /* setup */; end /* cmcs_create_queues_ */;  cmcs_date_time_.pl1 05/24/89 1047.9rew 05/24/89 0836.7 32031 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_date_time_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_date_time_: proc (a_clock_value, a_date, a_time); dcl a_clock_value fixed bin (71), a_date char (6) unaligned, a_time char (8) unaligned; /* This COBOL MCS procedure accepts a clock_ value as input and returns strings of form YYMMDD and HHMMSSTT, where YY is year MM is month DD is day and, HH is hour MM is minute SS is second TT is hundredths of a second It is directly adapted from the pl1_date_ and pl1_time_ subroutines, the difference being that the clock_ value is externally supplied and is used in both the date and time computations. Bob May, 6/30/77 */ dcl clock_value fixed bin (71); /* copy because we modify it */ dcl sys_info$time_delta fixed bin ext, (date, day, month, year, i) fixed bin; dcl clk float bin (63), (seconds, microseconds) fixed bin, digit (0:9) char (1) aligned static init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9"); dcl (divide, min, mod, substr) builtin; /* */ dcl table (6) fixed bin (6) static init (10, 10, 6, 10, 6, 10); clock_value = a_clock_value + 5000; /* round up to hundredths of a second, we'll truncate later */ date = (clock_value - sys_info$time_delta) / 8.64e10 + 694266; /* days from 3-1-0000 */ day = mod (date, 146097); /* days into 400 year cycle */ year = 400 * divide (date, 146097, 35, 0); /* year set to beginning of cycle */ date = 3 + 4 * (day + min (3, divide (date, 36534, 17, 0))); /* prepare year estimator */ day = mod (date, 1461); /* day = 4 * day_of_year (0 ... 365) */ year = year + divide (date, 1461, 17, 0); /* add in year of cycle */ date = 2 + 5 * divide (day, 4, 17, 0); /* prepare month estimator */ day = mod (date, 153); /* day = 5 * day_of_month (0 ... 30) */ month = 1 + mod (2 + divide (date, 153, 17, 0), 12); /* get month */ if month < 3 then year = year + 1; /* correct for jan, feb */ day = 1 + divide (day, 5, 17, 0); /* get day */ date = year * 10000 + month * 100 + day; do i = 6 by -1 to 1; substr (a_date, i, 1) = digit (mod (date, 10)); date = divide (date, 10, 35, 0); end; clk = mod (clock_value - sys_info$time_delta, 8.64e10); seconds = clk / 1.e6; microseconds = clk - seconds * 1.e6; seconds = mod (seconds, 86400); microseconds = microseconds / 10000.0; /* convert microseconds to hundredths of a second */ do i = 8 by -1 to 7; substr (a_time, i, 1) = digit (mod (microseconds, 10)); microseconds = divide (microseconds, 10, 35, 0); end; do while (i > 0); substr (a_time, i, 1) = digit (mod (seconds, table (i))); seconds = divide (seconds, table (i), 35, 0); i = i - 1; end; return; end /* cmcs_date_time_ */;  cmcs_decode_status_.pl1 05/24/89 1047.9rew 05/24/89 0833.9 70578 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_decode_status_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_decode_status_: proc (a_iocbp, a_cdp, a_io_type, a_io_subtype, a_code); /* This COBOL MCS subroutine decodes the status key in the input or output CD and prints this information on the specified output switch. If the call specifies a non-null output CD pointer, the station_names (in the output CD) are also printed with their corresponding error_keys. Bob May, 6/30/77 */ dcl a_iocbp ptr, a_cdp ptr, /* don't know yet if input, output, or null */ a_io_type fixed bin, a_io_subtype fixed bin, a_code fixed bin (35); /* if ever nonzero, there's a bug */ dcl io_types (7) char (8) int static options (constant) init ("Send", "Receive", "Enable", "Disable", "Accept", "Purge", "Print"); /* STOP RUN can't have status key */ dcl io_subtypes (0:28) char (24) int static options (constant) init ("Partial", /* Send - 0 */ "Segment", /* Send - 1 */ "Message", /* Send - 2 */ "Group", /* Send - 3 */ "filler", /* send is 0-3, others are 1-4 */ "Segment, No Wait", /* Receive - 1 */ "Message, No Wait", /* Receive - 2 */ "Segment, Wait", /* Receive - 3 */ "Message, Wait", /* Receive - 4 */ "Input (Queue)", /* Enable - 1 */ "Input Terminal", /* Enable - 2 */ "Output (Destination)", /* Enable - 3 */ "N/A", /* Enable - 4 */ "Input (Queue)", /* Disable - 1 */ "Input Terminal", /* Disable - 2 */ "Output (Destination)", /* Disable - 3 */ "N/A", /* Disable - 4 */ "Message Count", /* Accept - 1 */ "N/A", /* Accept - 2 */ "N/A", /* Accept - 3 */ "N/A", /* Accept - 4 */ "Sends Only (CODASYL)", /* Purge - 1 */ "Receives Only (Multics)", /* Purge - 2 */ "All (Multics)", /* Purge - 3 */ "N/A", /* Purge - 4 */ "Segment, No Wait", /* Print - 1 */ "Message, No Wait", /* Print - 2 */ "N/A", /* Print - 3 */ "N/A"); /* Print - 4 */ dcl status_keys (10) char (2) int static options (constant) init ("na", "00", "10", "15", "20", "30", "40", "50", "60", "70"); dcl io_type fixed bin, io_subtype fixed bin, count fixed bin, status_key char (2), error_key char (1), i fixed bin, input_cd_sw bit (1); dcl ioa_$ioa_switch entry options (variable); /* */ %include cmcs_cd_dcls; %include cmcs_error_table_dcls; /* */ a_code = 0; /* highly unlikely it will ever be otherwise */ input_cdp, output_cdp = a_cdp; /* easier to do both now */ go to set_io_type (a_io_type); /* send, purge (CODASYL), enable/disable output */ set_io_type (1): set_purge_io_subtype (1): /* Standard CODASYL */ set_purge_io_subtype (3): /* COBOL Extension */ set_en_dis_io_subtype (3): input_cd_sw = "0"b; /* function uses output CD */ if output_cdp = null () then status_key = "na"; else status_key = output_cd.status_key; go to print_status_key; /* receive (and print), accept, enable/disable input/input terminal, purge (partial rcvs) */ set_io_type (2): set_io_type (5): set_io_type (7): set_en_dis_io_subtype (1): set_en_dis_io_subtype (2): set_purge_io_subtype (2): input_cd_sw = "1"b; /* uses input CD */ if input_cdp = null () then status_key = "na"; /* special COBOL extension */ else status_key = input_cd.status_key; go to print_status_key; /* enable, disable */ set_io_type (3): set_io_type (4): go to set_en_dis_io_subtype (a_io_subtype); /* purge */ set_io_type (6): go to set_purge_io_subtype (a_io_subtype); /* */ print_status_key: call ioa_$ioa_switch (a_iocbp, "IO Type: ""^8a"", IO Subtype: ""^24a"", Status Key: ""^2a""", io_types (a_io_type), io_subtypes ((4 * (a_io_type - 1) + a_io_subtype)), status_key); do i = 1 to 12; if status_key = status_keys (i) then go to print_status_msg (i); end; a_code = cmcs_error_table_$bad_call_parm; go to ds_ret; /* na */ print_status_msg (1): call ioa_$ioa_switch (a_iocbp, "Null CD pointer used for this operation."); go to print_error_keys; /* 00 */ print_status_msg (2): call ioa_$ioa_switch (a_iocbp, "No error detected. Action completed."); go to print_error_keys; /* 10 */ print_status_msg (3): call ioa_$ioa_switch (a_iocbp, "One or more destinations are disabled. Action completed."); go to print_error_keys; /* 15 */ print_status_msg (4): call ioa_$ioa_switch (a_iocbp, "One or more queues or destinations already enabled."); go to print_error_keys; /* 20 */ print_status_msg (5): if a_io_subtype > 3 then io_type = 7 - a_io_type; /* 4, 5, 6 = 3, 2, 1, respectively */ else io_type = a_io_type; /* lumps send/purge, receive/accept, enable/disable */ if io_type = 1 then do; /* send, purge, enable/disable output */ print_status_msg_20 (1): call ioa_$ioa_switch (a_iocbp, "One or more destinations unknown. Action completed for known destinations. No action taken for unknown destinations. Data-name-4 (ERROR KEY) indicates known or unknown." ); go to print_error_keys; end; else if io_type = 2 then do; /* receive, accept, enable/disable input */ print_status_msg_20 (2): call ioa_$ioa_switch (a_iocbp, "One or more queues or subqueues unknown. No action taken."); go to print_error_keys; end; else do; /* io_type = 3 */ if a_io_subtype = 3 then io_subtype = 1; else io_subtype = a_io_subtype + 1; go to print_status_msg_20 (io_subtype); end; /* enable/disable input terminal */ print_status_msg_20 (3): call ioa_$ioa_switch (a_iocbp, "The source is unknown. No action taken."); go to print_error_keys; /* 30 */ print_status_msg (6): call ioa_$ioa_switch (a_iocbp, "Content of DESTINATION COUNT invalid. No action taken."); go to print_error_keys; /* 40 */ print_status_msg (7): call ioa_$ioa_switch (a_iocbp, "Passord invalid. No enabling/disabling action taken."); go to print_error_keys; /* 50 */ print_status_msg (8): call ioa_$ioa_switch (a_iocbp, "Character count greater than length of sending field. No action taken."); go to print_error_keys; /* 60 */ print_status_msg (9): call ioa_$ioa_switch (a_iocbp, "Partial segment with either zero character count or no sending area specified. No action taken."); go to print_error_keys; /* 70 */ print_status_msg (10): call ioa_$ioa_switch (a_iocbp, "One or more detinations do not have partial messages associated with them. Action completed for other destinations." ); go to print_error_keys; print_error_keys: if ^input_cd_sw then if output_cdp ^= null () then do; /* print out individual ERROR KEYs from output CD */ count = output_cd.station_count; if count <= output_cd.bin_max_station_count then do; /* valid CD info */ call ioa_$ioa_switch (a_iocbp, "Station Error Code"); do i = 1 to count; call ioa_$ioa_switch (a_iocbp, "^12a ^1a", output_cd.dest_table (i).station_name, output_cd.dest_table (i).error_key); end; call ioa_$ioa_switch (a_iocbp, ""); /* leave a little whitespace */ end; end; ds_ret: return; end /* cmcs_decode_status_ */;  cmcs_error_table_.alm 11/11/82 1551.2rew 11/11/82 1016.1 51354 " *********************************************************** " * * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1981 * " * * " * * " *********************************************************** " Modified since Version 4.3 name cmcs_error_table_ use codes .code_start: null use past_codes .code_end: null use codes segdef ambiguous_tree_path ambiguous_tree_path: vfd 18/.sys_sw,18/.ambiguous_tree_path use messages aci ,ambig_tp, .ambiguous_tree_path: acc ;Insufficient qualification. Subordinate receives already in process.; use codes segdef bad_call_parm bad_call_parm: vfd 18/.sys_sw,18/.bad_call_parm use messages aci ,bad_call, .bad_call_parm: acc ;An invalid parameter was passed to the COBOL MCS runtime support facility.; use codes segdef bad_dest bad_dest: vfd 18/.sys_sw,18/.bad_dest use messages aci ,bad_dest, .bad_dest: acc ;A specified message destination is undefined.; use codes segdef bad_dest_count bad_dest_count: vfd 18/.sys_sw,18/.bad_dest_count use messages aci ,bad_dc , .bad_dest_count: acc ;Specified message destination count is outside defined range.; use codes segdef bad_message_length bad_message_length: vfd 18/.sys_sw,18/.bad_message_length use messages aci ,bad_msgl, .bad_message_length: acc ;Specified length of message to be sent is invalid.; use codes segdef bad_password bad_password: vfd 18/.sys_sw,18/.bad_password use messages aci ,bad_psw , .bad_password: acc ;Attempt to perform an enable or disable function using an incorrect password.; use codes segdef bad_queue_path bad_queue_path: vfd 18/.sys_sw,18/.bad_queue_path use messages aci ,bad_qp , .bad_queue_path: acc ;The specified symbolic message queue is not in the current queue hierarchy.; use codes segdef bad_slew bad_slew: vfd 18/.sys_sw,18/.bad_slew use messages aci ,bad_slew, .bad_slew: acc ;The CMCS slew control is incorrect.; use codes segdef bad_source bad_source: vfd 18/.sys_sw,18/.bad_source use messages aci ,bad_src , .bad_source: acc ;The specified symbolic message source is undefined.; use codes segdef bad_station bad_station: vfd 18/.sys_sw,18/.bad_station use messages aci ,bad_sta , .bad_station: acc ;The specified station is not defined for CMCS use.; use codes segdef bad_term_devchn bad_term_devchn: vfd 18/.sys_sw,18/.bad_term_devchn use messages aci ,bad_term, .bad_term_devchn: acc ;The specified terminal device_channel is not defined for CMCS use.; use codes segdef bad_tree_path bad_tree_path: vfd 18/.sys_sw,18/.bad_tree_path use messages aci ,bad_tree, .bad_tree_path: acc ;The specified symbolic message queue is not in the current queue hierarchy.; use codes segdef dest_already_disabled dest_already_disabled: vfd 18/.sys_sw,18/.dest_already_disabled use messages aci ,dest_ad , .dest_already_disabled: acc ;A specified message destination is already disabled.; use codes segdef dest_already_enabled dest_already_enabled: vfd 18/.sys_sw,18/.dest_already_enabled use messages aci ,dest_ae , .dest_already_enabled: acc ;A specified message destination is already enabled.; use codes segdef dest_disabled dest_disabled: vfd 18/.sys_sw,18/.dest_disabled use messages aci ,dest_d , .dest_disabled: acc ;A specified message destination is currently disabled.; use codes segdef no_message no_message: vfd 18/.sys_sw,18/.no_message use messages aci ,no_msg , .no_message: acc ;No message exists in the specified queue hierarchy.; use codes segdef no_partial_messages no_partial_messages: vfd 18/.sys_sw,18/.no_partial_messages use messages aci ,no_pmsg , .no_partial_messages: acc ;A message queue contains no partial messages which can be purged.; use codes segdef null_partial_message null_partial_message: vfd 18/.sys_sw,18/.null_partial_message use messages aci ,nul_pmsg, .null_partial_message: acc ;Attempt to send a null partial message.; use codes segdef queue_already_disabled queue_already_disabled: vfd 18/.sys_sw,18/.queue_already_disabled use messages aci ,q_ad , .queue_already_disabled: acc ;A specified message queue is already disabled.; use codes segdef queue_already_enabled queue_already_enabled: vfd 18/.sys_sw,18/.queue_already_enabled use messages aci ,q_ae , .queue_already_enabled: acc ;A specified message queue is already enabled.; use codes segdef queue_disabled queue_disabled: vfd 18/.sys_sw,18/.queue_disabled use messages aci ,q_d , .queue_disabled: acc ;A specified message queue is currently disabled.; use codes segdef source_already_disabled source_already_disabled: vfd 18/.sys_sw,18/.source_already_disabled use messages aci ,src_ad , .source_already_disabled: acc ;A specified message source is already disabled.; use codes segdef source_already_enabled source_already_enabled: vfd 18/.sys_sw,18/.source_already_enabled use messages aci ,src_ae , .source_already_enabled: acc ;A specified message source is already enabled.; use codes segdef source_disabled source_disabled: vfd 18/.sys_sw,18/.source_disabled use messages aci ,src_d , .source_disabled: acc ;A specified message source is currently disabled.; bool .sys_sw,0 " use messages tempd .tp .trapproc: save eppbp 0,ic spribp .tp lda .tp ana =o77777,du epbpsb sp|0 lda sb|22,*au easplp 0,au eawplp 0,al ldx0 .tp eax1 .code_start .loop: stx0 lp|0,x1 eax1 1,x1 cmpx1 .code_end,du tmi .loop-*,ic return firstref <*text>|.trapproc join /text/messages join /link/codes,past_codes end  cmcs_expand_tree_path.pl1 05/24/89 1047.9rew 05/24/89 0836.6 25938 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_expand_tree_path.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_expand_tree_path: cmetp: proc (); /* This COBOL MCS command and active function provides the command interface to expand a short-form CMCS tree_path (no blanks, period delimiters) into the proper 48-char tree_path string. Its primary use will be as an active function for interactive and absentee initiation of COBOL MCS application programs that have an "INITIAL MESSAGE" clause, where the program must be told what CMCS queue (and subqueues) to use in its initial RECEIVE request. Bob May, 6/30/77 */ dcl af_sw bit (1); dcl my_name char (21) init ("cmcs_expand_tree_path"); dcl tree_path char (48); %include cmcs_arg_processing; dcl code fixed bin (35); dcl ioa_ entry options (variable); dcl cmcs_expand_tree_path_ entry (char (*), char (48), fixed bin (35)); /* */ call cu_$af_return_arg (arg_count, af_return_arg_ptr, af_return_arg_len, code); if code ^= 0 then if code = error_table_$not_act_fnc then do; call cu_$arg_count (arg_count); af_sw = "0"b; end; else do; /* probably active function, but something else is wrong */ call active_fnc_err_ (code, my_name, "Attempting to get active function paramters."); return; end; else af_sw = "1"b; /* everything is go for AF */ if arg_count ^= 1 then do; print_usage: code = 0; print_error: if af_sw then call active_fnc_err_ (code, my_name, "^/Usage: cmcs_expand_tree_path level_name1{.l_n2{.l_n3{.l_n4}}}"); else call com_err_ (code, my_name, "^/Usage: cmcs_expand_tree_path level_name1{.l_n2{.l_n3{.l_n4}}}"); return; end; if af_sw then call cu_$af_arg_ptr (1, arg_ptr, arg_len, code); else call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then go to print_error; call cmcs_expand_tree_path_ (arg, tree_path, code); if code ^= 0 then go to print_error; if af_sw then af_return_arg = """" || tree_path || """"; /* enclose it quotes for command line */ else call ioa_ ("""^48a""", tree_path); return; end /* cmcs_expand_tree_path */;  cmcs_expand_tree_path_.pl1 05/24/89 1047.9rew 05/24/89 0837.3 36621 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_expand_tree_path_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_expand_tree_path_: proc (a_input, a_tree_path, a_code); /* This COBOL MCS subroutine is used by the CMCS command interfaces to expand the short-form tree path (no blanks, period delimiters) into the proper 48-character internal representation. The level_names can be from 1-12 chars in length and must be period separated. Blanks may appear only on the trailing end of the input string. Errors will be returned if there are more than three periods, intervening blanks, adjacent periods, and level_names outside the length of 1-12 characters. Bob May, 6/30/77 */ dcl a_input char (*), a_tree_path char (48), a_code fixed bin (35); dcl cmcs_error_table_$bad_tree_path fixed bin (35) external; dcl buffer char (51), buffer_left_begin fixed bin, buffer_left_len fixed bin; dcl end_sw bit (1), (i, j) fixed bin; dcl tree_path_ptr ptr; dcl 1 tree_path based (tree_path_ptr), 2 level_names (4) char (12); dcl level_no fixed bin; dcl (index, length, search, substr, verify) builtin; /* */ /* Preliminary Checks */ if length (a_input) = 0 | length (a_input) > 51 then go to bad_tree_path; if substr (a_input, 1, 1) = "." | substr (a_input, 1, 1) = " " then go to bad_tree_path; /* period and blank */ /* Initialization */ tree_path_ptr = addr (a_tree_path); buffer = a_input; /* copy to fixed space for efficiency */ buffer_left_begin = 1; buffer_left_len = 51; level_no = 0; end_sw = "0"b; /* Main Procedure */ loop: level_no = level_no + 1; if level_no = 5 then go to bad_tree_path; /* data follows level_name-4 */ i = index (substr (buffer, buffer_left_begin, buffer_left_len), "."); /* look for another component preceded with "." */ if i = 0 then do; /* at least no more periods */ end_sw = "1"b; /* should be last time through */ i = index (substr (buffer, buffer_left_begin, buffer_left_len), " "); /* trailing blanks? */ if i = 0 then do; /* no, use all that remains */ i = buffer_left_len; end; else do; /* found trailing blank */ if buffer_left_begin + i < 53 then if verify (substr (buffer, buffer_left_begin + i), " ") ^= 0 /* look for data after blank */ then go to bad_tree_path; i = i - 1; /* adjust field length to elim blank */ end; end; else i = i - 1; /* found a period, set i to length of level_name */ /* validate level name */ if i = 0 then go to bad_tree_path; if i > 12 then go to bad_tree_path; /* must be 1-12 chars long */ level_names (level_no) = substr (buffer, buffer_left_begin, i); if level_names (level_no) = " " then go to bad_tree_path; /* tried to slip it in between good delims */ if ^end_sw then do; buffer_left_begin = buffer_left_begin + i + 1; buffer_left_len = buffer_left_len - i - 1; /* include the trailing "." as well */ go to loop; end; /* Finish Up */ if level_no ^= 4 then do i = level_no + 1 to 4; /* blank out all trailing level names */ level_names (i) = ""; end; a_code = 0; return; bad_tree_path: a_code = cmcs_error_table_$bad_tree_path; a_tree_path = ""; /* make sure they can't use anything */ return; end /* cmcs_expand_tree_path_ */;  cmcs_fillin_hdr_.pl1 05/24/89 1047.9rew 05/24/89 0836.6 17829 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_fillin_hdr_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_fillin_hdr_: proc (a_hdr_ptr, a_hdr_version, a_hdr_len, a_entry_len, a_code); /* This COBOL MCS subroutine is used to fill in the standard infoirmation in all CMCS control headers */ /* Bob May, 5/31/77 */ dcl a_hdr_ptr ptr, a_hdr_version fixed bin, a_hdr_len fixed bin, a_entry_len fixed bin, a_code fixed bin (35); %include cmcs_control_hdr; dcl sys_info$max_seg_size fixed bin (18) external; dcl divide builtin; dcl clock_ entry () returns (fixed bin (71)), get_group_id_$tag_star entry () returns (char (32)), get_process_id_ entry () returns (bit (36)); /* */ control_hdr_ptr = a_hdr_ptr; control_hdr.version = a_hdr_version; control_hdr.clock_created = clock_ (); control_hdr.group_id = get_group_id_$tag_star (); control_hdr.process_id = get_process_id_ (); if a_entry_len ^= 0 /* don't hiccup for structures with no entries */ then control_hdr.max_size = divide ((sys_info$max_seg_size - (control_hdr_len + a_hdr_len)), a_entry_len, 18, 0); else control_hdr.max_size = 0; control_hdr.current_size, control_hdr.entry_count = 0; a_code = 0; return; end /* cmcs_fillin_hdr_ */;  cmcs_initiate_ctl_.pl1 05/24/89 1047.9rew 05/24/89 0836.6 37746 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_initiate_ctl_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 03/16/82 by FCH, [5.2-1], eliminate need for copy switch by using temp seg, BUG530 */ /* Modified since Version 5.0 */ /* format: style3 */ cmcs_initiate_ctl_: proc (a_name, a_ptr, a_code); dcl a_name char (*), a_ptr ptr, /* used for xxx_ctl_ptr */ a_code fixed bin (35); dcl my_name char (18) init ("cmcs_initiate_ctl_"); dcl initiate_dir char (168); /* either WD or from user_ctl */ dcl x_ptr ptr; /* global initiate ptr */ dcl ioa_ entry options (variable); dcl get_wdir_ entry () returns (char (168)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); /*[5.2-1]*/ dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); /*[5.2-1]*/ dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); /*[5.2-1]*/ dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); /*[5.2-1]*/ dcl code fixed bin (35), TYPE fixed bin (2), BIT_COUNT fixed bin (24); /*[5.2-1]*/ dcl ptr_array (1) ptr static int; /*[5.2-1]*/ dcl SEG bit (9 * sys_info$max_seg_size) based; dcl error_table_$action_not_performed fixed bin (35) external; dcl sys_info$max_seg_size fixed bin (18) static ext; dcl null builtin; /* */ %include cmcs_cobol_mcs_dcls; %include cmcs_user_ctl; /* */ a_ptr = null (); call cobol_mcs_$get_user_ctl_exists_sw (user_ctl_exists_sw); if ^user_ctl_exists_sw then do; initiate_dir = get_wdir_ (); call initiate (a_name); a_ptr = x_ptr; return; end; user_ctl_ptr = external_user_ctl_ptr; initiate_dir = user_ctl.cmcs_dir; call initiate ("cmcs_queue_ctl.control"); user_ctl.queue_ctl_ptr = x_ptr; /* whether null or not */ call initiate ("cmcs_station_ctl.control"); user_ctl.station_ctl_ptr = x_ptr; /* whether null or not */ call initiate ("cmcs_system_ctl.control"); user_ctl.system_ctl_ptr = x_ptr; /* whether null or not */ call initiate ("cmcs_terminal_ctl.control"); user_ctl.terminal_ctl_ptr = x_ptr; /* whether null or not */ call initiate ("cmcs_tree_ctl.control"); /*[5.2-1]*/ call get_temp_segment_ ("cmcs_initiate_ctl_", ptr_array (1), code); /*[5.2-1]*/ if code ^= 0 /*[5.2-1]*/ then do; a_code = code; /*[5.2-1]*/ return; /*[5.2-1]*/ end; /*[5.2-1]*/ call hcs_$status_minf (initiate_dir, "cmcs_tree_ctl.control", 1, TYPE, BIT_COUNT, code); /*[5.2-1]*/ if code ^= 0 /*[5.2-1]*/ then do; a_code = code; /*[5.2-1]*/ return; /*[5.2-1]*/ end; /*[5.2-1]*/ user_ctl.tree_ctl_ptr = ptr_array (1); /*[5.2-1]*/ substr (user_ctl.tree_ctl_ptr -> SEG, 1, BIT_COUNT) = substr (x_ptr -> SEG, 1); call initiate ("cmcs_wait_ctl.control"); user_ctl.wait_ctl_ptr = x_ptr; /* whether null or not */ a_code = 0; return; release: entry (a_code); /*[5.2-1]*/ call release_temp_segments_ ("cmcs_initiate_ctl_", ptr_array, code); /*[5.2-1]*/ if code ^= 0 then a_code = code; /*[5.2-1]*/ return; /* */ initiate: proc (x_name); dcl x_name char (*); call hcs_$initiate (initiate_dir, x_name, "", 0, 0, x_ptr, a_code); if x_ptr = null () then do; call ioa_ ("""^a"" not not available. If needed, correct and retry.", x_name); return; end; a_code = 0; /* ptr is good, make code good too */ return; end /* initiate */; /* */ end /* cmcs_initiate_ctl_ */;  cmcs_print_.pl1 05/24/89 1047.9rew 05/24/89 0836.6 46026 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_print_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/02/81 by FCH, [5.0-1], emit NL after message if no slew, BUG510 */ /* Modified on 07/16/81 by FCH, [4.4-1], make BEF/AFT PAGE same as BEF/AFT 1 LINE unless printer, BUG468 */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_print_: proc (a_iocb_ptr, a_buffer_ptr, a_buffer_len, a_slew_ctl_ptr, a_code); /* This COBOL MCS subroutine is used to reformat messages and message segments for final output to a terminal device. It uses the slew control originally given in the SEND verb to determine the nature of slewing required. Slew control can specify a slew of zero lines. Thus, all output of data is terminated with a Carriage Return, rather than a Newline. It is up to the COBOL program to keep track of the need to slew. Bob May, 6/30/77 */ dcl a_iocb_ptr ptr, a_buffer_ptr ptr, a_buffer_len fixed bin (35), a_slew_ctl_ptr ptr, a_code fixed bin (35); dcl buffer char (a_buffer_len) based (a_buffer_ptr); /* for DEBUG */ dcl (addr, copy, fixed, null, substr, unspec) builtin; dcl test_sw bit (1) int static init ("0"b); dcl 1 esc_sequence, 2 ESC char (1), 2 vfu_chn pic "99", 2 ETX char (1); dcl (NL, FF, CR) char (1); dcl NL_string char (128); /* */ %include cmcs_slew_ctl; %include cmcs_iox_processing; %include cmcs_error_table_dcls; %include cmcs_user_ctl; /* */ /* Initialization */ slew_ctl_ptr = a_slew_ctl_ptr; /* to get at structure components */ unspec (esc_sequence.ESC) = "033"b3; unspec (esc_sequence.ETX) = "003"b3; unspec (CR) = "015"b3; unspec (NL) = "012"b3; unspec (FF) = "014"b3; /*[4.4-1]*/ user_ctl_ptr = external_user_ctl_ptr; NL_string = copy (NL, 128); /* */ if slew_ctl.when = 0 then do; call iox_$put_chars (a_iocb_ptr, addr (NL), 1, a_code); if a_code ^= 0 then return; call put_data; /* as-is, with trailing CR */ /*[5.0-1]*/ if ^user_ctl.attach_bit | (user_ctl.attach_bit & user_ctl.iocb_ptr = null ()) /*[5.0-1]*/ then call iox_$put_chars (a_iocb_ptr, addr (NL), 1, a_code); end; else if slew_ctl.when = 1 then do; /* send before slew */ call put_data; call put_slew; end; else if slew_ctl.when = 2 then do; /* send data after slew */ call put_slew; call put_data; end; else do; a_code = cmcs_error_table_$bad_call_parm; end; return; /* */ put_data: proc (); if a_buffer_len ^= 0 then do; /* sometimes they just want the slew */ call iox_$put_chars (a_iocb_ptr, a_buffer_ptr, fixed (a_buffer_len, 21), a_code); if a_code ^= 0 then return; end; call iox_$put_chars (a_iocb_ptr, addr (CR), 1, a_code); return; end /* put_data */; /* */ put_slew: proc (); if slew_ctl.what = 0 then do; /* same as slew zero lines... we put out the CR in front */ a_code = 0; return; end; else if slew_ctl.what = 1 then do; /* slew n lines */ /*[4.4-1]*/ call lines; return; end; /* what = 1 */ else if slew_ctl.what = 2 then do; /* wants slew to PAGE */ /*[4.4-1]*/ if user_ctl.attach_bit /*[4.4-1]*/ then if user_ctl.iocb_ptr ^= null () /*[4.4-1]*/ then do; call iox_$put_chars (a_iocb_ptr, addr (FF), 1, a_code); /*[4.4-1]*/ return; /*[4.4-1]*/ end; /*[4.4-1]*/ slew_ctl.how_much = 1; /*[4.4-1]*/ call lines; return; end; /* what = 2 */ else if slew_ctl.what = 3 then do; /* wants slew to channel */ if slew_ctl.how_much < 1 | slew_ctl.how_much > 16 then do; /* VFU channels can only be 1-16 */ a_code = cmcs_error_table_$bad_call_parm; return; end; esc_sequence.vfu_chn = slew_ctl.how_much; /* convert to ascii chars */ call iox_$put_chars (a_iocb_ptr, addr (esc_sequence), 4, a_code); return; end; else do; a_code = cmcs_error_table_$bad_call_parm; return; end; end /* put_slew */; /*[4.4-1]*/ lines: proc; if slew_ctl.how_much = 0 then do; /* same as what = 0 */ a_code = 0; return; end; else if slew_ctl.how_much > 128 then do; /* can't handle this */ a_code = cmcs_error_table_$bad_call_parm; return; end; call iox_$put_chars (a_iocb_ptr, addr (NL_string), fixed (slew_ctl.how_much, 21), a_code); end; /*[4.4-1]*/ end /* cmcs_print_ */;  cmcs_purge_queues_.pl1 05/24/89 1047.9rew 05/24/89 0833.9 64791 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_purge_queues_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_purge_queues_: proc (a_queue_ctl_eindex, a_long_sw, a_code); dcl a_queue_ctl_eindex fixed bin, a_long_sw bit (1), a_code fixed bin (35); dcl i fixed bin; /* dummy to avoid looping for count ^= 0 */ dcl my_name char (18) int static options (constant) init ("cmcs_purge_queues_"); dcl sub_err_ entry options (variable); dcl sub_err_retval fixed bin (35); dcl iocb_ptr ptr; dcl ( ioa_, ioa_$rsnnl ) entry options (variable); dcl 1 msg_descr int static like vfile_descr; dcl msg_descr_ptr ptr int static; dcl fb21 fixed bin (21); dcl (msg_no, seg_no) fixed bin (35); dcl 1 static_vfile_rs int static like vfile_rs; dcl attach_descr char (256), attach_descr_len fixed bin; dcl switch_name char (7) int static options (constant) init ("cmcs_pq"); dcl overlay_len fixed bin, overlay (overlay_len) fixed bin (35) based; dcl (error_table_$no_record) fixed bin (35) external; dcl (addr, fixed, null, size, substr) builtin; /* */ %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_error_table_dcls; %include cmcs_iox_processing; %include cmcs_key_dcls; %include cmcs_msg_hdr; %include cmcs_msg_seg; %include cmcs_queue_ctl; %include cmcs_user_ctl; %include cmcs_vfile_rs; /* */ /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.purge_queues) then call setup; if a_queue_ctl_eindex = 0 then do queue_ctl_eindex = 1 to queue_ctl.current_size; call purge_queue; end; else do; queue_ctl_eindex = a_queue_ctl_eindex; if queue_ctl_eindex < 1 | queue_ctl_eindex > queue_ctl.current_size then do; a_code = cmcs_error_table_$bad_call_parm; return; end; call purge_queue; /* dropped thru, specific index ok */ end; a_code = 0; return; /* */ purge_queue: proc (); /* Requires that queue_ctl_eindex be set to desired queue prior to call */ queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); if a_long_sw then call ioa_ ("Queue ^a^/^-Partial sends = ^d^/^-Available = ^d^/^-Partial receives ^d^/^-Completed = ^d", queue_ctl_entry.queue_name, queue_ctl_entry.status_list_ctl_entries (1).count, queue_ctl_entry.status_list_ctl_entries (2).count, queue_ctl_entry.status_list_ctl_entries (3).count, queue_ctl_entry.status_list_ctl_entries (4).count); call ioa_$rsnnl ("vfile_ ^a>^a -old", attach_descr, attach_descr_len, user_ctl.cmcs_dir, queue_ctl_entry.queue_name); call iox_$attach_name (switch_name, iocb_ptr, substr (attach_descr, 1, attach_descr_len), null (), a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to attach queue ^a.", queue_ctl_entry.queue_name); go to pq_ret; end; call iox_$open (iocb_ptr, 13, "0"b, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to open ^a.", queue_ctl_entry.queue_name); go to detach; end; do status_list_ctl_eindex = 1, 3, 4; status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (status_list_ctl_eindex)); do i = 1 to status_list_ctl_entry.count; msg_descr = status_list_ctl_entry.f_descr; /* get first in list */ if status_list_ctl_eindex = 3 then do; call cmcs_status_list_ctl_$move (queue_ctl_eptr, iocb_ptr, msg_descr_ptr, 3, 2, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to move status 3 message back to status 2."); go to end_count_loop; end; end; else do; /* 1 or 4, delete it */ static_vfile_rs.descr = status_list_ctl_entry.f_descr; call iox_$control (iocb_ptr, "record_status", vfile_rs_ptr, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to seek descriptor to get the msg header."); msg_hdr_ptr = null (); msg_seg_ptr = null (); go to end_count_loop; end; msg_hdr_ptr = static_vfile_rs.rec_ptr; msg_seg_ptr = addr (msg_hdr.msg_seg); msg_no = msg_hdr.msg_no; /* for subsequent seek keys */ call cmcs_status_list_ctl_$delete (queue_ctl_eptr, iocb_ptr, msg_descr_ptr, status_list_ctl_eindex, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to delete message from status list ^d.", status_list_ctl_eindex); go to end_count_loop; end; key_struc.msg_no = msg_no; key_struc.seg_no = 0; seg_delete_loop: key_struc.seg_no = key_struc.seg_no + 1; key = based_key; /* to make vfile_ happy */ call iox_$seek_key (iocb_ptr, key, fb21, a_code); if a_code ^= 0 then if a_code = error_table_$no_record then go to end_count_loop; else do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to seek ^d/^d for deletion.", key_struc.msg_no, key_struc.seg_no); go to end_count_loop; end; call iox_$delete_record (iocb_ptr, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to delete ^d/^d.", key_struc.msg_no, key_struc.seg_no); go to seg_delete_loop; end; end /* status 1 or 4 */; end_count_loop: end /* count > 0 */; end /* status 1, 3, or 4 */; close: call iox_$close (iocb_ptr, a_code); if a_code ^= 0 then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to close ^a.", queue_ctl_entry.queue_name); detach: call iox_$detach_iocb (iocb_ptr, a_code); if a_code ^= 0 then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to detach ^a.", queue_ctl_entry.queue_name); pq_ret: return; end /* purge_queue */; /* */ setup: proc (); user_ctl_ptr = external_user_ctl_ptr; queue_ctl_ptr = user_ctl.queue_ctl_ptr; msg_descr_ptr = addr (msg_descr); vfile_rs_ptr = addr (static_vfile_rs); overlay_len = size (static_vfile_rs); vfile_rs_ptr -> overlay (*) = 0; static_vfile_rs.locate_sw = "1"b; static_vfile_rs.version = vfile_rs_version; user_ctl.init_sw.purge_queues = "1"b; return; end /* setup */; end /* cmcs_purge_queues_ */;  cmcs_queue_ctl_.pl1 05/24/89 1047.9rew 05/24/89 0834.0 486792 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8087), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8087 cmcs_queue_ctl_.pl1 Shorten wait time for cmcs_station_ctl_. END HISTORY COMMENTS */ /* Modified on 10/10/84 by FCH, [5.3-1], BUG565(phx18385), wait time for set_lock_$lock */ /* Modified on 05/06/81 by FCH, [4.4-6], activate and deactivate commands, BUG468 */ /* Modified on 05/05/81 by FCH, [4.4-5], emi and egi are equiv, BUG468 */ /* Modified on 04/29/81 by FCH, [4.4-3], test station_ctl_entry.output_disabled_sw in send, BUG468 */ /* Modified on 04/25/81 by FCH, [4.4-2], once per process initialization, BUG468 */ /* Modified on 04/27/81, [4.4-1], check for now_much^=0 caused abort, BUG468 */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_queue_ctl_: proc; return; /* bad entrypoint */ /* This COBOL MCS subroutine manages the queue related CMCS functions of ACCEPT, SEND, RECEIVE, PURGE, and ENABLE/DISABLE INPUT (QUEUE). Common code is shared by receive/print, and purge/stop_run. Bob May, 6/30/77 */ /* Note: The disable/enable entrypoints all accept a char (10) password string. This string is ignored because it was already checked by cobol_mcs_. Current ANSI rules on the use of multiple passwords for CMCS terminals and queues is unclear and requests for clarification have been submitted. Until the clarification is issued, this implementation will use a single password. Thus, cobol_mcs_ can do the checking for everybody. */ dcl a_input_cdp ptr, a_output_cdp ptr, a_cdp ptr, /* when we don't know yet whether input or output (purge) */ a_code fixed bin (35), a_iocb_ptr ptr, /* print entrypoint only */ a_buffer_ptr ptr, a_buffer_len fixed bin, a_station_count fixed bin, /* send entrypoint only */ a_slew_ctl fixed bin (35), /* send entrypoint only */ a_password char (10), a_io_subtype fixed bin; dcl cdp ptr; /* intermediate value for purge and stop_run */ dcl buffer_len fixed bin (21), buffer_left_index fixed bin (35), buffer_left_len fixed bin (35), buffer_ptr ptr, buffer char (buffer_len) based (buffer_ptr); /* for copying data */ dcl (msg_no, seg_no) fixed bin (35); dcl sysprint file env (interactive); /* for DEBUG */ dcl program_interrupt condition; dcl test_sw bit (1) int static init ("0"b); dcl iocb_ptr ptr; /* for all the queue I/O, one at atime */ dcl 1 min_blksz_info int static, /* to ensure space for vfile lockword in each record */ 2 min_residue fixed bin (21), 2 min_capacity fixed bin (21); dcl my_name char (15) init ("cmcs_queue_ctl_"); /* for DEBUG */ dcl (addr, char, fixed, index, min, null, rtrim, size, string, substr) builtin; dcl ( ioa_, ioa_$rsnnl, sub_err_ ) entry options (variable); dcl sub_err_retval fixed bin (35); /* dummy for sub_err_ */ dcl get_process_id_ entry () returns (bit (36)), get_group_id_ entry () returns (char (32)), hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)), clock_ entry () returns (fixed bin (71)); dcl get_temp_segments_ entry (char (*), (*) ptr aligned, fixed bin (35)), release_temp_segments_ entry (char (*), (*) ptr aligned, fixed bin (35)); dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)), set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl (i, code) fixed bin (35); dcl ( error_table_$action_not_performed, error_table_$bad_new_key, error_table_$no_record, error_table_$not_open ) fixed bin (35) external; dcl (old_status, new_status) fixed bin, /* for status_list_ctl_ */ (io_subtype, io_type) fixed bin, station_name char (12), station_count fixed bin; dcl overlay_len fixed bin, /* to erase structure data */ overlay (overlay_len) fixed bin (35) based; dcl dest_table_index fixed bin, flag bit (1); dcl 1 msg_descr like vfile_descr; dcl zero fixed bin (35) int static options (constant) init (0); dcl zero_descr_ptr ptr int static; dcl 1 zero_descr like vfile_descr based (zero_descr_ptr); /* */ /* declarations for SEND */ dcl send_init_sw bit (1) int static init ("0"b); dcl ptr_array (1) ptr static internal; /* to pick up temp segs, one at a time */ dcl tseg_ptr ptr, /* temporary buffer for partial messages, per queue */ tseg_len fixed bin (21), tseg char (tseg_len) based (tseg_ptr); dcl tseg_max_len fixed bin (21) init (64 * 1024 * 4); /* arbitrary */ dcl switch_no fixed bin int static init (0);/* to generate switch names for same queue */ dcl attach_descr char (256); /* for iox_$attach */ dcl attach_descr_len fixed bin; /* returned by ioa_$rsnnl */ dcl switch_pic pic "99"; /* to generate switch name from queue_name, number */ dcl 1 send_vfile_rs like vfile_rs int static; /* to allocate records for send */ dcl send_vfile_rs_ptr ptr int static; dcl 1 send_descr like vfile_descr int static; dcl seek_len fixed bin (21); /* for record_status allocate */ dcl fb21 fixed bin (21); /* dummy output variable for seek_key */ /* */ /* Declarations for RECEIVE */ dcl init_queue_table_sw bit (1) int static init ("0"b); dcl queue_table_ptr ptr int static; dcl 1 queue_table_struc based (queue_table_ptr), 2 queue_table_len fixed bin, 2 queue_table (tree_ctl.current_size refer (queue_table_struc.queue_table_len)) fixed bin; /* table of queue indices for subtree */ dcl copy_len fixed bin (35); dcl 1 rcv_vfile_rs like vfile_rs int static; dcl 1 rcv_descr like vfile_descr int static; dcl rcv_vfile_rs_ptr ptr int static; dcl rcv_descr_ptr ptr int static; dcl subtree_count fixed bin; dcl rcv_init_sw bit (1) int static init ("0"b); /* Declarations for ACCEPT_MESSAGE_COUNT */ dcl msg_count fixed bin (35); /* careful, inside input_cd, it's a char item */ /* */ %include cmcs_cd_dcls; %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_error_table_dcls; %include cmcs_iox_processing; %include cmcs_key_dcls; %include cmcs_msg_hdr; %include cmcs_msg_seg; %include cmcs_queue_ctl; %include cmcs_slew_ctl; %include cmcs_station_ctl; %include cmcs_system_ctl; %include cmcs_tree_ctl; %include cmcs_user_ctl; %include cmcs_vfile_rs; %include cmcs_wait_ctl; /* */ set: proc; /*[4.4-2]*/ if ^external_user_ctl_ptr -> user_ctl.init_sw.queue_ctl then call setup; end; accept_message_count: entry (a_input_cdp, a_io_subtype, a_code); /*[4.4-2]*/ call set; input_cdp = a_input_cdp; io_type = 5; io_subtype = a_io_subtype; call build_queue_table (); if a_code ^= 0 then return; /* build_queue_table sets status_key */ msg_count = 0; /* accumulative */ do i = 1 to queue_table_len; /* sum individual counts for this specific request */ queue_ctl_eindex = queue_table (i); queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); /* accumulated count is not a "locked" count, since it can change before the user does a receive anyway */ msg_count = msg_count + queue_ctl_entry.status_list_ctl_entries (2).count; /* count only available msgs */ end; input_cd.msg_count = msg_count; /* fixed bin -> char, required by COBOL */ input_cd.status_key = "00"; return; /* end of accept_message_count entrypoint */ /* */ disable: entry (a_input_cdp, a_io_subtype, a_password, a_code); /* strictly for queues, not stations */ /*[4.4-2]*/ call set; input_cdp = a_input_cdp; io_type = 4; io_subtype = a_io_subtype; call build_queue_table; if a_code ^= 0 then return; code = 0; do i = 1 to queue_table_len; queue_ctl_eindex = queue_table (i); queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); if ^queue_ctl_entry.input_disabled_sw then queue_ctl_entry.input_disabled_sw = "1"b; else code = cmcs_error_table_$queue_already_disabled; end; a_code = code; /* whatever the results, status_key here is "00" */ input_cd.status_key = "00"; return; /* end of disable entrypoint */ /* */ enable: entry (a_input_cdp, a_io_subtype, a_password, a_code); /* strictly for queues, not stations */ /*[4.4-2]*/ call set; input_cdp = a_input_cdp; io_type = 3; io_subtype = a_io_subtype; call build_queue_table; if a_code ^= 0 then return; code = 0; do i = 1 to queue_table_len; queue_ctl_eindex = queue_table (i); queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); if queue_ctl_entry.input_disabled_sw then queue_ctl_entry.input_disabled_sw = "0"b; else code = cmcs_error_table_$queue_already_enabled; end; a_code = code; /* whatever the results, status_key here is "00" */ input_cd.status_key = "00"; return; /* end of enable entrypoint */ /* */ stop_run: entry (a_io_subtype, a_code); /* for now, a_io_subtype must always be 1 */ io_type = 8; /* for use in purge_common */ cdp = null (); go to purge_common; /* */ purge: entry (a_cdp, a_io_subtype, a_code); io_type = 6; /* to identify purge request */ cdp = a_cdp; /* From now on, purge and stop_run share common code. */ purge_common: dest_table_index = 0; a_code = 0; /*[4.4-2]*/ call set; io_subtype = a_io_subtype; /* if the cdp is null, we delete all sends and/or receives */ if cdp = null () then do; do tree_ctl_eindex = 1 to tree_ctl.hdr.current_size; tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex)); if tree_ctl_entry.subtree_count = 0 then if tree_ctl_entry.io_in_process_sw then do; /* active entry */ call get_tce_parms; if tree_ctl_entry.io_type = 1 then if ^(io_type = 6 & io_subtype = 2) /* specifically shouldn't do sends */ then do; call purge_send_entry; end; else ; else if tree_ctl_entry.io_type = 2 | tree_ctl_entry.io_type = 7 then if ^(io_type = 6 & io_subtype = 1) /* specifically shouldn't do receives */ then do; call purge_rcv_entry; end; end; if tree_ctl_entry.iocb_ptr ^= null () then call close; end; a_code = 0; return; end; /* of code for null cdp */ /* Drop-thru means the cdp wasn't null. Thus, we must be in purge, not stop_run. */ a_code = 0; /* set zero now, to let first error set non-zero */ if io_subtype = 1 then do; /* purge sends only */ output_cdp = cdp; output_cd.status_key = "00"; /* initialize good, set only on first error */ station_count = output_cd.station_count;/* thank heavens for pictures */ do dest_table_index = 1 to station_count; station_name = output_cd.dest_table (dest_table_index).station_name; call cmcs_tree_ctl_$find_destination (station_name, tree_ctl_eindex, tree_ctl_eptr, code); if code ^= 0 then do; if a_code = 0 then do; a_code = code; output_cd.status_key = "20"; end; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; call get_tce_parms; call purge_send_entry; if code ^= 0 then do; if a_code = 0 then do; a_code = code; output_cd.status_key = "20"; end; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; end; end; /* of purges of sends, using supplied cdp */ else if a_io_subtype = 2 /* just purge the receives */ then do; input_cdp = cdp; input_cd.status_key = "00"; /* set good now, change if needed */ call cmcs_tree_ctl_$find_tree_path (input_cdp, tree_ctl_eindex, subtree_count, tree_ctl_eptr, code); if code ^= 0 then do; purge_set_input_err: input_cd.status_key = "20"; a_code = code; return; end; if subtree_count = 0 then do; call get_tce_parms; call purge_rcv_entry; if code ^= 0 then go to purge_set_input_err; end; else do i = tree_ctl_eindex to tree_ctl_eindex + subtree_count - 1; tree_ctl_eptr = addr (tree_ctl.entries (i)); if tree_ctl_entry.subtree_count = 0 then do; call get_tce_parms; call purge_rcv_entry; if code ^= 0 then if a_code = 0 then do; a_code = code; input_cd.status_key = "20"; end; end; end; /* purge rcv subtree loop */ end; return; /* */ get_tce_parms: proc (); queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex; queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); iocb_ptr = tree_ctl_entry.iocb_ptr; msg_descr = tree_ctl_entry.msg_descr; msg_no = tree_ctl_entry.msg_no; return; end /* get_tce_parms */; /* */ purge_rcv_entry: proc (); if ^tree_ctl_entry.io_in_process_sw then do; code = cmcs_error_table_$no_partial_messages; return; end; /* Move the message from in-process back to available */ call cmcs_status_list_ctl_$move (queue_ctl_eptr, iocb_ptr, addr (msg_descr), 3, 2, code); if code ^= 0 then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to move message (^d in ^a) from status-3 back to status-2. Continuing.", msg_no, tree_ctl_entry.queue_name); call reset_tce_io; return; end /* purge_rcv_entry */; /* */ purge_send_entry: proc (); /* This procedure assumes that tree_ctl_eptr and dest_table_index are correctly set by the caller */ if ^tree_ctl_entry.io_in_process_sw then do; code = cmcs_error_table_$no_partial_messages; return; end; if tree_ctl_entry.partial_in_process_sw then do; tree_ctl_entry.tseg_len = 0; call hcs_$truncate_seg (tree_ctl_entry.tseg_ptr, 0, code); if code ^= 0 then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to truncate the temporary data segment for ^a. Continuing.", tree_ctl_entry.queue_name); tree_ctl_entry.partial_in_process_sw = "0"b; end; /* of partial seg processing */ if tree_ctl_entry.seg_count > 0 then do; /* physical records exist and must be deleted */ call cmcs_status_list_ctl_$delete (queue_ctl_eptr, iocb_ptr, addr (msg_descr), 1, code); if code ^= 0 then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to delete message (^d in ^a) from status-1. Continuing.", msg_no, tree_ctl_entry.queue_name); key_struc.msg_no = msg_no; do seg_no = 1 to tree_ctl_entry.seg_count; key_struc.seg_no = seg_no; key = based_key; /* to keep vfile_ happy */ call iox_$seek_key (iocb_ptr, key, fb21, code); if code ^= 0 then do; call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to seek message segment (^d/^d in ^a) for deletion. Continuing.", msg_no, seg_no, tree_ctl_entry.queue_name); go to end_delete_msg_seg_loop; end; call iox_$delete_record (iocb_ptr, code); if code ^= 0 then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to delete message segment (^d/^d in ^a). Continuing.", msg_no, seg_no, tree_ctl_entry.queue_name); end_delete_msg_seg_loop: end; end; /* seg_count > 0 */ if io_type = 6 & dest_table_index ^= 0 then do; call cmcs_station_ctl_$validate (station_name, station_ctl_eindex, code); /* just to get the entry index */ call cmcs_station_ctl_$output_disabled (station_ctl_eindex, flag, code); if flag then do; code = cmcs_error_table_$dest_disabled; if a_code = 0 then do; a_code = code; output_cd.status_key = "10"; end; output_cd.dest_table (dest_table_index).error_key = "1"; end; end; call reset_tce_io; return; end /* purge_send_entry */; /* */ print: entry (a_input_cdp, a_io_subtype, a_iocb_ptr, a_code); io_type = 7; /* to distinguish from receive in common code */ go to rcv_common; /* */ receive: entry (a_input_cdp, a_io_subtype, a_buffer_ptr, a_buffer_len, a_code); io_type = 2; /* to indicate receive in common code */ rcv_common: /* from here on, receive and print are nearly the same */ /*[4.4-2]*/ call set; if ^rcv_init_sw then do; /* do only 1st time entered */ rcv_descr_ptr = addr (rcv_descr); rcv_vfile_rs_ptr = addr (rcv_vfile_rs); overlay_len = size (rcv_vfile_rs); rcv_vfile_rs_ptr -> overlay (*) = 0; rcv_vfile_rs.version = vfile_rs_version; rcv_vfile_rs.lock_sw, /* locate switch set dynamically */ rcv_vfile_rs.unlock_sw = "0"b; /* We don't need to lock individual records because no two processes will ever be operating on the same message number at the same time. They are locked out at queue_ctl level. */ rcv_init_sw = "1"b; end; /* set basic controls */ input_cdp = a_input_cdp; io_subtype = a_io_subtype; /* First check for ambiguous tree_path. ANSI says that results from the specification of an ambiguous tree path are vendor defined. This implementation defines this situation to be an error. */ call build_queue_table; /* sets tree_ctl_e(index ptr) */ if a_code ^= 0 then return; /* status key already set */ if subtree_count ^= 0 then do; call rcv_check_io_in_process; if a_code ^= 0 then return; /* nonzero is ambiguous_tree_path */ end; else if tree_ctl_entry.io_in_process_sw then do; if io_type ^= tree_ctl_entry.io_type /* don't let them do a receive, for example */ then do; a_code = error_table_$action_not_performed; /*[4.4-6]*/ if ^user_ctl.rec then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to do a receive on tree path ""^a"" when another I/O operation (^d) is already in process. Returning a status key of ""20"".", string (tree_ctl_entry.tree_path), tree_ctl_entry.io_type); input_cd.status_key = "20"; return; end; iocb_ptr = tree_ctl_entry.iocb_ptr; queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex; queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); call rcv_set_type; /* reset the old and set the new */ if io_type = 7 then go to rcv_get_next_seg; /* only for print */ call rcv_set_buffer; go to rcv_copy_seg_data; /* only for receive */ end; /* drop-through means no io_in_process, check first if terminal output disabled */ rcv_find_msg: if user_ctl.terminal_sw then do; call cmcs_station_ctl_$output_disabled (user_ctl.station_ctl_eindex, flag, a_code); if a_code ^= 0 then return; if flag then do; a_code = cmcs_error_table_$dest_disabled; return; end; end; call qc_lock; /* so we can safely acquire a message */ if code ^= 0 then do; /* should never happen */ rcv_lock_err: /*[4.4-6]*/ if ^user_ctl.rec then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Problem locking queue_ctl to receive message. Return to COBOL program with status key of ""20""." ); a_code = code; input_cd.status_key = "20"; return; end; if subtree_count = 0 then do; /* user gave abs_tree_path */ queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex; queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); if queue_ctl_entry.status_list_ctl_entries (2).count = 0 then do; rcv_no_msg: if io_type = 2 & (io_subtype = 3 | io_subtype = 4) then go to rcv_wait_msg; a_code = cmcs_error_table_$no_message; input_cd.status_key = "00"; /* no-message is not an error */ call qc_unlock; return; end; go to rcv_found_msg; end; /* no abs path, must look in entire subtree */ else do; /* queue ctl still locked from above */ do i = 1 to queue_table_len; queue_ctl_eindex = queue_table (i); queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); if queue_ctl_entry.status_list_ctl_entries (2).count ^= 0 then go to rcv_found_msg; end; /* fell through, no messages in the subtree */ go to rcv_no_msg; end; rcv_wait_msg: /* come here to sit and wait */ call qc_unlock; /* don't keep locked or we'll have problems */ on program_interrupt begin; /* interactive user got tired of waiting */ call cmcs_wait_ctl_$delete (user_ctl.wait_ctl_eindex, a_code); a_code = cmcs_error_table_$no_message; input_cd.status_key = "20"; /* we can't say anything more meaningful */ /*[4.4-6]*/ if ^user_ctl.rec then call sub_err_ (a_code, my_name, "h", null (), sub_err_retval, "Program Interrupt occurred while waiting for message. Type ""start"" to return to COBOL program with status key of ""20""."); go to rcv_error_return; end; call cmcs_wait_ctl_$add (string (input_cd.tree_path), user_ctl.wait_ctl_eindex, a_code); /* When we reach here, we either went to sleep and have been awakened with a message, or wait ctl rejected our request to add our entry to its list. */ revert program_interrupt; if a_code ^= 0 then do; /* should never happen */ rcv_error_return: input_cd.status_key = "20"; return; end; /* We had a good sleep and were awakened with a message. Get the info about the message from the wait ctl entry and attempt to get it before someone else does. If we fail, just loop back on the wait again. */ wait_ctl_eindex = user_ctl.wait_ctl_eindex; wait_ctl_eptr = addr (wait_ctl.entries (wait_ctl_eindex)); queue_ctl_eindex = wait_ctl_entry.queue_ctl_eindex; queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); tree_ctl_eindex = wait_ctl_entry.tree_ctl_eindex; tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex)); call qc_lock; if code ^= 0 then go to rcv_lock_err; /* should never happen */ if queue_ctl_entry.status_list_ctl_entries (2).count = 0 then do; /* we missed it */ /*[4.4-6]*/ if ^user_ctl.rec then call sub_err_ (0, my_name, "c", null (), sub_err_retval, "Missed locking record from receive wait. Will wait for another."); go to rcv_wait_msg; /* unlock queue ctl there */ end; /* Getting here means that we actually detected an available msg in queue ctl. Now we must access it to be sure we really did get it. */ call cmcs_wait_ctl_$delete (wait_ctl_eindex, code); if code ^= 0 then do; /*[4.4-6]*/ if ^user_ctl.rec then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Unexpected error code from deleting entry in wait_ctl. Continuing."); end; go to rcv_set_msg_busy; /* all indices and ptrs already set */ rcv_found_msg: /* Getting here means that we found a message without having to wait for it. queue_ctl_eindex and queue_ctl_eptr must have been set already. */ tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex; tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex)); rcv_set_msg_busy: /* the lock, all ptrs, etc, must already be set */ call reset_tce_io; /* start clean */ call open; /* make sure the file is usable */ if code ^= 0 then do; rcv_queue_err: /* should never happen */ /*[4.4-6]*/ if ^user_ctl.rec then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to process queue ""^a"" for receive. Returning to COBOL program with status key of ""20"".", tree_ctl_entry.queue_name); a_code = code; input_cd.status_key = "20"; call qc_unlock; /* ignore error code */ return; end; rcv_descr, tree_ctl_entry.msg_descr = queue_ctl_entry.status_list_ctl_entries (2).f_descr; call cmcs_status_list_ctl_$move (queue_ctl_eptr, iocb_ptr, rcv_descr_ptr, 2, 3, code); /* move msg from available to busy */ if code ^= 0 then go to rcv_queue_err; /* should never happen */ /* The msg is now truly ours. Indicate that I/O is truly in_process and set appropriate control info */ call qc_unlock; /* ignore status */ /* Initialize Message Control Info */ call rcv_set_type; call rcv_seek_descr; /* make msg known to process */ if code ^= 0 then go to rcv_queue_err; /* should never happen */ msg_hdr_ptr, tree_ctl_entry.msg_hdr_ptr = rcv_vfile_rs.rec_ptr; tree_ctl_entry.seg_count = msg_hdr.seg_count; /* don't reference the hdr again until we're thru with it */ tree_ctl_entry.msg_len = msg_hdr.msg_len; /* Set Input CD Info */ input_cd.station_name = msg_hdr.source_station; call cmcs_date_time_ (msg_hdr.clock_available, input_cd.msg_date, input_cd.msg_time); string (input_cd.tree_path) = string (tree_ctl_entry.tree_path); msg_no, tree_ctl_entry.msg_no, key_struc.msg_no = msg_hdr.msg_no; seg_no, tree_ctl_entry.seg_no, key_struc.seg_no = msg_hdr.seg_no; msg_seg_ptr, tree_ctl_entry.msg_seg_ptr = addr (msg_hdr.msg_seg); /* Check for and Initialize Buffer Control */ if io_type = 2 then do; /* it's a rcv request */ call rcv_set_buffer; end; /* Initialize Segment Control */ rcv_set_seg_ctl: tree_ctl_entry.msg_seg_len, tree_ctl_entry.msg_seg_left_len = msg_seg.hdr.seg_len; tree_ctl_entry.msg_seg_left_index = 1; if io_type = 7 then do; /* must be a print request (7) */ call cmcs_print_ (a_iocb_ptr, addr (msg_seg.data.seg_data), msg_seg.hdr.seg_len, addr (msg_seg.hdr.slew_ctl), code); go to rcv_check_for_more_segs; /* ignore return status */ end; /* Processing a receive request instead */ rcv_copy_seg_data: if tree_ctl_entry.msg_seg_left_len = 0 then go to rcv_check_for_more_segs; if tree_ctl_entry.buffer_left_len = 0 then do; /* couldn't use up segment/message */ input_cd.text_len = tree_ctl_entry.buffer_len; input_cd.text_delim = 0; /* more to come */ input_cd.status_key = "00"; a_code = 0; return; end; copy_len = min (tree_ctl_entry.msg_seg_left_len, tree_ctl_entry.buffer_left_len); substr (buffer, tree_ctl_entry.buffer_left_index, copy_len) = substr (msg_seg.data.seg_data, tree_ctl_entry.msg_seg_left_index, copy_len); tree_ctl_entry.msg_seg_left_index = tree_ctl_entry.msg_seg_left_index + copy_len; tree_ctl_entry.msg_seg_left_len = tree_ctl_entry.msg_seg_left_len - copy_len; tree_ctl_entry.buffer_left_index = tree_ctl_entry.buffer_left_index + copy_len; tree_ctl_entry.buffer_left_len = tree_ctl_entry.buffer_left_len - copy_len; go to rcv_copy_seg_data; /* one of the two tests must fail */ rcv_check_for_more_segs: if tree_ctl_entry.seg_count = tree_ctl_entry.seg_no then do; /* no more segs, message is exhausted */ msg_hdr_ptr = tree_ctl_entry.msg_hdr_ptr; msg_hdr.clock_deleted = clock_ (); /* for future statistics */ input_cd.text_delim = msg_hdr.final_delim; input_cd.text_len = tree_ctl_entry.buffer_left_index - 1; tree_ctl_entry.io_in_process_sw = "0"b; rcv_descr = tree_ctl_entry.msg_descr; call qc_lock; if code ^= 0 then go to rcv_queue_err; call cmcs_status_list_ctl_$move (queue_ctl_eptr, tree_ctl_entry.iocb_ptr, rcv_descr_ptr, 3, 4, code); /* move from busy to used */ if code ^= 0 then do; /* should never happen */ /*[4.4-6]*/ if ^user_ctl.rec then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to put msg in ""used"" status list. Continuing."); end; call qc_unlock; /* ignore status */ input_cd.status_key = "00"; a_code = 0; return; end; /* more segs available if we want them */ if tree_ctl_entry.rcv_seg_sw then do; /* just wants one seg at a time */ input_cd.text_delim = 1; /* mark as seg delim */ input_cd.text_len = tree_ctl_entry.buffer_left_index - 1; input_cd.status_key = "00"; a_code = 0; return; end; /* User does want full message instead of just a segment */ rcv_get_next_seg: /* we already know there is one */ seg_no, key_struc.seg_no, tree_ctl_entry.seg_no = tree_ctl_entry.seg_no + 1; msg_no, key_struc.msg_no = tree_ctl_entry.msg_no; call rcv_seek_key; if code ^= 0 then do; /*[4.4-6]*/ if ^user_ctl.rec then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to seek another segment of current message. Returning to COBOL program with status key of ""20""."); a_code = code; input_cd.status_key = "20"; return; end; msg_seg_ptr, tree_ctl_entry.msg_seg_ptr = rcv_vfile_rs.rec_ptr; go to rcv_set_seg_ctl; /* */ rcv_seek_key: proc (); key = based_key; call iox_$seek_key (tree_ctl_entry.iocb_ptr, key, fb21, code); if code ^= 0 then return; rcv_vfile_rs.locate_sw = "0"b; /* use the record found by the seek */ call iox_$control (tree_ctl_entry.iocb_ptr, "record_status", rcv_vfile_rs_ptr, code); if code = 0 then rcv_descr = rcv_vfile_rs.descr; else rcv_descr = zero_descr; return; /* with last code */ end /* rcv_seek_key */; /* */ rcv_seek_descr: proc (); rcv_vfile_rs.descr = rcv_descr; rcv_vfile_rs.locate_sw = "1"b; call iox_$control (tree_ctl_entry.iocb_ptr, "record_status", rcv_vfile_rs_ptr, code); return; end /* rcv_seek_descr */; /* */ rcv_check_io_in_process: proc (); /* Assumes that tree_ctl_entry is set to starting node of subtree to be checked, and that subtree_count, always non_zero, includes the starting node. Both get set in call to build_queue_table. This procedure leaves the tree_ctl_eindex and tree_ctl_eptr intact with their original values upon exit. */ do i = tree_ctl_eindex + 1 to tree_ctl_eindex + subtree_count; /* we know the top node is not a queue */ tree_ctl_eptr = addr (tree_ctl.entries (i)); if tree_ctl_entry.subtree_count = 0 /* first find an entry for a queue */ then if tree_ctl_entry.io_in_process_sw then if tree_ctl_entry.io_type = 2 | tree_ctl_entry.io_type = 7 then do; a_code = cmcs_error_table_$ambiguous_tree_path; input_cd.status_key = "20"; return; end; end; tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex)); /* restore to original value just in case */ a_code = 0; return; end /* rcv_check_io_in_process */; /* */ build_queue_table: proc (); /* If subtree_count = 0, then tree_ctl_eindex and tree_ctl_eptr are set. Otherwise not. */ if ^init_queue_table_sw then do; allocate queue_table_struc; init_queue_table_sw = "1"b; end; call cmcs_tree_ctl_$find_tree_path (input_cdp, tree_ctl_eindex, subtree_count, tree_ctl_eptr, a_code); if a_code ^= 0 then do; input_cd.status_key = "20"; return; end; if subtree_count = 0 then do; /* we hit a queue entry all by itself */ queue_table_len = 1; queue_table (1) = tree_ctl.entries (tree_ctl_eindex).queue_ctl_eindex; return; end; else do; queue_table_len = 0; do i = tree_ctl_eindex + 1 to tree_ctl_eindex + subtree_count; tree_ctl_eptr = addr (tree_ctl.entries (i)); if tree_ctl_entry.subtree_count = 0 then do; /* found a queue entry */ queue_table_len = queue_table_len + 1; queue_table (queue_table_len) = tree_ctl_entry.queue_ctl_eindex; end; end; end; return; end /* build_queue_table */; /* */ rcv_set_type: proc (); string (tree_ctl_entry.io_flags) = (36)"0"b; tree_ctl_entry.io_in_process_sw = "1"b; tree_ctl_entry.io_type = io_type; tree_ctl_entry.io_subtype = io_subtype; if io_type = 2 then if io_subtype = 3 | io_subtype = 4 then tree_ctl_entry.rcv_wait_sw = "1"b; tree_ctl_entry.rcv_seg_sw, tree_ctl_entry.rcv_msg_sw = "0"b; /* init both to false and then set one true */ if io_subtype = 1 | io_subtype = 3 then tree_ctl_entry.rcv_seg_sw = "1"b; /* print subtype 1 and rcv subtype 1 are the same */ else tree_ctl_entry.rcv_msg_sw = "1"b; return; end /* rcv_set_type */; /* */ rcv_set_buffer: proc (); buffer_ptr = a_buffer_ptr; buffer_len, tree_ctl_entry.buffer_len, tree_ctl_entry.buffer_left_len = a_buffer_len; buffer_left_index, tree_ctl_entry.buffer_left_index = 1; end /* rcv_set_buffer */; /* */ send: entry (a_output_cdp, a_io_subtype, a_buffer_ptr, a_buffer_len, a_station_count, a_slew_ctl, a_code); /*[4.4-2]*/ call set; if ^send_init_sw then call send_init; /* from now on, a_code gets set only with the first non-zero status code returned */ output_cdp = a_output_cdp; io_type = 1; new_status, io_subtype = a_io_subtype; /* get old status later from tree_ctl_entry */ if new_status = 3 then new_status = 2; /* EMI and EGI are the same for us */ buffer_ptr = a_buffer_ptr; buffer_len = a_buffer_len; station_count = a_station_count; call send_check_slew; if a_code ^= 0 then do; output_cd.status_key = "60"; /* indicates no action taken */ return; end; /* No other checks needed here because cobol_mcs_ has already verified text-len, max-text-len, station-count, and max-station-count. */ output_cd.status_key = "00"; /* start clean, change only on first error */ /* The BIG Loop! The loop processes the message data for each destination (station) in the output_cd. It is possible, and legal, for the various destinations to have different statuses. That is, the message could be the first piece of a message for one destination and the middle piece for another destination. Thus, each station must be handled independently from the others. */ /* Note: To keep the do/end code from nesting too deeply, gotos are used in the outer controls */ do dest_table_index = 1 to station_count; /* cobol_mcs_ ensures count of at least 1 */ station_name = output_cd.dest_table (dest_table_index).station_name; /*[4.4-3]*/ call cmcs_station_ctl_$find_destination (station_name, station_ctl_eindex, station_ctl_eptr, code); call cmcs_tree_ctl_$find_destination (station_name, tree_ctl_eindex, tree_ctl_eptr, code); if code ^= 0 then do; if a_code = 0 then do; /* always report the first error encountered */ a_code = code; output_cd.status_key = "20"; end; output_cd.dest_table (dest_table_index).error_key = "1"; /*[4.4-3]*/ return; end; output_cd.dest_table (dest_table_index).error_key = "0"; /* initialize to good now, reset only on error */ queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex; tree_ctl_entry.queue_ctl_eptr, queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); if tree_ctl_entry.io_in_process_sw then do; if tree_ctl_entry.io_type > 1 then call E9; msg_hdr_ptr = tree_ctl_entry.msg_hdr_ptr; old_status = tree_ctl_entry.io_subtype; /* always 0 or 1 */ end; else do; call reset_tce_io; /* reset message dep params */ tree_ctl_entry.io_type = 1; /* send */ old_status = 0; /* for use in key computation */ end; call test_subtype; /*[4.4-4]*/ call set_new_status; /* 0(partial), 1(esi), 2(emi,egi) */ send_loop_end: /* set/reset io_in_process_sw. Only if there are no errors and the message is still not completed (just 0/EsI delim), will we set the busy switch. All other cases force it to be reset. This can cause garbage pieces (segments), to be left in the file. These can be cleaned up later with the cobol_mcs_admin request of purge_queues. At a later time, we may do dynamic purging. */ if (new_status ^= 2 & output_cd.dest_table (dest_table_index).error_key ^= "1") then tree_ctl_entry.io_in_process_sw = "1"b; /* set busy only if no errors and not (EMI or EGI) */ else tree_ctl_entry.io_in_process_sw = "0"b; /* force reset, for subsequent I/O */ end; return; test_subtype: proc; if io_subtype = 0 then call send_partial; else call send_non_partial; /* esi,emi,egi */ end; E1: proc; /* queue was disabled */ a_code = code; output_cd.status_key = "10"; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; E2: proc; /* output terminal was disabled */ a_code = code; output_cd.status_key = "10"; output_cd.dest_table (dest_table_index).error_key = "1"; /*[4.4-3]*/ /*go to send_loop_end;*/ end; E3: proc; /* input terminal was disabled */ if a_code = 0 then do; a_code = code; output_cd.status_key = "20"; /* for lack of a better status key */ end; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; E4: proc; /* check status after send_get_key */ call sub_err_ (code, my_name, "c", sub_err_retval, "Attempting to lock queue_ctl to get message number for ""^a"".", station_name); if a_code = 0 then do; a_code = code; output_cd.status_key = "50"; end; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; E5: proc; /* check status after open */ call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to open queue for message to ""^a"".", station_name); if a_code = 0 then do; a_code = code; output_cd.status_key = "20"; end; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; E6: proc; /* check status after send_seek_key */ call sub_err_ (code, my_name, "c", sub_err_retval, "Attempting to seek space for message to ""^a"".", station_name); if a_code = 0 then do; a_code = code; output_cd.status_key = "20"; end; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; E8: proc; /* check status after qc_lock, cmcs_status_list_ctl$(move,add) */ call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to add message for ""^a"" to status list. Contact CMCS Administrator. Continuing.", tree_ctl_entry.queue_name); if a_code = 0 then do; a_code = cmcs_error_table_$bad_dest; output_cd.status_key = "20"; end; output_cd.dest_table (dest_table_index).error_key = "1"; end; E9: proc; call sub_err_ (error_table_$action_not_performed, my_name, "c", null (), sub_err_retval, "Attempting to perform send to ""^a"" while other I/O in process.", station_name); if a_code = 0 then do; a_code = cmcs_error_table_$bad_dest; output_cd.status_key = "20"; end; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; E10: proc; /* check status in send_append_tag */ code = cmcs_error_table_$bad_message_length; call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Maximum size exceeded for partial message to ""^a"".", station_name); if a_code = 0 then do; a_code = code; output_cd.status_key = "20"; end; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; E11: proc; /* check status after get_temp_segments */ call sub_err_ (code, my_name, "s", null (), sub_err_retval, "Attempting to get temp seg for send to ""^a"". Contact CMCS Administrator.", station_name); if a_code = 0 then do; a_code = code; output_cd.status_key = "20"; end; output_cd.dest_table (dest_table_index).error_key = "1"; go to send_loop_end; end; send_partial: proc; if tree_ctl_entry.tseg_ptr = null () then do; /* allocate one temp seg */ call get_temp_segments_ (my_name, ptr_array, code); if code ^= 0 then call E11; tseg_ptr, tree_ctl_entry.tseg_ptr = ptr_array (1); tseg_len, tree_ctl_entry.tseg_len = 0; end; else do; tseg_ptr = tree_ctl_entry.tseg_ptr; tseg_len = tree_ctl_entry.tseg_len; end; if tree_ctl_entry.tseg_len + buffer_len > tseg_max_len then call E10; /* exceeded implementation limit for msg seg size */ substr (tseg, tseg_len + 1, buffer_len) = substr (buffer, 1, buffer_len); /* copy data to temp seg */ tree_ctl_entry.tseg_len = tree_ctl_entry.tseg_len + buffer_len; tree_ctl_entry.partial_in_process_sw = "1"b; end; send_non_partial: proc; /* send delim ^= 0 */ if user_ctl.terminal_sw then do; /* terminals are restricted, mp's aren't */ if ^tree_ctl_entry.io_in_process_sw /* check only for brand-new messages */ then do; /* once they are started, it's ok */ if queue_ctl_entry.input_disabled_sw then do; /* can't let them through */ code = cmcs_error_table_$queue_disabled; if a_code = 0 then call E1; end; if station_ctl_entry.output_disabled_sw then do; code = cmcs_error_table_$dest_disabled; if a_code = 0 then call E2; end; call cmcs_station_ctl_$input_disabled (user_ctl.station_ctl_eindex, flag, code); if code ^= 0 then call E3; if flag then do; code = cmcs_error_table_$source_disabled; call E3; end; end; end; call send_get_key; if code ^= 0 then call E4; call open; /* be sure we have a good IO switch */ if code ^= 0 then call E5; if tree_ctl_entry.seg_no = 1 then seek_len = msg_hdr_len + msg_seg_hdr_len; else seek_len = msg_seg_hdr_len; seek_len = 4 * seek_len + buffer_len; if tree_ctl_entry.partial_in_process_sw then seek_len = seek_len + tree_ctl_entry.tseg_len; call send_seek_key; if code ^= 0 then call E6; tree_ctl_entry.seg_count = seg_no; /* so we know how many we have altogether */ if tree_ctl_entry.seg_no = 1 then do; /* first segment of message */ msg_hdr_ptr, tree_ctl_entry.msg_hdr_ptr = send_vfile_rs.rec_ptr; call send_fillin_msg_hdr; tree_ctl_entry.msg_descr = send_vfile_rs.descr; /* will be needed later for changing status */ msg_seg_ptr, tree_ctl_entry.msg_seg_ptr = addr (msg_hdr.msg_seg); end; else do; /* not the first segment of the message */ msg_seg_ptr, tree_ctl_entry.msg_seg_ptr = send_vfile_rs.rec_ptr; tree_ctl_entry.msg_seg_descr = send_vfile_rs.descr; /* may be useful sometime, but not now */ end; call send_fillin_seg_hdr; /* then copy the real data */ if ^tree_ctl_entry.partial_in_process_sw then substr (msg_seg.data.seg_data, 1, buffer_len) = substr (buffer, 1, buffer_len); else do; /* do a gather-copy of the tseg and a_buffer */ tseg_ptr = tree_ctl_entry.tseg_ptr; tseg_len = tree_ctl_entry.tseg_len; msg_seg.hdr.seg_len = msg_seg.hdr.seg_len + 1; substr (msg_seg.data.seg_data, 1, tseg_len) = substr (tseg, 1, tseg_len); /* part 1 */ substr (msg_seg.data.seg_data, tseg_len + 1, 1) = " "; substr (msg_seg.data.seg_data, tseg_len + 2, buffer_len) = substr (buffer, 1, buffer_len); /* part 2 */ tree_ctl_entry.partial_in_process_sw = "0"b; tree_ctl_entry.tseg_len = 0; end; if new_status = 2 then do; /* this is the latest possible moment to set this info */ msg_hdr.clock_available = clock_ (); msg_hdr.source_station = user_ctl.station_name; msg_hdr.source_group_id = get_group_id_ (); msg_hdr.msg_len = tree_ctl_entry.msg_len; msg_hdr.final_delim = io_subtype; /* EMI or EGI */ msg_hdr.seg_count = tree_ctl_entry.seg_count; end; call qc_lock; /* ipc_$wakeup called herein */ if code ^= 0 then call E8; else do; if new_status = 2 & old_status = 1 then call cmcs_status_list_ctl_$move (queue_ctl_eptr, iocb_ptr, addr (tree_ctl_entry.msg_descr), old_status, new_status, code); else call cmcs_status_list_ctl_$add (queue_ctl_eptr, iocb_ptr, addr (tree_ctl_entry.msg_descr), new_status, code); if code ^= 0 then call E8; end; call qc_unlock; /* ignore return status */ end; /* */ send_check_slew: proc (); slew_ctl_ptr = addr (a_slew_ctl); /* for overlay processing */ if a_slew_ctl = 0 then do; /* when = 0, what = 0, how_much = 0 */ ret_good_slew: a_code = 0; return; end; else if slew_ctl.when = 0 then do; ret_bad_slew: a_code = cmcs_error_table_$bad_slew; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "From check of the slew control. The slew control supplied is: when (^d), what (^d), how much (^d). Error keys set for all destinations.", slew_ctl.when, slew_ctl.what, slew_ctl.how_much); output_cd.status_key = "20"; do i = 1 to station_count; output_cd.dest_table (i).error_key = "1"; end; return; end; else if slew_ctl.when < 0 | slew_ctl.when > 2 then go to ret_bad_slew; if slew_ctl.what < 0 | slew_ctl.what > 3 then go to ret_bad_slew; if slew_ctl.what = 1 then if slew_ctl.how_much < 0 | slew_ctl.how_much > 128 then go to ret_bad_slew; else ; else if slew_ctl.what = 2 then slew_ctl.how_much = 0; /*[4.4-1]*/ else if slew_ctl.what = 3 then if slew_ctl.how_much < 1 | slew_ctl.how_much > 16 then go to ret_bad_slew; go to ret_good_slew; end /* send_check_slew */; /* */ send_init: proc (); send_vfile_rs_ptr = addr (send_vfile_rs); overlay_len = size (send_vfile_rs); send_vfile_rs_ptr -> overlay (*) = 0; send_vfile_rs.version = vfile_rs_version; send_vfile_rs.create_sw = "1"b; /* send will always create new records */ send_init_sw = "1"b; return; end /* send_init */; /* */ send_seek_key: proc (); send_vfile_rs.rec_len, send_vfile_rs.max_rec_len = seek_len + 8; /* to give space for vfile lockword, if needed */ key = based_key; /* for vfile_ char (256) var key */ call iox_$seek_key (iocb_ptr, key, fb21, code); if code = 0 then do; /* must never happen, should always be not_found */ code = error_table_$bad_new_key; return; end; else if code ^= error_table_$no_record then return; /* Seek OK, now create new space */ call iox_$control (iocb_ptr, "record_status", addr (send_vfile_rs), code); return; end /* send_seek_key */; /* */ send_fillin_msg_hdr: proc (); overlay_len = msg_hdr_len; msg_hdr_ptr -> overlay (*) = 0; /* erase any existing garbage */ msg_hdr.lockword = get_process_id_ (); /* temporary id of author */ msg_hdr.version = msg_hdr_version; msg_hdr.source_station = user_ctl.station_name; msg_hdr.msg_no = tree_ctl_entry.msg_no; msg_hdr.seg_no = 1; /* always 1 in the msg_hdr */ msg_hdr.seg_count = -1; /* don't have a good number yet */ msg_hdr.msg_status = new_status; msg_hdr.final_delim = io_subtype; /* can only be 1-3 */ return; end /* send_fillin_msg_hdr */; /* */ send_fillin_seg_hdr: proc (); msg_seg.hdr.msg_no = tree_ctl_entry.msg_no; msg_seg.hdr.seg_no = tree_ctl_entry.seg_no; msg_seg.hdr.slew_ctl = a_slew_ctl; if ^tree_ctl_entry.partial_in_process_sw then msg_seg.hdr.seg_len = buffer_len; else msg_seg.hdr.seg_len = buffer_len + tree_ctl_entry.tseg_len; tree_ctl_entry.msg_len = tree_ctl_entry.msg_len + msg_seg.hdr.seg_len; tree_ctl_entry.seg_count = tree_ctl_entry.seg_no; /* may need in case of purge */ return; end /* send_fillin_seg_hdr */; /* */ reset_tce_io: proc; /* Procedure to reset all message dependent parameters */ /* tree_ctl_eptr must be set to the tree_ctl_entry to be reset */ string (tree_ctl_entry.io_flags) = (36)"0"b; tree_ctl_entry.msg_hdr_ptr = null (); tree_ctl_entry.io_type = 0; tree_ctl_entry.io_subtype = 0; string (tree_ctl_entry.io_flags) = (36)"0"b; tree_ctl_entry.seg_count = 0; tree_ctl_entry.msg_len = 0; tree_ctl_entry.msg_descr = zero_descr; tree_ctl_entry.msg_no = 0; tree_ctl_entry.seg_no = 0; tree_ctl_entry.tseg_len = 0; tree_ctl_entry.msg_seg_ptr = null (); tree_ctl_entry.msg_seg_descr = zero_descr; tree_ctl_entry.msg_seg_len = 0; tree_ctl_entry.msg_seg_left_index = 0; tree_ctl_entry.msg_seg_left_len = 0; tree_ctl_entry.buffer_len = 0; tree_ctl_entry.buffer_left_index = 0; tree_ctl_entry.buffer_left_len = 0; return; end /* reset_tce_io */; /* */ open: proc (); queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex; queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); if tree_ctl_entry.vfile_status = 2 then do; /* already open */ iocb_ptr = tree_ctl_entry.iocb_ptr; code = 0; return; end; else if tree_ctl_entry.vfile_status = 0 then do; /* brand new use */ iox_attach: switch_no = switch_no + 1; /* build "unique" switch name */ switch_pic = switch_no; tree_ctl_entry.switch_name = rtrim (tree_ctl_entry.queue_name) || "." || switch_pic; /* aaa.nn */ call ioa_$rsnnl ("vfile_ ^a>^a -share ^d -old", attach_descr, attach_descr_len, user_ctl.cmcs_dir, queue_ctl_entry.queue_name, system_ctl.lock_wait_time); /* q name already has suffix */ call iox_$attach_name (tree_ctl_entry.switch_name, iocb_ptr, substr (attach_descr, 1, attach_descr_len), null (), code); if code ^= 0 then return; tree_ctl_entry.vfile_status = 1; /* log in case of trouble */ iox_open: call iox_$open (iocb_ptr, 13, "0"b, code); /* 13 = direct_update */ if code ^= 0 then return; call iox_$control (iocb_ptr, "min_block_size", addr (min_blksz_info), code); if code ^= 0 then do; call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to perform min_block_size control order for queue ^a (switch ^a). Continuing.", tree_ctl_entry.queue_name, tree_ctl_entry.switch_name); end; tree_ctl_entry.vfile_status = 2; tree_ctl_entry.iocb_ptr = iocb_ptr; end; else if tree_ctl_entry.vfile_status = 1 then go to iox_open; else do; /* unrecognized vfile status */ code = error_table_$not_open; end; return; end /* open */; /* */ close: proc (); /* This procedure assumes that tree_ctl_eptr is set to the entry to be closed. */ if tree_ctl_entry.vfile_status > 0 then do; if tree_ctl_entry.vfile_status = 2 then do; call iox_$close (tree_ctl_entry.iocb_ptr, code); if code ^= 0 then do; close_err: call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to close the ^a queue.", tree_ctl_entry.queue_name); return; end; tree_ctl_entry.vfile_status = 1; end; call iox_$detach_iocb (tree_ctl_entry.iocb_ptr, code); if code ^= 0 then go to close_err; tree_ctl_entry.iocb_ptr = null (); tree_ctl_entry.vfile_status = 0; end; else if tree_ctl_entry.iocb_ptr ^= null () then do; code = cmcs_error_table_$bad_call_parm; call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Inconsistent vfile_ status for queue ^a (switch ^a). File closed.", tree_ctl_entry.queue_name, tree_ctl_entry.switch_name); call iox_$close (tree_ctl_entry.iocb_ptr, code); /* ignore return */ call iox_$detach_iocb (tree_ctl_entry.iocb_ptr, code); /* ignore return */ tree_ctl_entry.iocb_ptr = null (); tree_ctl_entry.vfile_status = 0; end; else code = 0; if tree_ctl_entry.tseg_ptr ^= null () then do; ptr_array (1) = tree_ctl_entry.tseg_ptr; call release_temp_segments_ (my_name, ptr_array, code); if code ^= 0 then do; call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to release temporary buffer segment for ^a. Continuing.", tree_ctl_entry.queue_name); code = 0; end; end; return; end /* close */; /* */ send_get_key: proc (); if tree_ctl_entry.msg_no = 0 then do; /* 1st segment of new msg */ /*[5.3-1]*/ call cmcs_set_lock_$lock (queue_ctl.hdr.lockword, system_ctl.lock_wait_time, code); if code ^= 0 then return; queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex; queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); msg_no, tree_ctl_entry.msg_no, key_struc.msg_no, queue_ctl_entry.msg_no = queue_ctl_entry.msg_no + 1; /* update all related fields at once */ call cmcs_set_lock_$unlock (queue_ctl.hdr.lockword, code); if code ^= 0 then do; /* also should never happen */ call sub_err_ (code, my_name, "c", sub_err_retval, "From attempt to unlock queue_ctl for ""^a"".", station_name); code = 0; end; seg_no, key_struc.seg_no, tree_ctl_entry.seg_no = 1; /* starting fresh msg always uses segno of 1 */ end; else do; /* msgno already exists, just bump the segno */ msg_no, key_struc.msg_no = tree_ctl_entry.msg_no; seg_no, key_struc.seg_no, tree_ctl_entry.seg_no = tree_ctl_entry.seg_no + 1; end; return; end /* send_get_key */; /* */ setup: proc; if ^(external_user_ctl_ptr -> user_ctl.init_sw.queue_ctl) then do; user_ctl_ptr = external_user_ctl_ptr; /* set local variable from global */ queue_ctl_ptr = user_ctl.queue_ctl_ptr; system_ctl_ptr = user_ctl.system_ctl_ptr; tree_ctl_ptr = user_ctl.tree_ctl_ptr; wait_ctl_ptr = user_ctl.wait_ctl_ptr; end; /* The following code initializes the data for the vfile_ control "min_block_size". This control ensures at least 8 extra characters will be left for the vfile record lockword. */ min_blksz_info.min_residue = 8; min_blksz_info.min_capacity = 8; zero_descr_ptr = addr (zero); /* for assignments of "null" descriptors */ user_ctl.init_sw.queue_ctl = "1"b; a_code = 0; return; end /* setup */; test: entry (); test_sw = "1"b; return; /* */ qc_lock: proc (); /*[5.3-1]*/ call cmcs_set_lock_$lock (queue_ctl.hdr.lockword, system_ctl.lock_wait_time, code); if code ^= 0 then do; call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to lock queue_ctl."); end; return; end /* qc_lock */; /* */ qc_unlock: proc (); call cmcs_set_lock_$unlock (queue_ctl.hdr.lockword, code); return; end /* qc_unlock */; set_new_status: proc; /*[4.4-4]*/ new_status, io_subtype, tree_ctl_entry.io_subtype = a_io_subtype; /*[4.4-4]*/ if new_status = 3 then new_status = 2; /* egi = emi */ end; end /* cmcs_queue_ctl_ */;  cmcs_scramble_.pl1 05/24/89 1047.9rew 05/24/89 0836.4 30357 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_scramble_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_scramble_: proc (arg) returns (char (10) aligned); /* COBOL MCS subroutine directly adapted from the scramble_ routine in tools to handle 10 character passwords */ /* Bob May, 6/30/77 */ /* SCRAMBLE_ - Scramble a char (10) string. This procedure, given a password as input, returns a 10-character output string which: 1. bears some relationship to the input 2. loses some information - some passwords may scramble to the same value 3. has no obvious relation to the input ("aaaaaaaa" and "aaaaaaab" . scramble to noticeably different values.) Passwords stored in system files are scrambled, so that if anyone gets a dump of the password file by accident, it won't do him much good. The transform is supposed to be non-invertible. A previous version of this program had two defects: 1) It was invertible, as Steve Lipner demonstrated. 2) It depended on double-precision MOD and MULTIPLY. These turned out . to have been incorrectly implemented by PL/I and so the scramble, . while good, would have given different values if the bugs were fixed. Method: 1. strip the two high-order bits of each ASCII character, packing to the right. 2. treat the resulting 70-bit quantity as both key and cipher text for . the system enciphering program. 3. destroy selected bits of the resulting cipher. Revised 5/21/73, THVV, for new algorithm. THVV 10/30/71 */ dcl arg char (10) aligned; dcl temp char (10), temp1 (1) fixed bin (71), temp2 (1) fixed bin (71), (p1, p2, p3) ptr, /* ptrs to based overlays */ (i, k) fixed bin; dcl bbt bit (72) aligned based (p1), b72 bit (72) aligned based (p3), bc10 char (10) aligned based (p3); dcl 1 tsx based (p2) aligned, 2 pad bit (2) unal, 2 z (8) bit (7) unal; dcl encipher_ entry (fixed bin (71), dim (*) fixed bin (71), dim (*) fixed bin (71), fixed bin); dcl (addr, fixed, mod, substr) builtin; /* ------------------------------------------------------- */ temp = arg; /* copy argument */ p1 = addr (temp); p2 = addr (temp1 (1)); p3 = addr (temp2 (1)); temp1 (1) = 0; k = 1; do i = 3 to 90 by 9; z (k) = substr (bbt, i, 7); /* squeeze out always-zero bits */ k = k + 1; end; temp = ""; /* Erase temporary copy */ call encipher_ (temp1 (1), temp1, temp2, 1); /* Encipher the password. */ temp1 (1) = 0; /* Tidy up */ b72 = b72 & "111111110111111110111111110111111110111111110111111110111111110111111110"b; return (bc10); end /* cmcs_scramble_ */;  cmcs_set_lock_.pl1 05/24/89 1047.9rew 05/24/89 0834.0 23895 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8087), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8087 cmcs_set_lock_.pl1 Shorten wait time for cmcs_station_ctl_. END HISTORY COMMENTS */ /* Modified on 10/20/84 by FCH, [5.3-1], BUG565(phx18385), wait time for set_lock_$lock */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_set_lock_: proc; return; /* invalid entry point */ /* This COBOL MCS subroutine is used to mask all IPS interrupts and then lock the specified lock. In the reverse, it will unlock the lock and then umask the IPS interrupts. */ /* Bob May, 6/30/77 */ /* hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned), hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned), */ dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)), set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl error_table_$invalid_lock_reset fixed bin (35) external; dcl (mask, oldmask) bit (36) aligned, lockword bit (36) aligned; dcl code fixed bin (35); /* */ %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_system_ctl; %include cmcs_user_ctl; /* */ lock: entry (a_lockword, time, a_code); dcl a_lockword bit (36) aligned, a_code fixed bin (35); /*[5.3-1]*/ dcl time fixed bin; if ^(external_user_ctl_ptr -> user_ctl.init_sw.set_lock) then do; call setup; if a_code ^= 0 then return; end; /*[5.3-1]*/ call set_lock_$lock (a_lockword, time, a_code); if a_code ^= 0 then if a_code = error_table_$invalid_lock_reset then a_code = 0; return; unlock: entry (a_lockword, a_code); if ^(external_user_ctl_ptr -> user_ctl.init_sw.set_lock) then do; call setup; if a_code ^= 0 then return; end; call set_lock_$unlock (a_lockword, a_code); return; setup: proc; user_ctl_ptr = external_user_ctl_ptr; /* set local variable from global */ system_ctl_ptr = user_ctl.system_ctl_ptr; user_ctl.init_sw.set_lock = "1"b; a_code = 0; return; end /* setup */; end /* cmcs_set_lock_ */;  cmcs_station_ctl_.pl1 05/24/89 1047.9rew 05/24/89 0834.0 92916 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8087), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8087 cmcs_station_ctl_.pl1 Shorten wait time for cmcs_station_ctl_. END HISTORY COMMENTS */ /* Modified on 10/20/84 by FCH, [5.3-1], BUG565(phx18385), wait time for set_lock_$lock */ /* Modified on 03/18/82 by FCH, [5.2-1], [4.4-4] was a disaster, BUG530 */ /* Modified on 06/08/81 by FCH, [4.4-5], code "20" not returned, BUG468 */ /* Modified on 05/12/81 by FCH, [4.4-4], zero deley if station in use, BUG468 */ /* Modified on 04/29/81 by FCH, [4.4-3], entry find_destination added, BUG468 */ /* Modified on 04/23/81 by FCH, [4.4-2], check destination count for legality, BUG468 */ /* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_station_ctl_: proc; /* COBOL MCS subroutine to manage stations for enable and disable functions. */ /* Note: The disable/enable entrypoints all accept a char (10) password string. This string is ignored because it was already checked by cobol_mcs_. Current ANSI rules on the use of multiple passwords for CMCS terminals and queues is unclear and requests for clarification have been submitted. Until the clarification is issued, this implementation will use a single password. Thus, cobol_mcs_ can do the checking for everybody. */ /* Bob May, 6/01/77 */ return; /* bad entry point */ dcl i fixed bin, my_name char (17) init ("cmcs_station_ctl_"); dcl com_err_ entry options (variable); dcl a_station_name char (12), a_station_ctl_eptr ptr, a_station_ctl_eindex fixed bin, a_input_cdp ptr, a_output_cdp ptr, a_station_output_cdp, a_password char (10), a_flag bit (1), a_code fixed bin (35); /*[4.4-4]*/ declare save_lwt fixed bin; dcl x_station_name char (12), station_count fixed bin; /* converted from char data */ dcl (error_table_$invalid_lock_reset) fixed bin (35) external; dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)), set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl (addr, null) builtin; /* */ %include cmcs_cd_dcls; %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_error_table_dcls; %include cmcs_station_ctl; %include cmcs_system_ctl; %include cmcs_user_ctl; /* */ validate: entry (a_station_name, a_station_ctl_eindex, a_code); /*[4.4-1]*/ call setup; call find_station (a_station_name); if a_code ^= 0 then a_station_ctl_eindex = 0; else a_station_ctl_eindex = station_ctl_eindex; return; /* end validate entrypoint */ attach: entry (a_station_name, a_station_ctl_eindex, a_code); /*[4.4-1]*/ call setup; call find_station (a_station_name); if a_code ^= 0 then return; /*[5.2-1]*/ /*save_lwt = system_ctl.lock_wait_time*/ /*[5.2-1]*/ /*system_ctl.lock_wait_time = 0;*/ call lock_station; /*[5.2-1]*/ /*system_ctl.lock_wait_time = save_lwt;*/ if a_code = 0 then a_station_ctl_eindex = station_ctl_eindex; /* went fine, give it to user */ else a_station_ctl_eindex = 0; /* if used, will blow */ user_ctl.station_name = a_station_name; return; /* */ detach: entry (a_station_ctl_eindex, a_code); /*[4.4-1]*/ call setup; station_ctl_eindex = a_station_ctl_eindex; station_ctl_eptr = addr (station_ctl.entries (station_ctl_eindex)); call unlock_station; if a_code = 0 then user_ctl.station_name = ""; return; /* */ detach_name: entry (a_station_name, a_code); /*[4.4-1]*/ call setup; call find_station (a_station_name); if a_code ^= 0 then return; call unlock_station; if a_code = 0 then user_ctl.station_name = ""; user_ctl.station_name = ""; return; /* */ disable_input_terminal: entry (a_input_cdp, a_password, a_code); /*[4.4-1]*/ call setup; input_cdp = a_input_cdp; x_station_name = input_cd.station_name; call find_station (x_station_name); if a_code ^= 0 then do; input_cd.status_key = "20"; return; end; if station_ctl_entry.input_disabled_sw then a_code = cmcs_error_table_$source_already_disabled; else do; station_ctl_entry.input_disabled_sw = "1"b; a_code = 0; end; input_cd.status_key = "00"; return; /* */ enable_input_terminal: entry (a_input_cdp, a_password, a_code); /*[4.4-1]*/ call setup; input_cdp = a_input_cdp; x_station_name = input_cd.station_name; call find_station (x_station_name); /*[4.4-5]*/ if a_code ^= 0 /*[4.4-5]*/ then do; input_cd.status_key = "20"; /*[4.4-5]*/ return; /*[4.4-5]*/ end; if ^station_ctl_entry.input_disabled_sw then a_code = cmcs_error_table_$source_already_enabled; else do; station_ctl_entry.input_disabled_sw = "0"b; a_code = 0; end; input_cd.status_key = "00"; return; /* */ disable_output_terminal: entry (a_output_cdp, a_password, a_code); /*[4.4-1]*/ call setup; output_cdp = a_output_cdp; if output_cdp ^= null () then do; /* process the supplied list */ output_cd.status_key = "00"; /* init to 00 is changed if any problem */ station_count = output_cd.station_count;/* convert from char data */ /*[4.4-2]*/ if station_count = 0 | station_count > output_cd.bin_max_station_count /*[4.4-2]*/ then output_cd.status_key = "30"; /*[4.4-2]*/ else do i = 1 to station_count; x_station_name = output_cd.station_name (i); call find_station (x_station_name); if a_code ^= 0 then do; output_cd.error_key (i) = "1"; output_cd.status_key = "20"; end; else output_cd.error_key (i) = "0"; if station_ctl_entry.output_disabled_sw then a_code = cmcs_error_table_$dest_already_disabled; else do; station_ctl_entry.output_disabled_sw = "1"b; a_code = 0; end; end; end; /* null output_cdp, do them all and ignore status key */ else do; do i = 1 to station_ctl.current_size; if ^station_ctl.entries (i).inactive_sw then station_ctl.entries (i).output_disabled_sw = "1"b; /* ignore previous state */ end; a_code = 0; end; return; /* */ enable_output_terminal: entry (a_output_cdp, a_password, a_code); /*[4.4-1]*/ call setup; output_cdp = a_output_cdp; if output_cdp ^= null () then do; /* process the supplied list */ output_cd.status_key = "00"; /* init to 00 is changed if any problem */ station_count = output_cd.station_count;/* convert from char data */ /*[4.4-2]*/ if station_count = 0 | station_count > output_cd.bin_max_station_count /*[4.4-2]*/ then output_cd.status_key = "30"; /*{4.4-2]*/ else do i = 1 to station_count; x_station_name = output_cd.station_name (i); call find_station (x_station_name); if a_code ^= 0 then do; output_cd.error_key (i) = "1"; output_cd.status_key = "20"; end; else output_cd.error_key (i) = "0"; if ^station_ctl_entry.output_disabled_sw then a_code = cmcs_error_table_$dest_already_enabled; else do; station_ctl_entry.output_disabled_sw = "0"b; a_code = 0; end; end; end; /* null output_cdp, do them all and ignore status key */ else do; do i = 1 to station_ctl.current_size; if ^station_ctl.entries (i).inactive_sw then station_ctl.entries (i).output_disabled_sw = "0"b; /* ignore previous state */ end; a_code = 0; end; return; /* */ input_disabled: entry (a_station_ctl_eindex, a_flag, a_code); /*[4.4-1]*/ call setup; station_ctl_eptr = addr (station_ctl.entries (a_station_ctl_eindex)); a_flag = station_ctl_entry.input_disabled_sw; a_code = 0; return; /* */ output_disabled: entry (a_station_ctl_eindex, a_flag, a_code); /*[4.4-1]*/ call setup; station_ctl_eptr = addr (station_ctl.entries (a_station_ctl_eindex)); a_flag = station_ctl_entry.output_disabled_sw; a_code = 0; return; /* */ setup: proc; /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.station_ctl) /*[4.4-1]*/ then do; user_ctl_ptr = external_user_ctl_ptr; /* set local variable from global */ /*[4.4-4]*/ system_ctl_ptr = user_ctl.system_ctl_ptr; station_ctl_ptr = user_ctl.station_ctl_ptr; user_ctl.init_sw.station_ctl = "1"b; /*[4.4-1]*/ end; a_code = 0; return; end /* setup */; /* */ find_station: proc (x_station_name); dcl x_station_name char (12); a_code = 0; /* init to good for immediate return */ do station_ctl_eindex = 1 to station_ctl.current_size; if x_station_name = station_ctl.entries (station_ctl_eindex).station_name then do; station_ctl_eptr = addr (station_ctl.entries (station_ctl_eindex)); if ^station_ctl_entry.inactive_sw then return; /* right name and active, go to it */ end; end; a_code = cmcs_error_table_$bad_station; /* didn't make it */ return; end /* find_station */; /* */ lock_station: proc; dcl LOCAL_LOCK_WAIT_TIME fixed bin internal static options (constant) init (5); /*[5.3-1]*/ call cmcs_set_lock_$lock (station_ctl_entry.lockword, LOCAL_LOCK_WAIT_TIME, a_code); return; end /* lock_station */; /* */ unlock_station: proc; call cmcs_set_lock_$unlock (station_ctl_entry.lockword, a_code); return; end /* unlock_station */; find_destination: entry (a_station_name, a_station_ctl_eindex, a_station_ctl_eptr, a_code); /*[4.4-1]*/ call setup; /*[4.4-3]*/ call find_station (a_station_name); /*[4.4-3]*/ if a_code ^= 0 /*[4.4-3]*/ then a_station_ctl_eindex = 0; /*[4.4-3]*/ else do; a_station_ctl_eindex = station_ctl_eindex; /*[4.4-3]*/ a_station_ctl_eptr = station_ctl_eptr; /*[4.4-3]*/ end; /*[4.4-3]*/ return; end /* cmcs_station_ctl_ */;  cmcs_status_list_ctl_.pl1 05/24/89 1047.9rew 05/24/89 0834.0 110907 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_status_list_ctl_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_status_list_ctl_: proc (); return; /* bad entrypoint */ /* This COBOL MCS subroutine is called by cmcs_queue_ctl_ to manipulate the activity status of a given message. It uses the process-INdependent locators of the vfile_ record_status control order, and manipulates linked-list locator values in the affected records to keep the messages in the desired status list. Note: This module requuires that the caller do the locking and unlocking of queue_ctl.hdr.lockword. Bob May, 6/30/77 */ dcl a_iocb_ptr ptr, a_queue_ctl_eptr ptr, a_old_status fixed bin, a_new_status fixed bin, a_descr_ptr ptr, a_code fixed bin (35); dcl 1 a_descr like vfile_descr based (a_descr_ptr); dcl sysprint file env (interactive); /* for DEBUG */ dcl my_name char (21) init ("cmcs_status_list_ctl_"); dcl iocb_ptr ptr, descr_ptr ptr; dcl (ioa_) entry options (variable); dcl test_sw bit (1) int static init ("0"b); dcl (size, string, unspec) builtin; dcl error_table_$action_not_performed fixed bin (35) external; /* */ dcl 1 (b_descr, c_descr, f_descr) like vfile_descr int static; dcl (b_descr_ptr, c_descr_ptr, f_descr_ptr) ptr int static; dcl 1 (b_rs, c_rs, f_rs) like vfile_rs int static; dcl (b_rs_ptr, c_rs_ptr, f_rs_ptr) ptr int static; dcl (b_ptr, c_ptr, f_ptr) ptr int static; dcl 1 ( b based (b_ptr), c based (c_ptr), f based (f_ptr) ) like msg_hdr; dcl zero fixed bin (35) int static init (0) options (constant); dcl zero_descr_ptr ptr int static; dcl 1 zero_descr like vfile_descr based (zero_descr_ptr); dcl init_ptrs_sw bit (1) int static init ("0"b); dcl overlay_len fixed bin, overlay (overlay_len) fixed bin (35) based; dcl (addr, baseptr, fixed, null) builtin; dcl sub_err_ entry options (variable), sub_err_retval fixed bin (35); /* */ %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_error_table_dcls; %include cmcs_iox_processing; %include cmcs_key_dcls; %include cmcs_msg_hdr; %include cmcs_msg_seg; %include cmcs_queue_ctl; %include cmcs_slew_ctl; %include cmcs_user_ctl; %include cmcs_vfile_rs; /* */ add: entry (a_queue_ctl_eptr, a_iocb_ptr, a_descr_ptr, a_new_status, a_code); if test_sw /* DEBUG */ then do; put skip data (a_queue_ctl_eptr); put skip data (a_iocb_ptr); put skip data (a_descr_ptr); put skip data (a_new_status); end; if ^(external_user_ctl_ptr -> user_ctl.init_sw.status_list_ctl) then call setup; call set_descr; if a_code ^= 0 then go to error_ret; call check_msg_status (a_new_status); if a_code ^= 0 then go to error_ret; status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (a_new_status)); call link_descr; if a_code ^= 0 then go to error_ret; go to check_wait; /* end of add entrypoint */ /* */ delete: entry (a_queue_ctl_eptr, a_iocb_ptr, a_descr_ptr, a_old_status, a_code); if test_sw /* DEBUG */ then do; put skip data (a_queue_ctl_eptr); put skip data (a_iocb_ptr); put skip data (a_descr_ptr); put skip data (a_old_status); end; if ^(external_user_ctl_ptr -> user_ctl.init_sw.status_list_ctl) then call setup; call set_descr; if a_code ^= 0 then go to error_ret; call check_msg_status (a_old_status); if a_code ^= 0 then go to error_ret; status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (a_old_status)); call unlink_descr; if a_code ^= 0 then go to error_ret; go to good_ret; /* end of delete entrypoint */ /* */ move: entry (a_queue_ctl_eptr, a_iocb_ptr, a_descr_ptr, a_old_status, a_new_status, a_code); if test_sw /* DEBUG */ then do; put skip data (a_iocb_ptr); put skip data (a_queue_ctl_eptr); put skip data (a_descr_ptr); put skip data (a_old_status); put skip data (a_new_status); end; if ^(external_user_ctl_ptr -> user_ctl.init_sw.status_list_ctl) then call setup; call set_descr; if a_code ^= 0 then go to error_ret; call check_msg_status (a_old_status); if a_code ^= 0 then go to error_ret; if a_new_status < 1 | a_new_status > 4 then do; a_code = cmcs_error_table_$bad_call_parm; go to error_ret; end; status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (a_old_status)); call unlink_descr; if a_code ^= 0 then go to error_ret; status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (a_new_status)); c.msg_status = a_new_status; /* do before we link in, it may be processed next */ call link_descr; if a_code ^= 0 then go to error_ret; check_wait: if a_new_status = 2 /* notify only for available messages */ then do; if status_list_ctl_entry.count ^= 1 then goto good_ret; /* and only when going nonzero */ call cmcs_wait_ctl_$find (string (queue_ctl_entry.tree_path), queue_ctl_eptr, a_code); if a_code ^= 0 then if a_code ^= cmcs_error_table_$no_message then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to find process waiting for message in ""^a"". Continuing.", string (queue_ctl_entry.tree_path)); go to error_ret; end; else a_code = 0; /* it's ok, nobody was waiting */ end; good_ret: a_code = 0; error_ret: return; /* end of move entrypoint */ /* */ link_descr: proc (); /* Procedure to add a message to the end of a given status list. It assumes that the main procedure has already set the following: status_list_ctl_eptr, all of the c_xxx variables for the current record, including the c_rs structure. Also assumes that the queue_ctl.hdr.lockword is locked by the caller of cmcs_status_list_ctl_, whatever the entrypoint. */ if status_list_ctl_entry.count = 0 then do; /* this is the easy one */ status_list_ctl_entry.f_descr, status_list_ctl_entry.b_descr = c_descr; /* for just one, both point to new entry */ c.f_descr, c.b_descr = zero_descr; /* similarly for new msg */ end; /* already at least one msg, new one always goes at the end */ else do; b_descr = status_list_ctl_entry.b_descr;/* get old last-entry descr */ call seek_descr (b_descr, b_rs_ptr, b_ptr); if a_code ^= 0 then return; c.b_descr = b_descr; c.f_descr = zero_descr; /* new one points back to head */ status_list_ctl_entry.b_descr, b.f_descr = c_descr; /* new one now in the loop */ end; a_code = 0; status_list_ctl_entry.count = status_list_ctl_entry.count + 1; return; end /* link_descr */; /* */ unlink_descr: proc (); /* Procedure to unlink a message from anywhere in the linked list. This subroutine makes the same assumptions as link_descr. */ if status_list_ctl_entry.count = 0 then do; /* impossible, unquote */ a_code = cmcs_error_table_$bad_call_parm; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Fatal error detected. Attempt to perform an unlink in a list with zero entries. Continuing."); return; end; if status_list_ctl_entry.count = 1 then do; /* another easy one */ if unspec (status_list_ctl_entry.f_descr) ^= unspec (c_descr) then do; /* another impossible situation */ a_code = cmcs_error_table_$bad_call_parm; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Message in status list does not match descriptor of record to be deleted. Continuing.") ; return; end; status_list_ctl_entry.f_descr, status_list_ctl_entry.b_descr = zero_descr; /* reset list to null */ c.f_descr, c.b_descr = zero_descr; c.msg_status = 0; end; /* not so easy, more than one message int static in the list */ else do; b_descr = c.b_descr; f_descr = c.f_descr; /* set both now, may only use one */ if unspec (b_descr) = (36)"0"b & unspec (f_descr) = (36)"0"b then do; a_code = error_table_$action_not_performed; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to unlink a message from queue ""^a"", status ""^d"", where both forward and backward record descriptors are zero. Please contact the CMCS Administrator. Continuing.", queue_ctl_entry.queue_name, a_old_status); go to zero_c_descr; end; if unspec (b_descr) = unspec (zero_descr) then do; /* first one in list */ call seek_descr (f_descr, f_rs_ptr, f_ptr); if a_code ^= 0 then return; f.b_descr = zero_descr; /* now 2nd one is first */ status_list_ctl_entry.f_descr = f_descr; end; else if unspec (f_descr) = unspec (zero_descr) then do; /* last one in list */ call seek_descr (b_descr, b_rs_ptr, b_ptr); if a_code ^= 0 then return; b.f_descr = zero_descr; /* second to last now last */ status_list_ctl_entry.b_descr = b_descr; end; /* message to be deleted is in middle of the list */ else do; call seek_descr (b_descr, b_rs_ptr, b_ptr); if a_code ^= 0 then return; call seek_descr (f_descr, f_rs_ptr, f_ptr); if a_code ^= 0 then return; b.f_descr = f_descr; /* link ones on each side together */ f.b_descr = b_descr; end; end; zero_c_descr: c.f_descr, c.b_descr = zero_descr; /* zero out for clean job */ status_list_ctl_entry.count = status_list_ctl_entry.count - 1; a_code = 0; return; end /* unlink_descr */; /* */ set_descr: proc (); queue_ctl_eptr = a_queue_ctl_eptr; iocb_ptr = a_iocb_ptr; descr_ptr = a_descr_ptr; c_descr = a_descr; call seek_descr (c_descr, c_rs_ptr, c_ptr); return; end /* set_descr */; /* */ check_msg_status: proc (x_status); dcl x_status fixed bin; a_code = cmcs_error_table_$bad_call_parm; if x_status < 1 | x_status > 4 then return; if c.msg_status ^= x_status then return; a_code = 0; return; end /* check_msg_status */; /* */ seek_descr: proc (x_descr, x_rs_ptr, x_ptr); /* uses vfile_ record_status control to find messages by their vfile_ descriptor */ dcl 1 x_descr like vfile_descr, x_rs_ptr ptr, x_ptr ptr; dcl 1 x_rs like vfile_rs based (x_rs_ptr); dcl 1 x like msg_hdr based (x_ptr); x_rs.descr = x_descr; /* maybe redundant sometimes, but consistent */ call iox_$control (iocb_ptr, "record_status", x_rs_ptr, a_code); if a_code ^= 0 then do; /* bad news, should never happen */ call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to use record_status control order to locate descriptor ^d.^d.", x_rs.descr.comp_no, fixed (x_rs.descr.comp_offset, 18)); x_ptr = null (); end; else x_ptr = x_rs.rec_ptr; return; end /* seek_descr */; /* */ init_ptrs: proc (); b_descr_ptr = addr (b_descr); c_descr_ptr = addr (c_descr); f_descr_ptr = addr (f_descr); b_rs_ptr = addr (b_rs); c_rs_ptr = addr (c_rs); f_rs_ptr = addr (f_rs); overlay_len = size (b_rs); b_rs_ptr -> overlay (*) = 0; c_rs_ptr -> overlay (*) = 0; c_rs_ptr -> overlay (*) = 0; b_rs.locate_sw = "1"b; c_rs.locate_sw = "1"b; f_rs.locate_sw = "1"b; b_rs.version, c_rs.version, f_rs.version = vfile_rs_version; zero_descr_ptr = addr (zero); init_ptrs_sw = "1"b; return; end /* init_ptrs */; /* */ setup: proc; user_ctl_ptr = external_user_ctl_ptr; /* set local variable from global */ queue_ctl_ptr = user_ctl.queue_ctl_ptr; call init_ptrs; /* setup, part two */ user_ctl.init_sw.status_list_ctl = "1"b; /* do this only once */ a_code = 0; return; end /* setup */; test: entry (); test_sw = "1"b; return; end /* cmcs_status_list_ctl_ */;  cmcs_terminal_ctl_.pl1 05/24/89 1047.9rew 05/24/89 0834.0 22797 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_terminal_ctl_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_terminal_ctl_: proc; /* must never enter here */ /* This COBOL MCS subroutine is used to obtain the default station_name for a given terminal subchannel (device_channel) */ /* Bob May, 5/31/77 */ return; /* */ dcl a_device_channel char (8), a_station_name char (12), a_code fixed bin (35); dcl my_name char (18) init ("cmcs_terminal_ctl_"); %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_terminal_ctl; %include cmcs_user_ctl; dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl get_pdir_ entry () returns (char (168)); dcl (ioa_, com_err_) entry options (variable); dcl i fixed bin (35); dcl (cmcs_error_table_$bad_term_devchn) fixed bin (35) external; find: entry (a_device_channel, a_station_name, a_code); if ^(external_user_ctl_ptr -> user_ctl.init_sw.terminal_ctl) then do; user_ctl_ptr = external_user_ctl_ptr; terminal_ctl_ptr = user_ctl.terminal_ctl_ptr; user_ctl.init_sw.terminal_ctl = "1"b; end; do i = 1 to terminal_ctl.current_size; if ^terminal_ctl.inactive_sw (i) then if terminal_ctl.device_channel (i) = a_device_channel then do; a_station_name = terminal_ctl.station_name (i); a_code = 0; return; end; end; a_station_name = "Undefined!"; a_code = cmcs_error_table_$bad_term_devchn; return; end /* cmcs_terminal_ctl_ */;  cmcs_tree_ctl_.pl1 05/24/89 1047.9rew 05/24/89 0834.0 45504 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cmcs_tree_ctl_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 05/05/81 by FCH, [4.4-3], entry name find_qual_name added, BUG468 */ /* Modified on 05/05/81 by FCH, [4.4-2], destination name may be any primitive node name, BUG468 */ /* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_tree_ctl_: proc; return; /* invalid_entrypoint */ /* This COBOL MCS subroutine is used to find and process the various entries in cmcs_tree_ctl.control segment. */ /* Bob May, 6/30/77 */ dcl a_dest char (12), a_index fixed bin, a_eptr ptr, a_count fixed bin, a_code fixed bin (35), a_input_cdptr ptr; dcl (i, j) fixed bin, full_tree_path char (48); /* Internal Static */ dcl (addr, null, string) builtin; /* */ %include cmcs_cd_dcls; %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_error_table_dcls; %include cmcs_tree_ctl; %include cmcs_user_ctl; %include cmcs_vfile_rs; /* */ find_destination: entry (a_dest, a_index, a_eptr, a_code); /*[4.4-2]*/ declare ch48 char (48), loc fixed bin; /*[4.4-3]*/ call find_name; /*[4.4-3]*/ return; find_name: proc; /*[4.4-1]*/ call setup; do i = 1 to tree_ctl.current_size; /*[4.4-2]*/ tree_ctl_eptr = addr (tree_ctl.entries (i)); /*[4.4-2]*/ ch48 = string (tree_ctl_entry.tree_path); /*[4.4-2]*/ loc = index (ch48, a_dest); /*[4.4-2]*/ if loc > 0 /*[4.4-2]*/ then if a_dest = substr (ch48, loc) /*[4.4-2]*/ then do; a_index = i; /*[4.4-2]*/ a_eptr = tree_ctl_eptr; /*[4.4-2]*/ a_code = 0; /*[4.4-2]*/ return; /*[4.4-2]*/ end; end; a_index = 0; /* didn't find it */ a_eptr = null (); a_code = cmcs_error_table_$bad_dest; end; find_qual_name: entry (a_dest, a_index, a_eptr, qn, a_code); /*[4.4-3]*/ call find_name; /*[4.4-3]*/ if a_code ^= 0 then return; /*[4.4-3]*/ call form_qual_name; /*[4.4-3]*/ qn = qual_name; /*[4.4-3]*/ return; /*[4.4-3]*/ declare blank_pos fixed bin; /*[4.4-3]*/ declare qual_name char (52) varying; /*[4.4-3]*/ declare qn char (52); form_qual_name: proc; /*[4.4-3]*/ qual_name = ""; /*[4.4-3]*/ call qual_comp (1); /*[4.4-3]*/ if blank_pos ^= 1 /*[4.4-3]*/ then do; call qual_comp (13); /*[4.4-3]*/ if blank_pos ^= 1 /*[4.4-3]*/ then do; call qual_comp (25); /*[4.4-3]*/ if blank_pos ^= 1 then call qual_comp (37); /*[4.4-3]*/ end; /*[4.4-3]*/ end; end; qual_comp: proc (pos); /*[4.4-3]*/ declare pos fixed bin; /*[4.4-3]*/ blank_pos = index (substr (ch48, pos, 12), " "); /*[4.4-3]*/ if blank_pos = 1 then return; /*[4.4-3]*/ if blank_pos = 0 then blank_pos = 13; /*[4.4-3]*/ if qual_name ^= "" then qual_name = qual_name || "."; /*[4.4-3]*/ qual_name = qual_name || substr (ch48, pos, blank_pos - 1); end; find_index: entry (a_index, a_eptr, a_code); /*[4.4-1]*/ call setup; if a_index <= tree_ctl.current_size then do; tree_ctl_eptr = addr (tree_ctl.entries (a_index)); if ^tree_ctl_entry.inactive_sw then do; a_eptr = tree_ctl_eptr; a_code = 0; return; end; end; a_eptr = null (); a_code = cmcs_error_table_$bad_dest; return; /* end of find_index entrypoint */ find_tree_path: entry (a_input_cdptr, a_index, a_count, a_eptr, a_code); /*[4.4-1]*/ call setup; full_tree_path = string (a_input_cdptr -> input_cd.tree_path); do i = 1 to tree_ctl.current_size; tree_ctl_eptr = addr (tree_ctl.entries (i)); if ^tree_ctl_entry.inactive_sw then if full_tree_path = string (tree_ctl_entry.tree_path) then do; a_index = i; a_count = tree_ctl_entry.subtree_count; a_eptr = tree_ctl_eptr; a_code = 0; return; end; end; a_index, a_count = 0; /* didn't find it */ a_eptr = null (); a_code = cmcs_error_table_$bad_queue_path; /* ---- */ return; /* end of find_tree_path entrypoint */ setup: proc; /*[4.4-1]*/ if (external_user_ctl_ptr -> user_ctl.init_sw.tree_ctl) then return; user_ctl_ptr = external_user_ctl_ptr; /* set local variable from global */ tree_ctl_ptr = user_ctl.tree_ctl_ptr; user_ctl.init_sw.tree_ctl = "1"b; a_code = 0; end /* setup */; end /* cmcs_tree_ctl_ */;  cmcs_wait_ctl_.pl1 05/24/89 1047.9rew 05/24/89 0834.1 191556 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8087), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8087 cmcs_wait_ctl_.pl1 Shorten wait time for cmcs_station_ctl_. END HISTORY COMMENTS */ /* Modified on 10/20/84 by FCH, [5.3-1], BUG565(phx18385), wait time for set_lock_$lock */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs_wait_ctl_: proc; return; /* bad entrypoint */ /* This COBOL MCS subroutine is used to manage the wait control lists. The lists are linked forward and backward by entry index. All additions are done at the end of the list. Deletions can occur anywhere. Lists are always searched from the beginning, in order to serve requests on a first-come, first-served (when appropriate) basis. Note: the wait_ctl.current_size is not decremented even when the last physical entry of the segment is deleted. The entry is just added to the free list. The segment will never have more entries than the maximum number of concurrent users, so it will never grow to unreasonable size. */ /* Bob May, 6/30/77 */ /* DEBUG dcls */ dcl (sub_err_, ioa_) entry options (variable); dcl sub_err_retval fixed bin (35); /* dummy for sub_err_ */ /* input/output parameters */ dcl a_tree_path char (48), a_index fixed bin, a_queue_ctl_eptr ptr, a_wait_ctl_mp_eindex fixed bin, a_tree_ctl_eindex fixed bin, a_code fixed bin (35); /* variables to manipulate entries */ dcl (c_ptr, b_ptr, f_ptr) ptr, (c_index, b_index, f_index) fixed bin, 1 c like wait_ctl_entry based (c_ptr), /* "current" entry */ 1 b like wait_ctl_entry based (b_ptr), /* entry before current entry */ 1 f like wait_ctl_entry based (f_ptr); /* entry following current entry */ dcl i fixed bin, new_index fixed bin; /* additional FB to process entry indices */ dcl code fixed bin (35); dcl my_name char (14) int static init ("cmcs_wait_ctl_"); dcl test_sw bit (1) int static init ("0"b); dcl ( free_flag init ("1"b), used_flag init ("0"b) ) bit (1) aligned int static options (constant); dcl get_process_id_ entry () returns (bit (36) aligned); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)), ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)), ipc_$block entry (ptr, ptr, fixed bin (35)); dcl error_table_$action_not_performed fixed bin (35) external; dcl (addr, null, string) builtin; /* */ %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_error_table_dcls; %include cmcs_queue_ctl; %include cmcs_tree_ctl; %include cmcs_user_ctl; %include cmcs_vfile_rs; %include cmcs_wait_ctl; /* */ add: entry (a_tree_path, a_index, a_code); if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl) then call setup; call lock; if a_code ^= 0 then return; call get_free_index (a_index); wait_ctl_eptr = addr (wait_ctl.entries (a_index)); wait_ctl_entry.rcv_process_id = get_process_id_ (); /* set owner info */ string (wait_ctl_entry.rcv_tree_path) = a_tree_path; wait_ctl_entry.ev_wait_chn = user_ctl.ev_wait_chn; call link_index (a_index, used_flag); call unlock; if test_sw then call ioa_ ("Now going to sleep."); /* Code to go to sleep until wakeup goes here */ call ipc_$block (user_ctl.ev_wait_list_ptr, user_ctl.ev_info_ptr, a_code); return; /* end of add entrypoint */ find: entry (a_tree_path, a_queue_ctl_eptr, a_code); if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl) then call setup; queue_ctl_eptr = a_queue_ctl_eptr; call lock; if a_code ^= 0 then return; call find_index (new_index); if a_code ^= 0 /* First check to see if COBOL program waiting */ then do; if a_code ^= cmcs_error_table_$no_message then do; /* should never happen */ call unlock; return; end; /* Drop-through means that no COBOL program was waiting */ tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex; /* should we notify an mp? */ tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex)); if (tree_ctl_entry.mp_sw | tree_ctl_entry.cobol_program_id_sw) /* don't bother unless there is some thing to do */ then if wait_ctl.mp_info.mp_active_count > 0 then do wait_ctl_mp_eindex = 1 to wait_ctl.mp_current_size; wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex)); if wait_ctl_mp_entry.process_id ^= (36)"0"b then if wait_ctl_mp_entry.available_sw /* found waiting mp */ then do; wait_ctl_mp_entry.available_sw = "0"b; wait_ctl_mp_entry.ev_message = 0; /* unused for the present */ wait_ctl_mp_entry.tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex; call hcs_$wakeup (wait_ctl_mp_entry.process_id, wait_ctl_mp_entry.ev_wait_chn, 0, code); if code ^= 0 then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to send wakeup to message processor (^w). Continuing.", wait_ctl_mp_entry.process_id); go to find_mp_ret; end; end; /* Drop-through means no message processors available either */ find_mp_ret: call unlock; a_code = 0; return; end; /* Got to here, so we found a COBOL program that was waiting on a receive */ tree_ctl_eindex, c.tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex; tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex)); string (c.abs_tree_path) = string (tree_ctl_entry.tree_path); c.queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex; c.queue_name = tree_ctl_entry.queue_name; c.ev_message = 0; wait_ctl_eptr = addr (wait_ctl.entries (new_index)); if test_sw then do; call ioa_ ("wait_ctl_$wakeup:^-^a, ^p", a_tree_path, a_queue_ctl_eptr); /* DEBUG */ call ioa_ ("^2-^a.", string (wait_ctl_entry.rcv_tree_path)); /* DEBUG */ end; call hcs_$wakeup (wait_ctl_entry.rcv_process_id, wait_ctl_entry.ev_wait_chn, 0, a_code); /* 0 says process message */ if a_code ^= 0 then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to send wakeup to waiting process. Continuing."); call unlock; return; /* end of find entrypoint */ /* */ delete: entry (a_index, a_code); if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl) then call setup; wait_ctl_eptr = addr (wait_ctl.entries (a_index)); if get_process_id_ () = wait_ctl_entry.rcv_process_id then do; call lock; if a_code ^= 0 then return; call unlink_index (a_index, used_flag); call link_index (a_index, free_flag); /* keep it for reuse */ call unlock; a_code = 0; end; else do; /* wrong index */ a_code = error_table_$action_not_performed; end; return; /* end of delete entrypoint */ /* */ link_index: proc (x_index, x_free_flag); dcl x_index fixed bin, x_free_flag bit (1) aligned; c_index = x_index; c_ptr = addr (wait_ctl.entries (c_index)); c.findex = 0; /* new entry always added at (logical) end */ if x_free_flag then do; /* added to free list */ b_index = wait_ctl.free.bindex; if b_index = 0 then do; /* new entry is only entry */ wait_ctl.free.bindex, wait_ctl.free.findex = c_index; c.bindex = 0; /* new, only entry can only point back to hdr */ end; else do; b_ptr = addr (wait_ctl.entries (b_index)); b.findex = c_index; /* make old last entry point forward to new, only one */ c.bindex = b_index; /* point back to old last entry */ wait_ctl.free.bindex = c_index; /* now points to new, only entry */ end; c.entry_status = 0; /* free */ wait_ctl.free.count = wait_ctl.free.count + 1; end; else do; /* added to used list */ b_index = wait_ctl.used.bindex; if b_index = 0 then do; /* new, only entry is only entry */ wait_ctl.used.bindex, wait_ctl.used.findex = c_index; c.bindex = 0; /* new, only entry can only point back to hdr */ end; else do; b_ptr = addr (wait_ctl.entries (b_index)); b.findex = c_index; /* make old last entry point forward to new one */ c.bindex = b_index; /* point back to old last entry */ wait_ctl.used.bindex = c_index; /* now points to new last entry */ end; c.entry_status = 1; /* used */ wait_ctl.used.count = wait_ctl.used.count + 1; end; return; end /* link_index */; /* */ unlink_index: proc (x_index, x_free_flag); dcl x_index fixed bin, x_free_flag bit (1) aligned; c_index = x_index; c_ptr = addr (wait_ctl.entries (c_index)); b_index = c.bindex; f_index = c.findex; if b_index = 0 then if x_free_flag /* current is first record (logically) following hdr */ then wait_ctl.free.findex = f_index; /* free list */ else wait_ctl.used.findex = f_index; /* used list */ else do; /* current was not the 1st record following hdr */ b_ptr = addr (wait_ctl.entries (b_index)); b.findex = f_index; end; if f_index = 0 then if x_free_flag /* current is last record in one list or the other */ then wait_ctl.free.bindex = b_index; /* free list */ else wait_ctl.used.bindex = b_index; /* used list */ else do; /* current was not last entry in list */ f_ptr = addr (wait_ctl.entries (f_index)); f.bindex = b_index; end; if x_free_flag then wait_ctl.free.count = wait_ctl.free.count - 1; else wait_ctl.used.count = wait_ctl.used.count - 1; c.findex, c.bindex = 262143; /* 777777, easy to spot unlinked entries */ return; end /* unlink_index */; /* */ find_index: proc (x_index); dcl x_index fixed bin; /* output, 0 if none found */ dcl x_level_names (4) char (12) based (addr (a_tree_path)); if wait_ctl.used.count = 0 then go to not_found; /* don't look any further */ c_index = wait_ctl.used.findex; find_index_loop: if c_index = 0 /* will never happen 1st time through */ then go to not_found; /* we exhausted the list without an appropriate match */ c_ptr = addr (wait_ctl.entries (c_index)); if x_level_names (1) = c.rcv_tree_path.level_names (1) then do i = 2 to 4; /* there's hope, check the rest */ if c.rcv_tree_path.level_names (i) = "" then go to found; /* req was for higher level, which is fine */ if x_level_names (i) ^= c.rcv_tree_path.level_names (i) then go to find_index_continue; /* doesn't agree at higher levels, forget it */ end; find_index_continue: c_index = c.findex; go to find_index_loop; found: x_index = c_index; a_code = 0; return; not_found: x_index = 0; a_code = cmcs_error_table_$no_message; return; end /* find_index */; /* */ setup: proc; if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl) then do; user_ctl_ptr = external_user_ctl_ptr; /* set local variable from global */ queue_ctl_ptr = user_ctl.queue_ctl_ptr; tree_ctl_ptr = user_ctl.tree_ctl_ptr; wait_ctl_ptr = user_ctl.wait_ctl_ptr; user_ctl.init_sw.wait_ctl = "1"b; end; a_code = 0; return; end /* setup */; /* */ get_free_index: proc (x_index); /* caller must link back in */ dcl x_index fixed bin; if wait_ctl.free.count = 0 then do; /* this is the easy way */ x_index, wait_ctl.current_size, wait_ctl.entry_count = wait_ctl.current_size + 1; end; else do; x_index = wait_ctl.free.findex; /* take the first one */ call unlink_index (x_index, free_flag); /* let caller link it to used list */ end; return; end /* get_free_index */; /* */ mp_login: entry (a_wait_ctl_mp_eindex, a_code); if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl) then call setup; if user_ctl.ev_wait_chn = 0 | user_ctl.process_id = (36)"0"b then do; a_code = cmcs_error_table_$bad_call_parm; mp_err: a_wait_ctl_mp_eindex = -1; /* if they try to use it, we'll blow */ call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Error found in message processor login control info. Returning to caller."); return; end; call mp_lock; if a_code ^= 0 then return; /* First check to see if mp is already logged in */ if wait_ctl.mp_current_size > 0 then do; do i = 1 to wait_ctl.mp_current_size; wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (i)); if wait_ctl_mp_entry.process_id = user_ctl.process_id then do; call mp_unlock; a_code = cmcs_error_table_$bad_call_parm; go to mp_err; end; end; /* So far, so good. Now, do we have any open slots already? */ do wait_ctl_mp_eindex = 1 to wait_ctl.mp_info.mp_current_size; wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex)); if wait_ctl_mp_entry.process_id = (36)"0"b then do; set_mp_info: string (wait_ctl_mp_entry.flags) = (36)"0"b; wait_ctl_mp_entry.ev_wait_chn = user_ctl.ev_wait_chn; wait_ctl_mp_entry.process_id = user_ctl.process_id; wait_ctl.mp_info.mp_active_count = wait_ctl.mp_info.mp_active_count + 1; a_wait_ctl_mp_eindex = wait_ctl_mp_eindex; /* all future calls will use this index */ call mp_unlock; a_code = 0; return; end; end; end; /* Got to here, so we must increase the current size of the table for the new entry */ if wait_ctl.mp_info.mp_current_size < 10 then do; wait_ctl_mp_eindex, wait_ctl.mp_info.mp_current_size = wait_ctl.mp_info.mp_current_size + 1; wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex)); go to set_mp_info; end; else do; /* already have 10 message processors */ a_code = error_table_$action_not_performed; go to mp_err; end; /* end of mp_login entrypoint */ /* */ mp_available: entry (a_wait_ctl_mp_eindex, a_tree_ctl_eindex, a_code); if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl) then call setup; /* No need to use mp_lock because entry is ignored until we set the available_sw true */ wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (a_wait_ctl_mp_eindex)); wait_ctl_mp_entry.available_sw = "1"b; call ipc_$block (user_ctl.ev_wait_list_ptr, user_ctl.ev_info_ptr, a_code); return; /* end of mp_available entrypoint */ /* */ mp_logout: entry (a_wait_ctl_mp_eindex, a_code); if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl) then call setup; wait_ctl_mp_eindex = a_wait_ctl_mp_eindex; wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex)); call mp_lock; if a_code ^= 0 then return; wait_ctl_mp_entry.process_id = (36)"0"b; wait_ctl_mp_entry.ev_wait_chn = 0; string (wait_ctl_mp_entry.flags) = (36)"0"b; if wait_ctl.mp_info.mp_active_count ^= 0 then wait_ctl.mp_info.mp_active_count = wait_ctl.mp_info.mp_active_count - 1; if wait_ctl_mp_eindex = wait_ctl.mp_info.mp_current_size then wait_ctl.mp_info.mp_current_size = wait_ctl.mp_info.mp_current_size - 1; call mp_unlock; a_code = 0; return; /* end of mp_logout entrypoint */ /* */ clear_mp: entry (a_code); /* Used to force a reset to zero of the message processor control information. This is necessary in case of a crash with active message processors. */ /*[5.3-1]*/ call cmcs_set_lock_$lock (wait_ctl.hdr.lockword, 0, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to set lock in preparation for clear_mp request. Returning to request level."); return; end; if wait_ctl.mp_info.mp_active_count > 0 then call sub_err_ (0, my_name, "c", null (), sub_err_retval, "Active message processor count reset from ^d to 0.", wait_ctl.mp_info.mp_active_count); do i = 1 to 10; wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (i)); wait_ctl_mp_entry.process_id = (36)"0"b; string (wait_ctl_mp_entry.flags) = (36)"0"b; end; wait_ctl.mp_info.mp_active_count, wait_ctl.mp_info.mp_current_size = 0; call cmcs_set_lock_$unlock (wait_ctl.mp_info.mp_lockword, a_code); /* ignore status */ a_code = 0; return; /* end of clear_mp entrypoint */ /* */ start_mp: entry (a_code); /* Used to wakeup message processors explicitly because the queues are already non-empty. The message processors must already be logged in and available. */ do queue_ctl_eindex = 1 to queue_ctl.current_size; queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex)); if queue_ctl_entry.status_list_ctl_entries (2).count > 0 then do; /* messages waiting to be processed */ tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex; tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex)); /* needed for getting short queue name in case of trouble */ call start_next_mp; if a_code ^= 0 then return; end; end; return; /* end of start_mp entrypoint */ /* */ stop_mp: entry (a_code); if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl) then call setup; call mp_lock; if a_code ^= 0 then return; /* Send a wakeup with a message of 1 to all mps. All will get this either immediately or the next time they go blocked */ if wait_ctl.mp_info.mp_active_count > 0 then do wait_ctl_mp_eindex = 1 to wait_ctl.mp_info.mp_current_size; wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex)); if wait_ctl_mp_entry.process_id ^= (36)"0"b then do; call hcs_$wakeup (wait_ctl_mp_entry.process_id, wait_ctl_mp_entry.ev_wait_chn, 1, a_code); /* 1 says to logout */ if a_code ^= 0 then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to send wakeup to tell process (^b) to log out. Continuing.", wait_ctl_mp_entry.process_id); end; end; call mp_unlock; a_code = 0; return; /* end of stop_mp entrypoint */ /* */ start_next_mp: proc (); /* Finds the next available message processor and sends it a wakeup. It will complain if none are available, rather than sending multiple wakeups to a single process. */ dcl old_wait_ctl_mp_eindex fixed bin int static init (0);/* To make sure we don't just continue looping */ if old_wait_ctl_mp_eindex = 0 then wait_ctl_mp_eindex, old_wait_ctl_mp_eindex = 1; /* first time through, initialize */ do i = 1 to wait_ctl.mp_info.mp_current_size; wait_ctl_mp_eindex = wait_ctl_mp_eindex + 1; if wait_ctl_mp_eindex > wait_ctl.mp_info.mp_current_size then wait_ctl_mp_eindex = 1; /* don't overflow the table entries */ if wait_ctl_mp_eindex = old_wait_ctl_mp_eindex then do; /* didn't finnd an available mp */ a_code = error_table_$action_not_performed; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Couldn't find an available message processor to start for ^a.", tree_ctl_entry.queue_name); /* without the suffix */ return; end; wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex)); if wait_ctl_mp_entry.process_id ^= (36)"0"b then if wait_ctl_mp_entry.available_sw then do; call hcs_$wakeup (wait_ctl_mp_entry.process_id, wait_ctl_mp_entry.ev_wait_chn, 0, a_code); if a_code ^= 0 then do; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to send wakeup to message processor for queue ^a.", tree_ctl_entry.queue_name); return; end; else do; wait_ctl_mp_entry.available_sw = "0"b; /* now this one is busy */ call sub_err_ (0, my_name, "c", null (), sub_err_retval, "Started message processor for queue ^a.", tree_ctl_entry.queue_name); end; end; end; a_code = 0; return; end /* start_next_mp */; /* */ test: entry; test_sw = "0"b; return; /* end of test entrypoint */ /* */ lock: proc; /*[5.3-1]*/ call cmcs_set_lock_$lock (wait_ctl.hdr.lockword, 0, a_code); if a_code ^= 0 then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to lock wait control."); return; end /* lock */; /* */ mp_lock: proc; /*[5.3-1]*/ call cmcs_set_lock_$lock (wait_ctl.mp_lockword, 0, a_code); if a_code ^= 0 then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to lock message processor wait control."); return; end /* mp_lock */; /* */ unlock: proc; call cmcs_set_lock_$unlock (wait_ctl.hdr.lockword, a_code); if a_code ^= 0 then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to unlock wait control."); return; end /* unlock */; /* */ mp_unlock: proc; call cmcs_set_lock_$unlock (wait_ctl.mp_lockword, a_code); if a_code ^= 0 then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to unlock message processor wait control."); return; end /* mp_unlock */; end /* cmcs_wait_ctl_ */;  cobol_mcs.pl1 05/24/89 1047.9rew 05/24/89 0834.1 391707 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_mcs.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 03/17/82 by FCH, [5.2-1], eliminate need for copy switch by using temp seg, BUG530 */ /* Modified on 07/21/81 by FCH, [4.4-9], ..command added, BUG468 */ /* Modified on 06/02/81 by FCH, [4.4-8], initialization, BUG468 */ /* Modified on 06/01/81 by FCH, [4.4-7], on command_abort_ added, BUG468 */ /* Modified on 05/05/81 by FCH, [4.4-5], attach and detach commands added, BUG468 */ /* Modified on 05/01/81 by FCH, [4.4-3], all option on receive added, BUG468 */ /* Modified on 04/23/81 by FCH, [4.4-1], delete final new-line from send buffer, BUG468 */ /* Modified since Version 4.3 */ /* format: style3 */ cmcs: cobol_mcs: procedure options (separate_static); /* This COBOL MCS command is used to intialize the process environment for subsequent CMCS processing. For "CMCS terminals", it will enter request mode, and allow the user to essentially duplicate the COBOL program MCS functions through the request interface. */ /* Bob May, 5/31/77 */ dcl (i, j) fixed bin, dname char (168), ename char (32), char_delim char (1), io_subtype fixed bin, rcv_tree_path char (48) init (""), code fixed bin (35), my_name char (16), /* either cobol_mcs or cobol_mcs_admin */ my_brief_name char (8), /* for whoami */ (password1, password2) char (10); dcl station_name char (12), dest_table_index fixed bin, err_sw bit (1) init ("0"b); dcl output_cd_size fixed bin; /* temp output CD stuff, to get started */ dcl output_cd_area (output_cd_size) fixed bin based (output_cdp); dcl ptr_array (1) ptr; /* for get, release temp segments */ dcl overlay_len fixed bin, /* for structure initialization */ overlay (overlay_len) fixed bin based; dcl buffer_len fixed bin (21), buffer_max_len fixed bin (21), buffer_ptr ptr, buffer char (256); dcl send_buffer_ptr ptr, send_buffer_max_len fixed bin (21), send_buffer_len fixed bin (35), /* actual number of chars in temp buffer */ char_send_buffer_len pic "9999", send_buffer char (send_buffer_max_len) based (send_buffer_ptr); /* Switches */ dcl (scpsw_sw, interactive_sw) bit (1); dcl test_sw bit (1) int static init ("0"b); dcl (cleanup, program_interrupt, command_abort_) condition; dcl term_id char (4), term_type fixed bin, term_channel char (8); dcl command_count fixed bin int static init (15); dcl 1 command_list int static, 2 brief (15) char (8) init ("q", /* 1 */ "e", /* 2 */ "amc", /* 3 */ "r", /* 4 */ "s", /* 5 */ "ei", /* 6 */ "eit", /* 7 */ "eo", /* 8 */ "di", /* 9 */ "dit", /* 10 */ "do", /* 11 */ "p", /* 12 */ ".", /* 13 */ "a", /* 14 */ "d"), /* 15 */ 2 long (15) char (32) init ("quit", /* 1 */ "execute", /* 2 */ "accept_message_count", /* 3 */ "receive", /* 4 */ "send", /* 5 */ "enable_input", /* 6 */ "enable_input_terminal", /* 7 */ "enable_output", /* 8 */ "disable_input", /* 9 */ "disable_input_terminal", /* 10 */ "disable_output", /* 11 */ "purge", /* 12 */ ".", /* 13 */ "activate", /* 14 */ "deactivate"); /* 15 */ dcl admin_command_count fixed bin int static init (11); dcl 1 admin_command_list int static, 2 brief (11) char (8) init (".", /* 1 */ "q", /* 2 */ "e", /* 3 */ "test", /* 4 */ "ccpsw", /* 5 */ "scpsw", /* 6 */ "ccq", /* 7 */ "start_mp", /* 8 (not currently used) */ "stop_mp", /* 9 */ "clear_mp", /* 10 */ "purge_qs"), /* 11 */ 2 long (11) char (32) init (".", /* 1 */ "quit", /* 2 */ "execute", /* 3 */ "test", /* 4 */ "change_cmcs_password", /* 5 */ "set_cmcs_password", /* 6 */ "create_cmcs_queues", /* 7 */ "start_mp", /* 8 (not currently used) */ "stop_mp", /* 9 */ "clear_mp", /* 10 */ "purge_queues"); /* 11 */ dcl req char (256), /* request line input buffer */ (req_arg_count, req_left_begin, req_left_len) fixed bin, req_len fixed bin (21), /* for use with iox_$get_line */ req_cmd_ptr ptr, req_cmd_len fixed bin; dcl (cmd_parsed_sw, args_parsed_sw) bit (1); dcl max_arg_count fixed bin int static options (constant) init (25); dcl 1 arg_array (25), 2 argp ptr, 2 argl fixed bin; dcl max_req_args fixed bin int static options (constant) init (16); /* loop control */ dcl whitespace char (5) int static options (constant) init (" "); /* b, HT, NL, VT, FF */ dcl user_info_$absentee_queue entry (fixed bin), user_info_$tty_data entry (char (*), fixed bin, char (*)), absolute_pathname_ entry (char (*), char (*), fixed bin (35)), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), cu_$cp entry (ptr, fixed bin, fixed bin (35)), read_password_ entry (char (*), char (*)), get_process_id_ entry () returns (bit (36)), get_wdir_ entry () returns (char (168)), get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)), release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), ( ioa_, ioa_$rsnnl ) entry options (variable); /*[5.2-1]*/ dcl cmcs_initiate_ctl_$release entry (fixed bin (35)); dcl ( error_table_$action_not_performed, error_table_$long_record, error_table_$too_many_args, error_table_$wrong_no_of_args ) fixed bin (35) external; dcl (addr, char, fixed, null, search, size, string, substr, verify) builtin; /* */ %include cmcs_arg_processing; %include cmcs_cd_dcls; %include cmcs_cobol_mcs_dcls; %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_error_table_dcls; %include cmcs_iox_processing; %include cmcs_ipc_processing; %include cmcs_station_ctl; %include cmcs_system_ctl; %include cmcs_terminal_ctl; %include cmcs_tree_ctl; %include cmcs_user_ctl; %include cmcs_vfile_rs; %include cmcs_wait_ctl; /* */ /* cobol_mcs, cmcs only */ my_name = "cobol_mcs"; my_brief_name = "cmcs"; call cu_$arg_count (arg_count); if arg_count < 2 | arg_count > 3 then do; print_usage: code = 0; print_error_usage: call com_err_ (code, my_name, "^/Usage: cobol_mcs cmcs_dir -message_processor (-mp) or: cobol_mcs cmcs_dir -terminal (-term) {}"); return; end; common_entry: call get_temp_segments_ ("cobol_mcs", ptr_array, code); if code ^= 0 then do; call com_err_ (code, my_name, "Attempting to create cmcs_user_ctl_.control in your process_dir."); return; end; user_ctl_ptr = ptr_array (1); /* now we can do something with it */ call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then go to print_error_usage; if arg = "-wd" | arg = "-working_dir" then dname = get_wdir_ (); else do; call absolute_pathname_ (arg, dname, code); if code ^= 0 then go to print_error_usage; end; /* general initialization */ buffer_ptr = addr (buffer); buffer_max_len = 4 * 16 * 1024; /* terminal input arbitrarily limited to 16k chunks */ /*[4.4-5]*/ user_ctl.attach_bit, user_ctl.rec = "0"b; d_stat_path = ""; /*[4.4-5]*/ user_ctl.output_file = ""; /*[4.4-5]*/ user_ctl.iocb_ptr = null (); /*[4.4-5]*/ IOCB_ptr = iox_$user_output; /* clear all user_ctl data */ overlay_len = size (user_ctl); user_ctl_ptr -> overlay (*) = 0; /* clean slate */ /*[4.4-8]*/ string (user_ctl.init_sw) = "0"b; user_ctl.cmcs_dir, user_ctl.station_name, user_ctl.term_id, user_ctl.term_channel, user_ctl.last_receive_info.tree_path, user_ctl.last_send_info.dest_name = ""; /* so it isn't garbage if printed */ user_ctl.last_receive_info.tree_ctl_eptr = null (); user_ctl.last_send_info.tree_ctl_eptr = null (); user_ctl.station_info.station_entries (*).station_ctl_eptr = null (); user_ctl.wait_info.wait_ctl_eptr = null (); /* so we don't reference the dseg */ user_ctl.cmcs_dir = dname; /* start filling things in */ external_user_ctl_ptr = user_ctl_ptr; /* first reference */ call cobol_mcs_$set_user_ctl_exists_sw ("1"b); /* let the world know we're ready */ call cmcs_initiate_ctl_ ("", null (), code); /* just set all the ptrs in user_ctl, ma'am */ if code ^= 0 then do; external_user_ctl_ptr = null (); return; /* cminit_ will print the error message */ end; /* Drop-thru means that user_ctl has had all its control seg ptrs set by cminit_. Now we all can get ptrs from user_ctl without using a call */ queue_ctl_ptr = user_ctl.queue_ctl_ptr; /* for admin and MPs */ station_ctl_ptr = user_ctl.station_ctl_ptr; /* for admin and MPs */ system_ctl_ptr = user_ctl.system_ctl_ptr; /* for admin and MPs */ terminal_ctl_ptr = user_ctl.terminal_ctl_ptr; /* for admin and MPs */ tree_ctl_ptr = user_ctl.tree_ctl_ptr; /* for admin and MPs */ wait_ctl_ptr = user_ctl.wait_ctl_ptr; user_ctl.process_id = get_process_id_ (); call set_interactive_info; if my_brief_name = "cmcsa" then do; user_ctl.admin_sw = "1"b; user_ctl.process_type = 3; /* admin process */ end; if my_name = "cobol_mcs" then do; /* cobol_mcs only */ call cu_$arg_ptr (2, arg_ptr, arg_len, code); if code ^= 0 then go to print_error_usage; if arg = "-mp" | arg = "-message_processor" then do; call cu_$arg_ptr (3, arg_ptr, arg_len, code); if code ^= 0 then go to print_error_usage; station_name = arg; user_ctl.mp_sw = "1"b; /* we made it, user is a station */ user_ctl.process_type = 1; /* process is a CMCS message processor */ end; else if arg = "-term" | arg = "-terminal" then do; if ^interactive_sw then do; call com_err_ (0, my_name, "The terminal option must be used interactively."); go to print_usage; end; if arg_count = 3 then do; call cu_$arg_ptr (3, arg_ptr, arg_len, code); if code ^= 0 then go to print_error_usage; station_name = arg; end; else do; call cmcs_terminal_ctl_$find (term_channel, station_name, code); if code ^= 0 then do; call com_err_ (code, my_name, "Attempting to find your terminal subchannel in the cmcs_terminal_ctl.control segment." ); return; end; end; user_ctl.station_name = station_name; user_ctl.terminal_sw = "1"b; user_ctl.process_type = 2; /* user is a CMCS terminal */ end; call cmcs_station_ctl_$attach (station_name, station_ctl_eindex, code); if code ^= 0 then do; /* station already taken */ call com_err_ (code, my_name, "Attempting to attach station ""^a"". Returning to command level.", station_name); return; end; user_ctl.station_name = station_name; user_ctl.station_ctl_eindex = station_ctl_eindex; /* save for disable checks */ end; /* Initialization for use as terminal */ if user_ctl.terminal_sw then do; allocate input_cd; /* fixed size, no problem */ output_cd_size = 100; /* can be increased later, if desired */ allocate output_cd_area; output_cd.bin_max_station_count = 10; /* artificial command-interface limitation */ output_cd.char_max_station_count = 10; /* artificial command-interface limitation */ call get_temp_segments_ (my_name, ptr_array, code); if code ^= 0 then do; call com_err_ (code, my_name, "Attempting to get temp seg for send buffer."); return; end; send_buffer_ptr = ptr_array (1); /* only using one */ send_buffer_max_len = 9999; /* max no of chars a COBOL program can send at one time */ end; if ^user_ctl.mp_sw then do; /* they just abort */ /* check for interrupted operations */ on program_interrupt /* for all modes of use */ begin; call ioa_ ("Returning to request level."); go to nonlocal_request; /* nonlocal goto */ end; /* catch any release stack */ /*[4.4-7]*/ on command_abort_ go to nonlocal_return; on cleanup go to nonlocal_return; /* for all modes of use */ end; user_ctl.initialized_sw = "1"b; /* Station Processing */ if ^user_ctl.admin_sw /* everyone else may need this */ then do; /* Any checks to force use only as daemon should go here */ call ipc_$create_ev_chn (user_ctl.ev_wait_chn, code); if code ^= 0 then do; call com_err_ (code, my_name, "Attempting to create an event wait channel. Returning to command level."); go to nonlocal_return; end; ev_wait_list.n_chn = 1; ev_wait_list.ev_chn (1) = user_ctl.ev_wait_chn; ev_wait_list_ptr, user_ctl.ev_wait_list_ptr = addr (ev_wait_list); ev_info_ptr, user_ctl.ev_info_ptr = addr (ev_info); end; if user_ctl.mp_sw then do; call cmcs_wait_ctl_$mp_login (user_ctl.wait_ctl_mp_eindex, code); if code ^= 0 then do; call com_err_ (code, my_name, "Attempting to add process to list of logged-in message processors. Returning to command level." ); go to nonlocal_return; end; /* We are logged in, but not yet available. Set ptr to mp wait entry for subsequent wakeup prcessing. */ wait_ctl_mp_eindex = user_ctl.wait_ctl_mp_eindex; /* set working value from saved value */ wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex)); mp_loop: call cmcs_wait_ctl_$mp_available (user_ctl.wait_ctl_mp_eindex, tree_ctl_eindex, code); /* wakeup with an available message, hopefully */ if code ^= 0 then do; call com_err_ (code, my_name, "Attempting to add process to list of available message processors. Returning to command level." ); go to nonlocal_return; end; /* So far, so good. Now check the ev_message to see what we are supposed to do. If 0, we process a message. If 1, we log out. If anything else, we complain, and wait for the next wakeup. Ho hum, what a life! */ if ev_info.ev_message = 1 then do; mp_logout: call ioa_ ("Message Processor (Station ^a) returning to command level.", user_ctl.station_name); call cmcs_wait_ctl_$mp_logout (wait_ctl_mp_eindex, code); /* we don't want any more wakeups */ if code ^= 0 then call com_err_ (code, my_name, "Attempting to request an mp_logout for this process. Continuing to log out."); go to nonlocal_return; end; else if ev_info.ev_message ^= 0 then do; code = error_table_$action_not_performed; call com_err_ (code, my_name, "Invalid event message received in wakeup. Returning to mp_loop."); go to mp_loop; end; /* Drop-thru means we must process a message in some queue specified in the mp wait entry */ /* process the returned tree_ctl_eindex */ tree_ctl_eindex = wait_ctl_mp_entry.tree_ctl_eindex; /* the tree_ctl_entry has all the necessary info */ tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex)); if ^(tree_ctl_entry.mp_sw | tree_ctl_entry.cobol_program_id_sw) then do; code = error_table_$action_not_performed; mp_cmd_err: call com_err_ (code, my_name, "Error found in command line syntax or execution for ""^a"". Returning to mp_loop."); go to mp_loop; end; call ioa_$rsnnl ("^a ^a ^a", buffer, buffer_len, substr (tree_ctl_entry.mp_line, 1, tree_ctl_entry.mp_line_len), substr (tree_ctl_entry.cobol_program_id, 1, tree_ctl_entry.cobol_program_id_len), string (tree_ctl_entry.tree_path)); call cu_$cp (addr (buffer), fixed (buffer_len, 17), code); if code ^= 0 then do; call com_err_ (code, my_name, "Executing command line (^a). Returning to mp_loop.", substr (buffer, 1, buffer_len)); end; go to mp_loop; end; /* of station processing */ /*[4.4-5]*/ declare 1 info_structure aligned, /*[4.4-5]*/ 2 ev_chain fixed bin (71), /*[4.4-5]*/ 2 input_available bit (1); /*[4.4-5]*/ declare timer_manager_$sleep entry (fixed bin (71), bit (2)); /*[4.4-5]*/ declare info_ptr ptr; /*[4.4-5]*/ declare IOCB_ptr ptr; delay: proc; /*[4.4-5]*/ info_ptr = addr (info_structure); /*[4.4-5]*/ do while ("1"b); /*[4.4-5]*/ call timer_manager_$sleep (1, "11"b); /* 1 sec delay */ /*[4.4-5]*/ call iox_$control (iox_$user_input, "read_status", info_ptr, code); /*[4.4-5]*/ if info_structure.input_available then go to GL; /*[4.4-5]*/ call rec_messages; /*[4.4-5]*/ end; end; rec_messages: proc; /*[4.4-5]*/ char_delim = "2"; /*[4.4-5]*/ io_subtype = 2; /*[4.4-5]*/ all_bit = "1"b; /*[4.4-5]*/ string (input_cd.tree_path) = d_stat_path; /*[4.4-5]*/ user_ctl.rec = "1"b; /*[4.4-5]*/ call rec; /*[4.4-5]*/ user_ctl.rec = "0"b; end; /* NONLOCAL REQUEST */ nonlocal_request: read_request: /*[4.4-5]*/ if my_brief_name = "cmcs" then if user_ctl.attach_bit then call delay; GL: call iox_$get_line (iox_$user_input, addr (req), 256, req_len, code); if code ^= 0 then do; if code = error_table_$long_record then do; call com_err_ (code, my_name, "Request lines must be <= 256 characters. Please reenter."); go to read_request; end; else do; /* unexpected problem */ call com_err_ (code, my_name, "Attempting to read a request line from user_input."); return; end; end; if req_len = 1 then go to read_request; /* just spacing down the terminal */ /*[4.4-9]*/ if substr (arg, 1, 2) = ".." /*[4.4-9]*/ then do; req_left_begin = 3; /*[4.4-9]*/ req_left_len = req_len - 2; /*[4.4-9]*/ go to command (2); /*[4.4-9]*/ end; cmd_parsed_sw, args_parsed_sw = "0"b; /* flags to control parsing */ req_left_begin = 1; req_left_len = req_len - 1; /* forget the trailing NL */ call get_req_cmd; /* strip off the command */ if user_ctl.process_type = 2 then do; do i = 1 to command_count; /* try the brief forms first */ if arg = command_list.brief (i) then go to command (i); end; do i = 1 to command_count; /* likes to type */ if arg = command_list.long (i) then go to command (i); end; end; else if user_ctl.process_type = 3 then do; do i = 1 to admin_command_count; /* try the brief forms first */ if arg = admin_command_list.brief (i) then go to admin_command (i); end; do i = 1 to admin_command_count; /* likes to type */ if arg = admin_command_list.long (i) then go to admin_command (i); end; end; call com_err_ (0, my_name, "Unrecognized command ""^a"". Please reenter request.", arg); go to read_request; cmcsa: cobol_mcs_admin: entry; my_name = "cobol_mcs_admin"; my_brief_name = "cmcsa"; call cu_$arg_count (arg_count); if arg_count ^= 1 then do; /* needs help */ call com_err_ (0, my_name, "Usage: cobol_mcs_admin cmcs_dir"); return; end; go to common_entry; /* NONLOCAL RETURN */ /* quit */ command (1): admin_command (2): /*[4.4-5]*/ if my_brief_name = "cmcs" then if user_ctl.attach_bit then call rec_messages; nonlocal_return: if ^user_ctl.admin_sw /* do for everyone except admin */ then do; if test_sw then call ioa_ ("Starting purge all before return."); /* DEBUG */ call cobol_mcs_$stop_run (); if user_ctl.terminal_sw /* no one else uses these */ then do; if input_cdp ^= null () then free input_cd; if output_cdp ^= null () then free output_cd; if send_buffer_ptr ^= null () then do; ptr_array (1) = send_buffer_ptr; call release_temp_segments_ (my_name, ptr_array, code); if code ^= 0 then call com_err_ (code, my_name, "From releasing the send buffer segment. Continuing."); end; end; call ipc_$delete_ev_chn (user_ctl.ev_wait_chn, code); if code ^= 0 then call com_err_ (code, my_name, "Attempting to delete the wait event channel. Please contact the CMCS Administrator. Continuing." ); call cmcs_station_ctl_$detach (user_ctl.station_ctl_eindex, code); if code ^= 0 then call com_err_ (code, my_name, "Attempting to detach the process station_name. Continuing."); end; call cobol_mcs_$set_user_ctl_exists_sw ("0"b); /* now illegal to use CMCS */ external_user_ctl_ptr = null (); ptr_array (1) = user_ctl_ptr; /*[5.2-1]*/ if my_brief_name = "cmcs" /*[5.2-1]*/ then do; call release_temp_segments_ ("cobol_mcs", ptr_array, code); if code ^= 0 then call com_err_ (code, my_name, "Attempting to release temporary segment for user_ctl. Continuing return to command level.") ; /*[5.2-1]*/ call cmcs_initiate_ctl_$release (code); /*[5.2-1]*/ end; return; /* execute */ command (2): admin_command (3): call cu_$cp (addr (substr (req, req_left_begin, 1)), req_left_len, code); if code ^= 0 then do; call com_err_ (code, my_name, "From execute request."); end; /*[4.4-5]*/ if my_brief_name = "cmcs" then if user_ctl.attach_bit then call rec_messages; go to read_request; /* accept_message_count */ command (3): if test_sw then call ioa_ ("amc"); io_subtype = 1; call get_req_arg_count; if arg_count ^= 1 then do; call com_err_ (0, my_name, "Usage: accept_message_count tree_path"); go to read_request; end; call req_arg_ptr (1); call cmcs_expand_tree_path_ (arg, rcv_tree_path, code); if code ^= 0 then do; amc_error: call com_err_ (code, my_name, "From accept_message_count, using ""^a"".", arg); call cmcs_decode_status_ (iox_$user_output, input_cdp, 5, io_subtype, code); go to read_request; end; string (input_cd.tree_path) = rcv_tree_path; call cobol_mcs_$accept (input_cdp, code); if code ^= 0 then go to amc_error; call ioa_ ("Message count for ""^a"" is ^a.", arg, input_cd.msg_count); rcv_tree_path = ""; /* so we don't confuse receives */ go to read_request; /*[4.4-3]*/ declare all_bit bit (1); /* receive */ command (4): if test_sw then call ioa_ ("receive"); /*[4.4-3]*/ all_bit = "0"b; call get_req_arg_count; if arg_count = 0 | arg_count > 2 then do; call com_err_ (0, my_name, "Usage: receive delim {tree_path}"); go to read_request; end; call req_arg_ptr (1); /* get delimiter */ if arg = "1" | arg = "esi" then do; /* wants message segment */ char_delim = "1"; io_subtype = 1; end; else if arg = "2" | arg = "emi" then do; /* wants entire message */ char_delim = "2"; io_subtype = 2; end; /*[4.4-3]*/ else if arg = "3" | arg = "all" /*[4.4-3]*/ then do; char_delim = "2"; /*[4.4-3]*/ io_subtype = 2; /* entire message */ /*[4.4-3]*/ all_bit = "1"b; /*[4.4-3]*/ end; else do; /*[4.4-3]*/ call com_err_ (0, my_name, "Receive delimiter must be esi (1) or emi (2) or all (3)."); go to read_request; end; if arg_count = 2 then do; /* supplied the tree_path */ call req_arg_ptr (2); call cmcs_expand_tree_path_ (arg, rcv_tree_path, code); if code ^= 0 then do; call com_err_ (code, my_name, "Expanding ""^a"" to full tree path.", arg); go to read_request; end; end; else if rcv_tree_path = "" /* didn't give new one, is old one ok? */ then do; call com_err_ (0, my_name, "Previous tree path is blank. Please reenter request with new tree path."); go to read_request; end; string (input_cd.tree_path) = rcv_tree_path; /*[4.4-3]*/ call rec; if code ^= 0 then do; call com_err_ (code, my_name, "From receive."); call cmcs_decode_status_ (iox_$user_output, input_cdp, 2, io_subtype, code); if code ^= 0 then call com_err_ (code, my_name, "From the status decode."); end; if input_cd.text_delim = 0 | input_cd.text_delim = 1 then rcv_tree_path = string (input_cd.tree_path); /* partial message, keep abs tree path */ else rcv_tree_path = ""; /* nullify for complete messages and rcv errors */ go to read_request; rec: proc; /*[4.4-3]*/ declare mess_bit bit (1); /*[4.4-3]*/ mess_bit = "0"b; /*[4.4-3]*/ do while ("1"b); /*[4.4-3]*/ call cmcs_queue_ctl_$print (input_cdp, io_subtype, IOCB_ptr, code); /*[4.4-3]*/ if ^all_bit then return; /*[4.4-3]*/ if code ^= 0 /*[4.4-3]*/ then do; if code = cmcs_error_table_$no_message & (mess_bit | user_ctl.attach_bit) then code = 0; /*[4.4-3]*/ return; /*[4.4-3]*/ end; /*[4.4-3]*/ mess_bit = "1"b; /*[4.4-3]*/ end; end; /* send */ command (5): if test_sw then call ioa_ ("send"); send_buffer_len = 0; /* start fresh each time */ call get_req_arg_count; /* for initial checks */ if arg_count < 2 then do; /* doesn't know how to use */ call com_err_ (0, my_name, "Usage: send delim dest1 {dest2 ... destn}"); go to read_request; end; else if arg_count > 11 then do; call com_err_ (0, my_name, "Only 10 destinations can be specified in the send request. Please reenter request."); go to read_request; end; call req_arg_ptr (1); /* get message delim */ if arg = "1" | arg = "esi" then do; /* send data as message segment */ char_delim = "1"; /* for cobol_mcs_ interface */ io_subtype = 1; /* for internal interfaces */ end; else if arg = "2" | arg = "emi" then do; /* send data as complete message */ char_delim = "2"; io_subtype = 2; end; else if arg = "3" | arg = "egi" then do; /* egi same as emi */ char_delim = "3"; io_subtype = 3; end; else do; call com_err_ (0, my_name, "The send delimiter must be esi (1), emi (2), or egi (3)."); go to read_request; end; call fill_dest_table (2); /* arg 2 = 1st dest name */ send_loop: call iox_$get_line (iox_$user_input, buffer_ptr, buffer_max_len, buffer_len, code); if code ^= 0 then do; call com_err_ (code, my_name, "While doing a get_line for the send data."); go to read_request; end; if buffer_len = 2 then if substr (buffer, 1, 1) = "." then do; if send_buffer_len = 0 then do; /* tried to send a null message */ call com_err_ (0, my_name, "Send data must be non-null. Returning to request level."); go to read_request; end; /*[4.4-1]*/ if substr (send_buffer, send_buffer_len, 1) = " " /*[4.4-1]*/ then send_buffer_len = send_buffer_len - 1; output_cd.text_len = send_buffer_len; call cobol_mcs_$send (output_cdp, send_buffer_ptr, "9999", char_delim, (36)"0"b, code); if code ^= 0 then do; call com_err_ (code, my_name, "From send."); call cmcs_decode_status_ (iox_$user_output, output_cdp, 1, io_subtype, code); if code ^= 0 then call com_err_ (code, my_name, "From decode of status information."); end; go to read_request; end; if send_buffer_len + buffer_len > send_buffer_max_len then do; /* should never happen, but just in case... */ call com_err_ (0, my_name, "You have exceeded the maximum amount of input to the send request (^d characters). Returning to request level.", send_buffer_max_len); go to read_request; end; substr (send_buffer, send_buffer_len + 1, buffer_len) = substr (buffer, 1, buffer_len); send_buffer_len = send_buffer_len + buffer_len; go to send_loop; /* enable_input */ command (6): if test_sw then call ioa_ ("ei"); io_subtype = 1; call get_req_arg_count; if arg_count ^= 1 then do; call com_err_ (0, my_name, "Usage: enable_input tree_path"); go to read_request; end; call req_arg_ptr (1); call cmcs_expand_tree_path_ (arg, rcv_tree_path, code); if code ^= 0 then do; ei_error: call com_err_ (code, my_name, "From enable_input."); call cmcs_decode_status_ (iox_$user_output, input_cdp, 3, io_subtype, code); go to read_request; end; string (input_cd.tree_path) = rcv_tree_path; call get_password; call cobol_mcs_$enable_input_queue (input_cdp, password1, code); if code ^= 0 then go to ei_error; go to read_request; /* enable_input_terminal */ command (7): if test_sw then call ioa_ ("eit"); io_subtype = 2; call get_req_arg_count; if arg_count ^= 1 then do; call com_err_ (0, my_name, "Usage: enable_input_terminal station_name"); go to read_request; end; call get_password; call req_arg_ptr (1); input_cd.station_name = arg; call cobol_mcs_$enable_input_terminal (input_cdp, password1, code); if code ^= 0 then do; call com_err_ (code, my_name, "From enable_input_terminal."); call cmcs_decode_status_ (iox_$user_output, input_cdp, 3, io_subtype, code); go to read_request; end; go to read_request; /* enable_output */ command (8): if test_sw then call ioa_ ("eo"); io_subtype = 3; call get_req_arg_count; if arg_count = 0 then do; call com_err_ (0, my_name, "Usage: enable_output dest1 {dest2 ... dest10}"); go to read_request; end; call get_password; call fill_dest_table (1); call cobol_mcs_$enable_output (output_cdp, password1, code); if code ^= 0 then do; call com_err_ (code, my_name, "From enable_output"); call cmcs_decode_status_ (iox_$user_output, output_cdp, 3, io_subtype, code); go to read_request; end; go to read_request; /* disable_input */ command (9): if test_sw then call ioa_ ("di"); io_subtype = 1; call get_req_arg_count; if arg_count ^= 1 then do; call com_err_ (0, my_name, "Usage: disable_input tree_path"); go to read_request; end; call req_arg_ptr (1); call cmcs_expand_tree_path_ (arg, rcv_tree_path, code); if code ^= 0 then do; di_error: call com_err_ (code, my_name, "From disable_input."); call cmcs_decode_status_ (iox_$user_output, input_cdp, 4, io_subtype, code); go to read_request; end; string (input_cd.tree_path) = rcv_tree_path; call get_password; call cobol_mcs_$disable_input_queue (input_cdp, password1, code); if code ^= 0 then go to di_error; go to read_request; /* disable_input_terminal */ command (10): if test_sw then call ioa_ ("dit"); io_subtype = 2; call get_req_arg_count; if arg_count ^= 1 then do; call com_err_ (0, my_name, "Usage: disable_input_terminal station_name"); go to read_request; end; call get_password; call req_arg_ptr (1); input_cd.station_name = arg; call cobol_mcs_$disable_input_terminal (input_cdp, password1, code); if code ^= 0 then do; call com_err_ (code, my_name, "From disable_input_terminal."); call cmcs_decode_status_ (iox_$user_output, input_cdp, 4, io_subtype, code); go to read_request; end; go to read_request; /* disable_output */ command (11): if test_sw then call ioa_ ("do"); io_subtype = 3; call get_req_arg_count; if arg_count = 0 then do; call com_err_ (0, my_name, "Usage: disable_output dest1 {dest2 ... dest10}"); go to read_request; end; call fill_dest_table (1); call get_password; call cobol_mcs_$disable_output (output_cdp, password1, code); if code ^= 0 then do; call com_err_ (code, my_name, "From disable_output"); call cmcs_decode_status_ (iox_$user_output, output_cdp, 4, io_subtype, code); go to read_request; end; go to read_request; /* purge */ command (12): if test_sw then call ioa_ ("purge"); io_subtype = 1; call get_req_arg_count; if arg_count = 0 then do; print_purge_usage: call com_err_ (0, my_name, "Usage: purge s {dest1 dest2 ... {dest10}"); go to read_request; end; call req_arg_ptr (1); if arg ^= "s" then go to print_purge_usage; if arg_count > 1 then do; call fill_dest_table (2); call cobol_mcs_$purge (output_cdp, code); /* sends only, for cmd interface */ if code ^= 0 then do; call com_err_ (code, my_name, "From purge"); call cmcs_decode_status_ (iox_$user_output, output_cdp, 6, io_subtype, code); end; end; else do; call cobol_mcs_$purge (null (), code); if code ^= 0 then call com_err_ (code, my_name, "From purge."); end; go to read_request; /*activate */ command (14): /* activate [ station_name [ path_name ]] */ /*[4.4-5]*/ if user_ctl.attach_bit /*[4.4-5]*/ then do; call com_err_ (0, my_name, "Station already activated"); /*[4.4-5]*/ go to read_request; /*[4.4-5]*/ end; /*[4.4-5]*/ call get_req_arg_count; /*[4.4-5]*/ if arg_count > 2 /*[4.4-5]*/ then do; call bad_attach; /*[4.4-5]*/ go to read_request; /*[4.4-5]*/ end; /*[4.4-5]*/ go to A (arg_count); /* activate */ A (0): /*[4.4-5]*/ ARG = user_ctl.station_name; user_ctl.iocb_ptr = null (); /*[4.4-5]*/ go to A0; /* activate station-name */ A (1): /*[4.4-5]*/ call save_station; user_ctl.iocb_ptr = null (); /*[4.4-5]*/ go to A0; /* activate station-name file_name */ A (2): /*[4.4-5]*/ call save_station; /*[4.4-5]*/ call save_path (2); /*[4.4-5]*/ go to A0; A0: /*[4.4-5]*/ call cmcs_tree_ctl_$find_qual_name (ARG, a_index, a_eptr, d_stat_path, code); /*[4.4-5]*/ if code ^= 0 /*[4.4-5]*/ then do; d_stat_path = ""; /*[4.4-5]*/ call com_err_ (code, my_name, "illegal destination"); /*[4.4-5]*/ end; /*[4.4-5]*/ user_ctl.attach_bit = "1"b; /*[4.4-5]*/ go to read_request; /*[4.4-5]*/ declare a_index fixed bin, a_eptr ptr; /*[4.4-5]*/ declare ARG char (12); /*[4.4-5]*/ declare d_stat_path char (52); /* deactivate */ command (15): /* deactivate */ /*[4.4-5]*/ if ^user_ctl.attach_bit /*[4.4-5]*/ then do; call com_err_ (0, my_name, "Station already deactivated"); /*[4.4-5]*/ go to read_request; /*[4.4-5]*/ end; /*[4.4-5]*/ if user_ctl.iocb_ptr ^= null () /*[4.4-5]*/ then do; call iox_$close (user_ctl.iocb_ptr, code); /*[4.4-5]*/ call code_test; /*[4.4-5]*/ call iox_$detach_iocb (user_ctl.iocb_ptr, code); /*[4.4-5]*/ call code_test; /*[4.4-5]*/ end; /*[4.4-5]*/ user_ctl.attach_bit = "0"b; /*[4.4-5]*/ user_ctl.output_file = ""; /*[4.4-5]*/ user_ctl.iocb_ptr = null (); /*[4.4-5]*/ IOCB_ptr = iox_$user_output; /*[4.4-5]*/ go to read_request; save_station: proc; /*[4.4-5]*/ call req_arg_ptr (1); /*[4.4-5]*/ ARG = arg; end; save_path: proc (arg_num); /*[4.4-5]*/ declare arg_num fixed bin; /*[4.4-5]*/ call req_arg_ptr (arg_num); /*[4.4-5]*/ call exp; /*[4.4-5]*/ call iox_$attach_name /*[4.4-5]*/ ("A", /*[4.4-5]*/ user_ctl.iocb_ptr, /*[4.4-5]*/ "vfile_ " || substr (dname, 1, dsz) || ">" || substr (ename, 1, esz) || " -extend", /*[4.4-5]*/ null (), /*[4.4-5]*/ code /*[4.4-5]*/); /*[4.4-5]*/ call code_test; /*[4.4-5]*/ call iox_$open (user_ctl.iocb_ptr, 2, "0"b, code); /*[4.4-5]*/ call code_test; /*[4.4-5]*/ IOCB_ptr = user_ctl.iocb_ptr; end; code_test: proc; /*[4.4-5]*/ if code ^= 0 /*[4.4-5]*/ then do; call com_err_ (code); /*[4.4-5]*/ go to read_request; /*[4.4-5]*/ end; end; bad_attach: proc; /*[4.4-5]*/ call com_err_ (0, my_name, "Usage: attach [atation-name] "); end; /* change_cmcs_password */ admin_command (5): if test_sw then call ioa_ ("Command ""change_cmcs_password"":"); scpsw_sw = "0"b; /* check old psw before resetting it */ call ioa_ ("Old password will be requested and then new password will be requested."); call get_password; scpsw_sw = "1"b; common_password: call get_password; /* if we return here, we checked out ok */ system_ctl.password = password2; /* changed from now on */ go to read_request; /* set_cmcs_password */ admin_command (6): if test_sw then call ioa_ ("Command ""set_cmcs_password"":"); scpsw_sw = "1"b; /* don't check old psw before resetting it */ go to common_password; /* create_cmcs_queues */ admin_command (7): if test_sw then call ioa_ ("Command ""create_cmcs_queues"":"); call cmcs_create_queues_ (code); if code ^= 0 then do; call com_err_ (code, my_name); end; go to read_request; /* who am I? */ command (13): admin_command (1): if user_ctl.process_type = 2 then call ioa_ ("^a, ^a", my_brief_name, user_ctl.station_name); else call ioa_ ("^a", my_brief_name); go to read_request; /* test */ admin_command (4): call get_req_arg_count; call ioa_ ("Arg count is ^d.", arg_count); go to read_request; /* stop_mp */ admin_command (9): call cmcs_wait_ctl_$stop_mp (code); if code ^= 0 then call com_err_ (code, my_name, "Attempting to issue ""stop_mp"" command. Returning to request level."); go to read_request; /* */ /* clear_mp */ admin_command (10): call cmcs_wait_ctl_$clear_mp (code); if code ^= 0 then call com_err_ (code, my_name, "Attempting to perform clear_mp request. Returning to request level."); go to read_request; /* */ /* start_mp */ admin_command (8): call cmcs_wait_ctl_$start_mp (code); if code ^= 0 then call com_err_ (code, my_name, "Attempting to perform start_mp request. Returning to request level."); go to read_request; /* */ /* purge_queues */ admin_command (11): /* This request currently purges all queues and all records with status 1 and status 4 are deleted. Records with status 3 are moved back to status 2. Records with status 2 are left as-is. This request must be executed only when no other users of the given CMCS environment are on the system because no attempt is made to determine that a message is being processed by another process. */ if test_sw then call ioa_ ("Command ""purge_queues"":"); call cmcs_purge_queues_ (0, "1"b, code); if code ^= 0 then call com_err_ (code, my_name, "From the purge_queues request. Returning to request level."); go to read_request; /* */ /* Parsing Procedures */ get_req_cmd: proc; if ^cmd_parsed_sw then do; call parse_args; req_cmd_ptr = arg_ptr; /* save for later reference */ req_cmd_len = arg_len; end; else do; arg_ptr = req_cmd_ptr; /* retrieve previously set values */ arg_len = req_cmd_len; end; return; end /* get_req_cmd */; /* */ get_req_arg_count: proc; if ^cmd_parsed_sw then call parse_args; if ^args_parsed_sw then do; call parse_args; req_arg_count = arg_count; /* save for later reference */ args_parsed_sw = "1"b; end; else arg_count = req_arg_count; return; end /* get_req_arg_count */; /* */ req_arg_ptr: proc (arg_no); dcl arg_no fixed bin; call get_req_arg_count; /* make sure everything is set up */ arg_ptr = arg_array (arg_no).argp; arg_len = arg_array (arg_no).argl; return; end /* req_arg_ptr */; /* */ parse_args: proc; arg_count = 0; do j = 1 to max_req_args while (req_left_len > 0); i = verify (substr (req, req_left_begin, req_left_len), whitespace); /* find first nonblank */ if i ^= 0 then do; /* found another arg */ arg_count = arg_count + 1; req_left_begin = req_left_begin + i - 1; req_left_len = req_left_len - i + 1; end; else req_left_len = 0; /* no more args, stop looking */ arg_ptr = addr (substr (req, req_left_begin, 1)); i = search (substr (req, req_left_begin, req_left_len), whitespace); /* find end of arg */ if i ^= 0 then arg_len = i - 1; else arg_len = req_left_len; req_left_begin = req_left_begin + arg_len; /* set for next iteration now or later */ req_left_len = req_left_len - arg_len; if ^cmd_parsed_sw then do; cmd_parsed_sw = "1"b; /* avoid infinite loop */ code = 0; return; /* that's all we need this time */ end; arg_array (arg_count).argp = arg_ptr; arg_array (arg_count).argl = arg_len; end; /* of parse loop */ if req_left_len ^= 0 then code = error_table_$too_many_args; else code = 0; return; end /* parse_args */; /* */ set_interactive_info: proc; call user_info_$absentee_queue (i); /* to see if we're interactive */ if i ^= -1 then interactive_sw = "0"b; /* No, Virginia */ else do; interactive_sw = "1"b; /* yes, Virginia */ call user_info_$tty_data (term_id, term_type, term_channel); user_ctl.interactive_sw = "1"b; user_ctl.term_id = term_id; user_ctl.term_type = term_type; user_ctl.term_channel = term_channel; end; return; end /* set_interactive_info */; /* */ get_password: proc (); if interactive_sw /* should be done interactively but... */ then do; request_password: call read_password_ ("Input COBOL MCS password:", password1); call read_password_ ("Please repeat for verification...", password2); if password1 ^= password2 then do; call com_err_ (0, my_name, "Passwords do not match. Please repeat."); go to request_password; end; encode_password: password2 = cmcs_scramble_ (password1); /* maintain secure passwords */ if ^scpsw_sw then if password2 ^= system_ctl.password/* change, not set */ then do; /* not what it's thought to be */ call com_err_ (cmcs_error_table_$bad_password, my_name, "Returning to request level."); go to read_request; end; scpsw_sw = "0"b; /* reset so we check the next time */ end; else do; call com_err_ (error_table_$action_not_performed, my_name, "Passwords for COBOL MCS must be changed either by COBOL program or interactively."); go to read_request; end; return; end /* get_password */; /* */ fill_dest_table: proc (x_arg_no); dcl x_arg_no fixed bin; /* starting arg number */ err_sw = "0"b; dest_table_index = 0; /* initialize */ do i = x_arg_no to arg_count; call req_arg_ptr (i); station_name = arg; /* for fixed 12 char size */ call cmcs_station_ctl_$validate (station_name, station_ctl_eindex, code); if code ^= 0 then do; err_sw = "1"b; call com_err_ (code, my_name, """^a"".", station_name); end; else do; dest_table_index = dest_table_index + 1; output_cd.dest_table (dest_table_index).station_name = station_name; end; end; if err_sw then do; call com_err_ (error_table_$action_not_performed, my_name, "Please reenter request."); go to read_request; /* non-local */ end; output_cd.station_count = dest_table_index; code = 0; return; end /* fill_dest_table */; exp: proc; /*[4.4-5]*/ call expand_pathname_ (arg, dname, ename, code); /*[4.4-5]*/ call code_test; /*[4.4-5]*/ dsz = index (dname, " "); /*[4.4-5]*/ if dsz <= 0 then dsz = 168; else dsz = dsz - 1; /*[4.4-5]*/ esz = index (ename, " "); /*[4.4-5]*/ if esz <= 0 then esz = 32; else esz = esz - 1; end; /*[4.4-5]*/ declare (dsz, esz) fixed bin; test: entry (); test_sw = "1"b; return; end /* cobol_mcs */;  cobol_mcs_.pl1 05/24/89 1047.9rew 05/24/89 0834.1 97011 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_mcs_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 06/08/81 by FCH, [4.4-2], code "60" returned, BUG468 */ /* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */ /* Modified since Version 4.3 */ /* format: style3 */ cobol_mcs_: proc; dcl a_input_cdp ptr, a_output_cdp ptr, a_code fixed bin (35), a_rcv_type fixed bin, a_slew_ctl bit (36), a_buffer_ptr ptr, a_char_buffer_len char (4), a_char_max_buffer_len char (4), a_bin_buffer_len fixed bin, a_char_delim char (1), a_sw bit (1) aligned, /* flag for set/get user_ctl_exists_sw */ a_password char (*); dcl buffer_len fixed bin, max_buffer_len fixed bin, io_subtype fixed bin, code fixed bin (35), purge_ptr ptr, scrambled_password char (10), password char (10); dcl my_name char (10) int static init ("cobol_mcs_"); dcl test_sw bit (1) int static init ("0"b); dcl (addr, fixed, index, null, substr) builtin; dcl (ioa_, com_err_, sub_err_) entry options (variable); /* Both for DEBUG */ dcl sub_err_retval fixed bin (35); dcl station_count fixed bin; dcl ( error_table_$noentry, error_table_$action_not_performed ) fixed bin (35) external; dcl cleanup condition; dcl continue_to_signal_ entry (fixed bin (35)); /* */ %include cmcs_cd_dcls; %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_error_table_dcls; %include cmcs_queue_ctl; %include cmcs_station_ctl; %include cmcs_system_ctl; %include cmcs_tree_ctl; %include cmcs_user_ctl; %include cmcs_vfile_rs; /* %include cmcs_wait_ctl; */ /* */ accept: entry (a_input_cdp, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; io_subtype = 1; /* and in this case only, only 1 */ call cmcs_queue_ctl_$accept_message_count (a_input_cdp, io_subtype, a_code); return; /* */ receive: entry (a_input_cdp, a_rcv_type, a_buffer_ptr, a_bin_buffer_len, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; if a_rcv_type = 0 then io_subtype = 2; /* convert to std form, 0 input = message, no wait */ else if a_rcv_type = 1 then io_subtype = 1; /* 1 input = segment, no wait */ call cmcs_queue_ctl_$receive (a_input_cdp, io_subtype, a_buffer_ptr, a_bin_buffer_len, a_code); return; /* */ receive_wait: entry (a_input_cdp, a_rcv_type, a_buffer_ptr, a_bin_buffer_len, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; if a_rcv_type = 0 then io_subtype = 4; /* convert to std form, 0 input = message (wait) */ else if a_rcv_type = 1 then io_subtype = 3; /* 1 input = segment (wait) */ call cmcs_queue_ctl_$receive (a_input_cdp, io_subtype, a_buffer_ptr, a_bin_buffer_len, a_code); return; /* */ send: entry (a_output_cdp, a_buffer_ptr, a_char_max_buffer_len, a_char_delim, a_slew_ctl, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; io_subtype = index ("0123", a_char_delim) - 1; if io_subtype < 0 /* not 0-3 */ then io_subtype = 0; output_cdp = a_output_cdp; buffer_len = output_cd.text_len; max_buffer_len = fixed (a_char_max_buffer_len, 17); /*[4.4-2]*/ if io_subtype = 0 & (buffer_len = 0 | a_buffer_ptr = null ()) then do; output_cd.status_key = "60"; a_code = cmcs_error_table_$null_partial_message; return; end; if buffer_len > max_buffer_len then do; a_code = cmcs_error_table_$bad_message_length; output_cd.status_key = "50"; return; end; output_cd.bin_max_station_count = output_cd.char_max_station_count; station_count = output_cd.station_count; if output_cd.bin_max_station_count < station_count | station_count = 0 then do; output_cd.status_key = "30"; a_code = cmcs_error_table_$bad_dest_count; return; end; /* The following call uses parameters different than those passed to cobol_mcs_. Specifically, buffer_len and station_count are used instead of max_buffer_len (and nothing). Since the validity checks are done here, there is no reason that we must continue passing character representations of numeric data. */ call cmcs_queue_ctl_$send (a_output_cdp, io_subtype, a_buffer_ptr, buffer_len, station_count, a_slew_ctl, a_code); return; /* */ purge: entry (a_output_cdp, a_code); /* CODASYL PURGE, sends only */ /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; if a_output_cdp ^= null () then do; output_cdp = a_output_cdp; output_cd.bin_max_station_count = output_cd.char_max_station_count; station_count = output_cd.station_count; if (output_cd.bin_max_station_count < station_count) | station_count = 0 then do; output_cd.status_key = "30"; a_code = cmcs_error_table_$bad_dest_count; return; end; end; io_subtype = 1; /* sends only, per CODASYL */ call cmcs_queue_ctl_$purge (a_output_cdp, io_subtype, a_code); return; /* */ enable_input_queue: entry (a_input_cdp, a_password, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; call check_password; /* also gets fixed size password */ if a_code ^= 0 then do; input_cdp = a_input_cdp; input_cd.status_key = "40"; return; end; io_subtype = 1; call cmcs_queue_ctl_$enable (a_input_cdp, io_subtype, password, a_code); return; /* */ disable_input_queue: entry (a_input_cdp, a_password, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; call check_password; /* also gets fixed size password */ if a_code ^= 0 then do; input_cdp = a_input_cdp; input_cd.status_key = "40"; return; end; io_subtype = 1; call cmcs_queue_ctl_$disable (a_input_cdp, io_subtype, password, a_code); return; /* */ enable_input_terminal: entry (a_input_cdp, a_password, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; call check_password; /* also gets fixed size password */ if a_code ^= 0 then do; input_cdp = a_input_cdp; input_cd.status_key = "40"; return; end; io_subtype = 2; call cmcs_station_ctl_$enable_input_terminal (a_input_cdp, password, a_code); return; /* */ disable_input_terminal: entry (a_input_cdp, a_password, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; call check_password; /* also gets fixed size password */ if a_code ^= 0 then do; input_cdp = a_input_cdp; input_cd.status_key = "40"; return; end; io_subtype = 2; call cmcs_station_ctl_$disable_input_terminal (a_input_cdp, password, a_code); return; /* */ enable_output: entry (a_output_cdp, a_password, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; call check_password; /* also gets fixed size password */ if a_code ^= 0 then do; output_cdp = a_output_cdp; output_cd.status_key = "40"; return; end; io_subtype = 3; call cmcs_station_ctl_$enable_output_terminal (a_output_cdp, password, a_code); return; /* */ disable_output: entry (a_output_cdp, a_password, a_code); /*[4.4-1]*/ if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then call setup; call check_password; /* also gets fixed size password */ if a_code ^= 0 then do; output_cdp = a_output_cdp; output_cd.status_key = "40"; return; end; io_subtype = 3; call cmcs_station_ctl_$disable_output_terminal (a_output_cdp, password, a_code); return; ret: /*[4.4-1]*/ return; /* */ check_password: proc (); password = a_password; /* need fixed size */ scrambled_password = cmcs_scramble_ (password); password = ""; /* at least eliminate OUR password visibility */ if scrambled_password = system_ctl.password then a_code = 0; else a_code = cmcs_error_table_$bad_password; return; end /* check_password */; /* */ stop_run: entry (); if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs) then return; /* temporary test to see if user doesn't use cmcs */ call cmcs_queue_ctl_$stop_run (1, code); if code ^= 0 then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "From purge (and queue detach) initiated by stop_run."); return; /* end of stop_run entrypoint */ cleanup_handler: call sub_err_ (0, my_name, "c", null (), sub_err_retval, "The cleanup condition was detected. A stop_run will be simulated."); call cmcs_queue_ctl_$stop_run (1, code); if code ^= 0 then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "From purge (and queue detach) initiated by stop_run."); call continue_to_signal_ (code); if code ^= 0 then call sub_err_ (code, my_name, "c", null (), sub_err_retval, "From attempt to continue signalling up the stack. Continuing."); return; /* end of cleanup_handler code */ /* */ setup: proc; if user_ctl_exists_sw /* must be running in the proper environment */ then do; user_ctl_ptr = external_user_ctl_ptr; /* set local variable from global */ queue_ctl_ptr = user_ctl.queue_ctl_ptr; station_ctl_ptr = user_ctl.station_ctl_ptr; system_ctl_ptr = user_ctl.system_ctl_ptr; terminal_ctl_ptr = user_ctl.terminal_ctl_ptr; tree_ctl_ptr = user_ctl.tree_ctl_ptr; wait_ctl_ptr = user_ctl.wait_ctl_ptr; on cleanup go to cleanup_handler; user_ctl.init_sw.mcs = "1"b; a_code = 0; end; else do; a_code = error_table_$action_not_performed; call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Private COBOL application programs using CMCS must be run under the cobol_mcs command (execute request). Please consult with your CMCS Administrator on procedures." ); go to ret; end; end /* setup */; /* */ test: entry (); test_sw = "1"b; return; /* */ set_user_ctl_exists_sw: entry (a_sw); user_ctl_exists_sw = a_sw; return; /* */ get_user_ctl_exists_sw: entry (a_sw); a_sw = user_ctl_exists_sw; return; end /* cobol_mcs_ */;  cv_cmcs_station_ctl.rd 03/17/86 1520.5rew 03/17/86 1431.2 90279 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* Modified on 04/23/81 by FCH, [4.4-2], accept minus in station names, BUG468 */ /* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */ /* Modified since Version 4.3 */ /* This procedure converts an ASCII list of station subchannels and their correspnding default station names to a binary control segment */ /*++ BEGIN / ; / add LEX (2) / BEGIN \ / end ; / close / RETURN \ / / ERROR (1) NEXT_STMT / BEGIN \ / / ERROR (2) / RETURN \ ++*/ cv_cmcs_station_ctl: proc; dcl new_station_name char (12), j fixed bin, aclinfo_ptr ptr, /* for use by tssi_ */ temp3 char (3); dcl test_sw bit (1) int static init ("0"b); /* */ %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_station_ctl; /* */ /* automatic */ declare (APstmt, APtoken) ptr, area_ptr ptr, /* for use by lex_string_. */ arg_length fixed bin (21), /* length of command argument. */ arg_ptr ptr, /* ptr to command argument */ bitcount fixed bin (24), code fixed bin (35), dname char (168), ename char (32), i fixed bin, n_chars fixed bin (21), object_name char (32), /* entry name of output control seg */ (pntep, object_ptr) ptr, /* ptrs to base of pnte and pnt */ source_ptr ptr; /* ptr to base of persmf */ /* based */ declare arg_string char (arg_length) based (arg_ptr) unaligned; /* builtin */ declare (addr, collate, dimension, divide, index, length, null, reverse, string, substr, verify) builtin; /* conditions */ declare cleanup condition; /* entries */ declare clock_ entry () returns (fixed bin (71)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35)), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), get_group_id_ entry () returns (char (32) aligned), get_process_id_ entry () returns (bit (36)), get_wdir_ entry () returns (char (168) aligned), hcs_$delentry_seg entry (ptr, fixed bin (35)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)), (ioa_, com_err_) entry options (variable), lex_error_ entry options (variable), lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var, char (*) var, char (*) var, char (*) var), lex_string_$lex entry (ptr, fixed bin (21), fixed bin, ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)), translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)), translator_temp_$release_all_segments entry (ptr, fixed bin (35)), tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)), tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)), tssi_$clean_up_segment entry (ptr), unique_chars_ entry (bit (*)) returns (char (15) aligned); /* internal static */ declare ((BREAKS, IGBREAKS, LEXCTL, LEXDLM) char (128) varying, /*[4.4-1]*/ first_time bit (1) aligned initial ("1"b)) int static; dcl (LEGAL char (71) aligned initial ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'_-^`~ ."), my_name char (20) initial ("cv_cmcs_station_ctl"), ALPHANUMERICS char (64) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_-") /*[4.4-2]*/ ) internal static options (constant); /* external static */ declare ((error_table_$badopt, error_table_$entlong, error_table_$bad_name, error_table_$translation_failed) fixed bin (35), sys_info$max_seg_size fixed bin (18) ) external static; /* program */ call cu_$arg_ptr (1, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, my_name, "Usage: cv_cmcs_station_ctl pathname (-brief|-bf|-long|-lg)"); return; end; call expand_pathname_ (arg_string, dname, ename, code); if code ^= 0 then do; call com_err_ (code, my_name, "^a", arg_string); return; end; call cu_$arg_ptr (2, arg_ptr, arg_length, code); if code = 0 then if arg_string = "-brief" | arg_string = "-bf" then SERROR_CONTROL = "01"b; else if arg_string = "-long" | arg_string = "-lg" then SERROR_CONTROL = "10"b; else do; call com_err_ (error_table_$badopt, my_name, "^a", arg_string); return; end; source_ptr = null; /* Initialize for cleanup handler */ object_ptr = null; /* .. */ area_ptr = null; /* .. */ aclinfo_ptr = null; /* .. */ on cleanup call clean_up; call hcs_$initiate_count (dname, ename, "", bitcount, 1b, source_ptr, code); if source_ptr = null then do; report_error: call com_err_ (code, my_name, "^a>^a", dname, ename); return; end; i = index (ename, ".src") - 1; if i < 1 then do; call com_err_ (error_table_$bad_name, my_name, "Source segment must have "".src"" suffix."); return; end; if i + length (".control") > length (object_name) then do; code = error_table_$entlong; go to report_error; end; object_name = substr (ename, 1, i) || ".control"; n_chars = divide (bitcount + 8, 9, 24, 0); dname = get_wdir_ (); call tssi_$get_segment (dname, object_name, object_ptr, aclinfo_ptr, code); if code ^= 0 then do; call com_err_ (code, my_name, "^a>^a", dname, object_name); return; end; station_ctl_ptr = object_ptr; /* actual working ptr - other is generic ptr */ call cmcs_fillin_hdr_ (station_ctl_ptr, station_ctl_version, station_ctl_hdr_len, station_ctl_entry_len, code); if code ^= 0 then do; call com_err_ (code, my_name, "Setting common header data."); return; end; /*[4.4-1]*/ if first_time /*[4.4-1]*/ then do; BREAKS = substr (collate, 1, 8) || substr (collate, 10, 24) || ";:,()"; IGBREAKS = substr (BREAKS, 1, 8+24); call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL); /*[4.4-1]*/ first_time = "1"b; /*[4.4-1]*/ end; call translator_temp_$get_segment (my_name, area_ptr, code); if area_ptr = null then do; call com_err_ (code, my_name, "Making temporary segment in process directory."); return; end; call lex_string_$lex (source_ptr, n_chars, 0, area_ptr, "1000"b, """", """", "/*", "*/", ";", BREAKS, IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, code); if code ^= 0 then do; call com_err_ (code, my_name, ename); return; end; Pthis_token = APtoken; call SEMANTIC_ANALYSIS (); if MERROR_SEVERITY > 1 then do; call com_err_ (error_table_$translation_failed, my_name, ename); call hcs_$delentry_seg (object_ptr, code); end; else do; bitcount = 36 * (station_ctl_hdr_len + station_ctl_entry_len * station_ctl.current_size); call tssi_$finish_segment (object_ptr, bitcount, "101"b, aclinfo_ptr, code); if code ^= 0 then call com_err_ (code, my_name, "Unable to set bitcount on ^a>^a to ^d", dname, object_name, bitcount); end; call clean_up; /* terminate input segments */ return; /* Clean up procedure. Called if command is "quit" out of, and at end of normal processing. */ clean_up: procedure; if source_ptr ^= null then call hcs_$terminate_noname (source_ptr, code); if object_ptr ^= null then call hcs_$terminate_noname (object_ptr, code); if area_ptr ^= null then call translator_temp_$release_all_segments (area_ptr, code); if aclinfo_ptr ^= null then call tssi_$clean_up_segment (aclinfo_ptr); end /* clean_up */ ; declare 1 error_control_table (2) aligned internal static, 2 severity fixed bin (17) unaligned initial ( (2)3), 2 Soutput_stmt bit (1) unaligned initial ( "1"b, "0"b), 2 message char (64) varying initial ( "Syntax error in ""^a"" statement.", "Premature end of input encountered."), 2 brief_message char (20) varying initial ( "^a", "Premature EOF."); /* */ valid_station: proc () returns (bit (1) aligned); if test_sw then call ioa_ ("Parse: token (^a).", token_value); if token_value = "end" then return ("0"b); /* special case this name */ if length (token_value) > 12 then return ("0"b); if verify (token_value, ALPHANUMERICS) ^= 0 then return ("0"b); new_station_name = token_value; return ("1"b); end /* valid_station */ ; close: proc (); if test_sw then call ioa_ ("CLOSE"); return; end /* close */ ; /* */ add: proc (); station_ctl.entry_count, station_ctl.current_size = station_ctl.current_size + 1; string (station_ctl.flags (station_ctl.current_size)) = (36) "0"b; station_ctl.station_name (station_ctl.current_size) = new_station_name; return; end /* add */ ; /* */ test: entry; test_sw = "1"b; return; /* end of test entrypoint */  cv_cmcs_terminal_ctl.rd 03/17/86 1520.5rew 03/17/86 1431.3 105768 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* Modified on 10/27/82 by FCH, [5.1-1], term subchannel name can only start with a/b/c/d, BUG14117(phx14117) */ /* Modified on 04/23/81 by FCH, [4.4-1], accept minus in station names, BUG468 */ /* Modified on 03/03/81 by FCH, [4.4-2], once per process initialization, BUG468 */ /* Modified on 02/27/81 by FCH, [4.4-1], BUG 467(TR9227), terminal name check */ /* Modified since Version 4.3 */ /* This procedure converts an ASCII list of terminal subchannels and their correspnding default station names to a binary control segment */ /*++ BEGIN / : / LEX (2) / station \ / end ; / / RETURN \ / / ERROR (1) NEXT_STMT / BEGIN \ / / ERROR (2) / RETURN \ station / ; / add LEX (2) / BEGIN \ / / ERROR (1) NEXT_STMT / BEGIN \ / / ERROR (2) / RETURN \ ++*/ cv_cmcs_terminal_ctl: proc; dcl new_station_name char (12), new_terminal_name char (8), j fixed bin, aclinfo_ptr ptr, /* for use by tssi_ */ temp3 char (3); %include cmcs_control_hdr; %include cmcs_station_ctl; %include cmcs_terminal_ctl; %include cmcs_entry_dcls; /* automatic */ declare (APstmt, APtoken) ptr, area_ptr ptr, /* for use by lex_string_. */ arg_length fixed bin (21), /* length of command argument. */ arg_ptr ptr, /* ptr to command argument */ bitcount fixed bin (24), code fixed bin (35), dname char (168), ename char (32), i fixed bin, n_chars fixed bin (21), object_name char (32), /* entry name of output control seg */ (pntep, object_ptr) ptr, /* ptrs to base of pnte and pnt */ source_ptr ptr; /* ptr to base of persmf */ /* based */ declare arg_string char (arg_length) based (arg_ptr) unaligned; /* builtin */ declare (addr, collate, dimension, divide, index, length, null, reverse, string, substr, verify) builtin; /* conditions */ declare cleanup condition; /* entries */ declare clock_ entry () returns (fixed bin (71)), com_err_ entry options (variable), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35)), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), get_group_id_ entry () returns (char (32) aligned), get_process_id_ entry () returns (bit (36)), get_wdir_ entry () returns (char (168) aligned), hcs_$delentry_seg entry (ptr, fixed bin (35)), hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)), lex_error_ entry options (variable), lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var, char (*) var, char (*) var, char (*) var), lex_string_$lex entry (ptr, fixed bin (21), fixed bin, ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)), translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)), translator_temp_$release_all_segments entry (ptr, fixed bin (35)), tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)), tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)), tssi_$clean_up_segment entry (ptr), unique_chars_ entry (bit (*)) returns (char (15) aligned); /* internal static */ declare ((BREAKS, IGBREAKS, LEXCTL, LEXDLM) char (128) varying, /*[4.4-2]*/ first_time bit (1) aligned initial ("1"b)) int static; dcl (LEGAL char (71) aligned initial ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'_-^`~ ."), my_name char (20) initial ("cv_cmcs_terminal_ctl"), ALPHANUMERICS char (64) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_-") /*[4.4-1]*/ ) internal static options (constant); /* external static */ declare ((error_table_$badopt, error_table_$entlong, error_table_$bad_name, error_table_$translation_failed) fixed bin (35), sys_info$max_seg_size fixed bin (18) ) external static; /* program */ call cu_$arg_ptr (1, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, my_name, "Usage: cv_cmcs_terminal_ctl pathname (-brief|-bf|-long|-lg)"); return; end; call expand_pathname_ (arg_string, dname, ename, code); if code ^= 0 then do; call com_err_ (code, my_name, "^a", arg_string); return; end; call cu_$arg_ptr (2, arg_ptr, arg_length, code); if code = 0 then if arg_string = "-brief" | arg_string = "-bf" then SERROR_CONTROL = "01"b; else if arg_string = "-long" | arg_string = "-lg" then SERROR_CONTROL = "10"b; else do; call com_err_ (error_table_$badopt, my_name, "^a", arg_string); return; end; source_ptr = null; /* Initialize for cleanup handler */ object_ptr = null; /* .. */ area_ptr = null; /* .. */ aclinfo_ptr = null; /* .. */ on cleanup call clean_up; call hcs_$initiate_count (dname, ename, "", bitcount, 1b, source_ptr, code); if source_ptr = null then do; report_error: call com_err_ (code, my_name, "^a>^a", dname, ename); return; end; i = index (ename, ".src") - 1; if i < 1 then do; call com_err_ (error_table_$bad_name, my_name, "Source segment must have "".src"" suffix."); return; end; if i + length (".control") > length (object_name) then do; code = error_table_$entlong; go to report_error; end; object_name = substr (ename, 1, i) || ".control"; n_chars = divide (bitcount + 8, 9, 24, 0); dname = get_wdir_ (); call tssi_$get_segment (dname, object_name, object_ptr, aclinfo_ptr, code); if code ^= 0 then do; call com_err_ (code, my_name, "^a>^a", dname, object_name); return; end; terminal_ctl_ptr = object_ptr; /* actual working ptr - other is generic ptr */ call cmcs_fillin_hdr_ (terminal_ctl_ptr, terminal_ctl_version, terminal_ctl_hdr_len, terminal_ctl_entry_len, code); if code ^= 0 then do; call com_err_ (code, my_name, "Setting common header data."); return; end; /*[4.4-2]*/ if first_time /*[4.4-2]*/ then do; BREAKS = substr (collate, 1, 8) || substr (collate, 10, 24) || ":,()"; IGBREAKS = substr (BREAKS, 1, 8+24); call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL); call hcs_$initiate (get_wdir_ (), "cmcs_station_ctl.control", "cmcs_station_ctl.control", 0, 0, station_ctl_ptr, code); if station_ctl_ptr = null () then do; call com_err_ (code, my_name, "The cmcs_station_ctl.control segment must exist in the current working directory before this command can be run."); return; end; /*[4.4-2]*/ first_time = "1"b; /*[4.4-2]*/ end; call translator_temp_$get_segment (my_name, area_ptr, code); if area_ptr = null () then do; call com_err_ (code, my_name, "Making temporary segment in process directory."); return; end; call lex_string_$lex (source_ptr, n_chars, 0, area_ptr, "1000"b, """", """", "/*", "*/", ";", BREAKS, IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, code); if code ^= 0 then do; call com_err_ (code, my_name, ename); return; end; Pthis_token = APtoken; call SEMANTIC_ANALYSIS (); if MERROR_SEVERITY > 1 then do; call com_err_ (error_table_$translation_failed, my_name, ename); call hcs_$delentry_seg (object_ptr, code); end; else do; bitcount = 36 * (terminal_ctl_hdr_len + terminal_ctl_entry_len * terminal_ctl.current_size); call tssi_$finish_segment (object_ptr, bitcount, "100"b, aclinfo_ptr, code); if code ^= 0 then call com_err_ (code, my_name, "Unable to set bitcount on ^a>^a to ^d", dname, object_name, bitcount); end; call clean_up; /* terminate input segments */ return; /* Clean up procedure. Called if command is "quit" out of, and at end of normal processing. */ clean_up: procedure; if source_ptr ^= null then call hcs_$terminate_noname (source_ptr, code); if object_ptr ^= null then call hcs_$terminate_noname (object_ptr, code); if area_ptr ^= null then call translator_temp_$release_all_segments (area_ptr, code); if aclinfo_ptr ^= null then call tssi_$clean_up_segment (aclinfo_ptr); end /* clean_up */ ; declare 1 error_control_table (2) aligned internal static, 2 severity fixed bin (17) unaligned initial ( (2)3), 2 Soutput_stmt bit (1) unaligned initial ( "1"b, "0"b), 2 message char (64) varying initial ( "Syntax error in ""^a"" statement.", "Premature end of input encountered."), 2 brief_message char (20) varying initial ( "^a", "Premature EOF."); /* */ valid_terminal: proc () returns (bit (1) aligned); /*[4.4-1]*/ /* name of communications channel, see CC92, Apendix A */ i = length(token_value); if i < 6 | i > 32 then return("0"b); /*[5.1-1]*/ i = index("abcdefghijklmnopqrst",substr(token_value,1,1)); if i <= 0 then return("0"b); if substr(token_value,2,1) ^= "." then return("0"b); i = index("lh",substr(token_value,3,1)); if i <= 0 then return("0"b); i = cv_dec_check_(substr(token_value,4,1),j); if j ^= 0 then return("0"b); if substr(token_value,3,1) = "h" then do; if i > 5 then return("0"b); end; else do; if i > 2 then return("0"b); end; i = cv_dec_check_(substr(token_value,5,2),j); if j ^= 0 then return("0"b); /*[4.4-1]*/ new_terminal_name = token_value; return ("1"b); end /* valid_terminal */ ; valid_station: proc () returns (bit (1) aligned); if token_value = "end" then return ("0"b); /* special case */ if length (token_value) > 12 then return ("0"b); if verify (token_value, ALPHANUMERICS) ^= 0 then return ("0"b); new_station_name = token_value; do station_ctl_eindex = 1 to station_ctl.current_size; station_ctl_eptr = addr (station_ctl.entries (station_ctl_eindex)); if ^station_ctl_entry.inactive_sw then if station_ctl_entry.station_name = new_station_name then return ("1"b); end; return ("0"b); end /* valid_station */ ; /* */ add: proc (); terminal_ctl.entry_count, terminal_ctl.current_size = terminal_ctl.current_size + 1; string (terminal_ctl.flags (terminal_ctl.current_size)) = (36) "0"b; terminal_ctl.device_channel (terminal_ctl.current_size) = new_terminal_name; terminal_ctl.station_name (terminal_ctl.current_size) = new_station_name; return; end /* add */ ;  cv_cmcs_tree_ctl.rd 03/17/86 1520.5rew 03/17/86 1430.1 207414 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* Modified on 10/02/81 by FCH, incorrect diags sometimes generated, BUG512 */ /* Modified on 06/01/81 by FCH, [4.4-2], once per process initialization, BUG468 */ /* Modified on 04/22/81 by FCH, [4.4-1], accept 01 as level number, accept minus in queue names, BUG468 */ /* Modified since Version 4.3 */ /* This procedure converts the ASCII definition of a COBOL MCS queue hierarchy into its binary representation. */ /*++ BEGIN / dcl 1 / / do_init \ / dcl 01 / / do_init \ / declare 1 / / do_init \ / declare 01 / / do_init \ / end ; / close_db / fini \ / / ERROR (1) NEXT_STMT / BEGIN \ / / ERROR (2) / abort \ do_init / / init_tree LEX (2) / get_level_name \ get_level_name / / set_level_name LEX (1) / follow \ / / ERROR (3) NEXT_STMT / BEGIN \ / / ERROR (2) / abort \ follow / , / close_tree_level LEX (1) / get_level_no \ / ; / close_tree LEX (1) / BEGIN \ / queue_name / LEX (1) / get_queue_name \ / command_line / LEX (1) / get_command_line \ / mp_line / LEX (1) / get_mp_line \ / cobol_program_id / LEX (1) / get_program_id \ follow_error / / ERROR (4) NEXT_STMT / BEGIN \ / / ERROR (2) / abort \ get_queue_name / / set_queue_name LEX (1) / follow \ / / ERROR (5) NEXT_STMT / BEGIN \ / / ERROR (6) / abort \ get_command_line / / set_command_line LEX (1) / follow \ / / ERROR (10) NEXT_STMT / BEGIN \ / / ERROR (7) / abort \ get_mp_line / / set_mp_line LEX (1) / follow \ / / ERROR (10) NEXT_STMT / BEGIN \ / / ERROR (1) / abort \ get_program_id / / set_program_id LEX (1) / follow \ / / ERROR (11) NEXT_STMT / BEGIN \ / / ERROR (1) / abort \ get_level_no / / open_tree_level LEX (1) / get_level_name \ / / ERROR (8) NEXT_STMT / BEGIN \ / / ERROR (9) / abort \ abort / / / RETURN \ fini / / / RETURN \ ++*/ cv_cmcs_tree_ctl: proc; dcl new_station_name char (12), new_terminal_name char (8), j fixed bin, aclinfo_ptr ptr, /* for use by tssi_ */ queue_name char (32), temp3 char (3); /* */ %include cmcs_control_hdr; %include cmcs_entry_dcls; %include cmcs_station_ctl; %include cmcs_tree_ctl; %include cmcs_vfile_rs; /* */ /* automatic */ /* levels structure, used to keep control information until the complete level entry is ready to be inserted into the tree_ctl structure */ dcl (current_level, previous_level, queue_level) fixed bin; dcl 1 levels (4), 2 flags, (3 cmd_sw bit (1), 3 mp_sw bit (1), 3 cobol_program_id_sw bit (1), 3 queue_sw bit (1), 3 filler bit (33)) unaligned, 2 tree_entry_index fixed bin, 2 subtree_count fixed bin, 2 level_name char (12), 2 queue_name char (32), 2 cmd_line_len fixed bin, 2 cmd_line char (128), 2 mp_line_len fixed bin, 2 mp_line char (128), 2 cobol_program_id_len fixed bin, 2 cobol_program_id char (128); declare (APstmt, APtoken) ptr, area_ptr ptr, /* for use by lex_string_. */ arg_length fixed bin (21), /* length of command argument. */ arg_ptr ptr, /* ptr to command argument */ bitcount fixed bin (24), code fixed bin (35), dname char (168), ename char (32), i fixed bin, n_chars fixed bin (21), object_name char (32), /* entry name of output control seg */ (pntep, object_ptr) ptr, /* ptrs to base of pnte and pnt */ source_ptr ptr; /* ptr to base of persmf */ /* based */ declare arg_string char (arg_length) based (arg_ptr) unaligned; dcl tree_ctl_entry_overlay (size (tree_ctl_entry)) fixed bin based (tree_ctl_eptr); /* used to zero out the entry before setting */ /* builtin */ declare (addr, collate, dimension, divide, index, length, null, reverse, size, string, substr, verify) builtin; /* conditions */ declare cleanup condition; /* entries */ declare clock_ entry () returns (fixed bin (71)), com_err_ entry options (variable), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35)), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), get_group_id_ entry () returns (char (32) aligned), get_process_id_ entry () returns (bit (36)), get_wdir_ entry () returns (char (168) aligned), hcs_$delentry_seg entry (ptr, fixed bin (35)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)), (ioa_, ioa_$ioa_switch) entry options (variable), lex_error_ entry options (variable), lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var, char (*) var, char (*) var, char (*) var), lex_string_$lex entry (ptr, fixed bin (21), fixed bin, ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)), translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)), translator_temp_$release_all_segments entry (ptr, fixed bin (35)), tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)), tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)), tssi_$clean_up_segment entry (ptr), unique_chars_ entry (bit (*)) returns (char (15) aligned); /* internal static */ declare ((BREAKS, IGBREAKS, LEXCTL, LEXDLM) char (128) varying, test_sw bit (1) init ("0"b), /*[4.4-2]*/ first_time bit (1) aligned initial ("1"b)) int static; dcl (LEGAL char (71) aligned initial ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'_-^`~ ."), my_name char (16) initial ("cv_cmcs_tree_ctl"), alphanumerics char (64) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_-") /*[4.4-1]*/ ) internal static options (constant); dcl letters char (52) defined (alphanumerics); /* external static */ declare ((error_table_$badopt, error_table_$entlong, error_table_$bad_name, error_table_$translation_failed) fixed bin (35), sys_info_$max_seg_size fixed bin (18) ) external static; /* */ call cu_$arg_ptr (1, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, my_name, "Usage: cv_cmcs_tree_ctl pathname (-brief|-bf|-long|-lg)"); return; end; call expand_pathname_ (arg_string, dname, ename, code); if code ^= 0 then do; call com_err_ (code, my_name, "^a", arg_string); return; end; call cu_$arg_ptr (2, arg_ptr, arg_length, code); if code = 0 then if arg_string = "-brief" | arg_string = "-bf" then SERROR_CONTROL = "01"b; else if arg_string = "-long" | arg_string = "-lg" then SERROR_CONTROL = "10"b; else do; call com_err_ (error_table_$badopt, my_name, "^a", arg_string); return; end; /*[5.0-1]*/ current_level,queue_level = 0; source_ptr = null; /* Initialize for cleanup handler */ object_ptr = null; /* .. */ area_ptr = null; /* .. */ aclinfo_ptr = null; /* .. */ on cleanup call clean_up; call hcs_$initiate_count (dname, ename, "", bitcount, 1b, source_ptr, code); if source_ptr = null then do; report_error: call com_err_ (code, my_name, "^a>^a", dname, ename); return; end; i = index (ename, ".src") - 1; if i < 1 then do; call com_err_ (error_table_$bad_name, my_name, "Source segment must have "".src"" suffix."); return; end; if i + length (".control") > length (object_name) then do; code = error_table_$entlong; go to report_error; end; object_name = substr (ename, 1, i) || ".control"; n_chars = divide (bitcount + 8, 9, 24, 0); dname = get_wdir_ (); call tssi_$get_segment (dname, object_name, object_ptr, aclinfo_ptr, code); if code ^= 0 then do; call com_err_ (code, my_name, "^a>^a", dname, object_name); return; end; /* Initialize Header Info */ tree_ctl_ptr = object_ptr; /* actual working ptr - other is generic ptr */ call cmcs_fillin_hdr_ (object_ptr, tree_ctl_version, tree_ctl_hdr_len, tree_ctl_entry_len, code); if code ^= 0 then call com_err_ (code, my_name, "Continuing compilation."); tree_ctl.queue_count = 0; /* not part of common hdr */ /* */ /*[4.4-2]*/ if first_time then do; BREAKS = substr (collate, 1, 8) || substr (collate, 10, 24) || ":,()"; IGBREAKS = substr (BREAKS, 1, 8+24); call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL); /*[4.4-2]*/ first_time = "1"b; end; call translator_temp_$get_segment (my_name, area_ptr, code); if area_ptr = null then do; call com_err_ (code, my_name, "Making temporary segment in process directory."); return; end; call lex_string_$lex (source_ptr, n_chars, 0, area_ptr, "1000"b, """", """", "/*", "*/", ";", BREAKS, IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, code); if code ^= 0 then do; call com_err_ (code, my_name, ename); return; end; Pthis_token = APtoken; call SEMANTIC_ANALYSIS (); if MERROR_SEVERITY > 1 then do; call com_err_ (error_table_$translation_failed, my_name, ename); call hcs_$delentry_seg (object_ptr, code); end; else do; bitcount = 36 * (tree_ctl_hdr_len + tree_ctl_entry_len * tree_ctl.current_size); call tssi_$finish_segment (object_ptr, bitcount, "101"b, aclinfo_ptr, code); /* rw, still needs copysw */ if code ^= 0 then call com_err_ (code, my_name, "Unable to set bitcount on ^a>^a to ^d", dname, object_name, bitcount); end; call clean_up; /* terminate input segments */ return; /* Clean up procedure. Called if command is "quit" out of, and at end of normal processing. */ clean_up: procedure; if source_ptr ^= null then call hcs_$terminate_noname (source_ptr, code); if object_ptr ^= null then call hcs_$terminate_noname (object_ptr, code); if area_ptr ^= null then call translator_temp_$release_all_segments (area_ptr, code); if aclinfo_ptr ^= null then call tssi_$clean_up_segment (aclinfo_ptr); end /* clean_up */ ; declare 1 error_control_table (11) aligned internal static, 2 severity fixed bin (17) unaligned initial ( (11) 3), 2 Soutput_stmt bit (1) unaligned initial ( "1"b, (10) (1) "0"b), 2 message char (96) varying initial ( "New declarations must begin with ""declare 01"" or ""dcl 01"": ^a", /* 01 */ "Premature end of input encountered.", /* 02 */ "Invalid level name: ^a", /* 03 */ "Level name must be followed by "","", queue, command, mp, or "";""", /* 04 */ "Invalid queue name: ^a", /* 05 */ "Unexpected EOF in source segment. Looking for queue name. ^a", /* 06 */ "Unexpected EOF in source segment. Looking for command line. ^a", /* 07 */ "Invalid tree level: ^a", /* 08 */ "Unexpected EOF in source segment. Looking for tree level number. ^a", /* 09 */ "Need quoted string for command or mp line: ^a", /* 10 */ "Bad program-id for cobol_program_id: ^a"), /* 11 */ 2 brief_message char (24) varying initial ( "Bad Declare: ^a", /* 01 */ "Unexpected EOF", /* 02 */ "Bad level name: ^a", /* 03 */ "Bad level args: ^a", /* 04 */ "Bad Queue Name: ^a", /* 05 */ "Msg Queue Name: ^a", /* 06 */ "Msg Command Line: ^a", /* 07 */ "Bad Tree Level: ^a", /* 08 */ "Msg Tree Level: ^a", /* 09 */ "Need quoted string ^a", /* 10 */ "Bad program-id ^a"); /* 11 */ /* */ /* */ valid_level: proc () returns (bit (1) aligned); if test_sw then call ioa_ ("Parse: valid_level: ""^a"".", token_value); i = cv_dec_check_ (token_value, j); if j ^= 0 then return ("0"b); if (i < 1 | i > 4) then return ("0"b); if i > current_level then do; if i > current_level + 1 then return ("0"b); if queue_level = current_level then return ("0"b); end; else do; /* new level <= current level */ if queue_level = 0 then return ("0"b); /* didn't specify a queue name for abs tree path */ else if queue_level ^= current_level then return ("0"b); /* should never find this */ queue_level = 0; /* last level had good queue, set up for next time */ end; previous_level = current_level; current_level = i; return ("1"b); end /* valid_level */ ; /* */ valid_program_id: proc () returns (bit (1) aligned); if test_sw then call ioa_ ("Parse: valid_program_id: ""^a"".", token_value); if length (token_value) > 30 then return ("0"b); /* COBOL variables limited to 30 chars */ if verify (token_value, alphanumerics) > 0 then return ("0"b); if index (letters, substr (token_value, 1, 1)) = 0 then return ("0"b); /* 1st char must be letter */ return ("1"b); end /* valid_program_id */ ; /* */ valid_queue_name: proc () returns (bit (1) aligned); if test_sw then call ioa_ ("Parse: valid_queue_name: ""^a"".", token_value); if length (token_value) > 21 then return ("0"b); /* COBOL queue names limited to 21 chars, plus suffix */ if verify (token_value, alphanumerics) > 0 then return ("0"b); if index (letters, substr (token_value, 1, 1)) = 0 then return ("0"b); /* 1st char must be letter */ return ("1"b); end /* valid_queue_name */ ; /* */ valid_level_name: proc () returns (bit (1) aligned); if test_sw then call ioa_ ("Parse: valid_level_name: ""^a"".", token_value); if length (token_value) > 12 then return ("0"b); /* COBOL variables limited to 12 chars */ if verify (token_value, alphanumerics) > 0 then return ("0"b); if index (letters, substr (token_value, 1, 1)) = 0 then return ("0"b); /* 1st char must be letter */ return ("1"b); end /* valid_level_name */ ; /* */ close_db: proc (); if test_sw then call ioa_ ("Semantics: close_db: ""^a"".", token_value); return; end /* close_db */ ; /* */ close_tree: proc (); if test_sw then call ioa_ ("Semantics: close_tree: ""^a"".", token_value); call close_tree_level; end /* close_tree */ ; /* */ close_tree_level: proc (); if test_sw then call ioa_ ("Semantics: close_tree_level: ""^a"".", token_value); i = levels (current_level).tree_entry_index; /* get location of tree_ctl_entry */ tree_ctl_eptr = addr (tree_ctl.entries (i)); /* for based operations */ tree_ctl_entry_overlay (*) = 0; /* wipe the slate clean */ tree_ctl_entry.level_no = current_level; /* for perusing the tree elsewhere */ tree_ctl_entry.cmd_sw = levels (current_level).cmd_sw; tree_ctl_entry.queue_sw = levels (current_level).queue_sw; tree_ctl_entry.mp_sw = levels (current_level).mp_sw; tree_ctl_entry.cobol_program_id_sw = levels (current_level).cobol_program_id_sw; queue_name, tree_ctl_entry.queue_name = levels (current_level).queue_name; tree_ctl_entry.cmd_line_len = levels (current_level).cmd_line_len; tree_ctl_entry.mp_line_len = levels (current_level).mp_line_len; tree_ctl_entry.cmd_line = levels (current_level).cmd_line; /* set ptr variables to null () for subsequent testing */ tree_ctl_entry.queue_ctl_eptr, tree_ctl_entry.iocb_ptr, tree_ctl_entry.msg_hdr_ptr, tree_ctl_entry.msg_seg_ptr, tree_ctl_entry.buffer_ptr, tree_ctl_entry.tseg_ptr = null (); tree_ctl_entry.switch_name = ""; /* so we dont print junk for unused entries */ tree_ctl_entry.mp_line = levels (current_level).mp_line; tree_ctl_entry.cobol_program_id_len = levels (current_level).cobol_program_id_len; tree_ctl_entry.cobol_program_id = levels (current_level).cobol_program_id; do i = 1 to 4; /* copy all level names, including blank trailing names */ tree_ctl_entry.level_names (i) = levels (i).level_name; end; do i = 1 to current_level; /* copy all the subtree counts */ j = levels (i).tree_entry_index; /* index into tree_ctl for the given entry */ tree_ctl.entries (j).subtree_count = levels (i).subtree_count; end; if tree_ctl_entry.queue_sw /* if entry is for queue, bump count */ then do; /* it's an entry for a queue */ do j = 1 to tree_ctl.current_size - 1; if queue_name = tree_ctl.entries (j).queue_name then do; tree_ctl_entry.queue_ctl_eindex = tree_ctl.entries (j).queue_ctl_eindex; /* point to the first occurrance */ go to close_tree_level_ret; end; end; tree_ctl_entry.queue_ctl_eindex, tree_ctl.queue_count = tree_ctl.queue_count + 1; /* drop-thru means first occurance */ end; close_tree_level_ret: return; end /* close_tree_level */ ; /* */ init_tree: proc (); if test_sw then call ioa_ ("Semantics: init_tree: ""^a"".", token_value); current_level, previous_level = 1; /* initialize for new set */ call open_tree_level; return; end /* init_tree */ ; /* */ open_tree_level: proc (); if test_sw then call ioa_ ("Semantics: open_tree_level: ""^a"".", token_value); tree_ctl.current_size, tree_ctl.entry_count = tree_ctl.current_size + 1; /* next place to store an entry */ levels (current_level).tree_entry_index = tree_ctl.current_size; /* remember it */ if current_level = 1 then do; string (levels (1).flags) = (36) "0"b; levels (1).level_name, levels (2).level_name, levels (3).level_name, levels (4).level_name, levels (1).queue_name, levels (1).cmd_line, levels (1).mp_line, levels (1).cobol_program_id = ""; levels (1).subtree_count, levels (1).cmd_line_len, levels (1).mp_line_len, levels (1).cobol_program_id_len = 0; end; else do; /* current_level ^= 1 */ do j = 1 to current_level - 1; levels (j).subtree_count = levels (j).subtree_count + 1; /* bump all ancestor counts by 1 */ end; if current_level ^= 4 /* clear out all following level names */ then do i = current_level + 1 to 4; /* just the trailing fields */ levels (i).level_name = ""; end; j = current_level - 1; /* copy from prev level, newer args overlay */ string (levels (current_level).flags) = string (levels (j).flags); levels (current_level).level_name = levels (j).level_name; levels (current_level).queue_name = levels (j).queue_name; levels (current_level).subtree_count = 0; levels (current_level).cmd_line_len = levels (j).cmd_line_len; levels (current_level).cmd_line = levels (j).cmd_line; levels (current_level).mp_line_len = levels (j).mp_line_len; levels (current_level).mp_line = levels (j).mp_line; levels (current_level).cobol_program_id_len = levels (j).cobol_program_id_len; levels (current_level).cobol_program_id = levels (j).cobol_program_id; if current_level > previous_level then if previous_level = queue_level then call ioa_ ("Warning: higher level follows queue_name level."); else; else queue_level = 0; /* ok - reset for next time */ end; return; end /* open_tree_level */ ; /* */ set_mp_line: proc (); if test_sw then call ioa_ ("Semantics: set_mp_line: ""^a"".", token_value); if length (token_value) > 128 then do; levels (current_level).mp_line_len = 128; /* truncate and push on to catch other errors */ levels (current_level).mp_line = substr (token_value, 1, 128); if test_sw then call ioa_ ("Warning: mp line truncated to 128 chars. Continuing."); end; else do; levels (current_level).mp_line_len = length (token_value); levels (current_level).mp_line = token_value; end; levels (current_level).mp_sw = "1"b; return; end /* set_mp_line */ ; /* */ set_command_line: proc (); if test_sw then call ioa_ ("Semantics: set_command_line: ""^a"".", token_value); if length (token_value) > 128 then do; levels (current_level).cmd_line_len = 128; /* truncate and push on to catch other errors */ levels (current_level).cmd_line = substr (token_value, 1, 128); if test_sw then call ioa_ ("Warning: command line truncated to 128 chars. Continuing."); end; else do; levels (current_level).cmd_line_len = length (token_value); levels (current_level).cmd_line = token_value; end; levels (current_level).cmd_sw = "1"b; call ioa_ ("Warning: The command_line arguments are ignored in this version."); /* just so they know */ return; end /* set_command_line */ ; /* */ set_program_id: proc (); if test_sw then call ioa_ ("Semantics: set_program_id: ""^a"".", token_value); levels (current_level).cobol_program_id_len = length (token_value); levels (current_level).cobol_program_id = token_value; levels (current_level).cobol_program_id_sw = "1"b; return; end /* set_program_id */ ; /* */ set_queue_name: proc (); if test_sw then call ioa_ ("Semantics: set_queue_name: ""^a"".", token_value); levels (current_level).queue_name = token_value; queue_level = current_level; /* to check that queue was given when needed */ levels (current_level).queue_sw = "1"b; return; end /* set_queue_name */ ; /* */ set_level_name: proc (); if test_sw then call ioa_ ("Semantics: set_level_name: ""^a"".", token_value); levels (current_level).level_name = token_value; return; end /* set_level_name */ ; test: entry; /* used to print out parse and semantics calls */ test_sw = "1"b; return; 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