linus_apply.pl1 07/29/86 1051.7r w 07/29/86 0939.5 36243 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ /* This is the main level procedure called by ssu_ to implement the linus apply request. Description and usage follows. Description: This request allows a user to edit the current query or a new query through use of apply. Usage: apply {-new | -old} command_line The control argument -new specifies that the user should start off with an empty query. The control argument -old specifies that the user should use the existing query. -old is the default. Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_apply: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; /* Mainline Processing Overview: (1) Check to make sure a data base is open. Process control args. (2) Get the subroutine to apply the query. */ call initialize; if new_or_old_query_flag | lcb.liocb_ptr = null then call linus_query_mgr$initialize_query_file (lcb_ptr); call linus_query_mgr$get (lcb_ptr, query_segment_ptr, query_segment_length, code); if code ^= 0 & code ^= linus_error_$no_current_query then call ssu_$abort_line (sci_ptr, code); call ssu_$apply_request_util (sci_ptr, first_command_argument, query_segment_ptr, query_segment_length, new_length); call linus_query_mgr$put (lcb_ptr, query_segment_ptr, new_length, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); return; initialize: proc; sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; if lcb.db_index = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_db); new_or_old_query_flag = OFF; call ssu_$arg_count (sci_ptr, number_of_args_supplied); first_command_argument = 0; do current_arg_number = 1 to number_of_args_supplied while (first_command_argument = 0); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg = "-new" then new_or_old_query_flag = ON; else if arg = "-old" then new_or_old_query_flag = OFF; else do; first_command_argument = current_arg_number; return; end; end; call ssu_$abort_line (sci_ptr, 0, "Usage: apply {-new | -old} command_line"); return; end initialize; dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; dcl code fixed bin (35); dcl current_arg_number fixed bin; dcl first_command_argument fixed bin; dcl fixed builtin; dcl linus_error_$no_current_query fixed bin(35) ext static; dcl linus_error_$no_db fixed bin(35) ext static; dcl linus_query_mgr$get entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl linus_query_mgr$initialize_query_file entry (ptr); dcl linus_query_mgr$put entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl new_length fixed bin (21); dcl new_or_old_query_flag bit (1) aligned; dcl null builtin; dcl number_of_args_supplied fixed bin; dcl query_segment_ptr ptr; dcl query_segment_length fixed bin (21); dcl rel builtin; dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$apply_request_util entry (ptr, fixed bin, ptr, fixed bin(21), fixed bin(21)); dcl sys_info$max_seg_size fixed bin(35) ext static; %page; %include linus_lcb; end linus_apply;  linus_column_value.pl1 07/29/86 1051.7r w 07/29/86 0939.5 84798 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus column_value request. Description and usage follows. Description: This active request returns the value of the current column, the previous column, or the next column. The column is named by the caller. If subtotals or totals are being generated, the subtotal or total for the referenced column is returned. Usage: "column_value STR {-control_args}" where STR is the name or number of the desired column. -control_args can be "-current_row", "-next_row", "-previous_row", or "-default STR". Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_column_value: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(3); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(3); call initialize; call verify_column_name_or_number; if status.flags.subtotals_ejection_in_progress then call get_subtotal_value; else if status.flags.totals_ejection_in_progress then call get_total_value; else call get_column_value; %skip(1); spare_string_length = length (spare_string); spare_string_redefined_ptr = addrel (addr (spare_string), 1); return_value = requote_string_ (spare_string_redefined_as_nonvarying); %skip(1); return; %page; get_column_value: proc; %skip(3); if (status.flags.first_row_of_report & previous_row) | (status.flags.last_row_of_report & next_row) then do; spare_string = default_return_value; return; end; %skip(1); if previous_row then row_value_p = status.previous_row_ptr; else if next_row then row_value_p = status.next_row_ptr; else row_value_p = status.current_row_ptr; %skip(1); spare_string = substr (row_value, table_info.columns.column_index (column_number), table_info.columns.column_length (column_number)); %skip(1); return; %skip(1); end get_column_value; %page; get_subtotal_value: proc; %skip(3); not_found = ON; subtotal_ip = format_report_info.subtotal_info_ptr; %skip(1); do loop = 1 to subtotal_info.number_of_columns_to_subtotal while (not_found); if column_number = subtotal_info.columns (loop).input_column & subtotal_info.columns (loop).level = subtotal_info.current_level then do; not_found = OFF; subtotal_number = loop; end; end; if not_found then do; call get_column_value; return; end; %skip(1); call ioa_$rsnnl (subtotal_info.columns.ioa_string (subtotal_number), spare_string, spare_string_length, subtotal_info.columns.subtotal (subtotal_number)); %skip(1); return; %skip(1); end get_subtotal_value; %page; get_total_value: proc; %skip(3); not_found = ON; total_ip = format_report_info.total_info_ptr; %skip(1); do loop = 1 to total_info.number_of_columns_to_total while (not_found); if column_number = total_info.input_column (loop) then do; not_found = OFF; total_number = loop; end; end; if not_found then do; call get_column_value; return; end; %skip(1); call ioa_$rsnnl (total_info.columns.ioa_string (total_number), spare_string, spare_string_length, total_info.columns.total (total_number)); %skip(1); return; %skip(1); end get_total_value; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); next_row = OFF; previous_row = OFF; current_row = ON; default_return_value = ""; %skip(1); call ssu_$return_arg (sci_ptr, number_of_args_supplied, active_request_flag, return_value_ptr, return_value_length); if number_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A column name or number must be supplied."); %skip(1); report_cip = lcb.report_control_info_ptr; if report_cip = null () then call ssu_$abort_line (sci_ptr, linus_error_$no_report); else if ^report_control_info.flags.report_has_been_started then call ssu_$abort_line (sci_ptr, linus_error_$no_report); %skip(1); format_report_ip = report_control_info.format_report_info_ptr; table_ip = format_report_info.table_info_ptr; row_segs_ip = table_info.row_segs_info_ptr; status_pointer = format_report_info.status_ptr; %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); column_identifier = arg; %skip(1); if number_of_args_supplied = 1 then return; %page; current_arg_number = 2; still_processing_args = ON; %skip(1); do loop = 2 to number_of_args_supplied while (still_processing_args); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg = "-current_row" | arg = "-crw" then do; current_row = ON; previous_row = OFF; next_row = OFF; end; else if arg = "-next_row" | arg = "-nrw" then do; next_row = ON; current_row = OFF; previous_row = OFF; end; else if arg = "-previous_row" | arg = "-prw" then do; previous_row = ON; current_row = OFF; next_row = OFF; end; else if arg = "-default" | arg = "-df" then do; if current_arg_number >= number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-default must be followed by a value."); else; current_arg_number = current_arg_number + 1; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); default_return_value = arg; end; else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a is not a valid control argument.", arg); current_arg_number = current_arg_number + 1; if current_arg_number > number_of_args_supplied then still_processing_args = OFF; end; %skip(1); return; %skip(1); end initialize; %page; verify_column_name_or_number: proc; %skip(3); if verify (column_identifier, DIGITS) = 0 then do; column_number = convert (column_number, column_identifier); if column_number < 1 | column_number > table_info.column_count then call ssu_$abort_line (sci_ptr, 0, "^d is not a valid column number.", column_number); else; end; else do; not_found = ON; do loop = 1 to table_info.column_count while (not_found); if column_identifier = table_info.columns.column_name (loop) then do; not_found = OFF; column_number = loop; end; end; if not_found then call ssu_$abort_line (sci_ptr, 0, "^a is not a valid column name.", column_identifier); end; %skip(1); return; %skip(1); end verify_column_name_or_number; %page; dcl DIGITS char (10) static int options (constant) init ("0123456789"); dcl OFF bit (1) aligned static int options (constant) init ("0"b); dcl ON bit (1) aligned static int options (constant) init ("1"b); %skip(1); dcl active_request_flag bit (1) aligned; dcl addr builtin; dcl addrel builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl column_number fixed bin; dcl column_identifier char (128) varying; dcl convert builtin; dcl current_arg_number fixed bin; dcl current_row bit (1) aligned; %skip(1); dcl default_return_value char (128) varying; %skip(1); dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl ioa_$rsnnl entry() options(variable); %skip(1); dcl length builtin; dcl linus_error_$no_report fixed bin(35) ext static; dcl loop fixed bin; %skip(1); dcl next_row bit (1) aligned; dcl not_found bit (1) aligned; dcl null builtin; dcl number_of_args_supplied fixed bin; %skip(1); dcl previous_row bit (1) aligned; %skip(1); dcl rel builtin; dcl requote_string_ entry (char(*)) returns(char(*)); dcl return_value char (return_value_length) varying based (return_value_ptr); dcl return_value_length fixed bin (21); dcl return_value_ptr ptr; %skip(1); dcl sci_ptr ptr; dcl spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl spare_string_length fixed bin (21); dcl spare_string_redefined_as_nonvarying char (spare_string_length) based (spare_string_redefined_ptr); dcl spare_string_redefined_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); dcl still_processing_args bit (1) aligned; dcl substr builtin; dcl subtotal_number fixed bin; dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl total_number fixed bin; %skip(1); dcl verify builtin; %page; %include arg_descriptor; %page; %include arg_list; %page; %include linus_options_extents; %page; %include linus_lcb; %page; %include linus_report_info; %page; %include linus_report_structures; %page; %include linus_table_info; %skip(3); end linus_column_value;  linus_create_data_file.pl1 10/24/88 1648.3r w 10/24/88 1400.3 145800 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-01-27,Dupuis), approve(88-03-03,MCR7844), audit(88-03-14,Blair), install(88-03-15,MR12.2-1036): Implemented the -progress/-no_progress control arguments. END HISTORY COMMENTS */ /* format: off */ %skip(3); /* This is the subroutine called by the linus write and write_data_file requests to implement the file writing. Description and usage follows. Description: This subroutine retrieves the selected data from the data base and writes it to a file which can later be input to the store_data_file request, and sometimes to the linus store request if the delimiters don't get in the way. Usage: "call linus_create_data_file (lcb_ptr, addr (data_file_info)); Known Bugs: Other Problems: History: Written - Al Dupuis - September 1983. */ %page; linus_create_data_file: proc ( lcb_ptr_parm, /* input: ptr to the linus control block info structure */ data_file_info_ptr_parm /* input: ptr to the data_file_info structure */ ); %skip(3); dcl data_file_info_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(3); /* Mainline Processing Overview: (1) Check that a data base is open and a translated query is available. (2) Attach and open output file. (3) Begin a new table and have first row retrieved. (4) Write the row to the output file, retrieve another and repeat. (5) Close file and delete table. */ %page; %skip(3); call initialize; if lcb.db_index = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_db); %skip(1); if lcb.si_ptr = null then do; call linus_translate_query$auto (sci_ptr, lcb_ptr); if lcb.si_ptr = null then call ssu_$abort_line (sci_ptr, 0); end; %skip(1); cleanup_signalled = OFF; on cleanup begin; cleanup_signalled = ON; call terminate; end; %skip(1); call setup_for_retrieval; still_retrieving = ON; %skip(1); do while (still_retrieving); call write_row_to_output_file; call linus_table$get_row (lcb_ptr, row_value_p, code); if code ^= 0 then if code = mrds_error_$tuple_not_found then still_retrieving = OFF; else call ssu_$abort_line (sci_ptr, code); else; end; %skip(1); call terminate; %skip(1); return; %page; initialize: proc; %skip(3); lcb_ptr = lcb_ptr_parm; file_info_ptr = data_file_info_ptr_parm; %skip(1); sci_ptr = lcb.subsystem_control_info_ptr; truncate = file_info.flags.truncate_file; %skip(1); checking_values = file_info.flags.check_values_for_delimiters; the_column_delimiter = file_info.column_delimiter; the_row_delimiter = file_info.row_delimiter; if checking_values then special_characters = the_column_delimiter || the_row_delimiter || QUOTE; %skip(1); creating_new_columns = file_info.flags.create_new_columns; if creating_new_columns then create_cm_ptr = file_info.create_columns_map_ptr; else create_cm_ptr = null; %skip(1); file_is_attached = OFF; file_is_opened = OFF; table_has_been_started = OFF; temp_segment_has_been_acquired = OFF; output_columns_map_has_been_allocated = OFF; %skip(1); return; %skip(1); end initialize; %page; setup_for_retrieval: proc; %skip(3); dcl sfr_current_table_column_number fixed bin; dcl sfr_inner_loop fixed bin; dcl sfr_loop fixed bin; dcl sfr_new_column_found bit (1) aligned; %skip(1); %skip(1); call linus_table$translate_query (lcb_ptr, table_ip, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); call linus_table$new_table (lcb_ptr, get_pdir_ (), TEMPORARY_TABLE, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); table_has_been_started = ON; %skip(1); call linus_table$info (lcb_ptr, table_ip, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); row_segs_ip = table_info.row_segs_info_ptr; row_ptrs_p = row_segs_info.seg_ptr (1); row_value_p = row_ptrs.row_value_ptr (1); number_of_output_columns = table_info.column_count; if creating_new_columns then number_of_output_columns = number_of_output_columns + create_columns_map.number_of_columns; allocate output_columns_map in (lcb.static_area) set (output_columns_map_ptr); output_columns_map_has_been_allocated = ON; output_columns_map.columns.index (*) = 0; output_columns_map.columns.length (*) = 0; output_columns_map.columns.value (*) = ""; %skip(1); sfr_current_table_column_number = 1; do sfr_loop = 1 to number_of_output_columns; sfr_new_column_found = OFF; if creating_new_columns then do sfr_inner_loop = 1 to create_columns_map.number_of_columns while (^sfr_new_column_found); if create_columns_map.column_numbers (sfr_inner_loop) = sfr_loop then sfr_new_column_found = ON; else; end; if ^sfr_new_column_found then do; output_columns_map.columns (sfr_loop).index = table_info.columns.column_index (sfr_current_table_column_number); output_columns_map.columns (sfr_loop).length = table_info.columns.column_length (sfr_current_table_column_number); sfr_current_table_column_number = sfr_current_table_column_number + 1; end; else; end; %skip(1); current_row_number = 0; %skip(1); call linus_temp_seg_mgr$get_segment (lcb_ptr, CREATE_DATA_FILE, "", buffer_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to acquire a temporary segment."); temp_segment_has_been_acquired = ON; buffer_length = sys_info$max_seg_size * 4 - 4; one_word_past_buffer_ptr = addrel (buffer_ptr, 1); %skip(1); spare_buffer_as_non_varying_ptr = addrel (addr (spare_buffer), 1); %skip(1); call expand_pathname_ (file_info.output_file_pathname, directory_name, entry_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to expand the output file pathname ^a.", file_info.output_file_pathname); %skip(1); switch_name = unique_chars_ ("0"b) || ".create_data_file"; if truncate then attach_description = "vfile_ " || rtrim (directory_name) || ">" || rtrim (entry_name); else attach_description = "vfile_ " || rtrim (directory_name) || ">" || rtrim (entry_name) || " -extend"; %skip(1); call iox_$attach_name (switch_name, output_file_iocb_ptr, attach_description, null (), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to attach file ^a in dir ^a.", rtrim (directory_name), rtrim (entry_name)); file_is_attached = ON; %skip(1); call iox_$open (output_file_iocb_ptr, Stream_output, "0"b, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to open file ^a in dir ^a.", rtrim (directory_name), rtrim (entry_name)); file_is_opened = ON; %skip(1); return; %skip(1); end setup_for_retrieval; %page; terminate: proc; %skip(3); if ^cleanup_signalled & file_info.flags.tracing then call ioa_ ("Writing completed. ^d tuples written.", current_row_number); %skip(1); if temp_segment_has_been_acquired then do; call linus_temp_seg_mgr$release_segment (lcb_ptr, CREATE_DATA_FILE, buffer_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to release a temporary segment."); else call ssu_$abort_line (sci_ptr, code, "^/While trying to release a temporary segment."); else temp_segment_has_been_acquired = OFF; end; %skip(1); if file_is_opened then do; call iox_$close (output_file_iocb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to close ^a.", entry_name); else call ssu_$abort_line (sci_ptr, code, "^/While trying to close ^a.", entry_name); else file_is_opened = OFF; end; else; %skip(1); if file_is_attached then do; call iox_$detach_iocb (output_file_iocb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to detach ^p.", output_file_iocb_ptr); else call ssu_$abort_line (sci_ptr, code, "^/While trying to detach ^p.", output_file_iocb_ptr); else do; file_is_attached = OFF; call iox_$destroy_iocb (output_file_iocb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to destroy ^p.", output_file_iocb_ptr); else call ssu_$abort_line (sci_ptr, code, "^/While trying to destroy ^p.", output_file_iocb_ptr); else; end; end; %page; if table_has_been_started then do; call linus_table$delete_table (lcb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to delete the table."); else call ssu_$abort_line (sci_ptr, code, "^/While trying to delete the table."); else table_has_been_started = OFF; end; %skip(1); if output_columns_map_has_been_allocated then do; free output_columns_map in (lcb.static_area); output_columns_map_has_been_allocated = OFF; end; %skip(1); return; %skip(1); end terminate; %page; write_row_to_output_file: proc; %skip(3); dcl wrtof_loop fixed bin; dcl wrtof_table_column_number fixed bin; %skip(1); buffer = ""; current_row_number = current_row_number + 1; wrtof_table_column_number = 0; %skip(1); do wrtof_loop = 1 to number_of_output_columns; if output_columns_map.columns (wrtof_loop).index ^= 0 then do; wrtof_table_column_number = wrtof_table_column_number + 1; if ^checking_values then buffer = buffer || substr (row_value, output_columns_map.columns (wrtof_loop).index, output_columns_map.columns (wrtof_loop).length); else call add_checked_value_to_buffer (wrtof_loop, wrtof_table_column_number); end; buffer = buffer || the_column_delimiter; end; %skip(1); buffer = buffer || the_row_delimiter; call iox_$put_chars (output_file_iocb_ptr, one_word_past_buffer_ptr, length (buffer), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to write row number ^d to the output file.", current_row_number); %skip(1); if file_info.flags.tracing then if mod (current_row_number, file_info.trace_every_n_tuples) = 0 then call ioa_ ("^d tuples have been written.", current_row_number); %skip(1); return; %skip(1); end write_row_to_output_file; %page; add_checked_value_to_buffer: proc ( acvtb_column_index_parm, /* input: number of current output column */ acvtb_table_index_parm /* input: number of current table column */ ); %skip(3); dcl acvtb_column_index fixed bin (21); dcl acvtb_column_index_parm fixed bin parm; dcl acvtb_column_length fixed bin (21); dcl acvtb_data_type fixed bin (6) unsigned unaligned; dcl acvtb_table_index_parm fixed bin parm; %skip(1); acvtb_column_index = output_columns_map.columns (acvtb_column_index_parm).index; acvtb_column_length = output_columns_map.columns (acvtb_column_index_parm).length; acvtb_data_type = addr (table_info.columns.column_data_type ( acvtb_table_index_parm)) -> descriptor.type; %skip(1); if acvtb_data_type ^= char_dtype & acvtb_data_type ^= varying_char_dtype & acvtb_data_type ^= bit_dtype & acvtb_data_type ^= varying_bit_dtype then spare_buffer = ltrim (rtrim (substr (row_value, acvtb_column_index, acvtb_column_length))); else spare_buffer = rtrim (substr (row_value, acvtb_column_index, acvtb_column_length)); if search (spare_buffer, special_characters) = 0 then buffer = buffer || spare_buffer; else do; spare_buffer_length = length (spare_buffer); buffer = buffer || requote_string_ (spare_buffer_as_non_varying); end; %skip(1); return; %skip(1); end add_checked_value_to_buffer; %page; dcl CREATE_DATA_FILE char (16) static internal options (constant) init ("create_data_file"); %skip(1); dcl MAXIMUM_MRDS_ATTRIBUTE_LENGTH fixed bin static internal options (constant) init (4096); %skip(1); dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %skip(1); dcl QUOTE char (1) static internal options (constant) init (""""); %skip(1); dcl TEMPORARY_TABLE bit (1) aligned static internal options (constant) init ("0"b); %page; dcl addr builtin; dcl addrel builtin; dcl attach_description char (256); %skip(1); dcl buffer char (buffer_length) varying based (buffer_ptr); dcl buffer_length fixed bin (21); dcl buffer_ptr ptr; %skip(1); dcl checking_values bit (1) aligned; dcl cleanup condition; dcl cleanup_signalled bit (1) aligned; dcl code fixed bin (35); dcl creating_new_columns bit (1) aligned; dcl current_row_number fixed bin; %skip(1); dcl directory_name char (168); %skip(1); dcl entry_name char (32); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); %skip(1); dcl 1 file_info like data_file_info based (file_info_ptr); dcl file_info_ptr ptr; dcl file_is_attached bit (1) aligned; dcl file_is_opened bit (1) aligned; dcl fixed builtin; %skip(1); dcl get_pdir_ entry() returns(char(168)); %skip(1); dcl ioa_ entry() options(variable); %skip(1); dcl length builtin; dcl linus_error_$no_db fixed bin(35) ext static; dcl linus_table$delete_table entry (ptr, fixed bin(35)); dcl linus_table$info entry (ptr, ptr, fixed bin(35)); dcl linus_table$new_table entry (ptr, char(168) var, bit(1) aligned, fixed bin(35)); dcl linus_table$get_row entry (ptr, ptr unaligned, fixed bin (35)); dcl linus_table$translate_query entry (ptr, ptr, fixed bin(35)); dcl linus_temp_seg_mgr$get_segment entry (ptr, char(*), char(*), ptr, fixed bin(35)); dcl linus_temp_seg_mgr$release_segment entry (ptr, char(*), ptr, fixed bin(35)); dcl linus_translate_query$auto entry (ptr, ptr); dcl ltrim builtin; %skip(1); dcl mod builtin; dcl mrds_error_$tuple_not_found fixed bin(35) ext static; %skip(1); dcl null builtin; dcl number_of_output_columns fixed bin; %skip(1); dcl one_word_past_buffer_ptr ptr; dcl 1 output_columns_map aligned based (output_columns_map_ptr), 2 number_of_columns fixed bin, 2 columns (number_of_output_columns refer (output_columns_map.number_of_columns)), 3 index fixed bin (21), 3 length fixed bin (21), 3 value char (1) varying; dcl output_columns_map_has_been_allocated bit (1) aligned; dcl output_columns_map_ptr ptr; dcl output_file_iocb_ptr ptr; %skip(1); dcl rel builtin; dcl requote_string_ entry (char(*)) returns(char(*)); dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl search builtin; dcl spare_buffer char (MAXIMUM_MRDS_ATTRIBUTE_LENGTH) varying; dcl spare_buffer_length fixed bin; dcl spare_buffer_as_non_varying char (spare_buffer_length) based (spare_buffer_as_non_varying_ptr); dcl spare_buffer_as_non_varying_ptr ptr; dcl special_characters char (3); dcl ssu_$abort_line entry() options(variable); dcl ssu_$print_message entry() options(variable); dcl still_retrieving bit (1) aligned; dcl substr builtin; dcl switch_name char (32); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl table_has_been_started bit (1) aligned; dcl temp_segment_has_been_acquired bit (1) aligned; dcl the_column_delimiter char (1); dcl the_row_delimiter char (1); dcl truncate bit (1) aligned; %skip(1); dcl unique_chars_ entry (bit(*)) returns(char(15)); %page; %include arg_descriptor; %page; %include arg_list; %page; %include iox_dcls; %page; %include iox_modes; %page; %include linus_data_file_info; %page; %include linus_lcb; %page; %include linus_table_info; %page; %include mdbm_descriptor; %page; %include std_descriptor_types; %skip(3); end linus_create_data_file;  linus_display.pl1 07/29/86 1051.7r w 07/29/86 0939.5 303048 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus display request. Description and usage follows. Description: This request takes far too many control arguments to list here (currently it accepts 55). See the info segment for details on the accepted control arguments and usage. Usage: Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_display: proc (sci_ptr_parm, lcb_ptr_parm); %skip(3); dcl sci_ptr_parm ptr parm; /* ptr to the subsystem control info structure */ dcl lcb_ptr_parm ptr parm; /* ptr to the linus control block info structure */ %skip(3); /* Mainline Processing Overview. (1) Make sure the format options are up to date and that there is data to create a report from. (2) Have the subroutine linus_display_process_args fill in the default control args and update the defaults with arguments supplied on the request line. (3) Delete existing report and table if appropriate, start new ones if appropriate, possibly sort the table, setup for multi-pass mode if appropriate. (4) Setup any output file, output switch, or the video system depending on what control arguments were given. (5) Print, scroll, or page the report. (6) Perform termination as instructed by the control args. */ %page; arguments_have_been_processed = OFF; cleanup_signalled = OFF; %skip(1); on cleanup begin; cleanup_signalled = ON; call terminate; end; %skip(1); call initialize; call linus_display_process_args (sci_ptr, lcb_ptr, work_area_ptr, table_ip, addr (display_arg_results)); arguments_have_been_processed = ON; call fill_in_the_defaults; %skip(1); call setup_io_switches; %skip(1); if display_arg_results.scroll_flag then call scroll_the_report; else if display_arg_results.pages_flag then call page_the_report; else call print_report; %skip(1); call terminate; %skip(1); return; %page; begin_new_report: proc; %skip(1); if display_arg_results.flags.keep_report_flag | display_arg_results.flags.scroll_flag then report_control_info.flags.permanent_report = ON; else report_control_info.flags.permanent_report = OFF; %skip(1); if display_arg_results.time_flag then time1 = vclock; %skip(1); call linus_fr_new_report (lcb_ptr, code); if display_arg_results.time_flag then do; time2 = vclock; report_control_info.report_setup_time = time2 - time1; call ioa_$ioa_switch (iox_$error_output, "Time used to setup the report was ^10.5f seconds.", report_control_info.report_setup_time / 1000000); end; %skip(1); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); report_control_info.flags.report_has_been_started = ON; report_control_info.flags.report_is_formatted = OFF; report_control_info.flags.report_has_just_been_completed = OFF; report_control_info.report_identifier = report_control_info.options_identifier; report_control_info.no_of_formatted_pages = 0; report_control_info.report_formatting_time = 0; report_control_info.report_display_time = 0; report_control_info.ssu_evaluate_active_string_time = 0; %skip(1); return; %skip(1); end begin_new_report; %page; begin_new_retrieval: proc; %skip(1); if display_arg_results.keep_retrieval_flag | display_arg_results.sort_flag then report_control_info.permanent_table = ON; else report_control_info.permanent_table = OFF; %skip(3); time1 = vclock; call linus_table$new_table (lcb_ptr, (report_control_info.temp_dir_name), (report_control_info.permanent_table), code); time2 = vclock; report_control_info.table_loading_time = time2 - time1; %skip(1); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); report_control_info.flags.table_has_been_started = ON; report_control_info.flags.table_is_full = OFF; report_control_info.flags.table_has_just_been_loaded = OFF; report_control_info.retrieval_identifier = table_info.retrieval_identifier; report_control_info.no_of_rows_retrieved = table_info.row_count; %skip(1); return; %skip(1); end begin_new_retrieval; %page; delete_report: proc; %skip(1); if display_arg_results.time_flag then time1 = vclock; %skip(1); call linus_fr_delete_report (lcb_ptr, code); if display_arg_results.time_flag then do; time2 = vclock; report_control_info.report_deletion_time = time2 - time1; call ioa_$ioa_switch (iox_$error_output, "Time used to delete the report was ^10.5f seconds.", report_control_info.report_deletion_time / 1000000); end; %skip(1); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code); else call ssu_$abort_line (sci_ptr, code); else; %skip(1); report_control_info.flags.report_has_been_started = OFF; %skip(1); return; %skip(1); end delete_report; %page; delete_table: proc; %skip(1); if display_arg_results.time_flag then time1 = vclock; %skip(1); call linus_table$delete_table (lcb_ptr, code); if display_arg_results.time_flag then do; time2 = vclock; report_control_info.table_deletion_time = time2 - time1; call ioa_$ioa_switch (iox_$error_output, "Time used to delete the table was ^10.5f seconds.", report_control_info.table_deletion_time / 1000000); end; %skip(1); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code); else call ssu_$abort_line (sci_ptr, code); else; %skip(1); report_control_info.flags.table_has_been_started = OFF; %skip(1); return; %skip(1); end delete_table; %page; fill_in_the_defaults: proc; %skip(1); /* Delete the old table and old report if a new retrieval or report has been requested and it wasn't deleted on our last termination. The user may have asked for an existing table or report to be used when it isn't possible. Examples of this are: when there isn't an existing table; when invocations of the print, report, etc. requests have occured since we were last active; when there isn't an existing report; when the user has invoked the sfo request; etc. If this has happened then it is treated as if the user asked for a new report/table. */ %skip(3); if ^display_arg_results.new_retrieval_flag then do; if report_control_info.retrieval_identifier ^= table_info.retrieval_identifier | ^report_control_info.flags.table_has_been_started then do; if display_arg_results.long_flag then call ssu_$print_message (sci_ptr, 0, "Warning: A new retrieval will be started."); display_arg_results.new_retrieval_flag = ON; end; else; end; else; %skip(1); if display_arg_results.new_retrieval_flag & report_control_info.flags.table_has_been_started then call delete_table; %skip(1); if ^display_arg_results.new_report_flag then do; if report_control_info.report_identifier ^= report_control_info.options_identifier | ^report_control_info.flags.report_has_been_started | display_arg_results.new_retrieval_flag then do; if display_arg_results.long_flag then call ssu_$print_message (sci_ptr, 0, "Warning: A new report will be started."); display_arg_results.new_report_flag = ON; end; else; end; else; %skip(1); if display_arg_results.new_report_flag & report_control_info.flags.report_has_been_started then call delete_report; %skip(1); /* Check for a new temp dir supplied by the user for placing the retrieved data table and formatted report. We only allow a new temp_dir when we're about to create a new table and report, because the ptrs to the rows and formatted pages of existing reports and tables would be invalid. */ %skip(1); if display_arg_results.temp_dir_flag then do; allocate status_branch in (work_area) set (status_ptr); call expand_pathname_ (display_arg_results.temp_dir_pathname, directory_name, entry_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to expand the temp dir ^a.", display_arg_results.temp_dir_pathname); call hcs_$status_long (directory_name, entry_name, 1, status_ptr, null (), code); if code ^= 0 & code ^= error_table_$no_s_permission then call ssu_$abort_line (sci_ptr, code, "^/While trying to determine the unique id of ^a.", display_arg_results.temp_dir_pathname); if display_arg_results.new_report_flag & display_arg_results.new_retrieval_flag then do; report_control_info.temp_dir_name = display_arg_results.temp_dir_pathname; report_control_info.temp_dir_unique_id = status_branch.long.uid; end; else if report_control_info.temp_dir_unique_id = status_branch.long.uid then; else do; if display_arg_results.long_flag then call ssu_$print_message (sci_ptr, 0, "Warning: The temp_dir ^a won't be used.", rtrim (display_arg_results.temp_dir_pathname)); display_arg_results.temp_dir_flag = OFF; end; end; else; %page; /* Check for multiple pass mode. */ %skip(1); if display_arg_results.flags.passes_flag then if ^display_arg_results.flags.new_report_flag then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/The control argument -passes can only be used with a new report."); else do; report_control_info.flags.multi_pass_mode = ON; report_control_info.number_of_passes = display_arg_results.number_of_passes; end; else report_control_info.flags.multi_pass_mode = OFF; /* Begin a new retrieval and report if appropriate. */ %skip(1); if display_arg_results.new_retrieval_flag then call begin_new_retrieval; %skip(1); if display_arg_results.new_report_flag then call begin_new_report; %skip(1); /* Sort the table if instructed. */ %skip(1); if display_arg_results.sort_flag then do; if ^report_control_info.flags.table_is_full then call load_the_entire_table; if display_arg_results.time_flag then time1 = vclock; call linus_table$sort (lcb_ptr, display_arg_results.sort_information_ptr, code); if display_arg_results.time_flag then do; time2 = vclock; report_control_info.table_sorting_time = time2 - time1; call ioa_$ioa_switch (iox_$error_output, "Time used to sort the table was ^10.5f seconds.", report_control_info.table_sorting_time / 1000000); end; if code ^= 0 then call ssu_$abort_line (sci_ptr, code); end; %skip(1); return; %skip(1); end fill_in_the_defaults; %page; format_page: proc; %skip(3); if display_arg_results.time_flag then time1 = vclock; call linus_fr_build_page (lcb_ptr, page_ip, code); if display_arg_results.time_flag then do; time2 = vclock; report_control_info.report_formatting_time = report_control_info.report_formatting_time + (time2 - time1); end; if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); if report_control_info.flags.report_has_just_been_completed then do; report_control_info.flags.report_has_just_been_completed = OFF; if display_arg_results.time_flag then call ioa_$ioa_switch (iox_$error_output, "Time used to format the report was ^10.5f seconds." || "^/(ssu_$evaluate_active_string used ^10.5f seconds of this time.)", report_control_info.report_formatting_time / 1000000, report_control_info.ssu_evaluate_active_string_time / 1000000); else; end; %skip(1); if report_control_info.flags.table_has_just_been_loaded then do; report_control_info.flags.table_has_just_been_loaded = OFF; if display_arg_results.time_flag then call ioa_$ioa_switch (iox_$error_output, "Time used to load the table was ^10.5f seconds.", report_control_info.table_loading_time / 1000000); else; end; %skip(1); call format_page_or_get_page_extra_processing (report_control_info.no_of_formatted_pages); %skip(1); return; %skip(1); end format_page; %page; format_page_or_get_page_extra_processing: proc ( fpgpep_page_number_parm /* input: number of page just got or formatted */ ); dcl fpgpep_page_number_parm fixed bin (21) parm; %skip(3); if fpgpep_page_number_parm = 1 then first_page_of_the_report = ON; else first_page_of_the_report = OFF; %skip(1); if report_control_info.report_is_formatted & report_control_info.no_of_formatted_pages = fpgpep_page_number_parm then last_page_of_the_report = ON; else last_page_of_the_report = OFF; %skip(1); if page_info.page_overstrike_info_ptr ^= null () then do; terminal_dependency = ON; page_overstrike_ip = page_info.page_overstrike_info_ptr; end; else terminal_dependency = OFF; %skip(1); return; %skip(1); end format_page_or_get_page_extra_processing; %page; get_page: proc (target_page_parm); %skip(1); dcl target_page_parm fixed bin (21) parm; %skip(3); call linus_fr_get_page (lcb_ptr, target_page_parm, page_ip, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to get page ^d.", target_page_parm); %skip(1); call format_page_or_get_page_extra_processing (target_page_parm); %skip(1); return; %skip(1); end get_page; %page; initialize: proc; %skip(1); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); /* Make sure that there is data to create a report from, and that the information on the columns is available. */ %skip(1); call linus_table$translate_query (lcb_ptr, table_ip, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); /* Make sure that the options are in sync with the current table. */ %skip(1); call linus_options$initialize (lcb_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); /* Automatic versions of a few odds and sodds we will need. */ %skip(1); report_cip = lcb.report_control_info_ptr; work_area_ptr = report_control_info.display_work_area_ptr; call release_area_ (work_area_ptr); work_area_ptr = report_control_info.display_work_area_ptr; video_has_been_set_up = OFF; %skip(1); return; %skip(1); end initialize; %page; load_the_entire_table: proc; %skip(3); if display_arg_results.time_flag then time1 = vclock; %skip(1); call linus_table$load_table (lcb_ptr, code); if display_arg_results.time_flag then do; time2 = vclock; report_control_info.table_loading_time = report_control_info.table_loading_time + (time2 - time1); call ioa_$ioa_switch (iox_$error_output, "Time used to load the table was ^10.5f seconds.", report_control_info.table_loading_time / 1000000); end; if code ^= 0 then if code = mrds_error_$tuple_not_found then; else call ssu_$abort_line (sci_ptr, code); else; %skip(1); report_control_info.flags.table_is_full = ON; report_control_info.no_of_rows_retrieved = table_info.row_count; %skip(1); return; %skip(1); end load_the_entire_table; %page; page_the_report: proc; %skip(1); dcl ptr_current_page_number fixed bin (21); dcl ptr_specified_pages_as_a_string bit (NUMBER_OF_ALLOWED_SPECIFIED_PAGES) based (ptr_specified_pages_as_a_string_ptr); dcl ptr_specified_pages_as_a_string_ptr ptr; dcl ptr_still_paging bit (1) aligned; %skip(3); if ^report_control_info.report_is_paginated then do; call print_report; return; end; %skip(1); report_control_info.report_display_time = 0; ptr_specified_pages_as_a_string_ptr = addr (display_arg_results.specified_pages (1)); ptr_current_page_number = 1; ptr_still_paging = ON; %skip(1); do while (ptr_still_paging); %skip(1); if ptr_current_page_number > report_control_info.no_of_formatted_pages then call format_page; else if display_arg_results.specified_pages (ptr_current_page_number) then call get_page (ptr_current_page_number); else; %skip(1); if display_arg_results.specified_pages (ptr_current_page_number) then call print_page; %skip(1); if ^display_arg_results.last_page_flag then if index (substr (ptr_specified_pages_as_a_string, ptr_current_page_number + 1), ON) = 0 then ptr_still_paging = OFF; else ptr_current_page_number = ptr_current_page_number + 1; else ptr_current_page_number = ptr_current_page_number + 1; %skip(1); if report_control_info.report_is_formatted & ptr_current_page_number > report_control_info.no_of_formatted_pages then ptr_still_paging = OFF; %skip(1); end; %page; if display_arg_results.last_page_flag then if ^display_arg_results.specified_pages (report_control_info.no_of_formatted_pages) then do; if ^display_arg_results.new_report_flag then call get_page (report_control_info.no_of_formatted_pages); else; call print_page; end; else; else; %skip(1); if display_arg_results.flags.time_flag then call ioa_$ioa_switch (iox_$error_output, "Time used to display the report was ^10.5f seconds.", report_control_info.report_display_time / 1000000); %skip(1); return; %skip(1); end page_the_report; %page; print_page: proc; %skip(1); dcl pp_chunk_of_line char (pp_number_of_chars) based (pp_chunk_of_line_ptr); dcl pp_chunk_of_line_ptr ptr; dcl pp_code fixed bin (35); dcl pp_ioa_string char (4); dcl pp_left_margin fixed bin; dcl pp_loop fixed bin; dcl pp_loop_limit fixed bin; dcl pp_number_of_chars fixed bin; dcl pp_overstrike_index fixed bin; dcl pp_right_margin fixed bin; %skip(3); if display_arg_results.time_flag then time1 = vclock; %skip(1); if ^display_arg_results.output_file_flag then if report_control_info.report_is_paginated | first_page_of_the_report then call ioa_$ioa_switch_nnl ( report_control_info.display_iocb_ptr, "^3/"); else; else; %skip(1); if ^display_arg_results.character_positions_flag & ^terminal_dependency then do; call iox_$put_chars (report_control_info.display_iocb_ptr, page_info.page_ptr, page_info.total_characters, pp_code); if pp_code ^= 0 then call ssu_$abort_line (sci_ptr, pp_code); end; else do; if display_arg_results.character_positions_flag then do; pp_right_margin = display_arg_results.right_margin_position; pp_left_margin = display_arg_results.left_margin_position; if pp_left_margin < 1 then pp_left_margin = 1; if pp_right_margin >= page_info.width then pp_right_margin = page_info.width - 1; end; else do; pp_right_margin = page_info.width - 1; pp_left_margin = 1; end; pp_number_of_chars = pp_right_margin - pp_left_margin + 1; if pp_number_of_chars ^> 0 then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_display, "The specified character positions result in no characters being printed."); pp_loop_limit = page_info.length - 1; do pp_loop = 1 to pp_loop_limit; pp_overstrike_index = ((pp_loop - 1) * page_info.width) + pp_left_margin; pp_chunk_of_line_ptr = addr (page_defined_as_chars (pp_overstrike_index)); if terminal_dependency & index (substr (page_overstrike_info_redefined.bit_map, pp_overstrike_index, pp_number_of_chars), ON) ^= 0 then call make_terminal_dependent_string; call ioa_$ioa_switch (report_control_info.display_iocb_ptr, "^a", pp_chunk_of_line); if terminal_dependency then pp_number_of_chars = pp_right_margin - pp_left_margin + 1; end; pp_overstrike_index = (pp_loop_limit * page_info.width) + pp_left_margin; pp_chunk_of_line_ptr = addr (page_defined_as_chars (pp_overstrike_index)); if report_control_info.report_is_paginated | last_page_of_the_report then pp_ioa_string = "^a^|"; else pp_ioa_string = "^a^/"; if terminal_dependency & index (substr (page_overstrike_info_redefined.bit_map, pp_overstrike_index, pp_number_of_chars), ON) ^= 0 then call make_terminal_dependent_string; call ioa_$ioa_switch_nnl (report_control_info.display_iocb_ptr, pp_ioa_string, pp_chunk_of_line); end; %skip(1); if display_arg_results.time_flag then do; time2 = vclock; report_control_info.report_display_time = report_control_info.report_display_time + (time2 - time1); end; %skip(1); return; %page; make_terminal_dependent_string: proc; %skip(1); dcl mtds_loop fixed bin; dcl mtds_overstrike_index fixed bin; %skip(3); spare_string = ""; mtds_overstrike_index = pp_overstrike_index; do mtds_loop = 1 to pp_number_of_chars; spare_string = spare_string || substr (pp_chunk_of_line, mtds_loop, 1); if page_overstrike_info.bit_map (mtds_overstrike_index) then spare_string = spare_string || BACKSPACE || page_overstrike_info.chars (mtds_overstrike_index); mtds_overstrike_index = mtds_overstrike_index + 1; end; %skip(1); pp_number_of_chars = length (spare_string); pp_chunk_of_line_ptr = addrel (addr (spare_string), 1); %skip(1); return; %skip(1); end make_terminal_dependent_string; %skip(1); end print_page; %page; print_report: proc; %skip(1); dcl pr_loop fixed bin (21); dcl pr_loop_limit fixed bin (21); %skip(3); report_control_info.report_display_time = 0; %skip(1); if report_control_info.no_of_formatted_pages ^= 0 then do; pr_loop_limit = report_control_info.no_of_formatted_pages; do pr_loop = 1 to pr_loop_limit; call get_page (pr_loop); call print_page; end; end; %skip(1); do while (^report_control_info.flags.report_is_formatted); call format_page; call print_page; end; %skip(1); if display_arg_results.flags.time_flag then call ioa_$ioa_switch (iox_$error_output, "Time used to display the report was ^10.5f seconds.", report_control_info.report_display_time / 1000000); %skip(1); return; %skip(1); end print_report; %page; scroll_the_report: proc; %skip(1); dcl str_still_looking_for_the_page bit (1) aligned; %skip(1); scroll_ip = display_arg_results.scroll_info_ptr; %skip(1); on display_buffer_empty begin; if scroll_info.target_page_number <= report_control_info.no_of_formatted_pages then call get_page (scroll_info.target_page_number); else call format_page; scroll_info.page_info_pointer = page_ip; end; %skip(1); do while (ON); if scroll_info.flags.goto_line_number_pending then call find_line_within_page; else call find_page; scroll_info.page_info_pointer = page_ip; call linus_display_scroll$continue (scroll_ip, code); if code ^= 0 then if code = error_table_$end_of_info then return; else call ssu_$abort_line (sci_ptr, code); else; end; %skip(1); return; %page; check_for_end_of_report: proc; %skip(3); scroll_info.flags.on_the_last_page = OFF; %skip(1); if report_control_info.flags.report_is_formatted then if scroll_info.target_page_number > report_control_info.no_of_formatted_pages then do; scroll_info.target_page_number = report_control_info.no_of_formatted_pages; scroll_info.flags.on_the_last_page = ON; end; else; else; %skip(1); return; %skip(1); end check_for_end_of_report; %page; find_line_within_page: proc; %skip(1); dcl flwp_beginning_line_number fixed bin (35); dcl flwp_ending_line_number fixed bin (35); dcl flwp_line_number_is_beyond_end_of_report bit (1) aligned; dcl flwp_still_looking_for_the_line bit (1) aligned; %skip(1); scroll_info.flags.goto_line_number_pending = OFF; flwp_still_looking_for_the_line = ON; flwp_line_number_is_beyond_end_of_report = OFF; scroll_info.target_page_number = 1; flwp_beginning_line_number = 1; %skip(1); do while (flwp_still_looking_for_the_line); if scroll_info.target_page_number <= report_control_info.no_of_formatted_pages then call get_page (scroll_info.target_page_number); else call format_page; %skip(1); flwp_ending_line_number = flwp_beginning_line_number + page_info.length - 1; if report_control_info.flags.report_is_formatted then if scroll_info.target_page_number = report_control_info.no_of_formatted_pages then do; scroll_info.flags.on_the_last_page = ON; if scroll_info.target_line_number > flwp_ending_line_number then flwp_line_number_is_beyond_end_of_report = ON; end; else; else; %skip(1); if (scroll_info.target_line_number >= flwp_beginning_line_number & scroll_info.target_line_number <= flwp_ending_line_number) | (flwp_line_number_is_beyond_end_of_report) then flwp_still_looking_for_the_line = OFF; else flwp_beginning_line_number = flwp_ending_line_number + 1; %skip(1); if ^flwp_still_looking_for_the_line then do; if flwp_line_number_is_beyond_end_of_report then scroll_info.target_line_number = (flwp_ending_line_number - flwp_beginning_line_number) - scroll_info.vertical_scroll_distance + 1; else scroll_info.target_line_number = scroll_info.target_line_number - flwp_beginning_line_number + 1; end; else scroll_info.target_page_number = scroll_info.target_page_number + 1; end; %skip(1); return; %skip(1); end find_line_within_page; %page; find_page: proc; %skip(3); call check_for_end_of_report; if scroll_info.target_page_number <= report_control_info.no_of_formatted_pages then call get_page (scroll_info.target_page_number); else do; str_still_looking_for_the_page = ON; do while (str_still_looking_for_the_page); call format_page; call check_for_end_of_report; if scroll_info.target_page_number = report_control_info.no_of_formatted_pages then str_still_looking_for_the_page = OFF; end; end; %skip(1); return; %skip(1); end find_page; %skip(1); end scroll_the_report; %page; setup_io_switches: proc; %skip(3); if display_arg_results.output_file_flag then call setup_output_file; else if display_arg_results.scroll_flag then do; call linus_display_scroll$start (sci_ptr, report_cip, addr (display_arg_results), work_area_ptr); video_has_been_set_up = ON; end; else if display_arg_results.output_switch_flag then call setup_output_switch; else report_control_info.display_iocb_ptr = iox_$user_output; %skip(1); return; %page; setup_output_file: proc; %skip(3); switch_name = unique_chars_ ("0"b) || ".linus_display"; if display_arg_results.truncate_flag then attach_description = "vfile_ " || rtrim (display_arg_results.output_file_directory_name) || ">" || rtrim (display_arg_results.output_file_entry_name); else attach_description = "vfile_ " || rtrim (display_arg_results.output_file_directory_name) || ">" || rtrim (display_arg_results.output_file_entry_name) || " -extend"; %skip(1); call iox_$attach_name (switch_name, iocb_ptr, attach_description, null (), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to attach file ^a in dir ^a.", rtrim (display_arg_results.output_file_entry_name), rtrim (display_arg_results.output_file_directory_name)); %skip(1); call iox_$open (iocb_ptr, Stream_output, "0"b, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to open file ^a in dir ^a.", rtrim (display_arg_results.output_file_entry_name), rtrim (display_arg_results.output_file_directory_name)); %skip(1); report_control_info.display_iocb_ptr = iocb_ptr; %skip(1); return; %skip(1); end setup_output_file; %page; setup_output_switch: proc; %skip(3); call iox_$look_iocb (display_arg_results.output_switch_name, report_control_info.display_iocb_ptr, code); if code = error_table_$no_iocb then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_display, BAD_OUTPUT_SWITCH_MESSAGE); %skip(1); if report_control_info.display_iocb_ptr -> iocb.attach_descrip_ptr = null () | report_control_info.display_iocb_ptr -> iocb.open_descrip_ptr = null () then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_display, BAD_OUTPUT_SWITCH_MESSAGE); %skip(1); return; %skip(1); end setup_output_switch; %skip(1); end setup_io_switches; %page; terminate: proc; %skip(3); if ^arguments_have_been_processed then return; %skip(1); /* Delete the table and report if instructed to do so. */ %skip(1); if ^display_arg_results.keep_retrieval_flag & report_control_info.flags.table_has_been_started then call delete_table; %skip(1); if ^display_arg_results.keep_report_flag & report_control_info.flags.report_has_been_started then call delete_report; %skip(1); /* If we were writing the report to a file clean up. */ %skip(1); if display_arg_results.output_file_flag & (report_control_info.display_iocb_ptr ^= iox_$user_output & report_control_info.display_iocb_ptr ^= null ()) then do; iocb_ptr = report_control_info.display_iocb_ptr; call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); call iox_$destroy_iocb (iocb_ptr, code); if cleanup_signalled & report_control_info.no_of_formatted_pages > 0 then call ssu_$print_message (sci_ptr, 0, "The partial report is contained in ^/^a.", rtrim (display_arg_results.output_file_directory_name) || ">" || rtrim (display_arg_results.output_file_entry_name)); else; end; else; %skip(1); if display_arg_results.scroll_flag & video_has_been_set_up then call linus_display_scroll$stop (display_arg_results.scroll_info_ptr); %skip(1); return; %skip(1); end terminate; %page; dcl BACKSPACE char (1) static int options (constant) init (""); dcl BAD_OUTPUT_SWITCH_MESSAGE char (69) static int options (constant) init ( "^/When -output_switch is used the switch must be opened and attached."); dcl OFF bit (1) aligned static int options (constant) init ("0"b); dcl ON bit (1) aligned static int options (constant) init ("1"b); %page; dcl addr builtin; dcl addrel builtin; dcl arguments_have_been_processed bit (1) aligned; dcl attach_description char (256); %skip(1); dcl cleanup condition; dcl cleanup_signalled bit (1) aligned; dcl code fixed bin (35); %skip(1); dcl directory_name char (168); dcl display_buffer_empty condition; %skip(1); dcl entry_name char (32); dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$no_iocb fixed bin(35) ext static; dcl error_table_$no_s_permission fixed bin(35) ext static; dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); %skip(1); dcl first_page_of_the_report bit (1) aligned; dcl fixed builtin; %skip(1); dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); %skip(1); dcl index builtin; dcl ioa_$ioa_switch entry() options(variable); dcl ioa_$ioa_switch_nnl entry() options(variable); dcl iocb_ptr ptr; %skip(1); dcl last_page_of_the_report bit (1) aligned; dcl length builtin; dcl linus_display_process_args entry (ptr, ptr, ptr, ptr, ptr); dcl linus_display_scroll$continue entry (ptr, fixed bin(35)); dcl linus_display_scroll$start entry (ptr, ptr, ptr, ptr); dcl linus_display_scroll$stop entry (ptr); dcl linus_error_$bad_report_display fixed bin(35) ext static; dcl linus_fr_build_page entry (ptr, ptr, fixed bin(35)); dcl linus_fr_delete_report entry (ptr, fixed bin(35)); dcl linus_fr_get_page entry (ptr, fixed bin (21), ptr, fixed bin (35)); dcl linus_fr_new_report entry (ptr, fixed bin(35)); dcl linus_options$initialize entry (ptr, fixed bin(35)); dcl linus_table$delete_table entry (ptr, fixed bin(35)); dcl linus_table$translate_query entry (ptr, ptr, fixed bin(35)); dcl linus_table$load_table entry (ptr, fixed bin(35)); dcl linus_table$new_table entry (ptr, char(168) var, bit (1) aligned, fixed bin(35)); dcl linus_table$sort entry (ptr, ptr, fixed bin(35)); %skip(1); dcl mrds_error_$tuple_not_found fixed bin(35) ext static; %skip(1); dcl null builtin; %skip(1); dcl rel builtin; dcl release_area_ entry (ptr); dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl ssu_$abort_line entry() options(variable); dcl ssu_$print_message entry() options(variable); dcl substr builtin; dcl switch_name char (42); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl terminal_dependency bit (1) aligned; dcl time1 float bin (63); dcl time2 float bin (63); %skip(1); dcl unique_chars_ entry (bit(*)) returns(char(15)); %skip(1); dcl vclock builtin; dcl video_has_been_set_up bit (1) aligned; %skip(1); dcl work_area area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; %page; %include arg_descriptor; %page; %include arg_list; %page; %include iocb; %page; %include iox_dcls; %page; %include iox_modes; %page; %include linus_display_arg_list; %page; %include linus_lcb; %page; %include linus_options_extents; %page; %include linus_page_info; %page; %include linus_report_info; %page; %include linus_scroll_info; %page; %include linus_sort_info; %page; %include linus_table_info; %page; %include status_structures; end linus_display;  linus_display_builtins.pl1 07/29/86 1051.7r w 07/29/86 0939.5 46350 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus display_builtins request. Description and usage follows. Description: This active request returns the value of the named builtin. The builtin is named by the user. Usage: "display_builtins STR" where STR is the name of the desired builtin. It can be chosen from: "current_row_number", "first_row", "last_row", "page_number", "previously_processed_row", "last_row_number", "last_page_number", "last_pass", or "current_pass_number". Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_display_builtins: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(3); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(3); call initialize; call get_builtin_value; %skip(1); return; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); call ssu_$return_arg (sci_ptr, number_of_args_supplied, active_request_flag, return_value_ptr, return_value_length); if number_of_args_supplied ^= 1 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, USAGE_MESSAGE); %skip(1); report_cip = lcb.report_control_info_ptr; if report_cip = null () then call ssu_$abort_line (sci_ptr, linus_error_$no_report); else if ^report_control_info.flags.report_has_been_started then call ssu_$abort_line (sci_ptr, linus_error_$no_report); %skip(1); format_report_ip = report_control_info.format_report_info_ptr; status_pointer = format_report_info.status_ptr; %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); desired_builtin = arg; %skip(1); return; %skip(1); end initialize; %page; get_builtin_value: proc; %skip(3); if desired_builtin = "current_row_number" then value = ltrim (convert (value, status.current_row_number)); else if desired_builtin = "first_row" then if status.flags.first_row_of_report then value = "true"; else value = "false"; else if desired_builtin = "last_row" then if status.flags.last_row_of_report then value = "true"; else value = "false"; else if desired_builtin = "page_number" then value = ltrim (convert (value, status.current_page_number)); else if desired_builtin = "previously_processed_row" then if status.flags.row_has_been_processed_before then value = "true"; else value = "false"; else if desired_builtin = "last_row_number" then value = ltrim (convert (value, status.last_row_number)); else if desired_builtin = "last_page_number" then value = ltrim (convert (value, status.last_page_number)); else if desired_builtin = "current_pass_number" then value = ltrim (convert (value, status.current_pass_number)); else if desired_builtin = "last_pass" then if status.flags.last_pass then value = "true"; else value = "false"; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/^a is not the name of a display builtin.", desired_builtin); %skip(1); return_value = requote_string_ (rtrim (value)); %skip(1); return; %skip(1); end get_builtin_value; %page; dcl USAGE_MESSAGE char (31) static int options (constant) init ( "^/Usage: [display_builtins STR]"); %skip(1); dcl active_request_flag bit (1) aligned; dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl convert builtin; %skip(1); dcl desired_builtin char (32) varying; %skip(1); dcl error_table_$bad_arg fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl linus_error_$no_report fixed bin(35) ext static; dcl ltrim builtin; %skip(1); dcl null builtin; dcl number_of_args_supplied fixed bin; %skip(1); dcl rel builtin; dcl requote_string_ entry (char(*)) returns(char(*)); dcl return_value char (return_value_length) varying based (return_value_ptr); dcl return_value_length fixed bin (21); dcl return_value_ptr ptr; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl value char (16); %page; %include linus_options_extents; %page; %include linus_lcb; %page; %include linus_report_info; %page; %include linus_report_structures; %skip(3); end linus_display_builtins;  linus_display_process_args.pl1 10/14/83 1041.6r 10/14/83 0930.0 351729 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the procedure called by the linus_display request to process its control args and return the result through the include file linus_display_arg_list. Description and usage follows. Description: This proc is called to setup the default control arguments, and then update them with any user supplied control args. It is broken out from the linus_display request so that it can (hopefully) be replaced when a general process_args subroutine comes along. Usage: See the paremeter list for usage. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_display_process_args: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm, /* input: ptr to the linus control block info structure */ area_ptr_parm, /* input: ptr to an area for allocations */ table_info_ptr_parm, /* input: ptr to table_info structure */ display_arg_results_ptr_parm /* input: ptr to the display_arg_results structure */ ); %skip(1); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; dcl area_ptr_parm ptr parm; dcl table_info_ptr_parm ptr parm; dcl display_arg_results_ptr_parm ptr parm; %skip(1); /* Mainline Processing Overview. 1) Set the default control arg flags. 2) Loop through the control args updating the default flags. 3) Process any pathnames supplied. 4) Print execution time if we're being timed. */ %skip(3); time1 = vclock; %skip(1); call initialize; call process_args; %skip(1); if based_display_arg_results.output_file_flag | based_display_arg_results.temp_dir_flag then call setup_additional_pathnames; %skip(1); if based_display_arg_results.time_flag then do; time2 = vclock; call ioa_$ioa_switch (iox_$error_output, "Time used to process the arguments was ^10.5f seconds.", (time2 - time1) / 1000000); end; %skip(1); return; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; the_area_ptr = area_ptr_parm; table_ip = table_info_ptr_parm; based_display_arg_results_ptr = display_arg_results_ptr_parm; %skip(1); /* Set the default control args up. */ %skip(1); unspec (based_display_arg_results.flags) = OFF; based_display_arg_results.pathnames = BLANK; unspec (based_display_arg_results.miscellaneous) = OFF; based_display_arg_results.sort_information_ptr = null (); %skip(1); based_display_arg_results.flags.all_flag = ON; based_display_arg_results.flags.new_report_flag = ON; based_display_arg_results.flags.new_retrieval_flag = ON; based_display_arg_results.flags.long_flag = ON; based_display_arg_results.flags.truncate_flag = ON; %skip(1); /* Setup the scrolling structure to it's default state. */ %skip(1); allocate scroll_info in (the_area) set (scroll_ip); unspec (scroll_info) = OFF; based_display_arg_results.scroll_info_ptr = scroll_ip; terminal_info_ptr = addr (local_terminal_info); terminal_info.version = terminal_info_version; call iox_$control (iox_$user_io, "terminal_info", terminal_info_ptr, code); if code ^= 0 then if code = error_table_$no_operation then window_system_cant_be_used = ON; else call ssu_$abort_line (sci_ptr, code, "Unable to get the terminal information."); else do; window_system_cant_be_used = OFF; call ttt_info_$function_key_data (terminal_info.term_type, the_area_ptr, function_key_data_ptr, code); if code ^= 0 then if code ^= error_table_$no_table then call ssu_$abort_line (sci_ptr, code, "Unable to get the function key information."); else function_keys_can_be_used = OFF; else do; scroll_info.function_key_data_pointer = function_key_data_ptr; if function_key_data.highest < HIGHEST_NUMBERED_FUNCTION_KEY_NEEDED | (function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_length = 0) | (function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_length = 0) | (function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_length = 0) | (function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_length = 0) then function_keys_can_be_used = OFF; else function_keys_can_be_used = ON; end; if function_keys_can_be_used then call process_enable_function_keys; else call process_enable_escape_keys; end; %skip(1); return; %skip(1); end initialize; %page; process_args: proc; %skip(3); /* Loop through the control args setting flags and collecting arguments to control args. Conflicting control args are overidden by the last one supplied. Args to control args (e.g. dir names, page numbers) are processed immediately. */ %skip(1); call ssu_$arg_count (sci_ptr, no_of_args_supplied); %skip(1); if no_of_args_supplied = 0 then return; %skip(1); still_processing_args = ON; current_arg = 1; %skip(1); do while (still_processing_args); %skip(1); call get_next_arg; argument_number = lookup_arg_number (arg); if argument_number = 0 then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^/^a is not a valid control argument. Type ""help display"" for correct usage.", arg); call process_arg_procs (argument_number); %skip(1); end; %skip(1); return; %page; lookup_arg_number: proc (arg_parm) returns (fixed bin); %skip(3); dcl arg_parm char (*) parm; %skip(3); loop1 = 1; loop2 = hbound (ARGUMENT_NAME_TABLE, 1); %skip(1); do while (loop1 <= loop2); %skip(1); loop3 = divide (loop1 + loop2, 2, 17); if arg_parm = ARGUMENT_NAME_TABLE (loop3) then return (loop3); %skip(1); if arg_parm < ARGUMENT_NAME_TABLE (loop3) then loop2 = loop3 - 1; else loop1 = loop3 + 1; %skip(1); end; %skip(1); return (0); %skip(3); %skip(1); end lookup_arg_number; %skip(1); end process_args; %page; process_all: proc; %skip(3); based_display_arg_results.all_flag = ON; %skip(1); based_display_arg_results.pages_flag = OFF; based_display_arg_results.scroll_flag = OFF; %skip(1); return; %skip(1); end process_all; %skip(5); process_brief: proc; %skip(3); based_display_arg_results.long_flag = OFF; %skip(1); return; %skip(1); end process_brief; %page; process_character_positions: proc; %skip(3); based_display_arg_results.scroll_flag = OFF; based_display_arg_results.character_positions_flag = ON; %skip(1); if ^still_processing_args then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-character_positions must be followed by a left, and optionally a right margin value."); call get_next_arg; based_display_arg_results.left_margin_position = cv_dec_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-character_positions must be followed by a valid left margin value, not ^a.", arg); if ^still_processing_args then generate_right_margin_position = ON; else do; call get_next_arg; if substr (arg, 1, 1) = HYPHEN then do; generate_right_margin_position = ON; current_arg = current_arg - 1; still_processing_args = ON; end; else do; generate_right_margin_position = OFF; based_display_arg_results.right_margin_position = cv_dec_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-character_positions must be followed by a valid left and right margin value, not ^a.", arg); end; end; if generate_right_margin_position then do; call linus_options$get (lcb_ptr, OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_PAGE_WIDTH), "", normalized_option_name, option_value, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to get the default report page width."); based_display_arg_results.right_margin_position = cv_dec_check_ ((option_value), code); if based_display_arg_results.right_margin_position = 0 then based_display_arg_results.right_margin_position = 100000; if code ^= 0 then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "^/Could not convert the page width ""^a"" to a number.", option_value); end; %skip(1); return; %skip(1); end process_character_positions; %page; process_debug: proc; %skip(3); based_display_arg_results.flags.debug_flag = ON; %skip(1); return; %skip(1); end process_debug; %skip(5); process_discard_report: proc; %skip(3); based_display_arg_results.keep_report_flag = OFF; %skip(1); return; %skip(1); end process_discard_report; %skip(5); process_discard_retrieval: proc; %skip(3); based_display_arg_results.keep_retrieval_flag = OFF; %skip(1); return; %skip(1); end process_discard_retrieval; %page; process_enable_escape_keys: proc; %skip(3); dcl peek_loop fixed bin; %skip(1); if window_system_cant_be_used then call ssu_$abort_line (sci_ptr, video_et_$unable_to_call_wsys); %skip(1); scroll_info.flags.escapes_in_use = ON; %skip(1); do peek_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER; keys_as_a_table (peek_loop) = ESCAPE_KEYS_AS_A_TABLE (peek_loop); mnemonic_key_sequences_as_a_table (peek_loop) = ESCAPE_KEY_MNEMONICS_AS_A_TABLE (peek_loop); end; %skip(1); return; %skip(1); end process_enable_escape_keys; %page; process_enable_function_keys: proc; %skip(3); dcl pefk_inner_loop fixed bin; dcl pefk_loop fixed bin; %skip(1); if window_system_cant_be_used then call ssu_$abort_line (sci_ptr, video_et_$unable_to_call_wsys); %skip(1); if ^function_keys_can_be_used then return; %skip(1); scroll_info.flags.escapes_in_use = OFF; scroll_info.keys.forward = substr (function_key_seqs, function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_index, function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_length); scroll_info.keys.backward = substr (function_key_seqs, function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_index, function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_length); scroll_info.keys.left = substr (function_key_seqs, function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_index, function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_length); scroll_info.keys.right = substr (function_key_seqs, function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_index, function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_length); %skip(1); pefk_inner_loop = 1; do pefk_loop = 5 to HIGHEST_DISPLAY_FUNCTION_NUMBER; keys_as_a_table (pefk_loop) = substr (function_key_seqs, function_key_data.function_keys (pefk_inner_loop, KEY_PLAIN).sequence_index, function_key_data.function_keys (pefk_inner_loop, KEY_PLAIN).sequence_length); pefk_inner_loop = pefk_inner_loop + 1; end; %skip(1); do pefk_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER; mnemonic_key_sequences_as_a_table (pefk_loop) = KEY_MNEMONICS_AS_A_TABLE (pefk_loop); end; %skip(1); return; %skip(1); end process_enable_function_keys; %page; process_extend: proc; %skip(3); based_display_arg_results.truncate_flag = OFF; %skip(1); return; %skip(1); end process_extend; %page; process_keep_report: proc; %skip(3); based_display_arg_results.keep_report_flag = ON; %skip(1); return; %skip(1); end process_keep_report; %skip(5); process_keep_retrieval: proc; %skip(3); based_display_arg_results.keep_retrieval_flag = ON; %skip(1); return; %skip(1); end process_keep_retrieval; %skip(3); process_long: proc; %skip(3); based_display_arg_results.long_flag = ON; %skip(1); return; %skip(1); end process_long; %page; process_new_report: proc; %skip(3); based_display_arg_results.new_report_flag = ON; %skip(1); return; %skip(1); end process_new_report; %skip(5); process_new_retrieval: proc; %skip(3); based_display_arg_results.new_retrieval_flag = ON; %skip(1); return; %skip(1); end process_new_retrieval; %page; process_old_report: proc; %skip(3); based_display_arg_results.new_report_flag = OFF; %skip(1); return; %skip(1); end process_old_report; %skip(5); process_old_retrieval: proc; %skip(3); based_display_arg_results.new_retrieval_flag = OFF; %skip(1); return; %skip(1); end process_old_retrieval; %page; process_output_file: proc; %skip(3); if ^still_processing_args then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-output_file must be followed by a pathname."); call get_next_arg; based_display_arg_results.output_file_flag = ON; based_display_arg_results.output_file_pathname = arg; based_display_arg_results.scroll_flag = OFF; based_display_arg_results.output_switch_flag = OFF; %skip(1); return; %skip(1); end process_output_file; %page; process_output_switch: proc; %skip(3); if ^still_processing_args then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-output_switch must be followed by a switch name."); call get_next_arg; based_display_arg_results.output_switch_flag = ON; based_display_arg_results.output_switch_name = arg; based_display_arg_results.output_file_flag = OFF; based_display_arg_results.scroll_flag = OFF; %skip(1); return; %skip(1); end process_output_switch; %page; process_pages: proc; %skip(3); /* The page ranges are handled with a bit map (currently accomodates 10,000 pages). Set bits in the array on for any page numbers given by the user. Page numbers can be given as "N", a blank separated list "N N", a range "N,N", as N to the last page "N," (or "N,$"), and as $ (means the last page). There is a special flag to indicate the last page has been requested. */ %skip(1); based_display_arg_results.all_flag = OFF; based_display_arg_results.scroll_flag = OFF; based_display_arg_results.pages_flag = ON; %skip(1); unspec (based_display_arg_results.specified_pages) = OFF; %skip(1); smallest_page_number = 1; largest_page_number = hbound (based_display_arg_results.specified_pages, 1); %skip(1); if still_processing_args then do; call get_next_arg; first_page_number_supplied = ON; end; else first_page_number_supplied = OFF; %skip(1); if ^first_page_number_supplied | substr (arg, 1, 1) = HYPHEN then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-pages must be followed by at least one page number."); %page; still_processing_page_numbers = ON; do while (still_processing_page_numbers); if verify (arg, PAGE_RANGE_VALID_CHARACTERS) ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, INVALID_PAGE_RANGE, arg); if arg = DOLLAR then based_display_arg_results.last_page_flag = ON; else do; if index (arg, COMMA) = 0 then do; beginning_page_number = cv_dec_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, INVALID_PAGE_RANGE, arg); else ending_page_number = beginning_page_number; end; else do; beginning_page_number = cv_dec_check_ (before (arg, COMMA), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, INVALID_PAGE_RANGE, arg); test_string = after (arg, COMMA); if test_string = "" | test_string = BLANK | test_string = DOLLAR then ending_page_number = largest_page_number; else do; ending_page_number = cv_dec_check_ ((test_string), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, INVALID_PAGE_RANGE, arg); end; end; if (beginning_page_number > ending_page_number) | (beginning_page_number < smallest_page_number) | (ending_page_number > largest_page_number) then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, INVALID_PAGE_RANGE, arg); do loop = beginning_page_number to ending_page_number; based_display_arg_results.specified_pages (loop) = ON; end; end; if still_processing_args then do; call get_next_arg; if substr (arg, 1, 1) = HYPHEN then do; current_arg = current_arg - 1; still_processing_page_numbers = OFF; still_processing_args = ON; end; end; else still_processing_page_numbers = OFF; end; %skip(1); return; %skip(1); end process_pages; %page; process_passes: proc; %skip(3); if ^still_processing_args then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-passes must be followed by the number of passes."); call get_next_arg; if verify (arg, DIGITS) ^= 0 | arg_length > REASONABLE_NUMBER_OF_DIGITS then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^/The value ^a is unacceptable for the number of passes.", arg); based_display_arg_results.flags.passes_flag = ON; based_display_arg_results.miscellaneous.number_of_passes = convert (based_display_arg_results.miscellaneous.number_of_passes, arg); if based_display_arg_results.miscellaneous.number_of_passes = 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^/The value zero is unacceptable for the number of passes."); else if based_display_arg_results.miscellaneous.number_of_passes = 1 then based_display_arg_results.flags.passes_flag = OFF; else; %skip(1); return; %skip(1); end process_passes; %page; process_scroll: proc; %skip(3); if window_system_cant_be_used then call ssu_$abort_line (sci_ptr, video_et_$unable_to_call_wsys); %skip(1); based_display_arg_results.scroll_flag = ON; %skip(1); based_display_arg_results.all_flag = OFF; based_display_arg_results.character_positions_flag = OFF; based_display_arg_results.pages_flag = OFF; based_display_arg_results.output_file_flag = OFF; based_display_arg_results.output_switch_flag = OFF; %skip(1); return; %skip(1); end process_scroll; %page; process_set_keys: proc; %skip(3); dcl psk_pair_of_key_bindings_found bit (1) aligned; dcl psk_function_name char (32); dcl psk_function_key_sequence char (32); %skip(1); if ^still_processing_args then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, SET_KEYS_ERROR_MESSAGE); %skip(1); psk_pair_of_key_bindings_found = OFF; still_processing_set_key_args = ON; %skip(1); do while (still_processing_set_key_args); call get_next_arg; if substr (arg, 1, 1) = HYPHEN | ^still_processing_args then do; if ^psk_pair_of_key_bindings_found | ^still_processing_args then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, SET_KEYS_ERROR_MESSAGE); current_arg = current_arg - 1; still_processing_args = ON; return; end; psk_function_name = arg; call get_next_arg; psk_function_key_sequence = arg; psk_pair_of_key_bindings_found = ON; call linus_display_scroll$set_fkey (scroll_ip, psk_function_name, psk_function_key_sequence, code); if code ^= 0 then if code = linus_error_$bad_fkey_name then call ssu_$abort_line (sci_ptr, linus_error_$bad_fkey_name, "^/^a is not a valid display scroll function name.", psk_function_name); else if code = linus_error_$bad_fkey_sequence then call ssu_$abort_line (sci_ptr, linus_error_$bad_fkey_sequence, "^/^a is not a valid mnemonic function key sequence.", psk_function_key_sequence); else call ssu_$abort_line (sci_ptr, code); if ^still_processing_args then still_processing_set_key_args = OFF; end; %skip(1); return; %skip(1); end process_set_keys; %page; process_sort: proc; %skip(3); if ^still_processing_args then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-sort must be followed by at least one column name or number."); %skip(1); call get_next_arg; if substr (arg, 1, 1) = HYPHEN then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/-sort must be followed by a column name or number, not ^a.", arg); %skip(1); /* Allocate the info structure big enough to hold all columns if they are all given. Keep track of which ones are given during the processing and if duplicates are given then shut things down. A bit map is used to keep track of duplicates. */ no_of_candidate_columns = table_info.column_count; allocate sort_info in (the_area) set (sort_info_ptr); based_display_arg_results.sort_information_ptr = sort_info_ptr; unspec (sort_info) = OFF; %skip(1); allocate sort_bit_map in (the_area) set (sort_bit_map_ptr); unspec (sort_bit_map) = OFF; %skip(1); based_display_arg_results.sort_flag = ON; still_processing_sort_specs = ON; sort_info.number_of_columns_to_sort = 0; %skip(1); /* (1) The name can be given as a name or number so it's normalized so that it's a name. If its not found things are shut down. (2) The name is looked up to find out its order in the selection expression. This operation can't fail because the name used for the lookup is the normalized name. (3) The name found is checked to make sure it's the first time it was given. If its been given before then things are shut down. (4) The number of columns to be sorted is bumped and the number of the column is stored. (5) The next arg (if there is one) is checked to see if its -ascending or one of its brothers. If it is fine. If it's a new control arg then a backup in necessary. If it's the next column name or number then it will be processed the next time through the loop. If it was one of the -ascending family then the next column name or number must be gotten before the loop is repeated (which may cause another backup operation), if there is another column name or number. */ %skip(1); do while (still_processing_sort_specs); %skip(1); /* Have column name or number changed to a name. */ %skip(1); call linus_options$check_identifier (lcb_ptr, OPTIONS.SPECIFIC_COLUMN.NAME (1), (arg), normalized_option_name, code); if code ^= 0 then if code = linus_error_$bad_option_identifier then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/^a is not a valid column name or number.", arg); else call ssu_$abort_line (sci_ptr, code); else; %skip(1); /* Find the number of the column. */ %skip(1); not_found = ON; the_column_name = after (normalized_option_name, BLANK); do loop = 1 to table_info.column_count while (not_found); if table_info.columns.column_name (loop) = the_column_name then do; not_found = OFF; column_number = loop; end; end; %skip(1); /* Reject duplicates, mark ones we've found. */ %skip(1); if not_found then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "^/Logic error while trying to find the column ^a.", arg); if sort_bit_map (column_number) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/The ^a column (#^d) was given more than once in the sort description.", table_info.columns.column_name (column_number), column_number); else sort_bit_map (column_number) = ON; %skip(1); sort_info.number_of_columns_to_sort = sort_info.number_of_columns_to_sort + 1; sort_info.columns.number (sort_info.number_of_columns_to_sort) = column_number; %page; if still_processing_args then do; still_processing_additional_sort_args = ON; do while (still_processing_additional_sort_args); backup_necessary = OFF; next_column_name_found = OFF; call get_next_arg; if arg = HYPHEN_DESCENDING | arg = HYPHEN_DSC then sort_info.columns.descending (sort_info.number_of_columns_to_sort) = ON; else if arg = HYPHEN_ASCENDING | arg = HYPHEN_ASC then; else if arg = HYPHEN_NON_CASE_SENSITIVE | arg = HYPHEN_NCS then sort_info.columns.non_case_sensitive (sort_info.number_of_columns_to_sort) = ON; else if arg = HYPHEN_CASE_SENSITIVE | arg = HYPHEN_CS then; else if substr (arg, 1, 1) = HYPHEN then backup_necessary = ON; else next_column_name_found = ON; if next_column_name_found | backup_necessary then still_processing_additional_sort_args = OFF; else if ^still_processing_args then do; still_processing_additional_sort_args = OFF; still_processing_sort_specs = OFF; end; else; if backup_necessary then do; current_arg = current_arg - 1; still_processing_args = ON; still_processing_sort_specs = OFF; end; end; end; else still_processing_sort_specs = OFF; end; %skip(1); return; %skip(1); end process_sort; %page; process_temp_dir: proc; %skip(3); if ^still_processing_args then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-temp_dir must be followed by a directory name."); call get_next_arg; based_display_arg_results.temp_dir_flag = ON; based_display_arg_results.temp_dir_pathname = arg; %skip(1); return; %skip(1); end process_temp_dir; %page; process_truncate: proc; %skip(3); based_display_arg_results.truncate_flag = ON; %skip(1); return; %skip(1); end process_truncate; %page; process_window: proc; %skip(3); if ^still_processing_args then if arg = "-window" | arg = "-win" then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-window must be followed by the name of a window."); else call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-io_switch must be followed by the name of a switch."); else; call get_next_arg; based_display_arg_results.window_flag = ON; based_display_arg_results.window_name = arg; %skip(1); return; %skip(1); end process_window; %page; process_time: proc; %skip(3); based_display_arg_results.time_flag = ON; %skip(1); return; %skip(1); end process_time; %page; get_next_arg: proc; %skip(3); call ssu_$arg_ptr (sci_ptr, current_arg, arg_ptr, arg_length); current_arg = current_arg + 1; if current_arg > no_of_args_supplied then still_processing_args = OFF; %skip(1); return; %skip(1); end get_next_arg; %page; setup_additional_pathnames: proc; %skip(3); /* If the user has requested the report be saved then expand the pathname given and stash away the dir and entry names. If a temp_dir was specified then expand and stash it away also. */ %skip(1); if based_display_arg_results.output_file_flag then do; call expand_pathname_ ( based_display_arg_results.output_file_pathname, based_display_arg_results.output_file_directory_name, based_display_arg_results.output_file_entry_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/Unable to expand the -output_file pathname ^a.", based_display_arg_results.output_file_pathname); end; %skip(1); if based_display_arg_results.temp_dir_flag then do; call expand_pathname_ ( based_display_arg_results.temp_dir_pathname, temporary_dir_name, entry_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/Unable to expand the -temp_dir name ^a.", based_display_arg_results.temp_dir_pathname); call hcs_$status_minf (temporary_dir_name, entry_name, 1, type, bit_count, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/Unable to get the status of the directory ^a.", rtrim (based_display_arg_results.temp_dir_pathname)); if type ^= DIRECTORY | (type = DIRECTORY & bit_count > 0) then call ssu_$abort_line (sci_ptr, error_table_$notadir, "^/-temp_dir must be followed by a directory name."); based_display_arg_results.temp_dir_pathname = rtrim (temporary_dir_name) || ">" || rtrim (entry_name); end; %skip(1); return; %skip(1); end setup_additional_pathnames; %page; /* To change this table also change the process_arg_procs table. */ %skip(1); dcl ARGUMENT_NAME_TABLE (55) char (21) varying static int options (constant) init ( "-a", /* process_all */ "-all", /* process_all */ "-bf", /* process_brief */ "-brief", /* process_brief */ "-character_positions", /* process_character_positions */ "-chpsn", /* process_character_positions */ "-debug", /* process_debug */ "-discard_report", /* process_discard_report */ "-discard_retrieval", /* process_discard_retrieval */ "-dsr", /* process_discard_retrieval */ "-dsrp", /* process_discard_report */ "-eek", /* process_enable_escape_keys */ "-efk", /* process_enable_function_keys */ "-enable_escape_keys", /* process_enable_escape_keys */ "-enable_function_keys", /* process_enable_function_keys */ "-extend", /* process_extend */ "-io_switch", /* process_window */ "-iosw", /* process_window */ "-keep_report", /* process_keep_report */ "-keep_retrieval", /* process_keep_retrieval */ "-kr", /* process_keep_retrieval */ "-krp", /* process_keep_report */ "-lg", /* process_long */ "-long", /* process_long */ "-new_report", /* process_new_report */ "-new_retrieval", /* process_new_retrieval */ "-nr", /* process_new_retrieval */ "-nrp", /* process_new_report */ "-of", /* process_output_file */ "-old_report", /* process_old_report */ "-old_retrieval", /* process_old_retrieval */ "-or", /* process_old_retrieval */ "-orp", /* process_old_report */ "-osw", /* process_output_switch */ "-output_file", /* process_output_file */ "-output_switch", /* process_output_switch */ "-page", /* process_pages */ "-pages", /* process_pages */ "-pass", /* process_passes */ "-passes", /* process_passes */ "-pg", /* process_pages */ "-pgs", /* process_pages */ "-scroll", /* process_scroll */ "-set_key", /* process_set_keys */ "-set_keys", /* process_set_keys */ "-sk", /* process_set_keys */ "-sks", /* process_set_keys */ "-sort", /* process_sort */ "-tc", /* process_truncate */ "-td", /* process_temp_dir */ "-temp_dir", /* process_temp_dir */ "-time", /* process_time */ "-truncate", /* process_truncate */ "-win", /* process_window */ "-window" /* process_window */ ); dcl BLANK char (1) static int options (constant) init (" "); dcl COMMA char (1) static int options (constant) init (","); dcl DIRECTORY fixed bin (2) static int options (constant) init (2); dcl DIGITS char (10) static int options (constant) init ("0123456789"); dcl DOLLAR char (1) static int options (constant) init ("$"); dcl HYPHEN char (1) static int options (constant) init ("-"); dcl HYPHEN_ASCENDING char (10) static int options (constant) init ("-ascending"); dcl HYPHEN_ASC char (4) static int options (constant) init ("-asc"); dcl HYPHEN_CASE_SENSITIVE char (15) static int options (constant) init ("-case_sensitive"); dcl HYPHEN_CS char (3) static int options (constant) init ("-cs"); dcl HYPHEN_DESCENDING char (11) static int options (constant) init ("-descending"); dcl HYPHEN_DSC char (4) static int options (constant) init ("-dsc"); dcl HYPHEN_NON_CASE_SENSITIVE char (19) static int options (constant) init ("-non_case_sensitive"); dcl HYPHEN_NCS char (4) static int options (constant) init ("-ncs"); dcl INVALID_PAGE_RANGE char (46) static int options (constant) init ("^/^a is not a valid page number or page range."); dcl OFF bit (1) static int options (constant) init ("0"b); dcl ON bit (1) static int options (constant) init ("1"b); dcl PAGE_RANGE_VALID_CHARACTERS char (13) static int options (constant) init (" ,$0123456789"); dcl REASONABLE_NUMBER_OF_DIGITS fixed bin static int options (constant) init (5); dcl SET_KEYS_ERROR_MESSAGE char (66) static internal options (constant) init ( "^/-set_keys must be followed by at least one pair of key bindings."); %page; dcl addr builtin; dcl after builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; dcl argument_number fixed bin; %skip(1); dcl backup_necessary bit (1) aligned; dcl 1 based_display_arg_results like display_arg_results based (based_display_arg_results_ptr); dcl based_display_arg_results_ptr ptr; dcl before builtin; dcl beginning_page_number fixed bin; dcl bit_count fixed bin (24); %skip(1); dcl code fixed bin (35); dcl column_number fixed bin; dcl convert builtin; dcl current_arg fixed bin; dcl cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35)); %skip(1); dcl divide builtin; %skip(1); dcl ending_page_number fixed bin; dcl entry_name char (32); dcl error_table_$bad_arg fixed bin(35) ext static; dcl error_table_$bad_conversion fixed bin(35) ext static; dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$no_operation fixed bin(35) ext static; dcl error_table_$no_table fixed bin(35) ext static; dcl error_table_$notadir fixed bin(35) ext static; dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); %skip(1); dcl first_page_number_supplied bit (1) aligned; dcl function_keys_can_be_used bit (1) aligned; %skip(1); dcl generate_right_margin_position bit (1) aligned; %skip(1); dcl hbound builtin; dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); %skip(1); dcl index builtin; dcl ioa_$ioa_switch entry() options(variable); dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); dcl iox_$error_output ptr ext static; dcl iox_$user_io ptr ext static; %skip(1); dcl largest_page_number fixed bin; dcl lcb_ptr ptr; dcl linus_display_scroll$set_fkey entry (ptr, char(*), char(*), fixed bin(35)); dcl linus_error_$bad_fkey_name fixed bin(35) ext static; dcl linus_error_$bad_fkey_sequence fixed bin(35) ext static; dcl linus_error_$bad_option_identifier fixed bin(35) ext static; dcl linus_error_$bad_report_setup fixed bin(35) ext static; dcl linus_options$check_identifier entry (ptr, char(*) var, char(*) var, char(*) var, fixed bin(35)); dcl linus_options$get entry (ptr, char(*) var, char(*) var, char(*) var, char(*) var, fixed bin(35)); dcl 1 local_terminal_info like terminal_info; dcl loop fixed bin; dcl loop1 fixed bin; dcl loop2 fixed bin; dcl loop3 fixed bin; %skip(1); dcl next_column_name_found bit (1) aligned; dcl no_of_args_supplied fixed bin; dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying; dcl not_found bit (1) aligned; dcl null builtin; %skip(1); dcl option_value char (32) varying; %skip(1); /* To change this table also change the ARGUMENT_NAME_TABLE table. */ %skip(1); dcl process_arg_procs (55) entry init ( process_all, /* "-a" */ process_all, /* "-all" */ process_brief, /* "-bf" */ process_brief, /* "-brief" */ process_character_positions, /* "-character_positions" */ process_character_positions, /* "-chpsn" */ process_debug, /* "-debug" */ process_discard_report, /* "-discard_report" */ process_discard_retrieval, /* "-discard_retrieval" */ process_discard_retrieval, /* "-dsr" */ process_discard_report, /* "-dsrp" */ process_enable_escape_keys, /* "-eek" */ process_enable_function_keys, /* "-efk" */ process_enable_escape_keys, /* "-enable_escape_keys" */ process_enable_function_keys, /* "-enable_function_keys" */ process_extend, /* "-extend" */ process_window, /* "-io_switch" */ process_window, /* "-iosw" */ process_keep_report, /* "-keep_report" */ process_keep_retrieval, /* "-keep_retrieval" */ process_keep_retrieval, /* "-kr" */ process_keep_report, /* "-krp" */ process_long, /* "-lg" */ process_long, /* "-long" */ process_new_report, /* "-new_report" */ process_new_retrieval, /* "-new_retrieval" */ process_new_retrieval, /* "-nr" */ process_new_report, /* "-nrp" */ process_output_file, /* "-of" */ process_old_report, /* "-old_report" */ process_old_retrieval, /* "-old_retrieval" */ process_old_retrieval, /* "-or" */ process_old_report, /* "-orp" */ process_output_switch, /* "-osw" */ process_output_file, /* "-output_file" */ process_output_switch, /* "-output_switch" */ process_pages, /* "-page" */ process_pages, /* "-pages" */ process_passes, /* "-pass" */ process_passes, /* "-passes" */ process_pages, /* "-pg" */ process_pages, /* "-pgs" */ process_scroll, /* "-scroll" */ process_set_keys, /* "-set_key" */ process_set_keys, /* "-set_keys" */ process_set_keys, /* "-sk" */ process_set_keys, /* "-sks" */ process_sort, /* "-sort" */ process_truncate, /* "-tc" */ process_temp_dir, /* "-td" */ process_temp_dir, /* "-temp_dir" */ process_time, /* "-time" */ process_truncate, /* "-truncate" */ process_window, /* "-win" */ process_window /* "-window" */ ); %skip(1); dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl smallest_page_number fixed bin; dcl sort_bit_map (no_of_candidate_columns) bit (1) based (sort_bit_map_ptr); dcl sort_bit_map_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl still_processing_additional_sort_args bit (1) aligned; dcl still_processing_args bit (1) aligned; dcl still_processing_page_numbers bit (1) aligned; dcl still_processing_set_key_args bit (1) aligned; dcl still_processing_sort_specs bit (1) aligned; dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl temporary_dir_name char (168); dcl test_string char (8) varying; dcl the_area area (sys_info$max_seg_size) based (the_area_ptr); dcl the_area_ptr ptr; dcl the_column_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying; dcl time1 float bin (63); dcl time2 float bin (63); dcl type fixed bin (2); %skip(1); dcl unspec builtin; dcl ttt_info_$function_key_data entry (char(*), ptr, ptr, fixed bin(35)); %skip(1); dcl vclock builtin; dcl verify builtin; dcl video_et_$unable_to_call_wsys fixed bin(35) ext static; %skip(1); dcl window_system_cant_be_used bit (1) aligned; %page; %include arg_descriptor; %page; %include arg_list; %page; %include function_key_data; %page; %include linus_display_arg_list; %page; %include linus_format_options; %page; %include linus_options_extents; %page; %include linus_scroll_info; %page; %include linus_sort_info; %page; %include linus_table_info; %skip(1); %page; %include terminal_info; %skip(1); end linus_display_process_args;  linus_display_scroll.pl1 11/01/84 1441.5r w 11/01/84 1304.1 587430 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the subroutine called by the display request to implement the linus display scrolling feature. Description and usage follows. Description: This module provides for the display of paginated and unpaginated reports through the video system. It also provides the function of setting a scroll function to a provided key sequence. This program operates in conjunction with linus_display_process_args (initial setup of the scroll_info structure) and linus_display (the caller of this subroutine). Usage: See the entrypoints for parameter descriptions. The entrypoint set_fkey is called by linus_display_process_args to set any functions to key sequences provided on the request line when the display request is given. The start, continue, and stop entrypoints are called by the linus_display module for setup, scrolling, and termination respectively. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_display_scroll: proc; %skip(3); /* These parameters are described at each entry where they are used. */ %skip(1); dcl code_parm fixed bin (35) parm; dcl display_arg_results_ptr_parm ptr parm; dcl function_name_parm char (*) parm; dcl function_key_sequence_parm char (*) parm; dcl rci_ptr_parm ptr parm; dcl sci_ptr_parm ptr parm; dcl scroll_info_ptr_parm ptr parm; dcl work_area_ptr_parm ptr parm; %skip(3); RETURN_TO_CALLING_PROGRAM: %skip(1); return; %page; continue: entry ( scroll_info_ptr_parm, /* input: ptr to the scroll_info structure */ code_parm /* output: success, failure, or user quit (error_table_$end_of_info) */ ); %skip(3); /* Mainline Processing Overview (1) Perform initialization. (2) Display a portion of the current page or buffer. Signal display_buffer_empty if we cross a buffer boundary in the middle of the display (unpaginated reports only). (3) Read a key sequence which tells us what to do next. (4) Perform the function the user has requested (e.g. forward). (5) Repeat 2 through 4 if we're still in the current page or buffer. Return to caller if we're outside of it, or if we crossed a buffer boundary during the display. */ %skip(3); scroll_ip = scroll_info_ptr_parm; code_parm = 0; call housekeeping; call scroll_the_report; code_parm = code; %skip(1); return; %page; set_fkey: entry ( scroll_info_ptr_parm, /* input: ptr to the scroll_info strucure */ function_name_parm, /* input: function to set the key to */ function_key_sequence_parm, /* input: the key sequence */ code_parm /* output: success or failure */ ); %skip(3); /* Mainline Processing Overview (1) Translate any mnemonic key sequences into the characters the terminal generates ("escape-", "esc-", "control-" and "ctl-" are translated). (2) Translate key sequences given as mnemonics into the characters the terminal generates (i.e. translate "up_arrow" into whatever the particular terminal generates when the up arrow is pressed). (3) Assign the translated key sequence to the table entry for that particular function. */ %skip(3); scroll_ip = scroll_info_ptr_parm; function_key_data_ptr = scroll_info.function_key_data_pointer; function_name = function_name_parm; function_key_sequence = function_key_sequence_parm; call set_function_key (function_name, function_key_sequence, code); code_parm = code; %skip(1); return; %page; start: entry ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ rci_ptr_parm, /* input: ptr to the report_control_info structure */ display_arg_results_ptr_parm, /* input: ptr to the display_arg_results structure */ work_area_ptr_parm /* input: ptr to a work area */ ); %skip(3); /* Mainline Processing Overview (1) Allocate various structures needed for the video system. (2) Turn on the video system if it's not already on. (3) If window was specified by the user check it out to make sure it meets the requirements. If window wasn't specified, then set one up and shrink user_i/o. (4) Setup the format_document_options structure for filling of help strings to the window width. */ %skip(3); sci_ptr = sci_ptr_parm; report_cip = rci_ptr_parm; display_results_ptr = display_arg_results_ptr_parm; work_area_ptr = work_area_ptr_parm; call setup_scroll; %skip(1); return; %page; stop: entry ( scroll_info_ptr_parm /* input: ptr to the scroll_info structure */ ); %skip(3); /* Mainline Processing Overview (1) If window wasn't specified by the user then destroy the window we created and put back user_i/o to the same state as we found it. (2) Turn off the video system if we turned it on. */ %skip(3); if scroll_info_ptr_parm = null () then return; scroll_ip = scroll_info_ptr_parm; call housekeeping; call terminate_scroll; %skip(1); return; %page; abort_line: proc ( code_parm, /* input: the code that caused the error */ message_parm /* input: additional information */ ); %skip(1); dcl code_parm fixed bin (35) parm; dcl message_parm_length fixed bin; dcl message_parm char (*) parm; %skip(3); if code_parm ^= 0 then do; call convert_status_code_ (code_parm, short_message, long_message); error_message = "^/" || rtrim (long_message); end; else error_message = ""; %skip(1); message_parm_length = length (rtrim (message_parm)); if message_parm_length > 0 then error_message = error_message || "^/" || rtrim (message_parm); %skip(1); call ssu_$abort_line (sci_ptr, linus_error_$bad_report_display, error_message); %skip(1); end abort_line; %page; check_code: proc; %skip(3); /* It is only valid to call this proc if the entrypoint "continue" was called. This proc takes care of the details of hiding the "window_status_pending" error code returned by any of the many, many different window_ entrypoints this subroutine calls. When this ugly error code is returned there is not enough information that can be gotten to do anything reasonable. For example, if we could determine from the video system where in the window the asyncronous output was written to, we could at least write around it or prompt the user to see if she has read it. But there isn't anything like that. Instead we get two bits, saying if there was asyncronous output or that the screen is invalid. This proc does a get_window_status control order, returns to linus_display, who immediately calls back here, resulting in a redisplay of the window. Invalid screens are the only thing we get in the default case, so this is always the correct action. In the case of the experienced user who has set up her own windows, if she has missed a message through this redisplay she can see them again with the multics_mode function or set up her windows more intelligently next time. */ %skip(1); if code = 0 then return; %skip(1); if code = video_et_$window_status_pending then call iox_$control (window_iocb_ptr, "get_window_status", window_status_info_ptr, code); %skip(1); code_parm = code; goto RETURN_TO_CALLING_PROGRAM; %skip(1); end check_code; %page; display_chunk_of_page: proc; %skip(1); dcl dcop_buffer_empty_pending bit (1) aligned; dcl dcop_current_line_on_page fixed bin; dcl dcop_current_line_on_screen fixed bin; dcl dcop_number_of_chars_to_write fixed bin; dcl dcop_loop fixed bin; dcl dcop_loop_limit fixed bin; dcl display_buffer_empty condition; %skip(1); dcop_buffer_empty_pending = OFF; call window_$clear_window (window_iocb_ptr, code); call check_code; %skip(1); /* Set the width so we don't exceed the portion of the page left or the window width. */ %skip(1); if page_info.width - 1 <= report_output_window_position_info.width then; else if scroll_info.left_vertical_position + report_output_window_position_info.width > page_info.width then scroll_info.left_vertical_position = page_info.width - report_output_window_position_info.width; dcop_number_of_chars_to_write = min (page_info.width - scroll_info.left_vertical_position, report_output_window_position_info.width); %skip(1); /* target_line_number can be less than 1 or greater than the page length. Adjust accordingly. */ %skip(1); if scroll_info.target_line_number < 1 then scroll_info.target_line_number = 1; else if report_control_info.flags.report_is_paginated then if scroll_info.target_line_number > page_info.length then scroll_info.target_line_number = max (1, page_info.length - scroll_info.vertical_scroll_distance); else; else; %skip(1); /* Simulate the line printer software's 3 blank lines if appropriate. */ %skip(1); if scroll_info.target_line_number = 1 & (report_control_info.flags.report_is_paginated | scroll_info.target_page_number = 1) then scroll_info.top_margin_offset = 3; else scroll_info.top_margin_offset = 0; %skip(1); /* Set limits, prepare to hit a buffer boundary for unpaginated reports in the middle of the display. */ %skip(1); dcop_current_line_on_page = scroll_info.target_line_number; dcop_current_line_on_screen = scroll_info.top_margin_offset + 1; dcop_loop_limit = min ( report_output_window_position_info.height - dcop_current_line_on_screen + 1, page_info.length - dcop_current_line_on_page + 1); %skip(1); if ^report_control_info.flags.report_is_paginated then if (page_info.length - dcop_current_line_on_page + 1 < report_output_window_position_info.height - dcop_current_line_on_screen + 1) & (^report_control_info.flags.report_is_formatted | (report_control_info.flags.report_is_formatted & scroll_info.target_page_number ^= report_control_info.no_of_formatted_pages)) then do; dcop_loop_limit = report_output_window_position_info.height - dcop_current_line_on_screen + 1; dcop_buffer_empty_pending = ON; end; else; else; %skip(1); /* Do the display, don't bother to write blank lines. */ %skip(1); do dcop_loop = 1 to dcop_loop_limit; call window_$position_cursor (window_iocb_ptr, dcop_current_line_on_screen, 1, code); call check_code; if substr (page_defined_as_lines (dcop_current_line_on_page), scroll_info.left_vertical_position, dcop_number_of_chars_to_write) = BLANK then; else do; call window_$overwrite_text (window_iocb_ptr, substr (page_defined_as_lines (dcop_current_line_on_page), scroll_info.left_vertical_position, dcop_number_of_chars_to_write), code); call check_code; end; dcop_current_line_on_screen = dcop_current_line_on_screen + 1; dcop_current_line_on_page = dcop_current_line_on_page + 1; if dcop_buffer_empty_pending then if dcop_current_line_on_page > page_info.length then do; scroll_info.target_page_number = scroll_info.target_page_number + 1; scroll_info.last_line_number_in_previous_buffer = page_info.length; signal display_buffer_empty; scroll_info.flags.buffer_boundary_just_crossed = ON; scroll_info.target_page_number = scroll_info.target_page_number - 1; dcop_current_line_on_page = 1; page_ip = scroll_info.page_info_pointer; end; else; else; end; %skip(1); /* Position cursor to bottom right hand side of window. */ %skip(1); call window_$position_cursor (window_iocb_ptr, report_output_window_position_info.height, report_output_window_position_info.width, code); call check_code; %skip(1); return; %skip(1); end display_chunk_of_page; %page; get_users_response: proc (gur_buffer_parm); %skip(1); dcl gur_buffer_parm char (*) parm; dcl gur_character_read char (1) varying; dcl gur_loop fixed bin; dcl gur_partial_match bit (1) aligned; %skip(1); /* Keep reading characters until we get a match, get a mis-match, or fill the buffer. */ %skip(1); gur_buffer_parm = ""; gur_partial_match = ON; %skip(1); do gur_loop = 1 to length (gur_buffer_parm) while (gur_partial_match); call window_$get_one_unechoed_char (window_iocb_ptr, gur_character_read, ON, code); call check_code; substr (gur_buffer_parm, gur_loop, 1) = gur_character_read; if (gur_buffer_parm = scroll_info.keys.forward) | (gur_buffer_parm = scroll_info.keys.backward) | (gur_buffer_parm = scroll_info.keys.left) | (gur_buffer_parm = scroll_info.keys.right) | (gur_buffer_parm = scroll_info.keys.help) | (gur_buffer_parm = scroll_info.keys.set_key) | (gur_buffer_parm = scroll_info.keys.set_scroll_increment) | (gur_buffer_parm = scroll_info.keys.quit) | (gur_buffer_parm = scroll_info.keys.redisplay) | (gur_buffer_parm = scroll_info.keys.start_of_report) | (gur_buffer_parm = scroll_info.keys.end_of_report) | (gur_buffer_parm = scroll_info.keys.multics_mode) | (gur_buffer_parm = scroll_info.keys.goto) then return; gur_partial_match = (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.forward, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.backward, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.left, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.right, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.help, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.set_key, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.set_scroll_increment, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.quit, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.redisplay, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.start_of_report, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.end_of_report, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.multics_mode, 1, gur_loop)) | (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.goto, 1, gur_loop)); end; %skip(1); return; %skip(1); end get_users_response; %page; housekeeping: proc; %skip(3); /* Move the pointers for our needed structures. */ %skip(1); display_results_ptr = scroll_info.display_arg_results_ptr; report_cip = scroll_info.report_control_info_ptr; work_area_ptr = scroll_info.area_ptr; user_io_window_position_ip = scroll_info.user_io_window_position_info_ptr; report_output_window_position_ip = scroll_info.report_output_window_position_info_ptr; sci_ptr = scroll_info.ssu_info_ptr; window_iocb_ptr = report_control_info.display_iocb_ptr; page_ip = scroll_info.page_info_pointer; window_status_info_ptr = scroll_info.window_status_info_pointer; function_key_data_ptr = scroll_info.function_key_data_pointer; format_document_options_ptr = scroll_info.format_document_op; %skip(1); return; %skip(1); end housekeeping; %page; prompt_for_more: proc ( pfm_line_in_window_parm, /* input: where to write the prompt */ pfm_user_wants_more_parm /* output: on if user wants more */ ); %skip(3); dcl pfm_break_character char (1) varying; dcl pfm_buffer char (1); dcl pfm_line_in_window_parm fixed bin parm; dcl pfm_number_of_chars_read fixed bin (21); dcl pfm_still_looking_for_a_valid_response bit (1) aligned; dcl pfm_user_wants_more_parm bit (1) aligned parm; %skip(1); /* Write the more prompt on caller designated line. Accept CR and DEL and mark parm accordingly. */ %skip(1); pfm_still_looking_for_a_valid_response = ON; %skip(1); do while (pfm_still_looking_for_a_valid_response); pfm_still_looking_for_a_valid_response = OFF; call window_$position_cursor (window_iocb_ptr, pfm_line_in_window_parm, 1, code); call check_code; call window_$clear_to_end_of_line (window_iocb_ptr, code); call check_code; call window_$write_sync_read (window_iocb_ptr, MORE_PROMPT, 1, pfm_buffer, pfm_number_of_chars_read, pfm_break_character, code); call check_code; if pfm_number_of_chars_read = 0 then if pfm_break_character = CARRIAGE_RETURN then pfm_user_wants_more_parm = ON; else if pfm_break_character = DEL then pfm_user_wants_more_parm = OFF; else pfm_still_looking_for_a_valid_response = ON; else pfm_still_looking_for_a_valid_response = ON; if pfm_still_looking_for_a_valid_response then do; call window_$bell (window_iocb_ptr, code); call check_code; end; end; %skip(1); return; %skip(1); end prompt_for_more; %page; prompt_user: proc ( pu_prompt_parm, /* input: the prompt */ pu_number_parm, /* output: the numeric response, or, */ pu_response_parm, /* output: the character response */ pu_numeric_parm /* input: if on a numeric response is required */ ); %skip(1); dcl pu_number_of_chars_read fixed bin (21); dcl pu_number_parm fixed bin (35) parm; dcl pu_numeric_parm bit (1) aligned parm; dcl pu_prompt_parm char (*) parm; dcl pu_response_buffer char (256); dcl pu_response_line fixed bin; dcl pu_response_parm char (*) parm; dcl pu_still_looking_for_a_valid_response bit (1) aligned; dcl pu_window_status_pending condition; dcl pu_window_status_pending_flag bit (1) aligned; %skip(3); /* Prompt the user with the supplied prompt in the last line of the window. Accept a numeric or character response depending on the setting of pu_numeric_parm. Keep prompting until we get a valid response. If we get a window_status_pending then re-write prompt on the first line of the window after doing a get_window_status control order. Use the iox_ entry point rather than a window_ entrypoint because the window_ system still doesn't have an equivalent. Note that the horrid window_status_pending never comes back from the iox_ entrypoint. */ %skip(1); pu_window_status_pending_flag = OFF; %skip(1); on pu_window_status_pending begin; pu_window_status_pending_flag = ON; pu_response_line = 1; call write_prompt; end; %skip(1); pu_number_parm = 0; pu_response_parm = ""; pu_still_looking_for_a_valid_response = ON; pu_response_line = report_output_window_position_info.height; %page; do while (pu_still_looking_for_a_valid_response); call write_prompt; call iox_$get_line (window_iocb_ptr, addr (pu_response_buffer), length (pu_response_buffer), pu_number_of_chars_read, code); if code ^= 0 then if code = error_table_$long_record then; else call abort_line (code, "Unable to read prompt response."); else do; pu_number_of_chars_read = pu_number_of_chars_read - 1; if pu_numeric_parm then if pu_number_of_chars_read > 0 & pu_number_of_chars_read < 10 then pu_still_looking_for_a_valid_response = (verify (substr (pu_response_buffer, 1, pu_number_of_chars_read), DIGITS) ^= 0); else; else pu_still_looking_for_a_valid_response = OFF; end; if pu_still_looking_for_a_valid_response then do; call window_$bell (window_iocb_ptr, code); if code ^= 0 then signal pu_window_status_pending; else; end; end; %skip(1); if pu_numeric_parm then pu_number_parm = convert (pu_number_parm, substr (pu_response_buffer, 1, pu_number_of_chars_read)); else pu_response_parm = substr (pu_response_buffer, 1, pu_number_of_chars_read); %skip(1); return; %page; write_prompt: proc; %skip(3); /* Repeat the sequence until we correctly write the prompt. */ %skip(1); if pu_window_status_pending_flag then do; call iox_$control (window_iocb_ptr, "get_window_status", window_status_info_ptr, code); if code ^= 0 then call abort_line (code, "Unable to peform a get_window_status control order."); pu_window_status_pending_flag = OFF; end; %skip(1); call window_$position_cursor (window_iocb_ptr, pu_response_line, 1, code); call window_$clear_to_end_of_line (window_iocb_ptr, code); call window_$overwrite_text (window_iocb_ptr, rtrim (pu_prompt_parm) || " (end with RETURN) ->", code); %skip(1); if code ^= 0 then if code = video_et_$window_status_pending then signal pu_window_status_pending; else call abort_line (code, "Unable to write the prompt."); else; %skip(1); return; %skip(1); end write_prompt; %skip(1); end prompt_user; %page; scroll_the_report: proc; %skip(3); /* Display a chunk of the page or buffer. Perform the scrolling function requested by the user. Return to the caller if we're outside of the current page, or if we just crossed a buffer boundary. */ %skip(1); still_in_the_scrolling_business = ON; %skip(1); do while (still_in_the_scrolling_business); call display_chunk_of_page; call setup_for_next_chunk; end; %skip(1); return; %skip(1); end scroll_the_report; %page; set_function_key: proc ( sfk_function_name_parm, /* input: function to set key to */ sfk_function_key_sequence_parm, /* input: key sequence to set */ sfk_code_parm /* output: success or failure */ ); %skip(3); dcl sfk_char_10 char (10); dcl sfk_character_loop char (length (CONTROL_HYPHEN)); dcl sfk_code_parm fixed bin (35) parm; dcl sfk_function_name_parm char (*) parm; dcl sfk_function_key_sequence_parm char (*) parm; dcl sfk_function_key_sequence char (32); dcl sfk_function_key_sequence_buffer char (32); dcl sfk_loop fixed bin; dcl sfk_no_match bit (1) aligned; %skip(3); /* Translate "escape-", "esc-", "control-X", "ctl-X", to the sequence the terminal generates, where X is the character following the "control-" or "ctl-" mnemonic. Next translate any of the recognized mnemonics in the provided key sequence to what the terminal generates (i.e. translate "down_arrow" into whatever the terminal generates). Look up the supplied scrolling function name and assign the key sequence to the slot in the table. Assign the mnemonic key sequence to the slot in another table for it's display when help is invoked. */ %skip(1); sfk_code_parm = 0; if index (sfk_function_key_sequence_parm, ESCAPE_HYPHEN) = 0 & index (sfk_function_key_sequence_parm, ESC_HYPHEN) = 0 & index (sfk_function_key_sequence_parm, CONTROL_HYPHEN) = 0 & index (sfk_function_key_sequence_parm, CTL_HYPHEN) = 0 then sfk_function_key_sequence = sfk_function_key_sequence_parm; else do; sfk_function_key_sequence = sfk_function_key_sequence_parm; do sfk_character_loop = ESCAPE_HYPHEN, ESC_HYPHEN, CONTROL_HYPHEN, CTL_HYPHEN; call translate_mnemonics (sfk_function_key_sequence, sfk_character_loop, sfk_function_key_sequence_buffer, sfk_code_parm); if sfk_code_parm ^= 0 then return; sfk_function_key_sequence = sfk_function_key_sequence_buffer; end; end; %page; if sfk_function_key_sequence = KEY_MNEMONICS.FORWARD then sfk_function_key_sequence = substr (function_key_seqs, function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_index, function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_length); else if sfk_function_key_sequence = KEY_MNEMONICS.BACKWARD then sfk_function_key_sequence = substr (function_key_seqs, function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_index, function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_length); else if sfk_function_key_sequence = KEY_MNEMONICS.LEFT then sfk_function_key_sequence = substr (function_key_seqs, function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_index, function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_length); else if sfk_function_key_sequence = KEY_MNEMONICS.RIGHT then sfk_function_key_sequence = substr (function_key_seqs, function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_index, function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_length); else if sfk_function_key_sequence = HOME then sfk_function_key_sequence = substr (function_key_seqs, function_key_data.cursor_motion_keys.home (KEY_PLAIN).sequence_index, function_key_data.cursor_motion_keys.home (KEY_PLAIN).sequence_length); else do; sfk_no_match = ON; do sfk_loop = 0 to hbound (function_key_data.function_keys, 1) while (sfk_no_match); if sfk_function_key_sequence = "f" || ltrim (convert (sfk_char_10, sfk_loop)) then do; sfk_function_key_sequence = substr (function_key_seqs, function_key_data.function_keys (sfk_loop, KEY_PLAIN).sequence_index, function_key_data.function_keys (sfk_loop, KEY_PLAIN).sequence_length); sfk_no_match = OFF; end; end; end; %skip(1); do sfk_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER; if sfk_function_name_parm = FUNCTION_NAMES_AS_A_TABLE (sfk_loop) then do; keys_as_a_table (sfk_loop) = sfk_function_key_sequence; mnemonic_key_sequences_as_a_table (sfk_loop) = sfk_function_key_sequence_parm; return; end; end; %skip(1); sfk_code_parm = linus_error_$bad_fkey_name; %skip(1); return; %page; translate_mnemonics: proc ( tm_string_in_parm, /* input: string to be translated */ tm_mnemonic_parm, /* input: the mnemonic to be translated */ tm_string_out_parm, /* output: the translated string */ tm_code_parm /* output: success or failure */ ); %skip(1); dcl tm_code_parm fixed bin (35) parm; dcl tm_current_position fixed bin; dcl tm_escape_is_replacement_char bit (1) aligned; dcl tm_mnemonic_length fixed bin; dcl tm_mnemonic char (32) varying; dcl tm_mnemonic_parm char (*) parm; dcl tm_still_translating bit (1) aligned; dcl tm_string_in_parm char (*) parm; dcl tm_string_index fixed bin; dcl tm_string_length fixed bin; dcl tm_string_out_parm char (*) parm; dcl tm_string_varying char (32) varying; dcl tm_target_character_index fixed bin; dcl tm_translation_index fixed bin; %skip(3); /* Translate "escape-", "esc-", "control-X", and "ctl-X" into the sequence the terminal generates. The "control-" or "ctl-" mnemonic has to be followed by another character, as a terminal can't generate control without pressing some other key. */ %skip(1); tm_code_parm = 0; tm_mnemonic = rtrim (tm_mnemonic_parm); %skip(1); if index (tm_string_in_parm, tm_mnemonic) = 0 then do; tm_string_out_parm = tm_string_in_parm; return; end; %skip(1); tm_mnemonic_length = length (tm_mnemonic); tm_escape_is_replacement_char = (tm_mnemonic = ESCAPE_HYPHEN | tm_mnemonic = ESC_HYPHEN); tm_string_varying = ""; tm_still_translating = ON; tm_string_length = length (rtrim (tm_string_in_parm)); tm_current_position = 1; %page; do while (tm_still_translating); tm_string_index = index (substr (tm_string_in_parm, tm_current_position), tm_mnemonic); if tm_string_index ^= 0 then do; if tm_current_position < tm_string_index then tm_string_varying = tm_string_varying || substr (tm_string_in_parm, tm_current_position, tm_string_index - tm_current_position); if tm_escape_is_replacement_char then do; tm_string_varying = tm_string_varying || ESCAPE; tm_current_position = tm_current_position + tm_string_index + tm_mnemonic_length - 1; end; else do; tm_target_character_index = tm_current_position + tm_string_index + tm_mnemonic_length - 1; if tm_target_character_index > tm_string_length then do; tm_code_parm = linus_error_$bad_fkey_sequence; return; end; tm_translation_index = index (TRANSLATION_TABLE, substr (tm_string_in_parm, tm_target_character_index, 1)); if tm_translation_index = 0 then do; tm_code_parm = linus_error_$bad_fkey_sequence; return; end; if tm_translation_index > 32 then tm_translation_index = tm_translation_index - 32; tm_string_varying = tm_string_varying || byte (tm_translation_index - 1); tm_current_position = tm_target_character_index + 1; end; if tm_current_position > tm_string_length then tm_still_translating = OFF; end; else do; if tm_string_length >= tm_current_position then tm_string_varying = tm_string_varying || substr (tm_string_in_parm, tm_current_position); tm_still_translating = OFF; end; end; %skip(1); tm_string_out_parm = tm_string_varying; %skip(1); return; %skip(1); end translate_mnemonics; %skip(1); end set_function_key; %page; setup_for_next_chunk: proc; %skip(1); dcl sfnc_function_key_procs (HIGHEST_DISPLAY_FUNCTION_NUMBER) entry init ( fkp_forward, fkp_backward, fkp_left, fkp_right, fkp_help, fkp_set_key, fkp_set_scroll_increment, fkp_quit, fkp_redisplay, fkp_start_of_report, fkp_end_of_report, fkp_multics_mode, fkp_goto); dcl sfnc_function_number fixed bin; dcl sfnc_loop fixed bin; dcl sfnc_still_looking_for_a_valid_response bit (1) aligned; dcl sfnc_users_response char (32); %skip(1); /* Get a valid user response for a scroll function. Perform the function. */ %skip(1); sfnc_still_looking_for_a_valid_response = ON; %skip(1); do while (sfnc_still_looking_for_a_valid_response); call get_users_response (sfnc_users_response); %skip(1); do sfnc_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER while (sfnc_still_looking_for_a_valid_response); if sfnc_users_response = keys_as_a_table (sfnc_loop) then do; sfnc_function_number = sfnc_loop; sfnc_still_looking_for_a_valid_response = OFF; end; end; %skip(1); if ^sfnc_still_looking_for_a_valid_response then call sfnc_function_key_procs (sfnc_function_number); if sfnc_still_looking_for_a_valid_response then do; call window_$bell (window_iocb_ptr, code); call check_code; end; %skip(1); end; %skip(1); return; %page; fkp_backward: proc; %skip(1); dcl fb_beginning_line_number fixed bin; %skip(3); /* Make sure we don't try to go backward if we're at the beginning of the report. If we're at the first line of a page then set the page number back one and return to linus_display, and set the line number very large so display_chunk_of_page can determine what the last line of the previous page is once that information is available (when we are called again). If we're not on the first line of a page then decrement the current line number and return. */ %skip(1); if scroll_info.target_line_number = 1 then if scroll_info.target_page_number = 1 then do; sfnc_still_looking_for_a_valid_response = ON; return; end; else if report_control_info.flags.report_is_paginated then do; scroll_info.target_page_number = scroll_info.target_page_number - 1; scroll_info.target_line_number = 99999; still_in_the_scrolling_business = OFF; return; end; else; else if report_control_info.flags.report_is_paginated then do; scroll_info.target_line_number = scroll_info.target_line_number - scroll_info.vertical_scroll_distance; return; end; %skip(1); /* We only make it this far if it's an unpaginated report. If the beginning line number is less than 1 then return to linus_display so it can get us the previous buffer. */ %skip(1); fb_beginning_line_number = scroll_info.target_line_number - scroll_info.vertical_scroll_distance; if fb_beginning_line_number < 1 then if scroll_info.target_page_number = 1 then do; scroll_info.target_line_number = 1; return; end; else do; scroll_info.target_line_number = scroll_info.last_line_number_in_previous_buffer + scroll_info.target_line_number - scroll_info.vertical_scroll_distance; still_in_the_scrolling_business = OFF; scroll_info.target_page_number = scroll_info.target_page_number - 1; return; end; else; %skip(1); /* Return to linus_display to get us the previous buffer if we used two buffers for the previous display. */ %skip(1); scroll_info.target_line_number = fb_beginning_line_number; if scroll_info.flags.buffer_boundary_just_crossed then do; scroll_info.flags.buffer_boundary_just_crossed = OFF; still_in_the_scrolling_business = OFF; end; %skip(1); return; %skip(1); end fkp_backward; %page; fkp_end_of_report: proc; %skip(3); /* If the report is paginated then set the page number very large. If the report is unpaginated then set the goto_line_number_pending flag and set the line number very large. Return to linus_display. */ %skip(1); still_in_the_scrolling_business = OFF; %skip(1); if report_control_info.flags.report_is_paginated then do; scroll_info.target_page_number = LARGEST_PAGE_NUMBER; scroll_info.target_line_number = 1; end; else do; scroll_info.flags.goto_line_number_pending = ON; scroll_info.target_line_number = LARGEST_LINE_NUMBER; end; %skip(1); return; %skip(1); end fkp_end_of_report; %page; fkp_forward: proc; %skip(1); dcl ff_beginning_line_number fixed bin; dcl ff_number_of_left_over_lines fixed bin; %skip(1); /* Handle unpaginated reports first. If we just crossed a buffer boundary and the first line to be displayed is in the first buffer then return to linus_display so it can get it. Otherwise we have just moved to the buffer we currently have. */ %skip(1); if scroll_info.flags.buffer_boundary_just_crossed then do; scroll_info.flags.buffer_boundary_just_crossed = OFF; ff_number_of_left_over_lines = scroll_info.last_line_number_in_previous_buffer - scroll_info.target_line_number + 1; if ff_number_of_left_over_lines > scroll_info.vertical_scroll_distance then do; scroll_info.target_line_number = scroll_info.target_line_number + scroll_info.vertical_scroll_distance; still_in_the_scrolling_business = OFF; return; end; scroll_info.target_line_number = scroll_info.vertical_scroll_distance - ff_number_of_left_over_lines + 1; scroll_info.target_page_number = scroll_info.target_page_number + 1; return; end; %skip(1); /* This code does paginated reports. Advance line number. Make sure we don't move off the end of the report. Return to linus_display if we move off the current page. */ %skip(1); ff_beginning_line_number = scroll_info.target_line_number + scroll_info.vertical_scroll_distance - scroll_info.top_margin_offset; if ff_beginning_line_number > page_info.length then if report_control_info.flags.report_is_formatted & scroll_info.target_page_number = report_control_info.no_of_formatted_pages then sfnc_still_looking_for_a_valid_response = ON; else do; scroll_info.target_page_number = scroll_info.target_page_number + 1; scroll_info.target_line_number = 1; still_in_the_scrolling_business = OFF; end; else scroll_info.target_line_number = ff_beginning_line_number; %skip(1); return; %skip(1); end fkp_forward; %page; fkp_goto: proc; %skip(1); dcl fg_prompt char (11); dcl fg_line_or_page_number fixed bin (35); dcl fg_still_looking_for_a_valid_response bit (1) aligned; %skip(3); /* Prompt for page or line number. Accept only a positive integer. Return to linus_display to get the page or buffer. */ %skip(1); if report_control_info.flags.report_is_paginated then fg_prompt = "Page number"; else fg_prompt = "Line number"; %skip(1); fg_still_looking_for_a_valid_response = ON; do while (fg_still_looking_for_a_valid_response); call prompt_user (fg_prompt, fg_line_or_page_number, users_response, NUMERIC_RESPONSE); if fg_line_or_page_number ^= 0 then do; if report_control_info.flags.report_is_paginated then do; scroll_info.target_page_number = fg_line_or_page_number; scroll_info.target_line_number = 1; end; else do; scroll_info.flags.goto_line_number_pending = ON; scroll_info.target_line_number = fg_line_or_page_number; end; fg_still_looking_for_a_valid_response = OFF; still_in_the_scrolling_business = OFF; end; else do; call window_$bell (window_iocb_ptr, code); call check_code; end; end; %skip(1); return; %skip(1); end fkp_goto; %page; fkp_help: proc; %skip(3); dcl fh_character_read char (1) varying; dcl fh_help_string char (1024); dcl fh_help_string_length fixed bin (21); dcl fh_number_of_chars_read fixed bin (21); dcl fh_still_looking_for_a_valid_response bit (1) aligned; dcl fh_returned_help_list char (512); dcl fh_still_helpful bit (1) aligned; dcl fh_users_response char (256); %skip(1); /* Format and write the general help message. Format and write the mnemonic key sequences and function names list, or, the specific help string for one of the functions. Repeat if user wants more help. */ %skip(1); fh_still_helpful = ON; %skip(1); do while (fh_still_helpful); call format_document_$string (GENERAL_HELP_MESSAGE, fh_help_string, fh_help_string_length, format_document_options_ptr, code); if code ^= 0 then call abort_line (code, ""); fh_still_looking_for_a_valid_response = ON; %skip(1); do while (fh_still_looking_for_a_valid_response); fh_still_looking_for_a_valid_response = OFF; call write_help_string (NO_PROMPT, fh_character_read); call iox_$get_line (window_iocb_ptr, addr (fh_users_response), length (fh_users_response), fh_number_of_chars_read, code); if code ^= 0 then call abort_line (code, ""); if fh_number_of_chars_read ^> 1 then fh_still_looking_for_a_valid_response = ON; else do; fh_number_of_chars_read = fh_number_of_chars_read - 1; if substr (fh_users_response, 1, fh_number_of_chars_read) = GENERAL_HELP_LIST then do; call ioa_$rsnnl (GENERAL_HELP_LIST_MESSAGE, fh_help_string, fh_help_string_length, mnemonic_key_sequences.forward, mnemonic_key_sequences.backward, mnemonic_key_sequences.left, mnemonic_key_sequences.right, mnemonic_key_sequences.help, mnemonic_key_sequences.set_key, mnemonic_key_sequences.set_scroll_increment, mnemonic_key_sequences.quit, mnemonic_key_sequences.redisplay, mnemonic_key_sequences.start_of_report, mnemonic_key_sequences.end_of_report, mnemonic_key_sequences.multics_mode, mnemonic_key_sequences.goto); call write_help_string (PROMPT, fh_character_read); end; else call help_for_function (fh_still_looking_for_a_valid_response); end; if fh_still_looking_for_a_valid_response then do; call window_$bell (window_iocb_ptr, code); call check_code; end; end; %skip(1); if fh_character_read ^= "h" then fh_still_helpful = OFF; %skip(1); end; %skip(1); return; %page; help_for_function: proc ( hff_invalid_function_parm /* output: off if it was a valid function */ ); %skip(1); dcl hff_function_number fixed bin; dcl hff_invalid_function_parm bit (1) aligned parm; dcl hff_loop fixed bin; dcl hff_target_function char (32); %skip(1); /* Find the scroll function by name or mnemonic key sequence. Write the help string for it. */ %skip(1); hff_invalid_function_parm = ON; hff_target_function = substr (fh_users_response, 1, fh_number_of_chars_read); %skip(1); do hff_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER while (hff_invalid_function_parm); if hff_target_function = FUNCTION_NAMES_AS_A_TABLE (hff_loop) | hff_target_function = mnemonic_key_sequences_as_a_table (hff_loop) then do; hff_invalid_function_parm = OFF; hff_function_number = hff_loop; end; end; %skip(1); if hff_invalid_function_parm then return; %skip(1); call ioa_$rsnnl (HELP_HEADER_CONTROL_STRING, fh_returned_help_list, fh_number_of_chars_read, FUNCTION_NAMES_AS_A_TABLE (hff_function_number), mnemonic_key_sequences_as_a_table (hff_function_number), HELP_MESSAGES (hff_function_number)); call format_document_$string (fh_returned_help_list, fh_help_string, fh_help_string_length, format_document_options_ptr, code); if code ^= 0 then call abort_line (code, ""); call write_help_string (PROMPT, fh_character_read); %skip(1); return; %skip(1); end help_for_function; %page; write_help_string: proc ( whs_prompt_parm, /* input: on means prompt to make sure user has seen it */ whs_char_read_parm /* output: the char read if above bit is on */ ); %skip(1); dcl whs_char_read_parm char (1) varying parm; dcl whs_current_position fixed bin; dcl whs_current_line_on_screen fixed bin; dcl whs_new_line_position fixed bin; dcl whs_prompt_parm bit (1) aligned parm; dcl whs_still_filling bit (1) aligned; dcl whs_wants_more bit (1) aligned; %skip(1); /* Fill and write the help string with optional prompt. */ %skip(1); whs_still_filling = ON; whs_current_position = 1; whs_current_line_on_screen = 1; if whs_prompt_parm then do; substr (fh_help_string, fh_help_string_length + 1) = HOW_TO_END_DISPLAY_MESSAGE; fh_help_string_length = fh_help_string_length + length (HOW_TO_END_DISPLAY_MESSAGE) + 1; end; else whs_char_read_parm = ""; call window_$clear_window (window_iocb_ptr, code); call check_code; %skip(1); do while (whs_still_filling); whs_new_line_position = index (substr (fh_help_string, whs_current_position), NEWLINE); if whs_new_line_position = 0 then whs_still_filling = OFF; else do; if whs_current_line_on_screen = report_output_window_position_info.height then do; call prompt_for_more (whs_current_line_on_screen, whs_wants_more); if ^whs_wants_more then do; call fkp_redisplay; return; end; else whs_current_line_on_screen = 1; end; call window_$position_cursor (window_iocb_ptr, whs_current_line_on_screen, 1, code); call check_code; call window_$clear_to_end_of_line (window_iocb_ptr, code); call check_code; call window_$overwrite_text (window_iocb_ptr, substr (fh_help_string, whs_current_position, whs_new_line_position - 1), code); call check_code; whs_current_line_on_screen = whs_current_line_on_screen + 1; whs_current_position = whs_current_position + whs_new_line_position; if whs_current_position > fh_help_string_length then whs_still_filling = OFF; end; end; %skip(1); if whs_prompt_parm then do; call window_$get_one_unechoed_char (window_iocb_ptr, whs_char_read_parm, ON, code); call check_code; end; %skip(1); return; %skip(1); end write_help_string; %skip(1); end fkp_help; %page; fkp_left: proc; %skip(3); /* Make sure we don't go left if we're at character position 1. Move left and adjust if we're too far left. If we've used two buffers in the previous display return to linus_display so it can get us back to the first. */ %skip(1); if scroll_info.left_vertical_position = 1 then do; sfnc_still_looking_for_a_valid_response = ON; return; end; %skip(1); scroll_info.left_vertical_position = max ( scroll_info.left_vertical_position - scroll_info.horizontal_scroll_distance, 1); %skip(1); if scroll_info.flags.buffer_boundary_just_crossed then do; still_in_the_scrolling_business = OFF; scroll_info.flags.buffer_boundary_just_crossed = OFF; end; %skip(1); return; %skip(1); end fkp_left; %page; fkp_multics_mode: proc; %skip(3); /* If window is user_i/o then clear it. Write message telling user how to get back to display. Get to Multics level. Do a redisplay. */ %skip(1); if window_iocb_ptr = iox_$user_io | window_iocb_ptr = iox_$user_output then call window_$clear_window (window_iocb_ptr, code); call check_code; call window_$position_cursor (window_iocb_ptr, 1, 1, code); call check_code; call window_$clear_to_end_of_line (window_iocb_ptr, code); call check_code; call window_$overwrite_text (window_iocb_ptr, HOW_TO_GET_BACK_MESSAGE, code); call check_code; if window_iocb_ptr = iox_$user_io | window_iocb_ptr = iox_$user_output then do; call window_$position_cursor (window_iocb_ptr, 2, 1, code); call check_code; end; %skip(1); unspec (command_level_flags) = OFF; call cu_$cl (command_level_flags); call fkp_redisplay; %skip(1); return; %skip(1); end fkp_multics_mode; %page; fkp_quit: proc; %skip(3); /* Thank you for using this product. Come back y'all. */ %skip(1); code = error_table_$end_of_info; still_in_the_scrolling_business = OFF; %skip(1); return; %skip(1); end fkp_quit; %page; fkp_redisplay: proc; %skip(3); /* This is all it takes to get a redisplay. Pretty simple huh? */ %skip(1); still_in_the_scrolling_business = OFF; %skip(1); return; %skip(1); end fkp_redisplay; %page; fkp_right: proc; %skip(3); /* Make sure we son't go too far right. If we used two buffers during the last display then return to linus_display so it can get us back the first one. */ %skip(1); if scroll_info.left_vertical_position + report_output_window_position_info.width >= page_info.width then do; sfnc_still_looking_for_a_valid_response = ON; return; end; %skip(1); scroll_info.left_vertical_position = scroll_info.left_vertical_position + scroll_info.horizontal_scroll_distance; %skip(1); if scroll_info.flags.buffer_boundary_just_crossed then do; still_in_the_scrolling_business = OFF; scroll_info.flags.buffer_boundary_just_crossed = OFF; end; %skip(1); return; %skip(1); end fkp_right; %page; fkp_set_key: proc; %skip(3); dcl fkp_valid_response bit (1) aligned; dcl fkp_prompt char (21); %skip(1); /* Prompt for function name and mnemonic key sequence. Assign the key sequence to the function. */ %skip(1); fkp_prompt = "Function name"; fkp_valid_response = OFF; %skip(1); do while (^fkp_valid_response); call prompt_user (fkp_prompt, 0, users_response, NON_NUMERIC_RESPONSE); function_name = users_response; fkp_valid_response = valid_function_name (function_name); if ^fkp_valid_response then call window_$bell (window_iocb_ptr, code); call check_code; end; %skip(1); fkp_prompt = "Mnemonic key sequence"; fkp_valid_response = OFF; %skip(1); do while (^fkp_valid_response); call prompt_user (fkp_prompt, 0, users_response, NON_NUMERIC_RESPONSE); call set_function_key (function_name, users_response, code); fkp_valid_response = (code = 0); if ^fkp_valid_response then call window_$bell (window_iocb_ptr, code); call check_code; end; %skip(1); return; %skip(1); end fkp_set_key; %page; fkp_set_scroll_increment: proc; %skip(3); call set_scroll_height_or_width; %skip(1); return; %skip(1); end fkp_set_scroll_increment; %page; fkp_start_of_report: proc; %skip(3); /* Return to linus_display so it can get us page 1 or buffer 1. */ %skip(1); still_in_the_scrolling_business = OFF; scroll_info.target_page_number = 1; scroll_info.target_line_number = 1; %skip(1); return; %skip(1); end fkp_start_of_report; %page; set_scroll_height_or_width: proc; %skip(1); dcl sshow_height bit (1) aligned; dcl sshow_prompt char (42); dcl sshow_scroll_height_or_width fixed bin (35); dcl sshow_still_looking_for_a_valid_response bit (1) aligned; %skip(1); /* Set the scroll increment for height or width. */ %skip(1); sshow_prompt = """h"" for height, anything else for width"; call prompt_user (sshow_prompt, sshow_scroll_height_or_width, users_response, NON_NUMERIC_RESPONSE); sshow_height = (users_response = "h"); if sshow_height then sshow_prompt = "New scroll height"; else sshow_prompt = "New scroll width"; %skip(1); sshow_still_looking_for_a_valid_response = ON; %skip(1); do while (sshow_still_looking_for_a_valid_response); sshow_still_looking_for_a_valid_response = OFF; call prompt_user (sshow_prompt, sshow_scroll_height_or_width, users_response, NUMERIC_RESPONSE); if sshow_height then if sshow_scroll_height_or_width > page_info.length | sshow_scroll_height_or_width < TOP_MARGIN_HEIGHT then sshow_still_looking_for_a_valid_response = ON; else; else if sshow_scroll_height_or_width > page_info.width then sshow_still_looking_for_a_valid_response = ON; else; if ^sshow_still_looking_for_a_valid_response then if sshow_height then scroll_info.vertical_scroll_distance = sshow_scroll_height_or_width; else scroll_info.horizontal_scroll_distance = sshow_scroll_height_or_width; else; if ^sshow_still_looking_for_a_valid_response then call fkp_redisplay; else do; call window_$bell (window_iocb_ptr, code); call check_code; end; end; %skip(1); return; %skip(1); end set_scroll_height_or_width; %skip(1); end setup_for_next_chunk; %page; setup_scroll: proc; %skip(3); /* Set the pointers we will need. */ %skip(1); scroll_ip = display_results.scroll_info_ptr; scroll_info.display_arg_results_ptr = display_results_ptr; scroll_info.report_control_info_ptr = report_cip; scroll_info.area_ptr = work_area_ptr; scroll_info.ssu_info_ptr = sci_ptr; %skip(1); /* Allocate the structures for the user_i/o and report windows, and the window_status_info. */ %skip(1); allocate user_io_window_position_info in (work_area) set (user_io_window_position_ip); scroll_info.user_io_window_position_info_ptr = user_io_window_position_ip; unspec (user_io_window_position_info) = OFF; user_io_window_position_info.version = window_position_info_version_1; %skip(1); allocate report_output_window_position_info in (work_area) set (report_output_window_position_ip); scroll_info.report_output_window_position_info_ptr = report_output_window_position_ip; report_output_window_position_info = user_io_window_position_info; %skip(1); allocate window_status_info in (work_area) set (window_status_info_ptr); window_status_info.version = window_status_version_1; scroll_info.window_status_info_pointer = window_status_info_ptr; %skip(1); /* Turn on the video system if it's not already on. */ %skip(1); if video_data_$terminal_iocb = null () then do; scroll_info.flags.video_was_already_on = OFF; call video_utils_$turn_on_login_channel (code, reason); if code ^= 0 then call abort_line (code, reason); end; else scroll_info.flags.video_was_already_on = ON; %page; /* If -window was specified by the user make sure it meets the requirements. If it wasn't setup a shriek named window and shrink user_i/o. */ %skip(1); if display_results.window_flag then do; call iox_$look_iocb (display_results.window_name, window_iocb_ptr, code); if code ^= 0 then call abort_line (code, "The window " || rtrim (display_results.window_name) || " doesn't exist."); if window_iocb_ptr -> iocb.attach_descrip_ptr ^= null () then if window_iocb_ptr -> iocb.open_descrip_ptr = null () then call abort_line (0, "The output switch " || rtrim (display_results.window_name) || " is attached but not open."); else; else call abort_line (0, "The output switch " || rtrim (display_results.window_name) || " is not attached."); scroll_info.flags.user_io_was_shrunk = OFF; call iox_$control (window_iocb_ptr, "get_window_info", report_output_window_position_ip, code); if code ^= 0 then call abort_line (code, "Unable to get the window information."); if report_output_window_position_info.height < MINIMUM_WINDOW_SIZE then call abort_line (0, MINIMUM_WINDOW_SIZE_ERROR_MESSAGE); end; else do; scroll_info.flags.user_io_was_shrunk = ON; call iox_$control (iox_$user_io, "get_window_info", user_io_window_position_ip, code); if code ^= 0 then call abort_line (code, "Unable to get the window information."); if user_io_window_position_info.height < MINIMUM_LINES_NEEDED then call abort_line (video_et_$insuff_room_for_window, MINIMUM_LINES_NEEDED_ERROR_MESSAGE); call window_$clear_window (iox_$user_io, code); if code ^= 0 then call abort_line (code, "Unable to clear the user_i/o window."); report_output_window_position_info = user_io_window_position_info; user_io_window_position_info.line = user_io_window_position_info.line + user_io_window_position_info.height - USER_IO_WINDOW_HEIGHT; user_io_window_position_info.height = USER_IO_WINDOW_HEIGHT; call iox_$control (iox_$user_io, "set_window_info", user_io_window_position_ip, code); if code ^= 0 then call abort_line (code, "Unable to set the window info for user_i/o."); switch_name = unique_chars_ ("0"b) || ".linus_display"; call iox_$find_iocb (switch_name, window_iocb_ptr, code); if code ^= 0 then call abort_line (code, "Unable to find the io control block for " || rtrim (switch_name) || "."); report_output_window_position_info.height = report_output_window_position_info.height - USER_IO_WINDOW_HEIGHT; call window_$create (video_data_$terminal_iocb, report_output_window_position_ip, window_iocb_ptr, code); if code ^= 0 then call abort_line (code, "Unable to create the window for the report."); end; %skip(1); /* Fill in the scroll_info and format_document_options structures. */ %skip(1); report_control_info.display_iocb_ptr = window_iocb_ptr; %skip(1); scroll_info.number_of_lines_for_report_display = report_output_window_position_info.height; scroll_info.vertical_scroll_distance = report_output_window_position_info.height - 1; scroll_info.horizontal_scroll_distance = report_output_window_position_info.width - 10; scroll_info.target_page_number = 1; scroll_info.target_line_number = 1; scroll_info.left_vertical_position = 1; %skip(1); allocate format_document_options in (work_area) set (format_document_options_ptr); unspec (format_document_options) = OFF; format_document_options.version_number = format_document_version_2; format_document_options.switches.galley_sw = ON; format_document_options.switches.break_word_sw = ON; format_document_options.switches.max_line_length_sw = ON; format_document_options.switches.sub_err_sw = ON; format_document_options.switches.literal_sw = ON; format_document_options.switches.dont_compress_sw = ON; format_document_options.line_length = report_output_window_position_info.width; format_document_options.switches.adj_sw = OFF; scroll_info.format_document_op = format_document_options_ptr; %skip(1); return; %skip(1); end setup_scroll; %page; terminate_scroll: proc; %skip(3); /* Clear the window. Destroy the window and restore user_i/o back to it's original size if -window wasn't given by the user. Turn off the video system if we turned it on. */ %skip(1); call window_$clear_window (window_iocb_ptr, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code); %skip(1); if ^display_results.window_flag then do; call window_$destroy (window_iocb_ptr, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code); user_io_window_position_info.line = report_output_window_position_info.line; user_io_window_position_info.height = report_output_window_position_info.height + user_io_window_position_info.height; call iox_$control (iox_$user_io, "set_window_info", user_io_window_position_info_ptr, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code); call iox_$destroy_iocb (window_iocb_ptr, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code); end; %skip(1); if ^scroll_info.flags.video_was_already_on then do; call video_utils_$turn_off_login_channel (code); if code ^= 0 then call ssu_$print_message (sci_ptr, code); end; %skip(1); return; %skip(1); end terminate_scroll; %page; valid_function_name: proc ( vfn_function_name_parm) /* input: function name */ returns (bit (1) aligned); %skip(3); dcl vfn_function_name_parm char (*) parm; %skip(1); /* Return true if it's a valid function name. */ %skip(3); return ((vfn_function_name_parm = FUNCTION_NAMES.FORWARD) | (vfn_function_name_parm = FUNCTION_NAMES.BACKWARD) | (vfn_function_name_parm = FUNCTION_NAMES.LEFT) | (vfn_function_name_parm = FUNCTION_NAMES.RIGHT) | (vfn_function_name_parm = FUNCTION_NAMES.HELP) | (vfn_function_name_parm = FUNCTION_NAMES.SET_KEY) | (vfn_function_name_parm = FUNCTION_NAMES.SET_SCROLL_INCREMENT) | (vfn_function_name_parm = FUNCTION_NAMES.QUIT) | (vfn_function_name_parm = FUNCTION_NAMES.REDISPLAY) | (vfn_function_name_parm = FUNCTION_NAMES.START_OF_REPORT) | (vfn_function_name_parm = FUNCTION_NAMES.END_OF_REPORT) | (vfn_function_name_parm = FUNCTION_NAMES.MULTICS_MODE) | (vfn_function_name_parm = FUNCTION_NAMES.GOTO)); %skip(1); end valid_function_name; %page; dcl BLANK char (1) static internal options (constant) init (" "); %skip(1); dcl CARRIAGE_RETURN char (1) static internal options (constant) init (" "); dcl CONTROL_HYPHEN char (8) static internal options (constant) init ("control-"); dcl CTL_HYPHEN char (4) static internal options (constant) init ("ctl-"); %skip(1); dcl DEL char (1) static internal options (constant) init (""); dcl DIGITS char (10) static int options (constant) init ("0123456789"); %skip(1); dcl ESCAPE char (1) static internal options (constant) init (""); dcl ESC_HYPHEN char (4) static internal options (constant) init ("esc-"); dcl ESCAPE_HYPHEN char (7) static internal options (constant) init ("escape-"); %skip(1); dcl GENERAL_HELP_MESSAGE char (128) static internal options (constant) init ( "Type the function name or mnemonic key sequence, or type ?? for a list of function names and key sequences. (end with RETURN) ->"); dcl GENERAL_HELP_LIST char (2) static internal options (constant) init ("??"); dcl GENERAL_HELP_LIST_MESSAGE char (203) static internal options (constant) init ( "forward (^a)^/backward (^a)^/left (^a)^/right (^a)^/help (^a)^/set_key (^a)^/set_scroll_increment (^a)^/quit (^a)^/redisplay (^a)^/start_of_report (^a)^/end_of_report (^a)^/multics_mode (^a)^/goto (^a)^/"); %skip(1); dcl HOME char (4) static internal options (constant) init ("home"); dcl HELP_HEADER_CONTROL_STRING char (15) internal static options (constant) init ("^a^x(^a)^2/^a^/"); dcl HELP_MESSAGES (13) char (254) internal static options (constant) init ( "The forward function moves the window forward into the report. The scroll height controls how many lines forward the window moves. The set_scroll_increment function can be used to change the scroll height.", "The backward function moves the window backward into the report. The scroll height controls how many lines backward the window moves. The set_scroll_increment function can be used to change the scroll height.", "The left function moves the window left in the report. The scroll width controls how many characters left the window moves. The set_scroll_increment function can be used to change the scroll width.", "The right function moves the window right in the report. The scroll width controls how many characters right the window moves. The set_scroll_increment function can be used to change the scroll width.", "The help function provides general information on the display function names and key sequences used to invoke the functions, or, more detailed help on any specific display function.", "The set_key function provides a way to associate key sequences with display functions. The function name and mnemonic key sequences are prompted for.", "The set_scroll_increment function provides a way to change the scroll height and width. Height is the number of lines forward or backward that the window will move; width is the number of characters left or right that the window will move.", "The quit function terminates the current invocation of the display request.", "The redisplay function redisplays the contents of the window. This is useful after the window contents have become invalid due to line noise, interactive messages, etc.", "The start_of_report function provides a way to get back to the start of the report from any arbitrary place in the report.", "The end_of_report function provides a way to get to the end of the report from any arbitrary place in the report.", "The multics_mode function provides a way to suspend the current invocation of display and use other Multics facilities. Typing ""start"" resumes the suspended invocation of display.", "The goto function provides a means to go directly to any page within a paginated report, or, directly to any line number within an unpaginated report." ); dcl HOW_TO_END_DISPLAY_MESSAGE char (62) static internal options (constant) init ("Type any single character for redisplay or h for more help -> "); dcl HOW_TO_GET_BACK_MESSAGE char (38) static internal options (constant) init ( "Type ""start"" to get back to display."); %skip(1); dcl LARGEST_LINE_NUMBER fixed bin (35) static internal options (constant) init (34359738365); dcl LARGEST_PAGE_NUMBER fixed bin (21) static internal options (constant) init (2097151); %skip(1); dcl MINIMUM_LINES_NEEDED fixed bin static internal options (constant) init (9); dcl MINIMUM_LINES_NEEDED_ERROR_MESSAGE char (45) static internal options (constant) init ("The user_i/o window must be at least 9 lines."); dcl MINIMUM_WINDOW_SIZE fixed bin static internal options (constant) init (5); dcl MINIMUM_WINDOW_SIZE_ERROR_MESSAGE char (45) static internal options (constant) init ( "The provided window must be at least 5 lines."); dcl MORE_PROMPT char (47) static internal options (constant) init ( "More? (RETURN for more; DEL to discard output.)"); %skip(1); dcl NEWLINE char (1) static internal options (constant) init (" "); dcl NO_PROMPT bit (1) aligned internal static options (constant) init ("0"b); dcl NON_NUMERIC_RESPONSE bit (1) aligned static int options (constant) init ("0"b); dcl NUMERIC_RESPONSE bit (1) aligned static int options (constant) init ("1"b); %skip(1); dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %skip(1); dcl PROMPT bit (1) aligned internal static options (constant) init ("1"b); %skip(1); dcl TRANSLATION_TABLE char (63) internal static options (constant) init ( "@ABCDEFGHIJKLMNOPQRSTUVWXYZ1\]^_`abcdefghijklmnopqrstuvwxyz{|}~"); dcl TOP_MARGIN_HEIGHT fixed bin static int options (constant) init (4); %skip(1); dcl USER_IO_WINDOW_HEIGHT fixed bin static int options (constant) init (4); %page; dcl addr builtin; %skip(1); dcl byte builtin; %skip(1); dcl code fixed bin (35); dcl 1 command_level_flags aligned, 2 reset_sw bit (1) unaligned, 2 mbx bit (35) unaligned; dcl convert builtin; dcl convert_status_code_ entry (fixed bin(35), char(8) aligned, char(100) aligned); dcl cu_$cl entry (1 aligned, 2 bit(1) unal, 2 bit(35) unal); %skip(1); dcl 1 display_results like display_arg_results based (display_results_ptr); dcl display_results_ptr ptr; %skip(1); dcl error_message char (256) varying; dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$long_record fixed bin(35) ext static; %skip(1); dcl format_document_$string entry (char(*), char(*), fixed bin(21), ptr, fixed bin(35)); dcl function_name char (32); dcl function_key_sequence char (32); %skip(1); dcl hbound builtin; %skip(1); dcl index builtin; dcl ioa_$rsnnl entry() options(variable); %skip(1); dcl length builtin; dcl linus_error_$bad_fkey_name fixed bin(35) ext static; dcl linus_error_$bad_fkey_sequence fixed bin(35) ext static; dcl linus_error_$bad_report_display fixed bin(35) ext static; dcl long_message char (100) aligned; dcl ltrim builtin; %skip(1); dcl max builtin; dcl min builtin; %skip(1); dcl null builtin; %skip(1); dcl reason char (64); dcl 1 report_output_window_position_info like window_position_info based (report_output_window_position_ip); dcl report_output_window_position_ip ptr; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl short_message char (8) aligned; dcl ssu_$abort_line entry() options(variable); dcl ssu_$print_message entry() options(variable); dcl still_in_the_scrolling_business bit (1) aligned; dcl substr builtin; dcl switch_name char (42); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl unique_chars_ entry (bit(*)) returns(char(15)); dcl unspec builtin; dcl 1 user_io_window_position_info like window_position_info based (user_io_window_position_ip); dcl user_io_window_position_ip ptr; dcl users_response char (32); %skip(1); dcl verify builtin; dcl video_data_$terminal_iocb ptr static external; dcl video_et_$insuff_room_for_window fixed bin(35) ext static; dcl video_et_$window_status_pending fixed bin(35) ext static; dcl video_utils_$turn_on_login_channel entry (fixed bin(35), char(*)); dcl video_utils_$turn_off_login_channel entry (fixed bin(35)); %skip(1); dcl window_iocb_ptr ptr; dcl work_area area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; %page; %include format_document_options; %page; %include function_key_data; %page; %include iocb; %page; %include iox_dcls; %page; %include linus_display_arg_list; %page; %include linus_options_extents; %page; %include linus_page_info; %page; %include linus_report_info; %page; %include linus_scroll_info; %page; %include window_control_info; %page; %include window_dcls; %skip(1); end linus_display_scroll;  linus_fr_build_page.pl1 07/29/86 1051.7r w 07/29/86 0939.5 1037169 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(1); /* This module is the linus page building subroutine called by linus_display. Description and usage follows. Description: This module is called to build a single page and return to its caller. In the case of unpaginated reports it builds a buffer (a portion of the single page an unpaginated report is made up of). In the case of multiple pass reports this module formats the report the number of passes minus one, then formats the first page or buffer of the last pass and returns to its caller. Usage: See the parameter list for usage. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 Modified: Al Dupuis - October 26, 1983. Added lines in internal procedure check_for_outlining to make sure that the column being outlined isn't excluded from the page. */ %page; /* Formatted Page Mainline Processing Overview ________________________________ | PAGE HEADER | 1. Format the page header. |______________________________| | TITLE BLOCK | 2. Format the title block. |______________________________| | DETAIL BLOCK | 3. Format N detail blocks (see below). |______________________________| | PAGE FOOTER | 4. Format the page footer. |______________________________| Detail Block Detail Block Processing Overview -------------------------------- | GROUP HEADER | 1. Format the group header. |______________________________| | ROW HEADER | 2. Format the row header. |______________________________| | ROW VALUE | 3. Format the row value. |______________________________| | SUBTOTAL BLOCK | 4. Format the subtotal block. |______________________________| | SUBCOUNT BLOCK | 5. Format the subcount block. |______________________________| | TOTAL BLOCK | 6. Format the total block. |______________________________| | COUNT BLOCK | 7. Format the count block. |______________________________| | ROW FOOTER | 8. Format the row footer. |______________________________| | GROUP FOOTER | 9. Format the group footer. |______________________________| The above mainline is done once per page for every page of the report. A return is done to the caller after every page is built. If the multi-pass feature is being used, no output is produced until the last pass. This means that the entire report is done "n" times without returning to the caller, where "n" is one less than the requested number of passes. On the final pass it returns to the caller after each page is built. */ %page; linus_fr_build_page: proc ( lcb_ptr_parm, /* input: ptr to the linus control block */ page_info_ptr_parm, /* output: description of the page */ code_parm /* output: success or failure */ ); %skip(1); dcl code_parm fixed bin (35) parm; dcl lcb_ptr_parm ptr parm; dcl page_info_ptr_parm ptr parm; %skip(3); lcb_ptr = lcb_ptr_parm; call housekeeping; call setup_for_a_page; call make_rows_available; on sub_error_ call sub_error_handler; %skip(1); if ^report_control_info.flags.multi_pass_mode then do; call build_page; return; end; %skip(1); status.flags.last_pass = OFF; do status.current_pass_number = 1 to report_control_info.number_of_passes - 1; do while (^report_control_info.flags.report_has_just_been_completed); call build_page; if ^report_control_info.flags.report_has_just_been_completed then call setup_for_a_page; end; call adjust_multi_pass_execution_control_info; call setup_for_a_page; end; %skip(1); report_control_info.flags.multi_pass_mode = OFF; status.flags.last_pass = ON; call build_page; %skip(1); return; %page; adjust_multi_pass_execution_control_info: proc; %skip(3); /* Just completed one pass of the report, set up for the next pass. */ %skip(1); status.current_row_ptr = null (); status.previous_row_ptr = null (); status.next_row_ptr = make_ptr (1); %skip(1); status.last_page_number = status.current_page_number; status.last_row_number = report_control_info.no_of_rows_retrieved; status.highest_row_formatted = 0; %skip(1); if format_report_info.flags.subtotal_is_defined then do; subtotal_info.columns.subtotal (*) = 0; subtotal_generation_info.current_generation_block = -1; end; if format_report_info.flags.total_is_defined then total_info.columns.total (*) = 0; %skip(1); if format_report_info.flags.subcount_is_defined then do; subcount_info.columns.subtotal (*) = 0; subcount_generation_info.current_generation_block = -1; end; if format_report_info.flags.count_is_defined then count_info.columns.total (*) = 0; %skip(1); report_control_info.flags.report_is_formatted = OFF; report_control_info.flags.report_has_just_been_completed = OFF; report_control_info.no_of_formatted_pages = 0; %skip(1); format_report_info.number_of_formatted_rows = 0; %skip(1); return; %skip(1); end adjust_multi_pass_execution_control_info; %page; backout_detail_block: proc ( bdb_object_doing_the_back_out_parm /* input: the caller */ ); %skip(1); dcl bdb_object_doing_the_back_out_parm char (*) varying parm; %skip(1); /* Remove one detail block from the page, make sure it isn't the first. */ %skip(1); if status.total_number_of_rows_used ^> 0 then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_format, "^/There isn't enough room to place the ^a on page number ^d." || "^/The current row number is ^d.", bdb_object_doing_the_back_out_parm, status.current_page_number, status.current_row_number); %skip(1); status.flags.page_overflow = ON; status.flags.last_row_of_report = OFF; status.current_line_on_page = formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).beginning_line_number; status.remaining_lines_on_page = template_map_number_of_bits - status.current_line_on_page + 1; status.flags.still_formatting_detail_blocks = OFF; if page_info.page_overstrike_info_ptr ^= null () then substr (page_overstrike_info_redefined.bit_map, ((status.current_line_on_page - 1) * page_info.width) + 1) = OFF; %skip(1); status.next_row_ptr = status.current_row_ptr; status.current_row_ptr = status.previous_row_ptr; if status.current_row_number < 3 then status.previous_row_ptr = null (); else status.previous_row_ptr = make_ptr (status.current_row_number - 2); %skip(1); if format_report_info.flags.subtotal_is_defined then call backout_subtotal_block; status.flags.totals_ejection_in_progress = OFF; status.flags.subtotals_ejection_in_progress = OFF; %skip(1); if format_report_info.flags.subcount_is_defined then call backout_subcount_block; status.flags.counts_ejection_in_progress = OFF; status.flags.subcounts_ejection_in_progress = OFF; %skip(1); substr (template_map_defined_as_a_string, status.current_line_on_page) = OFF; formatted_page_info.number_of_detail_blocks = formatted_page_info.number_of_detail_blocks - 1; %skip(1); return; %skip(1); end backout_detail_block; %page; backout_subcount_block: proc; %skip(1); dcl bsb_loop fixed bin; %skip(1); /* Back out the subtotal block if we've generated it or are in the process of generating it. */ %skip(1); if formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).subcount_length ^= 0 | status.flags.subcounts_ejection_in_progress then do; subcount_generation_info.current_generation_block = mod (subcount_generation_info.current_generation_block, subcount_generation_info.maximum_number_of_generation_blocks); do bsb_loop = 1 to subcount_generation_info.number_of_subtotals; subcount_info.columns (bsb_loop).subtotal = subcount_generation_info.generations (subcount_generation_info.current_generation_block).subtotals (bsb_loop); end; end; %skip(1); do bsb_loop = 1 to subcount_info.number_of_columns_to_subtotal; subcount_info.columns (bsb_loop).subtotal = subcount_info.columns (bsb_loop).subtotal - 1; end; %skip(1); return; %skip(1); end backout_subcount_block; %page; backout_subtotal_block: proc; %skip(1); dcl bsb_loop fixed bin; %skip(1); /* Back out the subcount block if we've generated it or are in the process of generating it. */ %skip(1); if formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).subtotal_length ^= 0 | status.flags.subtotals_ejection_in_progress then do; subtotal_generation_info.current_generation_block = mod (subtotal_generation_info.current_generation_block, subtotal_generation_info.maximum_number_of_generation_blocks); do bsb_loop = 1 to subtotal_generation_info.number_of_subtotals; subtotal_info.columns (bsb_loop).subtotal = subtotal_generation_info.generations (subtotal_generation_info.current_generation_block).subtotals (bsb_loop); end; end; %skip(1); do bsb_loop = 1 to subtotal_info.number_of_columns_to_subtotal; subtotal_info.columns (bsb_loop).subtotal = subtotal_info.columns (bsb_loop).subtotal - float (substr (next_row_value, table_info.columns.column_index (subtotal_info.columns (bsb_loop).input_column), table_info.columns.column_length (subtotal_info.columns (bsb_loop).input_column))); end; %skip(1); return; %skip(1); end backout_subtotal_block; %page; build_page: proc; %skip(1); /* Make the pointers to the rows. Do the page header, the title block, as many detail blocks as will fit, and the page footer. Use the alogorithm as described back in the picture at the beginning of this module. Close the page. Optionally save a copy of it. */ %skip(1); call make_row_ptrs; if format_report_info.flags.page_header_is_defined then call format_page_header; if format_report_info.flags.title_block_is_defined then call format_title_block; first_time_through_the_detail_block_loop = ON; status.still_formatting_detail_blocks = ON; %skip(1); do while (status.still_formatting_detail_blocks); if ^first_time_through_the_detail_block_loop then call make_row_ptrs; call format_detail_block; first_time_through_the_detail_block_loop = OFF; call make_rows_available; end; %skip(1); if format_report_info.flags.page_footer_is_defined then call format_page_footer; call close_page; if report_control_info.flags.permanent_report & ^report_control_info.flags.multi_pass_mode then call save_copy_of_page; %skip(1); page_info_ptr_parm = page_ip; code_parm = code; %skip(1); return; %skip(1); end build_page; %page; check_for_group_break: proc ( cfgb_group_info_ptr_parm, /* input: ptr to group_info structure */ cfgb_look_ahead_flag_parm, /* input: on if current should be compared to next */ cfgb_column_changed_flag_parm /* output: on if a column changed */ ); %skip(1); dcl cfgb_column_changed_flag_parm bit (1) aligned parm; dcl cfgb_column_number fixed bin; dcl 1 cfgb_group_info like group_info based (cfgb_group_info_ptr_parm); dcl cfgb_group_info_ptr_parm ptr parm; dcl cfgb_look_ahead_flag_parm bit (1) aligned parm; dcl cfgb_loop fixed bin; %skip(1); /* Check the value of the named columns against the previous or next row and set the parm accordingly. */ %skip(1); cfgb_column_changed_flag_parm = ON; if (status.flags.last_row_of_report & cfgb_look_ahead_flag_parm) | (status.flags.first_row_of_report & ^cfgb_look_ahead_flag_parm) then return; %skip(1); do cfgb_loop = 1 to cfgb_group_info.number_of_columns_to_group; cfgb_column_number = cfgb_group_info.column_number (cfgb_loop); if cfgb_look_ahead_flag_parm then if substr (current_row_value, table_info.columns.column_index (cfgb_column_number), table_info.columns.column_length (cfgb_column_number)) ^= substr (next_row_value, table_info.columns.column_index (cfgb_column_number), table_info.columns.column_length (cfgb_column_number)) then return; else; else if substr (current_row_value, table_info.columns.column_index (cfgb_column_number), table_info.columns.column_length (cfgb_column_number)) ^= substr (previous_row_value, table_info.columns.column_index (cfgb_column_number), table_info.columns.column_length (cfgb_column_number)) then return; else; end; %skip(1); cfgb_column_changed_flag_parm = OFF; %skip(1); return; %skip(1); end check_for_group_break; %page; check_for_outlining: proc; %skip(1); dcl cfo_inner_loop fixed bin; dcl cfo_loop fixed bin; dcl cfo_most_major_column_changed bit (1) aligned; dcl cfo_still_within_the_group bit (1) aligned; %skip(3); /* Never do outlining on the first row of the report or the first row on a page. Do the single columns first (columns who are not a member of the "group" of rows). Grab the column number and use it as an index into the input_columns_info array, which gives us the number of the output column. */ %skip(1); if status.flags.first_row_of_report | status.flags.first_row_on_page then do; output_columns_info.columns (*).flags.outline = OFF; return; end; %skip(1); if outline_info.number_of_single_columns ^= 0 then do cfo_loop = 1 to outline_info.number_of_single_columns; if input_columns_info.columns.output_column (outline_info.single_columns (cfo_loop)) ^= 0 then do; column_ip = addr (output_columns_info.columns (input_columns_info.columns.output_column ( outline_info.single_columns (cfo_loop)))); if substr (current_row_value, table_info.columns.column_index (outline_info.single_columns (cfo_loop)), table_info.columns.column_length (outline_info.single_columns (cfo_loop))) = substr (previous_row_value, table_info.columns.column_index (outline_info.single_columns (cfo_loop)), table_info.columns.column_length (outline_info.single_columns (cfo_loop))) then column_info.flags.outline = ON; else column_info.flags.outline = OFF; end; end; %page; /* Do the grouping columns next. A change in any member of the group who is more major than our target column causes a change in all columns down to our target column. Repeat the following sequence for each of our target columns. Use the group column number as an index into the input_columns_info array, which gives us the number of the output column. If it has changed, or a more major member has changed, then it isn't outlined. */ %skip(1); if outline_info.number_of_grouping_columns ^= 0 then do cfo_loop = 1 to outline_info.number_of_grouping_columns; %skip(1); cfo_most_major_column_changed = OFF; cfo_still_within_the_group = ON; %skip(1); do cfo_inner_loop = 1 to group_info.number_of_columns_to_group while (cfo_still_within_the_group); %skip(1); if input_columns_info.columns.output_column (group_info.column_number (cfo_inner_loop)) ^= 0 then do; column_ip = addr (output_columns_info.columns (input_columns_info.columns.output_column ( group_info.column_number (cfo_inner_loop)))); if cfo_most_major_column_changed then column_info.flags.outline = OFF; else do; if substr (current_row_value, table_info.columns.column_index (group_info.column_number (cfo_inner_loop)), table_info.columns.column_length (group_info.column_number (cfo_inner_loop))) = substr (previous_row_value, table_info.columns.column_index (group_info.column_number (cfo_inner_loop)), table_info.columns.column_length (group_info.column_number (cfo_inner_loop))) then column_info.flags.outline = ON; else do; cfo_most_major_column_changed = ON; column_info.flags.outline = OFF; end; end; end; %skip(1); if group_info.column_number (cfo_inner_loop) = outline_info.grouping_columns (cfo_loop) then cfo_still_within_the_group = OFF; %skip(1); end; %skip(1); end; %skip(1); return; %skip(1); end check_for_outlining; %page; check_for_page_break: proc; %skip(1); dcl cfpb_loop fixed bin; %skip(3); /* If we're on the last row then don't check for a page break. If the value of any column being watched is about to change with the next row then generate a page break. */ %skip(1); if ^status.flags.still_formatting_detail_blocks then return; %skip(1); status.still_formatting_detail_blocks = OFF; %skip(1); do cfpb_loop = 1 to input_columns_info.number_of_columns; if page_break_info.columns (cfpb_loop) then do; if substr (current_row_value, table_info.columns.column_index (cfpb_loop), table_info.columns.column_length (cfpb_loop)) ^= substr (next_row_value, table_info.columns.column_index (cfpb_loop), table_info.columns.column_length (cfpb_loop)) then return; end; end; %skip(1); status.still_formatting_detail_blocks = ON; %skip(1); return; %skip(1); end check_for_page_break; %page; check_for_subtotal_break: proc ( cfsb_subtotal_info_ptr_parm, /* input: ptr to subtotal_info structure */ cfsb_subtotal_columns_info_ptr_parm, /* input: ptr to subtotal_columns_info structure */ cfsb_level_number_parm, /* input: which level of subtotals we're on */ cfsb_column_changed_flag_parm /* output: on means it's time for a subtotal break */ ); %skip(1); dcl cfsb_column_changed_flag_parm bit (1) aligned parm; dcl cfsb_column_number fixed bin; dcl cfsb_inner_loop fixed bin; dcl cfsb_level_number fixed bin; dcl cfsb_level_number_parm fixed bin parm; dcl cfsb_loop fixed bin; dcl cfsb_most_major_column_changed bit (1) aligned; dcl cfsb_still_within_the_group bit (1) aligned; dcl 1 cfsb_subtotal_columns_info like subtotal_columns_info based (cfsb_subtotal_columns_info_ptr_parm); dcl cfsb_subtotal_columns_info_ptr_parm ptr parm; dcl 1 cfsb_subtotal_info like subtotal_info based (cfsb_subtotal_info_ptr_parm); dcl cfsb_subtotal_info_ptr_parm ptr parm; %skip(3); /* This subroutine walks through one level of subtotals looking at the watch column to see if it has changed. A change means it is time to generate the subtotal. If the watch column is a member of the "group" list of columns, then it and any more major in the group are also watched. A change in any member of the group causes all members lower to change also (down to the watch column). Start off by outlining every column. Walk through all of the subtotal columns processing only those that are at the current level. Grab the number of the watch column. Use the subtotal_info array to index into the input_columns_info array, which gives us the number of the subtotal_columns_info output column. If it is the last row of the report, or the watch column has changed, or the watch column is a group member and a more major column has changed, then generate a subtotal break. The column that changed can be excluded from the page; if it isn't then set the outline bit off for it (and possibly more minor columns). Set the outline bit off for the subtotal output column if we got a hit, and if the parent column has an editing request associated with it then set the pointer and length to the result of the editing request. */ %skip(1); cfsb_column_changed_flag_parm = OFF; cfsb_level_number = cfsb_level_number_parm; cfsb_subtotal_columns_info.columns (*).flags.outline = ON; %page; do cfsb_loop = 1 to cfsb_subtotal_info.number_of_columns_to_subtotal; if cfsb_subtotal_info.columns (cfsb_loop).level = cfsb_level_number then do; cfsb_column_number = cfsb_subtotal_info.columns (cfsb_loop).watch_column; column_ip = addr (cfsb_subtotal_columns_info.columns (input_columns_info.columns ( cfsb_subtotal_info.columns (cfsb_loop).input_column).output_column)); if ^cfsb_subtotal_info.columns (cfsb_loop).flags.group_column then do; if status.flags.last_row_of_report then call subtotal_break (input_columns_info.columns (cfsb_column_number).output_column); else if substr (current_row_value, table_info.columns.column_index (cfsb_column_number), table_info.columns.column_length (cfsb_column_number)) ^= substr (next_row_value, table_info.columns.column_index (cfsb_column_number), table_info.columns.column_length (cfsb_column_number)) then call subtotal_break (input_columns_info.columns (cfsb_column_number).output_column); else; end; else do; if status.flags.last_row_of_report then cfsb_most_major_column_changed = ON; else cfsb_most_major_column_changed = OFF; cfsb_still_within_the_group = ON; do cfsb_inner_loop = 1 to group_info.number_of_columns_to_group while (cfsb_still_within_the_group); if cfsb_most_major_column_changed then call subtotal_break (input_columns_info.columns ( group_info.column_number (cfsb_inner_loop)).output_column); else if substr (current_row_value, table_info.columns.column_index (group_info.column_number (cfsb_inner_loop)), table_info.columns.column_length (group_info.column_number (cfsb_inner_loop))) ^= substr (next_row_value, table_info.columns.column_index (group_info.column_number (cfsb_inner_loop)), table_info.columns.column_length (group_info.column_number (cfsb_inner_loop))) then call subtotal_break (input_columns_info.columns (group_info.column_number (cfsb_inner_loop)).output_column); else; if group_info.column_number (cfsb_inner_loop) = cfsb_column_number then cfsb_still_within_the_group = OFF; end; end; end; end; %skip(1); return; %page; subtotal_break: proc ( sb_output_column_number_parm /* input: number of column that changed */ ); %skip(1); dcl sb_output_column_number_parm fixed bin parm; %skip(3); /* This subroutine is called when a watch column has changed and it is time to generate a subtotal break. Set the parm to indicate a column has changed. Set the subtotal/subcount output column's editing flag off. If the column that changed isn't being excluded from the page, then set it's editing bit off and if it has an editing request associated with it, set the pointer and length so that the edited result is displayed in that column. */ %skip(1); cfsb_column_changed_flag_parm = ON; column_info.flags.outline = OFF; if sb_output_column_number_parm = 0 then return; %skip(1); cfsb_subtotal_columns_info.columns (sb_output_column_number_parm).flags.outline = OFF; if cfsb_subtotal_columns_info.columns (sb_output_column_number_parm).flags.editing then do; cfsb_subtotal_columns_info.columns (sb_output_column_number_parm).editing_string_result_ptr = output_columns_info.columns (sb_output_column_number_parm).editing_string_result_ptr; cfsb_subtotal_columns_info.columns (sb_output_column_number_parm).editing_string_result_length = output_columns_info.columns (sb_output_column_number_parm).editing_string_result_length; end; %skip(1); return; %skip(1); end subtotal_break; %skip(1); end check_for_subtotal_break; %page; close_page: proc; %skip(3); /* This subroutine closes a page. Increment the number of rows and pages we've already formatted. Check for end of report and set flags accordingly. If the whole page wasn't used then set page_info to reflect the space used. Check for a zero length page, and set the last character to a form feed if it's a paginated report or the last buffer of an unpaginated report. */ %skip(1); format_report_info.number_of_formatted_rows = format_report_info.number_of_formatted_rows + status.total_number_of_rows_used; %skip(1); report_control_info.no_of_formatted_pages = report_control_info.no_of_formatted_pages + 1; %skip(1); if format_report_info.number_of_formatted_rows >= report_control_info.no_of_rows_retrieved then do; report_control_info.flags.report_is_formatted = ON; report_control_info.flags.report_has_just_been_completed = ON; end; %skip(1); if status.remaining_lines_on_page ^= 0 then do; page_info.length = index (template_map_defined_as_a_string, OFF) - 1; page_info.total_characters = page_info.length * page_info.width; end; %skip(1); if page_info.total_characters = 0 then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_format, "The report description resulted in a zero length page."); %skip(1); if paginated_report | status.flags.last_row_of_report then substr (page_defined_as_lines (page_info.length), page_info.width, 1) = FORM_FEED; %skip(1); return; %skip(1); end close_page; %page; evaluate_active_string: proc ( eas_active_string_parm, /* input: the active string */ eas_result_string_parm /* output: resultant string */ ); %skip(1); dcl eas_active_string_parm char (*) varying parm; dcl eas_active_string_parm_length fixed bin (21); dcl eas_active_string_type fixed bin; dcl eas_code fixed bin (35); dcl eas_current_position fixed bin (21); dcl eas_current_inner_position fixed bin (21); dcl eas_left_bracket_count fixed bin; dcl eas_left_bracket_position fixed bin (21); dcl eas_looking_for_matching_right_bracket bit (1) aligned; dcl eas_next_bracket fixed bin (21); dcl eas_result_string_parm char (*) varying parm; dcl eas_right_bracket_count fixed bin; dcl eas_right_bracket_position fixed bin (21); dcl eas_still_evaluating bit (1) aligned; dcl eas_string char (eas_string_length) based (eas_string_ptr); dcl eas_string_length fixed bin (21); dcl eas_string_ptr ptr; dcl eas_string_start fixed bin (21); %skip(3); /* If there are no active requests return to caller. Find the left bracket. Check for "|[" and "||[" constructs and set flag accordingly. Move any user text before the left bracket into the result string. Find the matching right bracket. Have ssu_$evaluate_active_string evaluate everything between the left and matching right bracket. Move the result into the result string. Repeat these operations until no more active requests are left. Move any remaining user text into the result string. */ %skip(1); eas_next_bracket = search (eas_active_string_parm, LEFT_OR_RIGHT_BRACKET); if eas_next_bracket = 0 then do; eas_result_string_parm = eas_active_string_parm; return; end; %skip(1); eas_result_string_parm = ""; eas_current_position = 1; eas_active_string_parm_length = length (eas_active_string_parm); eas_still_evaluating = ON; %page; do while (eas_still_evaluating); %skip(1); eas_left_bracket_count = 0; eas_right_bracket_count = 0; eas_left_bracket_position = index (substr (eas_active_string_parm, eas_current_position), LEFT_BRACKET); if eas_left_bracket_position = 0 then call ssu_$abort_line (sci_ptr, error_table_$unbalanced_brackets, "^a", eas_active_string_parm); eas_left_bracket_count = eas_left_bracket_count + 1; %skip(1); if eas_left_bracket_position >= 3 then if substr (eas_active_string_parm, eas_current_position + eas_left_bracket_position - 3, 2) = BAR_BAR then eas_active_string_type = ATOMIC_ACTIVE_STRING; else if substr (eas_active_string_parm, eas_current_position + eas_left_bracket_position - 2, 1) = BAR then eas_active_string_type = TOKENS_ONLY_ACTIVE_STRING; else eas_active_string_type = NORMAL_ACTIVE_STRING; else if eas_left_bracket_position >= 2 then if substr (eas_active_string_parm, eas_current_position + eas_left_bracket_position - 2, 1) = BAR then eas_active_string_type = TOKENS_ONLY_ACTIVE_STRING; else eas_active_string_type = NORMAL_ACTIVE_STRING; else eas_active_string_type = NORMAL_ACTIVE_STRING; %skip(1); if eas_active_string_type = NORMAL_ACTIVE_STRING then eas_result_string_parm = eas_result_string_parm || substr (eas_active_string_parm, eas_current_position, eas_left_bracket_position - 1); else if eas_active_string_type = TOKENS_ONLY_ACTIVE_STRING then eas_result_string_parm = eas_result_string_parm || substr (eas_active_string_parm, eas_current_position, eas_left_bracket_position - 2); else eas_result_string_parm = eas_result_string_parm || substr (eas_active_string_parm, eas_current_position, eas_left_bracket_position - 3); %skip(1); eas_current_inner_position = eas_current_position + eas_left_bracket_position; eas_string_start = eas_current_inner_position; eas_looking_for_matching_right_bracket = ON; %skip(1); do while (eas_looking_for_matching_right_bracket); if eas_current_inner_position > eas_active_string_parm_length then call ssu_$abort_line (sci_ptr, error_table_$unbalanced_brackets, "^a", eas_active_string_parm); eas_next_bracket = search (substr (eas_active_string_parm, eas_current_inner_position), LEFT_OR_RIGHT_BRACKET); if eas_next_bracket = 0 then call ssu_$abort_line (sci_ptr, error_table_$unbalanced_brackets, "^a", eas_active_string_parm); if substr (eas_active_string_parm, eas_current_inner_position + eas_next_bracket - 1, 1) = LEFT_BRACKET then eas_left_bracket_count = eas_left_bracket_count + 1; else eas_right_bracket_count = eas_right_bracket_count + 1; if eas_left_bracket_count = eas_right_bracket_count then eas_looking_for_matching_right_bracket = OFF; else eas_current_inner_position = eas_current_inner_position + eas_next_bracket; end; %skip(1); eas_right_bracket_position = eas_current_inner_position + eas_next_bracket - 1; eas_string_length = eas_right_bracket_position - eas_string_start; eas_string_ptr = addr (substr (eas_active_string_parm, eas_string_start, 1)); time1 = vclock; call ssu_$evaluate_active_string (sci_ptr, null (), eas_string, eas_active_string_type, eas_spare_string, eas_code); time2 = vclock; report_control_info.ssu_evaluate_active_string_time = report_control_info.ssu_evaluate_active_string_time + time2 - time1; if eas_code ^= 0 then call ssu_$abort_line (sci_ptr, eas_code); %skip(1); eas_result_string_parm = eas_result_string_parm || eas_spare_string; eas_current_position = eas_right_bracket_position + 1; %skip(1); if eas_current_position > eas_active_string_parm_length then eas_still_evaluating = OFF; else if search (substr (eas_active_string_parm, eas_current_position), LEFT_OR_RIGHT_BRACKET) = 0 then do; eas_result_string_parm = eas_result_string_parm || substr (eas_active_string_parm, eas_current_position); eas_still_evaluating = OFF; end; else; %skip(1); end; %skip(1); return; %skip(1); end evaluate_active_string; %page; execute_editing_strings: proc; %skip(1); dcl ees_loop fixed bin; %skip(3); /* Walk through the list of input columns in the column order specified by the user. If the column has an editing request associated with it, pick up the pointer and length to the original editing request from the input_columns_info array. Have it evaluated. If the column isn't being excluded from the page, then set the editing string ptr and length for it's output column to the result string; if it is then set the same information for the input column. Stash the result string in the temp segment and advance the next available byte index. */ %skip(1); editing_strings_next_byte = format_report_info.editing_strings_next_available_byte; %skip(1); do ees_loop = 1 to input_columns_info.number_of_columns; column_ip = addr (input_columns_info.columns (input_columns_order (ees_loop))); if column_info.editing then do; editing_string_rl = column_info.editing_string_length; editing_string_rp = column_info.editing_string_ptr; input_string = editing_string_result; call evaluate_active_string (input_string, output_string); if column_info.output_column ^= 0 then column_ip = addr (output_columns_info.columns (column_info.output_column)); column_info.editing_string_result_length = length (output_string); column_info.editing_string_result_ptr = addr (editing_strings_temp_seg_as_an_array (editing_strings_next_byte)); substr (editing_strings_temp_seg, editing_strings_next_byte, column_info.editing_string_result_length) = output_string; editing_strings_next_byte = editing_strings_next_byte + column_info.editing_string_result_length; end; end; %skip(1); return; %skip(1); end execute_editing_strings; %page; fit_column: proc ( fc_column_value_parm, /* input: actual column value */ fc_output_width_parm, /* input: width to place it into */ fc_output_position_parm, /* input: starting position in template */ fc_alignment_mode_parm, /* input: left, right, center, or both */ fc_decimal_position_parm, /* input: decimal position within width */ fc_template_parm, /* input: template to lay down */ fc_fill_parm, /* input: fill or truncate */ fc_line_number_parm, /* input: beginning line number on page */ fc_code_parm /* output: success or failure */ ); %skip(1); dcl fc_additional_alignment bit (1) aligned; dcl fc_alignment_mode_parm fixed bin parm; dcl fc_code fixed bin (35); dcl fc_code_parm fixed bin (35) parm; dcl fc_column_value_parm char (*) varying parm; dcl fc_current_line_on_page fixed bin; dcl fc_current_position fixed bin; dcl fc_decimal_position_parm fixed bin; dcl fc_fill_parm bit (1) unaligned parm; dcl fc_line_number_parm fixed bin parm; dcl fc_new_line_position fixed bin; dcl fc_output_column char (fc_output_width_parm) based (fc_output_column_ptr); dcl fc_output_column_ptr ptr; dcl fc_output_width_parm fixed bin parm; dcl fc_output_position_parm fixed bin parm; dcl fc_returned_string_length fixed bin (21); dcl fc_spare_string_length fixed bin; dcl fc_still_filling bit (1) aligned; dcl fc_string_end fixed bin; dcl fc_template_parm char (*) parm; %skip(3); /* Make sure we're not starting past the end of the page. Set our current line on the page to where the parm says we're supposed to start. If a template hasn't been laid down yet on that line then lay one down and mark it as laid down. If the value contains hardcopy mechanical device motion control codes, or it is overlength, or the alignment is set to both, then have the value filled; else have the value placed. */ %skip(1); fc_code_parm = 0; if fc_line_number_parm > template_map_number_of_bits then do; fc_code_parm = PAGE_OVERFLOW_ERROR_CODE; return; end; else fc_current_line_on_page = fc_line_number_parm; %skip(1); if ^template_map (fc_current_line_on_page) then do; page_defined_as_lines (fc_current_line_on_page) = fc_template_parm; template_map (fc_current_line_on_page) = ON; end; %skip(1); if (search (fc_column_value_parm, BACKSPACE_OR_VERTICAL_TAB_OR_HORIZONTAL_TAB_OR_NL) ^= 0) | (length (fc_column_value_parm) > fc_output_width_parm) | (fc_alignment_mode_parm = BOTH_ALIGNMENT) then call fill_the_column; else call place_column (fc_column_value_parm); %skip(1); return; %page; fill_the_column: proc; %skip(3); /* The variable output_string is based on a segment, and the variable input_string is artificially constructed to look like a char (N) where N is the length of the meaninful portion of our parm. We do this because format_document_ doesn't want a varying char string, and because format_document_ will start out by doing a "length (rtrim (input_string))" of input_string, which could be an entire segment. Set the adj_sw and call format_document_. Artifically set the length of output_string based on how long format_document_ says it is. Strings filled by format_document_ may still have to be additionally aligned to center or right as they are being placed on the page. If the alignment mode is truncate then call the subroutine to do it, else do it here. */ %skip(1); input_string_non_varying_length = length (fc_column_value_parm); input_string_non_varying_ptr = addrel (addr (fc_column_value_parm), 1); format_document_options.line_length = fc_output_width_parm; if fc_alignment_mode_parm = BOTH_ALIGNMENT then format_document_options.switches.adj_sw = ON; else format_document_options.switches.adj_sw = OFF; %skip(1); call format_document_$string (input_string_non_varying, output_string_non_varying, fc_returned_string_length, format_document_options_ptr, fc_code); if fc_code ^= 0 then if fc_code ^= error_table_$recoverable_error then call ssu_$abort_line (sci_ptr, fc_code); if fc_returned_string_length = 0 then return; %skip(1); output_string_redefined.length_word = fc_returned_string_length; %skip(1); if fc_alignment_mode_parm = CENTER_ALIGNMENT | fc_alignment_mode_parm = RIGHT_ALIGNMENT then fc_additional_alignment = ON; else fc_additional_alignment = OFF; %skip(1); if ^fc_fill_parm then do; call truncate_the_column; return; end; %page; /* Walk through the filled string. Find the newline. If the found portion contains any backspaces then send it off to the hardcopy terminal alignment routine. If it doesn't and there is additional alignment then have it done. If it doesn't and there isn't additional alignment then just place it on the page. If we're still filling then advance our current line on the page, check for template already laid down, lay it down and mark it if it hasn't been laid down. */ %skip(1); fc_still_filling = ON; fc_current_position = 1; %skip(1); do while (fc_still_filling); fc_new_line_position = index (substr (output_string, fc_current_position), NEWLINE); if index (substr (output_string, fc_current_position, fc_new_line_position - 1), BACKSPACE) ^= 0 then do; fc_spare_string = substr (output_string, fc_current_position, fc_new_line_position - 1); call align_hardcopy_dependent_string (fc_spare_string); end; else if fc_additional_alignment then do; fc_spare_string = substr (output_string, fc_current_position, fc_new_line_position - 1); call place_column (fc_spare_string); end; else substr (page_defined_as_lines (fc_current_line_on_page), fc_output_position_parm, fc_new_line_position - 1) = substr (output_string, fc_current_position, fc_new_line_position - 1); fc_current_position = fc_current_position + fc_new_line_position; if fc_current_position > output_string_redefined.length_word then fc_still_filling = OFF; else do; fc_current_line_on_page = fc_current_line_on_page + 1; if fc_current_line_on_page > template_map_number_of_bits then do; fc_code_parm = PAGE_OVERFLOW_ERROR_CODE; return; end; if ^template_map (fc_current_line_on_page) then do; page_defined_as_lines (fc_current_line_on_page) = fc_template_parm; template_map (fc_current_line_on_page) = ON; end; end; end; %skip(1); return; %skip(1); end fill_the_column; %page; place_column: proc ( pc_column_value_parm /* input: actual column value */ ); %skip(1); dcl pc_column_value_parm char (*) varying parm; dcl pc_column_width fixed bin; dcl pc_decimal_position fixed bin; dcl pc_no_of_digits_to_the_left fixed bin; dcl pc_no_of_digits_to_the_right fixed bin; dcl pc_remaining_digits fixed bin; dcl pc_starting_position fixed bin; dcl pc_the_actual_decimal fixed bin; %skip(3); /* Set the pointer to the output column to the desired spot on the page. Have the value aligned within the output column based on what the parm says. */ %skip(1); fc_output_column_ptr = addr (page_defined_as_chars ( ((fc_current_line_on_page - 1) * page_info.width + fc_output_position_parm))); %skip(1); if fc_alignment_mode_parm = DECIMAL_ALIGNMENT then call align_decimal_value; else if fc_alignment_mode_parm = LEFT_ALIGNMENT then call align_left_value; else if fc_alignment_mode_parm = RIGHT_ALIGNMENT then call align_right_value; else if fc_alignment_mode_parm = CENTER_ALIGNMENT then call align_center_value; else call ssu_$abort_line (sci_ptr, error_table_$badcall, "Unknown alignment mode ^d.", fc_alignment_mode_parm); %skip(1); return; %page; align_center_value: proc; %skip(3); /* Center the value in the output column. (Centre it for the Canadian users. This subroutine speaks American and Canadian.) Figure out where it should start and substring it into place. */ %skip(1); pc_column_width = length (pc_column_value_parm); %skip(1); if (pc_column_width = fc_output_width_parm) | (fc_output_width_parm - pc_column_width) = 1 then pc_starting_position = 1; else if fc_output_width_parm - pc_column_width = 2 then pc_starting_position = 2; else do; pc_starting_position = fc_output_width_parm - pc_column_width; pc_starting_position = divide (pc_starting_position, 2, 17) + 1; end; %skip(1); substr (fc_output_column, pc_starting_position, pc_column_width) = pc_column_value_parm; %skip(1); return; %skip(1); end align_center_value; %page; align_decimal_value: proc; %skip(1); /* Decimal align it within the output column width, adding the decimal if necessary. */ %skip(1); pc_column_value = pc_column_value_parm; pc_column_width = length (pc_column_value); if fc_decimal_position_parm > fc_output_width_parm then pc_decimal_position = fc_output_width_parm; else pc_decimal_position = fc_decimal_position_parm; pc_no_of_digits_to_the_left = pc_decimal_position - 1; pc_no_of_digits_to_the_right = fc_output_width_parm - pc_decimal_position; %skip(1); substr (fc_output_column, pc_decimal_position, 1) = "."; pc_the_actual_decimal = index (pc_column_value, "."); if pc_the_actual_decimal = 0 then do; if pc_column_width = pc_decimal_position then pc_column_value = substr (pc_column_value, 2) || "."; else pc_column_value = pc_column_value || "."; pc_column_width = length (pc_column_value); pc_the_actual_decimal = pc_column_width; end; %skip(1); if pc_the_actual_decimal = pc_decimal_position then substr (fc_output_column, 1, pc_no_of_digits_to_the_left) = substr (pc_column_value, 1, pc_no_of_digits_to_the_left); else if pc_the_actual_decimal - 1 > pc_no_of_digits_to_the_left then substr (fc_output_column, 1, pc_no_of_digits_to_the_left) = substr (pc_column_value, pc_the_actual_decimal - pc_no_of_digits_to_the_left, pc_no_of_digits_to_the_left); else substr (fc_output_column, pc_no_of_digits_to_the_left - pc_the_actual_decimal + 2, pc_the_actual_decimal - 1) = substr (pc_column_value, 1, pc_the_actual_decimal - 1); %skip(1); if pc_no_of_digits_to_the_right = 0 | pc_the_actual_decimal = pc_column_width then return; %skip(1); pc_remaining_digits = pc_column_width - pc_the_actual_decimal; if pc_no_of_digits_to_the_right = pc_remaining_digits then substr (fc_output_column, pc_decimal_position + 1) = substr (pc_column_value, pc_the_actual_decimal + 1); else if pc_no_of_digits_to_the_right > pc_remaining_digits then substr (fc_output_column, pc_decimal_position + 1) = substr (pc_column_value, pc_the_actual_decimal + 1); else substr (fc_output_column, pc_decimal_position + 1) = substr (pc_column_value, pc_the_actual_decimal + 1, pc_no_of_digits_to_the_right); %skip(1); return; %skip(1); end align_decimal_value; %page; align_left_value: proc; %skip(3); /* An easy alignment task, but probably the most often used. Note that only the exact number of characters in the parm are what's moved. The template that was laid down already blanked the rest of the output column. */ %skip(1); substr (fc_output_column, 1, length (pc_column_value_parm)) = pc_column_value_parm; %skip(1); return; %skip(1); end align_left_value; %page; align_right_value: proc; %skip(3); /* Once again, only the characters in the parm are moved. */ %skip(1); substr (fc_output_column, fc_output_width_parm - length (pc_column_value_parm) + 1) = pc_column_value_parm; %skip(1); return; %skip(1); end align_right_value; %skip(3); end place_column; %page; align_hardcopy_dependent_string: proc ( ahds_column_value_parm /* input: actual column value */ ); %skip(1); dcl ahds_column_value_parm char (*) varying parm; dcl ahds_current_input_position fixed bin; dcl ahds_current_output_position fixed bin; dcl ahds_loop fixed bin; dcl ahds_number_of_chars_to_move fixed bin; dcl ahds_overstrike_index fixed bin; dcl ahds_still_overstriking bit (1) aligned; dcl ahds_string_length fixed bin; dcl ahds_truncate_the_column bit (1) aligned; dcl ahds_virtual_length fixed bin; %skip(3); /* Hopefully all of the hardcopy device support will one day be moved out of the operating system and applications forever. In the meantime we continue to bake it into everything written on Multics because that's the way it was done back in 1965 when Multics was first started. Fortunately the video system has said "I don't support ugly backspaces, and if you give me any to write I will refuse and hand you back an error code." This subroutine pre-processes the data so that the video system will not give us any error codes, and we can do things more rationally than they were done back in 1965 and are still being done today many places in Multics. This is also the key to why this formatter runs *so* fast when compared with others like compose. It never has to try to figure out where it really is on a page, because it doesn't have imbedded hardcopy device motion control characters stuck in the formatted page. Instead they are moved off to a separate overstrike array, and the formatter only runs slower for the people who continue to bake hardcopy device motion control characters in their formatted data. When the page is being displayed through the video system the page is displayed without any of the overstruck sequences; when it is being displayed in hardcopy dependent fashion the overstruck characters are put back in at display time. */ %skip(1); ahds_string_length = length (ahds_column_value_parm); if ahds_string_length = 0 then return; %skip(1); ahds_overstrike_index = ((fc_current_line_on_page - 1) * page_info.width) + fc_output_position_parm; fc_output_column_ptr = addr (page_defined_as_chars (ahds_overstrike_index)); %skip(1); ahds_virtual_length = 0; do ahds_loop = 1 to ahds_string_length; if substr (ahds_column_value_parm, ahds_loop, 1) ^= BACKSPACE then ahds_virtual_length = ahds_virtual_length + 1; else ahds_virtual_length = ahds_virtual_length - 1; end; %skip(1); if ^fc_fill_parm then do; if ahds_virtual_length > fc_output_width_parm then do; ahds_number_of_chars_to_move = fc_output_width_parm - truncation_indicator_length; ahds_truncate_the_column = ON; end; else do; ahds_number_of_chars_to_move = ahds_virtual_length; ahds_truncate_the_column = OFF; end; if ahds_truncate_the_column then if fc_output_width_parm <= truncation_indicator_length then do; if fc_output_width_parm < truncation_indicator_length then fc_output_column = substr (format_report_info.truncation_indicator, 1, fc_output_width_parm); else fc_output_column = format_report_info.truncation_indicator; return; end; else; else; end; else ahds_number_of_chars_to_move = ahds_virtual_length; %skip(1); if page_info.page_overstrike_info_ptr = null () then do; page_info.page_overstrike_info_ptr = page_overstrike_ip; unspec (page_overstrike_info.bit_map) = OFF; end; %skip(1); if ^fc_additional_alignment then ahds_current_output_position = 1; else do; if fc_alignment_mode_parm = RIGHT_ALIGNMENT then ahds_current_output_position = fc_output_width_parm - ahds_virtual_length + 1; else do; if fc_output_width_parm = ahds_virtual_length | fc_output_width_parm - ahds_virtual_length = 1 then ahds_current_output_position = 1; else if fc_output_width_parm - ahds_virtual_length = 2 then ahds_current_output_position = 2; else do; ahds_current_output_position = fc_output_width_parm - ahds_virtual_length; ahds_current_output_position = divide (ahds_current_output_position, 2, 17) + 1; end; end; end; ahds_current_input_position = 1; %page; do ahds_loop = 1 to ahds_number_of_chars_to_move; substr (fc_output_column, ahds_current_output_position, 1) = substr (ahds_column_value_parm, ahds_current_input_position, 1); ahds_current_input_position = ahds_current_input_position + 1; ahds_still_overstriking = ON; do while (ahds_still_overstriking); if ahds_current_input_position < ahds_string_length then if substr (ahds_column_value_parm, ahds_current_input_position, 1) ^= BACKSPACE then ahds_still_overstriking = OFF; else do; ahds_current_input_position = ahds_current_input_position + 1; page_overstrike_info.bit_map (ahds_overstrike_index + ahds_current_output_position - 1) = ON; page_overstrike_info.chars (ahds_overstrike_index + ahds_current_output_position - 1) = substr (ahds_column_value_parm, ahds_current_input_position, 1); ahds_current_input_position = ahds_current_input_position + 1; end; else ahds_still_overstriking = OFF; end; ahds_current_output_position = ahds_current_output_position + 1; end; %skip(1); if ^fc_fill_parm then if ahds_truncate_the_column then substr (fc_output_column, fc_output_width_parm - truncation_indicator_length + 1) = format_report_info.truncation_indicator; else; else; %skip(1); return; %skip(1); end align_hardcopy_dependent_string; %page; truncate_the_column: proc; %skip(3); /* Find out if the character string or the output width is smallest. Translate any newlines format_document_ may have put in into blanks. If it contains overstruck characters then have the subroutine which specializes in that type of stuff do it; else just place the portion of the character string that fits into the output position. If this results in truncation then place the truncation indicator to show the user this has happened. */ %skip(1); fc_string_end = min (output_string_redefined.length_word, fc_output_width_parm); if fc_string_end = 0 then return; %skip(1); fc_spare_string = substr (output_string, 1, fc_string_end); fc_spare_string = translate (fc_spare_string, BLANK, NEWLINE); if search (fc_spare_string, BACKSPACE) ^= 0 then do; call align_hardcopy_dependent_string (fc_spare_string); return; end; %skip(1); fc_spare_string_length = length (fc_spare_string); substr (page_defined_as_lines (fc_line_number_parm), fc_output_position_parm, fc_spare_string_length) = fc_spare_string; if output_string_redefined.length_word ^> fc_output_width_parm then return; %skip(1); if fc_output_width_parm > truncation_indicator_length then substr (page_defined_as_lines (fc_line_number_parm), fc_output_position_parm + fc_output_width_parm - truncation_indicator_length, truncation_indicator_length) = format_report_info.truncation_indicator; else substr (page_defined_as_lines (fc_line_number_parm), fc_output_position_parm, fc_output_width_parm) = substr (format_report_info.truncation_indicator, 1, fc_output_width_parm); %skip(1); return; %skip(1); end truncate_the_column; %skip(3); end fit_column; %page; format_detail_block: proc; %skip(1); dcl fdb_code fixed bin (35); dcl fdb_column_changed_flag bit (1) aligned; %skip(1); /* If the detail block won't fit on the page then we are done. Check to make sure that at least one detail block has been placed on the page. */ %skip(1); if (status.number_of_lines_needed_for_detail_block > status.remaining_lines_on_page) | (format_report_info.flags.page_footer_is_defined & status.remaining_lines_on_page < status.number_of_lines_needed_for_page_footer + status.number_of_lines_needed_for_detail_block) then do; if status.total_number_of_rows_used ^> 0 then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_format, "^/There isn't enough room to place the first row on the page." || "^/It was row number ^d on page number ^d.", status.current_row_number, status.current_page_number); else do; still_formatting_detail_blocks = OFF; return; end; end; %skip(1); /* Check to see if this row has been processed before and backed off the page. Flag appropriately. If the previous detail block used some lines then setup the detail_block information so this one can be backed out properly. */ %skip(1); if status.current_row_number > status.highest_row_formatted then do; status.highest_row_formatted = status.current_row_number; status.flags.row_has_been_processed_before = OFF; end; else status.flags.row_has_been_processed_before = ON; %skip(1); if status.flags.detail_block_used_some_lines then do; formatted_page_info.number_of_detail_blocks = formatted_page_info.number_of_detail_blocks + 1; formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks) = 0; formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).row_number = status.current_row_number; formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).beginning_line_number = status.current_line_on_page; end; %page; /* Mark this block initially as using no lines. Execute the editing requests, and gather the subtotals, subcounts, totals and counts before formatting anything. */ %skip(1); status.flags.detail_block_used_some_lines = OFF; %skip(1); if format_report_info.flags.editing_is_defined then call execute_editing_strings; %skip(1); if format_report_info.flags.subtotal_is_defined then call gather_subtotals; %skip(1); if format_report_info.flags.subcount_is_defined then call gather_subcounts; %skip(1); if format_report_info.flags.total_is_defined then call gather_totals; %skip(1); if format_report_info.flags.count_is_defined then call gather_counts; %skip(1); /* If a group header and trigger are defined then check to see if it is time to process it. If one of the trigger columns changed then format the header, backing it out if necessary. */ %skip(1); if format_report_info.flags.group_header_is_defined & format_report_info.flags.group_header_trigger_is_defined then do; call check_for_group_break (format_report_info.group_header_trigger_info_ptr, LOOK_BEHIND, fdb_column_changed_flag); if fdb_column_changed_flag then do; call format_header (format_report_info.group_header_info_ptr, GROUP_HEADER, status.current_line_on_page, status.remaining_lines_on_page, formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks) .group_header_length, fdb_code); if fdb_code ^= 0 then do; call backout_detail_block (GROUP_HEADER); return; end; else status.flags.detail_block_used_some_lines = ON; end; end; %page; /* Next the row header. If it's defined then format it, backing it out if necessary. */ %skip(1); if format_report_info.flags.row_header_is_defined then do; call format_header (format_report_info.row_header_info_ptr, ROW_HEADER, status.current_line_on_page, status.remaining_lines_on_page, formatted_page_info.detail_blocks (formatted_page_info .number_of_detail_blocks).row_header_length, fdb_code); if fdb_code ^= 0 then do; call backout_detail_block (ROW_HEADER); return; end; else status.flags.detail_block_used_some_lines = ON; end; %skip(1); /* If outlining is defined then outline the columns as appropriate. */ %skip(1); if format_report_info.flags.outline_is_defined then call check_for_outlining; %skip(1); /* If all columns haven't been excluded then format the row, backing it out if necessary. */ %skip(1); if format_report_info.flags.row_value_is_defined then do; call format_row (ROW_VALUE, output_columns_ip, row_value_template_ip, GENERATE_ZERO_BLANK_LINES_TRAILER, status.current_line_on_page, status.remaining_lines_on_page, formatted_page_info.detail_blocks (formatted_page_info .number_of_detail_blocks).row_length, fdb_code); if fdb_code ^= 0 then do; call backout_detail_block (ROW_VALUE); return; end; else status.flags.detail_block_used_some_lines = ON; end; %page; /* If subtotals are defined then format them if it's time for any of them to be generated, backing out the block if necessary. */ %skip(1); if format_report_info.flags.subtotal_is_defined then do; call format_subtotals (subtotal_ip, subtotal_columns_ip, subtotal_generation_ip, ROW_SUBTOTAL, formatted_page_info.detail_blocks.subtotal_length (formatted_page_info.number_of_detail_blocks), status.flags.subtotals_ejection_in_progress, fdb_code); if fdb_code ^= 0 then do; call backout_detail_block (ROW_SUBTOTAL); return; end; end; %skip(1); /* If subcounts are defined then format them if it's time for any of them to be generated, backing out the block if necessary. */ %skip(1); if format_report_info.flags.subcount_is_defined then do; call format_subtotals (subcount_ip, subcount_columns_ip, subcount_generation_ip, ROW_SUBCOUNT, formatted_page_info.detail_blocks.subcount_length (formatted_page_info.number_of_detail_blocks), status.flags.subcounts_ejection_in_progress, fdb_code); if fdb_code ^= 0 then do; call backout_detail_block (ROW_SUBCOUNT); return; end; end; %skip(1); /* If totals are defined and this is the last row of the report then format them, backing them out if necessary. */ %skip(1); if format_report_info.flags.total_is_defined & status.flags.last_row_of_report then do; call format_totals (total_ip, total_columns_ip, ROW_TOTAL, formatted_page_info.detail_blocks.total_length (formatted_page_info.number_of_detail_blocks), status.flags.totals_ejection_in_progress, fdb_code); if fdb_code ^= 0 then do; call backout_detail_block (ROW_TOTAL); return; end; end; %page; /* If counts are defined and this is the last row of the report then format them, backing them out if necessary. */ %skip(1); if format_report_info.flags.count_is_defined & status.flags.last_row_of_report then do; call format_totals (count_ip, count_columns_ip, ROW_COUNT, formatted_page_info.detail_blocks.count_length (formatted_page_info.number_of_detail_blocks), status.flags.counts_ejection_in_progress, fdb_code); if fdb_code ^= 0 then do; call backout_detail_block (ROW_COUNT); return; end; end; %skip(1); /* If the row footer is defined then format it, backing it out if necessary. */ %skip(1); if format_report_info.flags.row_footer_is_defined then do; call format_header (format_report_info.row_footer_info_ptr, ROW_FOOTER, status.current_line_on_page, status.remaining_lines_on_page, formatted_page_info.detail_blocks (formatted_page_info .number_of_detail_blocks).row_footer_length, fdb_code); if fdb_code ^= 0 then do; call backout_detail_block (ROW_FOOTER); return; end; else status.flags.detail_block_used_some_lines = ON; end; %page; /* If a group footer and trigger are defined then check to see if it is time to process it. If one of the trigger columns changed then format the footer, backing it out if necessary. */ %skip(1); if format_report_info.flags.group_footer_is_defined & format_report_info.flags.group_footer_trigger_is_defined then do; call check_for_group_break (format_report_info.group_footer_trigger_info_ptr, LOOK_AHEAD, fdb_column_changed_flag); if fdb_column_changed_flag then do; call format_header (format_report_info.group_footer_info_ptr, GROUP_FOOTER, status.current_line_on_page, status.remaining_lines_on_page, formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).group_footer_length, fdb_code); if fdb_code ^= 0 then do; call backout_detail_block (GROUP_FOOTER); return; end; else status.flags.detail_block_used_some_lines = ON; end; end; %skip(1); /* If we've just formatted the last row, or there isn't enough space remaining on the page to attempt the next row, then quit formatting detail blocks. */ %skip(1); status.total_number_of_rows_used = status.total_number_of_rows_used + 1; status.current_row_number = status.current_row_number + 1; %skip(1); if (status.current_row_number > report_control_info.no_of_rows_retrieved) | (status.number_of_lines_needed_for_detail_block > status.remaining_lines_on_page) | (format_report_info.flags.page_footer_is_defined & status.remaining_lines_on_page < status.number_of_lines_needed_for_page_footer + status.number_of_lines_needed_for_detail_block) then status.still_formatting_detail_blocks = OFF; %page; /* Adjust status flags and check to see if it's time for a page break. */ %skip(1); if report_control_info.table_is_full & status.current_row_number = report_control_info.no_of_rows_retrieved then status.flags.last_row_of_report = ON; %skip(1); status.flags.first_row_of_report = OFF; status.flags.first_row_on_page = OFF; %skip(1); if format_report_info.flags.page_break_is_defined then call check_for_page_break; %skip(1); return; %skip(1); end format_detail_block; %page; format_header: proc ( fh_header_info_ptr_parm, /* input: ptr to header info */ fh_executing_object_parm, /* input: who's calling */ fh_current_line_number_parm, /* input/output: current line on page */ fh_remaining_lines_on_page_parm, /* input/output: number left on page */ fh_number_of_lines_used_parm, /* output: number of lines used */ fh_code_parm /* output: success or failure */ ); %skip(1); dcl fh_current_line_number fixed bin; dcl fh_current_line_number_parm fixed bin parm; dcl fh_code_parm fixed bin (35) parm; dcl fh_executing_object_parm char (*) varying parm; dcl fh_header_info_ptr_parm ptr parm; dcl fh_loop fixed bin; dcl fh_next_line_number fixed bin; dcl fh_number_of_lines_used fixed bin; dcl fh_number_of_lines_used_parm fixed bin parm; dcl fh_remaining_lines_on_page_parm fixed bin parm; dcl fh_still_counting_lines bit (1) aligned; %skip(3); /* Check to make sure we aren't about to exceed the page length. Repeat the following sequence for each line of the header/footer. Lay down a template on the current line and mark it as laid down. For each portion of the header that's present, have any active requests evaluated and fit the header portion into it assigned slot on the page. If we've still got another header line to do then find out where on the page it will begin, and repeat the loop. When we've evaluated all lines then count how many we've used, fill in the parms, and return to caller. */ %skip(1); header_ip = fh_header_info_ptr_parm; fh_current_line_number = fh_current_line_number_parm; fh_number_of_lines_used_parm = 0; fh_code_parm = 0; status.flags.header_being_evaluated = ON; status.object_being_evaluated = fh_executing_object_parm; %skip(1); if fh_current_line_number > template_map_number_of_bits then do; fh_code_parm = PAGE_OVERFLOW_ERROR_CODE; return; end; %page; do status.current_header_line = 1 to header_info.number_of_lines; %skip(1); page_defined_as_lines (fh_current_line_number) = generic_template; template_map (fh_current_line_number) = ON; %skip(1); do status.current_header_part = 1 to header_info.maximum_number_of_parts; %skip(1); if header_info.lines (status.current_header_line).parts (status.current_header_part).flags.present then do; if header_info.lines (status.current_header_line).parts (status.current_header_part).flags.active then do; output_string = substr (headers_temp_seg, header_info.lines (status.current_header_line).parts (status.current_header_part).index, header_info.lines (status.current_header_line).parts (status.current_header_part).length); call evaluate_active_string (output_string, input_string); end; else input_string = substr (headers_temp_seg, header_info.lines (status.current_header_line).parts (status.current_header_part).index, header_info.lines (status.current_header_line).parts (status.current_header_part).length); call fit_column (input_string, header_info.lines (status.current_header_line).parts (status.current_header_part).width, header_info.lines (status.current_header_line).parts (status.current_header_part).starting_position, header_info.lines (status.current_header_line).parts (status.current_header_part).alignment, 0, generic_template, FILL, fh_current_line_number, fh_code_parm); if fh_code_parm ^= 0 then return; end; %skip(1); end; %skip(1); if status.current_header_line < header_info.number_of_lines then do; if fh_current_line_number < template_map_number_of_bits then fh_next_line_number = index (substr (template_map_defined_as_a_string, fh_current_line_number + 1), OFF); else fh_next_line_number = 0; if fh_next_line_number = 0 then do; fh_code_parm = PAGE_OVERFLOW_ERROR_CODE; return; end; else fh_current_line_number = fh_current_line_number + fh_next_line_number; end; %skip(1); end; %page; fh_still_counting_lines = ON; fh_number_of_lines_used = 0; %skip(1); do fh_loop = fh_current_line_number_parm to template_map_number_of_bits while (fh_still_counting_lines); if template_map (fh_loop) then fh_number_of_lines_used = fh_number_of_lines_used + 1; else fh_still_counting_lines = OFF; end; %skip(1); fh_number_of_lines_used_parm = fh_number_of_lines_used; fh_current_line_number_parm = fh_current_line_number_parm + fh_number_of_lines_used; fh_remaining_lines_on_page_parm = template_map_number_of_bits - fh_current_line_number_parm + 1; status.flags.header_being_evaluated = OFF; %skip(1); return; %skip(1); end format_header; %page; format_page_footer: proc; %skip(1); dcl fpf_beginning_line_number fixed bin; dcl fpf_code fixed bin (35); dcl fpf_loop fixed bin; dcl fpf_overstrike_index_1 fixed bin; dcl fpf_overstrike_index_2 fixed bin; dcl fpf_overstruck_page bit (1) aligned; dcl fpf_page_footer_doesnt_fit bit (1) aligned; %skip(1); /* Unpaginated reports only have a page footer placed after the last row of the report. Repeat the following sequence while the footer doesn't fit. Decrement the current row number so the last row on the page is available for the footer. Format the footer. If it doesn't fit then decrement the number of rows used on this page, back out the last detail block, and repeat the loop. If it does fit then kick out of the loop. (The proc that does the backing out never allows the first row of a page to be removed, so it is the governing mechanism in this loop.) */ %skip(1); if ^paginated_report & ^status.flags.last_row_of_report then return; %skip(1); fpf_page_footer_doesnt_fit = ON; %skip(1); do while (fpf_page_footer_doesnt_fit); status.current_row_number = status.current_row_number - 1; fpf_beginning_line_number = status.current_line_on_page; call format_header (format_report_info.page_footer_info_ptr, PAGE_FOOTER, status.current_line_on_page, status.remaining_lines_on_page, formatted_page_info.page_footer_length, fpf_code); if fpf_code ^= 0 then do; status.total_number_of_rows_used = status.total_number_of_rows_used - 1; call backout_detail_block (PAGE_FOOTER); end; else fpf_page_footer_doesnt_fit = OFF; end; %skip(1); /* Adjust the current row number to compensate for when we decremented it. If there are remaining lines on the page and it's a paginated report do the following steps. Work the loop from the last line of the page back up to where we placed the last line of the footer. If we've just moved up to the point where we originally placed the footer lines then lay down a generic template to blank out the footer line, mark the template map, and if it's an overstruck page then show the line as having no overstrikes. If we haven't arrived at this point yet, then move the footer line down the page to where it belongs, mark the template map, and move any overstrike info if it's an overstruck page. */ %page; status.current_row_number = status.current_row_number + 1; %skip(1); if status.remaining_lines_on_page > 0 then if paginated_report then do; fpf_overstruck_page = (page_info.page_overstrike_info_ptr ^= null ()); do fpf_loop = template_map_number_of_bits to fpf_beginning_line_number by -1; if fpf_loop < template_map_number_of_bits - formatted_page_info.page_footer_length + 1 then do; page_defined_as_lines (fpf_loop) = generic_template; template_map (fpf_loop) = ON; if fpf_overstruck_page then substr (page_overstrike_info_redefined.bit_map, ((fpf_loop - 1) * page_info.width) + 1, page_info.width) = OFF; else; end; else do; page_defined_as_lines (fpf_loop) = page_defined_as_lines (fpf_loop - status.remaining_lines_on_page); template_map (fpf_loop) = ON; if fpf_overstruck_page then do; fpf_overstrike_index_1 = ((fpf_loop - 1) * page_info.width) + 1; fpf_overstrike_index_2 = ((fpf_loop - status.remaining_lines_on_page - 1) * page_info.width) + 1; substr (page_overstrike_info_redefined.bit_map, fpf_overstrike_index_1, page_info.width) = substr (page_overstrike_info_redefined.bit_map, fpf_overstrike_index_2, page_info.width); substr (page_overstrike_info_redefined.chars, fpf_overstrike_index_1, page_info.width) = substr (page_overstrike_info_redefined.chars, fpf_overstrike_index_2, page_info.width); end; end; end; status.current_line_on_page = template_map_number_of_bits; status.remaining_lines_on_page = 0; end; else; else; %skip(1); return; %skip(1); end format_page_footer; %page; format_page_header: proc; %skip(1); dcl fph_code fixed bin (35); %skip(3); /* Unpaginated reports only have the header placed before the first row. Format the header and if it doesn't fit shut things down. */ %skip(1); if ^paginated_report & ^status.flags.first_row_of_report then return; %skip(1); call format_header (format_report_info.page_header_info_ptr, PAGE_HEADER, status.current_line_on_page, status.remaining_lines_on_page, formatted_page_info.page_header_length, fph_code); if fph_code ^= 0 then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_format, "^/There isn't enough room to place the page header on page number ^d.", status.current_page_number); %skip(1); return; %skip(1); end format_page_header; %page; format_row: proc ( fr_executing_object_parm, /* input: who's calling */ fr_output_columns_info_ptr_parm, /* input: ptr to output_columns_info */ fr_row_template_info_ptr_parm, /* input: ptr to template_info */ fr_number_of_blank_lines_parm, /* input: # of blank lines after row */ fr_current_line_number_parm, /* input/output: current line on page */ fr_remaining_lines_on_page_parm, /* input/output: number left on page */ fr_number_of_lines_used_parm, /* output: number of lines used */ fr_code_parm /* output: success or failure */ ); %skip(1); dcl fr_current_line_number_parm fixed bin parm; dcl fr_code_parm fixed bin (35) parm; dcl fr_current_detail_line fixed bin; dcl fr_current_line_number fixed bin; dcl fr_executing_object_parm char (*) varying parm; dcl fr_loop fixed bin; dcl fr_next_line_number fixed bin; dcl fr_number_of_blank_lines_parm fixed bin; dcl fr_number_of_lines_used fixed bin; dcl fr_number_of_lines_used_by_prefix fixed bin; dcl fr_number_of_lines_used_parm fixed bin parm; dcl 1 fr_output_columns_info like output_columns_info based (fr_output_columns_info_ptr); dcl fr_output_columns_info_ptr ptr; dcl fr_output_columns_info_ptr_parm ptr parm; dcl fr_remaining_lines_on_page_parm fixed bin parm; dcl 1 fr_row_template_info like template_info based (fr_row_template_info_ptr); dcl fr_row_template_info_ptr ptr; dcl fr_row_template_info_ptr_parm ptr parm; dcl fr_still_counting_lines bit (1) aligned; %skip(1); /* Move parms into automatic variables, check to make sure we aren't about to run off the page, lay down a template on the first line and mark it. */ %skip(1); status.object_being_evaluated = fr_executing_object_parm; fr_output_columns_info_ptr = fr_output_columns_info_ptr_parm; fr_row_template_info_ptr = fr_row_template_info_ptr_parm; fr_current_line_number = fr_current_line_number_parm; fr_number_of_lines_used_parm = 0; fr_code_parm = 0; %skip(1); fr_current_detail_line = 1; template_ptr = addr (fr_row_template_info.templates (fr_current_detail_line)); if fr_current_line_number > template_map_number_of_bits then do; fr_code_parm = PAGE_OVERFLOW_ERROR_CODE; return; end; page_defined_as_lines (fr_current_line_number) = template; template_map (fr_current_line_number) = ON; %page; /* Repeat the following sequence for each column that isn't being outlined. If it has a prefix character then expand it to full column width and have it fit into the output column. If it has an editing request then use it; else rtrim character column values and rtrim and ltrim all other column values. Fit the column into the output column. If we're not on the last column and the next column goes onto a different output line, then find out where the next output line is and lay down a template also marking it (making sure it doesn't place us past the end of the page). */ %skip(1); do status.current_column_number = 1 to fr_output_columns_info.number_of_columns; column_ip = addr (fr_output_columns_info.columns (status.current_column_number)); if ^column_info.flags.outline then do; if length (column_info.prefix_character) > 0 then do; fr_spare_string = copy (column_info.prefix_character, column_info.width); call fit_column (fr_spare_string, column_info.width, column_info.starting_position, LEFT_ALIGNMENT, 0, template, FILL, fr_current_line_number, fr_code_parm); if fr_code_parm ^= 0 then return; else fr_number_of_lines_used_by_prefix = 1; end; else fr_number_of_lines_used_by_prefix = 0; if column_info.flags.editing then do; editing_string_rl = column_info.editing_string_result_length; editing_string_rp = column_info.editing_string_result_ptr; input_string = editing_string_result; end; else do; if column_info.linus_data_type ^= CHAR_DATA_TYPE then input_string = ltrim (rtrim (substr (current_row_value, table_info.columns.column_index (column_info.input_column), table_info.columns.column_length (column_info.input_column)))); else input_string = rtrim (substr (current_row_value, table_info.columns.column_index (column_info.input_column), table_info.columns.column_length (column_info.input_column))); end; call fit_column (input_string, column_info.width, column_info.starting_position, column_info.alignment, column_info.decimal_position, template, column_info.folding_is_fill, fr_current_line_number + fr_number_of_lines_used_by_prefix, fr_code_parm); if fr_code_parm ^= 0 then return; end; else; if status.current_column_number ^= fr_output_columns_info.number_of_columns then if fr_output_columns_info.columns (status.current_column_number).output_line ^= fr_output_columns_info.columns (status.current_column_number + 1).output_line then do; if fr_current_line_number < template_map_number_of_bits then fr_next_line_number = index (substr (template_map_defined_as_a_string, fr_current_line_number + 1), OFF); else fr_next_line_number = 0; if fr_next_line_number = 0 then do; fr_code_parm = PAGE_OVERFLOW_ERROR_CODE; return; end; fr_current_line_number = fr_current_line_number + fr_next_line_number; fr_current_detail_line = fr_current_detail_line + 1; template_ptr = addr (fr_row_template_info.templates (fr_current_detail_line)); page_defined_as_lines (fr_current_line_number) = template; template_map (fr_current_line_number) = ON; end; end; %skip(1); /* Find out how many lines we've used. Add any blank trailer lines requested by the caller. Set the parms and return to caller. */ %skip(1); fr_still_counting_lines = ON; fr_number_of_lines_used = 0; %skip(1); do fr_loop = fr_current_line_number_parm to template_map_number_of_bits while (fr_still_counting_lines); if template_map (fr_loop) then fr_number_of_lines_used = fr_number_of_lines_used + 1; else fr_still_counting_lines = OFF; end; %skip(1); if fr_number_of_blank_lines_parm ^= 0 then do; fr_current_line_number = fr_current_line_number_parm + fr_number_of_lines_used; do fr_loop = 1 to fr_number_of_blank_lines_parm; if fr_current_line_number ^> template_map_number_of_bits then do; page_defined_as_lines (fr_current_line_number) = generic_template; template_map (fr_current_line_number) = ON; fr_current_line_number = fr_current_line_number + 1; fr_number_of_lines_used = fr_number_of_lines_used + 1; end; else do; fr_code_parm = PAGE_OVERFLOW_ERROR_CODE; return; end; end; end; %skip(1); fr_number_of_lines_used_parm = fr_number_of_lines_used; fr_current_line_number_parm = fr_current_line_number_parm + fr_number_of_lines_used; fr_remaining_lines_on_page_parm = template_map_number_of_bits - fr_current_line_number_parm + 1; %skip(1); return; %skip(1); end format_row; %page; format_title_block: proc; %skip(1); dcl ftb_code fixed bin (35); dcl ftb_current_line_number fixed bin; dcl ftb_loop fixed bin; %skip(3); /* Unpaginated reports only have the title block placed before the first row of the report. Create the title block if it's our first time and save it away for future use if it's a paginated report. If it isn't our first time then just place the title block we've already created. If the title block contains overstruck characters then they loose this optimization (the title block is formatted every time it's needed). If the title block doesn't fit then shut things down. */ %skip(1); if (^paginated_report & ^status.flags.first_row_of_report) then return; %skip(1); if format_report_info.title_block_info_ptr = null () then call create_title_block (ftb_code); else call place_title_block (ftb_code); %skip(1); if ftb_code ^= 0 then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_format, "^/There isn't enough room to place the titles on page number ^d.", status.current_page_number); %skip(1); return; %page; create_title_block: proc (ctb_code_parm); %skip(1); dcl ctb_code_parm fixed bin (35) parm; %skip(3); /* Format the title block onto the page. If it's not a paginated report or it contains overstruck characters then return to caller. Allocate the title_block_info structure and save away our formatted lines for future placement on the coming pages. */ %skip(1); title_block_columns_ip = format_report_info.title_block_columns_info_ptr; ftb_current_line_number = status.current_line_on_page; call format_row (ROW_TITLES, title_block_columns_ip, row_value_template_ip, GENERATE_ONE_BLANK_LINE_TRAILER, status.current_line_on_page, status.remaining_lines_on_page, formatted_page_info.title_block_length, ctb_code_parm); if ctb_code_parm ^= 0 then return; %skip(1); if ^paginated_report then return; else if page_info.page_overstrike_info_ptr ^= null () then if index (substr (page_overstrike_info_redefined.bit_map, ((ftb_current_line_number - 1) * page_info.width) + 1, page_info.width * formatted_page_info.title_block_length), ON) ^= 0 then return; %skip(1); tbi_init_line_length = page_info.width; tbi_init_number_of_lines = formatted_page_info.title_block_length; allocate title_block_info in (work_area) set (title_block_ip); %skip(1); do ftb_loop = 1 to formatted_page_info.title_block_length; title_block_info.lines (ftb_loop) = page_defined_as_lines (ftb_current_line_number); ftb_current_line_number = ftb_current_line_number + 1; end; %skip(1); format_report_info.title_block_info_ptr = title_block_ip; %skip(1); return; %skip(1); end create_title_block; %page; place_title_block: proc (ptb_code_parm); %skip(1); dcl ptb_code_parm fixed bin (35) parm; %skip(3); /* Place the saved away title lines onto the page. Lay down a title line and mark the template map. Repeat while we have more title lines. Set the title block length, current line on page, and remaining lines on page. */ %skip(1); ptb_code_parm = 0; title_block_ip = format_report_info.title_block_info_ptr; ftb_current_line_number = status.current_line_on_page; %skip(1); do ftb_loop = 1 to title_block_info.number_of_lines; if ftb_current_line_number > template_map_number_of_bits then do; ptb_code_parm = PAGE_OVERFLOW_ERROR_CODE; return; end; page_defined_as_lines (ftb_current_line_number) = title_block_info.lines (ftb_loop); template_map (ftb_current_line_number) = ON; ftb_current_line_number = ftb_current_line_number + 1; end; %skip(1); formatted_page_info.title_block_length = title_block_info.number_of_lines; status.current_line_on_page = status.current_line_on_page + title_block_info.number_of_lines; status.remaining_lines_on_page = template_map_number_of_bits - status.current_line_on_page + 1; %skip(1); return; %skip(1); end place_title_block; %skip(3); end format_title_block; %page; format_subtotals: proc ( fst_subtotal_info_ptr_parm, /* input: ptr to subtotal_info structure */ fst_subtotal_columns_info_ptr_parm, /* input: ptr to subtotal_columns_info structure */ fst_subtotal_generation_info_ptr_parm, /* input: ptr to subtotal_generation_info structure */ fst_caller_parm, /* input: "row subtotal" or "row subcount" */ fst_number_of_lines_used_parm, /* output: how many lines the block used */ fst_subtotals_ejection_in_progress_parm, /* output: on when ejection starts, off after ejection complete */ fst_code_parm /* output: success or failure */ ); %skip(1); dcl fst_caller_parm char (*) varying; dcl fst_code_parm fixed bin (35) parm; dcl fst_number_of_lines_used fixed bin; dcl fst_number_of_lines_used_parm fixed bin; dcl fst_some_column_changed bit (1) aligned; dcl 1 fst_subtotal_columns_info like subtotal_columns_info based (fst_subtotal_columns_info_ptr_parm); dcl fst_subtotal_columns_info_ptr_parm ptr parm; dcl 1 fst_subtotal_generation_info like subtotal_generation_info based (fst_subtotal_generation_info_ptr_parm); dcl fst_subtotal_generation_info_ptr_parm ptr parm; dcl 1 fst_subtotal_info like subtotal_info based (fst_subtotal_info_ptr_parm); dcl fst_subtotal_info_ptr_parm ptr parm; dcl fst_subtotals_ejection_in_progress_parm bit (1) aligned parm; dcl fst_subtotals_have_been_backed_up bit (1) aligned; dcl fst_total_lines_used fixed bin; %skip(1); /* Walk through the subtotals level by level. Check the watch columns to see if any at the current level have changed. If any have, then back up the subtotals if they haven't been backed up already. Generate subtotals whose watch columns have changed, returning to caller if they don't fit. Set our number of lines used parm and return to caller. */ %skip(1); fst_code_parm = 0; fst_number_of_lines_used_parm = 0; fst_total_lines_used = 0; fst_subtotals_have_been_backed_up = OFF; %skip(1); do fst_subtotal_info.current_level = 1 to fst_subtotal_info.highest_level; call check_for_subtotal_break (fst_subtotal_info_ptr_parm, fst_subtotal_columns_info_ptr_parm, fst_subtotal_info.current_level, fst_some_column_changed); if fst_some_column_changed then do; if ^fst_subtotals_have_been_backed_up then call make_backup_of_subtotals; fst_subtotals_have_been_backed_up = ON; call generate_subtotals (fst_subtotal_info.current_level, fst_number_of_lines_used, fst_code_parm); if fst_code_parm ^= 0 then return; fst_total_lines_used = fst_total_lines_used + fst_number_of_lines_used; end; end; %skip(1); fst_number_of_lines_used_parm = fst_total_lines_used; fst_subtotals_ejection_in_progress_parm = OFF; %skip(1); return; %page; generate_subtotals: proc ( gs_level_number_parm, /* input: current subtotal level number */ gs_number_of_lines_used_parm, /* output: number of lines used */ gs_code_parm /* output: success or failure */ ); %skip(1); dcl gs_code_parm fixed bin (35) parm; dcl gs_level_number_parm fixed bin; dcl gs_loop fixed bin; dcl gs_number_of_lines_used_parm fixed bin parm; %skip(3); /* Use the headers temp seg for temporary storage. Walk through all of the subtotals. For each one at the current level number that isn't being outlined, format the float dec (59) into character format. Then format the row. Walk through all of the subtotals again, and for each one at the current level, restore it's editing flag to what it used to be and zero any reset subtotals. */ %skip(1); headers_next_byte = format_report_info.headers_next_available_byte; fst_subtotals_ejection_in_progress_parm = ON; %skip(1); do gs_loop = 1 to fst_subtotal_info.number_of_columns_to_subtotal; if gs_level_number_parm = fst_subtotal_info.columns (gs_loop).level then do; column_ip = addr (fst_subtotal_columns_info.columns (input_columns_info.columns (fst_subtotal_info.columns (gs_loop).input_column).output_column)); if ^column_info.flags.outline then call format_total_or_subtotal_into_character_format ( fst_subtotal_info.columns.subtotal (gs_loop), fst_subtotal_info.columns.ioa_string (gs_loop)); end; end; %skip(1); call format_row (fst_caller_parm, fst_subtotal_columns_info_ptr_parm, row_value_template_ip, GENERATE_ONE_BLANK_LINE_TRAILER, status.current_line_on_page, status.remaining_lines_on_page, gs_number_of_lines_used_parm, gs_code_parm); %skip(1); if gs_code_parm = 0 then status.flags.detail_block_used_some_lines = ON; %page; do gs_loop = 1 to fst_subtotal_info.number_of_columns_to_subtotal; if gs_level_number_parm = fst_subtotal_info.columns (gs_loop).level then do; column_ip = addr (fst_subtotal_columns_info.columns (input_columns_info.columns ( fst_subtotal_info.columns (gs_loop).input_column).output_column)); column_info.flags.editing = column_info.flags.restore_editing; if ^column_info.flags.outline & fst_subtotal_info.columns (gs_loop).flags.reset then fst_subtotal_info.columns (gs_loop).subtotal = 0; end; end; %skip(1); return; %skip(1); end generate_subtotals; %page; make_backup_of_subtotals: proc; %skip(1); dcl mbos_loop fixed bin; %skip(3); /* Advance the current generation block in our circular table. Backup each subtotal. */ %skip(1); fst_subtotal_generation_info.current_generation_block = mod (fst_subtotal_generation_info.current_generation_block + 1, fst_subtotal_generation_info.maximum_number_of_generation_blocks); %skip(1); do mbos_loop = 1 to fst_subtotal_generation_info.number_of_subtotals; fst_subtotal_generation_info.generations (fst_subtotal_generation_info.current_generation_block).subtotals (mbos_loop) = fst_subtotal_info.columns (mbos_loop).subtotal; end; %skip(1); return; %skip(1); end make_backup_of_subtotals; %skip(1); end format_subtotals; %page; format_total_or_subtotal_into_character_format: proc ( ftosicf_subtotal_or_total_parm, /* input: the total or subtotal */ ftosicf_ioa_string_parm /* input: ioa_ string for editing */ ); %skip(1); dcl ftosicf_ioa_string_parm char (*) varying parm; dcl ftosicf_length_doesnt_matter fixed bin (21); dcl ftosicf_subtotal_or_total_parm float dec (59) parm; %skip(3); /* If the subtotal has an editing request then it's already been edited through it's parent column's editing request be the column_value request. Pick it up, or in the case of ones that don't have an editing request, edit them through ioa_ with the supplied string. Set the pointer and length to this result string, and stash the result string into the headers temp seg. Advance the next byte index, save the editing bit value, and turn on the editing bit for this column. */ %skip(1); if column_info.flags.editing then do; editing_string_rl = column_info.editing_string_length; editing_string_rp = column_info.editing_string_ptr; input_string = editing_string_result; call evaluate_active_string (input_string, output_string); end; else call ioa_$rsnnl (ftosicf_ioa_string_parm, output_string, ftosicf_length_doesnt_matter, ftosicf_subtotal_or_total_parm); %skip(1); column_info.editing_string_result_length = length (output_string); column_info.editing_string_result_ptr = addr (headers_temp_seg_as_an_array (headers_next_byte)); substr (headers_temp_seg, headers_next_byte, column_info.editing_string_result_length) = output_string; headers_next_byte = headers_next_byte + column_info.editing_string_result_length; column_info.flags.restore_editing = column_info.flags.editing; column_info.flags.editing = ON; %skip(1); return; %skip(1); end format_total_or_subtotal_into_character_format; %page; format_totals: proc ( ft_total_info_ptr_parm, /* input: ptr to total_info structure */ ft_total_columns_info_ptr_parm, /* input: ptr to total_columns_info structure */ ft_caller_parm, /* input: "row total" or "row count" */ ft_number_of_lines_used_parm, /* output: number of lines used */ ft_totals_ejection_in_progress_parm, /* output: on when ejection starts, off after ejection complete */ ft_code_parm /* output: success or failure */ ); %skip(1); dcl ft_caller_parm char (*) varying parm; dcl ft_code_parm fixed bin (35) parm; dcl ft_loop fixed bin; dcl ft_number_of_lines_used_parm fixed bin parm; dcl 1 ft_total_columns_info like total_columns_info based (ft_total_columns_info_ptr_parm); dcl ft_total_columns_info_ptr_parm ptr parm; dcl 1 ft_total_info like total_info based (ft_total_info_ptr_parm); dcl ft_total_info_ptr_parm ptr parm; dcl ft_totals_ejection_in_progress_parm bit (1) aligned parm; %skip(3); /* Use the headers temp segment for temporary storage. For each total reach into the total_info array picking up the index to it's input column, which gives us the index into the input_columns_info array to pick up the index for the total_columns_info output column. Set the prefix to "=", turn off the outline bit, and format the total into character format. Then format the row and restore the editing bit for the columns. */ %skip(1); ft_code_parm = 0; ft_number_of_lines_used_parm = 0; ft_totals_ejection_in_progress_parm = ON; %skip(1); headers_next_byte = format_report_info.headers_next_available_byte; %skip(1); do ft_loop = 1 to ft_total_info.number_of_columns_to_total; column_ip = addr (ft_total_columns_info.columns (input_columns_info.columns.output_column (ft_total_info.columns.input_column (ft_loop)))); column_info.prefix_character = "="; column_info.flags.outline = OFF; call format_total_or_subtotal_into_character_format ( ft_total_info.columns.total (ft_loop), ft_total_info.columns.ioa_string (ft_loop)); end; %skip(1); call format_row (ft_caller_parm, ft_total_columns_info_ptr_parm, row_value_template_ip, GENERATE_ZERO_BLANK_LINES_TRAILER, status.current_line_on_page, status.remaining_lines_on_page, ft_number_of_lines_used_parm, ft_code_parm); %page; if ft_code_parm = 0 then status.flags.detail_block_used_some_lines = ON; %skip(1); do ft_loop = 1 to ft_total_columns_info.number_of_columns; ft_total_columns_info.columns (ft_loop).flags.editing = ft_total_columns_info.columns (ft_loop).flags.restore_editing; end; %skip(1); ft_totals_ejection_in_progress_parm = OFF; %skip(1); return; %skip(1); end format_totals; %page; gather_counts: proc; %skip(1); dcl gc_loop fixed bin; %skip(3); /* If the row hasn't been processed before then add one to the count. */ %skip(1); if status.flags.row_has_been_processed_before then return; %skip(1); do gc_loop = 1 to count_info.number_of_columns_to_total; count_info.columns (gc_loop).total = count_info.columns (gc_loop).total + 1; end; %skip(1); return; %skip(1); end gather_counts; %page; gather_subcounts: proc; %skip(1); dcl gs_loop fixed bin; %skip(3); /* Add one to the subcount. */ %skip(1); do gs_loop = 1 to subcount_info.number_of_columns_to_subtotal; subcount_info.columns.subtotal (gs_loop) = subcount_info.columns.subtotal (gs_loop) + 1; end; %skip(1); return; %skip(1); end gather_subcounts; %page; gather_subtotals: proc; %skip(1); dcl gs_loop fixed bin; %skip(3); /* Add in the value of the current column to the subtotal. */ %skip(1); do gs_loop = 1 to subtotal_info.number_of_columns_to_subtotal; subtotal_info.columns (gs_loop).subtotal = subtotal_info.columns (gs_loop).subtotal + float (substr (current_row_value, table_info.columns.column_index (subtotal_info.columns.input_column (gs_loop)), table_info.columns.column_length (subtotal_info.columns.input_column (gs_loop)))); end; %skip(1); return; %skip(1); end gather_subtotals; %page; gather_totals: proc; %skip(1); dcl gt_loop fixed bin; %skip(3); /* If the row hasn't been processed before then add the current column's value into the total. */ %skip(1); if status.flags.row_has_been_processed_before then return; %skip(1); do gt_loop = 1 to total_info.number_of_columns_to_total; total_info.columns (gt_loop).total = total_info.columns (gt_loop).total + float (substr (current_row_value, table_info.columns.column_index (total_info.columns.input_column (gt_loop)), table_info.columns.column_length (total_info.columns.input_column (gt_loop)))); end; %skip(1); return; %skip(1); end gather_totals; %page; housekeeping: proc; %skip(3); /* Move everything we need into automatic variables. */ %skip(1); sci_ptr = lcb.subsystem_control_info_ptr; maximum_segment_size = sys_info$max_seg_size * 4; %skip(1); report_cip = lcb.report_control_info_ptr; work_area_ptr = report_control_info.report_work_area_ptr; temp_seg_ptr = report_control_info.report_temp_seg_ptr; %skip(1); format_report_ip = report_control_info.format_report_info_ptr; table_ip = format_report_info.table_info_ptr; row_segs_ip = table_info.row_segs_info_ptr; %skip(1); input_columns_ip = format_report_info.input_columns_info_ptr; input_columns_op = format_report_info.input_columns_order_ptr; output_columns_ip = format_report_info.output_columns_info_ptr; %skip(1); input_string_ptr = report_control_info.input_string_temp_seg_ptr; input_string_length = maximum_segment_size - 4; input_string = ""; input_string_non_varying_ptr = addrel (input_string_ptr, 1); input_string_non_varying_length = 0; %skip(1); output_string_ptr = report_control_info.output_string_temp_seg_ptr; output_string_length = maximum_segment_size - 4; output_string = ""; output_string_non_varying_ptr = addrel (output_string_ptr, 1); output_string_non_varying_length = output_string_length; %skip(1); editing_strings_tsp = report_control_info.editing_strings_temp_seg_ptr; headers_tsp = report_control_info.headers_temp_seg_ptr; %skip(1); group_ip = format_report_info.group_info_ptr; outline_ip = format_report_info.outline_info_ptr; page_break_ip = format_report_info.page_break_info_ptr; %skip(1); if format_report_info.flags.subtotal_is_defined then do; subtotal_ip = format_report_info.subtotal_info_ptr; subtotal_columns_ip = subtotal_info.columns_info_ptr; subtotal_generation_ip = subtotal_info.subtotal_generation_info_ptr; end; %page; if format_report_info.flags.subcount_is_defined then do; subcount_ip = format_report_info.subcount_info_ptr; subcount_columns_ip = subcount_info.columns_info_ptr; subcount_generation_ip = subcount_info.subtotal_generation_info_ptr; end; %skip(1); if format_report_info.flags.total_is_defined then do; total_ip = format_report_info.total_info_ptr; total_columns_ip = total_info.columns_info_ptr; end; %skip(1); if format_report_info.flags.count_is_defined then do; count_ip = format_report_info.count_info_ptr; count_columns_ip = count_info.columns_info_ptr; end; %skip(1); format_document_options_ptr = format_report_info.format_document_op; %skip(1); paginated_report = report_control_info.report_is_paginated; page_ip = format_report_info.copy_of_page_info_ptr; page_info = format_report_info.page_info_ptr -> page_info; page_info.page_overstrike_info_ptr = null (); page_overstrike_ip = format_report_info.overstrike_info_ptr; %skip(1); formatted_page_ip = format_report_info.formatted_page_info_ptr; row_value_template_ip = format_report_info.row_value_template_info_ptr; template_length = page_info.width; generic_template_length = template_length; generic_tp = format_report_info.generic_template_ptr; %skip(1); template_map_number_of_bits = page_info.length; template_mp = format_report_info.template_map_ptr; %skip(1); truncation_indicator_length = length (format_report_info.truncation_indicator); status_pointer = format_report_info.status_ptr; %skip(1); code = 0; %skip(1); return; %skip(1); end housekeeping; %page; make_ptr: proc (mp_row_number_parm) returns (ptr); %skip(1); dcl mp_row_number_parm fixed bin (35) parm; dcl mp_segment_ptr_index fixed bin (21); dcl mp_row_ptr_index fixed bin (21); %skip(3); /* Make an index for the segment that the row pointer lives in. Make an index for the row pointer within the segment. Make a pointer to the segment. Return the pointer for the row. */ %skip(1); mp_segment_ptr_index = divide (mp_row_number_parm, row_segs_info.max_number_of_ptrs_per_seg, 21); if mod (mp_row_number_parm, row_segs_info.max_number_of_ptrs_per_seg) ^= 0 then mp_segment_ptr_index = mp_segment_ptr_index + 1; %skip(1); mp_row_ptr_index = mod (mp_row_number_parm, row_segs_info.max_number_of_ptrs_per_seg); if mp_row_ptr_index = 0 then mp_row_ptr_index = row_segs_info.max_number_of_ptrs_per_seg; %skip(1); row_ptrs_p = row_segs_info.seg_ptr (mp_segment_ptr_index); %skip(1); return (row_ptrs.row_value_ptr (mp_row_ptr_index)); %skip(1); end make_ptr; %page; make_rows_available: proc; %skip(3); dcl mra_code fixed bin (35); dcl mra_number_of_rows_needed fixed bin (35); dcl mra_number_of_rows_retrieved fixed bin (35); %skip(1); /* If the table is full, or we have enough rows to do this page then return. Have the rows loaded and time the operation, removing this time from our formatting time so the timers are accurate. Bump the number of rows retrieved and check for end of file on the data base setting appropriate flags. Shut things down if anything went wrong. */ %skip(1); if report_control_info.flags.table_is_full then return; %skip(1); mra_number_of_rows_needed = page_info.length + 1; if report_control_info.no_of_rows_retrieved - status.current_row_number > mra_number_of_rows_needed then return; %skip(1); time1 = vclock; call linus_table$load_rows (lcb_ptr, mra_number_of_rows_needed, mra_number_of_rows_retrieved, 1, mra_code); time2 = vclock; report_control_info.table_loading_time = report_control_info.table_loading_time + (time2 - time1); report_control_info.report_formatting_time = report_control_info.report_formatting_time - (time2 - time1); %skip(1); if mra_number_of_rows_retrieved ^= 0 then report_control_info.no_of_rows_retrieved = report_control_info.no_of_rows_retrieved + mra_number_of_rows_retrieved; if mra_code ^= 0 then if mra_code = mrds_error_$tuple_not_found then do; report_control_info.flags.table_is_full = ON; report_control_info.flags.table_has_just_been_loaded = ON; if status.current_row_number = report_control_info.no_of_rows_retrieved then status.flags.last_row_of_report = ON; end; else call ssu_$abort_line (sci_ptr, mra_code, "While trying to retrieve ^d rows.", mra_number_of_rows_needed); else; %skip(1); return; %skip(1); end make_rows_available; %page; make_row_ptrs: proc; %skip(3); /* Make pointers to the previous, current and next rows. */ %skip(1); status.previous_row_ptr = status.current_row_ptr; %skip(1); status.current_row_ptr = status.next_row_ptr; if status.current_row_ptr = null () then status.current_row_ptr = make_ptr (status.current_row_number); %skip(1); if status.flags.last_row_of_report then status.next_row_ptr = null (); else status.next_row_ptr = make_ptr (status.current_row_number + 1); %skip(1); return; %skip(1); end make_row_ptrs; %page; save_copy_of_page: proc; %skip(3); dcl scop_code fixed bin (35); dcl scop_record_key char (256) varying; dcl scop_record_length fixed bin (21); dcl scop_record_number fixed bin (21); %skip(1); /* Use the page or buffer number as the key for the record. Save a copy of the formatted page. Append ".page_info" to the page number and save the page_info structure under that key. Append ".formatted_page_info" to the page number and save the formatted_page_info structure under that key. If the page contains overstrikes then append ".page_overstrike_info" to the page number and save the page_overstrike_info structure under that key. */ %skip(1); scop_record_number = report_control_info.no_of_formatted_pages; scop_record_key = ltrim (convert (scop_record_key, scop_record_number)); call iox_$seek_key (format_report_info.report_iocb_ptr, scop_record_key, scop_record_length, scop_code); if scop_code ^= error_table_$no_record then call ssu_$abort_line (sci_ptr, scop_code, "Logic error while trying to save a copy of page ^a.", scop_record_key); %skip(1); call iox_$write_record (format_report_info.report_iocb_ptr, page_info.page_ptr, page_info.total_characters, scop_code); if scop_code ^= 0 then call ssu_$abort_line (sci_ptr, scop_code, "Unable to save a copy of page ^d.", scop_record_key); %skip(1); scop_record_key = scop_record_key || ".page_info"; call iox_$seek_key (format_report_info.report_iocb_ptr, scop_record_key, scop_record_length, scop_code); if scop_code ^= error_table_$no_record then call ssu_$abort_line (sci_ptr, scop_code, "Logic error while trying to save a copy of page ^a.", scop_record_key); %skip(1); call iox_$write_record (format_report_info.report_iocb_ptr, page_ip, page_info.page_info_size * 4, scop_code); if scop_code ^= 0 then call ssu_$abort_line (sci_ptr, scop_code, "Unable to save a copy of page ^d.", scop_record_key); %page; scop_record_key = before (scop_record_key, ".") || ".formatted_page_info"; call iox_$seek_key (format_report_info.report_iocb_ptr, scop_record_key, scop_record_length, scop_code); if scop_code ^= error_table_$no_record then call ssu_$abort_line (sci_ptr, scop_code, "Logic error while trying to save a copy of page ^a.", scop_record_key); %skip(1); call iox_$write_record (format_report_info.report_iocb_ptr, formatted_page_ip, currentsize (formatted_page_info) * 4, scop_code); if scop_code ^= 0 then call ssu_$abort_line (sci_ptr, scop_code, "Unable to save a copy of page ^d.", scop_record_key); %skip(1); if page_info.page_overstrike_info_ptr = null () then return; %skip(1); scop_record_key = before (scop_record_key, ".") || ".page_overstrike_info"; call iox_$seek_key (format_report_info.report_iocb_ptr, scop_record_key, scop_record_length, scop_code); if scop_code ^= error_table_$no_record then call ssu_$abort_line (sci_ptr, scop_code, "Logic error while trying to save a copy of page ^a.", scop_record_key); %skip(1); call iox_$write_record (format_report_info.report_iocb_ptr, page_overstrike_ip, currentsize (page_overstrike_info) * 4, scop_code); if scop_code ^= 0 then call ssu_$abort_line (sci_ptr, scop_code, "Unable to save a copy of page ^d.", scop_record_key); %skip(1); return; %skip(1); end save_copy_of_page; %page; setup_for_a_page: proc; %skip(3); /* Set all of the info needed to begin a new page. */ %skip(1); page_ip = format_report_info.copy_of_page_info_ptr; page_info = format_report_info.page_info_ptr -> page_info; page_info.page_overstrike_info_ptr = null (); page_overstrike_ip = format_report_info.overstrike_info_ptr; %skip(1); formatted_page_info.page_header_length = 0; formatted_page_info.title_block_length = 0; formatted_page_info.page_footer_length = 0; formatted_page_info.number_of_detail_blocks = 0; unspec (formatted_page_info.detail_blocks) = OFF; %skip(1); template_map (*) = OFF; %skip(1); if format_report_info.number_of_formatted_rows = 0 then status.flags.first_row_of_report = ON; else status.flags.first_row_of_report = OFF; status.current_row_number = format_report_info.number_of_formatted_rows + 1; if report_control_info.flags.table_is_full & report_control_info.no_of_rows_retrieved = status.current_row_number then status.flags.last_row_of_report = ON; else status.flags.last_row_of_report = OFF; status.flags.first_row_on_page = ON; status.flags.page_overflow = OFF; status.flags.subtotals_ejection_in_progress = OFF; status.flags.totals_ejection_in_progress = OFF; status.flags.header_being_evaluated = OFF; status.flags.detail_block_used_some_lines = ON; %skip(1); status.total_number_of_rows_used = 0; if paginated_report then status.current_page_number = report_control_info.no_of_formatted_pages + 1; else status.current_page_number = 1; status.current_line_on_page = 1; status.remaining_lines_on_page = page_info.length; if status.current_row_number ^> status.highest_row_formatted then status.flags.row_has_been_processed_before = ON; else status.flags.row_has_been_processed_before = OFF; %skip(1); return; %skip(1); end setup_for_a_page; %page; sub_error_handler: proc; %skip(1); dcl seh_code fixed bin (35); %skip(3); /* Find the sub_error_info structure and if it wasn't format_document_ that signalled it then continue to signal. Set the ptr to the format_document_error structure and print the error message with added information to identify where in the report the error occured. */ %skip(1); condition_info_ptr = addr (local_condition_info); condition_info.version = condition_info_version_1; call find_condition_info_ (null (), condition_info_ptr, seh_code); if seh_code ^= 0 then call ssu_$abort_line (sci_ptr, seh_code); sub_error_info_ptr = condition_info.info_ptr; if sub_error_info.name ^= "format_document_" then do; call continue_to_signal_ (seh_code); return; end; %skip(1); format_document_error_ptr = sub_error_info.info_ptr; if status.flags.header_being_evaluated then call ssu_$print_message (sci_ptr, linus_error_$bad_report_format, "^/Page ^d, ^a (line ^d, ^a).^/^a^x""^a""", status.current_page_number, status.object_being_evaluated, status.current_header_line, HEADER_PARTS_LABELS (status.current_header_part), sub_error_info.header.info_string, format_document_error.text_line); else call ssu_$print_message (sci_ptr, linus_error_$bad_report_format, "^/Page ^d, ^a (row ^d, ^a column).^/^a^x""^a""", status.current_page_number, status.object_being_evaluated, status.current_row_number, table_info.columns.column_name (output_columns_info.columns.input_column (status.current_column_number)), sub_error_info.header.info_string, format_document_error.text_line); %skip(1); return; %skip(1); end sub_error_handler; %page; dcl BACKSPACE char (1) static int options (constant) init (""); dcl BACKSPACE_OR_VERTICAL_TAB_OR_HORIZONTAL_TAB_OR_NL char (4) static int options (constant) init ("  "); dcl BAR char (1) static int options (constant) init ("|"); dcl BAR_BAR char (2) static int options (constant) init ("||"); dcl BLANK char (1) static int options (constant) init (" "); dcl FILL bit (1) unaligned static int options (constant) init ("1"b); dcl FORM_FEED char (1) static int options (constant) init (" "); dcl GENERATE_ONE_BLANK_LINE_TRAILER fixed bin static int options (constant) init (1); dcl GENERATE_ZERO_BLANK_LINES_TRAILER fixed bin static int options (constant) init (0); dcl GROUP_FOOTER char (16) varying static int options (constant) init ("group footer"); dcl GROUP_HEADER char (16) varying static int options (constant) init ("group header"); dcl HEADER_PARTS_LABELS (3) char (11) varying static int options (constant) init ("left part", "center part", "right part"); dcl LEFT_BRACKET char (1) static int options (constant) init ("["); dcl LEFT_OR_RIGHT_BRACKET char (2) static int options (constant) init ("[]"); dcl LOOK_AHEAD bit (1) aligned static int options (constant) init ("1"b); dcl LOOK_BEHIND bit (1) aligned static int options (constant) init ("0"b); dcl NEWLINE char (1) static int options (constant) init (" "); dcl OFF bit (1) aligned int static options (constant) init ("0"b); dcl ON bit (1) aligned int static options (constant) init ("1"b); dcl PAGE_FOOTER char (16) varying static int options (constant) init ("page footer"); dcl PAGE_HEADER char (16) varying static int options (constant) init ("page header"); dcl PAGE_OVERFLOW_ERROR_CODE fixed bin (35) static int options (constant) init (1); dcl ROW_COUNT char (16) varying static int options (constant) init ("row count"); dcl ROW_FOOTER char (16) varying static int options (constant) init ("row footer"); dcl ROW_HEADER char (16) varying static int options (constant) init ("row header"); dcl ROW_SUBCOUNT char (16) varying static int options (constant) init ("row subcount"); dcl ROW_SUBTOTAL char (16) varying static int options (constant) init ("row subtotal"); dcl ROW_TITLES char (16) varying static int options (constant) init ("row titles"); dcl ROW_TOTAL char (16) varying static int options (constant) init ("row total"); dcl ROW_VALUE char (16) varying static int options (constant) init ("row value"); %page; dcl addr builtin; dcl addrel builtin; %skip(1); dcl before builtin; %skip(1); dcl code fixed bin (35); dcl copy builtin; dcl continue_to_signal_ entry (fixed bin(35)); dcl convert builtin; dcl currentsize builtin; %skip(1); dcl divide builtin; %skip(1); dcl eas_spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl error_table_$badcall fixed bin(35) ext static; dcl error_table_$no_record fixed bin(35) ext static; dcl error_table_$recoverable_error fixed bin(35) ext static; dcl error_table_$unbalanced_brackets fixed bin(35) ext static; %skip(1); dcl fc_spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl find_condition_info_ entry (ptr, ptr, fixed bin(35)); dcl first_time_through_the_detail_block_loop bit (1) aligned; dcl fixed builtin; dcl float builtin; dcl format_document_$string entry (char(*), char(*), fixed bin(21), ptr, fixed bin(35)); dcl fr_spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying; %skip(1); dcl index builtin; dcl input_string char (input_string_length) varying based (input_string_ptr); dcl input_string_length fixed bin (21); dcl input_string_ptr ptr; dcl input_string_non_varying char (input_string_non_varying_length) based (input_string_non_varying_ptr); dcl input_string_non_varying_length fixed bin (21); dcl input_string_non_varying_ptr ptr; dcl ioa_$rsnnl entry() options(variable); dcl iox_$write_record entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl iox_$seek_key entry (ptr, char(256) var, fixed bin(21), fixed bin(35)); %skip(1); dcl length builtin; dcl linus_error_$bad_report_format fixed bin(35) ext static; dcl linus_table$load_rows entry (ptr, fixed bin(35), fixed bin(35), fixed bin(35), fixed bin (35)); dcl 1 local_condition_info like condition_info; dcl ltrim builtin; %skip(1); dcl min builtin; dcl mod builtin; dcl mrds_error_$tuple_not_found fixed bin(35) ext static; %skip(1); dcl null builtin; %skip(1); dcl output_string char (output_string_length) varying based (output_string_ptr); dcl output_string_length fixed bin (21); dcl output_string_ptr ptr; dcl output_string_non_varying char (output_string_non_varying_length) based (output_string_non_varying_ptr); dcl output_string_non_varying_length fixed bin (21); dcl output_string_non_varying_ptr ptr; dcl 1 output_string_redefined based (output_string_ptr), 2 length_word fixed bin (35) aligned, 2 frobus char (output_string_non_varying_length) unaligned; %skip(1); dcl paginated_report bit (1) aligned; dcl pc_column_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; %skip(1); dcl rel builtin; dcl rtrim builtin; %skip(1); dcl search builtin; dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$evaluate_active_string entry (ptr, ptr, char(*), fixed bin, char(*) var, fixed bin(35)); dcl ssu_$print_message entry() options(variable); dcl sub_error_ condition; dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl temp_seg_ptr ptr; dcl time1 float bin (63); dcl time2 float bin (63); dcl translate builtin; dcl truncation_indicator_length fixed bin; %skip(1); dcl unspec builtin; %skip(1); dcl vclock builtin; %skip(1); dcl work_area area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; %page; %include arg_descriptor; %page; %include arg_list; %page; %include condition_info; %page; %include condition_info_header; %page; %include cp_active_string_types; %page; %include format_document_error; %page; %include format_document_options; %page; %include linus_lcb; %page; %include linus_options_extents; %page; %include linus_page_info; %page; %include linus_report_info; %page; %include linus_report_structures; %page; %include linus_table_info; %page; %include sub_error_info; %skip(3); end linus_fr_build_page;  linus_fr_delete_report.pl1 07/29/86 1051.7r w 07/29/86 0939.5 27288 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(1); /* This module is called by the the linus_display module to delete the environment set up by linus_fr_new_report. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_fr_delete_report: proc ( lcb_ptr_parm, /* input: ptr to the linus control block */ code_parm /* output: success or failure */ ); %skip(3); dcl code_parm fixed bin (35) parm; dcl lcb_ptr_parm ptr parm; %skip(3); lcb_ptr = lcb_ptr_parm; code_parm = 0; sci_ptr = lcb.subsystem_control_info_ptr; %skip(1); /* Truncate the work area. */ %skip(1); report_cip = lcb.report_control_info_ptr; work_area_ptr = report_control_info.report_work_area_ptr; call release_area_ (work_area_ptr); %skip(1); /* If we kept a copy of the original report while we were making it then delete it. */ %skip(1); if report_control_info.flags.permanent_report then do; format_report_ip = report_control_info.format_report_info_ptr; iocb_ptr = format_report_info.report_iocb_ptr; if iocb_ptr = null () then return; call iox_$close (iocb_ptr, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "While trying to close ^p.", iocb_ptr); call iox_$detach_iocb (iocb_ptr, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "While trying to detach ^p.", iocb_ptr); call iox_$destroy_iocb (iocb_ptr, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "While trying to destroy ^p.", iocb_ptr); call delete_$path (format_report_info.report_directory_name, format_report_info.report_entry_name, "100111"b, "display", code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "While trying to delete ^a in directory^/^a.", format_report_info.report_entry_name, format_report_info.report_directory_name); format_report_info.report_iocb_ptr = null (); code_parm = code; end; %skip(1); return; %page; dcl addr builtin; dcl code fixed bin (35); dcl delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35)); dcl fixed builtin; dcl iocb_ptr ptr; dcl iox_$close entry (ptr, fixed bin(35)); dcl iox_$destroy_iocb entry (ptr, fixed bin(35)); dcl iox_$detach_iocb entry (ptr, fixed bin(35)); dcl null builtin; dcl rel builtin; dcl release_area_ entry (ptr); dcl sci_ptr ptr; dcl ssu_$print_message entry() options(variable); dcl sys_info$max_seg_size fixed bin(35) ext static; dcl work_area_ptr ptr; %page; %include linus_options_extents; %page; %include linus_lcb; %page; %include linus_report_info; %page; %include linus_report_structures; %skip(3); end linus_fr_delete_report;  linus_fr_get_page.pl1 07/29/86 1051.7r w 07/29/86 0939.5 43776 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(1); /* This module is called to get a page. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_fr_get_page: proc ( lcb_ptr_parm, /* input: ptr to linus control block */ page_number_parm, /* input: desired page */ page_ip_parm, /* output: ptr to page_info */ code_parm /* output: success or failure */ ); %skip(3); dcl code_parm fixed bin (35) parm; dcl lcb_ptr_parm ptr parm; dcl page_number_parm fixed bin (21) parm; dcl page_ip_parm ptr parm; %skip(3); lcb_ptr = lcb_ptr_parm; code_parm = 0; page_ip_parm = null (); %skip(1); /* Move the pointers for the structures we will need. */ %skip(1); report_cip = lcb.report_control_info_ptr; format_report_ip = report_control_info.format_report_info_ptr; iocb_ptr = format_report_info.report_iocb_ptr; %skip(1); /* Get set to read in the page. */ %skip(1); record_key = ltrim (convert (record_key, page_number_parm)); call iox_$seek_key (iocb_ptr, record_key, record_length, code_parm); if code_parm ^= 0 then return; %skip(1); /* It has it's own segment for it's exclusive use. */ %skip(1); buffer_ptr = report_control_info.report_temp_seg_ptr; buffer_length = sys_info$max_seg_size * 4; call iox_$read_record (iocb_ptr, buffer_ptr, buffer_length, record_length, code_parm); if code_parm ^= 0 then return; %skip(1); /* Get set to read in the page_info structure for the page. */ %skip(1); record_key = record_key || ".page_info"; call iox_$seek_key (iocb_ptr, record_key, record_length, code_parm); if code_parm ^= 0 then return; %skip(1); /* It will temporarily go into a report temp segment. */ %skip(1); buffer_ptr = report_control_info.input_string_temp_seg_ptr; call iox_$read_record (iocb_ptr, buffer_ptr, buffer_length, record_length, code_parm); if code_parm ^= 0 then return; %skip(1); /* Set the automatic pointer the structure is based on and set the pointer to where the page is stored. Adjust the buffer pointer and length so the next structure can share the same segment. */ %skip(1); page_ip = buffer_ptr; page_info.page_ptr = report_control_info.report_temp_seg_ptr; buffer_word_displacement = divide (record_length, 4, 21) + 1; if mod (buffer_word_displacement, 2) ^= 0 then buffer_word_displacement = buffer_word_displacement + 1; buffer_ptr = addrel (buffer_ptr, buffer_word_displacement); buffer_length = buffer_length - (buffer_word_displacement * 4); %skip(1); /* Get set to read in the formatted_page_info structure. */ %skip(1); record_key = before (record_key, ".") || ".formatted_page_info"; call iox_$seek_key (iocb_ptr, record_key, record_length, code_parm); if code_parm ^= 0 then return; %skip(1); /* Set the pointer for the structure and re-adjust buffer length. */ %skip(1); call iox_$read_record (iocb_ptr, buffer_ptr, buffer_length, record_length, code_parm); if code_parm ^= 0 then return; page_info.formatted_page_info_ptr = buffer_ptr; buffer_length = sys_info$max_seg_size * 4; %skip(1); /* If the page contains overstruck characters then read in that structure. Set the pointer to the structure. */ %skip(1); if page_info.page_overstrike_info_ptr ^= null () then do; buffer_ptr = report_control_info.output_string_temp_seg_ptr; record_key = before (record_key, ".") || ".page_overstrike_info"; call iox_$seek_key (iocb_ptr, record_key, record_length, code_parm); if code_parm ^= 0 then return; call iox_$read_record (iocb_ptr, buffer_ptr, buffer_length, record_length, code_parm); if code_parm ^= 0 then return; page_info.page_overstrike_info_ptr = buffer_ptr; end; %skip(1); page_ip_parm = page_ip; %skip(1); return; %page; dcl addr builtin; dcl addrel builtin; dcl before builtin; dcl buffer_length fixed bin (21); dcl buffer_ptr ptr; dcl buffer_word_displacement fixed bin (21); dcl convert builtin; dcl divide builtin; dcl fixed builtin; dcl iocb_ptr ptr; dcl iox_$seek_key entry (ptr, char(256) var, fixed bin(21), fixed bin(35)); dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl ltrim builtin; dcl mod builtin; dcl null builtin; dcl record_key char (256) varying; dcl record_length fixed bin (21); dcl rel builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %page; %include linus_options_extents; %page; %include linus_lcb; %page; %include linus_page_info; %page; %include linus_report_info; %page; %include linus_report_structures; %skip(3); end linus_fr_get_page;  linus_fr_new_report.pl1 07/29/86 1051.7r w 07/29/86 0939.6 690426 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(1); /* This module is called by the linus display request to set up the environment for a new report. Description and usage follows. Description: This module calls linus_options to get the values of the formatting options. It then uses the set of defined options to allocate all of the structures needed by linus_fr_build_page. The number of structures, their extents, etc. are all dictated by the definition of the format options. These structures which result from the translation provide a complete execution environment for linus_fr_build_page. Usage: Both parameters are passed to this program by it's caller, linus_display. It is called every time a new report is desired. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_fr_new_report: proc ( lcb_ptr_parm, /* input: points to the linus control block */ code_parm /* output: success or failure */ ); %skip(3); dcl code_parm fixed bin (35) parm; dcl lcb_ptr_parm ptr parm; %skip(3); /* Mainline Processing Overview. (1) Perform initialization. (2) Go through the process of getting format options from linus_options and allocating/filling in the execution structures based on what the options are defined as. The order is roughly setting up the input columns, the output columns, the page information, the subtotals and subcounts, the totals and counts, the report info, the headers/footers info, and the status info. Everything specific to one of these areas sometimes can't all be done in the specific subroutine because there are some things that are order dependent. */ %skip(1); lcb_ptr = lcb_ptr_parm; code_parm = 0; call housekeeping; call setup_input_column_info; call setup_output_column_info; call setup_page_info; call setup_subtotals_info; call setup_subcounts_info; call setup_totals_info; call setup_counts_info; call setup_report_info; call setup_header_info; call setup_status_info; %skip(1); report_control_info.format_report_info_ptr = format_report_ip; %skip(1); return; %page; get_option_value: proc ( gov_option_name_parm, /* input: name of option */ gov_option_identifier_parm, /* input: column identifier */ gov_option_value_parm /* output: option value */ ); %skip(1); dcl gov_code fixed bin (35); dcl gov_option_identifier_parm char (*) varying parm; dcl gov_option_name_parm char (*) varying parm; dcl gov_option_value_parm char (*) varying parm; %skip(3); call linus_options$get (lcb_ptr, gov_option_name_parm, gov_option_identifier_parm, normalized_option_name, gov_option_value_parm, gov_code); %skip(1); if gov_code ^= 0 then call ssu_$abort_line (sci_ptr, gov_code); %skip(1); return; %skip(1); end get_option_value; %page; housekeeping: proc; %skip(3); /* Make sure the table information is up to date. Set the pointers to our needed temp segments and areas. Allocate/initialize the format_report_info structure. */ %skip(1); sci_ptr = lcb.subsystem_control_info_ptr; %skip(1); call linus_table$info (lcb_ptr, table_ip, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); number_of_defined_columns = table_info.column_count; maximum_segment_size = sys_info$max_seg_size * 4; %skip(1); report_cip = lcb.report_control_info_ptr; work_area_ptr = report_control_info.report_work_area_ptr; temp_seg_ptr = report_control_info.report_temp_seg_ptr; editing_strings_tsp = report_control_info.editing_strings_temp_seg_ptr; editing_strings_next_byte = 1; headers_tsp = report_control_info.headers_temp_seg_ptr; headers_next_byte = 1; %skip(1); allocate format_report_info in (work_area) set (format_report_ip); unspec (format_report_info) = OFF; format_report_info.table_info_ptr = table_ip; %skip(1); code = 0; %skip(1); return; %skip(1); end housekeeping; %page; map_column_list: proc ( mcl_type_of_map_parm, /* input: two different types of map */ mcl_option_value_parm, /* input: the list of columns */ mcl_no_of_columns_found_parm /* output: how many were in the list */ ); %skip(1); dcl mcl_character_string_length fixed bin; dcl mcl_column_number fixed bin; dcl mcl_column_position fixed bin; dcl mcl_current_position fixed bin; dcl mcl_next_blank fixed bin; dcl mcl_no_of_columns_found fixed bin; dcl mcl_no_of_columns_found_parm fixed bin parm; dcl mcl_option_value_parm char (*) varying parm; dcl mcl_still_processing_columns bit (1) aligned; dcl mcl_type_of_map_parm bit (1) aligned parm; %skip(3); /* Parse the column list and fill in the column_map structure based on what we find. Set the output parm to reflect how many columns we've found. The column map has been normalized by linus_options to change all column numbers to names, place a single blank between each, and trim all leading and trailing whitespace. We supply two types of maps. The parameter mcl_type_of_map_parm when set to OUTPUT_MAP results in us preserving the order in which we find them. If it is set to INPUT_MAP the order of the selection expression is preserved. For example, if the user selected a, b, c, d, e, f, g, h and the list contained "e c" the map would look like: OUTPUT_MAP 1 2 3 4 5 6 7 8 1 1 0 0 0 0 0 0 PRESENT 5 3 0 0 0 0 0 0 POSITION INPUT_MAP 1 2 3 4 5 6 7 8 0 0 1 0 1 0 0 0 PRESENT 0 0 3 0 5 0 0 0 POSITION */ %skip(1); unspec (column_map) = OFF; mcl_option_value_parm = mcl_option_value_parm || BLANK; mcl_current_position = 1; mcl_character_string_length = length (mcl_option_value_parm); mcl_column_position = 1; mcl_no_of_columns_found = 0; mcl_still_processing_columns = ON; %page; do while (mcl_still_processing_columns); mcl_next_blank = index (substr (mcl_option_value_parm, mcl_current_position), BLANK); mcl_column_number = lookup_column_number (); if mcl_type_of_map_parm = OUTPUT_MAP then do; column_map.present (mcl_column_position) = ON; column_map.position (mcl_column_position) = mcl_column_number; mcl_column_position = mcl_column_position + 1; end; else do; column_map.present (mcl_column_number) = ON; column_map.position (mcl_column_number) = mcl_column_number; end; mcl_current_position = mcl_current_position + mcl_next_blank; mcl_no_of_columns_found = mcl_no_of_columns_found + 1; if mcl_current_position > mcl_character_string_length then mcl_still_processing_columns = OFF; end; %skip(1); mcl_no_of_columns_found_parm = mcl_no_of_columns_found; %skip(1); return; %page; lookup_column_number: proc () returns (fixed bin); %skip(1); dcl lcn_loop fixed bin; %skip(1); lcn_column_name = substr (mcl_option_value_parm, mcl_current_position, mcl_next_blank - 1); %skip(1); do lcn_loop = 1 to number_of_defined_columns; if lcn_column_name = table_info.columns.column_name (lcn_loop) then return (lcn_loop); end; %skip(1); call ssu_$abort_line (sci_ptr, linus_error_$bad_option_value, "^/Invalid column list ""^a"".", mcl_option_value_parm); %skip(1); return (0); %skip(1); end lookup_column_number; %skip(1); end map_column_list; %page; set_grouping_info: proc ( sgi_option_name_parm, /* input: name of group option */ sgi_grouping_is_defined_flag_parm, /* output: on if group is defined */ sgi_group_info_ptr_parm /* output: ptr to group_info structure if above is on */ ); %skip(1); dcl 1 sgi_group_info like group_info based (sgi_group_info_ptr); dcl sgi_group_info_ptr ptr; dcl sgi_group_info_ptr_parm ptr parm; dcl sgi_grouping_is_defined_flag_parm bit (1) parm; dcl sgi_loop fixed bin; dcl sgi_option_name_parm char (*) varying parm; %skip(3); /* Get the option value associated with the named option. Set the flag to reflect whether or not it's defined. Allocate/fill in the group_info structure if it's defined. */ %skip(1); sgi_group_info_ptr_parm = null (); call get_option_value (sgi_option_name_parm, "", option_value); if option_value = "" then do; sgi_grouping_is_defined_flag_parm = OFF; return; end; %skip(1); sgi_grouping_is_defined_flag_parm = ON; call map_column_list (OUTPUT_MAP, option_value, gi_init_number_of_columns_to_group); allocate sgi_group_info in (work_area) set (sgi_group_info_ptr); %skip(1); do sgi_loop = 1 to gi_init_number_of_columns_to_group; sgi_group_info.column_number (sgi_loop) = column_map.position (sgi_loop); end; sgi_group_info_ptr_parm = sgi_group_info_ptr; %skip(1); return; %skip(1); end set_grouping_info; %page; set_ioa_string_for_total_or_subtotal: proc ( sisfs_descriptor_ptr_parm, /* input: ptr to the descriptor */ sisfs_ioa_string_parm /* output: the proper ioa_ string to edit it through */ ); %skip(1); dcl sisfs_char_10 char (10) based; dcl sisfs_descriptor_ptr_parm ptr parm; dcl sisfs_ioa_string_parm char (*) varying parm; dcl sisfs_scale fixed bin; %skip(3); /* If the scale is greater than zero then set the ioa_ string to reflect the number of digits (i.e. fixed dec (5,2) would be "^.2f"). If scale is zero then set the ioa_ string to "^f" for float numbers and "^d" for all others. */ %skip(1); desc_ptr = sisfs_descriptor_ptr_parm; sisfs_scale = fixed (descriptor.size.scale, 17, 0); if sisfs_scale > 0 then sisfs_ioa_string_parm = "^." || ltrim (convert (sisfs_char_10, sisfs_scale)) || "f"; else if descriptor.type = 3 | descriptor.type = 4 | descriptor.type = 7 | descriptor.type = 8 | descriptor.type = 10 | descriptor.type = 12 | descriptor.type = 42 | descriptor.type = 44 | descriptor.type = 46 then sisfs_ioa_string_parm = "^f"; else sisfs_ioa_string_parm = "^d"; %skip(1); return; %skip(1); end set_ioa_string_for_total_or_subtotal; %page; setup_counts_info: proc; %skip(3); /* Get the value for the count option and get the subroutine to figure out if it's defined and allocate/initialize the structure if it is. Set it's pointer in format_report_info. */ %skip(1); call get_option_value (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_COUNT), "", option_value); call setup_totals_or_counts_info (ROW_COUNT, option_value, format_report_info.flags.count_is_defined, count_ip); if format_report_info.flags.count_is_defined then format_report_info.count_info_ptr = count_ip; else format_report_info.count_info_ptr = null (); %skip(1); return; %skip(1); end setup_counts_info; %page; setup_header_info: proc; %skip(1); dcl shi_additional_indent fixed bin; dcl shi_alignment_modes (3) fixed bin; dcl shi_delimiter char (1); dcl shi_inner_loop fixed bin; dcl shi_loop fixed bin; dcl shi_current_header_part fixed bin; dcl shi_current_inner_position fixed bin; dcl shi_current_position fixed bin; dcl shi_header_info_ptr ptr; dcl shi_header_length fixed bin; dcl shi_header_part_length fixed bin; dcl shi_n_parts_width (3) fixed bin; dcl shi_next_newline_position fixed bin; dcl shi_number_of_lines_found fixed bin; dcl shi_number_of_parts_found fixed bin; dcl shi_second_delimiter_position fixed bin; dcl shi_starting_position fixed bin; dcl shi_still_counting bit (1) aligned; dcl shi_still_parsing bit (1) aligned; %skip(3); /* Get the header portion delimiter. Init maximum number of portions to three and set the widths for 1, 2, and 3 part headers. Make left, center and right portions alignment accordingly. Get the subroutine to figure out which headers/footers are defined and allocate/fill in the structures. Group headers and footers need grouping info set for them. The parsed versions of the character strings the headers/footers were set to are placed contiguosly in a temp segment, and the rest of the temp seg is used during the evaluation of each (in linus_fr_build_page). */ %skip(1); call get_option_value (OPTIONS.GENERAL_REPORT.NAME ( INDEX_FOR_DELIMITER), "", option_value); if option_value ^= "" then format_report_info.header_part_delimiter = substr (option_value, 1, 1); else format_report_info.header_part_delimiter = BLANK; shi_delimiter = format_report_info.header_part_delimiter; hi_init_maximum_number_of_parts = 3; shi_n_parts_width (1) = page_info.width - 1; shi_n_parts_width (2) = divide (shi_n_parts_width (1), 2, 17); shi_n_parts_width (3) = divide (shi_n_parts_width (1), 3, 17); shi_alignment_modes (1) = LEFT_ALIGNMENT; shi_alignment_modes (2) = CENTER_ALIGNMENT; shi_alignment_modes (3) = RIGHT_ALIGNMENT; %page; call define_header (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_PAGE_HEADER_VALUE), format_report_info.flags.page_header_is_defined, format_report_info.page_header_info_ptr); %skip(1); call define_header (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_PAGE_FOOTER_VALUE), format_report_info.flags.page_footer_is_defined, format_report_info.page_footer_info_ptr); %skip(1); call define_header (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_ROW_HEADER_VALUE), format_report_info.flags.row_header_is_defined, format_report_info.row_header_info_ptr); %skip(1); call define_header (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_ROW_FOOTER_VALUE), format_report_info.flags.row_footer_is_defined, format_report_info.row_footer_info_ptr); %skip(1); call define_header (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP_HEADER_VALUE), format_report_info.flags.group_header_is_defined, format_report_info.group_header_info_ptr); %skip(1); call define_header (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP_FOOTER_VALUE), format_report_info.flags.group_footer_is_defined, format_report_info.group_footer_info_ptr); %skip(1); call set_grouping_info (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP_HEADER_TRIGGER), format_report_info.flags.group_header_trigger_is_defined, format_report_info.group_header_trigger_info_ptr); %skip(1); call set_grouping_info (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP_FOOTER_TRIGGER), format_report_info.flags.group_footer_trigger_is_defined, format_report_info.group_footer_trigger_info_ptr); %skip(1); format_report_info.headers_next_available_byte = headers_next_byte; %skip(1); return; %page; define_header: proc ( dh_header_option_name_parm, /* input: name of header/footer option */ dh_header_is_defined_flag_parm, /* output: on if header is defined */ dh_header_info_ptr_parm /* output: points to header_info structure */ ); %skip(1); dcl dh_header_option_name_parm char (*) varying parm; dcl dh_header_is_defined_flag_parm bit (1) parm; dcl dh_header_info_ptr_parm ptr parm; %skip(3); /* Parse the header and set pointer and bit to reflect it's definition. */ %skip(1); dh_header_info_ptr_parm = null (); call get_option_value (dh_header_option_name_parm, "", option_value); if option_value = "" then do; dh_header_is_defined_flag_parm = OFF; return; end; %skip(1); call parse_header (option_value, shi_header_info_ptr); dh_header_is_defined_flag_parm = ON; dh_header_info_ptr_parm = shi_header_info_ptr; %skip(1); return; %skip(1); end define_header; %page; parse_header: proc ( ph_header_value_parm, /* input: the header to be parsed */ ph_header_info_ptr_parm /* output: ptr to the header info structure */ ); %skip(1); dcl ph_header_info_ptr_parm ptr parm; dcl ph_header_line_length fixed bin; dcl ph_header_value_parm char (*) varying parm; %skip(3); /* Make sure header ends in new line. Allocate header_info structure based on how many lines it is. Cleanup header and place it in temp seg. For each part within each line fill in the structure and redistribute page space. Set the starting position on the page and alignment for each part. */ %skip(1); ph_header_info_ptr_parm = null (); if substr (ph_header_value_parm, length (ph_header_value_parm), 1) ^= NL then ph_header_value_parm = ph_header_value_parm || NL; call allocate_header_info_structure; %skip(1); shi_current_position = 1; %skip(1); do shi_loop = 1 to shi_number_of_lines_found; call cleanup_and_save_header_line; shi_current_header_part = 1; shi_number_of_parts_found = 0; shi_current_inner_position = 1; shi_still_parsing = ON; do while (shi_still_parsing); call set_header_part_info; end; call correct_header_part_anomaly; do shi_inner_loop = 1 to hi_init_maximum_number_of_parts; call set_header_part_additional_info; end; headers_next_byte = headers_next_byte + ph_header_line_length; end; %skip(1); ph_header_info_ptr_parm = header_ip; %skip(1); return; %page; allocate_header_info_structure: proc; %skip(3); /* Allocate structure based on number of lines it is made up of. */ %skip(1); shi_number_of_lines_found = 0; shi_current_position = 1; shi_header_length = length (ph_header_value_parm); shi_still_counting = ON; %skip(1); do while (shi_still_counting); shi_next_newline_position = index (substr (ph_header_value_parm, shi_current_position), NL); shi_number_of_lines_found = shi_number_of_lines_found + 1; shi_current_position = shi_current_position + shi_next_newline_position; if shi_current_position > shi_header_length then shi_still_counting = OFF; end; %skip(1); hi_init_number_of_lines = shi_number_of_lines_found; allocate header_info in (work_area) set (header_ip); unspec (header_info.lines) = OFF; %skip(1); return; %skip(1); end allocate_header_info_structure; %page; cleanup_and_save_header_line: proc; %skip(3); /* Left, right, and center portion delimiters are optional. Place any missing ones. Save the cleaned up header line. */ %skip(1); shi_next_newline_position = index (substr (ph_header_value_parm, shi_current_position), NL); ph_header_line = substr (ph_header_value_parm, shi_current_position, shi_next_newline_position - 1); shi_current_position = shi_current_position + shi_next_newline_position; %skip(1); if length (ph_header_line) = 0 then ph_header_line = shi_delimiter || shi_delimiter; if substr (ph_header_line, 1, 1) ^= shi_delimiter then ph_header_line = shi_delimiter || ph_header_line; if substr (ph_header_line, length (ph_header_line), 1) ^= shi_delimiter then ph_header_line = ph_header_line || shi_delimiter; %skip(1); ph_header_line_length = length (ph_header_line); substr (headers_temp_seg, headers_next_byte, ph_header_line_length) = ph_header_line; %skip(1); return; %skip(1); end cleanup_and_save_header_line; %page; correct_header_part_anomaly: proc; %skip(1); dcl chpa_loop fixed bin; %skip(1); /* Parts of a header/footer which are zero length have their space assigned to the parts whose length is greater than zero. This creates an environment where all space on the page is available for use. For example, if only the center part of a header has a length greater than zero, the text is centered on the page but it has 100% of the page width available to use. There are two cases where this action is not desired, and this subroutine takes care of these two special cases (listed in the table below as the two special cases). NORMAL RE-DISTIBUTION ACTION 1. !!text!! 100%-centered 2. !text!text!text! 33%-left aligned, 33%-centered, 33%-right aligned 3. !text!!text! 50%-left aligned, 50%-right aligned 4. !text!!! 100%-left aligned 5. !!!text! 100%-right aligned SPECIAL CASE - NO RE-DISTRIBUTION ACTION 6. !text!text!! 33%-left aligned, 33%-centered, 33%-UNUSED 7. !!text!text! 33%-UNUSED, 33%-centered, 33%-right aligned Special case, #7 above, followed immediately by #6. */ %skip(1); if (header_info.lines (shi_loop).parts (1).flags.present & header_info.lines (shi_loop).parts (1).length = 0) & (header_info.lines (shi_loop).parts (2).flags.present & header_info.lines (shi_loop).parts (2).length > 0) & (header_info.lines (shi_loop).parts (3).flags.present & header_info.lines (shi_loop).parts (3).length > 0) then return; else if (header_info.lines (shi_loop).parts (3).flags.present & header_info.lines (shi_loop).parts (3).length = 0) & (header_info.lines (shi_loop).parts (1).flags.present & header_info.lines (shi_loop).parts (1).length > 0) & (header_info.lines (shi_loop).parts (2).flags.present & header_info.lines (shi_loop).parts (2).length > 0) then return; else; %skip(1); do chpa_loop = 1 to hi_init_maximum_number_of_parts; if header_info.lines (shi_loop).parts (chpa_loop).flags.present then if header_info.lines (shi_loop).parts (chpa_loop).length = 0 then do; header_info.lines (shi_loop).parts (chpa_loop).flags.present = OFF; shi_number_of_parts_found = shi_number_of_parts_found - 1; end; else; else; end; %skip(1); return; %skip(1); end correct_header_part_anomaly; %page; set_header_part_additional_info: proc; %skip(3); /* For each part that's present set it's width, starting position on the page, and alignment. */ %skip(1); if header_info.lines (shi_loop).parts (shi_inner_loop).flags.present then do; header_info.lines (shi_loop).parts (shi_inner_loop).width = shi_n_parts_width (shi_number_of_parts_found); if shi_number_of_parts_found = 1 then shi_starting_position = 1; else if shi_number_of_parts_found = 2 then if shi_inner_loop = 1 then shi_starting_position = 1; else shi_starting_position = shi_n_parts_width (2) + mod (shi_n_parts_width (1), 2) + 1; else if shi_inner_loop = 1 then shi_starting_position = 1; else if shi_inner_loop = 2 then do; shi_starting_position = shi_n_parts_width (3) + 1; shi_additional_indent = mod (shi_n_parts_width (1), 3); if shi_additional_indent = 2 then shi_additional_indent = 1; shi_starting_position = shi_starting_position + shi_additional_indent; end; else shi_starting_position = shi_n_parts_width (1) - shi_n_parts_width (3) + 1; header_info.lines (shi_loop).parts (shi_inner_loop).starting_position = shi_starting_position; header_info.lines (shi_loop).parts (shi_inner_loop).alignment = shi_alignment_modes (shi_inner_loop); end; %skip(1); return; %skip(1); end set_header_part_additional_info; %page; set_header_part_info: proc; %skip(3); /* Find the portion and it's length. Mark it present and whether it contains active requests. Set the index and length to it. Check to make sure the maximum number of header parts isn't exceeded. */ %skip(1); shi_second_delimiter_position = index (substr (ph_header_line, shi_current_inner_position + 1), shi_delimiter); shi_header_part_length = shi_second_delimiter_position - 1; shi_number_of_parts_found = shi_number_of_parts_found + 1; header_info.lines (shi_loop).parts (shi_current_header_part).flags.present = ON; %skip(1); if shi_header_part_length ^= 0 then if search (substr (ph_header_line, shi_current_inner_position + 1, shi_header_part_length), LEFT_OR_RIGHT_BRACKET) ^= 0 then header_info.lines (shi_loop).parts (shi_current_header_part).flags.active = ON; else; else; %skip(1); header_info.lines (shi_loop).parts (shi_current_header_part).index = headers_next_byte + shi_current_inner_position; header_info.lines (shi_loop).parts (shi_current_header_part).length = shi_header_part_length; %skip(1); shi_current_inner_position = shi_current_inner_position + shi_second_delimiter_position; if shi_current_inner_position >= ph_header_line_length then shi_still_parsing = OFF; else shi_current_header_part = shi_current_header_part + 1; if shi_current_header_part > hi_init_maximum_number_of_parts then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "^/A header or footer was found which contained more than ^d parts." || "^/The line in error was ^/^a", hi_init_maximum_number_of_parts, ph_header_line); %skip(1); return; %skip(1); end set_header_part_info; %skip(1); end parse_header; %skip(1); end setup_header_info; %page; setup_input_column_info: proc; %skip(1); dcl sici_hit bit (1) aligned; dcl sici_inner_loop fixed bin; dcl sici_loop fixed bin; %skip(3); /* Allocate and init the input_columns_info and input_columns_order structures. */ %skip(1); initialize_number_of_columns = number_of_defined_columns; allocate input_columns_info in (work_area) set (input_columns_ip); unspec (input_columns_info.columns) = OFF; format_report_info.input_columns_info_ptr = input_columns_ip; allocate input_columns_order in (work_area) set (input_columns_op); format_report_info.input_columns_order_ptr = input_columns_op; %skip(1); /* Set the width, alignment, folding, prefix character, editing, title, and data type for each column. Stash the editing string and the title in the editing strings temp segment. */ %skip(1); do sici_loop = 1 to number_of_defined_columns; option_identifier = ltrim (convert (option_identifier, sici_loop)); input_columns_info.columns (sici_loop).input_column = sici_loop; %skip(1); call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_WIDTH), option_identifier, option_value); input_columns_info.columns (sici_loop).width = convert (sici_loop, option_value); %skip(1); call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_ALIGNMENT), option_identifier, option_value); call set_alignment_and_decimal_position (sici_loop, option_value); %skip(1); call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_FOLDING), option_identifier, option_value); if option_value = "fill" then input_columns_info.columns (sici_loop).folding_is_fill = ON; else input_columns_info.columns (sici_loop).folding_is_fill = OFF; input_columns_info.columns (sici_loop).prefix_character = ""; %skip(1); call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_EDITING), option_identifier, option_value); if option_value = "" then input_columns_info.columns (sici_loop).editing = OFF; else do; format_report_info.flags.editing_is_defined = ON; input_columns_info.columns (sici_loop).editing = ON; input_columns_info.columns (sici_loop).editing_string_length = length (option_value); input_columns_info.columns (sici_loop).editing_string_ptr = addr (editing_strings_temp_seg_as_an_array (editing_strings_next_byte)); substr (editing_strings_temp_seg, editing_strings_next_byte, input_columns_info.columns (sici_loop).editing_string_length) = option_value; editing_strings_next_byte = editing_strings_next_byte + input_columns_info.columns (sici_loop).editing_string_length; end; %skip(1); call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_TITLE), option_identifier, option_value); if option_value = "" then option_value = BLANK; input_columns_info.columns (sici_loop).editing_string_result_length = length (option_value); input_columns_info.columns (sici_loop).editing_string_result_ptr = addr (editing_strings_temp_seg_as_an_array (editing_strings_next_byte)); substr (editing_strings_temp_seg, editing_strings_next_byte, input_columns_info.columns (sici_loop).editing_string_result_length) = option_value; editing_strings_next_byte = editing_strings_next_byte + input_columns_info.columns (sici_loop).editing_string_result_length; %skip(1); call set_linus_data_type (sici_loop); end; %skip(1); /* Set the next available byte in the editing strings temp seg. Allocate the column map structure. Map the column order list and set the input_columns_info and input_columns_order structures to reflect the order. Set the grouping info. */ %skip(1); format_report_info.editing_strings_next_available_byte = editing_strings_next_byte; column_map_number_of_columns = number_of_defined_columns; allocate column_map in (work_area) set (column_mp); %skip(1); call get_option_value (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_COLUMN_ORDER), "", option_value); call map_column_list (OUTPUT_MAP, option_value, no_of_columns_found); do sici_loop = 1 to number_of_defined_columns; input_columns_info.columns (sici_loop).order = column_map.position (sici_loop); input_columns_info.columns (sici_loop).input_column = sici_loop; input_columns_order (sici_loop) = column_map.position (sici_loop); end; %skip(1); call set_grouping_info (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP), format_report_info.flags.group_is_defined, format_report_info.group_info_ptr); if format_report_info.flags.group_is_defined then group_ip = format_report_info.group_info_ptr; else group_ip = null (); %page; /* Allocate/set the page_break_info structure. Any column requested as a page break candidate who is a member of the "group" columns has any columns more major in the group set also. */ %skip(1); call get_option_value (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_PAGE_BREAK), "", option_value); if option_value = "" then do; format_report_info.flags.page_break_is_defined = OFF; format_report_info.page_break_info_ptr = null (); end; else do; format_report_info.flags.page_break_is_defined = ON; call map_column_list (INPUT_MAP, option_value, no_of_columns_found); pbi_init_number_of_columns = input_columns_info.number_of_columns; allocate page_break_info in (work_area) set (page_break_ip); page_break_info.columns (*) = OFF; format_report_info.page_break_info_ptr = page_break_ip; do sici_loop = 1 to input_columns_info.number_of_columns; if column_map.present (sici_loop) then page_break_info.columns (sici_loop) = ON; end; if format_report_info.flags.group_is_defined then do; do sici_loop = 1 to input_columns_info.number_of_columns; sici_hit = OFF; do sici_inner_loop = group_info.number_of_columns_to_group to 1 by -1; if group_info.column_number (sici_inner_loop) = sici_loop & page_break_info.columns (group_info.column_number (sici_inner_loop)) then sici_hit = ON; if sici_hit then page_break_info.columns (group_info.column_number (sici_inner_loop)) = ON; end; end; end; end; %page; /* Allocate/set the outline_info structure. The columns named who are a member of the "group" of columns are treated separately from the columns who are not a member of the group. */ %skip(1); call get_option_value (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_OUTLINE), "", option_value); if option_value = "" then do; format_report_info.flags.outline_is_defined = OFF; format_report_info.outline_info_ptr = null (); end; else do; format_report_info.flags.outline_is_defined = ON; call map_column_list (INPUT_MAP, option_value, no_of_columns_found); if format_report_info.flags.group_is_defined then oi_init_maximum_number_of_grouping_columns = group_info.number_of_columns_to_group; else oi_init_maximum_number_of_grouping_columns = 0; oi_init_maximum_number_of_single_columns = input_columns_info.number_of_columns; allocate outline_info in (work_area) set (outline_ip); format_report_info.outline_info_ptr = outline_ip; outline_info.number_of_grouping_columns = 0; if format_report_info.flags.group_is_defined then do sici_loop = 1 to input_columns_info.number_of_columns; do sici_inner_loop = group_info.number_of_columns_to_group to 1 by -1; if group_info.column_number (sici_inner_loop) = sici_loop & column_map.present (group_info.column_number (sici_inner_loop)) then do; outline_info.number_of_grouping_columns = outline_info.number_of_grouping_columns + 1; outline_info.grouping_columns (outline_info.number_of_grouping_columns) = group_info.column_number (sici_inner_loop); column_map.present (group_info.column_number (sici_inner_loop)) = OFF; end; end; end; outline_info.number_of_single_columns = 0; if outline_info.number_of_grouping_columns ^= no_of_columns_found then do sici_loop = 1 to input_columns_info.number_of_columns; if column_map.present (sici_loop) then do; outline_info.number_of_single_columns = outline_info.number_of_single_columns + 1; outline_info.single_columns (outline_info.number_of_single_columns) = sici_loop; end; end; end; %skip(1); return; %skip(1); end setup_input_column_info; %page; setup_output_column_info: proc; %skip(1); dcl soci_inner_loop fixed bin; dcl soci_loop fixed bin; %skip(3); /* Find out which columns are excluded from the page. */ %skip(1); call get_option_value (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_EXCLUDE), "", option_value); if option_value ^= "" then do; format_report_info.flags.exclude_is_defined = ON; call map_column_list (INPUT_MAP, option_value, no_of_columns_found); initialize_number_of_columns = number_of_defined_columns - no_of_columns_found; end; else do; initialize_number_of_columns = number_of_defined_columns; unspec (column_map) = OFF; end; %skip(1); /* If all columns are excluded fill them in as all present for the case where it is a report consisting of totals/subtotals only. */ %skip(1); if initialize_number_of_columns = 0 then do; format_report_info.flags.row_value_is_defined = OFF; initialize_number_of_columns = number_of_defined_columns; unspec (column_map) = OFF; end; else format_report_info.flags.row_value_is_defined = ON; allocate output_columns_info in (work_area) set (output_columns_ip); format_report_info.output_columns_info_ptr = output_columns_ip; %page; /* Allocate/set the output_columns_order array. Assign input_columns_info for each column that isn't excluded into output_columns_info, and make each output_columns_info reflect it's input_columns_info (i.e. if the user re-ordered and excluded columns, the output_columns_info structure will reflect it.) */ %skip(1); output_columns_order_number_of_columns = output_columns_info.number_of_columns; allocate output_columns_order in (work_area) set (output_columns_op); soci_inner_loop = 1; %skip(1); do soci_loop = 1 to number_of_defined_columns; if ^column_map.present (input_columns_info.columns (soci_loop).order) then do; output_columns_order (soci_inner_loop) = input_columns_info.columns (soci_loop).order; soci_inner_loop = soci_inner_loop + 1; end; end; %skip(1); do soci_loop = 1 to output_columns_info.number_of_columns; output_columns_info.columns (soci_loop) = input_columns_info.columns (output_columns_order (soci_loop)); input_columns_info.columns (output_columns_order (soci_loop)).output_column = soci_loop; end; %skip(1); return; %skip(1); end setup_output_column_info; %page; setup_page_info: proc; %skip(1); dcl spi_current_detail_line fixed bin; dcl spi_current_position fixed bin; dcl spi_exceeds_max_seg_size bit (1) aligned; dcl spi_last_column_on_detail_line bit (1) aligned; dcl spi_loop fixed bin; dcl spi_separator_width fixed bin; %skip(3); /* Get the page length and width. A page length of zero means the report is unpaginated. If page length is zero then set the internal page length to a healthy buffer size. Unpaginated reports are buffered into chunks that are mostly treated just like a page, because it would be foolish to try to do the whole report in one chunk when there may be several million rows in the table. Allocate formatted_page_info structure. */ %skip(1); call get_option_value (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_PAGE_WIDTH), "", option_value); format_report_info.page_width = convert (spi_loop, option_value); if format_report_info.page_width = 0 then format_report_info.flags.unlimited_page_width = ON; else format_report_info.flags.unlimited_page_width = OFF; call get_option_value (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_PAGE_LENGTH), "", option_value); format_report_info.page_length = convert (spi_loop, option_value); if format_report_info.page_length = 0 then do; report_control_info.flags.report_is_paginated = OFF; format_report_info.flags.unlimited_page_length = ON; format_report_info.page_length = convert (format_report_info.page_length, OPTIONS.GENERAL_REPORT.VALUE (INDEX_FOR_PAGE_LENGTH)) * SAFETY_FACTOR; end; else do; report_control_info.flags.report_is_paginated = ON; format_report_info.flags.unlimited_page_length = OFF; end; fpi_init_maximum_number_of_detail_blocks = format_report_info.page_length; allocate formatted_page_info in (work_area) set (formatted_page_ip); format_report_info.formatted_page_info_ptr = formatted_page_ip; %skip(1); /* Get the definition of the title line. If page width is zero then calculate exactly what's needed; if it isn't zero then reduce the width of any column who exceeds page width to page width. */ %skip(1); call get_option_value (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_TITLE_LINE), "", option_value); if option_value = "on" then format_report_info.flags.title_block_is_defined = ON; else format_report_info.flags.title_block_is_defined = OFF; %skip(1); if format_report_info.page_width = 0 then do; spi_current_position = 1; do spi_loop = 1 to output_columns_info.number_of_columns; spi_current_position = spi_current_position + output_columns_info.columns (spi_loop).width; if spi_loop ^= output_columns_info.number_of_columns then do; option_identifier = ltrim (convert (option_identifier, output_columns_info.columns (spi_loop).input_column)); call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_SEPARATOR), option_identifier, option_value); spi_current_position = spi_current_position + length (option_value); end; else; end; format_report_info.page_width = spi_current_position - 1; end; else do spi_loop = 1 to output_columns_info.number_of_columns; if output_columns_info.columns (spi_loop).width > format_report_info.page_width then output_columns_info.columns (spi_loop).width = format_report_info.page_width; end; %skip(1); /* Add one to page width to accomodate the newline. If report isn't paginated then check to make sure that our chosen page length * page width doesn't exceed the maximum segment size. If it does reduce accordingly. */ %skip(1); format_report_info.page_width = format_report_info.page_width + 1; if format_report_info.flags.unlimited_page_length then do; spi_exceeds_max_seg_size = ON; do while (spi_exceeds_max_seg_size); if format_report_info.page_width * (format_report_info.page_length - 6) ^> maximum_segment_size then spi_exceeds_max_seg_size = OFF; else do; if format_report_info.page_length < 8 then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "The page width of ^d causes a single page to exceed the maximum segment size.", format_report_info.page_width); format_report_info.page_length = divide (format_report_info.page_length, 2, 17); if format_report_info.page_length < 7 then format_report_info.page_length = 7; else; end; end; end; %page; /* Allocate/set page_info structure. Make sure a single page doesn't exceed a segment for paginated reports. Allocate a second copy of the structure so linus_fr_build_page can adjust the length, width, and total_characters after formatting each page and then restore the original structure before beginning the next page. Allocate page_overstrike_info structure. */ %skip(1); allocate page_info in (work_area) set (page_ip); page_info.width = format_report_info.page_width; page_info.length = format_report_info.page_length - 6; page_info.total_characters = page_info.width * page_info.length; if format_report_info.flags.unlimited_page_length then if page_info.total_characters > maximum_segment_size then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "^/The page width of ^d and the page length of ^d cause a single page to exceed the maximum segment size.", format_report_info.page_width, format_report_info.page_length); else; else; page_info.page_info_size = size (page_info); page_info.page_ptr = report_control_info.report_temp_seg_ptr; page_info.formatted_page_info_ptr = format_report_info.formatted_page_info_ptr; format_report_info.page_info_ptr = page_ip; allocate page_info in (work_area) set (page_ip); page_info = format_report_info.page_info_ptr -> page_info; format_report_info.copy_of_page_info_ptr = page_ip; allocate page_overstrike_info in (work_area) set (page_overstrike_ip); format_report_info.overstrike_info_ptr = page_overstrike_ip; %skip(1); /* Allocate the generic_template (for headers and the like). Base template at the beginning of the temp seg and assign it initially the value of the generic template. */ %skip(1); generic_template_length = page_info.width; allocate generic_template in (work_area) set (generic_tp); generic_template = BLANK; substr (generic_template, generic_template_length, 1) = NL; format_report_info.generic_template_ptr = generic_tp; template_length = generic_template_length; template_ptr = temp_seg_ptr; template = generic_template; %page; /* Walk through the output columns. Set the number of detail lines a row value will take and do folding of columns which won't fit down to the next detail line(s). Create a template for each individual detail line and stash it away in the temp seg. Set the starting position on the page for each output column, and fill it's separator into the template. The last column of each detail line doesn't have a separator. */ %skip(1); spi_current_detail_line = 1; spi_current_position = 1; %skip(1); do spi_loop = 1 to output_columns_info.number_of_columns; option_identifier = ltrim (convert (option_identifier, output_columns_info.columns (spi_loop).input_column)); if spi_loop = output_columns_info.number_of_columns then spi_last_column_on_detail_line = ON; else spi_last_column_on_detail_line = OFF; %skip(1); output_columns_info.columns (spi_loop).starting_position = spi_current_position; output_columns_info.columns (spi_loop).output_line = spi_current_detail_line; spi_current_position = spi_current_position + output_columns_info.columns (spi_loop).width; %skip(1); call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_SEPARATOR), option_identifier, option_value); spi_separator_width = length (option_value); if spi_current_position + spi_separator_width > page_info.width then spi_last_column_on_detail_line = ON; %skip(1); if ^spi_last_column_on_detail_line then if spi_current_position + spi_separator_width + output_columns_info.columns (spi_loop + 1).width > page_info.width then spi_last_column_on_detail_line = ON; %skip(1); if ^spi_last_column_on_detail_line then do; substr (template, spi_current_position, spi_separator_width) = option_value; spi_current_position = spi_current_position + spi_separator_width; end; else if spi_loop ^= output_columns_info.number_of_columns then do; template_ptr = addrel (template_ptr, size (template)); template = generic_template; spi_current_detail_line = spi_current_detail_line + 1; spi_current_position = 1; end; else; end; %page; /* Initialize the number of templates, and allocate/set the row_value_template_info structure. Allocate the template_map structure (used to determine which lines on a page have already had a template laid down). */ %skip(1); ti_init_number_of_templates = spi_current_detail_line; ti_init_template_width = template_length; allocate row_value_template_info in (work_area) set (row_value_template_ip); format_report_info.row_value_template_info_ptr = row_value_template_ip; template_map_number_of_bits = page_info.length; allocate template_map in (work_area) set (template_mp); format_report_info.template_map_ptr = template_mp; template_ptr = temp_seg_ptr; do spi_loop = 1 to spi_current_detail_line; row_value_template_info.templates (spi_loop) = template; template_ptr = addrel (template_ptr, size (template)); end; %skip(1); /* If the title line is on then allocate/set the title_block_columns_info structure. Null the pointer to the title_block_info structure so that linus_fr_build_page will know it is the first time formatting the titles (it only formats the title block on page 1 and then places the resulting lines on the page for every one after page 1.) */ %skip(1); if format_report_info.flags.title_block_is_defined then do; initialize_number_of_columns = output_columns_info.number_of_columns; allocate title_block_columns_info in (work_area) set (title_block_columns_ip); title_block_columns_info = output_columns_info; format_report_info.title_block_columns_info_ptr = title_block_columns_ip; do spi_loop = 1 to initialize_number_of_columns; column_ip = addr (title_block_columns_info.columns (spi_loop)); column_info.flags.outline = OFF; column_info.flags.editing = ON; column_info.alignment = CENTER_ALIGNMENT; end; format_report_info.title_block_info_ptr = null (); end; %skip(1); return; %skip(1); end setup_page_info; %page; setup_report_info: proc; %skip(3); /* Set the truncation indicator. Allocate/set the format_document_options structure. */ %skip(1); call get_option_value (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_TRUNCATION), "", option_value); format_report_info.truncation_indicator = option_value; %skip(1); allocate format_document_options in (work_area) set (format_document_options_ptr); unspec (format_document_options) = OFF; format_document_options.version_number = format_document_version_2; format_document_options.switches.galley_sw = ON; format_document_options.switches.break_word_sw = ON; format_document_options.switches.max_line_length_sw = ON; format_document_options.switches.sub_err_sw = ON; call get_option_value (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_FORMAT_DOCUMENT_CONTROLS), "", option_value); if option_value = "off" then do; format_document_options.switches.literal_sw = ON; format_document_options.switches.dont_compress_sw = ON; end; call get_option_value (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_HYPHENATION), "", option_value); if option_value = "on" then format_document_options.switches.hyphenation_sw = ON; format_document_options.syllable_size = DEFAULT_SYLLABLE_SIZE; format_report_info.format_document_op = format_document_options_ptr; %skip(1); /* If it's a permanent report then setup the file which will contain a copy of each formatted page. */ %skip(1); if report_control_info.flags.permanent_report then do; switch_name = unique_chars_ ("0"b) || ".linus_report"; format_report_info.report_entry_name = unique_chars_ ("0"b); format_report_info.report_directory_name = report_control_info.temp_dir_name; call iox_$attach_name (switch_name, iocb_ptr, "vfile_ " || rtrim (format_report_info.report_directory_name) || ">" || rtrim (format_report_info.report_entry_name), null (), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to attach file ^a in dir ^a.", rtrim (format_report_info.report_directory_name), rtrim (format_report_info.report_entry_name)); call iox_$open (iocb_ptr, Direct_update, "0"b, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to open file ^a in dir ^a.", rtrim (format_report_info.report_directory_name), rtrim (format_report_info.report_entry_name)); format_report_info.report_iocb_ptr = iocb_ptr; end; %skip(1); return; %skip(1); end setup_report_info; %page; setup_status_info: proc; %skip(3); /* Allocate/set the status structure. This is the execution control structure that linus_fr_build_page lives and breathes by. */ %skip(1); allocate status in (work_area) set (status_pointer); unspec (status) = OFF; %skip(1); status.number_of_lines_needed_for_detail_block = 0; if ^format_report_info.flags.row_header_is_defined then status.number_of_lines_needed_for_row_header = 0; else do; header_ip = format_report_info.row_header_info_ptr; status.number_of_lines_needed_for_row_header = header_info.number_of_lines; status.number_of_lines_needed_for_detail_block = status.number_of_lines_needed_for_detail_block + status.number_of_lines_needed_for_row_header; end; if format_report_info.flags.row_value_is_defined then do; status.number_of_lines_needed_for_row_value = row_value_template_info.number_of_templates; status.number_of_lines_needed_for_detail_block = status.number_of_lines_needed_for_detail_block + status.number_of_lines_needed_for_row_value; end; if ^format_report_info.flags.row_footer_is_defined then status.number_of_lines_needed_for_row_footer = 0; else do; header_ip = format_report_info.row_footer_info_ptr; status.number_of_lines_needed_for_row_footer = header_info.number_of_lines; status.number_of_lines_needed_for_detail_block = status.number_of_lines_needed_for_detail_block + status.number_of_lines_needed_for_row_footer; end; %skip(1); if ^format_report_info.flags.page_footer_is_defined then status.number_of_lines_needed_for_page_footer = 0; else do; header_ip = format_report_info.page_footer_info_ptr; status.number_of_lines_needed_for_page_footer = header_info.number_of_lines; end; %skip(1); if ^format_report_info.flags.group_header_is_defined then status.number_of_lines_needed_for_group_header = 0; else do; header_ip = format_report_info.group_header_info_ptr; status.number_of_lines_needed_for_group_header = header_info.number_of_lines; end; %page; if ^format_report_info.flags.group_footer_is_defined then status.number_of_lines_needed_for_group_footer = 0; else do; header_ip = format_report_info.group_footer_info_ptr; status.number_of_lines_needed_for_group_footer = header_info.number_of_lines; end; %skip(1); status.current_row_ptr = null (); status.previous_row_ptr = null (); status.next_row_ptr = null (); status.last_row_number = 0; status.last_page_number = 0; status.current_pass_number = 1; status.flags.last_pass = ON; %skip(1); format_report_info.status_ptr = status_pointer; %skip(1); return; %skip(1); end setup_status_info; %page; setup_subcounts_info: proc; %skip(3); /* Allocate/set the subcount_info, subcount_generation_info, and subcount_columns_info structures if the subcount option is defined. */ %skip(1); call get_option_value (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_SUBCOUNT), "", option_value); call setup_subtotals_or_subcounts_info (ROW_SUBCOUNT, option_value, format_report_info.flags.subcount_is_defined, subcount_ip); if format_report_info.flags.subcount_is_defined then do; format_report_info.subcount_info_ptr = subcount_ip; subcount_generation_ip = subcount_info.subtotal_generation_info_ptr; subcount_columns_ip = subcount_info.columns_info_ptr; end; else format_report_info.subcount_info_ptr = null (); %skip(1); return; %skip(1); end setup_subcounts_info; %page; setup_subtotals_info: proc; %skip(3); /* Allocate/set the subtotal_info, subtotal_generation_info, and subtotal_columns_info structures if the subtotal option is defined. */ %skip(1); call get_option_value (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_SUBTOTAL), "", option_value); call setup_subtotals_or_subcounts_info (ROW_SUBTOTAL, option_value, format_report_info.flags.subtotal_is_defined, subtotal_ip); if format_report_info.flags.subtotal_is_defined then do; format_report_info.subtotal_info_ptr = subtotal_ip; subtotal_generation_ip = subtotal_info.subtotal_generation_info_ptr; subtotal_columns_ip = subtotal_info.columns_info_ptr; end; else format_report_info.subtotal_info_ptr = null (); %skip(1); return; %skip(1); end setup_subtotals_info; %page; setup_subtotals_or_subcounts_info: proc ( ssosi_subtotal_flag_parm, /* input: on for subtotals, off for subcounts */ ssosi_option_value_parm, /* input: the value for the option */ ssosi_defined_flag_parm, /* output: on if it is defined */ ssosi_subtotal_info_ptr_parm /* output: points to subtotal_info structure */ ); %skip(1); dcl ssosi_comma_position fixed bin; dcl ssosi_current_position fixed bin; dcl ssosi_current_inner_position fixed bin; dcl ssosi_defined_flag_parm bit (1) parm; dcl ssosi_inner_loop fixed bin; dcl ssosi_loop fixed bin; dcl ssosi_next_blank fixed bin; dcl ssosi_option_value_parm char (*) varying parm; dcl ssosi_still_counting_subtotals bit (1) aligned; dcl ssosi_subtotal_flag_parm bit (1) aligned parm; dcl 1 ssosi_subtotal_columns_info like subtotal_columns_info based (ssosi_subtotal_columns_info_ptr); dcl ssosi_subtotal_columns_info_ptr ptr; dcl 1 ssosi_subtotal_generation_info like subtotal_generation_info based (ssosi_subtotal_generation_info_ptr); dcl ssosi_subtotal_generation_info_ptr ptr; dcl 1 ssosi_subtotal_info like subtotal_info based (ssosi_subtotal_info_ptr_parm); dcl ssosi_subtotal_info_ptr_parm ptr parm; dcl ssosi_subtotal_list_length fixed bin; %skip(3); /* This subroutine works for subcounts and subtotals. See if it's defined. */ %skip(1); if ssosi_option_value_parm = "" then do; ssosi_defined_flag_parm = OFF; ssosi_subtotal_info_ptr_parm = null (); return; end; %skip(1); /* Great! First let's remove the subtotals/subcounts whose parents are excluded from the page and see if we still have any defined. */ %skip(1); ssosi_defined_flag_parm = ON; si_init_number_of_columns_to_subtotal = 0; ssosi_still_counting_subtotals = ON; ssosi_current_position = 1; ssosi_option_value_parm = ssosi_option_value_parm || BLANK; call remove_orphan_subtotals; if ssosi_option_value_parm = BLANK then do; ssosi_defined_flag_parm = OFF; ssosi_subtotal_info_ptr_parm = null (); return; end; ssosi_subtotal_list_length = length (ssosi_option_value_parm); %skip(1); /* We have some defined. Let's see how many. */ %skip(1); do while (ssosi_still_counting_subtotals); ssosi_next_blank = index (substr (ssosi_option_value_parm, ssosi_current_position), BLANK); if ssosi_next_blank ^= 0 then si_init_number_of_columns_to_subtotal = si_init_number_of_columns_to_subtotal + 1; else ssosi_still_counting_subtotals = OFF; if ssosi_still_counting_subtotals then ssosi_current_position = ssosi_current_position + ssosi_next_blank; if ssosi_current_position > ssosi_subtotal_list_length then ssosi_still_counting_subtotals = OFF; end; %skip(1); /* Allocate/set the subtotal_info structure. */ %skip(1); allocate ssosi_subtotal_info in (work_area) set (ssosi_subtotal_info_ptr_parm); ssosi_subtotal_info.current_level = 0; unspec (ssosi_subtotal_info.columns) = OFF; ssosi_subtotal_info.columns (*).subtotal = 0; %page; /* Allocate the subtotal_generation_info structure. This is a circular list used to place the value of each subtotal after it's been generated. During formatting when the removal of rows is necessary, the subtotals are restored back to their old values from this circular list. */ %skip(1); sgi_init_number_of_subtotals = si_init_number_of_columns_to_subtotal; sgi_init_number_of_generations = divide (page_info.length, 2, 17) + 1; allocate ssosi_subtotal_generation_info in (work_area) set (ssosi_subtotal_generation_info_ptr); ssosi_subtotal_info.subtotal_generation_info_ptr = ssosi_subtotal_generation_info_ptr; ssosi_subtotal_generation_info.current_generation_block = -1; %skip(1); /* Allocate/set the subtotal_map structure so we can figure out how many levels of them we have (several subtotals defined on the same column, who are generated when different column's values change.) For the subtotal_info structure set the input column and level for each column. Set the highest_level in the same structure. For subtotals there is a requirement that they must be numbers; this isn't true for subcounts. Set the ioa_ string to edit them through. If the "watch" column is a member of the group of columns then mark it. Set the reset flag accordingly. */ %skip(1); subtotal_map_init_number_of_columns = input_columns_info.number_of_columns; allocate subtotal_map in (work_area) set (subtotal_map_ptr); unspec (subtotal_map.columns) = OFF; ssosi_current_position = 1; ssosi_subtotal_info.highest_level = 0; %skip(1); do ssosi_loop = 1 to si_init_number_of_columns_to_subtotal; ssosi_current_inner_position = 1; ssosi_next_blank = index (substr (ssosi_option_value_parm, ssosi_current_position), BLANK); ssosi_option_value = substr (ssosi_option_value_parm, ssosi_current_position, ssosi_next_blank - 1); ssosi_comma_position = index (ssosi_option_value, COMMA); ssosi_column_name = substr (ssosi_option_value, 1, ssosi_comma_position - 1); ssosi_subtotal_info.columns (ssosi_loop).input_column = get_column_number (); subtotal_map.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).present = ON; subtotal_map.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).number = subtotal_map.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).number + 1; ssosi_subtotal_info.columns (ssosi_loop).level = subtotal_map.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).number; if ssosi_subtotal_info.columns (ssosi_loop).level > ssosi_subtotal_info.highest_level then ssosi_subtotal_info.highest_level = ssosi_subtotal_info.columns (ssosi_loop).level; if ssosi_subtotal_flag_parm then do; if input_columns_info.columns (ssosi_subtotal_info.columns .input_column (ssosi_loop)).linus_data_type = NUMERIC_DATA_TYPE | input_columns_info.columns (ssosi_subtotal_info.columns .input_column (ssosi_loop)).linus_data_type = DECIMAL_DATA_TYPE then; else call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "^/A subtotal was specified for the ^a column and it is not numeric.", table_info.columns.column_name (ssosi_subtotal_info.columns.input_column (ssosi_loop))); call set_ioa_string_for_total_or_subtotal ( addr (table_info.columns (ssosi_subtotal_info.columns.input_column (ssosi_loop)).column_data_type), ssosi_subtotal_info.columns.ioa_string (ssosi_loop)); end; else ssosi_subtotal_info.columns.ioa_string (ssosi_loop) = "^d"; ssosi_current_inner_position = ssosi_current_inner_position + ssosi_comma_position; ssosi_comma_position = index (substr (ssosi_option_value, ssosi_current_inner_position), COMMA); ssosi_column_name = substr (ssosi_option_value, ssosi_current_inner_position, ssosi_comma_position - 1); ssosi_subtotal_info.columns (ssosi_loop).watch_column = get_column_number (); if format_report_info.flags.group_is_defined then do ssosi_inner_loop = 1 to group_info.number_of_columns_to_group; if group_info.column_number (ssosi_inner_loop) = ssosi_subtotal_info.columns (ssosi_loop).watch_column then ssosi_subtotal_info.columns (ssosi_loop).flags.group_column = ON; end; ssosi_subtotal_info.columns (ssosi_loop).flags.reset = (substr (ssosi_option_value, ssosi_current_inner_position + ssosi_comma_position) = RESET); ssosi_current_position = ssosi_current_position + ssosi_next_blank; end; %skip(1); /* Allocate/set the subtotal_columns_info structure. Assign the values of the output_columns to them, and set the prefix of all to blank. Walk through the subtotal_columns_info structure setting the prefix of each one that is really a subtotal/subcount to "-", and set the alignment in the case of subcounts to right. */ %skip(1); initialize_number_of_columns = output_columns_info.number_of_columns; allocate ssosi_subtotal_columns_info in (work_area) set (ssosi_subtotal_columns_info_ptr); ssosi_subtotal_info.columns_info_ptr = ssosi_subtotal_columns_info_ptr; ssosi_subtotal_columns_info = output_columns_info; ssosi_subtotal_columns_info.columns (*).prefix_character = BLANK; %skip(1); do ssosi_loop = 1 to ssosi_subtotal_info.number_of_columns_to_subtotal; ssosi_subtotal_columns_info.columns (input_columns_info.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).output_column).prefix_character = "-"; if ^ssosi_subtotal_flag_parm then ssosi_subtotal_columns_info.columns (input_columns_info.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).output_column).alignment = RIGHT_ALIGNMENT; end; %skip(1); return; %page; get_column_number: proc () returns (fixed bin); %skip(1); dcl gcn_loop fixed bin; %skip(3); /* Get the column number for the supplied column name. These names have been verified in linus_options, so any name that isn't found indicates the parsing code in this module messed up somewhere. */ %skip(1); do gcn_loop = 1 to number_of_defined_columns; if ssosi_column_name = table_info.columns.column_name (gcn_loop) then return (gcn_loop); end; %skip(1); if ssosi_subtotal_flag_parm then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "The column name ""^a"" in the subtotal list ""^a"" isn't valid.", ssosi_column_name, ssosi_option_value_parm); else call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "The column name ""^a"" in the subcount list ""^a"" isn't valid.", ssosi_column_name, ssosi_option_value_parm); %skip(1); return (0); %skip(1); end get_column_number; %page; remove_orphan_subtotals: proc; %skip(1); dcl ros_column_number fixed bin; dcl ros_current_position fixed bin; dcl ros_next_blank fixed bin; dcl ros_next_comma fixed bin; dcl ros_still_eliminating_orphans bit (1) aligned; dcl ros_subtotal_list_length fixed bin; %skip(3); /* Walk through the list eliminating any subtotals whose parents have been excluded from the page. */ %skip(1); ssosi_option_value = ""; ros_subtotal_list_length = length (ssosi_option_value_parm); ros_current_position = 1; ros_still_eliminating_orphans = ON; %skip(1); do while (ros_still_eliminating_orphans); ros_next_blank = index (substr (ssosi_option_value_parm, ros_current_position), BLANK); ros_next_comma = index (substr (ssosi_option_value_parm, ros_current_position), COMMA); ssosi_column_name = substr (ssosi_option_value_parm, ros_current_position, ros_next_comma - 1); ros_column_number = get_column_number (); if input_columns_info.columns (ros_column_number).output_column ^= 0 then ssosi_option_value = ssosi_option_value || substr (ssosi_option_value_parm, ros_current_position, ros_next_blank); ros_current_position = ros_current_position + ros_next_blank; if ros_current_position > ros_subtotal_list_length then ros_still_eliminating_orphans = OFF; end; %skip(1); ssosi_option_value_parm = ssosi_option_value; %skip(1); return; %skip(1); end remove_orphan_subtotals; %skip(1); end setup_subtotals_or_subcounts_info; %page; setup_totals_info: proc; %skip(3); /* Get the subroutine to figure out if we have any defined. */ %skip(1); call get_option_value (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_TOTAL), "", option_value); call setup_totals_or_counts_info (ROW_TOTAL, option_value, format_report_info.flags.total_is_defined, total_ip); if format_report_info.flags.total_is_defined then format_report_info.total_info_ptr = total_ip; else format_report_info.total_info_ptr = null (); %skip(1); return; %skip(1); end setup_totals_info; %page; setup_totals_or_counts_info: proc ( stoci_total_flag_parm, /* input: on for totals, off for counts */ stoci_option_value_parm, /* input: the value for the option */ stoci_defined_flag_parm, /* output: on if it's defined */ stoci_total_info_ptr_parm /* output: points to total_info structure */ ); %skip(1); dcl stoci_defined_flag_parm bit (1) parm; dcl stoci_inner_loop fixed bin; dcl stoci_loop fixed bin; dcl stoci_option_value_parm char (*) varying parm; dcl 1 stoci_total_columns_info like total_columns_info based (stoci_total_columns_info_ptr); dcl stoci_total_columns_info_ptr ptr; dcl stoci_total_flag_parm bit (1) aligned parm; dcl 1 stoci_total_info like total_info based (stoci_total_info_ptr_parm); dcl stoci_total_info_ptr_parm ptr parm; %skip(3); /* See if we have any defined. */ %skip(1); if stoci_option_value_parm = "" then do; stoci_defined_flag_parm = OFF; stoci_total_info_ptr_parm = null (); return; end; %skip(1); /* Yes we do. Get a map and remove any totals whose parents are excluded from the page. Adjust our count accordingly. */ %skip(1); stoci_defined_flag_parm = ON; call map_column_list (INPUT_MAP, stoci_option_value_parm, ti_init_number_of_columns_to_total); do stoci_loop = 1 to number_of_defined_columns; if column_map.present (stoci_loop) then if input_columns_info.columns (stoci_loop).output_column = 0 then do; column_map.present (stoci_loop) = OFF; ti_init_number_of_columns_to_total = ti_init_number_of_columns_to_total - 1; end; else; else; end; %skip(1); /* There may not be any defined at this point. */ %skip(1); if ti_init_number_of_columns_to_total ^> 0 then do; stoci_defined_flag_parm = OFF; stoci_total_info_ptr_parm = null (); return; end; %skip(1); /* Looks like we still have some left. Allocate the total_info structure and zero all totals. */ %skip(1); allocate stoci_total_info in (work_area) set (stoci_total_info_ptr_parm); stoci_total_info.columns.total (*) = 0; stoci_inner_loop = 1; %skip(1); /* Walk through the column map setting the input column and ioa_ string. There is a requirement that totals be defined on columns that are numbers; no such requirement for counts. */ %skip(1); do stoci_loop = 1 to output_columns_info.number_of_columns; if column_map.present (output_columns_info.columns (stoci_loop).input_column) then do; stoci_total_info.columns.input_column (stoci_inner_loop) = output_columns_info.columns (stoci_loop).input_column; if stoci_total_flag_parm then do; if input_columns_info.columns (stoci_total_info.columns.input_column (stoci_inner_loop)) .linus_data_type = NUMERIC_DATA_TYPE | input_columns_info.columns (stoci_total_info.columns.input_column (stoci_inner_loop)) .linus_data_type = DECIMAL_DATA_TYPE then; else call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "^/A total was specified for the ^a column and it is not numeric.", table_info.columns.column_name (stoci_total_info.columns.input_column (stoci_inner_loop))); call set_ioa_string_for_total_or_subtotal ( addr (table_info.columns (stoci_total_info.columns.input_column (stoci_inner_loop)).column_data_type), stoci_total_info.columns.ioa_string (stoci_inner_loop)); end; else stoci_total_info.columns.ioa_string (stoci_inner_loop) = "^d"; stoci_inner_loop = stoci_inner_loop + 1; end; end; %page; /* Allocate the total_columns_info structure. Assign the output_columns_info to total_columns_info. Set outlining on for all and right alignment if we are playing with counts rather than totals. */ %skip(1); initialize_number_of_columns = output_columns_info.number_of_columns; allocate stoci_total_columns_info in (work_area) set (stoci_total_columns_info_ptr); stoci_total_info.columns_info_ptr = stoci_total_columns_info_ptr; stoci_total_columns_info = output_columns_info; stoci_total_columns_info.columns (*).flags.outline = ON; if ^stoci_total_flag_parm then stoci_total_columns_info.columns (*).alignment = RIGHT_ALIGNMENT; %skip(1); return; %skip(1); end setup_totals_or_counts_info; %page; set_alignment_and_decimal_position: proc ( saadp_column_number_parm, /* input: number of column */ saadp_option_value_parm /* input: value of option for column */ ); %skip(1); dcl saadp_claimed_digits char (7) varying; dcl saadp_column_number_parm parm; dcl saadp_option_value_parm char (*) varying parm; %skip(3); /* Set the alignment and in the case of decimal, the position within the display width where the decimal alignment should take place. */ %skip(1); if saadp_option_value_parm = "center" then input_columns_info.columns (saadp_column_number_parm).alignment = CENTER_ALIGNMENT; else if saadp_option_value_parm = "left" then input_columns_info.columns (saadp_column_number_parm) .alignment = LEFT_ALIGNMENT; else if saadp_option_value_parm = "right" then input_columns_info.columns (saadp_column_number_parm) .alignment = RIGHT_ALIGNMENT; else if saadp_option_value_parm = "both" then input_columns_info.columns (saadp_column_number_parm) .alignment = BOTH_ALIGNMENT; else do; input_columns_info.columns (saadp_column_number_parm) .alignment = DECIMAL_ALIGNMENT; saadp_claimed_digits = after (saadp_option_value_parm, BLANK); if verify (saadp_claimed_digits, DIGITS) ^= 0 then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "^/The decimal alignment position could not be converted to an integer. ""^a""", saadp_option_value_parm); input_columns_info.columns (saadp_column_number_parm).decimal_position = convert (saadp_column_number_parm, saadp_claimed_digits); if input_columns_info.columns (saadp_column_number_parm).decimal_position > input_columns_info.columns (saadp_column_number_parm).width then call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "^/The decimal alignment position ^d is larger than the column width ^d for column number ^d.", input_columns_info.columns (saadp_column_number_parm).decimal_position, input_columns_info.columns (saadp_column_number_parm).width, saadp_column_number_parm); end; %skip(1); return; %skip(1); end set_alignment_and_decimal_position; %page; set_linus_data_type: proc (sldt_column_number_parm); %skip(1); dcl sldt_column_number_parm fixed bin parm; dcl sldt_column_type fixed bin (6) unsigned unaligned; %skip(3); /* Simplify all of the possibilities into numeric, decimal, bit or character. */ %skip(1); desc_ptr = addr (table_info.columns.column_data_type (sldt_column_number_parm)); sldt_column_type = descriptor.type; %skip(1); if (sldt_column_type >= 1 & sldt_column_type <= 8) | (sldt_column_type = 33 | sldt_column_type = 34) then input_columns_info.columns (sldt_column_number_parm) .linus_data_type = NUMERIC_DATA_TYPE; else if (sldt_column_type >= 9 & sldt_column_type <= 12) | (sldt_column_type = 29 | sldt_column_type = 30) | (sldt_column_type = 35 | sldt_column_type = 36) | (sldt_column_type >= 38 & sldt_column_type <= 46) then input_columns_info.columns (sldt_column_number_parm) .linus_data_type = DECIMAL_DATA_TYPE; else if (sldt_column_type = 19 | sldt_column_type = 20) then input_columns_info.columns (sldt_column_number_parm) .linus_data_type = BIT_DATA_TYPE; else if (sldt_column_type = 21 | sldt_column_type = 22) then input_columns_info.columns (sldt_column_number_parm) .linus_data_type = CHAR_DATA_TYPE; else call ssu_$abort_line (sci_ptr, linus_error_$bad_report_setup, "^/The table information described an unsupported data type.^/The data type was ^d.", sldt_column_type); %skip(1); return; %skip(1); end set_linus_data_type; %page; dcl BLANK char (1) static int options (constant) init (" "); dcl COMMA char (1) static int options (constant) init (","); dcl DEFAULT_SYLLABLE_SIZE fixed bin static int options (constant) init (2); dcl DIGITS char (10) static int options (constant) init ("0123456789"); dcl INPUT_MAP bit (1) aligned static int options (constant) init ("1"b); dcl LEFT_OR_RIGHT_BRACKET char (2) internal static options (constant) init ("[]"); dcl NL char (1) internal static options (constant) init (" "); dcl OFF bit (1) aligned internal static options (constant) init ("0"b); dcl ON bit (1) aligned internal static options (constant) init ("1"b); dcl OUTPUT_MAP bit (1) aligned static int options (constant) init ("0"b); dcl RESET char (5) static int options (constant) init ("reset"); dcl ROW_COUNT bit (1) aligned static int options (constant) init ("0"b); dcl ROW_SUBCOUNT bit (1) aligned static int options (constant) init ("0"b); dcl ROW_SUBTOTAL bit (1) aligned static int options (constant) init ("1"b); dcl ROW_TOTAL bit (1) aligned static int options (constant) init ("1"b); dcl SAFETY_FACTOR fixed bin int static options (constant) init (4); %page; dcl addr builtin; dcl addrel builtin; dcl after builtin; %skip(1); dcl code fixed bin (35); dcl convert builtin; %skip(1); dcl divide builtin; %skip(1); dcl fixed builtin; %skip(1); dcl iocb_ptr ptr; dcl index builtin; dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)); dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)); %skip(1); dcl lcn_column_name char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying; dcl length builtin; dcl linus_error_$bad_option_value fixed bin(35) ext static; dcl linus_error_$bad_report_setup fixed bin(35) ext static; dcl linus_options$get entry (ptr, char(*) var, char(*) var, char(*) var, char(*) var, fixed bin(35)); dcl linus_table$info entry (ptr, ptr, fixed bin(35)); dcl ltrim builtin; %skip(1); dcl mod builtin; %skip(1); dcl no_of_columns_found fixed bin; dcl normalized_option_name char (97) varying; dcl null builtin; dcl number_of_defined_columns fixed bin; %skip(1); dcl option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying; dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl output_columns_order (output_columns_order_number_of_columns) fixed bin based (output_columns_op); dcl output_columns_order_number_of_columns fixed bin; dcl output_columns_op ptr; %skip(1); dcl ph_header_line char (MAXIMUM_OPTION_VALUE_LENGTH) varying; %skip(1); dcl rel builtin; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl search builtin; dcl size builtin; dcl ssosi_column_name char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying; dcl ssosi_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl ssu_$abort_line entry() options(variable); dcl 1 subtotal_map aligned based (subtotal_map_ptr), 2 number_of_columns fixed bin, 2 columns (subtotal_map_init_number_of_columns refer (subtotal_map.number_of_columns)), 3 present bit (1), 3 number fixed bin; dcl substr builtin; dcl subtotal_map_init_number_of_columns fixed bin; dcl subtotal_map_ptr ptr; dcl switch_name char (32); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl temp_seg_ptr ptr; %skip(1); dcl unique_chars_ entry (bit(*)) returns(char(15)); dcl unspec builtin; %skip(1); dcl verify builtin; %skip(1); dcl work_area area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; %page; %include arg_descriptor; %page; %include arg_list; %page; %include format_document_options; %page; %include iox_modes; %page; %include linus_lcb; %page; %include linus_format_options; %page; %include linus_names_and_values; %page; %include linus_options_extents; %page; %include linus_page_info; %page; %include linus_report_info; %page; %include linus_report_structures; %page; %include linus_table_control; %page; %include linus_table_info; %page; %include mdbm_descriptor; %skip(3); end linus_fr_new_report;  linus_input_query.pl1 07/29/86 1051.7r w 07/29/86 0939.6 123777 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus input_query request. Description and usage follows. Description: This request collects a user provided query and makes it available for linus data manipulation requests. Usage: input_query {-control_args} USAGE (1): "input_query" or "input_query -terminal_input" The query is prompted for from user_input. It is terminated when the user types "." on a line by itself, or types "\f" or "\q". "\f" means enter qedx. The control args -brief and -long control the prompt string "Query:". USAGE (2): "input_query -input_file pathname.lquery" or "input_query pathname.lquery" The query is read from the file named by pathname. The control arguments -force and -no_force can be provided with either usage. -no_force is the default, and means the user should be queried about replacing the existing linus query if there is one. Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_input_query: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(1); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(1); /* Mainline Processing Overview: (1) Set defaults and process the arguments. (2) Attach and open file if -input_file is used. (3) Prompt before replacing existing query if -force isn't used. (4) Initialize the query file. (5) Get the query from the file or user. (6) Enter qedx if user ended query with "\f". */ %skip(1); call initialize; %skip(1); if ^terminal_input then do; cleanup_signalled = OFF; on cleanup begin; cleanup_signalled = ON; call close_and_detach_input_file; end; call attach_and_open_input_file; end; %skip(1); if ^force then do; call prompt_user_for_replacing_query; if ^user_wants_the_query_replaced then return; end; %skip(1); call linus_query_mgr$initialize_query_file (lcb_ptr); %skip(1); if terminal_input then call get_query_from_user; else call get_query_from_file; %skip(1); if enter_the_editor then call linus_qedx_the_query (lcb_ptr, OLD_QUERY); %skip(1); return; %page; attach_and_open_input_file: proc; %skip(1); attached = OFF; opened = OFF; call expand_pathname_$add_suffix (input_file_pathname, "lquery", input_file_directory_name, input_file_entry_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to expand ^a.", rtrim (input_file_pathname)); switch_name = unique_chars_ ("0"b) || "linus.input_query"; %skip(1); call iox_$attach_name (switch_name, input_file_iocb_ptr, "vfile_ " || rtrim (input_file_directory_name) || ">" || rtrim (input_file_entry_name), null (), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to attach ^a in ^a.", input_file_entry_name, input_file_directory_name); else attached = ON; %skip(1); call iox_$open (input_file_iocb_ptr, Stream_input, "0"b, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to open ^a in ^a.", input_file_entry_name, input_file_directory_name); else opened = ON; %skip(1); return; %skip(1); end attach_and_open_input_file; %page; close_and_detach_input_file: proc; %skip(3); if opened then do; call iox_$close (input_file_iocb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to close ^a.", input_file_pathname); else call ssu_$abort_line (sci_ptr, code, "^/While trying to close ^a.", input_file_pathname); else opened = OFF; end; else; %skip(1); if attached then do; call iox_$detach_iocb (input_file_iocb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to detach ^p.", input_file_iocb_ptr); else call ssu_$abort_line (sci_ptr, code, "^/While trying to detach ^p.", input_file_iocb_ptr); else do; attached = OFF; call iox_$destroy_iocb (input_file_iocb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to destroy ^p.", input_file_iocb_ptr); else call ssu_$abort_line (sci_ptr, code, "^/While trying to destroy ^p.", input_file_iocb_ptr); else; end; end; %skip(1); return; %skip(1); end close_and_detach_input_file; %page; get_query_from_file: proc; %skip(3); still_writing_the_file = ON; %skip(1); do loop = 1 to LARGEST_LILA_LINE_NUMBER while (still_writing_the_file); call iox_$get_line (input_file_iocb_ptr, input_buffer_ptr, INPUT_BUFFER_LENGTH, number_of_characters_read, code); if code ^= 0 then if code ^= error_table_$end_of_info then call ssu_$abort_line (sci_ptr, code, "^/While reading a line from ^a in ^a.", input_file_entry_name, input_file_directory_name); else still_writing_the_file = OFF; else call write_query_line_to_file (number_of_characters_read, loop); end; %skip(1); call close_and_detach_input_file; %skip(1); return; %skip(3); end get_query_from_file; %page; get_query_from_user: proc; %skip(3); if ^brief then call ioa_ ("Query:"); still_collecting_lines = ON; %skip(1); do loop = 1 to LARGEST_LILA_LINE_NUMBER while (still_collecting_lines); there_is_a_line_to_write = ON; call iox_$get_line (iox_$user_input, input_buffer_ptr, INPUT_BUFFER_LENGTH, number_of_characters_read, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While reading a query line from the terminal."); if number_of_characters_read = 2 then if input_buffer_as_an_array (1) = "." then do; still_collecting_lines = OFF; there_is_a_line_to_write = OFF; end; else; else; if still_collecting_lines then if index (substr (input_buffer, 1, number_of_characters_read - 1), "\f") > 0 | index (substr (input_buffer, 1, number_of_characters_read - 1), "\q") > 0 then do; still_collecting_lines = OFF; if number_of_characters_read = 3 then do; if input_buffer_as_an_array (number_of_characters_read - 1) = "f" then enter_the_editor = ON; else enter_the_editor = OFF; there_is_a_line_to_write = OFF; end; else do; input_buffer_as_an_array (number_of_characters_read - 2) = NEWLINE; if input_buffer_as_an_array (number_of_characters_read - 1) = "f" then enter_the_editor = ON; else enter_the_editor = OFF; number_of_characters_read = number_of_characters_read - 2; end; end; else; else; if there_is_a_line_to_write then call write_query_line_to_file (number_of_characters_read, loop); end; %skip(1); return; %skip(3); end get_query_from_user; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); if lcb.db_index = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_db); %skip(1); force = OFF; terminal_input = ON; user_wants_the_query_replaced = OFF; enter_the_editor = OFF; brief = OFF; %skip(1); input_buffer_ptr = addr (input_buffer); %skip(1); call ssu_$arg_count (sci_ptr, number_of_args_supplied); if number_of_args_supplied = 0 then return; %skip(1); /* The first arg can be the pathname, let's see if it is. */ %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); if arg_length > 0 then if substr (arg, 1, 1) ^= "-" then do; terminal_input = OFF; input_file_pathname = arg; current_arg_number = 2; if current_arg_number > number_of_args_supplied then return; else; end; else current_arg_number = 1; else current_arg_number = 1; %page; still_processing_args = ON; %skip(1); do while (still_processing_args); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); current_arg_number = current_arg_number + 1; if arg = "-force" | arg = "-fc" then force = ON; else if arg = "-no_force" | arg = "-nfc" then force = OFF; else if arg = "-terminal_input" | arg = "-ti" then terminal_input = ON; else if arg = "-input_file" | arg = "-if" then do; if current_arg_number > number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/When -input_file is used it must be followed by a pathname."); else call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); input_file_pathname = arg; terminal_input = OFF; current_arg_number = current_arg_number + 1; end; else if arg = "-brief" | arg = "-bf" then brief = ON; else if arg = "-long" | arg = "-lg" then brief = OFF; else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^/Unrecognized control argument ^a.", arg); if current_arg_number > number_of_args_supplied then still_processing_args = OFF; end; %skip(1); return; %skip(1); end initialize; %page; prompt_user_for_replacing_query: proc; %skip(3); if lcb.liocb_ptr = null () then user_wants_the_query_replaced = ON; else if lcb.lila_count ^> 0 then user_wants_the_query_replaced = ON; else call linus_query$yes_no (lcb_ptr, user_wants_the_query_replaced, DO_YOU_WANT_TO_REPLACE_THE_EXISTING_QUERY); %skip(1); return; %skip(1); end prompt_user_for_replacing_query; %page; write_query_line_to_file: proc ( wqltf_number_of_chars_to_write_parm, /* input: # of chars to write */ wqltf_record_key_parm /* input: key for record */ ); %skip(3); dcl wqltf_number_of_chars_to_write_parm fixed bin (21) parm; dcl wqltf_record_key_parm fixed bin parm; dcl wqltf_record char (wqltf_number_of_chars_to_write_parm) based (input_buffer_ptr); %skip(1); call linus_query_mgr$write_line (lcb_ptr, wqltf_record_key_parm, wqltf_record, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to write the record ^/^a", wqltf_record); else; %skip(1); return; %skip(1); end write_query_line_to_file; %page; dcl DO_YOU_WANT_TO_REPLACE_THE_EXISTING_QUERY char (51) varying static internal options (constant) init ( "A query already exists, do you wish to replace it? "); %skip(1); dcl INPUT_BUFFER_LENGTH fixed bin (21) static internal options (constant) init (4096); %skip(1); dcl LARGEST_LILA_LINE_NUMBER fixed bin (17) static internal options (constant) init (9999); %skip(1); dcl NEWLINE char (1) static internal options (constant) init (" "); %skip(1); dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl OLD_QUERY bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %page; dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; dcl attached bit (1) aligned; %skip(1); dcl brief bit (1) aligned; %skip(1); dcl cleanup condition; dcl cleanup_signalled bit (1) aligned; dcl code fixed bin (35); dcl current_arg_number fixed bin; %skip(1); dcl enter_the_editor bit (1) aligned; dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); %skip(1); dcl fixed builtin; dcl force bit (1) aligned; %skip(1); dcl index builtin; dcl input_buffer char (INPUT_BUFFER_LENGTH); dcl input_buffer_as_an_array (INPUT_BUFFER_LENGTH) char (1) based (addr (input_buffer)); dcl input_buffer_ptr ptr; dcl input_file_directory_name char (168); dcl input_file_entry_name char (32); dcl input_file_iocb_ptr ptr; dcl input_file_pathname char (168); dcl ioa_ entry() options(variable); %skip(1); dcl linus_error_$no_db fixed bin(35) ext static; dcl linus_query_mgr$initialize_query_file entry (ptr); dcl linus_query_mgr$write_line entry (ptr, fixed bin, char(*), fixed bin(35)); dcl linus_qedx_the_query entry (ptr, bit(1) aligned); dcl linus_query$yes_no entry (ptr, bit(1) aligned, char(*) var); dcl loop fixed bin; %skip(1); dcl null builtin; dcl number_of_args_supplied fixed bin; dcl number_of_characters_read fixed bin (21); %skip(1); dcl opened bit (1) aligned; %skip(1); dcl rel builtin; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$print_message entry() options(variable); dcl still_collecting_lines bit (1) aligned; dcl still_processing_args bit (1) aligned; dcl still_writing_the_file bit (1) aligned; dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; dcl switch_name char (32); %skip(1); dcl terminal_input bit (1) aligned; dcl there_is_a_line_to_write bit (1) aligned; %skip(1); dcl unique_chars_ entry (bit(*)) returns(char(15)); dcl user_wants_the_query_replaced bit (1) aligned; %page; %include iox_modes; %page; %include iox_dcls; %page; %include linus_lcb; %skip(3); end linus_input_query;  linus_list_format_options.pl1 07/29/86 1051.7r w 07/29/86 0939.6 142722 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ %skip(3); /* The main level procedure called by ssu_ to implement the linus list_format_options request. Description and usage follows. This request does either 1, 2 or 3 listed below. 1) Lists the ACTIVE option names and values. 2) Lists ALL the option names and values. 3) Lists USER SPECIFIED option names and values. Usage (1): "list_format_options" or "list_format_options -active" Only the active option names and values are listed. Usage (2): list_format_options -all All of the formatting option names and values are listed. Usage (3): list_format_options -format_option_args or [list_format_options -format_option_args] Where -format_option_args are the same ones taken by the set_format_options_request except no values are supplied. When used as an active request only one format option can be specified. Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_list_format_options: proc (sci_ptr_parm, lcb_ptr_parm); %skip(3); dcl sci_ptr_parm ptr parm; /* ptr to the subsystem control info structure */ dcl lcb_ptr_parm ptr parm; /* ptr to the linus control block info structure */ %skip(3); /* Mainline Processing Overview. (1) Determine requested usage. (2) (a) For usage 1 and 2 get the active or all the option names and values. (b) For usage 3 as a request, get the option value, list it, continue until all user provided option names are exhausted, then return. For usage 3 as an active request do the same except only one format option is specified. (3) List the names and values. */ %page; %skip(3); call initialize; %skip(1); if usage_1 then call linus_options$get_active (lcb_ptr, names_and_values_info_ptr, no_of_names_and_values, names_and_values_ptr, size_of_names_and_values, code); else if usage_2 then call linus_options$get_all (lcb_ptr, names_and_values_info_ptr, no_of_names_and_values, names_and_values_ptr, size_of_names_and_values, code); else do; call get_and_list_user_specified_option_values; return; end; %skip(1); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); call list_the_values; %skip(1); return; %page; get_and_list_option_name: proc; %skip(3); call linus_options$get (lcb_ptr, long_option_name, option_identifier, normalized_option_name, option_value, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); if active_request_flag then do; if ^identifier_needed then number_of_legal_args = 1; else number_of_legal_args = 2; if number_of_args_supplied > number_of_legal_args then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, INVALID_ACTIVE_REQUEST_MESSAGE); else; return_value = requote_string_ ((option_value)); return; end; else; %skip(1); if index (option_value, NEWLINE) = 0 then do; padded_option_name = normalized_option_name; call ioa_ ("^a", padded_option_name || QUOTE || option_value || QUOTE); end; else call ioa_ ("^a^x^a^/^a^a^x^a", normalized_option_name, "beginning", option_value, normalized_option_name, "end"); %skip(1); return; %skip(1); end get_and_list_option_name; %page; get_and_list_star_name: proc; %skip(3); /* Get and list the names and values for the columns named by the starname. */ %skip(1); if active_request_flag then call ssu_$abort_line (sci_ptr, error_table_$nostars, "^/When used as an active request starnames are not allowed."); %skip(1); option_name_table.the_name (1) = long_option_name; option_name_table.the_identifier (1) = option_identifier; %skip(1); call linus_options$get_named (lcb_ptr, option_name_table_ptr, no_of_options_in_name_table, names_and_values_info_ptr, no_of_names_and_values, names_and_values_ptr, size_of_names_and_values, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); else; %skip(1); call list_the_values; %skip(1); return; %skip(1); end get_and_list_star_name; %page; get_and_list_user_specified_option_values: proc; %skip(3); /* Walk through the loop once for each format option. Pick up the format option name and have it expanded into a long name, and determine if it needs a column identifier. If it does need a column identifier then pick it up. Get the option value associated with the format option. If called as an active request then set the return value and return. If called as a regular request then list the value and repeat the loop as long as there are more options. */ %skip(1); report_cip = lcb.report_control_info_ptr; names_and_values_area_ptr = report_control_info.name_value_area_ptr; no_of_options_in_name_table = 1; allocate option_name_table in (names_and_values_area) set (option_name_table_ptr); %skip(1); option_identifier = ""; current_arg_number = 1; %skip(1); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); current_arg_number = current_arg_number + 1; still_processing_args = ON; %skip(1); do while (still_processing_args); %skip(1); option_name = arg; call linus_options$check_name (lcb_ptr, option_name, long_option_name, identifier_needed, code); if code ^= 0 then if code = linus_error_$no_lila_expr_processed then call ssu_$abort_line (sci_ptr, code, "^/There must be columns defined before the value of ^a can be listed.", long_option_name); else if code = linus_error_$bad_option_name then call ssu_$abort_line (sci_ptr, code, "^/^a is not a valid option name.", option_name); else call ssu_$abort_line (sci_ptr, code); else; %skip(1); this_is_a_star_name = OFF; if identifier_needed then do; if current_arg_number > number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "The option ^a was not followed by a column identifier.", long_option_name); else; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); current_arg_number = current_arg_number + 1; option_identifier = arg; call linus_options$check_identifier (lcb_ptr, long_option_name, option_identifier, normalized_option_name, code); if code ^= 0 then if code = linus_error_$bad_option_identifier then call ssu_$abort_line (sci_ptr, code, "^/^a is not a valid column identifier for ^a.", option_identifier, long_option_name); else if code = error_table_$nostars then this_is_a_star_name = ON; else call ssu_$abort_line (sci_ptr, code); else; end; else; %skip(1); if this_is_a_star_name then call get_and_list_star_name; else call get_and_list_option_name; %skip(1); if active_request_flag then return; %skip(1); if current_arg_number > number_of_args_supplied then still_processing_args = OFF; else do; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); current_arg_number = current_arg_number + 1; end; %skip(1); end; %skip(1); return; %skip(1); end get_and_list_user_specified_option_values; %page; initialize: proc; %skip(3); /* If zero args then usage_1 is requested. If there are any args supplied then walk through them all once setting the usage_1 and usage_2 flags as -active and -all are found. If -active and -all are not found then usage_3 has been requested, or an incorrectly spelled control arg has been given. If -active or -all are found then there can't be any format_option_args supplied. */ %skip(1); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); usage_1 = OFF; usage_2 = OFF; usage_3 = OFF; %skip(1); /* Make sure the format options are up to date. */ %skip(1); call linus_options$initialize (lcb_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); /* Find the longest column name for the current select. */ %skip(1); call linus_table$info (lcb_ptr, table_ip, code); if code = linus_error_$no_lila_expr_processed then the_longest_option_name = LONGEST_GENERAL_REPORT_OPTION_NAME_LENGTH + 5; else do; if LONGEST_SPECIFIC_COLUMN_OPTION_NAME_LENGTH > LONGEST_GENERAL_COLUMN_OPTION_NAME_LENGTH then the_longest_option_name = LONGEST_SPECIFIC_COLUMN_OPTION_NAME_LENGTH; else the_longest_option_name = LONGEST_GENERAL_COLUMN_OPTION_NAME_LENGTH; the_longest_option_name = the_longest_option_name + table_info.maximum_column_name_length + 5; end; padded_option_name_ptr = addr (chunk_of_automatic_storage); %skip(1); call ssu_$return_arg (sci_ptr, number_of_args_supplied, active_request_flag, return_value_ptr, return_value_length); %page; if number_of_args_supplied = 0 then do; usage_1 = ON; if active_request_flag then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, INVALID_ACTIVE_REQUEST_MESSAGE); else; end; else do; number_of_control_args_found = 0; do loop = 1 to number_of_args_supplied; call ssu_$arg_ptr (sci_ptr, loop, arg_ptr, arg_length); if arg = "-active" | arg = "-act" then do; number_of_control_args_found = number_of_control_args_found + 1; usage_1 = ON; usage_2 = OFF; end; else if arg = "-all" | arg = "-a" then do; number_of_control_args_found = number_of_control_args_found + 1; usage_2 = ON; usage_1 = OFF; end; else; end; if usage_1 | usage_2 then if active_request_flag then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, INVALID_ACTIVE_REQUEST_MESSAGE); else if number_of_control_args_found ^= number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/When used, ^[-all^;-active^] must be the only argument given.", fixed (usage_1 || usage_2)); else; else; end; %skip(1); if ^usage_1 & ^usage_2 then usage_3 = ON; %skip(1); return; %skip(1); end initialize; %page; list_the_values: proc; %skip(3); /* Walk through the loop once for each format option value. The user may have requested that the active options were to be listed, and the result of this may be zero option values to list. */ %skip(1); if no_of_names_and_values = 0 then do; call ioa_ ("^a^/^a", "All of the formatting options are set to their default values.", "There are no column options defined."); return; end; %skip(1); do loop = 1 to no_of_names_and_values; %skip(1); option_value = substr (names_and_values, name_value_info.value.index (loop), name_value_info.value.length (loop)); %skip(1); if index (option_value, NEWLINE) = 0 then do; padded_option_name = substr (names_and_values, name_value_info.name.index (loop), name_value_info.name.length (loop)); call ioa_ ("^a", padded_option_name || QUOTE || option_value || QUOTE); end; else call ioa_ ("^a^x^a^/^a^a^x^a", substr (names_and_values, name_value_info.name.index (loop), name_value_info.name.length (loop)), "beginning", option_value, substr (names_and_values, name_value_info.name.index (loop), name_value_info.name.length (loop)), "end"); %skip(1); end; %skip(1); return; %skip(1); end list_the_values; %page; dcl INVALID_ACTIVE_REQUEST_MESSAGE char (79) static int options (constant) init ( "^/When used as an active request only one format option value can be requested."); dcl NEWLINE char (1) static int options (constant) init (" "); dcl OFF bit (1) aligned static int options (constant) init ("0"b); dcl ON bit (1) aligned static int options (constant) init ("1"b); dcl QUOTE char (1) static int options (constant) init (""""); %skip(1); dcl active_request_flag bit (1) aligned; dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl chunk_of_automatic_storage char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH); dcl code fixed bin (35); dcl current_arg_number fixed bin; %skip(1); dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$nostars fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl identifier_needed bit (1) aligned; dcl index builtin; dcl ioa_ entry() options(variable); %skip(1); dcl linus_error_$bad_option_identifier fixed bin(35) ext static; dcl linus_error_$bad_option_name fixed bin(35) ext static; dcl linus_error_$no_lila_expr_processed fixed bin(35) ext static; dcl linus_options$check_identifier entry (ptr, char(*) var, char(*) var, char(*) var, fixed bin(35)); dcl linus_options$check_name entry (ptr, char(*) var, char(*) var, bit(1) aligned, fixed bin(35)); dcl linus_options$get entry (ptr, char(*) var, char(*) var, char(*) var, char(*) var, fixed bin(35)); dcl linus_options$get_active entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35)); dcl linus_options$get_all entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35)); dcl linus_options$get_named entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35)); dcl linus_options$initialize entry (ptr, fixed bin(35)); dcl linus_table$info entry (ptr, ptr, fixed bin(35)); dcl long_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying; dcl loop fixed bin; %skip(1); dcl names_and_values_area area (sys_info$max_seg_size) based (names_and_values_area_ptr); dcl names_and_values_area_ptr ptr; dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying; dcl null builtin; dcl number_of_args_supplied fixed bin; dcl number_of_control_args_found fixed bin; dcl number_of_legal_args fixed bin; %skip(1); dcl option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying; dcl option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying; dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; %skip(1); dcl padded_option_name char (the_longest_option_name) based (padded_option_name_ptr); dcl padded_option_name_ptr ptr; %skip(1); dcl rel builtin; dcl requote_string_ entry (char(*)) returns(char(*)); dcl return_value char (return_value_length) varying based (return_value_ptr); dcl return_value_length fixed bin (21); dcl return_value_ptr ptr; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); dcl still_processing_args bit (1) aligned; dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl the_longest_option_name fixed bin; dcl this_is_a_star_name bit (1) aligned; %skip(1); dcl usage_1 bit (1) aligned; dcl usage_2 bit (1) aligned; dcl usage_3 bit (1) aligned; %page; %include arg_descriptor; %page; %include arg_list; %page; %include linus_lcb; %page; %include linus_names_and_values; %page; %include linus_options_extents; %page; %include linus_report_info; %page; %include linus_table_info; %page; end linus_list_format_options;  linus_opened_database.pl1 07/29/86 1053.3rew 07/29/86 0938.5 44748 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-07,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): /* This is the main level procedure called by ssu_ to implement the linus opened_database request. END HISTORY COMMENTS */ /* Description: This request returns true or false to indicate if a databse is opened or closed. Usage: "opened_database {database_pathname}" where database_pathname is the name of a mrds database. If this isn't supplied, true is returned if a database is currently opened. */ /* format: off */ %page; linus_opened_database: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(1); dcl lcb_ptr_parm ptr parm; dcl sci_ptr_parm ptr parm; %skip(1); call initialize; call check_for_opened_database; %skip(1); return; %page; check_for_opened_database: proc; %skip(1); dcl cfod_code fixed bin (35); dcl cfod_dir_name_1 char (168); dcl cfod_dir_name_2 char (168); dcl cfod_entry_name_1 char (32); dcl cfod_entry_name_2 char (32); dcl cfod_db_pathname char (168) varying; dcl cfod_opening_mode char (20); dcl cfod_suffix char (3); dcl cfod_uid_1 bit (36) aligned; dcl cfod_uid_2 bit (36) aligned; %skip(1); if number_of_args_supplied = 0 | lcb.db_index = 0 then do; if lcb.db_index ^= 0 then return_value = "true"; return; end; %skip(1); call dsl_$get_pn (lcb.db_index, cfod_db_pathname, cfod_opening_mode, cfod_code); if cfod_code ^= 0 then call ssu_$abort_line (sci_ptr, cfod_code, "^/Unable to get the database pathname."); call expand_pathname_ ((cfod_db_pathname), cfod_dir_name_1, cfod_entry_name_1, (0)); call hcs_$get_uid_file (cfod_dir_name_1, cfod_entry_name_1, cfod_uid_1, cfod_code); if cfod_code ^= 0 then call ssu_$abort_line (sci_ptr, cfod_code, "^/Unable to get the uid of the opened database."); %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); cfod_suffix = reverse (before (reverse (arg), ".")); call expand_pathname_$add_suffix (arg, cfod_suffix, cfod_dir_name_2, cfod_entry_name_2, cfod_code); if cfod_code ^= 0 then call ssu_$abort_line (sci_ptr, cfod_code, "^/^a could not be expanded.", arg); call hcs_$get_uid_file (cfod_dir_name_2, cfod_entry_name_2, cfod_uid_2, cfod_code); if cfod_code ^= 0 then if cfod_code = error_table_$noentry then return; else call ssu_$abort_line (sci_ptr, cfod_code, "^/Unable to get the uid for the supplied arg pathname."); if cfod_uid_1 = cfod_uid_2 then return_value = "true"; %skip(1); return; %skip(1); end check_for_opened_database; %page; initialize: proc; %skip(1); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); call ssu_$return_arg (sci_ptr, number_of_args_supplied, active_request_flag, return_value_ptr, return_value_length); return_value = "false"; if number_of_args_supplied > 1 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, USAGE_MESSAGE); %skip(1); return; %skip(1); end initialize; %page; dcl USAGE_MESSAGE char (44) internal static options (constant) init ( "^/Usage: opened_database {database_pathname}"); %skip(1); dcl active_request_flag bit (1) aligned; dcl addr builtin; dcl after builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl before builtin; %skip(1); dcl dsl_$get_pn entry (fixed bin(35), char(168) var, char(20), fixed bin(35)); %skip(1); dcl error_table_$noentry fixed bin(35) ext static; dcl error_table_$too_many_args fixed bin(35) ext static; dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); %skip(1); dcl fixed builtin; %skip(1); dcl hcs_$get_uid_file entry (char(*), char(*), bit(36) aligned, fixed bin(35)); %skip(1); dcl index builtin; %skip(1); dcl number_of_args_supplied fixed bin; %skip(1); dcl rel builtin; dcl return_value char (return_value_length) varying based (return_value_ptr); dcl return_value_length fixed bin (21); dcl return_value_ptr ptr; dcl reverse builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); %page; %include linus_lcb; %skip(1); end linus_opened_database;  linus_options.pl1 10/03/86 1249.1rew 10/02/86 1512.1 978489 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-18,JSLove), approve(86-08-18,MCR7518), audit(86-08-21,Parisek), install(86-10-02,MR12.0-1175): Changed to call match_star_name_ instead of linus_match_star_name. Linus_match_star_name was deleted when the new match_star_name_ was installed. END HISTORY COMMENTS */ /* format: off */ %skip(1); linus_options: proc; %skip(1); /* This module provides an interface to the options used in formatting reports. The following external entry points in order of appearance are available: initialize Called by all format related requests when they are invoked. It takes care of making sure everything is up to date, allocated, etc. terminate Called by linus termination code if lcb.report_control_info_ptr is non-null. It takes care of undoing everything this subroutine does during the course of a linus session. check_identifier Called to check a column/option identifier. Translates an option name and option identifier into a character string consisting of the option name and real option identifier (i.e. translates 1 into the name of column 1.) Can also be used to determine if the column name is a star name. check_name Called to check an option name, expand the short option name into a long name, and determine if it needs a column/option identifier. get Called to get the value of a formatting option. get_active Called to get the names and values of the active formatting options. get_all Called to get the names and values of all of the formatting options. get_named Called to get the names and values of a set of formatting options. The options are named by the caller, but the names of columns can be names, star names or numbers. The names returned by this module are actual column names instead of numbers or star names. set_and_check Called to set a formatting option to a provided value. The option name and value are checked for validity. set_all_to_system_defaults Called to set all of the formatting options to their default values. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; %skip(3); /* These parameters are described at each entry where they are used. */ %skip(3); dcl code_parm fixed bin (35) parm; dcl identifier_needed_parm bit (1) aligned parm; dcl lcb_ptr_parm ptr parm; dcl long_option_name_parm char (*) varying parm; dcl names_and_values_info_ptr_parm ptr parm; dcl names_and_values_ptr_parm ptr parm; dcl no_of_names_and_values_parm fixed bin (21) parm; dcl no_of_options_in_name_table_parm fixed bin (21) parm; dcl normalized_option_name_parm char (*) varying parm; dcl option_identifier_parm char (*) varying parm; dcl option_name_parm char (*) varying parm; dcl option_name_table_ptr_parm ptr parm; dcl option_value_parm char (*) varying parm; dcl size_of_names_and_values_parm fixed bin (21) parm; dcl system_default_parm bit (1) aligned parm; %skip(5); call ssu_$abort_line (lcb.subsystem_control_info_ptr, 0, "This is not a valid entrypoint."); %page; initialize: entry ( %skip(1); lcb_ptr_parm, /* input: pointer to the linus control block */ code_parm /* output: success or failure */ ); %skip(1); /* This entry point is called by the display, set_format_options, list_format_options, save_format_options and restore_format_options requests when they are invoked. It is not called by column_value or display_builtins, and should not be called by any future active requests like column_value when they are implemented. This code makes sure that: 1) The linus options value seg is created; that the value seg is loaded with the system defaults; that 3 areas for allocations are created; and that 9 temp segments are created. This is done once per linus invocation. 2) That the area used for allocations of name value pairs is emptied. This is done once per invocation of this entrypoint. 3) That the options which refer to columns are up to date. This means deleting the old column options and loading the value seg with the new column default options if the user has done a lila proc since the last time this entry was called, or deleting the old column options if the user has done an unsuccessful lila proc since the last time this entry was called. */ %skip(1); me = "linus_options$initialize"; lcb_ptr = lcb_ptr_parm; code_parm = 0; %skip(1); if lcb.report_control_info_ptr = null () then do; call setup_to_do_reporting; lcb.report_control_info_ptr = report_cip; call load_value_seg_with_report_defaults; end; %skip(1); call housekeeping; temp_seg_ptr = names_and_values_area_ptr; call release_area_ (temp_seg_ptr); %skip(1); if lcb.selection_expression_identifier = 0 then return; %page; /* If we are out of date, or, there is no valid lila expression available but the column options are still around, then delete the column options. Then if there is a valid lila selection expression available, load the new column default values. */ %skip(1); if report_control_info.selection_expression_identifier ^= lcb.selection_expression_identifier | ^valid_selection_expression then do; call value_$get (value_seg_ptr, PERMANENT, OPTIONS.GENERAL_COLUMN.NAME (1), returned_option_value, code); if code = 0 then call delete_column_options; else if code ^= error_table_$oldnamerr then call ssu_$abort_line (sci_ptr, code, "While trying to get the value of ^a for ^a.", OPTIONS.GENERAL_COLUMN.NAME (1), me); else; end; %skip(1); if report_control_info.selection_expression_identifier ^= lcb.selection_expression_identifier & valid_selection_expression then call load_value_seg_with_column_defaults; %skip(1); return; %page; terminate: entry ( %skip(1); lcb_ptr_parm, /* input: ptr to the linus control block */ code_parm /* output: success or failure */ ); %skip(1); /* This entry point is called by the linus termination procedure when the linus user has issued the "quit" request, or cleanup of linus has been signalled. It deletes the value segment and releases areas and temp segs set up in the setup_to_do_reporting proc. It also deletes the copy of the report if one is still laying around (i.e. the display request was invoked with "-keep_report" and linus was quit out of before display was invoked again). */ %skip(1); /* Have to use this name or temp segs won't be released. */ %skip(1); me = "linus_options$initialize"; %skip(1); lcb_ptr = lcb_ptr_parm; code_parm = 0; sci_ptr = lcb.subsystem_control_info_ptr; %skip(1); report_cip = lcb.report_control_info_ptr; if report_control_info.flags.permanent_report then do; call linus_fr_delete_report (lcb_ptr, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "While trying to delete the copy of the report."); end; %skip(1); /* Delete the value seg. */ %skip(1); call delete_$ptr (report_control_info.value_seg_ptr, "100111"b, me, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "While trying to delete the format options."); %skip(1); /* Then the area/temp seg for name value allocations. */ %skip(1); temp_seg_ptr = report_control_info.name_value_area_ptr; call release_area_ (temp_seg_ptr); call release_temp_segment (report_control_info.name_value_area_ptr); %skip(1); /* The temp seg for arrays of name-value pairs. */ %skip(1); call release_temp_segment (report_control_info.name_value_temp_seg_ptr); %skip(1); /* The temp seg for report workspace. */ %skip(1); call release_temp_segment (report_control_info.report_temp_seg_ptr); %skip(1); /* The temp seg and area for display workspace. */ %skip(1); temp_seg_ptr = report_control_info.display_work_area_ptr; call release_area_ (temp_seg_ptr); call release_temp_segment (report_control_info.display_work_area_ptr); %skip(1); /* The temp seg and area for report allocations. */ %skip(1); temp_seg_ptr = report_control_info.report_work_area_ptr; call release_area_ (temp_seg_ptr); call release_temp_segment (report_control_info.report_work_area_ptr); %skip(1); /* And the 4 temp segs for report building workspace. */ %skip(1); call release_temp_segment (report_control_info.input_string_temp_seg_ptr); call release_temp_segment (report_control_info.output_string_temp_seg_ptr); call release_temp_segment (report_control_info.editing_strings_temp_seg_ptr); call release_temp_segment (report_control_info.headers_temp_seg_ptr); %skip(1); return; %page; check_identifier: entry ( %skip(1); lcb_ptr_parm, /* input: ptr to linus control block */ option_name_parm, /* input: option name to look up */ option_identifier_parm, /* input: option identifier to look up */ normalized_option_name_parm, /* output: the option name and identifier */ code_parm /* output: success or failure */ ); %skip(1); /* This entry is called to translate an option name and identifier into a character string that contains the option name and real option identifier. That is, an option identifier can be a number or the name of a column. The returned option identifier is always the name of the column. The option_name_parm should be the expanded version, as this entry shouldn't be called until the check_name entry was called. This entry does not support star names, but is useful for determining if the identifier is a star name. */ %skip(1); me = "linus_options$check_identifier"; lcb_ptr = lcb_ptr_parm; option_name = option_name_parm; option_identifier = option_identifier_parm; normalized_option_name_parm = ""; code_parm = 0; %skip(1); call housekeeping; %skip(1); call normalize_option_name (option_name, option_identifier, option_type, option_table_index, normalized_option_name, code); code_parm = code; normalized_option_name_parm = normalized_option_name; %skip(1); return; %page; check_name: entry ( %skip(1); lcb_ptr_parm, /* input: ptr to linus control block */ option_name_parm, /* input: option name to determine type of */ long_option_name_parm, /* output: long version of above name */ identifier_needed_parm, /* output: ON means identifier needed */ code_parm /* output: success or failure */ ); %skip(1); /* This entry point is called to check an option name and determine the type of option the caller is dealing with. There are two types of options. Ones like "-page_size" (general report or general column options) which do not require anything else to identify them. For these types "0"b is returned to describe their type. Others like "-width" (specific column options) require a column number or name to identify which they apply to. For these types "1"b is returned. The short or long name provided is used to find the long name of the option and this long name is returned. */ %skip(1); me = "linus_options$check_name"; lcb_ptr = lcb_ptr_parm; option_name = option_name_parm; long_option_name_parm = ""; identifier_needed_parm = OFF; code_parm = 0; %skip(1); call housekeeping; %skip(1); call expand_short_option_name (option_name, long_option_name, code); if code ^= 0 then do; code_parm = code; return; end; else long_option_name_parm = long_option_name; %skip(1); call lookup_option_number (long_option_name, option_type, option_table_index); if option_type = SPECIFIC_COLUMN_OPTION then identifier_needed_parm = ON; else; %page; if ^valid_selection_expression then if (option_type = GENERAL_COLUMN_OPTION | option_type = SPECIFIC_COLUMN_OPTION) then code_parm = linus_error_$no_lila_expr_processed; else; else; %skip(1); return; %page; get: entry ( %skip(1); lcb_ptr_parm, /* input: ptr to the linus control block */ option_name_parm, /* input: option name to get value for */ option_identifier_parm, /* input: option identifier for name */ normalized_option_name_parm, /* output: the option name and identifier */ option_value_parm, /* output: option value defined for name */ code_parm /* output: success or failure */ ); %skip(1); /* This entry point is called by subroutines and requests. It attempts to get the option value associated with the caller provided option name. For option names that require an identifier, the option name concatenated with a blank and the real option identifier is also returned. That is, column names rather than numbers are always returned. */ %skip(1); me = "linus_options$get"; %skip(1); lcb_ptr = lcb_ptr_parm; option_name = option_name_parm; option_identifier = option_identifier_parm; %skip(1); normalized_option_name_parm = ""; option_value_parm = ""; code_parm = 0; %skip(1); call housekeeping; %skip(1); call normalize_option_name (option_name, option_identifier, option_type, option_table_index, normalized_option_name, code); if code ^= 0 then do; code_parm = code; return; end; %skip(1); call value_$get (value_seg_ptr, PERMANENT, normalized_option_name, option_value, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to get the value for ^a.", normalized_option_name_parm); %skip(1); normalized_option_name_parm = normalized_option_name; option_value_parm = option_value; %skip(1); return; %page; get_active: entry ( %skip(1); lcb_ptr_parm, /* input: ptr to the linus control block */ names_and_values_info_ptr_parm, /* output: ptr to names and values info */ no_of_names_and_values_parm, /* output: no of name-value pairs */ names_and_values_ptr_parm, /* output: ptr to the names and values */ size_of_names_and_values_parm, /* output: length of names_and_values char string */ code_parm /* output: success or failure */ ); %skip(1); /* This entrypoint is called by the linus list_format_options and save_format_options requests to get all the active formatting option names and values. They are returned as a character string, along with a structure which describes the character string. */ %skip(1); me = "linus_options$get_active"; lcb_ptr = lcb_ptr_parm; names_and_values_info_ptr_parm = null (); no_of_names_and_values_parm = 0; names_and_values_ptr_parm = null (); size_of_names_and_values_parm = 0; code_parm = 0; %skip(1); call housekeeping; %skip(1); call get_all_names_and_values; call extract_active_from_all; %skip(1); names_and_values_info_ptr_parm = like_names_and_values_info_ptr; no_of_names_and_values_parm = no_of_active_names_and_values; names_and_values_ptr_parm = names_and_values_ptr; size_of_names_and_values_parm = size_of_names_and_values; %skip(1); return; %page; get_all: entry ( %skip(1); lcb_ptr_parm, /* input: ptr to the linus control block */ names_and_values_info_ptr_parm, /* output: ptr to names and values info */ no_of_names_and_values_parm, /* output: no of name-value pairs */ names_and_values_ptr_parm, /* output: ptr to the names and values */ size_of_names_and_values_parm, /* output: length of names_and_values char string */ code_parm /* output: success or failure */ ); %skip(1); /* This entrypoint is called by the linus list_format_options and save_format_options requests to get all of the formatting option names and values. They are returned as a character string, along with a structure which describes the character string. */ %skip(1); me = "linus_options$get_all"; lcb_ptr = lcb_ptr_parm; names_and_values_info_ptr_parm = null (); no_of_names_and_values_parm = 0; names_and_values_ptr_parm = null (); size_of_names_and_values_parm = 0; code_parm = 0; %skip(1); call housekeeping; %skip(1); call get_all_names_and_values; %skip(1); names_and_values_info_ptr_parm = names_and_values_info_ptr; no_of_names_and_values_parm = no_of_names_and_values; names_and_values_ptr_parm = names_and_values_ptr; size_of_names_and_values_parm = size_of_names_and_values; %skip(1); return; %page; get_named: entry ( %skip(1); lcb_ptr_parm, /* input: ptr to the linus control block */ option_name_table_ptr_parm, /* input: an array of option names and identifiers */ no_of_options_in_name_table_parm, /* input: no of option names */ names_and_values_info_ptr_parm, /* output: ptr to names and values info */ no_of_names_and_values_parm, /* output: no of name value pairs */ names_and_values_ptr_parm, /* output: ptr to the names and values */ size_of_names_and_values_parm, /* output: length of names_and_values char string */ code_parm /* output: success or failure */ ); %skip(1); /* This entrypoint is called by the linus save_format_options and list_format_options requests. It takes an array of names as input and creates a character string containing all of the names and values, along with a structure which describes the character string. */ %skip(1); me = "linus_options$get_named"; lcb_ptr = lcb_ptr_parm; option_name_table_ptr = option_name_table_ptr_parm; no_of_options_in_name_table = no_of_options_in_name_table_parm; names_and_values_info_ptr_parm = null(); no_of_names_and_values_parm = 0; names_and_values_ptr_parm = null (); size_of_names_and_values_parm = 0; code_parm = 0; %skip(1); call housekeeping; %skip(1); call get_named_values (code); if code ^= 0 then code_parm = code; else do; names_and_values_info_ptr_parm = names_and_values_info_ptr; no_of_names_and_values_parm = no_of_names_and_values; names_and_values_ptr_parm = names_and_values_ptr; size_of_names_and_values_parm = size_of_names_and_values; end; %skip(1); return; %page; set_and_check: entry ( %skip(1); lcb_ptr_parm, /* input: ptr to linus control block */ option_name_parm, /* input: option name to set value for */ option_identifier_parm, /* input: option identifier for name */ option_value_parm, /* input: option value to set */ system_default_parm, /* input: on = set value to system default */ code_parm /* output: success or failure */ ); %skip(1); /* This entry point is called by the set_format_options request to set a user specified option name to either a user provided option value or the system provided default. It first makes sure that the option name is valid. The caller should have first called the check_name entry of this suboutine and had the option name expanded and checked at that time. If the user has requested that it be set to the system default value, it sets it from system tables. Otherwise it determines if the value is legitimate for the particular option. It is then set if the value is correct. */ %skip(1); me = "linus_options$set_and_check"; lcb_ptr = lcb_ptr_parm; option_name = option_name_parm; option_identifier = option_identifier_parm; option_value = option_value_parm; system_default = system_default_parm; code_parm = 0; %skip(1); call housekeeping; %skip(1); call set_the_values (option_name, option_identifier, option_value, system_default, code); code_parm = code; %skip(1); return; %page; set_all_to_system_defaults: entry ( %skip(1); lcb_ptr, /* input: ptr to linus control block */ code_parm /* output: success or failure */ ); %skip(1); /* This entrypoint is called by the set_format_options request to set all of the formatting options to the system provided defaults. It first sets the general report options. It then sets the general and specific column options if a valid lila statement is available. If there are old column options hanging around they are deleted before the set operation. */ %skip(1); me = "linus_options$set_all_to_system_defaults"; lcb_ptr = lcb_ptr_parm; code_parm = 0; %skip(1); call housekeeping; call load_value_seg_with_report_defaults; %skip(1); if ^valid_selection_expression then return; %skip(1); call value_$get (value_seg_ptr, PERMANENT, OPTIONS.GENERAL_COLUMN.NAME (1), returned_option_value, code); if code = 0 then call delete_column_options; else if code ^= error_table_$oldnamerr then call ssu_$abort_line (sci_ptr, code, "While trying to get the value of ^a for ^a.", OPTIONS.GENERAL_COLUMN.NAME (1), me); else; %skip(1); call load_value_seg_with_column_defaults; %skip(1); return; %page; delete_column_options: proc; %skip(3); /* This proc is called to delete the column option names and values so that leftover column options from another select don't get confused with the current column options. If it runs into trouble the line is aborted here because reporting can't possibly continue. */ %skip(1); dcl dco_inner_loop fixed bin; dcl dco_loop fixed bin; %skip(1); alloc_name_count = NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE + NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE; alloc_max_name_len = max (LONGEST_SPECIFIC_COLUMN_OPTION_NAME_LENGTH, LONGEST_GENERAL_COLUMN_OPTION_NAME_LENGTH) + length (BLANK) + length (STAR_DOT_STAR_STAR); allocate match_info in (names_and_values_area) set (match_info_ptr); match_info.version = match_info_version_1; %skip(1); do dco_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE; %skip(1); match_info.name_array.exclude_sw (dco_loop) = OFF; match_info.name_array.regexp_sw (dco_loop) = OFF; match_info.name_array.name (dco_loop) = OPTIONS.GENERAL_COLUMN.NAME (dco_loop); %skip(1); end; %skip(1); dco_inner_loop = NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE + 1; %skip(1); do dco_loop = 1 to NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE; %skip(1); match_info.name_array.exclude_sw (dco_inner_loop) = OFF; match_info.name_array.regexp_sw (dco_inner_loop) = OFF; match_info.name_array.name (dco_inner_loop) = OPTIONS.SPECIFIC_COLUMN.NAME (dco_loop) || BLANK || STAR_DOT_STAR_STAR; dco_inner_loop = dco_inner_loop + 1; %skip(1); end; %page; call value_$list (value_seg_ptr, PERMANENT, match_info_ptr, names_and_values_area_ptr, value_list_info_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", "While trying to get the option names for the columns."); %skip(1); do dco_loop = 1 to value_list_info.pair_count; %skip(1); call value_$delete (value_seg_ptr, PERMANENT, substr (value_list_info.chars, value_list_info.pairs.name_index (dco_loop), value_list_info.pairs.name_len (dco_loop)), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to delete the value of ^a.", substr (value_list_info.chars, value_list_info.pairs.name_index (dco_loop), value_list_info.pairs.name_len (dco_loop))); %skip(1); end; %skip(1); report_control_info.options_identifier = report_control_info.options_identifier + 1; %skip(1); return; %skip(1); end delete_column_options; %page; expand_short_option_name: proc ( eson_option_name_parm, /* input: option name to expand */ eson_long_option_name_parm, /* output: long version of option name */ eson_code_parm /* output: success or failure */ ); %skip(3); /* When this proc is called it expects eson_option_name_parm to contain the short or long option name. It sets eson_long_option_name_parm based on the value of eson_option_name_parm. If the name isn't valid it sets eson_code_parm to reflect this. It first does a binary table search on the short_names table and if it's unsucessful it does the same to the long_names table. */ %skip(1); dcl eson_code_parm fixed bin (35) parm; dcl eson_long_option_name_parm char (*) varying parm; dcl eson_option_name_parm char (*) varying parm; dcl eson_table_index fixed bin; %skip(3); eson_long_option_name_parm = ""; eson_code_parm = 0; %skip(1); eson_table_index = lookup_name_from_table (eson_option_name_parm, OPTION_NAMES_AS_ARGS.SHORT_NAME); if eson_table_index ^= 0 then do; eson_long_option_name_parm = OPTION_NAMES_AS_ARGS. LONG_NAME_IN_SHORT_NAME_ORDER (eson_table_index); return; end; %skip(1); eson_table_index = lookup_name_from_table (eson_option_name_parm, OPTION_NAMES_AS_ARGS.LONG_NAME); if eson_table_index ^= 0 then eson_long_option_name_parm = eson_option_name_parm; else eson_code_parm = linus_error_$bad_option_name; %skip(1); return; %page; lookup_name_from_table: proc ( lnft_name_parm, /* input: name to look up */ lnft_table_parm /* output: table to do lookup from */ ) returns (fixed bin); %skip(3); dcl lnft_loop1 fixed bin; dcl lnft_loop2 fixed bin; dcl lnft_loop3 fixed bin; dcl lnft_name_parm char (*) varying parm; dcl lnft_table_parm (*) char (*) varying parm; %skip(1); lnft_loop1 = 1; lnft_loop2 = hbound (lnft_table_parm, 1); %skip(1); do while (lnft_loop1 <= lnft_loop2); %skip(1); lnft_loop3 = divide (lnft_loop1 + lnft_loop2, 2, 17); if lnft_name_parm = lnft_table_parm (lnft_loop3) then return (lnft_loop3); %skip(1); if lnft_name_parm < lnft_table_parm (lnft_loop3) then lnft_loop2 = lnft_loop3 - 1; else lnft_loop1 = lnft_loop3 + 1; %skip(1); end; %skip(1); return (0); %skip(1); end lookup_name_from_table; %skip(3); end expand_short_option_name; %page; extract_active_from_all: proc; %skip(3); /* This proc is called by the entry get_active to extract the names and values from the value list structures that are considered active. It expects that get_all_names_and_values has just been called, and moves the index and length of each name and value considered active, into a structure returned to the caller of the get_active entrypoint. */ %skip(1); dcl eafa_inner_loop fixed bin; dcl eafa_loop fixed bin; %skip(3); no_of_names_and_values_in_bit_map = no_of_names_and_values; no_of_active_names_and_values = no_of_names_and_values; %skip(1); allocate names_and_values_bit_map in (names_and_values_area) set (names_and_values_bit_map_ptr); unspec (names_and_values_bit_map) = OFF; %skip(1); do eafa_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE; %skip(1); if report_control_info.format_options_flags. general_report_default_value (eafa_loop) then do; names_and_values_bit_map (eafa_loop) = ON; no_of_active_names_and_values = no_of_active_names_and_values - 1; end; %skip(1); end; %page; if valid_selection_expression then do; eafa_inner_loop = NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE + 1; do eafa_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE; if report_control_info.format_options_flags .general_column_default_value (eafa_loop) then do; names_and_values_bit_map (eafa_inner_loop) = ON; no_of_active_names_and_values = no_of_active_names_and_values - 1; end; eafa_inner_loop = eafa_inner_loop + 1; end; end; %skip(1); allocate like_name_value_info in (names_and_values_area) set (like_names_and_values_info_ptr); %skip(1); eafa_inner_loop = 1; %skip(1); do eafa_loop = 1 to no_of_names_and_values_in_bit_map; if names_and_values_bit_map (eafa_loop) = OFF then do; like_name_value_info.name.index (eafa_inner_loop) = name_value_info.name.index (eafa_loop); like_name_value_info.name.length (eafa_inner_loop) = name_value_info.name.length (eafa_loop); like_name_value_info.value.index (eafa_inner_loop) = name_value_info.value.index (eafa_loop); like_name_value_info.value.length (eafa_inner_loop) = name_value_info.value.length (eafa_loop); eafa_inner_loop = eafa_inner_loop + 1; end; end; %skip(1); return; %skip(1); end extract_active_from_all; %page; get_all_names_and_values: proc; %skip(3); /* This proc is called to obtain all of the names and values. It first gets the general report options. Then, if there are column options defined, the general column options are gotten, followed by the specific column options. */ %skip(1); dcl ganav_inner_loop fixed bin; dcl ganav_loop fixed bin; dcl ganav_loop_limit fixed bin; dcl ganav_no_of_chars_already_done fixed bin (21); %skip(3); /* Get the names and values for the general report options. */ %skip(1); alloc_name_count = NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE; alloc_max_name_len = LONGEST_GENERAL_REPORT_OPTION_NAME_LENGTH; allocate match_info in (names_and_values_area) set (match_info_ptr); match_info.version = match_info_version_1; %skip(1); do ganav_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE; %skip(1); match_info.name_array.exclude_sw (ganav_loop) = OFF; match_info.name_array.regexp_sw (ganav_loop) = OFF; match_info.name_array.name (ganav_loop) = OPTIONS.GENERAL_REPORT.NAME (ganav_loop); %skip(1); end; %skip(1); call value_$list (value_seg_ptr, PERMANENT, match_info_ptr, names_and_values_area_ptr, value_list_info_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to get the report option names and values."); %skip(1); general_report_names_and_values_info_ptr = value_list_info_ptr; %page; /* Get the names and values for the general and specific column options. */ %skip(1); if valid_selection_expression then do; %skip(1); alloc_name_count = NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE; alloc_max_name_len = LONGEST_GENERAL_COLUMN_OPTION_NAME_LENGTH; allocate match_info in (names_and_values_area) set (match_info_ptr); match_info.version = match_info_version_1; %skip(1); do ganav_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE; %skip(1); match_info.name_array.exclude_sw (ganav_loop) = OFF; match_info.name_array.regexp_sw (ganav_loop) = OFF; match_info.name_array.name (ganav_loop) = OPTIONS.GENERAL_COLUMN.NAME (ganav_loop); %skip(1); end; %skip(1); call value_$list (value_seg_ptr, PERMANENT, match_info_ptr, names_and_values_area_ptr, value_list_info_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to get the general column option names and values."); %skip(1); general_columns_names_and_values_info_ptr = value_list_info_ptr; %skip(1); alloc_name_count = NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE; alloc_max_name_len = LONGEST_SPECIFIC_COLUMN_OPTION_NAME_LENGTH + length (BLANK) + length (STAR_DOT_STAR_STAR); allocate match_info in (names_and_values_area) set (match_info_ptr); match_info.version = match_info_version_1; %skip(1); do ganav_loop = 1 to NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE; %skip(1); match_info.name_array.exclude_sw (ganav_loop) = OFF; match_info.name_array.regexp_sw (ganav_loop) = OFF; match_info.name_array.name (ganav_loop) = OPTIONS.SPECIFIC_COLUMN.NAME (ganav_loop) || BLANK || STAR_DOT_STAR_STAR; %skip(1); end; %skip(1); call value_$list (value_seg_ptr, PERMANENT, match_info_ptr, names_and_values_area_ptr, value_list_info_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to get the specific column option names and values."); %skip(1); specific_columns_names_and_values_info_ptr = value_list_info_ptr; %skip(1); end; %skip(1); /* Set the number of options we have and the length of them. */ %skip(1); if valid_selection_expression then size_of_names_and_values = general_report_names_and_values_info_ptr -> value_list_info.chars_len + general_columns_names_and_values_info_ptr -> value_list_info.chars_len + specific_columns_names_and_values_info_ptr -> value_list_info.chars_len; else size_of_names_and_values = general_report_names_and_values_info_ptr -> value_list_info.chars_len; allocate names_and_values in (names_and_values_area) set (names_and_values_ptr); %skip(1); if valid_selection_expression then no_of_names_and_values = general_report_names_and_values_info_ptr -> value_list_info.pair_count + general_columns_names_and_values_info_ptr -> value_list_info.pair_count + specific_columns_names_and_values_info_ptr -> value_list_info.pair_count; else no_of_names_and_values = general_report_names_and_values_info_ptr -> value_list_info.pair_count; allocate name_value_info in (names_and_values_area) set (names_and_values_info_ptr); %skip(1); /* Move the general report options and their lengths and index into the callers table. */ %skip(1); value_list_info_ptr = general_report_names_and_values_info_ptr; substr (names_and_values, 1, value_list_info.chars_len) = value_list_info.chars; %skip(1); do ganav_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE; %skip(1); name_value_info.name.index (ganav_loop) = value_list_info.pairs.name_index (ganav_loop); name_value_info.name.length (ganav_loop) = value_list_info.pairs.name_len (ganav_loop); name_value_info.value.index (ganav_loop) = value_list_info.pairs.value_index (ganav_loop); name_value_info.value.length (ganav_loop) = value_list_info.pairs.value_len (ganav_loop); %skip(1); end; %skip(1); if ^valid_selection_expression then return; %skip(1); /* Move the general and specific column options and their lengths and index into the callers table. */ %skip(1); ganav_no_of_chars_already_done = value_list_info.chars_len; ganav_inner_loop = NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE + 1; value_list_info_ptr = general_columns_names_and_values_info_ptr; substr (names_and_values, ganav_no_of_chars_already_done + 1, value_list_info.chars_len) = value_list_info.chars; %skip(1); do ganav_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE; %skip(1); name_value_info.name.index (ganav_inner_loop) = value_list_info.pairs.name_index (ganav_loop) + ganav_no_of_chars_already_done; name_value_info.name.length (ganav_inner_loop) = value_list_info.pairs.name_len (ganav_loop); %skip(1); name_value_info.value.index (ganav_inner_loop) = value_list_info.pairs.value_index (ganav_loop) + ganav_no_of_chars_already_done; name_value_info.value.length (ganav_inner_loop) = value_list_info.pairs.value_len (ganav_loop); ganav_inner_loop = ganav_inner_loop + 1; %skip(1); end; %skip(1); ganav_no_of_chars_already_done = ganav_no_of_chars_already_done + value_list_info.chars_len; value_list_info_ptr = specific_columns_names_and_values_info_ptr; substr (names_and_values, ganav_no_of_chars_already_done + 1, value_list_info.chars_len) = value_list_info.chars; %skip(1); ganav_loop_limit = NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE * table_info.column_count; %skip(1); do ganav_loop = 1 to ganav_loop_limit; %skip(1); name_value_info.name.index (ganav_inner_loop) = value_list_info.pairs.name_index (ganav_loop) + ganav_no_of_chars_already_done; name_value_info.name.length (ganav_inner_loop) = value_list_info.pairs.name_len (ganav_loop); %skip(1); name_value_info.value.index (ganav_inner_loop) = value_list_info.pairs.value_index (ganav_loop) + ganav_no_of_chars_already_done; name_value_info.value.length (ganav_inner_loop) = value_list_info.pairs.value_len (ganav_loop); ganav_inner_loop = ganav_inner_loop + 1; %skip(1); end; %skip(1); return; %skip(1); end get_all_names_and_values; %page; get_general_column_default_value: proc ( ggcdv_option_name_parm, /* input: name of option */ ggcdv_option_value_parm /* output: default value for above option */ ); %skip(3); /* When this proc is called it expects ggcdv_option_name_parm to contain the name of the option that the default should be generated for. It sets ggcdv_option_value_parm to this default value or "ERROR" if things don't work out well. */ %skip(1); dcl ggcdv_loop fixed bin; dcl ggcdv_option_name_parm char (*) varying parm; dcl ggcdv_option_value_parm char (*) varying parm; %skip(1); if ggcdv_option_name_parm = OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_COLUMN_ORDER) then do; ggcdv_option_value_parm = table_info.columns.column_name (1); if number_of_defined_columns = 1 then return; do ggcdv_loop = 2 to number_of_defined_columns; ggcdv_option_value_parm = ggcdv_option_value_parm || BLANK || table_info.columns.column_name (ggcdv_loop); end; end; else ggcdv_option_value_parm = "ERROR"; %skip(1); return; %skip(1); end get_general_column_default_value; %page; get_specific_column_default_value: proc ( gscdv_option_name_parm, /* input: option name */ gscdv_option_identifier_parm, /* input: identifier for name */ gscdv_option_value_parm /* output: value for the option */ ); %skip(3); /* This proc gets the default value of any given column. When called, it expects that gscdv_option_name_parm contains a valid option name and gscdv_option_identifier_parm contains a valid option identifier which has been normalized into a column name. It places the default value in gscdv_option_value_parm. This proc expects that table_info is available and up to date, which means there has to be a set of columns defined. Error conditions are handled by setting the value "ERROR". There should never be any error conditions unless this proc is used incorrectly. */ %skip(1); dcl gscdv_column_option_number fixed bin; dcl gscdv_column_type fixed bin (6) unsigned unaligned; dcl gscdv_hit bit (1) aligned; dcl gscdv_loop fixed bin; dcl gscdv_option_identifier_parm char (*) varying parm; dcl gscdv_option_name_parm char (*) varying parm; dcl gscdv_option_value_parm char (*) varying parm; %skip(1); gscdv_hit = OFF; %skip(1); do gscdv_loop = 1 to number_of_defined_columns while (^gscdv_hit); if table_info.columns.column_name (gscdv_loop) = gscdv_option_identifier_parm then do; gscdv_hit = ON; gscdv_column_option_number = gscdv_loop; end; end; %skip(1); if ^gscdv_hit then do; gscdv_option_value_parm = "ERROR"; return; end; %page; if gscdv_option_name_parm = OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_ALIGNMENT) then do; desc_ptr = addr (table_info.columns.column_data_type ( gscdv_column_option_number)); gscdv_column_type = descriptor.type; if (gscdv_column_type >= 1 & gscdv_column_type <= 8) /* NUMERIC */ | (gscdv_column_type = 33 | gscdv_column_type = 34) then gscdv_option_value_parm = RIGHT; else if (gscdv_column_type >= 9 & gscdv_column_type <= 12) /* DECIMAL */ | (gscdv_column_type = 29 | gscdv_column_type = 30) | (gscdv_column_type = 35 | gscdv_column_type = 36) | (gscdv_column_type >= 38 & gscdv_column_type <= 46) then if fixed (descriptor.size.scale, 17, 0) > 0 then gscdv_option_value_parm = DECIMAL || BLANK || ltrim (char (table_info.columns.column_length (gscdv_column_option_number) - fixed (descriptor.size.scale, 17, 0))); else gscdv_option_value_parm = RIGHT; else if (gscdv_column_type >= 19 & gscdv_column_type <= 22) /* CHAR OR BIT */ then gscdv_option_value_parm = LEFT; else call ssu_$abort_line (sci_ptr, 0, "The table information described an unsupported data type.^/The data descriptor was ^d.", gscdv_column_type); end; else if gscdv_option_name_parm = OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_TITLE) then gscdv_option_value_parm = table_info.columns.column_name (gscdv_column_option_number); else if gscdv_option_name_parm = OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_WIDTH) then gscdv_option_value_parm = ltrim (char (table_info.columns.column_length (gscdv_column_option_number))); else gscdv_option_value_parm = "ERROR"; %skip(1); end get_specific_column_default_value; %page; get_named_values: proc (gnv_code_parm); %skip(3); /* This proc is called by the get_named entrypoint to get the names and values which match a set of option names and identifiers supplied by the caller of the get_named entry. The option name can be a short or long name. The column/option identifier provided can be a column name, column number, or star name. The star names can only match column names; star name matching of column numbers is not attempted. Unfortunately, value_$list has an ugly little quirk of not returning the code error_table_$nomatch when star names result in no match, if any other name in the match_info structure does get a match. So we have to pre-match star names or else user specified star names that don't get a match could well go unnoticed. */ %skip(1); dcl gnv_code_parm fixed bin (35) parm; dcl gnv_current_star_name fixed bin; dcl gnv_inner_loop fixed bin; dcl gnv_loop fixed bin; dcl gnv_match_info_index fixed bin; dcl gnv_number_of_matches fixed bin; %skip(1); gnv_code_parm = 0; %skip(1); alloc_name_count = no_of_options_in_name_table; if valid_selection_expression then alloc_max_name_len = MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH; else alloc_max_name_len = MAXIMUM_OPTION_NAME_LENGTH; %skip(1); star_name_info_ptr = names_and_values_temp_seg_ptr; star_name_info.maximum_number_of_star_names = no_of_options_in_name_table; star_name_info.star_name_map (*) = OFF; star_name_info.number_of_star_names = 1; %skip(1); allocate column_map in (names_and_values_area) set (column_map_ptr); %skip(1); do gnv_loop = 1 to no_of_options_in_name_table; %skip(1); call normalize_option_name ( option_name_table.the_name (gnv_loop), option_name_table.the_identifier (gnv_loop), option_type, option_table_index, normalized_option_name, gnv_code_parm); if gnv_code_parm = 0 then if option_type = SPECIFIC_COLUMN_OPTION then option_name_table.the_identifier (gnv_loop) = after (normalized_option_name, BLANK); else option_name_table.the_identifier (gnv_loop) = ""; else if gnv_code_parm = error_table_$nostars then do; call match_column_names ( option_name_table.the_identifier (gnv_loop), column_map, gnv_number_of_matches, gnv_code_parm); if gnv_code_parm ^= 0 then call ssu_$abort_line (sci_ptr, gnv_code_parm, "^/The column identifier ^a did not match any column names.", option_name_table.the_identifier (gnv_loop)); else; if gnv_number_of_matches ^= 1 then alloc_name_count = alloc_name_count + gnv_number_of_matches - 1; star_name_info.star_name_map (gnv_loop) = ON; star_name_info.column_maps_info ( star_name_info.number_of_star_names) .number_of_matches = gnv_number_of_matches; star_name_info.column_maps_info ( star_name_info.number_of_star_names) .column_bit_map (*) = column_map (*); star_name_info.number_of_star_names = star_name_info.number_of_star_names + 1; end; else if gnv_code_parm = linus_error_$bad_option_name then call ssu_$abort_line (sci_ptr, gnv_code_parm, "^/^a is not a valid option name.", option_name_table.the_name (gnv_loop)); else if gnv_code_parm = linus_error_$bad_option_identifier then call ssu_$abort_line (sci_ptr, gnv_code_parm, "^/^a is not a valid option identifier for ^a.", option_name_table.the_identifier (gnv_loop), option_name_table.the_name (gnv_loop)); else call ssu_$abort_line (sci_ptr, gnv_code_parm); %skip(1); end; %skip(1); star_name_info.number_of_star_names = star_name_info.number_of_star_names - 1; %skip(1); allocate match_info in (names_and_values_area) set (match_info_ptr); match_info.version = match_info_version_1; %skip(1); gnv_match_info_index = 1; gnv_current_star_name = 1; do gnv_loop = 1 to no_of_options_in_name_table; %skip(1); match_info.name_array.exclude_sw (gnv_match_info_index) = OFF; match_info.name_array.regexp_sw (gnv_match_info_index) = OFF; %skip(1); if ^star_name_info.star_name_map (gnv_loop) then do; if option_name_table.the_identifier (gnv_loop) = "" then match_info.name_array.name (gnv_match_info_index) = option_name_table.the_name (gnv_loop); else match_info.name_array.name (gnv_match_info_index) = option_name_table.the_name (gnv_loop) || BLANK || option_name_table.the_identifier (gnv_loop); gnv_match_info_index = gnv_match_info_index + 1; end; else do; column_map_ptr = addr (star_name_info .column_maps_info (gnv_current_star_name) .column_bit_map (1)); do gnv_inner_loop = 1 to number_of_defined_columns; if column_map (gnv_inner_loop) then do; match_info.name_array.name (gnv_match_info_index) = option_name_table.the_name (gnv_loop) || BLANK || table_info.columns.column_name (gnv_inner_loop); gnv_match_info_index = gnv_match_info_index + 1; end; end; gnv_current_star_name = gnv_current_star_name + 1; end; %skip(1); end; %skip(1); call value_$list (value_seg_ptr, PERMANENT, match_info_ptr, names_and_values_area_ptr, value_list_info_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/Unable to get the values of the specified format options."); else; %skip(1); no_of_names_and_values = value_list_info.pair_count; allocate name_value_info in (names_and_values_area) set (names_and_values_info_ptr); %skip(1); do gnv_loop = 1 to no_of_names_and_values; name_value_info.name.length (gnv_loop) = value_list_info.pairs.name_len (gnv_loop); name_value_info.name.index (gnv_loop) = value_list_info.pairs.name_index (gnv_loop); name_value_info.value.length (gnv_loop) = value_list_info.pairs.value_len (gnv_loop); name_value_info.value.index (gnv_loop) = value_list_info.pairs.value_index (gnv_loop); end; %skip(1); size_of_names_and_values = value_list_info.chars_len; allocate names_and_values in (names_and_values_area) set (names_and_values_ptr); names_and_values = value_list_info.chars; %skip(1); return; %skip(1); end get_named_values; %page; housekeeping: proc; %skip(3); /* This procedure is called to set up various automatic versions of some of some things we will need to run this subroutine, and to make sure linus_table$info has been called. */ %skip(1); sci_ptr = lcb.subsystem_control_info_ptr; report_cip = lcb.report_control_info_ptr; value_seg_ptr = report_control_info.value_seg_ptr; names_and_values_area_ptr = report_control_info.name_value_area_ptr; names_and_values_temp_seg_ptr = report_control_info.name_value_temp_seg_ptr; %skip(1); call linus_table$info (lcb_ptr, table_ip, code); if code ^= 0 then if code ^= linus_error_$no_lila_expr_processed then call ssu_$abort_line (sci_ptr, code, "While trying to get table information."); else do; valid_selection_expression = OFF; number_of_defined_columns = 0; end; else do; valid_selection_expression = ON; number_of_defined_columns = table_info.column_count; end; %skip(1); return; %skip(1); end housekeeping; %page; load_value_seg_with_column_defaults: proc; %skip(3); /* This procedure is called to load all of the column default values into the value seg. It expects that table_info has been set and is current (which means there must be a valid selection expression available.) */ %skip(1); dcl lvswcd_inner_loop fixed bin; dcl lvswcd_loop fixed bin; %skip(1); do lvswcd_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE; %skip(1); lvswcd_option_name = OPTIONS.GENERAL_COLUMN.NAME (lvswcd_loop); lvswcd_option_value = OPTIONS.GENERAL_COLUMN.VALUE (lvswcd_loop); if length (lvswcd_option_value) > 0 then if substr (lvswcd_option_value, 1, 1) = LEFT_BRACKET then do; call get_general_column_default_value ( lvswcd_option_name, lvswcd_option_value); if lvswcd_option_value = "ERROR" then call ssu_$abort_line (sci_ptr, 0, "While trying to get the default value for ^a.", lvswcd_option_name); else; end; else; else; %skip(1); call value_$set (value_seg_ptr, PERMANENT, lvswcd_option_name, lvswcd_option_value, returned_option_value, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to set the value ^a for ^a.", lvswcd_option_value, lvswcd_option_name); %skip(1); end; %page; do lvswcd_loop = 1 to NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE; %skip(1); lvswcd_option_name = OPTIONS.SPECIFIC_COLUMN.NAME (lvswcd_loop); %skip(1); do lvswcd_inner_loop = 1 to number_of_defined_columns; %skip(1); lvswcd_option_identifier = table_info.columns.column_name (lvswcd_inner_loop); normalized_option_name = lvswcd_option_name || BLANK || lvswcd_option_identifier; lvswcd_option_value = OPTIONS.SPECIFIC_COLUMN.VALUE (lvswcd_loop); if length (lvswcd_option_value) > 0 then if substr (lvswcd_option_value, 1, 1) = LEFT_BRACKET then do; call get_specific_column_default_value ( lvswcd_option_name, lvswcd_option_identifier, lvswcd_option_value); if lvswcd_option_value = "ERROR" then call ssu_$abort_line (sci_ptr, 0, "While trying to get the default value for ^a.", normalized_option_name); else; end; else; else; %skip(1); call value_$set (value_seg_ptr, PERMANENT, normalized_option_name, lvswcd_option_value, returned_option_value, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to set the value ^a for ^a.", lvswcd_option_value, normalized_option_name); %skip(1); end; %skip(1); end; %skip(1); report_control_info.options_identifier = report_control_info.options_identifier + 1; report_control_info.selection_expression_identifier = lcb.selection_expression_identifier; report_control_info.format_options_flags .general_column_default_value (*) = ON; %skip(1); return; %skip(1); end load_value_seg_with_column_defaults; %page; load_value_seg_with_report_defaults: proc; %skip(3); /* This proc is called to load the value seg with the general report option defaults from the OPTIONS.GENERAL_REPORT table found in the include file linus_format_options.incl.pl1. */ %skip(1); dcl lvswrd_loop fixed bin; %skip(1); do lvswrd_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE; %skip(1); call value_$set (value_seg_ptr, PERMANENT, OPTIONS.GENERAL_REPORT.NAME (lvswrd_loop), OPTIONS.GENERAL_REPORT.VALUE (lvswrd_loop), returned_option_value, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to set the value ^a for ^a.", OPTIONS.GENERAL_REPORT.VALUE (lvswrd_loop), OPTIONS.GENERAL_REPORT.NAME (lvswrd_loop)); %skip(1); end; %skip(1); report_control_info.options_identifier = report_control_info.options_identifier + 1; report_control_info.format_options_flags.general_report_default_value (*) = ON; %skip(1); return; %skip(1); end load_value_seg_with_report_defaults; %page; lookup_option_number: proc ( lon_option_name_parm, /* input: option name to look up */ lon_option_type_parm, /* output: the table to index into */ lon_option_index_parm /* output: the index into the table */ ); %skip(1); /* This proc looks up option names from the three tables of option names. lon_option_name_parm is expected to contain the name of the option. lon_option_type_parm is set to indicate whether it is a general report, general column, or specific column option. lon_option_index_parm is the index into the appropriate table so the caller can obtain its value. */ %skip(1); dcl lon_loop fixed bin; dcl lon_option_name_parm char (*) varying parm; dcl lon_option_type_parm fixed bin parm; dcl lon_option_index_parm fixed bin parm; %skip(1); lon_option_type_parm = 0; %skip(1); lon_option_index_parm = lookup_general_report_option (); if lon_option_index_parm ^= 0 then do; lon_option_type_parm = GENERAL_REPORT_OPTION; return; end; %skip(1); lon_option_index_parm = lookup_general_column_option (); if lon_option_index_parm ^= 0 then do; lon_option_type_parm = GENERAL_COLUMN_OPTION; return; end; %skip(1); lon_option_index_parm = lookup_specific_column_option (); if lon_option_index_parm ^= 0 then lon_option_type_parm = SPECIFIC_COLUMN_OPTION; %skip(1); return; %page; lookup_general_column_option: proc () returns (fixed bin); %skip(1); /* Look up the option name from the general column names table. */ %skip(1); do lon_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE; if lon_option_name_parm = OPTIONS.GENERAL_COLUMN.NAME (lon_loop) then return (lon_loop); end; %skip(1); return (0); %skip(1); end lookup_general_column_option; %skip(3); lookup_general_report_option: proc () returns (fixed bin); %skip(1); /* Look up the option name from the general report names table. */ %skip(1); do lon_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE; if lon_option_name_parm = OPTIONS.GENERAL_REPORT.NAME (lon_loop) then return (lon_loop); end; %skip(1); return (0); %skip(1); end lookup_general_report_option; %skip(3); lookup_specific_column_option: proc () returns (fixed bin); %skip(1); /* Look up the option name from the specific column names table. */ %skip(1); do lon_loop = 1 to NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE; if lon_option_name_parm = OPTIONS.SPECIFIC_COLUMN.NAME (lon_loop) then return (lon_loop); end; %skip(1); return (0); %skip(1); end lookup_specific_column_option; %skip(1); end lookup_option_number; %page; match_column_names: proc ( mcn_star_name_parm, /* input: star name to match */ mcn_column_map_parm, /* input/output: array of match bits */ mcn_number_of_matches_parm, /* output: number of matches */ mcn_code_parm /* output: success or failure */ ); %skip(3); /* This proc is called with a star name to determine which columns match it. The variable mcn_star_name_parm contains the variable which is used to try to get a match. The array mcn_column_map_parm contains one bit for each defined column. Each column that matches the star name has its corresponding bit turned on, and the variable mcn_number_of_matches_parm contains the number of columns that matched. The variable mcn_code_parm is set to reflect any problems encountered. */ %skip(1); dcl mcn_code_parm fixed bin (35) parm; dcl mcn_loop fixed bin; dcl mcn_column_map_parm (*) bit (1) parm; dcl mcn_number_of_matches fixed bin; dcl mcn_number_of_matches_parm fixed bin parm; dcl mcn_star_name_parm char (*) varying parm; %skip(1); mcn_column_map_parm (*) = OFF; mcn_number_of_matches_parm = 0; mcn_code_parm = 0; %skip(1); if hbound (mcn_column_map_parm, 1) ^= number_of_defined_columns then call ssu_$abort_line (sci_ptr, 0, "^a ^a^/^a", "Invalid use of match_column_names by ", me, "The match table was not equal to the number of defined columns."); else; %skip(1); mcn_number_of_matches = 0; do mcn_loop = 1 to number_of_defined_columns; call match_star_name_ ( (table_info.columns.column_name (mcn_loop)), (mcn_star_name_parm), mcn_code_parm); if mcn_code_parm = 0 then do; mcn_column_map_parm (mcn_loop) = ON; mcn_number_of_matches = mcn_number_of_matches + 1; end; else if mcn_code_parm ^= error_table_$nomatch then return; else; end; %skip(1); if mcn_number_of_matches ^= 0 then do; mcn_number_of_matches_parm = mcn_number_of_matches; mcn_code_parm = 0; end; else; %skip(1); return; %skip(1); end match_column_names; %page; normalize_option_name: proc ( non_option_name_parm, /* input: the option name */ non_option_identifier_parm, /* input: the column name or number */ non_option_type_parm, /* output: the type of option */ non_option_table_index_parm, /* output: index into options table */ non_normalized_option_name_parm, /* output: the option and column name */ non_code_parm /* output: success or failure */ ); %skip(1); /* This proc is called to set general purpose info about the option currently being dealt with. It expects non_option_name_parm to contain a name which can be used to determine whether or not it requires an identifier. The option_name must already have been expanded into a long name (see the "check_name" entry for expansion of option names). If an identifier is needed, it expects non_option_identifier_parm to contain it. The identifier can be the name of a column or the position of the column in the LILA select. If the identifier is a star name or invalid, non_code_parm is set. It places the option name into non_normalized_option_name_parm if a column identifier isn't needed, and the option name and column name in it when an identifier is needed. When errors occur normalized_option_name is set to "", except for starnames. The variable non_option_type_parm is set to flag whether it is a general report, general column, or specific column option. The variable non_option_table_index_parm is set so the caller can index into the appropriate options table. */ %skip(1); dcl non_code_parm fixed bin (35) parm; dcl non_column_option_number fixed bin; dcl non_loop fixed bin; dcl non_normalized_option_name_parm char (*) varying parm; dcl non_option_identifier_parm char (*) varying parm; dcl non_option_name_parm char (*) varying parm; dcl non_option_table_index_parm fixed bin parm; dcl non_option_type_parm fixed bin parm; %skip(3); non_normalized_option_name_parm = ""; non_code_parm = 0; %skip(1); call lookup_option_number (non_option_name_parm, non_option_type_parm, non_option_table_index_parm); if non_option_table_index_parm = 0 then do; non_code_parm = linus_error_$bad_option_name; return; end; %skip(1); if (non_option_type_parm = GENERAL_COLUMN_OPTION | non_option_type_parm = SPECIFIC_COLUMN_OPTION) & (^valid_selection_expression) then do; code = linus_error_$no_lila_expr_processed; return; end; else; %skip(1); if non_option_type_parm = GENERAL_REPORT_OPTION | non_option_type_parm = GENERAL_COLUMN_OPTION then do; non_normalized_option_name_parm = non_option_name_parm; return; end; %skip(1); if search (non_option_identifier_parm, STAR_OR_QUESTION_MARK) ^= 0 then do; non_code_parm = error_table_$nostars; non_normalized_option_name_parm = non_option_name_parm || BLANK || non_option_identifier_parm; return; end; %skip(1); if verify (non_option_identifier_parm, DIGITS) = 0 then do; non_column_option_number = convert (non_column_option_number, non_option_identifier_parm); if non_column_option_number < 1 | non_column_option_number > number_of_defined_columns then non_code_parm = linus_error_$bad_option_identifier; else non_normalized_option_name_parm = non_option_name_parm || BLANK || table_info.columns.column_name (non_column_option_number); return; end; %skip(1); do non_loop = 1 to number_of_defined_columns; if non_option_identifier_parm = table_info.columns.column_name (non_loop) then do; non_normalized_option_name_parm = non_option_name_parm || BLANK || non_option_identifier_parm; return; end; end; %skip(1); non_code_parm = linus_error_$bad_option_identifier; %skip(1); return; %skip(1); end normalize_option_name; %page; release_temp_segment: proc ( rts_ptr_parm /* input: ptr to temp segment */ ); %skip(3); dcl rts_code fixed bin (35); dcl rts_ptr_parm ptr parm; %skip(1); call release_temp_segment_ (me, rts_ptr_parm, rts_code); if rts_code ^= 0 then call ssu_$print_message (sci_ptr, rts_code, "While trying to release the temporary segment pointed to by ^/^p.", rts_ptr_parm); %skip(1); return; %skip(1); end release_temp_segment; %page; set_the_values: proc ( stv_option_name_parm, /* input: option name */ stv_option_identifier_parm, /* input: column identifier */ stv_option_value_parm, /* input: option value */ stv_system_default_parm, /* input: on means yes */ stv_code_parm /* output: success or failure */ ); %skip(1); /* This proc is called to set the value of a format option. If the value is a star name then the value is set for every name that matches the star name. The internal proc set_value sets the value. For a normal column name, it is called once with normalized_option_name used for the set operation. For star names, normalized_option_name is changed before each call with a column name that matched the star name. */ %skip(1); dcl stv_code_parm fixed bin (35) parm; dcl stv_loop fixed bin; dcl stv_number_of_matches fixed bin; dcl stv_option_name_parm char (*) varying parm; dcl stv_option_identifier_parm char (*) varying parm; dcl stv_option_value_parm char (*) varying parm; dcl stv_system_default_parm bit (1) aligned parm; dcl stv_value_has_been_tested bit (1) aligned; %skip(1); call normalize_option_name (stv_option_name_parm, stv_option_identifier_parm, option_type, option_table_index, normalized_option_name, stv_code_parm); if stv_code_parm = 0 then do; call set_value (stv_code_parm); return; end; else if stv_code_parm ^= error_table_$nostars then return; %skip(1); allocate column_map in (names_and_values_area) set (column_map_ptr); call match_column_names (stv_option_identifier_parm, column_map, stv_number_of_matches, stv_code_parm); if stv_code_parm ^= 0 then return; %page; do stv_loop = 1 to number_of_defined_columns; %skip(1); if column_map (stv_loop) then do; normalized_option_name = stv_option_name_parm || BLANK || table_info.columns.column_name (stv_loop); call set_value (stv_code_parm); if stv_code_parm ^= 0 then return; end; %skip(1); end; %skip(1); return; %page; set_value: proc ( sv_code_parm /* output: success or failure */ ); %skip(3); /* This proc is called to set the value of a format option. The variable stv_system_default_parm is used to determine if the caller wants the system default value for the named option. normalized_option_name is used to determine who's to be set. stv_option_value_parm is the value which will be set if stv_system_default_parm is off. option_type and option_table_index are used to find the value which will be set when stv_system_default_parm is on. The bit that indicates whether or not a value is the same as the system default is set for the general report and general column options. These bits are used by the get_active entry to determine which values are considered active. If the caller requested that it be set to the system default, the value is set from the OPTIONS table. General column and specific column values from this table sometimes need the actual value computed based on the current set of columns. These values are recognizable because they begin with a left bracket. The procs get_general_column_default_value and get_specific_column_default_value are called to compute the value. There is a dependency between the -group option and the two options -group_footer_trigger and -group_header_trigger. If the -group option is being set back to the default then the function valid_option_value is invoked to make sure the other two are set back to their defaults. */ %skip(3); dcl sv_code_parm fixed bin (35) parm; dcl sv_force_group_triggers_consistency bit (1); %skip(1); sv_code_parm = 0; %skip(1); if ^stv_system_default_parm then do; sv_option_value = stv_option_value_parm; if ^valid_option_value (stv_option_name_parm, sv_option_value) then do; stv_code_parm = linus_error_$bad_option_value; return; end; else; end; else do; if option_type = GENERAL_REPORT_OPTION then do; sv_option_value = OPTIONS.GENERAL_REPORT.VALUE (option_table_index); report_control_info.format_options_flags. general_report_default_value (option_table_index) = ON; end; else if option_type = GENERAL_COLUMN_OPTION then do; sv_option_value = OPTIONS.GENERAL_COLUMN.VALUE (option_table_index); if length (sv_option_value) > 0 then if substr (sv_option_value, 1, 1) = LEFT_BRACKET then call get_general_column_default_value ( stv_option_name_parm, sv_option_value); else; else if stv_option_name_parm = OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP) then sv_force_group_triggers_consistency = valid_option_value (stv_option_name_parm, sv_option_value); else; report_control_info.format_options_flags. general_column_default_value (option_table_index) = ON; end; else do; sv_option_value = OPTIONS.SPECIFIC_COLUMN.VALUE (option_table_index); if length (sv_option_value) > 0 then if substr (sv_option_value, 1, 1) = LEFT_BRACKET then do; sv_spare_option_identifier = after (normalized_option_name, BLANK); call get_specific_column_default_value ( stv_option_name_parm, sv_spare_option_identifier, sv_option_value); end; else; else; end; if sv_option_value = "ERROR" then call ssu_$abort_line (sci_ptr, 0, "Unable to set the value of ^a to the system default.", normalized_option_name); end; %skip(1); call value_$set (value_seg_ptr, PERMANENT, normalized_option_name, sv_option_value, returned_option_value, code); %skip(1); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to set the value ^a for ^a.", sv_option_value, normalized_option_name); %skip(1); report_control_info.options_identifier = report_control_info.options_identifier + 1; %skip(1); if stv_system_default_parm | option_type = SPECIFIC_COLUMN_OPTION then return; %page; if option_type = GENERAL_REPORT_OPTION then do; if sv_option_value = OPTIONS.GENERAL_REPORT.VALUE (option_table_index) then report_control_info.format_options_flags. general_report_default_value (option_table_index) = ON; else report_control_info.format_options_flags. general_report_default_value (option_table_index) = OFF; end; else do; stv_value_has_been_tested = OFF; if length (sv_option_value) > 0 & length (OPTIONS.GENERAL_COLUMN.VALUE (option_table_index)) > 0 then if substr (OPTIONS.GENERAL_COLUMN.VALUE ( option_table_index), 1, 1) = LEFT_BRACKET then do; call get_general_column_default_value ( stv_option_name_parm, sv_spare_option_value); if sv_spare_option_value = "ERROR" then call ssu_$abort_line (sci_ptr, 0, "Unable to get the default value of ^a.", stv_option_name_parm); else; stv_value_has_been_tested = ON; if sv_option_value = sv_spare_option_value then report_control_info.format_options_flags. general_column_default_value (option_table_index) = ON; else report_control_info.format_options_flags. general_column_default_value (option_table_index) = OFF; end; else; else; if ^stv_value_has_been_tested then if sv_option_value = OPTIONS.GENERAL_COLUMN.VALUE (option_table_index) then report_control_info.format_options_flags. general_column_default_value (option_table_index) = ON; else report_control_info.format_options_flags. general_column_default_value (option_table_index) = OFF; else; end; %skip(1); return; %skip(1); end set_value; %skip(1); end set_the_values; %page; setup_to_do_reporting: proc; %skip(3); /* This proc is called to setup all the areas, temp segs, etc. that are needed to produce linus reports through the display request. Each "thing" it needs is described below before it is created. */ %skip(1); sci_ptr = lcb.subsystem_control_info_ptr; %skip(1); /* Create the info structure. */ %skip(1); allocate report_control_info in (lcb.static_area) set (report_cip); unspec (report_control_info) = OFF; %skip(1); /* Create the value segment. */ %skip(1); call hcs_$make_seg (get_pdir_(), "linus_format_options.value", "", REW_ACCESS_BIN, value_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", "While trying to create the options' value segment."); %skip(1); /* Initialize its contents. */ %skip(1); call value_$init_seg (value_seg_ptr, 0, null(), 0, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", "While trying to initialize the options' value segment."); report_control_info.value_seg_ptr = value_seg_ptr; %skip(1); /* Create a temp seg for name-value allocations. Define an area over it. This area will be emptied from now on every time the initialize entrypoint is called, via a call to release_area_. */ %skip(1); call get_temp_segment_ (me, temp_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to create a temporary segment for the options."); names_and_values_area_ptr = temp_seg_ptr; call mdbm_util_$mu_define_area (names_and_values_area_ptr, (sys_info$max_seg_size), "options.LIN", EXTENSIBLE, NON_FREEING, NO_ZERO_ON_ALLOC, NO_ZERO_ON_FREE, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to define an area for allocations of options."); report_control_info.name_value_area_ptr = names_and_values_area_ptr; %skip(1); /* Create a temp seg for star name processing and other temp operations. */ %skip(1); call get_temp_segment_ (me, temp_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to create a temporary segment for the options."); report_control_info.name_value_temp_seg_ptr = temp_seg_ptr; %skip(1); /* Create a temp seg/area for display work space. */ %skip(1); call get_temp_segment_ (me, temp_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to create a temporary segment for the options."); call mdbm_util_$mu_define_area (temp_seg_ptr, (sys_info$max_seg_size), "display.LIN", EXTENSIBLE, NON_FREEING, NO_ZERO_ON_ALLOC, NO_ZERO_ON_FREE, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to define an area for allocations for display."); report_control_info.display_work_area_ptr = temp_seg_ptr; %skip(1); /* Create a temp seg for holding the formatted page. */ %skip(1); call get_temp_segment_ (me, temp_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to create a temporary segment for the report."); report_control_info.report_temp_seg_ptr = temp_seg_ptr; %skip(1); /* Create a temp seg for report allocations. Define an area over it. */ %skip(1); call get_temp_segment_ (me, temp_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to create a temporary segment for the report."); call mdbm_util_$mu_define_area (temp_seg_ptr, (sys_info$max_seg_size), "options.LIN", EXTENSIBLE, NON_FREEING, NO_ZERO_ON_ALLOC, NO_ZERO_ON_FREE, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to define an area for allocations of report information."); report_control_info.report_work_area_ptr = temp_seg_ptr; %skip(1); /* Create 4 temp segs for report building workspace. */ %skip(1); call get_temp_segment_ (me, temp_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to create a temporary segment for the report."); report_control_info.input_string_temp_seg_ptr = temp_seg_ptr; %skip(1); call get_temp_segment_ (me, temp_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to create a temporary segment for the report."); report_control_info.output_string_temp_seg_ptr = temp_seg_ptr; %skip(1); call get_temp_segment_ (me, temp_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to create a temporary segment for the report."); report_control_info.editing_strings_temp_seg_ptr = temp_seg_ptr; %skip(1); call get_temp_segment_ (me, temp_seg_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to create a temporary segment for the report."); report_control_info.headers_temp_seg_ptr = temp_seg_ptr; %skip(1); /* Set a few values so we start cleanly */ %skip(1); report_control_info.format_report_info_ptr = null (); report_control_info.display_iocb_ptr = null (); report_control_info.temp_dir_name = get_pdir_ (); allocate status_branch in (names_and_values_area) set (status_ptr); call expand_pathname_ (report_control_info.temp_dir_name, directory_name, entry_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to expand ^a.", report_control_info.temp_dir_name); call hcs_$status_long (directory_name, entry_name, 1, status_ptr, null (), code); if code ^= 0 & code ^= error_table_$no_s_permission then call ssu_$abort_line (sci_ptr, code, "While trying to determine the unique id of ^a.", report_control_info.temp_dir_name); report_control_info.temp_dir_unique_id = status_branch.long.uid; %skip(1); return; %skip(1); end setup_to_do_reporting; %page; valid_option_value: proc ( vov_option_name_parm, /* input: option name */ vov_option_value_parm /* input: option value */ ) returns (bit (1)); %skip(3); /* This function is invoked to check the value for an option. It expects that vov_option_name_parm contains a valid option name which has been expanded, and that vov_option_value_parm contains the value to check for validity. This function calls an internal procedure to do the checking. These internal procedures are declared in the three tables immediately following this description. If it is a valid value, "1"b is returned. "0"b indicates an invalid value. */ %skip(1); dcl vov_any_or_all bit (1) aligned; dcl vov_check_result_bit bit (1) aligned; %skip(1); dcl vov_check_procs_for_general_report_options (NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE) entry init ( check_any_single_printable_character, /* "-delimiter" */ check_on_or_off, /* "-format_document_controls" */ check_on_or_off, /* "-hyphenation" */ check_any_character_string, /* "-page_footer_value" */ check_any_character_string, /* "-page_header_value" */ check_zero_or_greater_than_six, /* "-page_length" */ check_zero_or_any_positive_integer, /* "-page_width" */ check_on_or_off, /* "-title_line" */ check_any_printable_string_no_NL /* "-truncation" */ ); %skip(1); dcl vov_check_procs_for_general_column_options (NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE) entry init ( check_all_column_names_eventually, /* "-column_order" */ check_any_column_names_or_none, /* "-count" */ check_any_column_names_or_none, /* "-exclude" */ check_and_keep_triggers_consistent, /* "-group" */ check_any_valid_group_list, /* "-group_footer_trigger" */ check_any_character_string, /* "-group_footer_value" */ check_any_valid_group_list, /* "-group_header_trigger" */ check_any_character_string, /* "-group_header_value" */ check_any_column_names_or_none, /* "-outline" */ check_any_column_names_or_none, /* "-page_break" */ check_any_character_string, /* "-row_footer_value" */ check_any_character_string, /* "-row_header_value" */ check_subcount_list_or_none, /* "-subcount" */ check_subtotal_list_or_none, /* "-subtotal" */ check_any_column_names_or_none /* "-total" */ ); %skip(1); dcl vov_check_procs_for_specific_column_options (NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE) entry init ( check_any_alignment_mode, /* "-alignment" */ check_any_character_string, /* "-editing" */ check_any_folding_action, /* "-folding" */ check_any_printable_string_no_NL, /* "-separator" */ check_any_character_string, /* "-title" */ check_any_positive_integer /* "-width" */ ); %skip(1); dcl vov_character_string char (80) varying; dcl vov_complete_the_list bit (1) aligned; dcl vov_loop fixed bin; dcl vov_loop_limit fixed bin; dcl vov_number_tester fixed bin; dcl vov_one_to_nine_found bit (1) aligned; dcl vov_option_name_parm char (*) varying parm; dcl vov_option_value_parm char (*) varying parm; dcl vov_target_character char (1); %skip(3); vov_check_result_bit = OFF; %skip(1); call lookup_option_number (vov_option_name_parm, option_type, option_table_index); if option_table_index = 0 then return (OFF); %skip(1); if option_type = GENERAL_REPORT_OPTION then call vov_check_procs_for_general_report_options (option_table_index); else if option_type = GENERAL_COLUMN_OPTION then call vov_check_procs_for_general_column_options (option_table_index); else call vov_check_procs_for_specific_column_options (option_table_index); %skip(1); return (vov_check_result_bit); %page; check_all_column_names_eventually: proc; %skip(3); vov_any_or_all = ANY; vov_complete_the_list = ON; vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr); %skip(1); return; %skip(1); end check_all_column_names_eventually; %page; check_and_keep_triggers_consistent: proc; %skip(1); dcl caktc_group_list_ptr ptr; dcl caktc_inner_loop fixed bin; dcl caktc_loop fixed bin; %skip(3); if vov_option_value_parm = "" then do; do caktc_loop = INDEX_FOR_GROUP_HEADER_TRIGGER, INDEX_FOR_GROUP_FOOTER_TRIGGER; call value_$set (value_seg_ptr, PERMANENT, OPTIONS.GENERAL_COLUMN.NAME (caktc_loop), OPTIONS.GENERAL_COLUMN.VALUE (caktc_loop), returned_option_value, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to set the value ^a for ^a.", OPTIONS.GENERAL_COLUMN.NAME (caktc_loop), OPTIONS.GENERAL_COLUMN.VALUE (caktc_loop)); report_control_info.format_options_flags. general_column_default_value (caktc_loop) = ON; end; vov_check_result_bit = ON; return; end; %skip(1); vov_any_or_all = ANY; vov_complete_the_list = OFF; vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr); if ^vov_check_result_bit then return; %skip(1); caktc_group_list_ptr = judgement_table_ptr; caktc_option_value = vov_option_value_parm; do caktc_loop = INDEX_FOR_GROUP_HEADER_TRIGGER, INDEX_FOR_GROUP_FOOTER_TRIGGER; call value_$get (value_seg_ptr, PERMANENT, OPTIONS.GENERAL_COLUMN.NAME (caktc_loop), vov_option_value_parm, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to get the value of ^a.", OPTIONS.GENERAL_COLUMN.NAME (caktc_loop)); if vov_option_value_parm ^= "" then do; vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr); do caktc_inner_loop = 1 to number_of_defined_columns; if judgement_table.present (caktc_inner_loop) then if ^(caktc_group_list_ptr -> judgement_table.present (caktc_inner_loop)) then judgement_table.present (caktc_inner_loop) = OFF; else; else; end; vov_option_value_parm = ""; do caktc_inner_loop = 1 to number_of_defined_columns; if judgement_table.present (caktc_inner_loop) then vov_option_value_parm = vov_option_value_parm || table_info.columns (caktc_inner_loop).column_name || BLANK; else; end; vov_option_value_parm = rtrim (vov_option_value_parm); call value_$set (value_seg_ptr, PERMANENT, OPTIONS.GENERAL_COLUMN.NAME (caktc_loop), vov_option_value_parm, returned_option_value, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to set the value ^a for ^a.", vov_option_value_parm, OPTIONS.GENERAL_COLUMN.NAME (caktc_loop)); if vov_option_value_parm = "" then report_control_info.format_options_flags. general_column_default_value (caktc_loop) = ON; end; end; %skip(1); vov_check_result_bit = ON; vov_option_value_parm = caktc_option_value; %skip(1); return; %skip(1); end check_and_keep_triggers_consistent; %page; check_any_alignment_mode: proc; %skip(3); if vov_option_value_parm = RIGHT | vov_option_value_parm = LEFT | vov_option_value_parm = CENTER | vov_option_value_parm = BOTH then vov_check_result_bit = ON; else do; vov_character_string = before (vov_option_value_parm, BLANK); if vov_character_string ^= DECIMAL then return; vov_character_string = ltrim (rtrim (after (vov_option_value_parm, DECIMAL))); if verify (vov_character_string, DIGITS) = 0 then if convert (vov_loop, vov_character_string) ^= 0 then vov_check_result_bit = ON; else; else; end; %skip(1); return; %skip(1); end check_any_alignment_mode; %page; check_any_character_string: proc; %skip(3); vov_check_result_bit = ON; %skip(1); return; %skip(1); end check_any_character_string; %skip(1); check_any_column_names_or_none: proc; %skip(3); if vov_option_value_parm = "" then do; vov_check_result_bit = ON; return; end; vov_any_or_all = ANY; vov_complete_the_list = OFF; vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr); %skip(1); return; %skip(1); end check_any_column_names_or_none; %skip(3); check_any_folding_action: proc; %skip(3); if vov_option_value_parm = FILL | vov_option_value_parm = TRUNCATE then vov_check_result_bit = ON; %skip(1); return; %skip(1); end check_any_folding_action; %page; check_any_printable_string_no_NL: proc; %skip(3); vov_loop_limit = length (vov_option_value_parm); if vov_loop_limit = 0 then do; vov_check_result_bit = ON; return; end; do vov_loop = 1 to vov_loop_limit; vov_target_character = substr (vov_option_value_parm, vov_loop, 1); if vov_target_character < BLANK | vov_target_character > TILDE then return; end; vov_check_result_bit = ON; %skip(1); return; %skip(1); end check_any_printable_string_no_NL; %skip(3); check_any_single_printable_character: proc; %skip(3); if length (vov_option_value_parm) = 1 then if vov_option_value_parm >= BLANK & vov_option_value_parm <= TILDE then vov_check_result_bit = ON; else; else; %skip(1); return; %skip(1); end check_any_single_printable_character; %page; check_any_positive_integer: proc; %skip(3); vov_loop_limit = length (vov_option_value_parm); if vov_loop_limit = 0 then return; vov_one_to_nine_found = OFF; do vov_loop = 1 to vov_loop_limit; vov_target_character = substr (vov_option_value_parm, vov_loop, 1); if vov_target_character < ZERO | vov_target_character > NINE then return; if vov_target_character ^= ZERO then vov_one_to_nine_found = ON; end; if vov_one_to_nine_found then vov_check_result_bit = ON; %skip(1); return; %skip(1); end check_any_positive_integer; %page; check_any_valid_group_list: proc; %skip(1); dcl cavgl_group_list_judgement_table_ptr ptr; dcl cavgl_loop fixed bin; %skip(3); if vov_option_value_parm = "" then do; vov_check_result_bit = ON; return; end; vov_any_or_all = ANY; vov_complete_the_list = OFF; vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr); if ^vov_check_result_bit then return; cavgl_group_list_judgement_table_ptr = judgement_table_ptr; cavgl_save_option_value = vov_option_value_parm; call value_$get (value_seg_ptr, PERMANENT, OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP), vov_option_value_parm, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While trying to get the value of ^a.", OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP)); vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr); if ^vov_check_result_bit then return; vov_option_value_parm = cavgl_save_option_value; vov_check_result_bit = OFF; %skip(1); do cavgl_loop = 1 to number_of_defined_columns; if cavgl_group_list_judgement_table_ptr -> judgement_table.present (cavgl_loop) then if ^judgement_table.present (cavgl_loop) then return; else; else; end; vov_check_result_bit = ON; %skip(1); return; %skip(1); end check_any_valid_group_list; %page; check_on_or_off: proc; %skip(3); if vov_option_value_parm = "on" | vov_option_value_parm = "off" then vov_check_result_bit = ON; %skip(1); return; %skip(1); end check_on_or_off; %page; check_subcount_list_or_none: proc; %skip(3); if vov_option_value_parm = "" then do; vov_check_result_bit = ON; return; end; %skip(1); vov_check_result_bit = replace_subtotal_list_after_checking (ALLOW_DUPLICATES); %skip(1); return; %skip(1); end check_subcount_list_or_none; %skip(3); check_subtotal_list_or_none: proc; %skip(3); if vov_option_value_parm = "" then do; vov_check_result_bit = ON; return; end; %skip(1); vov_check_result_bit = replace_subtotal_list_after_checking (DONT_ALLOW_DUPLICATES); %skip(1); return; %skip(1); end check_subtotal_list_or_none; %skip(3); check_zero_or_any_positive_integer: proc; %skip(3); if verify (vov_option_value_parm, DIGITS) = 0 then vov_check_result_bit = ON; %skip(1); return; %skip(1); end check_zero_or_any_positive_integer; %page; check_zero_or_greater_than_six: proc; %skip(3); if verify (vov_option_value_parm, DIGITS) = 0 then do; vov_number_tester = convert (vov_number_tester, vov_option_value_parm); if vov_number_tester = 0 | vov_number_tester > 6 then vov_check_result_bit = ON; end; %skip(1); return; %skip(1); end check_zero_or_greater_than_six; %page; replace_column_list_after_checking: proc ( rclac_judgement_table_ptr_parm /* output: points to the judgement table */ ) returns (bit(1)); %skip(3); /* This proc is called to check a list of columns, which may be given as column names or numbers, and then create a new list containing only column names if the check proved sucessful. It expects that vov_option_value_parm contains the list of columns. The variable vov_any_or_all_parm dictates what type of checking is done. Since the time when this code was written the restriction of having all columns named in a "-column_order" option was removed, but this subroutine still provides the service of validating that all columns are present in a list because it is felt an additional option which has this requirement may be added sometime in the future. If the check proves sucessfull, vov_option_value_parm is replaced with a list of column names, and "1"b is returned. An unsucessful check returns "0"b and the value of vov_option_value_parm isn't set. If the variable vov_complete_the_list is on the list is filled in with any missing columns; if it is off the list will only contain the names of the columns found. The judgment_table structure if filled in to describe the original list found. Each bit turned on indicates that particular column was found in the list and the number field of the structure indicates where in the list it was found. */ %skip(1); dcl rclac_code fixed bin (35); dcl rclac_column_name_length fixed bin; dcl rclac_current_position fixed bin; dcl rclac_finished bit (1) aligned; dcl rclac_first_blank fixed bin; dcl rclac_hit bit (1) aligned; dcl rclac_inner_loop fixed bin; dcl 1 rclac_judgement_table (number_of_defined_columns) like judgement_table based (rclac_judgement_table_ptr); dcl rclac_judgement_table_ptr ptr; dcl rclac_judgement_table_ptr_parm ptr parm; dcl rclac_loop fixed bin; dcl rclac_no_of_claimed_digits fixed bin; dcl rclac_spare_option_value_length fixed bin; dcl rclac_still_skipping_blanks bit (1) aligned; dcl rclac_target_character char (1); %skip(1); rclac_judgement_table_ptr_parm = null (); if vov_option_value_parm = "" then return (OFF); %skip(1); rclac_spare_option_value = ltrim (rtrim (translate (vov_option_value_parm, BLANK, TAB))) || BLANK; rclac_spare_option_value_length = length (rclac_spare_option_value); rclac_current_position = 1; %skip(1); allocate rclac_judgement_table in (names_and_values_area) set (rclac_judgement_table_ptr); unspec (rclac_judgement_table) = OFF; %skip(1); rclac_finished = OFF; %skip(1); do rclac_loop = 1 to number_of_defined_columns while (^rclac_finished); %skip(1); rclac_first_blank = index (substr (rclac_spare_option_value, rclac_current_position), BLANK) + rclac_current_position - 1; if rclac_first_blank >= rclac_spare_option_value_length then if rclac_loop ^= number_of_defined_columns & vov_any_or_all = ALL then return (OFF); else rclac_finished = ON; else; %skip(1); rclac_target_character = substr (rclac_spare_option_value, rclac_current_position, 1); if rclac_target_character >= ZERO & rclac_target_character <= NINE then do; rclac_no_of_claimed_digits = rclac_first_blank - rclac_current_position; if rclac_no_of_claimed_digits < 1 then return (OFF); %skip(1); rclac_judgement_table.number (rclac_loop) = cv_dec_check_ (substr (rclac_spare_option_value, rclac_current_position, rclac_no_of_claimed_digits), rclac_code); if rclac_code ^= 0 then return (OFF); %skip(1); if rclac_judgement_table.number (rclac_loop) < 1 | rclac_judgement_table.number (rclac_loop) > number_of_defined_columns then return (OFF); end; else do; rclac_hit = OFF; rclac_column_name_length = rclac_first_blank - rclac_current_position; %skip(1); do rclac_inner_loop = 1 to number_of_defined_columns while (^rclac_hit); if substr (rclac_spare_option_value, rclac_current_position, rclac_column_name_length) = table_info.columns.column_name (rclac_inner_loop) then rclac_hit = ON; end; %skip(1); if ^rclac_hit then return (OFF); else rclac_judgement_table.number (rclac_loop) = rclac_inner_loop - 1; end; %skip(1); if rclac_judgement_table.present (rclac_judgement_table.number (rclac_loop)) then return (OFF); %skip(1); rclac_judgement_table.present ( rclac_judgement_table.number (rclac_loop)) = ON; %skip(1); if ^rclac_finished then do; rclac_still_skipping_blanks = ON; rclac_current_position = rclac_first_blank + 1; do while (rclac_still_skipping_blanks); if substr (rclac_spare_option_value, rclac_current_position, 1) ^= BLANK then rclac_still_skipping_blanks = OFF; else rclac_current_position = rclac_current_position + 1; end; if rclac_current_position < rclac_spare_option_value_length & rclac_loop >= number_of_defined_columns then return (OFF); end; end; %skip(1); if vov_any_or_all = ALL then do rclac_loop = 1 to number_of_defined_columns; if ^rclac_judgement_table.present (rclac_loop) then return (OFF); end; %skip(1); rclac_spare_option_value = ""; %skip(1); do rclac_loop = 1 to number_of_defined_columns; if rclac_judgement_table.number (rclac_loop) ^= 0 then rclac_spare_option_value = rclac_spare_option_value || table_info.columns.column_name ( rclac_judgement_table.number (rclac_loop)) || BLANK; end; %skip(1); if vov_complete_the_list then do rclac_loop = 1 to number_of_defined_columns; if ^rclac_judgement_table.present (rclac_loop) then rclac_spare_option_value = rclac_spare_option_value || table_info.columns.column_name (rclac_loop) || BLANK; end; %skip(1); vov_option_value_parm = rtrim (rclac_spare_option_value); rclac_judgement_table_ptr_parm = rclac_judgement_table_ptr; %skip(1); return (ON); %skip(1); end replace_column_list_after_checking; %page; replace_subtotal_list_after_checking: proc (rslac_allow_duplicates_parm) returns (bit(1)); %skip(3); /* This proc is called to check a list of subtotal triplets, and then create a new list if the check proved successful. The syntax of a triplet is "column_1,column_2{,reset|running}". Each triplet is separated by whitespace. column_N can be given as a column name or column number. It expects that vov_option_value_parm contains the list of subtotal triplets. If the check proves successful, vov_option_value_parm is replaced with a list of triplets which has each column number replaced by the column name, and the optional third portion of a triplet filled in. A single blank separates each triplet in the new list. */ %skip(1); dcl rslac_allow_duplicates_parm bit (1) aligned parm; dcl rslac_blank_position fixed bin; dcl rslac_code fixed bin (35); dcl rslac_current_position fixed bin; dcl rslac_original_option_value_length fixed bin; dcl rslac_still_parsing bit (1) aligned; %skip(1); if vov_option_value_parm = "" then return (OFF); %skip(1); rslac_original_option_value = ltrim (rtrim (translate (vov_option_value_parm, BLANK, TAB))) || BLANK; rslac_original_option_value_length = length (rslac_original_option_value); rslac_result_option_value = ""; rslac_current_position = 1; rslac_still_parsing = ON; %skip(1); do while (rslac_still_parsing); call get_triplet (rslac_code); if rslac_code = 0 then call parse_triplet (rslac_allow_duplicates_parm, rslac_code); end; %skip(1); if rslac_code ^= 0 then return (OFF); %skip(1); vov_option_value_parm = rtrim (rslac_result_option_value); %skip(1); return (ON); %page; get_triplet: proc (gt_code_parm); %skip(3); dcl gt_code_parm fixed bin (35) parm; dcl gt_still_skipping_blanks bit (1) aligned; %skip(1); gt_code_parm = 0; rslac_blank_position = index (substr (rslac_original_option_value, rslac_current_position), BLANK); rslac_triplet = substr (rslac_original_option_value, rslac_current_position, rslac_blank_position - 1); rslac_current_position = rslac_current_position + rslac_blank_position; %skip(1); if rslac_current_position >= rslac_original_option_value_length then rslac_still_parsing = OFF; else do; gt_still_skipping_blanks = ON; do while (gt_still_skipping_blanks); if substr (rslac_original_option_value, rslac_current_position, 1) = BLANK then rslac_current_position = rslac_current_position + 1; else gt_still_skipping_blanks = OFF; end; end; %skip(1); return; %skip(1); end get_triplet; %page; parse_triplet: proc ( pt_allow_duplicates_parm, /* input: on means allow duplicate definitions, a subtotal can also "watch" itself */ pt_code_parm /* output: success or failure */ ); %skip(3); dcl pt_allow_duplicates_parm bit (1) aligned parm; dcl pt_character_string char (80) varying; dcl pt_code_parm fixed bin (35) parm; dcl pt_column_number fixed bin; dcl pt_comma_position fixed bin; dcl pt_current_position fixed bin; dcl pt_first_column_found fixed bin; dcl pt_hit bit (1) aligned; dcl pt_inner_loop fixed bin; dcl pt_loop fixed bin; dcl pt_second_column_found fixed bin; dcl pt_triplet_length fixed bin; %skip(1); pt_code_parm = 1; pt_triplet_length = length (rslac_triplet); pt_current_position = 1; %skip(1); do pt_loop = 1 to 2; pt_comma_position = index (substr (rslac_triplet, pt_current_position), COMMA); if pt_comma_position = 0 then if pt_loop = 1 then return; else pt_comma_position = pt_triplet_length + 2 - pt_current_position; else; pt_character_string = substr (rslac_triplet, pt_current_position, pt_comma_position - 1); pt_current_position = pt_current_position + pt_comma_position; if pt_current_position > pt_triplet_length & pt_loop = 1 then return; if verify (pt_character_string, DIGITS) = 0 then do; pt_column_number = convert (pt_column_number, pt_character_string); if pt_column_number < 1 | pt_column_number > number_of_defined_columns then return; else; rslac_result_option_value = rslac_result_option_value || table_info.columns.column_name (pt_column_number) || COMMA; if pt_loop = 1 then pt_first_column_found = pt_column_number; else pt_second_column_found = pt_column_number; end; else do; pt_hit = OFF; do pt_inner_loop = 1 to number_of_defined_columns while (^pt_hit); if pt_character_string = table_info.columns.column_name (pt_inner_loop) then do; pt_hit = ON; pt_column_number = pt_inner_loop; end; end; if ^pt_hit then return; else; if pt_loop = 1 then pt_first_column_found = pt_column_number; else pt_second_column_found = pt_column_number; rslac_result_option_value = rslac_result_option_value || pt_character_string || COMMA; end; end; %skip(1); if ^pt_allow_duplicates_parm then if pt_first_column_found = pt_second_column_found then return; else; else; %skip(1); if pt_current_position >= pt_triplet_length then rslac_result_option_value = rslac_result_option_value || RESET || BLANK; else do; pt_character_string = substr (rslac_triplet, pt_current_position); if pt_character_string = RESET then rslac_result_option_value = rslac_result_option_value || RESET || BLANK; else if pt_character_string = RUNNING then rslac_result_option_value = rslac_result_option_value || RUNNING || BLANK; else return; end; %skip(1); pt_code_parm = 0; %skip(1); return; %skip(1); end parse_triplet; %skip(1); end replace_subtotal_list_after_checking; %skip(1); end valid_option_value; %page; %skip(1); dcl ALL bit (1) aligned static int options (constant) init ("1"b); dcl ALLOW_DUPLICATES bit (1) aligned static int options (constant) init ("1"b); dcl ANY bit (1) aligned static int options (constant) init ("0"b); %skip(1); dcl BLANK char (1) static int options (constant) init (" "); dcl BOTH char (4) static int options (constant) init ("both"); %skip(1); dcl CENTER char (6) static int options (constant) init ("center"); dcl COMMA char (1) static int options (constant) init (","); %skip(1); dcl DECIMAL char (7) static int options (constant) init ("decimal"); dcl DIGITS char (10) static int options (constant) init ("0123456789"); dcl DONT_ALLOW_DUPLICATES bit (1) aligned static int options (constant) init ("0"b); %skip(1); dcl EXTENSIBLE bit (1) aligned static int options (constant) init ("1"b); %skip(1); dcl FILL char (4) static int options (constant) init ("fill"); %skip(1); dcl LEFT char (4) static int options (constant) init ("left"); dcl LEFT_BRACKET char (1) static int options (constant) init ("["); %skip(1); dcl NINE char (1) static int options (constant) init ("9"); dcl NO_ZERO_ON_ALLOC bit (1) aligned static int options (constant) init ("0"b); dcl NO_ZERO_ON_FREE bit (1) aligned static int options (constant) init ("0"b); dcl NON_FREEING bit (1) aligned static int options (constant) init ("1"b); %skip(1); dcl OFF bit (1) aligned static int options (constant) init ("0"b); dcl ON bit (1) aligned static int options (constant) init ("1"b); %skip(1); dcl PERMANENT bit (36) aligned static int options (constant) init ("01"b); %skip(1); dcl RESET char (5) static int options (constant) init ("reset"); dcl RIGHT char (5) static int options (constant) init ("right"); dcl RUNNING char (7) static int options (constant) init ("running"); %skip(1); dcl STAR_OR_QUESTION_MARK char (2) static int options (constant) init ("*?"); dcl STAR_DOT_STAR_STAR char (4) static int options (constant) init ("*.**"); %skip(1); dcl TAB char (1) static int options (constant) init (" "); dcl TILDE char (1) static int options (constant) init ("~"); dcl TRUNCATE char (8) static int options (constant) init ("truncate"); %skip(1); dcl ZERO char (1) static int options (constant) init ("0"); %page; dcl addr builtin; dcl after builtin; %skip(1); dcl before builtin; %skip(1); dcl caktc_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl cavgl_save_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl char builtin; dcl code fixed bin (35); dcl column_map (number_of_defined_columns) bit (1) based (column_map_ptr); dcl column_map_ptr ptr; dcl convert builtin; dcl cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35)); %skip(1); dcl delete_$ptr entry (ptr, bit(6), char(*), fixed bin(35)); dcl directory_name char (168); dcl divide builtin; %skip(1); dcl entry_name char (32); dcl error_table_$no_s_permission fixed bin(35) ext static; dcl error_table_$nomatch fixed bin(35) ext static; dcl error_table_$nostars fixed bin(35) ext static; dcl error_table_$oldnamerr fixed bin(35) ext static; dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); %skip(1); dcl fixed builtin; %skip(1); dcl general_columns_names_and_values_info_ptr ptr; dcl general_report_names_and_values_info_ptr ptr; dcl get_pdir_ entry() returns(char(168)); dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35)); %skip(1); dcl hbound builtin; dcl hcs_$make_seg entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)); dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); %skip(1); dcl index builtin; %skip(1); dcl 1 judgement_table (number_of_defined_columns) aligned based (judgement_table_ptr), 2 present bit (1), 2 number fixed bin (35); dcl judgement_table_ptr ptr; %skip(1); dcl length builtin; dcl 1 like_name_value_info (no_of_active_names_and_values) based (like_names_and_values_info_ptr) like name_value_info; dcl like_names_and_values_info_ptr ptr; dcl linus_error_$bad_option_identifier fixed bin(35) ext static; dcl linus_error_$bad_option_name fixed bin(35) ext static; dcl linus_error_$bad_option_value fixed bin(35) ext static; dcl linus_error_$no_lila_expr_processed fixed bin(35) ext static; dcl linus_fr_delete_report entry (ptr, fixed bin(35)); dcl match_star_name_ entry (char(*), char(*), fixed bin(35)); dcl linus_table$info entry (ptr, ptr, fixed bin (35)); dcl long_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying; dcl ltrim builtin; dcl lvswcd_option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying; dcl lvswcd_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying; dcl lvswcd_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; %skip(1); dcl max builtin; dcl me char (64); dcl mdbm_util_$mu_define_area entry (ptr, fixed bin(18), char(11), bit(1) aligned, bit(1) aligned, bit(1) aligned, bit(1) aligned, fixed bin(35)); %skip(1); dcl names_and_values_area area (sys_info$max_seg_size) based (names_and_values_area_ptr); dcl names_and_values_area_ptr ptr; dcl names_and_values_bit_map (no_of_names_and_values_in_bit_map) bit (1) based (names_and_values_bit_map_ptr); dcl names_and_values_bit_map_ptr ptr; dcl names_and_values_temp_seg_ptr ptr; dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying; dcl no_of_active_names_and_values fixed bin; dcl no_of_names_and_values_in_bit_map fixed bin; dcl null builtin; dcl number_of_defined_columns fixed bin; %skip(1); dcl option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying; dcl option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying; dcl option_table_index fixed bin; dcl option_type fixed bin; dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; %skip(1); dcl rel builtin; dcl release_area_ entry (ptr); dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl returned_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl rclac_spare_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl rslac_original_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl rslac_result_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl rslac_triplet char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl search builtin; dcl specific_columns_names_and_values_info_ptr ptr; dcl 1 star_name_info based (star_name_info_ptr), 2 maximum_number_of_star_names fixed bin, 2 number_of_star_names fixed bin, 2 star_name_map (maximum_number_of_star_names) bit (1), 2 column_maps_info (number_of_star_names), 3 number_of_matches fixed bin, 3 column_bit_map (number_of_defined_columns) bit (1); dcl star_name_info_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$print_message entry() options(variable); dcl substr builtin; dcl sv_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl sv_spare_option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying; dcl sv_spare_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl sys_info$max_seg_size fixed bin(35) ext static; dcl system_default bit (1) aligned; %skip(1); dcl temp_seg_ptr ptr; dcl translate builtin; %skip(1); dcl unspec builtin; %skip(1); dcl valid_selection_expression bit (1) aligned; dcl value_seg_ptr ptr; dcl value_$delete entry (ptr, bit(36) aligned, char(*), fixed bin(35)); dcl value_$init_seg entry (ptr, fixed bin, ptr, fixed bin(19), fixed bin(35)); dcl value_$get entry() options(variable); dcl value_$list entry (ptr, bit(36) aligned, ptr, ptr, ptr, fixed bin(35)); dcl value_$set entry() options(variable); dcl verify builtin; %skip(1); %page; %include access_mode_values; %page; %include arg_descriptor; %page; %include arg_list; %page; %include linus_format_options; %page; %include linus_lcb; %page; %include linus_names_and_values; %page; %include linus_options_extents; %page; %include linus_report_info; %page; %include linus_table_info; %page; %include mdbm_descriptor; %page; %include status_structures; %page; %include value_structures; %skip(3); end linus_options;  linus_parse_file.pl1 03/16/88 0829.7r w 03/15/88 1553.6 203202 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the subroutine called by the linus store and store_from_data_file requests to implement the file parsing. Description and usage follows. Description: This subroutine has the following entrypoints. start called as the first thing the request does. Usage: "call linus_parse_file$start (lcb_ptr, addr (data_file_info), table_info_ptr, code);" stop called as the last thing the request does. Usage: "call linus_parse_file$stop (lcb_ptr, addr (data_file_info), table_info_ptr, cleanup_signalled, code);" get_row called to get a row from the file and place in row value slot. Usage: "call linus_parse_file$get_row (lcb_ptr, addr (data_file_info), table_info_ptr, row_value_ptr, code);" Known Bugs: Other Problems: History: Written - Al Dupuis - September 1983. */ %page; linus_parse_file: proc; %skip(3); /* These parms are described at each entry where they are used. */ %skip(3); dcl code_parm fixed bin (35) parm; dcl cleanup_signalled_parm bit (1) aligned parm; dcl data_file_info_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; dcl row_value_ptr_parm ptr parm; dcl table_info_ptr_parm ptr parm; %skip(3); return; %page; get_row: entry ( lcb_ptr_parm, /* input: ptr to the linus control block */ data_file_info_ptr_parm, /* input: ptr to data_file_info structure */ table_info_ptr_parm, /* input: ptr to table_info structure */ row_value_ptr_parm, /* input: ptr to row value char string */ code_parm /* output: success or failure */ ); %skip(1); lcb_ptr = lcb_ptr_parm; file_info_ptr = data_file_info_ptr_parm; table_ip = table_info_ptr_parm; row_value_p = row_value_ptr_parm; code_parm = 0; %skip(1); call fill_the_buffer (code_parm); if code_parm = 0 then call get_the_row (code_parm); %skip(1); return; %page; start: entry ( lcb_ptr_parm, /* input: ptr to the linus control block */ data_file_info_ptr_parm, /* input: ptr to data_file_info structure */ table_info_ptr_parm, /* input: ptr to table_info structure */ code_parm /* output: success or failure */ ); %skip(1); lcb_ptr = lcb_ptr_parm; file_info_ptr = data_file_info_ptr_parm; table_ip = table_info_ptr_parm; code_parm = 0; %skip(1); call start_parsing_file; %skip(1); return; %page; stop: entry ( lcb_ptr_parm, /* input: ptr to the linus control block */ data_file_info_ptr_parm, /* input: ptr to data_file_info structure */ table_info_ptr_parm, /* input: ptr to table_info structure */ cleanup_signalled_parm, /* input: on if called by cleanup handler */ code_parm /* output: success or failure */ ); %skip(1); lcb_ptr = lcb_ptr_parm; file_info_ptr = data_file_info_ptr_parm; table_ip = table_info_ptr_parm; cleanup_signalled = cleanup_signalled_parm; code_parm = 0; %skip(1); call stop_parsing_file; %skip(1); return; %page; fill_the_buffer: proc ( ftb_code_parm /* output: success or failure */ ); %skip(1); dcl ftb_code fixed bin (35); dcl ftb_code_parm fixed bin (35) parm; dcl ftb_current_file_buffer_length fixed bin (21); dcl ftb_file_buffer_ptr ptr; dcl ftb_number_of_chars_available_in_buffer fixed bin (21); dcl ftb_number_of_chars_read fixed bin (21); %skip(1); ftb_code_parm = 0; %skip(1); sci_ptr = lcb.subsystem_control_info_ptr; work_area_ptr = addr (lcb.static_area); the_row_delimiter = file_info.row_delimiter; the_column_delimiter = file_info.column_delimiter; %skip(1); if file_info.current_char_in_previous_buffer ^= 0 then do; file_buffer = substr (file_buffer, file_info.current_char_in_previous_buffer); file_info.current_char_in_previous_buffer = 0; end; else file_buffer = ""; %skip(1); if file_info.flags.end_of_file_has_been_hit then do; if length (file_buffer) = 0 then ftb_code_parm = error_table_$end_of_info; return; end; %skip(1); ftb_current_file_buffer_length = length (file_buffer); ftb_number_of_chars_available_in_buffer = file_info.file_buffer_length - ftb_current_file_buffer_length; if ftb_number_of_chars_available_in_buffer < 1 then return; %skip(1); ftb_file_buffer_ptr = addcharno (addrel (file_info.file_buffer_ptr, 1), ftb_current_file_buffer_length); call iox_$get_chars (file_info.file_iocb_ptr, ftb_file_buffer_ptr, ftb_number_of_chars_available_in_buffer, ftb_number_of_chars_read, ftb_code); file_info.file_buffer_ptr -> file_buffer_length_word = ftb_number_of_chars_read + ftb_current_file_buffer_length; if ftb_code ^= 0 & ftb_code ^= error_table_$short_record then if ftb_code = error_table_$end_of_info then do; if ftb_number_of_chars_read = 0 & ftb_current_file_buffer_length = 0 then ftb_code_parm = error_table_$end_of_info; file_info.flags.end_of_file_has_been_hit = ON; end; else call ssu_$abort_line (sci_ptr, ftb_code); else; %skip(1); return; %skip(1); end fill_the_buffer; %page; get_the_row: proc ( gtr_code_parm /* output: success or failure */ ); %skip(1); dcl gtr_code_parm fixed bin (35) parm; dcl gtr_column_delimiter_was_found bit (1) aligned; dcl gtr_current_column_number fixed bin; dcl gtr_current_row_number fixed bin; dcl gtr_end_of_buffer fixed bin (21); dcl gtr_in_a_quoted_string bit (1) aligned; dcl gtr_last_column_processed fixed bin; dcl gtr_maximum_column_length fixed bin (21); dcl gtr_number_of_columns fixed bin; dcl gtr_processing_quotes bit (1) aligned; dcl gtr_processing_whitespace bit (1) aligned; dcl gtr_row_delimiter_was_found bit (1) aligned; dcl gtr_still_processing_the_row bit (1) aligned; %skip(1); gtr_code_parm = 0; %skip(1); if length (file_buffer) = 0 then do; gtr_code_parm = error_table_$end_of_info; if file_info.current_row_number = 0 then call ssu_$abort_line (sci_ptr, linus_error_$bad_file_process, PROBLEM_LINE_NUMBER_MESSAGE || PROBLEM_ROW_NUMBER_MESSAGE ||"^/The file ^a is empty.", file_info.current_line_number, file_info.current_row_number, file_info.directory_name || ">" || file_info.entry_name); return; end; %skip(1); gtr_current_row_number = file_info.current_row_number; file_info.current_char_in_buffer = 1; gtr_end_of_buffer = length (file_buffer); gtr_number_of_columns = table_info.column_count; gtr_row_delimiter_was_found = OFF; gtr_processing_quotes = file_info.flags.process_quotes; gtr_processing_whitespace = file_info.flags.process_whitespace; gtr_still_processing_the_row = ON; %skip(1); do gtr_current_column_number = 1 to gtr_number_of_columns while (gtr_still_processing_the_row); call get_column (gtr_current_row_number, gtr_current_column_number); gtr_maximum_column_length = table_info.columns.column_length (gtr_current_column_number); if length (column_buffer) > gtr_maximum_column_length then do; call ssu_$print_message (sci_ptr, 0, "Warning: the value ""^a"" ^/for the ""^a"" column will be truncated to ^d characters.", column_buffer, table_info.columns.column_name ( gtr_current_column_number), gtr_maximum_column_length); substr (row_value, table_info.columns.column_index (gtr_current_column_number), table_info.columns.column_length (gtr_current_column_number)) = substr (column_buffer, 1, gtr_maximum_column_length); end; else substr (row_value, table_info.columns.column_index (gtr_current_column_number), table_info.columns.column_length (gtr_current_column_number)) = column_buffer; gtr_last_column_processed = gtr_current_column_number; end; %skip(1); if gtr_last_column_processed ^= gtr_number_of_columns then call ssu_$abort_line (sci_ptr, linus_error_$bad_file_process, PROBLEM_LINE_NUMBER_MESSAGE || PROBLEM_ROW_NUMBER_MESSAGE || PROBLEM_COLUMN_NAME_MESSAGE || "^/There were ^d columns expected but only ^d were found." || PROBLEM_ROW_VALUE_MESSAGE, file_info.current_line_number, file_info.current_row_number, table_info.columns.column_name (gtr_last_column_processed + 1), gtr_number_of_columns, gtr_last_column_processed, substr (file_buffer, 1, file_info.current_char_in_buffer - 1)); else if ^gtr_row_delimiter_was_found then do; if file_info.current_char_in_buffer ^> gtr_end_of_buffer then if substr (file_buffer, file_info. current_char_in_buffer, 1) = the_row_delimiter then do; gtr_row_delimiter_was_found = ON; file_info.current_char_in_buffer = file_info.current_char_in_buffer + 1; if the_row_delimiter = NEWLINE then file_info.current_line_number = file_info.current_line_number + 1; end; else; else; if ^gtr_row_delimiter_was_found then call ssu_$abort_line (sci_ptr, linus_error_$bad_file_process, PROBLEM_LINE_NUMBER_MESSAGE || PROBLEM_ROW_NUMBER_MESSAGE || MISSING_ROW_DELIMITER_MESSAGE || PROBLEM_ROW_VALUE_MESSAGE, file_info.current_line_number, file_info.current_row_number, table_info.columns.column_name (gtr_number_of_columns), substr (file_buffer, 1, file_info.current_char_in_buffer - 1)); end; else if ^gtr_column_delimiter_was_found then if ^file_info.flags.last_column_delimiter_is_optional then call ssu_$abort_line (sci_ptr, linus_error_$bad_file_process, PROBLEM_LINE_NUMBER_MESSAGE || PROBLEM_ROW_NUMBER_MESSAGE || MISSING_COLUMN_DELIMITER_MESSAGE || PROBLEM_ROW_VALUE_MESSAGE, file_info.current_line_number, file_info.current_row_number, table_info.columns.column_name (gtr_number_of_columns), substr (file_buffer, 1, file_info.current_char_in_buffer - 1)); else; else; %skip(1); if file_info.current_char_in_buffer <= gtr_end_of_buffer then file_info.current_char_in_previous_buffer = file_info.current_char_in_buffer; else file_info.current_char_in_previous_buffer = 0; %skip(1); file_info.current_row_number = file_info.current_row_number + 1; %skip(1); return; %page; get_column: proc ( gc_row_number_parm, /* input: number of our current row */ gc_column_number_parm /* input: number of our current column */ ); %skip(1); dcl gc_column_number_parm fixed bin parm; dcl gc_current_char char (1); dcl gc_current_position fixed bin (21); dcl gc_maximum_reasonable_column_length fixed bin (21); dcl gc_row_number_parm fixed bin parm; dcl gc_starting_position fixed bin (21); dcl gc_still_getting_the_column bit (1) aligned; %skip(1); gc_starting_position = file_info.current_char_in_buffer; gc_current_position = gc_starting_position; gc_maximum_reasonable_column_length = table_info.columns.column_length (gc_column_number_parm) * 2 + 2; gtr_column_delimiter_was_found = OFF; column_buffer = ""; %skip(1); if gc_current_position > gtr_end_of_buffer then call ssu_$abort_line (sci_ptr, linus_error_$bad_file_process, PROBLEM_LINE_NUMBER_MESSAGE || PROBLEM_ROW_NUMBER_MESSAGE || PROBLEM_COLUMN_NAME_MESSAGE || MAXIMUM_CHARACTERS_FOR_A_ROW_MESSAGE || NUMBER_OF_CHARACTERS_ALREADY_PROCESSED_MESSAGE || PROBLEM_ROW_VALUE_MESSAGE, file_info.current_line_number, file_info.current_row_number, table_info.columns.column_name (gc_column_number_parm), file_info.file_buffer_length, file_info.file_buffer_length, substr (file_buffer, 1, gc_current_position)); %skip(1); gc_still_getting_the_column = ON; gtr_in_a_quoted_string = OFF; %skip(1); do while (gc_still_getting_the_column); %skip(1); gc_current_char = substr (file_buffer, gc_current_position, 1); %skip(1); if gc_current_char = QUOTE & gtr_processing_quotes then call current_char_is_a_quote; else if gc_current_char = the_column_delimiter then call current_char_is_the_column_delimiter; else if gc_current_char = the_row_delimiter then call current_char_is_the_row_delimiter; else column_buffer = column_buffer || gc_current_char; %skip(1); gc_current_position = gc_current_position + 1; %skip(1); if gc_still_getting_the_column then do; if gc_current_position > gtr_end_of_buffer then gc_still_getting_the_column = OFF; else if gc_current_position - gc_starting_position - 1 > gc_maximum_reasonable_column_length then call ssu_$abort_line (sci_ptr, linus_error_$bad_file_process, PROBLEM_LINE_NUMBER_MESSAGE || PROBLEM_ROW_NUMBER_MESSAGE || PROBLEM_COLUMN_NAME_MESSAGE || MAXIMUM_CHARACTERS_FOR_A_COLUMN_MESSAGE || NUMBER_OF_CHARACTERS_ALREADY_PROCESSED_MESSAGE || PROBLEM_ROW_VALUE_MESSAGE, file_info.current_line_number, file_info.current_row_number, table_info.columns.column_name (gc_column_number_parm), gc_maximum_reasonable_column_length, gc_maximum_reasonable_column_length, substr (file_buffer, 1, gc_current_position - 1)); else; end; else if gc_starting_position = gc_current_position then call ssu_$abort_line (sci_ptr, linus_error_$bad_file_process, PROBLEM_LINE_NUMBER_MESSAGE || PROBLEM_ROW_NUMBER_MESSAGE || "^/There were ^d columns expected but only ^d were found." || PROBLEM_ROW_VALUE_MESSAGE, file_info.current_line_number, file_info.current_row_number, gtr_number_of_columns, gc_column_number_parm - 1, substr (file_buffer, 1, gc_current_position - 1)); else; %skip(1); if gc_current_char = NEWLINE then file_info.current_line_number = file_info.current_line_number + 1; %skip(1); end; %skip(1); file_info.current_char_in_buffer = gc_current_position; %skip(1); return; %page; current_char_is_a_quote: proc; %skip(1); if gtr_in_a_quoted_string then do; if gc_current_position + 1 ^> gtr_end_of_buffer then do; if substr (file_buffer, gc_current_position + 1, 1) = QUOTE then do; gc_current_position = gc_current_position + 1; column_buffer = column_buffer || QUOTE; end; else gtr_in_a_quoted_string = OFF; end; else gtr_in_a_quoted_string = OFF; end; else gtr_in_a_quoted_string = ON; %skip(1); return; %skip(1); end current_char_is_a_quote; %page; current_char_is_the_column_delimiter: proc; %skip(1); dcl ccitcd_still_processing_whitespace bit (1) aligned; %skip(1); if gtr_in_a_quoted_string then do; column_buffer = column_buffer || gc_current_char; return; end; %skip(1); gtr_column_delimiter_was_found = ON; gc_still_getting_the_column = OFF; %skip(1); if gtr_processing_whitespace then do; ccitcd_still_processing_whitespace = ON; do while (ccitcd_still_processing_whitespace); if gc_current_position + 1 ^> gtr_end_of_buffer then do; if search (substr (file_buffer, gc_current_position + 1, 1), WHITESPACE) ^= 0 then gc_current_position = gc_current_position + 1; else ccitcd_still_processing_whitespace = OFF; end; else ccitcd_still_processing_whitespace = OFF; end; end; %skip(1); return; %skip(1); end current_char_is_the_column_delimiter; %page; current_char_is_the_row_delimiter: proc; %skip(1); if gtr_in_a_quoted_string then column_buffer = column_buffer || gc_current_char; else do; gtr_still_processing_the_row = OFF; gc_still_getting_the_column = OFF; gtr_row_delimiter_was_found = ON; end; %skip(1); return; %skip(1); end current_char_is_the_row_delimiter; %skip(1); end get_column; %skip(3); end get_the_row; %page; start_parsing_file: proc; %skip(1); dcl spf_code fixed bin (35); %skip(1); sci_ptr = lcb.subsystem_control_info_ptr; work_area_ptr = addr (lcb.static_area); %skip(1); file_info.flags.file_is_attached = OFF; file_info.flags.file_is_opened = OFF; file_info.flags.end_of_file_has_been_hit = OFF; file_info.current_row_number = 1; file_info.current_line_number = 1; file_info.current_char_in_buffer = 1; file_info.current_char_in_previous_buffer = 0; file_info.file_iocb_ptr = null; file_info.file_buffer_ptr = null; %skip(1); call expand_pathname_ (file_info.output_file_pathname, file_info.directory_name, file_info.entry_name, spf_code); if spf_code ^= 0 then call ssu_$abort_line (sci_ptr, spf_code, "^/While trying to expand the output file pathname ^a.", file_info.output_file_pathname); %skip(1); switch_name = unique_chars_ ("0"b) || ".parse_file"; attach_description = "vfile_ " || rtrim (file_info.directory_name) || ">" || rtrim (file_info.entry_name); %skip(1); call iox_$attach_name (switch_name, file_info.file_iocb_ptr, attach_description, null, spf_code); if spf_code ^= 0 then call ssu_$abort_line (sci_ptr, spf_code, "While trying to attach file ^a in dir ^a.", rtrim (file_info.entry_name), rtrim (file_info.directory_name)); file_info.flags.file_is_attached = ON; %skip(1); call iox_$open (file_info.file_iocb_ptr, Stream_input, "0"b, spf_code); if spf_code ^= 0 then call ssu_$abort_line (sci_ptr, spf_code, "^/Unable to open file ^a in dir ^a.", rtrim (file_info.entry_name), rtrim (file_info.directory_name)); file_info.flags.file_is_opened = ON; %skip(1); file_info.file_buffer_length = (table_info.row_value_length * 2) + (table_info.column_count * 2); allocate file_buffer in (work_area) set (file_info.file_buffer_ptr); file_buffer = ""; %skip(1); return; %skip(1); end start_parsing_file; %page; stop_parsing_file: proc; %skip(1); dcl spf_code fixed bin (35); %skip(1); sci_ptr = lcb.subsystem_control_info_ptr; work_area_ptr = addr (lcb.static_area); %skip(1); if file_info.file_buffer_ptr ^= null then do; free file_buffer; file_info.file_buffer_ptr = null; end; %skip(1); if file_info.flags.file_is_opened then do; call iox_$close (file_info.file_iocb_ptr, spf_code); if spf_code ^= 0 & ^cleanup_signalled then call ssu_$print_message (sci_ptr, spf_code, "^/While trying to close ^a.", file_info.entry_name); file_info.flags.file_is_opened = OFF; end; else; %skip(1); if file_info.flags.file_is_attached then do; call iox_$detach_iocb (file_info.file_iocb_ptr, spf_code); if spf_code ^= 0 & ^cleanup_signalled then call ssu_$print_message (sci_ptr, spf_code, "^/While trying to detach ^p.", file_info.file_iocb_ptr); file_info.flags.file_is_attached = OFF; call iox_$destroy_iocb (file_info.file_iocb_ptr, spf_code); if spf_code ^= 0 & ^cleanup_signalled then call ssu_$print_message (sci_ptr, spf_code, "^/While trying to destroy ^p.", file_info.file_iocb_ptr); end; %skip(1); return; %skip(1); end stop_parsing_file; %page; %skip(1); dcl MAXIMUM_CHARACTERS_FOR_A_COLUMN_MESSAGE char (58) static internal options (constant) init ( "^/The column should have taken a maximum of ^d characters."); %skip(1); dcl MAXIMUM_CHARACTERS_FOR_A_ROW_MESSAGE char (55) static internal options (constant) init ( "^/The row should have taken a maximum of ^d characters."); %skip(1); dcl MAXIMUM_MRDS_ATTRIBUTE_LENGTH fixed bin internal static options (constant) init (4096); %skip(1); dcl MISSING_COLUMN_DELIMITER_MESSAGE char (66) static internal options (constant) init ( "^/The column delimiter character wasn't found after the ^a column."); %skip(1); dcl NUMBER_OF_CHARACTERS_ALREADY_PROCESSED_MESSAGE char (53) static internal options (constant) init ( "^/There were already ^d characters processed for it."); %skip(1); dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %skip(1); dcl MISSING_ROW_DELIMITER_MESSAGE char (63) static internal options (constant) init ( "^/The row delimiter character wasn't found after the ^a column."); %skip(1); dcl NEWLINE char (1) static internal options (constant) init (" "); %skip(1); dcl PROBLEM_COLUMN_NAME_MESSAGE char (61) static internal options (constant) init ( "^/The ^a column was being processed when the problem occured."); %skip(1); dcl PROBLEM_LINE_NUMBER_MESSAGE char (58) static internal options (constant) init ( "^/A problem was encountered on line ^d of the input file."); %skip(1); dcl PROBLEM_ROW_NUMBER_MESSAGE char (59) static internal options (constant) init ( "^/The current row about to be stored into the table was ^d."); %skip(1); dcl PROBLEM_ROW_VALUE_MESSAGE char (61) static internal options (constant) init ( "^/The row value collected at the time of the error was:^/""^a"""); %skip(1); dcl QUOTE char (1) static internal options (constant) init (""""); %skip(1); /* WHITESPACE is BLANK, HORIZONTAL TAB, and VERTICAL TAB */ dcl WHITESPACE char (3) internal static options (constant) init (" "); %page; dcl addcharno builtin; dcl addr builtin; dcl addrel builtin; dcl attach_description char (256); %skip(1); dcl cleanup_signalled bit (1) aligned; dcl column_buffer char (MAXIMUM_MRDS_ATTRIBUTE_LENGTH) varying; %skip(1); dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$short_record fixed bin(35) ext static; dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); %skip(1); %skip(1); dcl file_buffer char (file_info.file_buffer_length) varying based (file_info.file_buffer_ptr); dcl file_buffer_length_word fixed bin (35) based; dcl 1 file_info like data_file_info based (file_info_ptr); dcl file_info_ptr ptr; dcl fixed builtin; %skip(1); dcl length builtin; dcl linus_error_$bad_file_process fixed bin(35) ext static; %skip(1); dcl null builtin; %skip(1); dcl rel builtin; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl search builtin; dcl ssu_$abort_line entry() options(variable); dcl ssu_$print_message entry() options(variable); dcl substr builtin; dcl switch_name char (32); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl the_column_delimiter char (1); dcl the_row_delimiter char (1); %skip(1); dcl unique_chars_ entry (bit(*)) returns(char(15)); %skip(1); dcl work_area area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; %page; %include arg_descriptor; %page; %include arg_list; %page; %include iox_dcls; %page; %include iox_modes; %page; %include linus_data_file_info; %page; %include linus_lcb; %page; %include linus_table_info; %skip(3); end linus_parse_file;  linus_print_query.pl1 07/29/86 1051.7r w 07/29/86 0939.6 31716 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus print_query request. Description and usage follows. Description: This request prints the query when called as a request, and returns the query when called as an active request. Usage: print_query or [print_query] Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_print_query: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(1); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(1); /* Mainline Processing Overview: (1) Check to make sure a data base is open and get the current query. (2) Print or return it. */ %skip(1); call initialize; call print_or_return_the_query; %skip(1); return; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); if lcb.db_index = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_db); %skip(1); call ssu_$return_arg (sci_ptr, number_of_args_supplied, active_request, return_string_ptr, return_string_length); if number_of_args_supplied ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "^/This request does not accept any control arguments."); %skip(1); call linus_query_mgr$get (lcb_ptr, query_segment_ptr, query_segment_length, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); return; %skip(1); end initialize; %page; print_or_return_the_query: proc; %skip(3); if active_request then return_string = requote_string_ (query_segment); else do; call iox_$put_chars (iox_$user_output, query_segment_ptr, query_segment_length, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); end; %skip(1); return; %skip(1); end print_or_return_the_query; %page; dcl active_request bit (1) aligned; dcl addr builtin; %skip(1); dcl code fixed bin (35); %skip(1); dcl error_table_$too_many_args fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl iox_$user_output ptr ext static; %skip(1); dcl linus_error_$no_db fixed bin(35) ext static; dcl linus_query_mgr$get entry (ptr, ptr, fixed bin(21), fixed bin(35)); %skip(1); dcl number_of_args_supplied fixed bin; %skip(1); dcl query_segment char (query_segment_length) based (query_segment_ptr); dcl query_segment_length fixed bin (21); dcl query_segment_ptr ptr; %skip(1); dcl rel builtin; dcl requote_string_ entry (char (*)) returns (char (*)); dcl return_string char (return_string_length) varying based (return_string_ptr); dcl return_string_length fixed bin (21); dcl return_string_ptr ptr; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); dcl sys_info$max_seg_size fixed bin(35) ext static; %page; %include linus_lcb; %skip(3); end linus_print_query;  linus_qedx.pl1 07/29/86 1051.7r w 07/29/86 0939.6 29088 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus qedx request. Description and usage follows. Description: This request allows a user to edit the current query or a new query through the qedx editor. Usage: qedx -new | -old The control argument -new specifies that the user should start off with an empty query. The control argument -old specifies that the user should use the existing query. -old is the default. Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_qedx: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(1); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(1); /* Mainline Processing Overview: (1) Check to make sure a data base is open. Process control args. (2) Get the subroutine to qedx the query. */ %skip(1); call initialize; %skip(1); call linus_qedx_the_query (lcb_ptr, new_or_old_query_flag); %skip(1); return; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); if lcb.db_index = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_db); %skip(1); new_or_old_query_flag = OFF; %skip(1); call ssu_$arg_count (sci_ptr, number_of_args_supplied); if number_of_args_supplied = 0 then return; %skip(1); do current_arg_number = 1 to number_of_args_supplied; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg = "-new" then new_or_old_query_flag = ON; else if arg = "-old" then new_or_old_query_flag = OFF; else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^/Unrecognized control argument ^a.", arg); end; %skip(1); return; %skip(1); end initialize; %page; dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %skip(1); dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl current_arg_number fixed bin; %skip(1); dcl error_table_$badopt fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl linus_error_$no_db fixed bin(35) ext static; dcl linus_qedx_the_query entry (ptr, bit(1) aligned); %skip(1); dcl new_or_old_query_flag bit (1) aligned; dcl number_of_args_supplied fixed bin; %skip(1); dcl rel builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl sys_info$max_seg_size fixed bin(35) ext static; %page; %include linus_lcb; %skip(3); end linus_qedx;  linus_qedx_the_query.pl1 07/29/86 1051.7r w 07/29/86 0939.7 46404 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the subroutine called by requests to implement the qedx'ing of the current query. Description and usage follows. Description: This subroutine takes the current query and calls qedx_ with it in a buffer, or calls qedx with an empty buffer depending on the setting of the second parameter. Unless the user did a quit_force the edited query replaces the original. Usage: call linus_qedx_the_query (lcb_ptr, new_query_flag); lcb_ptr - input - pointer to linus control block structure new_query_flag - input - on means start a new query, off means use the old Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_qedx_the_query: proc ( lcb_ptr_parm, /* input: ptr to the linus control block info structure */ new_flag_parm /* input: on if caller wants to start with a new query */ ); %skip(3); dcl lcb_ptr_parm ptr parm; dcl new_flag_parm bit (1) aligned parm; %skip(3); /* Mainline Processing Overview: (1) Get the current query placed in a temp segment, or get an empty temp segment if there is no current query. Set the temp segment length to zero if a new query was requested. (2) Fill in the qedx_information structure. (3) Call qedx and let the user do some editing. (4) If user didn't do a quit force then make the result of editing the current query. */ %skip(1); call initialize; call call_qedx; if query_should_be_replaced then do; call linus_query_mgr$put (lcb_ptr, query_segment_ptr, qedx_information.buffers (1).region_final_lth, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); else; end; else; %skip(1); return; %page; call_qedx: proc; %skip(1); query_should_be_replaced = OFF; call qedx_ (addr (qedx_information), code); if code ^= 0 then if code = error_table_$fatal_error then call ssu_$abort_line (sci_ptr, 0); else if code = error_table_$recoverable_error then if qedx_information.flags.quit_forced then return; else; else call ssu_$abort_line (sci_ptr, 0); else; %skip(1); query_should_be_replaced = ON; %skip(1); return; %skip(1); end call_qedx; %page; initialize: proc; %skip(3); lcb_ptr = lcb_ptr_parm; new_query = new_flag_parm; sci_ptr = lcb.subsystem_control_info_ptr; %skip(1); call linus_query_mgr$get (lcb_ptr, query_segment_ptr, query_segment_length, code); if code ^= 0 then if code = linus_error_$no_current_query then; else call ssu_$abort_line (sci_ptr, code); else; %skip(1); if new_query then query_segment_length = 0; %skip(1); qedx_information.header.version = QEDX_INFO_VERSION_1; qedx_information.editor_name = "linus (qedx)"; unspec (qedx_information.header.flags) = OFF; qedx_information.header.flags.query_if_modified = ON; qedx_information.n_buffers = 1; %skip(1); qedx_information.buffers (1).buffer_name = "0"; qedx_information.buffers (1).buffer_pathname = ""; qedx_information.buffers (1).region_ptr = query_segment_ptr; qedx_information.buffers (1).region_max_lth = sys_info$max_seg_size * 4; qedx_information.buffers (1).region_initial_lth = query_segment_length; %skip(1); unspec (qedx_information.buffers (1).flags) = OFF; qedx_information.buffers (1).flags.read_write_region = ON; qedx_information.buffers (1).flags.locked_pathname = ON; qedx_information.buffers (1).flags.default_read_ok = ON; qedx_information.buffers (1).flags.default_write_ok = ON; %skip(1); return; %skip(1); end initialize; %page; dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %page; dcl addr builtin; %skip(1); dcl code fixed bin (35); %skip(1); dcl error_table_$fatal_error fixed bin(35) ext static; dcl error_table_$recoverable_error fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl linus_error_$no_current_query fixed bin(35) ext static; dcl linus_query_mgr$get entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl linus_query_mgr$put entry (ptr, ptr, fixed bin(21), fixed bin(35)); %skip(1); dcl new_query bit (1) aligned; %skip(1); dcl qedx_ entry (ptr, fixed bin(35)); dcl 1 qedx_information aligned, 2 header like qedx_info.header, 2 buffers (1) like qedx_info.buffers; dcl query_segment_ptr ptr; dcl query_segment_length fixed bin (21); dcl query_should_be_replaced bit (1) aligned; %skip(1); dcl rel builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl unspec builtin; %page; %include linus_lcb; %page; %include qedx_info; %skip(3); end linus_qedx_the_query;  linus_query_mgr.pl1 07/29/86 1051.7r w 07/29/86 0939.7 87480 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the subroutine called by requests to implement the managment of the current query. Description and usage follows. Description: This subroutine has the following entrypoints. The get entry point takes the current query and places it in a segment. A pointer to the segment and the length are returned in the first two output parms, and the third output parm is the code to indicate success or failure. In the case where there isn't a query, the ptr and length (0) are still valid, and the code is set to reflect no query (linus_error_$no_current_query). The initialize_query_file entrypoint deletes the current query if there is one, and initializes the keyed lila statement file if there isn't one. The put entrypoint takes the caller supplied query and makes it the current query. When the caller passes a query with a length of zero, the current query statements are deleted. The write_line entrypoint takes the caller supplied query line and places it into the keyed lila file under the caller specified key. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_query_mgr: proc; %skip(3); /* These parameters are described at each entry where they are used. */ %skip(1); dcl code_parm fixed bin (35) parm; dcl lcb_ptr_parm ptr parm; dcl query_key_parm fixed bin parm; dcl query_line_parm char (*) parm; dcl query_segment_ptr_parm ptr parm; dcl query_segment_length_parm fixed bin (21) parm; %skip(3); return; %page; get: entry ( lcb_ptr_parm, /* input: ptr to the linus control block */ query_segment_ptr_parm, /* output: points to the returned query */ query_segment_length_parm, /* output: length of returned query */ code_parm /* output: success or failure */ ); %skip(3); lcb_ptr = lcb_ptr_parm; query_segment_ptr_parm = null (); query_segment_length_parm = 0; code_parm = 0; sci_ptr = lcb.subsystem_control_info_ptr; lila_file_iocb_ptr = lcb.liocb_ptr; %skip(1); call get_the_query (code_parm); query_segment_ptr_parm = query_segment_ptr; query_segment_length_parm = query_segment_length; %skip(1); return; %page; initialize_query_file: entry ( lcb_ptr_parm /* input: ptr to the linus control block */ ); %skip(3); lcb_ptr = lcb_ptr_parm; call linus_lila$initialize_lila_file (lcb_ptr); %skip(1); return; %page; put: entry ( lcb_ptr_parm, /* input: ptr to the linus control block */ query_segment_ptr_parm, /* input: points to the query */ query_segment_length_parm, /* input: length of query */ code_parm /* output: success or failure */ ); %skip(3); lcb_ptr = lcb_ptr_parm; query_segment_ptr = query_segment_ptr_parm; query_segment_length = query_segment_length_parm; code_parm = 0; %skip(1); if query_segment_ptr = null () then do; code_parm = error_table_$null_info_ptr; return; end; %skip(1); sci_ptr = lcb.subsystem_control_info_ptr; %skip(1); call put_the_query (code_parm); %skip(1); return; %page; write_line: entry ( lcb_ptr_parm, /* input: ptr to the linus control block */ query_key_parm, /* input: key to place the line under */ query_line_parm, /* input: the query line to write */ code_parm /* output: success or failure */ ); %skip(3); lcb_ptr = lcb_ptr_parm; sci_ptr = lcb.subsystem_control_info_ptr; lila_file_iocb_ptr = lcb.liocb_ptr; %skip(1); call write_the_query_line (query_key_parm, query_line_parm, code_parm); %skip(1); return; %page; get_the_query: proc (gtq_code_parm); %skip(3); dcl gtq_code fixed bin (35); dcl gtq_code_parm fixed bin (35) parm; dcl gtq_current_position fixed bin (21); dcl gtq_record_length fixed bin (21); dcl gtq_still_reading_lines bit (1) aligned; %skip(1); query_segment_ptr = lcb.query_temp_segment_ptr; query_segment_length = 0; if lila_file_iocb_ptr = null () | lcb.lila_count < 1 then do; gtq_code_parm = linus_error_$no_current_query; return; end; %skip(1); call iox_$position (lila_file_iocb_ptr, -1, 0, gtq_code); if gtq_code ^= 0 then call ssu_$abort_line (sci_ptr, gtq_code, "^/While trying to position to beginning of LILA file."); input_buffer_ptr = addr (input_buffer); gtq_current_position = 1; gtq_still_reading_lines = ON; %skip(1); do while (gtq_still_reading_lines); call iox_$read_record (lila_file_iocb_ptr, input_buffer_ptr, INPUT_BUFFER_LENGTH, gtq_record_length, gtq_code); if gtq_code ^= 0 then if gtq_code = error_table_$end_of_info then gtq_still_reading_lines = OFF; else call ssu_$abort_line (sci_ptr, gtq_code, "^/While trying to read a line from the query file."); else do; substr (query_segment, gtq_current_position, gtq_record_length - 1) = substr (input_buffer, 2, gtq_record_length - 1); gtq_current_position = gtq_current_position + gtq_record_length - 1; end; end; %skip(1); query_segment_length = gtq_current_position - 1; %skip(1); return; %skip(1); end get_the_query; %page; put_the_query: proc (ptq_code_parm); %skip(3); dcl ptq_code_parm fixed bin (35) parm; dcl ptq_current_position fixed bin (21); dcl ptq_loop fixed bin; dcl ptq_newline_index fixed bin (21); dcl ptq_query_line char (ptq_newline_index) based (addr (ptq_query_segment (ptq_current_position))); dcl ptq_query_segment (query_segment_length) char (1) based (query_segment_ptr); dcl ptq_still_writing_lines bit (1) aligned; %skip(1); ptq_code_parm = 0; %skip(1); call linus_lila$initialize_lila_file (lcb_ptr); if query_segment_length = 0 then return; %skip(1); lila_file_iocb_ptr = lcb.liocb_ptr; if substr (query_segment, query_segment_length, 1) ^= NEWLINE then do; query_segment_length = query_segment_length + 1; substr (query_segment, query_segment_length, 1) = NEWLINE; end; ptq_current_position = 1; ptq_still_writing_lines = ON; %skip(1); do ptq_loop = 1 to 9999 while (ptq_still_writing_lines); ptq_newline_index = index (substr (query_segment, ptq_current_position), NEWLINE); if ptq_newline_index = 0 then call ssu_$abort_line (sci_ptr, 0, "Logic error while trying to replace the query"); call write_the_query_line (ptq_loop, ptq_query_line, ptq_code_parm); if ptq_code_parm ^= 0 then return; ptq_current_position = ptq_current_position + ptq_newline_index; if ptq_current_position > query_segment_length then ptq_still_writing_lines = OFF; end; %skip(1); return; %skip(1); end put_the_query; %page; write_the_query_line: proc ( wtql_query_key_parm, /* input: key to place the line under */ wtql_query_line_parm, /* input: the query line to write */ wtql_code_parm /* output: success or failure */ ); %skip(3); dcl wtql_code_parm fixed bin (35) parm; dcl wtql_newline_index fixed bin; dcl wtql_pictured_record_key pic "9999"; dcl wtql_query_key_parm fixed bin parm; dcl wtql_query_line_parm char (*) parm; dcl wtql_query_record char (4096); dcl wtql_record_key char (256) varying; dcl wtql_record_length fixed bin (21); %skip(1); wtql_code_parm = 0; wtql_pictured_record_key = wtql_query_key_parm; wtql_record_key = wtql_pictured_record_key; %skip(1); wtql_newline_index = index (wtql_query_line_parm, NEWLINE); if wtql_newline_index = 0 then wtql_query_record = BLANK || rtrim (wtql_query_line_parm) || NEWLINE; else wtql_query_record = BLANK || rtrim (wtql_query_line_parm); %skip(1); call iox_$seek_key (lila_file_iocb_ptr, wtql_record_key, wtql_record_length, wtql_code_parm); if wtql_code_parm ^= error_table_$no_record then return; %skip(1); wtql_record_length = length (rtrim (wtql_query_record)); call iox_$write_record (lila_file_iocb_ptr, addr (wtql_query_record), wtql_record_length, wtql_code_parm); if wtql_code_parm ^= 0 then return; %skip(1); lcb.lila_chars = lcb.lila_chars + wtql_record_length; lcb.lila_count = lcb.lila_count + 1; %skip(1); return; %skip(1); end write_the_query_line; %page; dcl BLANK char (1) static internal options (constant) init (" "); %skip(1); dcl INPUT_BUFFER_LENGTH fixed bin (21) static internal options (constant) init (4096); %skip(1); dcl NEWLINE char (1) static internal options (constant) init (" "); %skip(1); dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %page; dcl addr builtin; %skip(1); dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$no_record fixed bin(35) ext static; dcl error_table_$null_info_ptr fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl index builtin; dcl input_buffer char (INPUT_BUFFER_LENGTH); dcl input_buffer_ptr ptr; %skip(1); dcl length builtin; dcl lila_file_iocb_ptr ptr; dcl linus_error_$no_current_query fixed bin(35) ext static; dcl linus_lila$initialize_lila_file entry (ptr); %skip(1); dcl null builtin; %skip(1); dcl query_segment char (sys_info$max_seg_size * 4) based (query_segment_ptr); dcl query_segment_ptr ptr; dcl query_segment_length fixed bin (21); %skip(1); dcl rel builtin; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %page; %include iox_dcls; %page; %include linus_lcb; %skip(3); end linus_query_mgr;  linus_restore_format_option.pl1 09/16/83 1806.4rew 09/16/83 1740.3 31761 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus restore_format_options request. Description and usage follows. Description: This request takes the pathname given as input and calls the ssu_$execute_string entrypoint to do a subsystem exec_com on the user specified file. Usage: "restore_format_options path" Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_restore_format_option: proc (sci_ptr_parm, lcb_ptr_parm); %skip(3); dcl sci_ptr_parm ptr parm; /* ptr to the subsystem control info structure */ dcl lcb_ptr_parm ptr parm; /* ptr to the linus control block info structure */ %skip(3); /* Mainline Processing Overview. (1) Get and expand/suffix the pathname arg. (2) Make sure the file exists. (3) Get ssu_ to do a subsystem ec on the file. */ %page; %skip(3); sci_ptr = sci_ptr_parm; %skip(1); /* The first and only arg must be pathname. */ %skip(1); call ssu_$arg_count (sci_ptr, number_of_args_supplied); %skip(1); if number_of_args_supplied ^= 1 then do; if number_of_args_supplied = 0 then code = error_table_$noarg; else code = error_table_$inconsistent; call ssu_$abort_line (sci_ptr, code, "^/Usage: restore_format_options path"); end; %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); pathname = arg; call expand_pathname_$add_suffix (pathname, "fo.lec", dir_name, entry_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/The pathname ^a couldn't be expanded.", pathname); %skip(1); call hcs_$status_minf (dir_name, entry_name, 1, file_type, bit_count, code); if code = error_table_$noentry then call ssu_$abort_line (sci_ptr, code, "^/The file ^a doesn't exist.", rtrim (dir_name) || ">" || rtrim (entry_name)); %skip(1); call ssu_$execute_string (sci_ptr, "ec " || rtrim (dir_name) || ">" || rtrim (entry_name), code); %skip(1); return; %page; %skip(1); dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl bit_count fixed bin (24); %skip(1); dcl code fixed bin (35); %skip(1); dcl dir_name char (168); %skip(1); dcl entry_name char (32); dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; dcl error_table_$noentry fixed bin(35) ext static; dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); %skip(1); dcl file_type fixed bin (2); %skip(1); dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); %skip(1); dcl number_of_args_supplied fixed bin; %skip(1); dcl pathname char (168); %skip(1); dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$execute_string entry (ptr, char(*), fixed bin(35)); %skip(3); end linus_restore_format_option;  linus_save_format_options.pl1 07/29/86 1051.7r w 07/29/86 0939.7 223884 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus save_format_options request. Description and usage follows. Description: This request does EITHER 1, 2 or 3 listed below. 1) Saves the ACTIVE option names and values. 2) Saves ALL the option names and values. 3) Saves USER SPECIFIED option names and values. Usage (1): "svfo path {-query}" or "svfo path {-query} -active" Only the active option names and values are saved to the file specifed by path. The query is optionally saved also. Usage (2): "svfo path {-query} -all" All of the formatting option names and values are saved to the file specifed by path. The query is optionally saved also. Usage (3): "svfo path {-query} -format_option_args" Where -format_option_args are the names of the formatting options whose values are to be saved to the file specifed by path. The query is optionally saved also. The formatting option names and values are saved to the file as an exec_com. The counterpart to this request, restore_format_options, does a subsystem exec_com on this file to accomplish the restoring. The old control argument of -selection_expression | -se is still accepted but not documented. Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_save_format_options: proc (sci_ptr_parm, lcb_ptr_parm); %skip(3); dcl sci_ptr_parm ptr parm; /* ptr to the subsystem control info structure */ dcl lcb_ptr_parm ptr parm; /* ptr to the linus control block info structure */ %skip(3); /* Mainline Processing Overview. (1) Determine requested usage. (2) Write the exec_com header and optionally the selection expression. (3) Get the option names and values. Either all of them, the active ones, or user provided ones. (4) Write the option names and values. (5) Write the exec_com footer. */ %page; %skip(3); cleanup_signalled = OFF; %skip(1); on cleanup begin; cleanup_signalled = ON; call terminate; end; %skip(1); call initialize; call write_exec_com_header; %skip(1); if usage_1 then call linus_options$get_active (lcb_ptr, names_and_values_info_ptr, no_of_names_and_values, names_and_values_ptr, size_of_names_and_values, code); else if usage_2 then call linus_options$get_all (lcb_ptr, names_and_values_info_ptr, no_of_names_and_values, names_and_values_ptr, size_of_names_and_values, code); else do; call get_user_specified_option_names; call linus_options$get_named (lcb_ptr, option_name_table_ptr, no_of_options_in_name_table, names_and_values_info_ptr, no_of_names_and_values, names_and_values_ptr, size_of_names_and_values, code); end; %skip(1); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); call write_the_names_and_values; call write_exec_com_footer; call terminate; %skip(1); return; %page; get_user_specified_option_names: proc; %skip(3); /* Load up the table with format option names and identifiers. The variable number_of_format_option_names has been set back in the initialize procedure when the first pass through the control args was made. If the format option names and identifiers were specified correctly then the table will be the exact size needed. If they were incorrectly specified it will be diagnosed here before the table can overflow. */ %skip(1); report_cip = lcb.report_control_info_ptr; names_and_values_area_ptr = report_control_info.name_value_area_ptr; no_of_options_in_name_table = number_of_format_option_names; %skip(1); allocate option_name_table in (names_and_values_area) set (option_name_table_ptr); %skip(1); current_arg = 2; call get_next_format_option_arg (code); if code = NO_MORE_FORMAT_OPTION_ARGS then call ssu_$abort_line (sci_ptr, 0, "Logic error while processing the format option arguments."); %skip(1); still_processing_args = ON; loop = 1; %skip(1); do while (still_processing_args); %skip(1); option_name = arg; call linus_options$check_name (lcb_ptr, option_name, long_option_name, identifier_needed, code); if code ^= 0 then if code = linus_error_$bad_option_name then call ssu_$abort_line (sci_ptr, code, "^/^a is not a valid option name.", option_name); else if code = linus_error_$no_lila_expr_processed then call ssu_$abort_line (sci_ptr, code, "^/There must be columns defined before the value of ^a can be saved.", long_option_name); else call ssu_$abort_line (sci_ptr, code); else; option_name_table.the_name (loop) = long_option_name; %skip(1); if identifier_needed then do; call get_next_format_option_arg (code); if code = NO_MORE_FORMAT_OPTION_ARGS then call ssu_$abort_line (sci_ptr, 0, "The option name ^a was not followed by an identifier.", option_name); else option_name_table.the_identifier (loop) = arg; call linus_options$check_identifier (lcb_ptr, option_name_table.the_name (loop), option_name_table.the_identifier (loop), normalized_option_name, code); if code ^= 0 then if code = linus_error_$bad_option_identifier then call ssu_$abort_line (sci_ptr, code, "^/^a is not a valid column identifier for ^a.", option_name_table.the_identifier (loop), option_name_table.the_name (loop)); else if code ^= error_table_$nostars then call ssu_$abort_line (sci_ptr, code); else; else; end; else option_name_table.the_identifier (loop) = ""; %skip(1); loop = loop + 1; call get_next_format_option_arg (code); if code = NO_MORE_FORMAT_OPTION_ARGS then still_processing_args = OFF; %skip(1); if still_processing_args then if loop > no_of_options_in_name_table then call ssu_$abort_line (sci_ptr, 0, "A format option name or column identifier was incorrectly specified."); else; else; %skip(1); end; %skip(1); return; %page; get_next_format_option_arg: proc (code_parm); %skip(3); /* Skip over the control args and get to the format option arg. Set code if there isn't any left. */ %skip(1); dcl code_parm fixed bin (35) parm; %skip(1); code_parm = 0; %skip(1); do while (this_is_a_control_arg (current_arg)); current_arg = current_arg + 1; end; %skip(1); if current_arg > no_of_args_supplied then do; code_parm = NO_MORE_FORMAT_OPTION_ARGS; return; end; %skip(1); call ssu_$arg_ptr (sci_ptr, current_arg, arg_ptr, arg_length); current_arg = current_arg + 1; %skip(1); return; %skip(1); end get_next_format_option_arg; %skip(1); end get_user_specified_option_names; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); usage_1 = OFF; usage_2 = OFF; usage_3 = OFF; %skip(1); selection_expression_flag = OFF; file_needs_terminating = OFF; unspec (this_is_a_control_arg) = OFF; number_of_control_args_found = 0; %skip(1); /* Make sure the format options are up to date. */ %skip(1); call linus_options$initialize (lcb_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); /* If no args are given then it is an error. The first arg must be pathname. If no additional args are given then usage (1) has been requested. If "-active" is given, then usage (1) has been requested by explicitely stating the default. If -active and -all are given the last one supplied is used. -active and -all cannot be used with the format_option_args. If -all is used correctly then usage (2) has been requested. If -active and -all are not found, then usage (3) is assumed, and invalid option names are reported as they are encountered. */ %skip(1); call ssu_$arg_count (sci_ptr, no_of_args_supplied); %skip(1); if no_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: save_format_options path {-format_options_args} {-control_args}."); else; %skip(1); /* Get the mandatory, positional pathname argument. */ %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); pathname = arg; %page; /* Determine which usage was intended and count the number of user supplied format option names so the table to hold them can be allocated. */ %skip(1); number_of_format_option_names = 0; if no_of_args_supplied = 1 then usage_1 = ON; else do loop = 2 to no_of_args_supplied; call ssu_$arg_ptr (sci_ptr, loop, arg_ptr, arg_length); if arg = "-all" | arg = "-a" | arg = "-active" | arg = "-act" | arg = "-selection_expression" | arg = "-se" | arg = "-query" then do; this_is_a_control_arg (loop) = ON; number_of_control_args_found = number_of_control_args_found + 1; if arg = "-all" | arg = "-a" then do; usage_2 = ON; usage_1 = OFF; end; else if arg = "-active" | arg = "-act" then do; usage_1 = ON; usage_2 = OFF; end; else selection_expression_flag = ON; end; else do; usage_3 = ON; if substr (arg, 1, 1) = "-" then number_of_format_option_names = number_of_format_option_names + 1; else; end; end; %skip(1); if ^usage_1 & ^usage_2 & ^usage_3 then usage_1 = ON; %skip(1); /* Check for inconsistent combinations of control args. */ %skip(1); if (usage_3 & (usage_1 | usage_2)) | ((usage_1 | usage_2) & (number_of_format_option_names > 0)) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/When ^[-all^;-active^] is used no format option args can be specified.", fixed (usage_1 || usage_2)); else if usage_3 & number_of_format_option_names ^> 0 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/At least one format option name must be specified."); else; %skip(1); /* Make sure a selection expression is available if the user asked for it to be saved with the file. */ %skip(1); if selection_expression_flag then do; call linus_table$info (lcb_ptr, table_ip, code); if code = linus_error_$no_lila_expr_processed then call ssu_$abort_line (sci_ptr, linus_error_$no_lila_expr_processed, "^/The format was not saved."); end; %skip(1); /* Ready the file, truncate it if it exists. */ %skip(1); call expand_pathname_$add_suffix (pathname, "fo.lec", dir_name, entry_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to expand ^a.", pathname); %skip(1); switch_name = unique_chars_ ("0"b) || ".linus_svfo"; %skip(1); call iox_$attach_name (switch_name, iocb_ptr, "vfile_ " || rtrim (dir_name) || ">" || entry_name, null (), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to attach ^a.", pathname); %skip(1); file_needs_terminating = ON; %skip(1); call iox_$open (iocb_ptr, Stream_output, "0"b, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to open ^a.", pathname); %skip(1); return; %skip(1); end initialize; %page; terminate: proc; %skip(3); if file_needs_terminating then do; call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); call iox_$destroy_iocb (iocb_ptr, code); if cleanup_signalled then call delete_$path (dir_name, entry_name, "100111"b, ME, code); end; %skip(1); return; %skip(1); end terminate; %page; write_exec_com_footer: proc; %skip(3); call ioa_$ioa_switch (iocb_ptr, "&detach^/&quit"); %skip(1); return; %skip(1); end write_exec_com_footer; %page; write_exec_com_header: proc; %skip(3); /* First the necessary exec_com statements. */ %skip(1); call ioa_$ioa_switch (iocb_ptr, "&version 2^/&trace off^/&attach"); %skip(1); /* Then the selection expression if requested. */ %skip(1); if ^selection_expression_flag then return; %skip(1); call linus_query_mgr$get (lcb_ptr, query_segment_ptr, query_segment_length, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); call ioa_$ioa_switch (iocb_ptr, "input_query -force -brief -terminal_input"); query_segment_current_position = 1; still_processing_lila_lines = ON; %skip(1); do while (still_processing_lila_lines); query_segment_newline_index = index (substr (query_segment, query_segment_current_position), NEWLINE); if query_segment_newline_index = 0 then call ssu_$abort_line (sci_ptr, 0, "Logic error while trying to save the selection expression."); ampersand_position = index (substr (query_segment, query_segment_current_position, query_segment_newline_index), AMPERSAND); if ampersand_position = 0 then call ioa_$ioa_switch (iocb_ptr, "^a", substr (query_segment, query_segment_current_position, query_segment_newline_index - 1)); else do; line_buffer = substr (query_segment, query_segment_current_position, query_segment_newline_index - 1); starting_position = 1; still_quoting_ampersands = ON; do while (still_quoting_ampersands); line_buffer = substr (line_buffer, 1, ampersand_position - 1) || AMPERSAND || substr (line_buffer, ampersand_position); starting_position = ampersand_position + 2; if starting_position ^> length (line_buffer) then do; ampersand_position = index (substr (line_buffer, starting_position), AMPERSAND); if ampersand_position = 0 then still_quoting_ampersands = OFF; else ampersand_position = ampersand_position + starting_position - 1; end; else still_quoting_ampersands = OFF; end; call ioa_$ioa_switch (iocb_ptr, "^a", line_buffer); end; query_segment_current_position = query_segment_current_position + query_segment_newline_index; if query_segment_current_position > query_segment_length then still_processing_lila_lines = OFF; else; end; %skip(1); call ioa_$ioa_switch (iocb_ptr, ".^/translate_query"); %skip(1); return; %skip(1); end write_exec_com_header; %page; write_the_names_and_values: proc; %skip(3); /* If the linus_options$get_active entry was called there may not be any format option values to save. */ %skip(1); if no_of_names_and_values = 0 then call ssu_$abort_line (sci_ptr, 0, "^/^a^/^a", "All of the formatting options are set to their default values.", "There are no column options defined. The format was not saved."); %skip(1); /* Loop through the names and values writing them out to the exec_com file as linus set_format_options requests. The values must be special cased in the following way. Version 2 exec_com strips leading and trailing whitespace, so it must be protected. Version 2 ec also barfs if the value contains an ampersand, so they must be protected. The ssu_ request processor does quote stripping, active function evaluation, etc. so all of these things must be protected. The set_format_options request has a number of control args it takes, so if the value is the same as any of these control args it must be protected. If the value is a zero length character string then it must be translated to the request language zero length string "". And finally, single line values do not have a trailing newline character, so if it is going to be protected for any of the previous reasons, it must have a newline added. */ %skip(1); do loop = 1 to no_of_names_and_values; %skip(1); normalized_option_name = substr (names_and_values, name_value_info.name.index (loop), name_value_info.name.length (loop)); %skip(1); option_value = substr (names_and_values, name_value_info.value.index (loop), name_value_info.value.length (loop)); %skip(1); special_characters_in_option_value = OFF; newline_needed = OFF; requoting_needed = OFF; %skip(1); option_value_length = length (option_value); if option_value_length = 0 then do; option_value = """"""; option_value_length = 2; end; else do; if substr (option_value, option_value_length) ^= NEWLINE then newline_needed = ON; else; if search (option_value, SPECIAL_CHARACTERS) ^= 0 then special_characters_in_option_value = ON; else; if substr (option_value, 1, 1) = "-" then if option_value = "-reset" | option_value = "-rs" | option_value = "-no_reset" | option_value = "-nrs" | option_value = "-long" | option_value = "-lg" | option_value = "-brief" | option_value = "-bf" | option_value = "-prompt" | option_value = "-default" then special_characters_in_option_value = ON; else; else; if search (option_value, AMPERSAND_BLANK_OR_TAB) ^= 0 then requoting_needed = ON; else; end; %skip(1); /* Do special exec_com quoting first. Handle the easiest case first, when it is just a one line value that needs a newline character after exec_com quotes are added. Values which are several lines long must be quoted separately, as quoted strings that contain a newline are not legal exec_com statements. */ %skip(1); if requoting_needed then do; if newline_needed then option_value = AMPERSAND || requote_string_ (substr (option_value, 1)) || NEWLINE; else do; spare_option_value = ""; still_creating_lines = ON; starting_position = 1; do while (still_creating_lines); newline_position = index (substr (option_value, starting_position), NEWLINE); if newline_position ^= 0 then do; line_buffer = substr (option_value, starting_position, newline_position - 1); spare_option_value = spare_option_value || AMPERSAND || requote_string_ (substr (line_buffer, 1)) || NEWLINE; starting_position = starting_position + newline_position; if starting_position > option_value_length then still_creating_lines = OFF; end; else do; spare_option_value = spare_option_value || AMPERSAND || requote_string_ (substr (option_value, starting_position)) || NEWLINE; still_creating_lines = OFF; end; end; option_value = spare_option_value; end; end; else if newline_needed & special_characters_in_option_value then option_value = option_value || NEWLINE; else; %skip(1); if special_characters_in_option_value then call ioa_$ioa_switch (iocb_ptr, "^a^x^a^x^a^/^a^a", "set_format_options", normalized_option_name, "-prompt -brief", option_value, "."); else call ioa_$ioa_switch (iocb_ptr, "^a^x^a^x^a", "set_format_options", normalized_option_name, option_value); %skip(1); end; %skip(1); return; %skip(1); end write_the_names_and_values; %page; dcl AMPERSAND char (1) static int options (constant) init ("&"); dcl AMPERSAND_BLANK_OR_TAB char (3) static int options (constant) init ("& "); dcl OFF bit (1) aligned static int options (constant) init ("0"b); dcl ON bit (1) aligned static int options (constant) init ("1"b); dcl ME char (19) static int options (constant) init ("save_format_options"); dcl NEWLINE char (1) static int options (constant) init (" "); dcl NO_MORE_FORMAT_OPTION_ARGS fixed bin (35) static int options (constant) init (1); /* SPECIAL_CHARACTERS are blank, tab, left and right bracket, left and right paraen, ampersand, quote, and newline */ dcl SPECIAL_CHARACTERS char (9) static int options (constant) init ( " []()&"" "); %skip(1); dcl addr builtin; dcl ampersand_position fixed bin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl cleanup condition; dcl cleanup_signalled bit (1) aligned; dcl code fixed bin (35); dcl current_arg fixed bin; %skip(1); dcl delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35)); dcl dir_name char (168); %skip(1); dcl entry_name char (32); dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; dcl error_table_$nostars fixed bin(35) ext static; dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); %skip(1); dcl file_needs_terminating bit (1) aligned; dcl fixed builtin; %skip(1); dcl identifier_needed bit (1) aligned; dcl index builtin; dcl ioa_$ioa_switch entry() options(variable); dcl iocb_ptr ptr; dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)); dcl iox_$close entry (ptr, fixed bin(35)); dcl iox_$destroy_iocb entry (ptr, fixed bin(35)); dcl iox_$detach_iocb entry (ptr, fixed bin(35)); dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)); %skip(1); dcl length builtin; dcl line_buffer char (4096) varying; dcl linus_error_$bad_option_identifier fixed bin(35) ext static; dcl linus_error_$bad_option_name fixed bin(35) ext static; dcl linus_error_$no_lila_expr_processed fixed bin(35) ext static; dcl linus_options$check_identifier entry (ptr, char(*) var, char(*) var, char(*) var, fixed bin(35)); dcl linus_options$check_name entry (ptr, char(*) var, char(*) var, bit(1) aligned, fixed bin(35)); dcl linus_options$get_active entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35)); dcl linus_options$get_all entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35)); dcl linus_options$get_named entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35)); dcl linus_options$initialize entry (ptr, fixed bin(35)); dcl linus_query_mgr$get entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl linus_table$info entry (ptr, ptr, fixed bin(35)); dcl long_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying; dcl loop fixed bin; %skip(1); dcl names_and_values_area area (sys_info$max_seg_size) based (names_and_values_area_ptr); dcl names_and_values_area_ptr ptr; dcl newline_needed bit (1) aligned; dcl newline_position fixed bin; dcl no_of_args_supplied fixed bin; dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying; dcl number_of_control_args_found fixed bin; dcl number_of_format_option_names fixed bin; dcl null builtin; %skip(1); dcl option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying; dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl option_value_length fixed bin; %skip(1); dcl pathname char (168); %skip(1); dcl query_segment char (query_segment_length) based (query_segment_ptr); dcl query_segment_current_position fixed bin (21); dcl query_segment_length fixed bin (21); dcl query_segment_newline_index fixed bin (21); dcl query_segment_ptr ptr; %skip(1); dcl rel builtin; dcl requote_string_ entry (char(*)) returns(char(*)); dcl requoting_needed bit (1) aligned; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl search builtin; dcl selection_expression_flag bit (1) aligned; dcl spare_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; dcl special_characters_in_option_value bit (1) aligned; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl starting_position fixed bin; dcl still_creating_lines bit (1) aligned; dcl still_processing_args bit (1) aligned; dcl still_quoting_ampersands bit (1) aligned; dcl still_processing_lila_lines bit (1) aligned; dcl substr builtin; dcl switch_name char (32); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl this_is_a_control_arg (360) bit (1) unaligned; %skip(1); dcl unique_chars_ entry (bit(*)) returns(char(15)); dcl unspec builtin; dcl usage_1 bit (1) aligned; dcl usage_2 bit (1) aligned; dcl usage_3 bit (1) aligned; %page; %include arg_descriptor; %page; %include arg_list; %page; %include iox_modes; %page; %include linus_lcb; %page; %include linus_names_and_values; %page; %include linus_options_extents; %page; %include linus_report_info; %page; %include linus_table_info; %page; end linus_save_format_options;  linus_save_query.pl1 07/29/86 1051.7r w 07/29/86 0939.7 58473 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus save_query request. Description and usage follows. Description: This request saves the current query in the file named by the caller. Usage: save_query path.lquery Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_save_query: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(1); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(1); /* Mainline Processing Overview: (1) Check to make sure a data base is open and get the current query. (2) Open the file, write the query, and close the file. */ %skip(1); call initialize; %skip(1); on cleanup begin; cleanup_signalled = ON; call close_file; end; %skip(1); call open_file; call write_the_file; call close_file; %skip(1); return; %page; close_file: proc; %skip(3); if opened then do; call iox_$close (output_file_iocb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to close ^a.", output_file_pathname); else call ssu_$abort_line (sci_ptr, code, "^/While trying to close ^a.", output_file_pathname); else opened = OFF; end; else; %skip(1); if attached then do; call iox_$detach_iocb (output_file_iocb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to detach ^p.", output_file_iocb_ptr); else call ssu_$abort_line (sci_ptr, code, "^/While trying to detach ^p.", output_file_iocb_ptr); else do; attached = OFF; call iox_$destroy_iocb (output_file_iocb_ptr, code); if code ^= 0 then if cleanup_signalled then call ssu_$print_message (sci_ptr, code, "^/While trying to destroy ^p.", output_file_iocb_ptr); else call ssu_$abort_line (sci_ptr, code, "^/While trying to destroy ^p.", output_file_iocb_ptr); else; end; end; %skip(1); return; %skip(1); end close_file; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); attached = OFF; opened = OFF; cleanup_signalled = OFF; %skip(1); if lcb.db_index = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_db); %skip(1); call linus_query_mgr$get (lcb_ptr, query_segment_ptr, query_segment_length, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); call ssu_$arg_count (sci_ptr, number_of_args_supplied); if number_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, USAGE_MESSAGE); else if number_of_args_supplied ^= 1 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, USAGE_MESSAGE); %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); output_file_pathname = arg; %skip(1); return; %skip(1); end initialize; %page; open_file: proc; %skip(3); call expand_pathname_$add_suffix (output_file_pathname, "lquery", output_file_directory_name, output_file_entry_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to expand ^a.", rtrim (output_file_pathname)); switch_name = unique_chars_ ("0"b) || "linus.save_query"; %skip(1); call iox_$attach_name (switch_name, output_file_iocb_ptr, "vfile_ " || rtrim (output_file_directory_name) || ">" || rtrim (output_file_entry_name), null (), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to attach ^a in ^a.", output_file_entry_name, output_file_directory_name); else attached = ON; %skip(1); call iox_$open (output_file_iocb_ptr, Stream_output, "0"b, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/While trying to open ^a in ^a.", output_file_entry_name, output_file_directory_name); else opened = ON; %skip(1); return; %skip(1); end open_file; %page; write_the_file: proc; %skip(3); call iox_$put_chars (output_file_iocb_ptr, query_segment_ptr, query_segment_length, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); return; %skip(1); end write_the_file; %page; dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); dcl USAGE_MESSAGE char (28) static internal options (constant) init ( "^/Usage: save_query pathname"); %skip(1); dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; dcl attached bit (1) aligned; %skip(1); dcl code fixed bin (35); dcl cleanup condition; dcl cleanup_signalled bit (1) aligned; %skip(1); dcl error_table_$too_many_args fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); %skip(1); dcl fixed builtin; %skip(1); dcl linus_error_$no_db fixed bin(35) ext static; dcl linus_query_mgr$get entry (ptr, ptr, fixed bin(21), fixed bin(35)); %skip(1); dcl number_of_args_supplied fixed bin; dcl null builtin; %skip(1); dcl opened bit (1) aligned; dcl output_file_directory_name char (168); dcl output_file_entry_name char (32); dcl output_file_iocb_ptr ptr; dcl output_file_pathname char (168); %skip(1); dcl query_segment_length fixed bin (21); dcl query_segment_ptr ptr; %skip(1); dcl rel builtin; dcl rtrim builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$print_message entry() options(variable); dcl switch_name char (32); dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl unique_chars_ entry (bit(*)) returns(char(15)); %page; %include iox_modes; %page; %include iox_dcls; %page; %include linus_lcb; %skip(3); end linus_save_query;  linus_scope_manager.pl1 10/24/88 1648.3r w 10/24/88 1400.1 198522 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-08,Dupuis), approve(86-01-10,MCR7188), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Written - Al Dupuis - December 1984 as part of the rewrite of all linus scope modules. 2) change(86-01-08,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Changed code so that del_scope and set_scope work as active requests. (SCP 6287). 3) change(86-10-03,Dupuis), approve(86-10-21,MCR7562), audit(86-10-22,Blair), install(86-10-23,MR12.0-1199): Changed the default wait time from 30 seconds to linus_data_$lock_wait_time. END HISTORY COMMENTS */ /* format: off */ %skip(1); /* This is the main level procedure called by ssu_ to implement the linus set_scope and del_scope request. */ %page; linus_scope_manager: proc; %skip(3); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(1); call com_err_ (error_table_$badcall, "linus_scope_manager", "^/This isn't a valid entry."); %skip(1); return; %page; delete_scope: entry ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(1); the_entry_called = "delete_scope"; call initialize; %skip(1); on cleanup begin; cleanup_has_been_signalled = ON; call terminate; end; %skip(1); call housekeeping; call process_delete_scope_args; %skip(1); if delete_all_scope then do; call dsl_$dl_scope_all (lcb.db_index, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/Unable to delete all scope."); else if active_request_flag then return_value = "true"; end; else do; call process_common_args; if active_request_flag then do; error_codes (1) = mrds_error_$scope_not_found; on sub_error_ call linus_stifle_mrds_sub_error (error_codes); end; call cu_$generate_call (dsl_$dl_scope, arg_list_ptr); if active_request_flag then revert sub_error_; if scope_information.dsl_error_code ^= 0 then if scope_information.dsl_error_code = mrds_error_$scope_not_found & active_request_flag then return_value = "false"; else call ssu_$abort_line (sci_ptr, scope_information.dsl_error_code); else if active_request_flag then return_value = "true"; end; %skip(1); call terminate; %skip(1); return; %page; set_scope: entry ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(1); the_entry_called = "set_scope"; call initialize; %skip(1); on cleanup begin; cleanup_has_been_signalled = ON; call terminate; end; %skip(1); call housekeeping; call process_set_scope_args; call process_common_args; %skip(1); if active_request_flag then do; error_codes (1) = mrds_error_$db_busy; on sub_error_ call linus_stifle_mrds_sub_error (error_codes); end; %skip(1); call cu_$generate_call (dsl_$set_scope, arg_list_ptr); if scope_information.dsl_error_code ^= 0 then if scope_information.dsl_error_code = mrds_error_$db_busy & active_request_flag then return_value = "false"; else call ssu_$abort_line (sci_ptr, scope_information.dsl_error_code); else if active_request_flag then return_value = "true"; %skip(1); call terminate; %skip(1); return; %page; housekeeping: proc; %skip(1); dcl h_code fixed bin (35); %skip(1); call dsl_$get_scope_info (lcb.db_index, work_area_ptr, scope_ptr, h_code); if h_code ^= 0 then call ssu_$abort_line (sci_ptr, h_code, "^/Unable to get the scope information."); %skip(1); call dsl_$get_pn (lcb.db_index, data_base_pathname, opening_mode, h_code); if h_code ^= 0 then call ssu_$abort_line (sci_ptr, h_code, "^/Unable to get the database pathname."); %skip(1); if substr (opening_mode, 1, 9) = "exclusive" then call ssu_$abort_line (sci_ptr, mrds_error_$unshared_opening); else if the_entry_called = "set_scope" then if scope_info.active_scopes > 0 then call ssu_$abort_line (sci_ptr, mrds_error_$scope_not_empty); else; else; %skip(1); return; %skip(1); end housekeeping; %page; initialize: proc; %skip(1); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); call ssu_$return_arg (sci_ptr, number_of_args_supplied, active_request_flag, return_value_ptr, return_value_length); if active_request_flag then return_value = ""; %skip(1); if lcb.db_index = 0 then call ssu_$abort_line (sci_ptr, linus_error_$no_db); %skip(1); work_area_ptr = lcb.general_work_area_ptr; scope_ptr = null; scope_information_ptr = null; arg_list_ptr = null; forced_retrieve_scope_info_ptr = null; cleanup_has_been_signalled = OFF; delete_all_scope = OFF; wait_time = linus_data_$lock_wait_time; %skip(1); arg_descriptor_ptr = addr (character_30_descriptor); arg_descriptor.flag = ON; arg_descriptor.type = char_dtype; arg_descriptor.packed = ON; arg_descriptor.number_dims = 0; arg_descriptor.size = 30; %skip(1); arg_descriptor_ptr = addr (fixed_bin_35_descriptor); fixed_arg_descriptor.flag = ON; fixed_arg_descriptor.type = real_fix_bin_1_dtype; fixed_arg_descriptor.packed = OFF; fixed_arg_descriptor.number_dims = 0; fixed_arg_descriptor.scale = 0; fixed_arg_descriptor.precision = 35; %skip(1); return; %skip(1); end initialize; %page; process_common_args: proc; %skip(1); dcl pca_loop fixed bin; dcl pca_scope_index fixed bin; %skip(1); if mod (number_of_args_supplied, 3) ^= 0 then if the_entry_called = "set_scope" then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, SET_SCOPE_USAGE_MESSAGE); else call ssu_$abort_line (sci_ptr, error_table_$inconsistent, DELETE_SCOPE_USAGE_MESSAGE); else; %skip(1); si_init_number_of_triplets = divide (number_of_args_supplied, 3, 17); allocate scope_information in (work_area) set (scope_information_ptr); scope_information.data_base_index = lcb.db_index; scope_information.dsl_error_code = 0; %skip(1); forced_retrieve_scope_info_ptr = lcb.force_retrieve_scope_info_ptr; if the_entry_called = "set_scope" then do; if forced_retrieve_scope_info_ptr ^= null then free forced_retrieve_scope_info; frsi_init_number_of_relations = si_init_number_of_triplets; allocate forced_retrieve_scope_info in (work_area) set (forced_retrieve_scope_info_ptr); forced_retrieve_scope_info.relations.name (*) = ""; forced_retrieve_scope_info.relations.retrieve_scope_was_forced (*) = OFF; lcb.force_retrieve_scope_info_ptr = forced_retrieve_scope_info_ptr; end; %skip(1); arg_list_arg_count = number_of_args_supplied + ONE_FOR_DATA_BASE_INDEX_AND_ONE_FOR_ERROR_CODE; if the_entry_called = "set_scope" then arg_list_arg_count = arg_list_arg_count + ONE_FOR_THE_WAIT_TIME; allocate arg_list in (work_area) set (arg_list_ptr); arg_list_ptr -> arg_list.pad1 = OFF; arg_list_ptr -> arg_list.call_type = Interseg_call_type; arg_list_ptr -> arg_list.desc_count = arg_list_ptr -> arg_list.arg_count; arg_list_ptr -> arg_list.pad2 = OFF; arg_list_ptr -> arg_list.arg_ptrs (1) = addr (scope_information.data_base_index); arg_list_ptr -> arg_list.desc_ptrs (1) = addr (fixed_bin_35_descriptor); arg_list_ptr -> arg_list.arg_ptrs (arg_list_arg_count) = addr (scope_information.dsl_error_code); arg_list_ptr -> arg_list.desc_ptrs (arg_list_arg_count) = addr (fixed_bin_35_descriptor); if the_entry_called = "set_scope" then do; scope_information.wait_time = wait_time; arg_list_ptr -> arg_list.arg_ptrs (arg_list_arg_count - 1) = addr (scope_information.wait_time); arg_list_ptr -> arg_list.desc_ptrs (arg_list_arg_count - 1) = addr (fixed_bin_35_descriptor); end; %page; pca_scope_index = 1; %skip(1); do pca_loop = 1 to number_of_args_supplied by 3; %skip(1); call ssu_$arg_ptr (sci_ptr, pca_loop, arg_ptr, arg_length); scope_information.triplets.relation_name (pca_scope_index) = check_relation_name (arg); arg_list_ptr -> arg_list.arg_ptrs (pca_loop + 1) = addr (scope_information.triplets.relation_name (pca_scope_index)); arg_list_ptr -> arg_list.desc_ptrs (pca_loop + 1) = addr (character_30_descriptor); %skip(1); call ssu_$arg_ptr (sci_ptr, pca_loop + 1, arg_ptr, arg_length); scope_information.triplets.permit_op (pca_scope_index) = convert_scope_to_binary (arg, PERMITS); arg_list_ptr -> arg_list.arg_ptrs (pca_loop + 2) = addr (scope_information.triplets.permit_op (pca_scope_index)); arg_list_ptr -> arg_list.desc_ptrs (pca_loop + 2) = addr (fixed_bin_35_descriptor); call force_retrieve_kludge_for_modify; %skip(1); call ssu_$arg_ptr (sci_ptr, pca_loop + 2, arg_ptr, arg_length); scope_information.triplets.prevent_op (pca_scope_index) = convert_scope_to_binary (arg, PREVENTS); arg_list_ptr -> arg_list.arg_ptrs (pca_loop + 3) = addr (scope_information.triplets.prevent_op (pca_scope_index)); arg_list_ptr -> arg_list.desc_ptrs (pca_loop + 3) = addr (fixed_bin_35_descriptor); pca_scope_index = pca_scope_index + 1; %skip(1); end; %skip(1); return; %page; check_relation_name: proc ( crn_relation_name_parm) /* input: relation name */ returns (char (30)); /* output: relation name */ %skip(1); dcl crn_loop fixed bin; dcl crn_relation_name char (30); dcl crn_relation_name_parm char (*) parm; %skip(1); if length (crn_relation_name_parm) > 30 then call ssu_$abort_line (sci_ptr, mrds_error_$rel_name_too_long, "^/The table name ^a is invalid.", crn_relation_name_parm); crn_relation_name = crn_relation_name_parm; %skip(1); do crn_loop = 1 to scope_info.nfiles; if crn_relation_name = scope_info.scope.sm_name (crn_loop) then return (crn_relation_name); end; %skip(1); call ssu_$abort_line (sci_ptr, linus_error_$inv_table, "^/The table ^a isn't a permanent table.", crn_relation_name); %skip(1); end check_relation_name; %page; convert_scope_to_binary: proc ( cstb_scope_parm, /* input: character version of scope */ cstb_prevents_parm) /* input: on if this is a prevent */ returns (fixed bin /* output: encoded version of scope */ ); %skip(1); dcl cstb_binary_scope fixed bin; dcl cstb_prevents_parm bit (1) aligned parm; dcl cstb_scope_parm char (*) parm; dcl cstb_scope char (6) varying; %skip(1); if length (cstb_scope_parm) > VALID_SCOPE_SETTINGS_LENGTH then call ssu_$abort_line (sci_ptr, error_table_$bigarg, "^/The maximum length ^a can be is ^d characters.", cstb_scope_parm, VALID_SCOPE_SETTINGS_LENGTH); cstb_scope = cstb_scope_parm; if verify (cstb_scope, VALID_SCOPE_SETTINGS) ^= 0 then call ssu_$abort_line (sci_ptr, linus_error_$ill_scp_op, "^x^a", cstb_scope_parm); if index (cstb_scope, NULL_CHARACTER) > 0 then if cstb_scope ^= NULL_CHARACTER then call ssu_$abort_line (sci_ptr, linus_error_$ill_scp_op, "^/The scope string ^a can't specify ""n"" in conjunction with other scopes.", cstb_scope); if index (cstb_scope, UPDATE_CHARACTER) ^= 0 then if ^(cstb_scope = UPDATE_CHARACTER || RETRIEVE_CHARACTER | cstb_scope = RETRIEVE_CHARACTER || UPDATE_CHARACTER | cstb_scope = UPDATE_CHARACTER) then call ssu_$abort_line (sci_ptr, linus_error_$ill_scp_op, "^/The scope string ^a can only specify ""r"" in addition to ""u"".", cstb_scope); %skip(1); if search (cstb_scope, UPDATE_CHARACTER) ^= 0 then if cstb_prevents_parm then return (MODIFY_BINARY + STORE_BINARY + DELETE_BINARY); else return (RETRIEVE_BINARY + MODIFY_BINARY + STORE_BINARY + DELETE_BINARY); else; %skip(1); cstb_binary_scope = 0; if search (cstb_scope, RETRIEVE_CHARACTER) ^= 0 then cstb_binary_scope = RETRIEVE_BINARY; if search (cstb_scope, MODIFY_CHARACTER) ^= 0 then if cstb_prevents_parm then cstb_binary_scope = cstb_binary_scope + MODIFY_BINARY; else cstb_binary_scope = RETRIEVE_BINARY + MODIFY_BINARY; else; if search (cstb_scope, DELETE_CHARACTER) ^= 0 then cstb_binary_scope = cstb_binary_scope + DELETE_BINARY; if search (cstb_scope, STORE_CHARACTER) ^= 0 then cstb_binary_scope = cstb_binary_scope + STORE_BINARY; %skip(1); return (cstb_binary_scope); %skip(1); end convert_scope_to_binary; %page; force_retrieve_kludge_for_modify: proc; %skip(1); dcl frkfm_loop fixed bin; %skip(1); if the_entry_called = "set_scope" then do; forced_retrieve_scope_info.relations.name (pca_scope_index) = scope_information.triplets.relation_name (pca_scope_index); if index (arg, MODIFY_CHARACTER) > 0 & index (arg, RETRIEVE_CHARACTER) = 0 then forced_retrieve_scope_info.relations.retrieve_scope_was_forced (pca_scope_index) = ON; else if arg = UPDATE_CHARACTER then forced_retrieve_scope_info.relations.retrieve_scope_was_forced (pca_scope_index) = ON; else; return; end; %skip(1); if forced_retrieve_scope_info_ptr = null then return; %skip(1); do frkfm_loop = 1 to forced_retrieve_scope_info.number_of_relations_scope_is_set_for while (forced_retrieve_scope_info.relations.name (frkfm_loop) ^= scope_information.triplets.relation_name (pca_scope_index)); end; %skip(1); if frkfm_loop > forced_retrieve_scope_info.number_of_relations_scope_is_set_for then call ssu_$abort_line (sci_ptr, linus_error_$inv_table, "^/Scope hasn't been set for ^a.", scope_information.triplets.relation_name (pca_scope_index)); else; %skip(1); if index (arg, RETRIEVE_CHARACTER) > 0 then if forced_retrieve_scope_info.relations.retrieve_scope_was_forced (frkfm_loop) then call ssu_$abort_line (sci_ptr, linus_error_$r_scope_not_set, "^/Retrieve scope can't be deleted for ^a because it's needed for modify.", forced_retrieve_scope_info.relations.name (frkfm_loop)); else; else if arg = UPDATE_CHARACTER then if ^forced_retrieve_scope_info.relations.retrieve_scope_was_forced (frkfm_loop) then scope_information.triplets.permit_op (pca_scope_index) = scope_information.triplets.permit_op (pca_scope_index) - RETRIEVE_BINARY; else; else; %skip(1); return; %skip(1); end force_retrieve_kludge_for_modify; %skip(1); end process_common_args; %page; process_delete_scope_args: proc; %skip(1); if number_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, DELETE_SCOPE_USAGE_MESSAGE); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); if arg = "*" then do; if number_of_args_supplied > 1 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, DELETE_SCOPE_USAGE_MESSAGE); else delete_all_scope = ON; end; %skip(1); return; %skip(1); end process_delete_scope_args; %page; process_set_scope_args: proc; %skip(1); if number_of_args_supplied ^> 2 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, SET_SCOPE_USAGE_MESSAGE); %skip(1); call ssu_$arg_ptr (sci_ptr, number_of_args_supplied - 1, arg_ptr, arg_length); if arg = "-time" | arg = "-tm" then do; call ssu_$arg_ptr (sci_ptr, number_of_args_supplied, arg_ptr, arg_length); if verify (arg, DIGITS) ^= 0 | arg_length > REASONABLE_NUMBER_OF_DIGITS then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^/The value ^a is not acceptable for a wait time.", arg); wait_time = convert (wait_time, arg); number_of_args_supplied = number_of_args_supplied - 2; end; %skip(1); return; %skip(1); end process_set_scope_args; %page; terminate: proc; %skip(1); if scope_ptr ^= null then free scope_info; if scope_information_ptr ^= null then free scope_information; if arg_list_ptr ^= null then free arg_list_ptr -> arg_list; %skip(1); if cleanup_has_been_signalled & the_entry_called = "set_scope" & forced_retrieve_scope_info_ptr ^= null then do; free forced_retrieve_scope_info; lcb.force_retrieve_scope_info_ptr = null; end; %skip(1); if active_request_flag then if cleanup_has_been_signalled then return_value = "false"; %skip(1); return; %skip(1); end terminate; %page; dcl DELETE_BINARY fixed bin internal static options (constant) init (4); dcl DELETE_CHARACTER char (1) internal static options (constant) init ("d"); dcl DELETE_SCOPE_USAGE_MESSAGE char (71) internal static options (constant) init ("^/Usage: ds table_1 {permit_1 prevent_1 ... table_n permit_n prevent_n}"); dcl DIGITS char (10) internal static options (constant) init ("0123456789"); %skip(1); dcl MODIFY_BINARY fixed bin internal static options (constant) init (8); dcl MODIFY_CHARACTER char (1) internal static options (constant) init ("m"); %skip(1); dcl NULL_CHARACTER char (1) internal static options (constant) init ("n"); %skip(1); dcl OFF bit (1) aligned internal static options (constant) init ("0"b); dcl ON bit (1) aligned internal static options (constant) init ("1"b); dcl ONE_FOR_DATA_BASE_INDEX_AND_ONE_FOR_ERROR_CODE fixed bin internal static options (constant) init (2); dcl ONE_FOR_THE_WAIT_TIME fixed bin internal static options (constant) init (1); %skip(1); dcl PERMITS bit (1) aligned internal static options (constant) init ("0"b); dcl PREVENTS bit (1) aligned internal static options (constant) init ("1"b); %skip(1); dcl REASONABLE_NUMBER_OF_DIGITS fixed bin internal static options (constant) init (5); dcl RETRIEVE_BINARY fixed bin internal static options (constant) init (1); dcl RETRIEVE_CHARACTER char (1) internal static options (constant) init ("r"); dcl SET_SCOPE_USAGE_MESSAGE char (85) internal static options (constant) init ("^/Usage: ss table_1 permit_1 prevent_1 {...table_n permit_n prevent_n {-control_arg}}"); %skip(1); dcl STORE_BINARY fixed bin internal static options (constant) init (2); dcl STORE_CHARACTER char (1) internal static options (constant) init ("s"); %skip(1); dcl UPDATE_CHARACTER char (1) internal static options (constant) init ("u"); %skip(1); dcl VALID_SCOPE_SETTINGS char (6) internal static options (constant) init ("dmnrsu"); dcl VALID_SCOPE_SETTINGS_LENGTH fixed bin internal static options (constant) init (6); %page; dcl active_request_flag bit (1) aligned; dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_list_arg_count fixed bin; dcl arg_list_ptr ptr; dcl arg_ptr ptr; %skip(1); dcl character_30_descriptor bit (36) aligned; dcl cleanup condition; dcl cleanup_has_been_signalled bit (1) aligned; dcl code fixed bin (35); dcl com_err_ entry() options(variable); dcl convert builtin; dcl cu_$generate_call entry (entry, ptr); %skip(1); dcl data_base_pathname char (168); dcl delete_all_scope bit (1) aligned; dcl divide builtin; dcl dsl_$dl_scope entry() options(variable); dcl dsl_$dl_scope_all entry (fixed bin(35), fixed bin(35)); dcl dsl_$get_pn entry (fixed bin (35), char (168), char (20), fixed bin (35)); dcl dsl_$get_scope_info entry (fixed bin (35), ptr, ptr, fixed bin (35)); dcl dsl_$set_scope entry() options(variable); %skip(1); dcl error_codes (1) fixed bin (35); dcl error_table_$bad_conversion fixed bin(35) ext static; dcl error_table_$badcall fixed bin(35) ext static; dcl error_table_$bigarg fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; %skip(1); dcl fixed builtin; dcl fixed_bin_35_descriptor bit (36) aligned; %skip(1); dcl index builtin; %skip(1); dcl length builtin; dcl linus_data_$lock_wait_time fixed bin (35) ext static; dcl linus_error_$ill_scp_op fixed bin(35) ext static; dcl linus_error_$inv_table fixed bin(35) ext static; dcl linus_error_$no_db fixed bin(35) ext static; dcl linus_error_$r_scope_not_set fixed bin(35) ext static; dcl linus_stifle_mrds_sub_error entry ((*) fixed bin(35)); %skip(1); dcl mod builtin; dcl mrds_error_$db_busy fixed bin(35) ext static; dcl mrds_error_$rel_name_too_long fixed bin(35) ext static; dcl mrds_error_$scope_not_empty fixed bin(35) ext static; dcl mrds_error_$scope_not_found fixed bin(35) ext static; dcl mrds_error_$unshared_opening fixed bin(35) ext static; %skip(1); dcl null builtin; dcl number_of_args_supplied fixed bin; %skip(1); dcl opening_mode char (20); %skip(1); dcl rel builtin; dcl return_value char (return_value_length) varying based (return_value_ptr); dcl return_value_length fixed bin (21); dcl return_value_ptr ptr; %skip(1); dcl sci_ptr ptr; dcl 1 scope_information aligned based (scope_information_ptr), 2 data_base_index fixed bin (35), 2 wait_time fixed bin (35), 2 dsl_error_code fixed bin (35), 2 number_of_triplets fixed bin, 2 triplets (si_init_number_of_triplets refer (scope_information.number_of_triplets)), 3 relation_name char (30) unaligned, 3 permit_op fixed bin (35), 3 prevent_op fixed bin (35); dcl scope_information_ptr ptr; dcl search builtin; dcl si_init_number_of_triplets fixed bin; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)); dcl sub_error_ condition; dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl the_entry_called char (12); %skip(1); dcl verify builtin; %skip(1); dcl wait_time fixed bin (35); dcl work_area area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; %page; %include arg_list; %page; %include arg_descriptor; %page; %include linus_lcb; %page; %include linus_forced_scope_info; %page; %include mdbm_scope_info; %page; %include std_descriptor_types; %skip(3); end linus_scope_manager;  linus_set_format_options.pl1 09/16/83 1806.4rew 09/16/83 1740.3 151740 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus set_format_options request. Description and usage follows. Description: This request does one or more of the following actions. 1) Sets INDIVIDUAL formatting option values to USER SPECIFIED VALUES. 2) Sets INDIVIDUAL formatting option values to SYSTEM DEFAULTS. 3) Sets ALL of the formatting option values to SYSTEM DEFAULTS. Usage: set_format_options {-format_option_args} {-control_args} Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - August 1983 */ %page; linus_set_format_options: proc (sci_ptr_parm, lcb_ptr_parm); %skip(3); dcl sci_ptr_parm ptr parm; /* ptr to the subsystem control info structure */ dcl lcb_ptr_parm ptr parm; /* ptr to the linus control block info structure */ %skip(3); /* Mainline Processing Overview. (1) Go through the control args once setting the long and reset flags. (2) Reset all values to system defaults if -reset is in effect. (3) Process the format option args, prompting for value if requested, then setting the value to user provided or system default value. */ %page; %skip(3); call initialize; %skip(1); if reset_flag then do; call linus_options$set_all_to_system_defaults (lcb_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); if number_of_control_args = number_of_args_supplied then return; end; %skip(1); current_arg_number = 1; still_processing_format_option_args = ON; %skip(1); do while (still_processing_format_option_args); call get_argument_set; call get_and_or_set_the_value; end; %skip(1); return; %page; get_accumulated_input: proc; %skip(3); /* Keep picking up pieces of the value concatenating each piece to the one before with a blank separating each one. The value is complete when we see the next format option name, which is recognizable by the leading hyphen. If the arg before the next format option name was -string then conceal the special meaning of "-". The value is also complete when we exhaust the format option arguments. */ %skip(1); still_adding_chunks_of_the_value = ON; %skip(1); do while (still_adding_chunks_of_the_value); %skip(1); call get_next_format_arg (code); if code = NO_MORE_FORMAT_ARGS_LEFT then return; %skip(1); if substr (arg, 1, 1) = "-" & ^this_is_a_string_arg (save_arg_number_for_hyphen_string) then do; still_adding_chunks_of_the_value = OFF; current_arg_number = save_arg_number_for_hyphen_string + 1; still_processing_format_option_args = ON; end; else option_value = option_value || " " || substr (arg, 1, arg_length); %skip(1); end; %skip(1); return; %skip(1); end get_accumulated_input; %page; get_and_or_set_the_value: proc; %skip(3); /* Pick up the rest of the value if necessary. If the previous argument was -string then conceal the special meaning of -prompt and -default. If the value contains a trailing newline only then remove it. If the value contains imedded newlines then make sure it ends with a newline. */ %skip(1); if option_value = "-default" & ^this_is_a_string_arg (save_arg_number_for_hyphen_string) then call linus_options$set_and_check (lcb_ptr, long_option_name, option_identifier, option_value, SYSTEM_DEFAULT, code); else do; if option_value = "-prompt" & ^this_is_a_string_arg (save_arg_number_for_hyphen_string) then call get_prompted_input; else call get_accumulated_input; if length (option_value) > 0 then do; if index (substr (option_value, 1, length (option_value) - 1), NEWLINE) ^= 0 then if substr (option_value, length (option_value)) ^= NEWLINE then option_value = option_value || NEWLINE; else; else if substr (option_value, length (option_value)) = NEWLINE then option_value = substr (option_value, 1, length (option_value) - 1); else; end; call linus_options$set_and_check (lcb_ptr, long_option_name, option_identifier, option_value, NOT_SYSTEM_DEFAULT, code); end; %skip(1); /* Report various errors. */ %skip(1); if code ^= 0 then if code = linus_error_$bad_option_value then if identifier_needed then call ssu_$abort_line (sci_ptr, code, "^/^a is not a valid value for ^a.", option_value, normalized_option_name); else call ssu_$abort_line (sci_ptr, code, "^/^a is not a valid value for ^a.", option_value, long_option_name); else if code = error_table_$nomatch then call ssu_$abort_line (sci_ptr, code, "^/The column identifier ^a did not match any column names.", option_identifier); else call ssu_$abort_line (sci_ptr, code); else; %skip(1); return; %skip(1); end get_and_or_set_the_value; %page; get_argument_set: proc; %skip(3); /* Get the option name. */ %skip(1); call get_next_format_arg (code); if code ^= 0 then call ssu_$abort_line (sci_ptr, 0, "Logic error while processing the request arguments."); %skip(1); /* Translate the short or long name into a long name and find out if a column identifier is needed. */ %skip(1); option_name = arg; call linus_options$check_name (lcb_ptr, option_name, long_option_name, identifier_needed, code); if code ^= 0 then if code = linus_error_$no_lila_expr_processed then call ssu_$abort_line (sci_ptr, code, "^/There must be columns defined before the value of ^a can be set.", long_option_name); else if code = linus_error_$bad_option_name then call ssu_$abort_line (sci_ptr, code, "^/^a is not a valid option name.", option_name); else call ssu_$abort_line (sci_ptr, code); else; %skip(1); /* Get the identifier if its required and check to make sure it's valid so that we never prompt the user for the value when the option identifier is invalid. */ %skip(1); if identifier_needed then do; call get_next_format_arg (code); if code = NO_MORE_FORMAT_ARGS_LEFT then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "The option name ^a was not followed by an identifier.", long_option_name); else; option_identifier = arg; call linus_options$check_identifier (lcb_ptr, long_option_name, option_identifier, normalized_option_name, code); if code ^= 0 then if code = linus_error_$bad_option_identifier then call ssu_$abort_line (sci_ptr, code, "^/^a is not a valid identifier for ^a.", option_identifier, long_option_name); else if code ^= error_table_$nostars then call ssu_$abort_line (sci_ptr, code); else; else; end; else; %skip(1); /* Get the first part of the option value which might be the complete value, part of the value, or the control args -default or -prompt. */ %skip(1); call get_next_format_arg (code); if code = NO_MORE_FORMAT_ARGS_LEFT then call ssu_$abort_line (sci_ptr, linus_error_$bad_option_value, "^/The format option ^a did not have a value supplied.", long_option_name); %skip(1); option_value = arg; %skip(1); return; %skip(1); end get_argument_set; %page; get_next_format_arg: proc (code_parm); %skip(3); /* Ignore control args and get straight to the format option arg. Save the number of the arg preceding the format option arg so -string processing can be done. Make sure that there is another format option arg for the next pass through and set an indicator if we've exhausted them. */ %skip(1); dcl code_parm fixed bin (35) parm; %skip(1); code_parm = 0; %skip(1); /* Skip over the control args and get to the format args. */ %skip(1); do while (this_is_a_control_arg (current_arg_number)); current_arg_number = current_arg_number + 1; end; %skip(1); if current_arg_number > number_of_args_supplied then do; code = NO_MORE_FORMAT_ARGS_LEFT; still_processing_format_option_args = OFF; return; end; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); save_arg_number_for_hyphen_string = current_arg_number - 1; current_arg_number = current_arg_number + 1; %skip(1); /* Make sure there is another format option arg. */ %skip(1); do while (this_is_a_control_arg (current_arg_number)); current_arg_number = current_arg_number + 1; end; %skip(1); if current_arg_number > number_of_args_supplied then still_processing_format_option_args = OFF; %skip(1); return; %skip(1); end get_next_format_arg; %page; get_prompted_input: proc; %skip(3); /* Keep collecting lines from user_input until we hit a line which consists of the single character ".". Don't prompt before collecting if we are in brief mode. If the value is more than one line then leave the newline character after each line. If the value is one line then remove the newline from the end. */ %skip(1); input_buffer = ""; option_value = ""; %skip(1); if ^brief_flag then if identifier_needed then call ioa_ ("Enter ^a.", normalized_option_name); else call ioa_ ("Enter ^a.", long_option_name); else; %skip(1); number_of_input_lines = 0; more_input = ON; %skip(1); do while (more_input); call iox_$get_line (iox_$user_input, input_buffer_ptr, input_buffer_length, number_of_chars_read, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); else; number_of_input_lines = number_of_input_lines + 1; if number_of_chars_read = 2 then if substr (input_buffer, 1, 1) = "." then more_input = OFF; else; else; if more_input then option_value = option_value || substr (input_buffer, 1, number_of_chars_read); end; %skip(1); if number_of_input_lines = 2 then option_value = substr (option_value, 1, length (option_value) - 1); %skip(1); return; %skip(1); end get_prompted_input; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); reset_flag = OFF; brief_flag = OFF; %skip(1); /* Make sure the format options are up to date. */ %skip(1); call linus_options$initialize (lcb_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); %skip(1); /* If no args are given it is an error. */ %skip(1); call ssu_$arg_count (sci_ptr, number_of_args_supplied); if number_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: set_format_options {-format_option_args} {-control_args}"); %skip(1); /* Go through the control args once setting the flags and flagging the control args we should ignore on our next pass through. This is done with a map of bits for the control args and another map of bits for the string args. */ %skip(1); unspec (this_is_a_control_arg) = OFF; unspec (this_is_a_string_arg) = OFF; number_of_control_args = 0; current_arg_number = 1; still_processing_control_args = ON; %skip(1); do while (still_processing_control_args); %skip(1); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); %skip(1); if arg = "-string" | arg = "-str" then do; this_is_a_control_arg (current_arg_number) = ON; this_is_a_string_arg (current_arg_number) = ON; number_of_control_args = number_of_control_args + 1; current_arg_number = current_arg_number + 1; if current_arg_number > number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-string must be followed by a format option value."); else; end; else if arg = "-reset" | arg = "-rs" | arg = "-no_reset" | arg = "-nrs" then do; this_is_a_control_arg (current_arg_number) = ON; number_of_control_args = number_of_control_args + 1; if arg = "-reset" | arg = "-rs" then reset_flag = ON; else reset_flag = OFF; end; else if arg = "-brief" | arg = "-bf" | arg = "-long" | arg = "-lg" then do; this_is_a_control_arg (current_arg_number) = ON; number_of_control_args = number_of_control_args + 1; if arg = "-brief" | arg = "-bf" then brief_flag = ON; else brief_flag = OFF; end; else; %skip(1); current_arg_number = current_arg_number + 1; if current_arg_number > number_of_args_supplied then still_processing_control_args = OFF; %skip(1); end; %skip(1); /* If no format option args were given (only control args were given), then -reset must be in effect or there's nothing to do. */ %skip(1); if number_of_control_args = number_of_args_supplied then if ^reset_flag then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/-reset was not specified and there are no format option values to set."); else; else; %skip(1); /* Used as the buffer to hold prompted input lines. */ %skip(1); input_buffer_ptr = addr (input_buffer); input_buffer_length = MAXIMUM_OPTION_VALUE_LENGTH; option_identifier = ""; %skip(1); return; %skip(1); end initialize; %page; dcl NEWLINE char (1) static int options (constant) init (" "); dcl NO_MORE_FORMAT_ARGS_LEFT fixed bin (35) static int options (constant) init (1); dcl NOT_SYSTEM_DEFAULT bit (1) aligned static int options (constant) init ("0"b); dcl OFF bit (1) aligned static int options (constant) init ("0"b); dcl ON bit (1) aligned static int options (constant) init ("1"b); dcl SYSTEM_DEFAULT bit (1) aligned static int options (constant) init ("1"b); %skip(1); dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl brief_flag bit (1) aligned; %skip(1); dcl code fixed bin (35); dcl current_arg_number fixed bin; %skip(1); dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; dcl error_table_$nomatch fixed bin(35) ext static; dcl error_table_$nostars fixed bin(35) ext static; %skip(1); dcl identifier_needed bit (1) aligned; dcl index builtin; dcl input_buffer char (MAXIMUM_OPTION_VALUE_LENGTH); dcl input_buffer_length fixed bin (21); dcl input_buffer_ptr ptr; dcl ioa_ entry() options(variable); dcl iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl iox_$user_input ptr ext static; %skip(1); dcl lcb_ptr ptr; dcl length builtin; dcl linus_error_$bad_option_identifier fixed bin (35) ext static; dcl linus_error_$bad_option_name fixed bin(35) ext static; dcl linus_error_$bad_option_value fixed bin (35) static ext; dcl linus_error_$no_lila_expr_processed fixed bin(35) ext static; dcl linus_options$check_name entry (ptr, char(*) var, char(*) var, bit(1) aligned, fixed bin(35)); dcl linus_options$initialize entry (ptr, fixed bin(35)); dcl linus_options$check_identifier entry (ptr, char(*) var, char(*) var, char(*) var, fixed bin(35)); dcl linus_options$set_all_to_system_defaults entry (ptr, fixed bin(35)); dcl linus_options$set_and_check entry (ptr, char(*) var, char(*) var, char(*) var, bit(1) aligned, fixed bin(35)); dcl long_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying; %skip(1); dcl more_input bit (1) aligned; %skip(1); dcl number_of_chars_read fixed bin (21); dcl number_of_args_supplied fixed bin; dcl number_of_control_args fixed bin; dcl number_of_input_lines fixed bin; dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying; %skip(1); dcl option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying; dcl option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying; dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying; %skip(1); dcl reset_flag bit (1) aligned; %skip(1); dcl save_arg_number_for_hyphen_string fixed bin; dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl still_adding_chunks_of_the_value bit (1) aligned; dcl still_processing_format_option_args bit (1) aligned; dcl still_processing_control_args bit (1) aligned; dcl substr builtin; %skip(1); dcl this_is_a_control_arg (360) bit (1) unaligned; dcl this_is_a_string_arg (360) bit (1) unaligned; %skip(1); dcl unspec builtin; %page; %include linus_options_extents; %skip(3); end linus_set_format_options;  linus_stifle_mrds_sub_error.pl1 07/29/86 1054.5rew 07/29/86 0938.6 21771 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /* This is the procedure called by linus active requests to stifle the sub_error_ action of mrds, for certain error codes. An example of when this would be used would be for requests like "[open foobar u]". If the database can't be opened because of mrds_error_$db_busy, the request would like to return the value "false" without mrds printing all of the sub_error_ garbage on the terminal. If the database couldn't be opened for other reasons (trouble switch set, doesn't exist, etc.), the garbage will be printed on the terminal and ssu_$abort_line will eventually get called. */ /****^ HISTORY COMMENTS: 1) change(86-01-07,Dupuis), approve(86-05-23,MCR7404), audit(86-07-23,GWMay), install(86-07-29,MR12.0-1106): Initially written. END HISTORY COMMENTS */ /* format: off */ %page; linus_stifle_mrds_sub_error: proc ( error_codes_parm /* input: an array of codes to look for */ ); %skip(1); dcl error_codes_parm (*) fixed bin (35); %skip(1); condition_info_ptr = addr (local_condition_info); condition_info.version = condition_info_version_1; call find_condition_info_ (null (), condition_info_ptr, (0)); %skip(1); sub_error_info_ptr = condition_info.info_ptr; if substr (sub_error_info.name, 1, 9) ^= "mrds_dsl_" & substr (sub_error_info.name, 1, 3) ^= "mu_" & substr (sub_error_info.name, 1, 4) ^= "mus_" then call continue_to_signal_ ((0)); else do loop = 1 to hbound (error_codes_parm, 1); if sub_error_info.header.status_code = error_codes_parm (loop) then return; end; call continue_to_signal_ ((0)); %skip(1); return; %page; dcl addr builtin; dcl continue_to_signal_ entry (fixed bin(35)); dcl find_condition_info_ entry (ptr, ptr, fixed bin(35)); dcl hbound builtin; dcl 1 local_condition_info like condition_info; dcl loop fixed bin; dcl null builtin; dcl substr builtin; %page; %include condition_info; %page; %include condition_info_header; %page; %include sub_error_info; %skip(1); end linus_stifle_mrds_sub_error;  linus_store_from_data_file.pl1 03/16/88 0829.7rew 03/15/88 1551.4 118485 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-01-27,Dupuis), approve(88-03-03,MCR7844), audit(88-03-14,Blair), install(88-03-15,MR12.2-1036): Implemented the -progress/-no_progress and -warning/-no_warning control arguments. END HISTORY COMMENTS */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus store_from_data_file request. Description and usage follows. Description: This request reads the values from a file. It then takes these values and stores them into the specified relation. Usage: "store_from_data_file table_name -control_args" where table_name is the name of the relation where the data will be stored. -control_args can be: -column_delimiter X -- the delimiter used to separate column values. X can be any single ascii character (default is a tilde). -input_file pathname -- the file where the values should be taken from. This is a required control argument. -progress {N} -- prints a progress report every N tuples, where N defaults to linus_data_$trace_every_n_tuples if not specified. -row_delimiter X -- the delimiter used to separate rows. X can be any single ascii character (default is newline character). -warning, -warn, -no_warning, -no_warn -- prints or doesn't print warning messages caused by the storing of duplicate tuples or conversion errors. Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - September 1983 - Al Dupuis */ %page; linus_store_from_data_file: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(3); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(3); /* Mainline Processing Overview: (1) Process control arguments setting flags and collecting values. (2) Get a row from the file. (3) Store the row and repeat 2 and 3 until no more rows. (4) Clean up things. */ %skip(3); call initialize; %skip(1); cleanup_signalled = OFF; on cleanup begin; cleanup_signalled = ON; call terminate; end; %skip(1); call process_args; %skip(1); if ^input_file_has_been_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/An input file name must be supplied."); %skip(1); still_storing = ON; do while (still_storing); call get_row_from_file; if still_storing then do; call store_the_row; if data_file_info.flags.tracing then if mod (data_file_info.current_row_number - 1, data_file_info.trace_every_n_tuples) = 0 then call ioa_ ("^d lines (^d tuples) read from input file. ^d tuples stored.", data_file_info.current_line_number - 1, data_file_info.current_row_number - 1, number_of_tuples_stored); end; else if data_file_info.flags.tracing then call ioa_ ("Storing completed. ^d lines (^d tuples) read, ^d tuples stored.", data_file_info.current_line_number - 1, data_file_info.current_row_number - 1, number_of_tuples_stored); end; %skip(1); call terminate; %skip(1); return; %page; get_row_from_file: proc; %skip(1); dcl grff_code fixed bin (35); %skip(1); if ^file_parsing_has_been_started then do; call linus_parse_file$start (lcb_ptr, addr (data_file_info), table_ip, grff_code); if grff_code ^= 0 then call ssu_$abort_line (sci_ptr, grff_code); file_parsing_has_been_started = ON; end; %skip(1); call linus_parse_file$get_row (lcb_ptr, addr (data_file_info), table_ip, buffer_ptr, grff_code); if grff_code ^= 0 then if grff_code = error_table_$end_of_info then still_storing = OFF; else call ssu_$abort_line (sci_ptr, grff_code); else; %skip(1); return; %skip(1); end get_row_from_file; %page; initialize: proc; %skip(1); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; work_area_ptr = addr (lcb.static_area); %skip(1); unspec (data_file_info) = OFF; data_file_info.flags.process_quotes = ON; data_file_info.column_delimiter = TILDE; data_file_info.row_delimiter = NEWLINE; data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples; buffer_has_been_allocated = OFF; table_info_has_been_allocated = OFF; file_parsing_has_been_started = OFF; input_file_has_been_supplied = OFF; print_warning_messages = ON; number_of_tuples_stored = 0; %skip(1); call ssu_$arg_count (sci_ptr, number_of_args_supplied); if number_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, USAGE_MESSAGE); %skip(1); return; %skip(1); end initialize; %page; process_args: proc; %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); table_name = arg; call linus_table$info_for_store (lcb_ptr, table_name, work_area_ptr, table_ip, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); number_of_columns = table_info.column_count; table_info_has_been_allocated = ON; buffer_length = table_info.row_value_length; allocate buffer in (work_area) set (buffer_ptr); buffer_has_been_allocated = ON; %skip(1); if number_of_args_supplied = 1 then return; %skip(1); current_arg_number = 2; still_processing_args = ON; %skip(1); do while (still_processing_args); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); %skip(1); if arg = "-column_delimiter" | arg = "-cdm" | arg = "-row_delimiter" | arg = "-rdm" then do; current_arg_number = current_arg_number + 1; if current_arg_number > number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/^a must be followed by a delimiter.", arg); else; if arg = "-row_delimiter" | arg = "-rdm" then row_delimiter_flag = ON; else row_delimiter_flag = OFF; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg_length ^= 1 then call ssu_$abort_line (sci_ptr, 0, "The specified delimiter ""^a"" is not a single ascii character.", arg); else; if row_delimiter_flag then data_file_info.row_delimiter = arg; else data_file_info.column_delimiter = arg; end; else if arg = "-input_file" | arg = "-if" then do; current_arg_number = current_arg_number + 1; if current_arg_number > number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/^a must be followed by a pathname.", arg); else; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); data_file_info.output_file_pathname = arg; input_file_has_been_supplied = ON; end; else if arg = "-progress" | arg = "-pg" then do; data_file_info.flags.tracing = ON; if current_arg_number + 1 <= number_of_args_supplied then do; call ssu_$arg_ptr (sci_ptr, current_arg_number + 1, arg_ptr, arg_length); if verify (arg, "01234546789") = 0 then do; data_file_info.trace_every_n_tuples = convert (data_file_info.trace_every_n_tuples, arg); current_arg_number = current_arg_number + 1; end; end; end; else if arg = "-no_progress" | arg = "-npg" then do; data_file_info.flags.tracing = OFF; data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples; end; else if arg = "-warning" | arg = "-warn" then print_warning_messages = ON; else if arg = "-no_warning" | arg = "-no_warn" then print_warning_messages = OFF; else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a is not a valid control argument.", arg); %skip(1); current_arg_number = current_arg_number + 1; if current_arg_number > number_of_args_supplied then still_processing_args = OFF; end; %skip(1); return; %skip(1); end process_args; %page; store_the_row: proc; %skip(1); dcl str_code fixed bin (35); dcl str_loop fixed bin; %skip(1); row_value_p = buffer_ptr; call linus_table$store_row (lcb_ptr, table_ip, row_value_p, str_code); if str_code = 0 then number_of_tuples_stored = number_of_tuples_stored + 1; if str_code = 0 | ((str_code = mrds_error_$duplicate_key | str_code ^= mrds_error_$conversion_condition) & ^print_warning_messages) then return; call ssu_$print_message (sci_ptr, str_code, "^/The error occured on line number ^d while trying to store row number ^d.", data_file_info.current_line_number - 1, data_file_info.current_row_number - 1); call ioa_ ("^/The column values were:"); do str_loop = 1 to number_of_columns; call ioa_ ("^a^x=^x""^a""", table_info.columns.column_name (str_loop), substr (row_value, table_info.columns.column_index (str_loop), table_info.columns.column_length (str_loop))); end; if str_code ^= mrds_error_$duplicate_key & str_code ^= mrds_error_$conversion_condition then call ssu_$abort_line (sci_ptr, 0); %skip(1); return; %skip(1); end store_the_row; %page; terminate: proc; %skip(3); if buffer_has_been_allocated then do; free buffer; buffer_has_been_allocated = OFF; end; %skip(1); if table_info_has_been_allocated then do; store_ap = table_info.store_args_ptr; free store_args; free table_info; table_info_has_been_allocated = OFF; end; %skip(1); if file_parsing_has_been_started then do; call linus_parse_file$stop (lcb_ptr, addr (data_file_info), table_ip, cleanup_signalled, code); file_parsing_has_been_started = OFF; end; %skip(1); return; %skip(1); end terminate; %page; %skip(1); %skip(1); dcl NEWLINE char (1) static internal options (constant) init (" "); %skip(1); dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %skip(1); dcl TILDE char (1) static internal options (constant) init ("~"); dcl USAGE_MESSAGE char (73) static internal options (constant) init ( "^/Usage: store_from_data_file table_name -input_file path {-control_args}"); %page; dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; %skip(1); dcl buffer char (buffer_length) based (buffer_ptr); dcl buffer_has_been_allocated bit (1) aligned; dcl buffer_length fixed bin (21); dcl buffer_ptr ptr; %skip(1); dcl cleanup condition; dcl cleanup_signalled bit (1) aligned; dcl code fixed bin (35); dcl convert builtin; dcl current_arg_number fixed bin; %skip(1); dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$end_of_info fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; %skip(1); dcl file_parsing_has_been_started bit (1) aligned; dcl fixed builtin; %skip(1); dcl input_file_has_been_supplied bit (1) aligned; dcl ioa_ entry() options(variable); %skip(1); dcl linus_data_$trace_every_n_tuples fixed bin (35) external static; dcl linus_parse_file$get_row entry (ptr, ptr, ptr, ptr, fixed bin(35)); dcl linus_parse_file$start entry (ptr, ptr, ptr, fixed bin(35)); dcl linus_parse_file$stop entry (ptr, ptr, ptr, bit(1) aligned, fixed bin(35)); dcl linus_table$info_for_store entry (ptr, char(30), ptr, ptr, fixed bin(35)); dcl linus_table$store_row entry (ptr, ptr, ptr unal, fixed bin(35)); %skip(1); dcl mod builtin; dcl mrds_error_$conversion_condition fixed bin(35) ext static; dcl mrds_error_$duplicate_key fixed bin(35) ext static; %skip(1); dcl number_of_args_supplied fixed bin; dcl number_of_columns fixed bin; dcl number_of_tuples_stored fixed bin (35); %skip(1); dcl print_warning_messages bit (1) aligned; %skip(1); dcl rel builtin; dcl row_delimiter_flag bit (1) aligned; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl ssu_$print_message entry() options(variable); dcl still_processing_args bit (1) aligned; dcl still_storing bit (1) aligned; dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl table_info_has_been_allocated bit (1) aligned; dcl table_name char (30); %skip(1); dcl unspec builtin; %skip(1); dcl verify builtin; %skip(1); dcl work_area area (sys_info$max_seg_size) based (work_area_ptr); dcl work_area_ptr ptr; %page; %include arg_descriptor; %page; %include arg_list; %page; %include iox_dcls; %page; %include iox_modes; %page; %include linus_data_file_info; %page; %include linus_lcb; %page; %include linus_table_info; %skip(3); end linus_store_from_data_file;  linus_temp_seg_mgr.pl1 07/29/86 1051.7r w 07/29/86 0939.7 96651 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ linus_temp_seg_mgr: proc (); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This program implements the temporary segment management features */ /* as used by the LINUS report writer (and possibly other modules later). */ /* */ /* Last Modified: (date and reason): */ /* 04/06/83 original coding by Dave Schimke */ /* taken from get_temporary_segments_.pl1, but modified to add */ /* directory specification. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Parameters */ dcl a_lcb_ptr ptr; dcl a_caller char (*); dcl a_dir char (*); dcl a_ptrs (*) ptr; dcl a_ptr ptr; dcl a_code fixed bin (35); /* */ get_segments: entry (a_lcb_ptr, a_caller, a_dir, a_ptr, a_code); n_segs = dim (a_ptrs, 1); /* get number of segments wanted */ array_ptr = addr (a_ptrs); /* get ptr to the array of ptrs */ gts_join: call initialize; a_code = 0; n_found = 0; /* initialize indicating we've found no free entries */ if a_dir = "" then dir_name = get_pdir_ (); else dir_name = a_dir; status_ip = addr(status_info); call expand_pathname_ (dir_name, containing_dir, dir_entryname, code); if code ^= 0 then do; a_code = code; return; end; call hcs_$status_long (containing_dir, dir_entryname, 1, status_ip, null(), code); if code ^= 0 & code ^= error_table_$no_s_permission then do; a_code = code; return; end; dir_uid = status_info.long.uid; if block_ptr = null then do; /* we haven't yet gotten any segments */ temp_seg_info.number_of_temp_segs, n_blocks = n_segs; /* so get the exact amount requested */ allocate block in (area) set (block_ptr); /* get the needed storage */ temp_seg_info.seg_block_ptr = block_ptr; old_blocks = 0; /* needed by get_new_segments routine */ call get_new_segments; /* do the work in this subr */ return; end; do i = 1 to n_blocks while (n_found < n_segs); /* search for the necessary free segments */ if (^block (i).used & block(i).uid = dir_uid) then do; /* we found another free one */ block (i).used = "1"b; /* mark entry as being used */ block (i).caller = a_caller; /* save name of whose using it */ n_found = n_found + 1; ptrs (n_found) = block (i).segptr; end; end; if n_found < n_segs then do; /* there weren't enough free ones */ new_blocks = n_blocks + n_segs - n_found; /* get more storage, just large enough */ old_blocks = n_blocks; allocate new_block in (area) set (new_block_ptr); /* get the needed storage */ new_block_ptr -> block = block; /* copy the current structure */ free block in (area); temp_seg_info.number_of_temp_segs, n_blocks = new_blocks; temp_seg_info.seg_block_ptr, block_ptr = new_block_ptr; call get_new_segments; /* get the needed segments */ end; return; get_new_segments: proc; dcl (i, j) fixed bin; do i = old_blocks + 1 to n_blocks; /* initialize the new entries */ block (i).used = "1"b; /* the caller will use these blocks */ block (i).caller = a_caller; /* ditto */ block (i).uid = dir_uid; /* save the dir_uid */ ename2 = unique_chars_ (unique_bits_ ()) || ".temp."; ename = substr(ename2, 1, 20); call hcs_$make_seg (dir_name, ename, "", 01110b, block (i).segptr, code); if code ^= 0 then do; call undo; return; end; segment_number = bin (baseno (block (i).segptr), 18); do j = 1 to 4; segno (j) = substr ("01234567", bin (digit (j), 3) + 1, 1); end; call hcs_$chname_seg (block (i).segptr, ename, ename2, code); if code ^= 0 then do; call undo; return; end; call hcs_$set_safety_sw_seg (block (i).segptr, "1"b, code); block (i).name = substr(ename2, 1, 25); n_found = n_found + 1; ptrs (n_found) = block (i).segptr; end; undo: proc; a_code = code; temp_seg_info.number_of_temp_segs, n_blocks = old_blocks; /* reset to the way things were */ do j = old_blocks + 1 to i - 1; /* clean up the segments we already got */ call delete_$ptr (block (j).segptr, "100100"b, "", code); end; end; end; /* */ get_segment: entry (a_lcb_ptr, a_caller, a_dir, a_ptr, a_code); n_segs = 1; /* only 1 segment is being processed */ array_ptr = addr (a_ptr); go to gts_join; /* */ release_segments: entry (a_lcb_ptr, a_caller, a_ptrs, a_code); n_segs = dim (a_ptrs, 1); /* get number of segments wanted */ array_ptr = addr (a_ptrs); /* get ptr to the array of ptrs */ rts_join: call initialize; a_code = 0; do i = 1 to n_segs; /* release each segment passed in */ if ptrs (i) ^= null then do; found_it = "0"b; /* flag says we've not yet found this segment */ do j = 1 to n_blocks while (^found_it); /* search for segment in array */ if block (j).used then do; /* candidate, see if right one */ if ptrs (i) = block (j).segptr then do; /* we found the given segment */ if block (j).caller ^= substr(a_caller, 1, min (length (a_caller),32)) then a_code = error_table_$argerr; else do; /* the right guy (as far as we care) */ call hcs_$truncate_seg (block (j).segptr, 0, code); /* truncate now */ if code ^= 0 then a_code = code; /* accumulate error */ block (j).used = "0"b; /* ditto */ block (j).caller = ""; ptrs (i) = null; found_it = "1"b; end; end; end; end; if ^found_it then a_code = error_table_$argerr; end; end; return; /* */ release_segment: entry (a_lcb_ptr, a_caller, a_ptr, a_code); n_segs = 1; /* only 1 segment is being processed */ array_ptr = addr (a_ptr); goto rts_join; /* */ terminate: entry (a_lcb_ptr, a_code); call initialize; a_code = 0; do i = 1 to n_blocks; /* delete all */ if block(i).used then call com_err_ (0, "linus_temp_seg_mgr", "Warning. An unreleased temp seg has been found. (^a)", block(i).caller); call delete_$ptr (block(i).segptr, "100100"b, "linus_temp_seg_mgr", a_code); end; call release_temp_segment_ ("linus_temp_seg_mgr", temp_seg_info.work_area_ptr, a_code); lcb.temp_seg_info_ptr = null; return; /* */ initialize: proc; lcb_ptr = a_lcb_ptr; sci_ptr = lcb.subsystem_control_info_ptr; info_ptr = lcb.temp_seg_info_ptr; if info_ptr = null then do; allocate temp_seg_info in (lcb.static_area) set (info_ptr); lcb.temp_seg_info_ptr = info_ptr; end; area_p = temp_seg_info.work_area_ptr; if area_p = null then do; call get_temp_segment_ ("linus_temp_seg_mgr", temp_seg_info.work_area_ptr, a_code); allocate area_info set (area_infop); area_info.version = 1; area_info.control.extend = "0"b; area_info.control.zero_on_alloc = "0"b; area_info.control.zero_on_free = "0"b; area_info.control.no_freeing = "0"b; area_info.control.system = "0"b; area_info.owner = a_caller; area_info.pad = "0"b; area_info.size = sys_info$max_seg_size; area_info.areap = temp_seg_info.work_area_ptr; call define_area_ (area_infop, a_code); area_p = temp_seg_info.work_area_ptr; free area_info; end; block_ptr = temp_seg_info.seg_block_ptr; n_blocks = temp_seg_info.number_of_temp_segs; end initialize; /* Automatic */ dcl area_p ptr init (null); dcl array_ptr ptr; dcl block_ptr ptr init (null); dcl code fixed bin (35); dcl containing_dir char(168); dcl dir_entryname char(32); dcl dir_name char(168); dcl dir_uid bit(36) unal; dcl ename char (20); dcl ename2 char (32); dcl found_it bit (1); dcl i fixed bin; dcl info_ptr ptr; dcl j fixed bin; dcl n_blocks fixed bin init (0); dcl n_found fixed bin; dcl n_segs fixed bin; dcl new_block_ptr ptr; dcl new_blocks fixed bin; dcl old_blocks fixed bin; dcl sci_ptr ptr; dcl segment_number fixed bin; dcl segno (4) char (1) defined (ename2) pos (22); dcl status_ip ptr; /* Based */ dcl area area based (area_p); dcl 1 block (n_blocks) aligned based (block_ptr), 2 caller char (32), 2 segptr ptr, 2 name char (25), 2 uid bit(36) unal, 2 used bit (1); dcl 1 temp_seg_info based (info_ptr), 2 number_of_temp_segs fixed bin init (0), 2 seg_block_ptr ptr init(null), 2 work_area_ptr ptr init(null); dcl 1 new_block (new_blocks) aligned based (new_block_ptr) like block; dcl 1 octal_digits aligned based (addr (segment_number)), 2 filler bit (24) unal, 2 digit (4) bit (3) unal; dcl ptrs (n_segs) ptr based (array_ptr); dcl 1 status_info like status_branch; /* Builtin */ dcl (addr, baseno, bin, dim, fixed, length, min, null, rel, substr) builtin; /* Entries */ dcl com_err_ entry() options(variable); dcl define_area_ entry (ptr, fixed bin(35)); dcl delete_$ptr entry (ptr, bit(6), char(*), fixed bin(35)); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl get_pdir_ entry() returns(char(168)); dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl hcs_$chname_seg entry (ptr, char (*), char (*), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); dcl hcs_$set_safety_sw_seg entry (ptr, bit (1), fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl unique_bits_ entry returns (bit (70)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* External */ dcl error_table_$argerr fixed bin (35) ext; dcl error_table_$no_s_permission fixed bin(35) ext static; dcl sys_info$max_seg_size fixed bin(35) ext static; %page; %include area_info; %include linus_lcb; %include status_structures; end linus_temp_seg_mgr;  linus_translate_query.pl1 07/29/86 1051.7r w 07/29/86 0939.7 113814 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ linus_translate_query: proc (sci_ptr, arg_lcb_ptr); /* DESCRIPTION: This is the top level procedure of the LILA translator for LINUS. This procedure deletes the previous MRDS selection expression (if any), sets up the LILA stack header, places the LILA source into a single character string, and calls a procedure to process a set value or a LILA set, whichever is appropriate. The result of this procedure is a select_info structure suitable for use by data base access requests. HISTORY: 77-07-01 J. A. Weeldreyer: Initially written. 78-03-01 J. A. Weeldreyer: Modified to give better error message. 78-03-02 J. A. Weeldreyer: Modified to check ending token. 80-03-13 Rickie E. Brinegar: Modified to use a work area based on lcb.lila_area_ptr rather than getting system free area. 81-10-07 Rickie E. Brinegar: changed to set ls_header.(from_token reserved) to "0"b. This is in response to TR11628. 81-10-07 Rickie E. Brinegar: changed the name of this module from linus_translate to linus_lila_translate as only linus_lila calls it and its purpose in life is to translate a LILA selection expression into a MRDS selection expression. 81-11-06 Rickie E. Brinegar: Change to allocate the selection expression in the lila temporary segment which has its header reset each time the linus lila proc request is issued. Removed calls to linus_free_se as the selection expression is now allocated in the lila area. 82-06-22 Dave J. Schimke: added if-then conditionals to the initialization of select_info.se_vals, select_info.mrds_item, and select_info.user_item to avoid stringrange errors when the extents of the arrays are zero. 82-06-24 Al Dupuis: added code to increment lcb.selection_expression_identifier after sucessful proc'ing of lila select clause. 82-11-15 Dave Schimke: Declared unspec builtin. 83-08-29 Bert Moberg: Changed to linus_translate_query and added the entry point proc for lila 83-08-31 Al Dupuis: Added the setting of error code to linus_error_$no_llila_data or linus_error_$no_current_query depending on whether this was called via "translate_query" or lila "proc". */ %include linus_lcb; %page; %include linus_lit_string; %page; %include linus_ls_header; %page; %include linus_select_info; %page; %include linus_source; %page; %include linus_ef_data; %page; %include linus_rel_array; %page; %include linus_token_data; %page; %include linus_set_fn; dcl (sci_ptr, arg_lcb_ptr) ptr; dcl called_from_lila bit (1); dcl nargs fixed; dcl ( code, /* Output: kill flag */ icode, /* internal status code */ source_pos ) fixed bin (35); /* curr. pos. while making source str. */ dcl i fixed bin; /* internal index */ dcl ( rec_len, /* LILA source record length */ nread ) fixed bin (21); /* num. chars read */ dcl work_area area (sys_info$max_seg_size) based (lcb.lila_area_ptr); dcl fn_name char (32) var; /* name of set function */ dcl 1 tok_data aligned like token_data; dcl 1 set_fn_data aligned like ef_data; dcl token char (tok_data.length) based (tok_data.t_ptr); /* token value */ dcl sex char (select_info.se_len) based (select_info.se_ptr); dcl key char (256) var; /* LILA source line no. */ dcl BOF fixed bin int static options (constant) init (-1); dcl HEADER fixed bin int static options (constant) init (1); dcl SET_FUN fixed bin int static options (constant) init (3); dcl KILL fixed bin (35) int static options (constant) init (1); dcl NOKILL fixed bin (35) int static options (constant) init (0); dcl ( linus_data_$max_user_items, linus_data_$max_expr_items, linus_data_$lila_id, linus_data_$lit_string_size, linus_data_$max_range_items, linus_data_$max_lvars, linus_error_$text_follows, linus_error_$no_current_query, linus_error_$no_db, linus_error_$no_input_arg_reqd, linus_error_$no_lila_data, mrds_data_$max_select_items, sys_info$max_seg_size ) fixed bin (35) ext; dcl linus_lila_error_ condition; dcl (null, substr, after, addr, fixed, rel, unspec) builtin; dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$read_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl linus_define_area entry (ptr, char (6), fixed bin (35)); dcl linus_lila_get_token entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35)); dcl linus_lila_set_fn entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_set entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl linus_lila_error entry (ptr, ptr, fixed bin (35), char (*)); dcl linus_print_error entry (fixed bin (35), char (*)); dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35)); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$abort_line entry() options(variable); dcl ssu_$abort_subsystem entry() options(variable); lcb_ptr = arg_lcb_ptr; called_from_lila = "0"b; call ssu_$arg_count (sci_ptr, nargs); if nargs ^= 0 then call error (linus_error_$no_input_arg_reqd, "", NOKILL); goto common; auto: entry (sci_ptr, arg_lcb_ptr); /* Auto proc doesn't care if there were arguments */ lcb_ptr = arg_lcb_ptr; called_from_lila = "0"b; goto common; proc: entry (arg_lcb_ptr, code); lcb_ptr = arg_lcb_ptr; called_from_lila = "1"b; common: if lcb.db_index = 0 then call ssu_$abort_line (lcb.subsystem_control_info_ptr, linus_error_$no_db); si_ptr, lsh_ptr, lcb.lit_ptr = null; /* init. */ lcb.si_ptr = null; on linus_lila_error_ begin; if ^called_from_lila then call ssu_$abort_line (sci_ptr); go to exit; end; call linus_define_area (lcb.lila_area_ptr, "LILA", icode); if icode ^= 0 then call error (icode, "", icode); linus_rel_array_ptr = lcb.rel_array_ptr; linus_rel_array.num_of_rels = 0; if lcb.lila_count <= 0 then if called_from_lila then call error (linus_error_$no_lila_data, "", NOKILL); else call error (linus_error_$no_current_query, "", NOKILL); else; allocate ls_header in (work_area); /* set up lila stack header */ ls_header.type = HEADER; ls_header.src_ptr, ls_header.back_ptr, ls_header.fwd_ptr = null; ls_header.cur_ptr = lsh_ptr; ls_header.trans_failed = "0"b; ls_header.from_token = "0"b; ls_header.reserved = "0"b; call iox_$position (lcb.liocb_ptr, BOF, 0, icode);/* position to begining of lila source file */ if icode ^= 0 then call error (icode, "LILA source file", KILL); allocate source_str in (work_area); /* place for string version */ source_pos = 1; /* initialize */ ls_header.line_data.lno (0) = "0000"; ls_header.line_data.last_char (0) = 0; do i = 1 to lcb.lila_count; /* for every source line */ call iox_$read_key (lcb.liocb_ptr, key, rec_len, icode); /* get record len. */ if icode ^= 0 then call error (icode, "LILA source file", KILL); call iox_$read_record (lcb.liocb_ptr, addr (source_array (source_pos)), rec_len, nread, icode); /* read the record */ if icode ^= 0 then call error (icode, "LILA source file", KILL); source_pos = source_pos + rec_len; /* update position */ ls_header.line_data.lno (i) = key; ls_header.line_data.last_char (i) = ls_header.line_data.last_char (i - 1) + rec_len; /* and line char table */ end; /* making source string */ ls_header.cur_pos = 1; /* initialize scan pos. */ allocate lit_string in (work_area); lit_string = "0"b; lcb.curr_lit_offset = 0; call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, addr (tok_data), icode); /* get first token */ if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); if tok_data.key = SET_FN then do; /* if set function */ fn_name = token; /* save name */ call linus_lila_set_fn (lcb_ptr, lsh_ptr, addr (tok_data), addr (set_fn_data), icode); /* process set funct. */ if icode ^= 0 then call error (icode, "", NOKILL); nsv_init, nmi_init = 0; /* allocate and set up select info for set funct. */ nui_init = 1; allocate select_info in (work_area); unspec (select_info.se_flags) = "0"b; if select_info.nsv_alloc ^= 0 then unspec (select_info.se_vals) = "0"b; if select_info.nmi_alloc ^= 0 then unspec (select_info.mrds_item) = "0"b; if select_info.nui_alloc ^= 0 then unspec (select_info.user_item) = "0"b; select_info.set_fn, select_info.se_flags.val_ret = "1"b; select_info.dup_flag, select_info.unique_flag, select_info.se_flags.val_dtt, select_info.se_flags.val_del, select_info.se_flags.val_mod = "0"b; select_info.prior_sf_ptr, select_info.se_ptr, select_info.sel_items_ptr = null; select_info.nsevals, select_info.n_mrds_items, select_info.sel_items_len, select_info.se_len = 0; select_info.n_user_items = 1; select_info.user_item.name (1) = fn_name; select_info.user_item.item_type (1) = SET_FUN; select_info.user_item.rslt_desc (1) = set_fn_data.desc; select_info.user_item.rslt_bit_len (1) = set_fn_data.bit_length; select_info.user_item.rslt_assn_ptr (1) = set_fn_data.assn_ptr; select_info.user_item.rslt_assn_type (1) = set_fn_data.assn_type; select_info.user_item.rslt_assn_len (1) = set_fn_data.assn_len; select_info.user_item.item_ptr = set_fn_data.ef_ptr; set_fn_data.ef_ptr -> linus_set_fn.fwd_ptr = null; /* no other set fn at this level */ end; /* if set value */ else do; /* if lila set */ nmi_init = mrds_data_$max_select_items; /* init and alloc select info */ nui_init = linus_data_$max_user_items; nsv_init = linus_data_$max_range_items + linus_data_$max_lvars; allocate select_info in (work_area); call linus_lila_set (lcb_ptr, lsh_ptr, addr (tok_data), si_ptr, icode); /* process the lila set */ if icode ^= 0 then call error (icode, "", NOKILL); if select_info.dup_flag & ^select_info.unique_flag then /* need to add -dup */ substr (after (sex, "-select "), 1, 4) = "-dup"; end; /* if lila set */ if tok_data.key ^= NULL then /* must end with null token */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$text_follows, token); if ls_header.cur_pos < lcb.lila_chars then do; /* if text left */ call linus_lila_get_token (lcb_ptr, lsh_ptr, ls_header.cur_pos, addr (tok_data), icode); if icode ^= 0 then call linus_lila_error (lcb_ptr, lsh_ptr, icode, token); if tok_data.key ^= NULL then /* if meaningfull data at end */ call linus_lila_error (lcb_ptr, lsh_ptr, linus_error_$text_follows, token); end; ls_header.src_ptr = null; lcb.si_ptr = si_ptr; lsh_ptr = null; lcb.selection_expression_identifier = lcb.selection_expression_identifier + 1; exit: return; error: proc (cd, msg, fatal_flag); /* error procedure */ dcl (cd, ucd, fatal_flag) fixed bin (35); dcl msg char (*); call linus_convert_code (cd, ucd, linus_data_$lila_id); call linus_print_error (ucd, msg); if ^called_from_lila then do; if fatal_flag = NOKILL then call ssu_$abort_line (sci_ptr); else call ssu_$abort_subsystem (sci_ptr); end; else code = fatal_flag; go to exit; end error; end linus_translate_query;  linus_write_data_file.pl1 03/16/88 0829.7rew 03/15/88 1551.5 120645 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-01-27,Dupuis), approve(88-03-03,MCR7844), audit(88-03-14,Blair), install(88-03-15,MR12.2-1036): Implemented the -progress/-no_progress control arguments. END HISTORY COMMENTS */ /* format: off */ %skip(3); /* This is the main level procedure called by ssu_ to implement the linus write_data_file request. Description and usage follows. Description: This request retrieves the selected data from the data base and writes it to a file which can later be input to the load_data_file request. Usage: "write_data_file pathname {-control_args}" pathname is the required file where the data will be written to. -control_args can be: -column_delimiter X -- the delimiter used to separate column values. X can be any single ascii character (default is one blank). The old control arg -delimiter is still accepted but not documented. -create_columns N {... N} -- new columns with null values are placed in the specified column positions. -extend -- the file is extended rather than truncated. -progress {N} -- prints a progress report every N tuples, where N defaults to linus_data_$trace_every_n_tuples if not specified. -row_delimiter X -- the delimiter used to separate rows. X can be any single ascii character (default is newline character). -truncate -- the file is truncated rather than extended (default). Both parameters are passed to this request by ssu_. Known Bugs: Other Problems: History: Written - Al Dupuis - September 1983. */ %page; linus_write_data_file: proc ( sci_ptr_parm, /* input: ptr to the subsystem control info structure */ lcb_ptr_parm /* input: ptr to the linus control block info structure */ ); %skip(3); dcl sci_ptr_parm ptr parm; dcl lcb_ptr_parm ptr parm; %skip(3); /* Mainline Processing Overview: (1) Process control arguments setting flags and collecting values. (2) Have the subroutine do all the work (it reports errors and calls ssu_$abort_line if things don't go well). */ %skip(3); call initialize; on cleanup call terminate; call process_args; call linus_create_data_file (lcb_ptr, addr (data_file_info)); call terminate; %skip(1); return; %page; initialize: proc; %skip(3); sci_ptr = sci_ptr_parm; lcb_ptr = lcb_ptr_parm; %skip(1); unspec (data_file_info) = OFF; data_file_info.column_delimiter = TILDE; data_file_info.row_delimiter = NEWLINE; data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples; %skip(1); data_file_info.flags.truncate_file = ON; data_file_info.flags.check_values_for_delimiters = ON; create_columns_map_has_been_allocated = OFF; %skip(1); return; %skip(1); end initialize; %page; process_args: proc; %skip(3); call ssu_$arg_count (sci_ptr, number_of_args_supplied); if number_of_args_supplied = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: write_data_file pathname {-control_args}."); %skip(1); call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length); data_file_info.output_file_pathname = arg; if number_of_args_supplied = 1 then return; %skip(1); current_arg_number = 2; still_processing_args = ON; %skip(1); do while (still_processing_args); %skip(1); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); argument_type = lookup_arg_number (arg); if argument_type = 0 then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^/Invalid control argument ^a.", arg); else; %skip(1); if argument_type ^> ARGUMENT_TYPE_1 then call process_args_type_1 (argument_type); else if argument_type ^> ARGUMENT_TYPE_2 then call process_args_type_2 (argument_type); else if argument_type ^> ARGUMENT_TYPE_3 then call process_args_type_3 (argument_type); else call process_args_type_4 (argument_type); %skip(1); current_arg_number = current_arg_number + 1; if current_arg_number > number_of_args_supplied then still_processing_args = OFF; %skip(1); end; %skip(1); return; %page; lookup_arg_number: proc ( argument_parm /* input: name of control argument */ ) returns (fixed bin); %skip(3); dcl argument_parm char (*) parm; %skip(1); if argument_parm = "-column_delimiter" | argument_parm = "-cdm" then return (COLUMN_DELIMITER_INDEX); else if argument_parm = "-row_delimiter" | argument_parm = "-rdm" then return (ROW_DELIMITER_INDEX); else if argument_parm = "-extend" then return (EXTEND_INDEX); else if argument_parm = "-truncate" | argument_parm = "-tc" then return (TRUNCATE_INDEX); else if argument_parm = "-create_columns" | argument_parm = "-crc" then return (CREATE_COLUMNS_INDEX); else if argument_parm = "-progress" | argument_parm = "-pg" then return (TRACE_INDEX); else if argument_parm = "-no_progress" | argument_parm = "-npg" then return (NO_TRACE_INDEX); else return (0); %skip(1); end lookup_arg_number; %page; process_args_type_1: proc ( argument_type_parm /* input: index for type of argument */ ); %skip(3); dcl argument_type_parm fixed bin parm; %skip(1); current_arg_number = current_arg_number + 1; if current_arg_number > number_of_args_supplied then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, ERROR_MESSAGE_FOR_MISSING_MODIFIER (argument_type)); %skip(1); call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg_length ^= 1 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, ERROR_MESSAGE_FOR_MISSING_MODIFIER (argument_type) || "^/The delimiter ""^a"" is invalid.", arg); else; if argument_type = COLUMN_DELIMITER_INDEX then data_file_info.column_delimiter = arg; else data_file_info.row_delimiter = arg; %skip(1); return; %skip(1); end process_args_type_1; %page; process_args_type_2: proc ( pat2_argument_type_parm /* input: index for type of argument */ ); %skip(1); dcl pat2_argument_type_parm fixed bin parm; dcl pat2_current_arg_number fixed bin; dcl pat2_error_occured bit (1) aligned; dcl pat2_loop fixed bin; dcl pat2_still_processing_args bit (1) aligned; %skip(1); current_arg_number = current_arg_number + 1; pat2_error_occured = OFF; if current_arg_number > number_of_args_supplied then pat2_error_occured = ON; else do; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if arg_length = 0 then pat2_error_occured = ON; else if substr (arg, 1, 1) = "-" then pat2_error_occured = ON; else; end; if pat2_error_occured then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, ERROR_MESSAGE_FOR_MISSING_MODIFIER (argument_type)); else; %skip(1); if create_columns_map_has_been_allocated then do; free create_columns_map in (lcb.static_area); create_columns_map_has_been_allocated = OFF; data_file_info.flags.create_new_columns = OFF; end; %skip(1); create_columns_map_init_number_of_columns = 0; pat2_current_arg_number = current_arg_number; pat2_still_processing_args = ON; %skip(1); do while (pat2_still_processing_args); call ssu_$arg_ptr (sci_ptr, pat2_current_arg_number, arg_ptr, arg_length); if arg_length ^> 0 then pat2_still_processing_args = OFF; else if substr (arg, 1, 1) = "-" then pat2_still_processing_args = OFF; else do; create_columns_map_init_number_of_columns = create_columns_map_init_number_of_columns + 1; pat2_current_arg_number = pat2_current_arg_number + 1; if pat2_current_arg_number > number_of_args_supplied then pat2_still_processing_args = OFF; else; end; end; %page; allocate create_columns_map in (lcb.static_area) set (create_cm_ptr); create_columns_map_has_been_allocated = ON; create_columns_map.column_numbers (*) = 0; %skip(1); do pat2_loop = 1 to create_columns_map_init_number_of_columns; call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length); if verify (arg, DIGITS) ^= 0 then call ssu_$abort_line (sci_ptr, 0, "The argument ""^a"" could not be converted to a column position.", arg); create_columns_map.column_numbers (pat2_loop) = convert (pat2_loop, arg); if create_columns_map.column_numbers (pat2_loop) = 0 then call ssu_$abort_line (sci_ptr, 0, "The argument ""^a"" cannot be used a column position.", arg); current_arg_number = current_arg_number + 1; end; %skip(1); data_file_info.create_columns_map_ptr = create_cm_ptr; data_file_info.flags.create_new_columns = ON; %skip(1); return; %skip(1); end process_args_type_2; %page; process_args_type_3: proc ( argument_type_parm /* input: index for type of argument */ ); %skip(3); dcl argument_type_parm fixed bin parm; %skip(1); if argument_type = EXTEND_INDEX then data_file_info.flags.truncate_file = OFF; else if argument_type = TRUNCATE_INDEX then data_file_info.flags.truncate_file = ON; else if argument_type = NO_TRACE_INDEX then do; data_file_info.tracing = OFF; data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples; end; %skip(1); return; %skip(1); end process_args_type_3; %page; process_args_type_4: proc ( argument_type_parm /* input: index for type of argument */ ); %skip(3); dcl argument_type_parm fixed bin parm; %skip(1); data_file_info.tracing = ON; %skip(1); if current_arg_number + 1 > number_of_args_supplied then return; %skip(1); call ssu_$arg_ptr (sci_ptr, current_arg_number + 1, arg_ptr, arg_length); if verify (arg, "01234546789") = 0 then do; data_file_info.trace_every_n_tuples = convert (data_file_info.trace_every_n_tuples, arg); current_arg_number = current_arg_number + 1; end; %skip(1); return; %skip(1); end process_args_type_4; %skip(1); end process_args; %page; terminate: proc; %skip(3); if create_columns_map_has_been_allocated then do; free create_columns_map in (lcb.static_area); create_columns_map_has_been_allocated = OFF; end; %skip(1); return; %skip(1); end terminate; %page; dcl ARGUMENT_TYPE_1 fixed bin static internal options (constant) init (2); dcl ARGUMENT_TYPE_2 fixed bin static internal options (constant) init (3); dcl ARGUMENT_TYPE_3 fixed bin static internal options (constant) init (6); %skip(1); dcl COLUMN_DELIMITER_INDEX fixed bin static internal options (constant) init (1); dcl CREATE_COLUMNS_INDEX fixed bin static internal options (constant) init (3); %skip(1); dcl DIGITS char (10) static internal options (constant) init ("0123456789"); %skip(1); dcl ERROR_MESSAGE_FOR_MISSING_MODIFIER (ARGUMENT_TYPE_2) char (65) init ( "^/-column_delimiter must be followed by a single ascii character.", "^/-row_delimiter must be followed by a single ascii character.", "^/-create_columns must be followed by column numbers." ); dcl EXTEND_INDEX fixed bin static internal options (constant) init (4); %skip(1); dcl NEWLINE char (1) static internal options (constant) init (" "); dcl NO_TRACE_INDEX fixed bin static internal options (constant) init (6); %skip(1); dcl OFF bit (1) aligned static internal options (constant) init ("0"b); dcl ON bit (1) aligned static internal options (constant) init ("1"b); %skip(1); dcl ROW_DELIMITER_INDEX fixed bin static internal options (constant) init (2); %skip(1); dcl TILDE char (1) static internal options (constant) init ("~"); dcl TRUNCATE_INDEX fixed bin static internal options (constant) init (5); dcl TRACE_INDEX fixed bin static internal options (constant) init (7); %page; dcl addr builtin; dcl arg char (arg_length) based (arg_ptr); dcl arg_length fixed bin (21); dcl arg_ptr ptr; dcl argument_type fixed bin; %skip(1); dcl cleanup condition; dcl convert builtin; dcl create_columns_map_has_been_allocated bit (1) aligned; dcl current_arg_number fixed bin; %skip(1); dcl error_table_$bad_arg fixed bin(35) ext static; dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; %skip(1); dcl fixed builtin; %skip(1); dcl linus_create_data_file entry (ptr, ptr); dcl linus_data_$trace_every_n_tuples fixed bin (35) external static; %skip(1); dcl number_of_args_supplied fixed bin; %skip(1); dcl rel builtin; %skip(1); dcl sci_ptr ptr; dcl ssu_$abort_line entry() options(variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)); dcl still_processing_args bit (1) aligned; dcl substr builtin; dcl sys_info$max_seg_size fixed bin(35) ext static; %skip(1); dcl unspec builtin; %skip(1); dcl verify builtin; %page; %include linus_data_file_info; %page; %include linus_lcb; %skip(3); end linus_write_data_file; */ ----------------------------------------------------------- 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 */