deckfile_manager.pl1 10/21/92 1023.4rew 10/21/92 1021.1 118197 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Bull Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-21,Fakoury), approve(86-08-21,MCR7515), audit(87-01-07,Farley), install(87-01-08,MR12.0-1263): Originally coded 0682 by R. Fakoury for MR12. 2) change(89-11-08,Fakoury), approve(89-11-20,MECR0014), audit(89-11-09,Parisek), install(89-11-20,MR12.3-1120): To correct the path for the info dir. 3) change(89-11-20,Fakoury), approve(89-11-20,PBF8146), audit(89-11-20,Parisek), install(89-11-20,MR12.3-1120): Again, correct info dir problem. Let ssu_ figure it out. END HISTORY COMMENTS */ /* The deckfile_manager command provides the functionallity to maintain a tandd_deck_file */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ deckfile_manager: dfm: proc (); /* Automatic */ dcl ab_sw bit (1) aligned; dcl argl fixed bin (21); dcl argp ptr; dcl arg_num fixed bin; dcl code fixed bin (35); dcl debug_sw bit (1) aligned; dcl deckfile_length fixed bin (21); dcl deckfile_ptr ptr; dcl nargs fixed bin; dcl profile_dir char (168); dcl profile_entry char (32); dcl profile_length fixed bin (21); dcl profile_ptr ptr; dcl profile_sw bit (1); dcl prompt_length fixed bin (21); dcl prompt_ptr ptr; dcl prompt_sw bit (1); dcl quit_sw bit (1); dcl request_loop_sw bit (1); dcl ready_sw bit (1) aligned; dcl request_sw bit (1); dcl request_line_length fixed bin (21); dcl request_line_ptr ptr; dcl sci_ptr ptr; dcl startup_sw bit (1); /* Based */ dcl arg char (argl) based (argp); dcl deckfile_string char (deckfile_length) based (deckfile_ptr); dcl free_area area based (get_system_free_area_ ()); dcl profile_string char (profile_length) based (profile_ptr); dcl prompt_string char (prompt_length) aligned based (prompt_ptr); /* Builtins */ dcl addr builtin; dcl codeptr builtin; dcl null builtin; /* Conditions */ dcl cleanup condition; /* Constants */ dcl dfm_version_1 char (4) int static options (constant) init ("1.0a"); dcl false bit (1) int static options (constant) init ("0"b); dcl last_position fixed bin int static options (constant) init (9999); dcl max_prompt_length fixed bin int static options (constant) init (64); dcl myname char (3) int static options (constant) init ("dfm"); dcl true bit (1) int static options (constant) init ("1"b); /* Entries */ dcl active_fnc_err_ entry options (variable); dcl com_err_ entry () options (variable); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_list_ptr entry () returns (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$generate_call entry (entry, ptr); dcl dfm_$clean_up entry (ptr, ptr); dcl dfm_$pi_handler entry; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ssu_$add_info_dir entry (ptr, char (*), fixed bin, fixed bin (35)); dcl ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35)); dcl ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl ssu_$execute_start_up entry () options (variable); dcl ssu_$get_temp_segment entry (ptr, char (*), ptr); dcl ssu_$listen entry (ptr, ptr, fixed bin (35)); dcl ssu_$record_usage entry (ptr, ptr, fixed bin (35)); dcl ssu_$release_temp_segment entry (ptr, ptr); dcl ssu_$set_abbrev_info entry (ptr, ptr, ptr, bit (1) aligned); dcl ssu_$set_debug_mode entry (ptr, bit (1) aligned); dcl ssu_$set_ec_suffix entry (ptr, char (32)); dcl ssu_$set_procedure entry (ptr, char (*), entry, fixed bin (35)); dcl ssu_$set_prompt entry (ptr, char (64) var); dcl ssu_$set_prompt_mode entry (ptr, bit (*)); dcl ssu_$set_ready_mode entry (ptr, bit (1) aligned); /* External */ dcl dfm_request_table_$dfm_request_table_ fixed bin ext static; dcl error_table_$active_function fixed bin (35) ext static; dcl error_table_$badopt 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_$not_act_fnc fixed bin (35) ext static; dcl ssu_et_$subsystem_aborted fixed bin (35) ext static; dcl ssu_et_$program_interrupt fixed bin (35) ext static; dcl ssu_et_$null_request_line fixed bin (35) ext static; dcl ssu_et_$request_line_aborted fixed bin (35) ext static; dcl ssu_info_directories_$standard_requests char (168) external; dcl ssu_request_tables_$standard_requests bit (36) aligned external; %page; call cu_$af_return_arg (nargs, null (), 0, code); if code ^= error_table_$not_act_fnc then do; if code = 0 then call active_fnc_err_ (error_table_$active_function, myname); else call com_err_ (code, myname); return; end; call dfm_init (); on cleanup call deckfile_manager_cleanup (); do arg_num = 1 to nargs; /* process all the arguments */ call cu_$arg_ptr (arg_num, argp, argl, code); if code ^= 0 then call complain (code, myname, "Getting arg ptr."); if arg = "-abbrev" | arg = "-ab" then ab_sw = true; else if arg = "-debug" | arg = "-db" then debug_sw = true; else if arg = "-deckfile" | arg = "-dkf" then do; call next_arg (deckfile_ptr, deckfile_length, code); if code ^= 0 then call complain (code, myname, "Getting deckfile pathname."); call expand_pathname_ (deckfile_string, dfm_info.deckfile_dir, dfm_info.deckfile_entry, code); if code ^= 0 then call complain (code, myname, "Expanding deckfile pathname."); end; else if arg = "-no_abbrev" | arg = "-nab" then ab_sw = false; else if arg = "-no_debug" | arg = "-ndb" then debug_sw = false; else if arg = "-no_prompt" then prompt_sw = false; else if arg = "-no_startup" | arg = "-nsu" then startup_sw = false; else if arg = "-profile" | arg = "-pf" then do; call next_arg (profile_ptr, profile_length, code); if code ^= 0 then call complain (code, myname, "Getting profile pathname."); call expand_pathname_$add_suffix (profile_string, "profile", profile_dir, profile_entry, code); if code ^= 0 then call complain (code, myname, "Expanding profile pathname."); call initiate_file_ (profile_dir, profile_entry, R_ACCESS, profile_ptr, 0, code); if profile_ptr = null () then call complain (code, myname, "Initiating the profile ^a>^a.", profile_dir, profile_entry); ab_sw, profile_sw = true; end; else if arg = "-prompt" then do; call next_arg (prompt_ptr, prompt_length, code); if code ^= 0 then call complain (code, myname, "Getting prompt string"); if prompt_length > max_prompt_length then call complain (error_table_$bigarg, myname, "The prompt may be a maximum of ^d characters", max_prompt_length); prompt_sw = true; end; else if arg = "-quit" | arg = "-q" then quit_sw, dfm_info.flags.force_quit = true; else if arg = "-ready_off" | arg = "-rdf" then ready_sw = false; else if arg = "-ready_on" | arg = "-rdn" then ready_sw = true; else if arg = "-request" | arg = "-rq" then do; if request_sw then call complain (error_table_$inconsistent, myname, "Only one request per invocation"); call next_arg (request_line_ptr, request_line_length, code); if code ^= 0 then call complain (code, myname, "Getting request line"); request_sw = true; end; else if arg = "-request_loop" | arg = "-rql" then request_loop_sw = true; else if arg = "-startup" | arg = "su" then startup_sw = true; else call complain (error_table_$badopt, myname, "^a", arg); end; /* end argument processing */ call ssu_$create_invocation (myname, dfm_version_1, dfm_infop, addr (dfm_request_table_$dfm_request_table_), ">doc>subsystem>dfm", sci_ptr, code); if code ^= 0 then call complain (code, myname, "Creating subsystem invocation."); call ssu_$record_usage (sci_ptr, codeptr (dfm), 0); call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests, last_position, code); if code ^= 0 then call complain (code, myname, "Adding ssu info dir."); call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), last_position, code); if code ^= 0 then call complain (code, myname, "Adding ssu request table."); call ssu_$set_procedure (sci_ptr, "program_interrupt", dfm_$pi_handler, code); if code ^= 0 then call complain (code, myname, "Adding pi handler."); call ssu_$set_ec_suffix (sci_ptr, "dfmec"); call ssu_$get_temp_segment (sci_ptr, "dfm_data", dfm_info.dfm_data_ptr); call ssu_$set_abbrev_info (sci_ptr, profile_ptr, profile_ptr, ab_sw); call ssu_$set_debug_mode (sci_ptr, debug_sw); if prompt_sw & prompt_length > 0 then call ssu_$set_prompt (sci_ptr, (prompt_string)); call ssu_$set_prompt_mode (sci_ptr, ^prompt_sw); call ssu_$set_ready_mode (sci_ptr, ready_sw); if startup_sw then do; call ssu_$execute_start_up (sci_ptr, code); if code ^= 0 then call complain (code, myname, "Executing ssu startup."); end; if request_sw then do; call ssu_$execute_line (sci_ptr, request_line_ptr, request_line_length, code); if code ^= 0 then do; if (code = ssu_et_$null_request_line | code = ssu_et_$program_interrupt | code = ssu_et_$request_line_aborted) & request_loop_sw then goto listen; else if code = ssu_et_$subsystem_aborted then goto subsystem_wrapup; /* normal end of subsystem */ else call complain (code, myname, "Encountered while executing request line"); end; end; if quit_sw then goto subsystem_wrapup; listen: call ssu_$listen (sci_ptr, null (), code); if code ^= ssu_et_$subsystem_aborted then call com_err_ (code, myname, "Calling the listener."); subsystem_wrapup: call deckfile_manager_cleanup (); return; %page; /* complain - an internal proc to print an error message and wrapup. */ complain: proc () options (variable); call cu_$generate_call (com_err_, cu_$arg_list_ptr ()); goto subsystem_wrapup; end complain; %page; /* deckfile_manager_cleanup - internal proc to cleanup a deckfile_manager invocation. */ deckfile_manager_cleanup: proc (); if dfm_infop ^= null then do; if dfm_info.flags.request_active then call dfm_$clean_up (sci_ptr, dfm_infop); if dfm_info.dfm_data_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, dfm_info.dfm_data_ptr); if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr); free dfm_info in (free_area); dfm_infop = null; end; end deckfile_manager_cleanup; %page; /* Internal proc that initializes dfm variables */ dfm_init: proc (); dfm_infop = null; allocate dfm_info in (free_area) set (dfm_infop); ab_sw = false; debug_sw = false; dfm_info.deckfile_dir = ""; dfm_info.deckfile_entry = ""; dfm_info.dfm_data_ptr = null; dfm_info.page_number = 0; dfm_info.flags.request_active = false; dfm_info.force_quit = false; dfm_info.pad = "0"b; dfm_info.version = dfm_info_version_1; profile_ptr = null; profile_sw = false; prompt_length = 0; prompt_ptr = null; prompt_sw = true; /* default is to prompt */ quit_sw = false; request_loop_sw = false; ready_sw = false; request_sw = false; request_line_length = 0; request_line_ptr = null; sci_ptr = null; startup_sw = false; end dfm_init; %page; /* Internal proc that gets the next argument from the argument string, complaining if it's not there */ next_arg: proc (nargp, nargl, nacode); dcl nargp ptr; dcl nacode fixed bin (35); dcl nargl fixed bin (21); arg_num = arg_num + 1; call cu_$arg_ptr (arg_num, nargp, nargl, nacode); end next_arg; %page; %include access_mode_values; %page; %include dfm_info; %page; %include ssu_prompt_modes; end deckfile_manager;  dfm_.pl1 10/21/92 1023.4rew 10/21/92 1021.6 553842 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Bull Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-21,Fakoury), approve(86-08-21,MCR7515), audit(87-01-07,Farley), install(87-01-08,MR12.0-1263): Originally coded 0782 by Rick Fakoury for MR12. 2) change(87-01-13,Fakoury), approve(87-01-13,MCR7515), audit(87-01-14,Martinson), install(87-01-14,MR12.0-1278): PBF to correct -deckfile short name to -df from -dkf. 3) change(89-02-06,Fakoury), approve(90-10-03,MCR8147), audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049): to to allow tape copy without using a deck file or list seg. 4) change(89-06-01,Fakoury), approve(90-10-03,MCR8147), audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049): to to insert a space in the copy tape attach description for TR21325 to increase the size of att_desc from 64 to 181 for TR21336. 5) change(90-10-30,Fakoury), approve(90-11-28,MCR8219), audit(90-11-28,Schroth), install(90-11-28,MR12.4-1051): PBF correct to previous installation: changed to call dfm_util_$make_key after call to get_cata for catalog record. END HISTORY COMMENTS */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ dfm_: proc (); return; /* not a valid entry */ /* AUTOMATIC */ dcl N fixed bin; dcl X fixed bin; dcl al fixed bin (21); dcl all_diskettes bit (1); dcl alp ptr; dcl ap ptr; dcl c_att_desc char (181); dcl code fixed bin (35); dcl decks_tb_deleted (10) char (24) varying; dcl deck_tb_patched char (24) varying; dcl deckfile_path char (168); dcl diskettes_tb_read (hbound (valid_diskettes, 1)) char (8) varying; dcl diskette_type char (4); dcl dkf_dir (3) char (168); dcl dkf_entry (3) char (32); dcl dkf_path (3) char (168); dcl dkf_path_idx fixed bin; dcl dl_patch bit (1); dcl dwg_num_tab char (2); dcl eof bit (1); dcl err bit (1); dcl lsf_dir char (168); dcl lsf_entry char (32); dcl i fixed bin; dcl j fixed bin; dcl list_all_keys bit (1); dcl mca bit (1); dcl mca_err bit (72); dcl mca_id char (4); dcl ml fixed bin (21); dcl n_diskettes_tb_read fixed bin; dcl nargs fixed bin; dcl npatches fixed bin; dcl ndecks_tb_deleted fixed bin; dcl of_dir char (168); dcl of_entry char (32); dcl of_path char (168); dcl output_mode_specified bit (1); dcl patch_length fixed bin; dcl patch_ptr ptr; dcl patch_word char (84) varying; dcl pname char (72) varying; dcl prod_num_tab char (2); dcl query_info_ptr ptr; dcl query_message char (256); dcl rl fixed bin (21); dcl sci_ptr ptr; dcl tdec fixed bin (35); dcl term bit (1); dcl user_entry char (8) varying; dcl user_reply char (256) varying; dcl vfile_open_mode fixed bin; dcl xofn char (2); dcl yes_sw bit (1); /* BASED */ dcl add_pic pic "999999" based; dcl arg char (al) based (ap); dcl bin_arg fixed bin (35) based (ap); dcl bit_arg bit (al) based (ap); dcl 1 df_keys based (dfm_data.dfkp) aligned, /* template for deckfile catalog keys */ 2 n_entries fixed bin, /* number of catalog entries */ 2 key (1 refer (df_keys.n_entries)) char (24); /* entry search keys */ dcl free_area area based (get_system_free_area_ ()); dcl ptr_arg ptr based (ap); /* BUILTINS */ dcl addr builtin; dcl before builtin; dcl bin builtin; dcl char builtin; dcl clock builtin; dcl convert builtin; dcl index builtin; dcl hbound builtin; dcl lbound builtin; dcl length builtin; dcl ltrim builtin; dcl null builtin; dcl rtrim builtin; dcl search builtin; dcl string builtin; dcl substr builtin; dcl translate builtin; dcl unspec builtin; /* CONDITIONS */ dcl cleanup condition; /* CONSTANTS */ dcl deckfile char (16) int static options (constant) init (">tandd_deck_file"); dcl false bit (1) int static options (constant) init ("0"b); dcl minargs fixed bin int static options (constant) init (3); dcl nl_sw bit (1) aligned int static options (constant) init ("0"b); dcl pad_sw bit (1) aligned int static options (constant) init ("0"b); dcl print bit (1) int static options (constant) init ("0"b); dcl system_dir char (21) int static options (constant) init (">system_library_tandd"); dcl true bit (1) int static options (constant) init ("1"b); dcl wrapup bit (1) int static options (constant) init ("1"b); /* EXTERNAL ENTRIES */ dcl command_query_ entry () options (variable); dcl command_query_$yes_no entry () options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date_time_ entry (fixed bin (52), char (*)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl dfm_util_$ck_applic entry (ptr) returns (bit (1)); dcl dfm_util_$copy_eof entry (ptr); dcl dfm_util_$delete_deck entry (ptr, char (24) var, fixed bin (35)); dcl dfm_util_$detach_file entry (ptr, ptr); dcl dfm_util_$find_dkend entry (ptr, char (24) var, ptr, fixed bin, fixed bin (35)); dcl dfm_util_$find_file entry (ptr, char (*), char (*)); dcl dfm_util_$find_key entry (ptr, ptr, char (24) var, ptr, fixed bin (35)); dcl dfm_util_$get_cata entry (ptr, ptr, char (24) var, ptr, ptr, fixed bin (35)); dcl dfm_util_$insert_deck entry (ptr, ptr, ptr, fixed bin (21), char (24) varying); dcl dfm_util_$make_key entry (ptr); dcl dfm_util_$mca_attach entry (ptr, char (4)); dcl dfm_util_$mca_detach entry (ptr); dcl dfm_util_$merge_files entry (ptr, ptr, ptr); dcl dfm_util_$mount_diskette entry (ptr, char (8) var, ptr) returns (bit (1)); dcl dfm_util_$open_file entry (ptr, char (64), char (181), fixed bin (17), ptr); dcl dfm_util_$print_list entry (ptr, ptr, char (24) varying); dcl dfm_util_$read_deck entry (ptr, bit (1), bit (1)); dcl dfm_util_$read_diskette entry (ptr, char (*), ptr, fixed bin (21), bit (72), fixed bin (35)); dcl dfm_util_$update_list entry (ptr, fixed bin (2)); dcl dfm_util_$valid_diskette entry (ptr, char (8) varying) returns (bit (1)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl get_wdir_ entry returns (char (168)); dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned); dcl ioa_$rsnnl entry () options (variable); dcl mca_$read_data entry (fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35)); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$get_info_ptr entry (ptr) returns (ptr); dcl ssu_$get_temp_segment entry (ptr, char (*), ptr); dcl ssu_$get_subsystem_and_request_name entry (ptr) returns (char (72) var); dcl ssu_$print_message entry () options (variable); dcl ssu_$release_temp_segment entry (ptr, ptr); dcl sub_err_ entry () options (variable); /* EXTERNAL STATIC */ dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$segnamedup fixed bin (35) ext static; dcl error_table_$too_many_names fixed bin (35) ext static; dcl iox_$user_output ext ptr; /* PARAMETERS */ dcl P_dfm_infop ptr parameter; dcl P_sci_ptr ptr parameter; %page; /* clean_up - general clean up rountine */ clean_up: entry (P_sci_ptr, P_dfm_infop); call setup_part1; call wrap_up; return; %page; /* This procedure is a general purpose complainer. If ABORT is true, then ssu_$abort_line is called. ssu_$print_message is called otherwise. */ /* calling sequence: dfm_$complain (dfm_datap, abort, code, ioa_control_string, arg1...argn) */ complain: entry options (variable); dcl ecode fixed bin (35); dcl message char (256); dcl ABORT bit (1); message = ""; ml = 0; call cu_$arg_count (nargs, code); if nargs < minargs then call sub_err_ (code, "dfm_$complain", ACTION_CANT_RESTART, null, 0, ""); do i = 1 to minargs; call cu_$arg_ptr (i, ap, al, code); if code ^= 0 then call sub_err_ (code, "dfm_$complain", ACTION_CANT_RESTART, null, 0, "encountered while attempting to get ^[dfm_datap^;abort^;code^] arg.", i); else if i = 1 then dfm_datap = ptr_arg; else if i = 2 then ABORT = bit_arg; else if i = 3 then ecode = bin_arg; end; sci_ptr = dfm_data.sci_ptr; if nargs > minargs then do; call cu_$arg_list_ptr (alp); call ioa_$general_rs (alp, 4, 5, message, ml, pad_sw, nl_sw); end; if ABORT then do; dfm_infop = dfm_data.infop; call wrap_up; /* free the stuff I MAY have allocated */ call ssu_$abort_line (sci_ptr, ecode, "^a", substr (message, 1, ml)); /* BYE! */ end; else call ssu_$print_message (sci_ptr, ecode, "^a", substr (message, 1, ml)); return; %page; /* delete_deck - entry to delete a deck a deckfile */ delete_deck: entry (P_sci_ptr, P_dfm_infop); call setup_part1; call setup_part2; dd = true; ndecks_tb_deleted = 0; on cleanup call wrap_up; call ssu_$arg_count (sci_ptr, nargs); if nargs > 0 then do i = 1 to nargs; call ssu_$arg_ptr (sci_ptr, i, ap, al); if arg = "-deckfile" | arg = "-df" then do; /* user will specify path */ i = i + 1; call ssu_$arg_ptr (sci_ptr, i, ap, al); if al = 0 then call complain (dfm_datap, wrapup, error_table_$bad_arg, "obtaining ""-deckfile"" specification.", ""); else deckfile_path = arg; end; else if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true; /* user doesn't want unnecessary nessages */ else do; ndecks_tb_deleted = ndecks_tb_deleted + 1; if ndecks_tb_deleted > hbound (decks_tb_deleted, 1) then call complain (dfm_datap, wrapup, error_table_$too_many_names, "only ^d decks maybe deleted", hbound (decks_tb_deleted, 1)); decks_tb_deleted (ndecks_tb_deleted) = arg; end; end; if ndecks_tb_deleted = 0 then do; call complain (dfm_datap, print, error_table_$noarg, "No key given to specify the deck to be deleted.", ""); query_message = "Enter a key or partial key for the deck to be deleted."; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter: "); ndecks_tb_deleted = 1; decks_tb_deleted (ndecks_tb_deleted) = user_reply; end; if ndecks_tb_deleted > 0 then do; call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.dfkp); /* get temp seg for catalog keys */ call ssu_$get_temp_segment (sci_ptr, "catalog list", dfm_data.lcatp); /* get temp seg for list catalog */ dfm_data.liocb_ptr = iox_$user_output; dfm_data.terminal_out = true; dfm_data.deckfile_sw = true; /* deckfile is required */ call get_files; do i = 1 to ndecks_tb_deleted; call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, decks_tb_deleted (i), dfm_data.dfkp, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", decks_tb_deleted (i)); term = false; if df_keys.n_entries > 1 then do j = 1 to df_keys.n_entries while (^term); call command_query_$yes_no (yes_sw, 0, pname, "^d ^2s entries matched the key given", "key given matched ^d entries. ^/Entry ^d is ^a - Is this the deck to be deleted?", df_keys.n_entries, j, df_keys.key (j)); if yes_sw then do; term = true; j = j - 1; /* adjust to correct value */ end; end; else j = 1; if j <= df_keys.n_entries then do; decks_tb_deleted (i) = df_keys.key (j); call dfm_util_$delete_deck (dfm_datap, decks_tb_deleted (i), code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "attempting to delete deck ^a", decks_tb_deleted (i)); dfm_data.list_key = "ls." || rtrim (decks_tb_deleted (i)); call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key); end; end; end; call wrap_up; return; %page; /* list - entry to generate a list file or display on the user terminal all or portion of the list information in a deckfile */ list: entry (P_sci_ptr, P_dfm_infop); call setup_part1; call setup_part2; dfm_data.list = true; list_all_keys = false; output_mode_specified = false; on cleanup call wrap_up; call ssu_$arg_count (sci_ptr, nargs); if nargs > 0 then do i = 1 to nargs; call ssu_$arg_ptr (sci_ptr, i, ap, al); if arg = "-all" | arg = "-a" then list_all_keys = true; else if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true; /* user doesn't want unnecessary nessages */ else if arg = "-deckfile" | arg = "-df" then do; /* user will specify path */ i = i + 1; call ssu_$arg_ptr (sci_ptr, i, ap, al); if al = 0 then call complain (dfm_datap, wrapup, error_table_$bad_arg, "obtaining ""-deckfile"" specification.", ""); else deckfile_path = arg; end; else if arg = "-file_out" | arg = "-fo" then do; dfm_data.terminal_out = false; output_mode_specified = true; end; else if arg = "-term_out" | arg = "-to" then dfm_data.terminal_out, output_mode_specified = true; else if dfm_data.list_key = "" then dfm_data.list_key = arg; else call complain (dfm_datap, wrapup, error_table_$bad_arg, "More than one list key specified.", ""); end; if ^list_all_keys & dfm_data.list_key = "" then do; call complain (dfm_datap, print, error_table_$noarg, "Insufficient number of args supplied.", ""); query_message = "Enter a key for the file to be listed or all to create a complete deckfile.list."; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter: "); if user_reply = "-all" | user_reply = "-a" then list_all_keys = true; else dfm_data.list_key = user_reply; end; if ^output_mode_specified & dfm_data.list_key ^= "" then do; dfm_data.terminal_out = true; dfm_data.page_no = 0; end; dfm_data.deckfile_sw = true; /* deckfile is required */ call get_files; call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.lcatp); /* get temp seg for catalog keys */ lcata.n_entries = 0; /* initially set to 0 entries */ if dfm_data.terminal_out then dfm_data.liocb_ptr = iox_$user_output; if list_all_keys then do i = lbound (list_types, 1) to hbound (list_types, 1); dfm_data.list_key = list_types (i); call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key, dfm_data.lcatp, code); if code ^= 0 then dfm_data.list_key = ""; if dfm_data.list_key ^= "" then call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key); end; else if dfm_data.list_key ^= "" then do; if index (dfm_data.list_key, "ls.") ^= 1 then dfm_data.list_key = "ls." || dfm_data.list_key; call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key, dfm_data.lcatp, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", dfm_data.list_key); if lcata.n_entries > 1 then do j = 1 to lcata.n_entries while (^term); call command_query_$yes_no (yes_sw, 0, pname, "^d^2s entries matched the key given", "key given matched ^d entries.^/ Entry ^d is ^a - Is this the file to be listed?", lcata.n_entries, j, lcata.key (j)); if yes_sw then do; term = true; dfm_data.list_key = lcata.key (j); end; else dfm_data.list_key = ""; end; if dfm_data.list_key = "" then call complain (dfm_datap, wrapup, 0, "There are no files to be listed", ""); else call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key); end; call wrap_up; return; %page; /* list_diskettes - entry to list valid diskette types used in the load_from_diskette entry */ list_diskette_types: entry (P_sci_ptr, P_dfm_infop); dcl out_str char (hbound (valid_diskettes, 1) * 5) varying; call setup_part1; on cleanup call wrap_up; out_str = ""; do i = 1 to hbound (valid_diskettes, 1); out_str = out_str || substr (valid_diskettes (i), 1, 3) || " "; end; call complain (dfm_datap, print, 0, "^/^a^/", out_str); dfm_data.finished = true; dfm_info.flags.request_active = false; return; %page; /* load_from_diskette - entry to read MCA diskettes into a deckfile */ load_from_diskette: entry (P_sci_ptr, P_dfm_infop); call setup_part1; call setup_part2; dfm_data.lfd = true; dir_ptr = null; on cleanup begin; if dir_ptr ^= null then free directory in (free_area); call wrap_up; end; all_diskettes = false; mca = false; call ssu_$arg_count (sci_ptr, nargs); if nargs > 0 then do i = 1 to nargs; call ssu_$arg_ptr (sci_ptr, i, ap, al); if arg = "-mca" then do; i = i + 1; call ssu_$arg_ptr (sci_ptr, i, ap, al); if al ^= 1 then call complain (dfm_datap, wrapup, 0, "arg following -mca arg incorrect", ""); else if search (arg, "abcd") = 0 then call complain (dfm_datap, wrapup, 0, "arg following -mca arg incorrect", ""); else mca = true; mca_id = "mca" || arg; end; else if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true; /* user doesn't want unnecessary nessages */ else if arg = "-deckfile" | arg = "-df" then do; /* user will specify path */ i = i + 1; call ssu_$arg_ptr (sci_ptr, i, ap, al); if al = 0 then call complain (dfm_datap, wrapup, error_table_$bad_arg, "obtaining ""-deckfile"" specification.", ""); else deckfile_path = arg; end; else if arg = "-all" | arg = "-a" then all_diskettes = true; else if dfm_util_$valid_diskette (dfm_datap, (arg)) then do; n_diskettes_tb_read = n_diskettes_tb_read + 1; diskettes_tb_read (n_diskettes_tb_read) = arg; end; else call complain (dfm_datap, wrapup, 0, "Invalid arg ^a", arg); end; if n_diskettes_tb_read = 0 & ^all_diskettes then do; call complain (dfm_datap, print, error_table_$noarg, "A diskette to be read must be specified", ""); query_message = "Enter a diskette name, or -all for all diskettes"; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter: "); if user_reply = "-all" | user_reply = "-a" then all_diskettes = true; else do; user_entry = substr (user_reply, 1, 8); if dfm_util_$valid_diskette (dfm_datap, user_entry) then do; n_diskettes_tb_read = 1; diskettes_tb_read (n_diskettes_tb_read) = user_entry; end; else call complain (dfm_datap, wrapup, 0, "Invalid diskette name, use list_diskette_types (ldt) request to obtain valid types", ""); end; end; if ^mca then do; query_message = "Enter the mca (a-d) of the mca to be used"; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, " Enter MCA to be used "); if search (user_reply, "abcd") = 0 then call complain (dfm_datap, wrapup, 0, "invalid mca id entered", ""); else mca = true; mca_id = "mca" || rtrim (user_reply); end; if all_diskettes then do; n_diskettes_tb_read = hbound (valid_diskettes, 1); diskettes_tb_read = valid_diskettes; end; if n_diskettes_tb_read < 1 then call complain (dfm_datap, wrapup, 0, "no diskette type entered", ""); call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.lcatp); /* get temp seg for list catalog */ call ssu_$get_temp_segment (sci_ptr, "diskette catalog", dfm_data.dcatp); /* get temp seg for diskette catalog */ call ssu_$get_temp_segment (sci_ptr, "mca catalog", dfm_data.mcatp); /* get temp seg for mca catalog */ call ssu_$get_temp_segment (sci_ptr, "mca data read buffer", dfm_data.mca_wksp); /* get temp seg for reading mca data */ /* attach and open needed files */ dfm_data.deckfile_sw = true; /* deckfile is required */ call get_files; call dfm_util_$mca_attach (dfm_datap, mca_id); %page; /* main processing loop */ call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr, "cata.nio.mca", dfm_data.mcatp, dfm_data.mksp, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "can't get mca catalog", ""); do i = 1 to n_diskettes_tb_read; unspec (dcata) = "0"b; remount: if dfm_util_$mount_diskette (dfm_datap, translate (diskettes_tb_read (i), uc, lc), dfm_data.mca_wksp) then call dfm_util_$read_diskette (dfm_datap, "HDR", dfm_data.mca_wksp, rl, mca_err, code); else do; call complain (dfm_datap, print, code, pname, "Operator unable to mount diskette ^a", diskettes_tb_read (i)); query_message = "Problems encountered mounting the diskette. Enter: - (a)bort, (s)kip or (r)etry? "; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter: - (a)bort, (s)kip or (r)etry? "); if user_reply = "r" | user_reply = "retry" then goto remount; if user_reply = "s" | user_reply = "skip" then goto next_disk; else goto exit_lfd; end; header_ptr = dfm_data.mca_wksp; if mca_status.maj | mca_sub.data_p | code ^= 0 | substr (translate (header.unique_id, lc, uc), 1, 3) ^= substr (diskettes_tb_read (i), 1, 3) | substr (header.title, 1, 4) ^= "UTIL" then do; if substr (translate (header.unique_id, lc, uc), 1, 3) ^= substr (diskettes_tb_read (i), 1, 3) then do; call complain (dfm_datap, print, pname, "Diskette ^a mounted - instead of ^a? ", header.unique_id, diskettes_tb_read (i)); query_message = "Wrong diskette mounted. Enter: - (a)bort, (s)kip or (r)etry? "; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter: - (a)bort, (s)kip or (r)etry? "); if user_reply = "r" | user_reply = "retry" then goto remount; if user_reply = "s" | user_reply = "skip" then goto next_disk; else goto exit_lfd; end; next_disk: if i < n_diskettes_tb_read then do; call command_query_$yes_no (yes_sw, code, pname, "Unable to read the HEADER - want to continue", "Unable to read the ^a - read the next diskette?", "HEADER"); if yes_sw then goto next_diskette; else goto exit_lfd; end; else call complain (dfm_datap, wrapup, code, "reading ^a HEADER", (diskettes_tb_read (i))); end; call complain (dfm_datap, print, 0, "Mounted diskette ^a on drive ^d", header.unique_id, dfm_data.disk_num); N = bin (substr (header.x_of_n, 1, 9), 9); X = bin (substr (header.x_of_n, 10, 9), 9); unspec (xofn) = header.x_of_n; dir_number = 0; substr (unspec (dir_number), 21, 16) = header.dir_size.msb || header.dir_size.lsb; dir_number = dir_number / 16; dfm_data.edit_date = header.date_changed; diskette_type = header.equip_type; dwg_num_tab = substr (header.disk_dwg_num, 11); prod_num_tab = substr (header.unique_id, 7); dfm_data.current_disk_name = rtrim (header.unique_id); current_filename = rtrim ("HDR." || header.unique_id || prod_num_tab || "00"); if i = 1 then call add_name ("mca.diskettes.rev." || prod_num_tab); call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr, "cata.nio." || rtrim (header.unique_id), dfm_data.dcatp, dfm_data.dksp, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "can't get ^a catalog", header.unique_id); call file_deck (dfm_data.mca_wksp, rl); call dfm_util_$read_diskette (dfm_datap, "DIRECTORY", dfm_data.mca_wksp, rl, mca_err, code); if mca_status.maj | mca_sub.data_p | code ^= 0 then do; if i < n_diskettes_tb_read then do; call command_query_$yes_no (yes_sw, code, pname, "Unable to read DIRECTORY file. Want to continue?", "Unable to read ^a file. Read the next diskette?", "DIRECTORY"); if yes_sw then goto next_diskette; else goto exit_lfd; end; else call complain (dfm_datap, wrapup, code, "reading ^a DIRECTORY", diskettes_tb_read (i)); end; dir_ptr = dfm_data.mca_wksp; alloc directory in (free_area) set (dir_ptr); directory = dfm_data.mca_wksp -> directory; current_filename = rtrim (diskette_type || ".DIRECTRY" || prod_num_tab || "00"); call file_deck (dfm_data.mca_wksp, rl); do j = 1 to dir_number; dire_ptr = addr (directory.array (j)); if (dire.path_name = ".DPSFILE" & j < dir_number) | dire.deleted then goto next_file; call dfm_util_$read_diskette (dfm_datap, "P=" || dire.path_name, dfm_data.mca_wksp, rl, mca_err, code); if mca_status.maj | code ^= 0 then do; if j < dir_number then do; call command_query_$yes_no (yes_sw, code, pname, "Unable to read last file. Want to continue?", "Unable to read file ^a. Read the next file?", dire.path_name); if yes_sw then goto next_file; end; else do; free directory in (free_area); dir_ptr = null; call complain (dfm_datap, wrapup, code, "unable to read file ^a", dire.path_name); end; end; current_filename = rtrim (dire.path_name || prod_num_tab || dwg_num_tab); call file_deck (dfm_data.mca_wksp, rl); next_file: end; free directory in (free_area); dir_ptr = null; current_filename = rtrim ("cata." || dfm_data.current_disk_name); rl = dcata.n_entries * 24 + 4; call file_deck (dfm_data.dcatp, rl); next_diskette: dfm_data.hdr_sw = true; /* force a new header */ end; dfm_data.current_filename = rtrim ("cata.mca"); rl = mcata.n_entries * 24 + 4; call file_deck (dfm_data.mcatp, rl); call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lcatp, length (unspec (lcata)), "ls.cata." || dfm_data.ls_type || ".list"); call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, "ls.cata." || dfm_data.ls_type || ".list"); exit_lfd: call wrap_up; return; %page; /* load_from_tape - entry to read an ifad or fnp tape into a deckfile */ load_from_tape: entry (P_sci_ptr, P_dfm_infop); call setup_part1; call setup_part2; dfm_data.lft = true; on cleanup call wrap_up; call ssu_$arg_count (sci_ptr, nargs); if nargs > 0 then do j = 1 to nargs; call ssu_$arg_ptr (sci_ptr, j, ap, al); if index (arg, "-") ^= 1 then do; /* must be tape name */ dfm_data.t_att_desc = "tape_nstd_ " || arg; /* start attach description */ if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then dfm_data.t_att_desc = rtrim (dfm_data.t_att_desc) || " -density " || ltrim (char (tdec)); tape_name = before (arg, ","); /* If comma, use stuff before */ dfm_data.l_att_desc = "vfile_ " || tape_name; /* start listing attach description */ end; else if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true; /* user doesn't want unnecessary nessages */ else if arg = "-firmware" | arg = "-fw" then do; dfm_data.firmware_sw = true; /* user just wants firmware loaded */ dfm_data.attach_copy, dfm_data.deckfile_sw = false; end; else if arg = "-copy" | arg = "-cp" then do; /* user wantsd to make copy of ifad tape */ j = j + 1; call ssu_$arg_ptr (sci_ptr, j, ap, al); if al = 0 then call complain (dfm_datap, wrapup, code, "obtaining ""-copy"" tape reel specification.", ""); c_att_desc = "tape_nstd_ " || arg; /* generate initial copy attach description */ if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then c_att_desc = rtrim (c_att_desc) || " -density " || ltrim (char (tdec)); dfm_data.attach_copy = true; /* set flag */ dfm_data.firmware_sw = false; end; else if arg = "-deckfile" | arg = "-df" then do; /* user will specify path */ j = j + 1; call ssu_$arg_ptr (sci_ptr, j, ap, al); if al = 0 then call complain (dfm_datap, wrapup, error_table_$bad_arg, "obtaining ""-deckfile"" specification.", ""); else deckfile_path = arg; dfm_data.deckfile_sw = true; end; else if arg = "-density" | arg = "-den" then do; /* next arg must be density value */ j = j + 1; call ssu_$arg_ptr (sci_ptr, j, ap, al); if al = 0 then call complain (dfm_datap, wrapup, code, "obtaining ""-density"" specification.", ""); tdec = cv_dec_check_ (arg, code); if code ^= 0 then go to bad_arg; if tdec = 6250 | tdec = 1600 | tdec = 800 | tdec = 556 | tdec = 200 then do; if dfm_data.attach_copy then do; /* if setting density on copy tape */ c_att_desc = rtrim (c_att_desc) || " -density " || ltrim (char (tdec)); cd_sw = true; /* set indicator */ end; if dfm_data.tape_name ^= "" then dfm_data.t_att_desc = rtrim (dfm_data.t_att_desc) || " -density " || ltrim (char (tdec)); end; else go to bad_arg; /* make him get it right */ end; else if arg = "-patches" then dfm_data.allow_0_cksum = true; /* user wants to allow firmware decks with a 0 checksum */ else if arg = "-track" | arg = "-tk" then do; /* next arg must be 7 or 9 */ j = j + 1; call ssu_$arg_ptr (sci_ptr, j, ap, al); /* get track arg */ if al = 0 then /* error */ call complain (dfm_datap, wrapup, code, "obtaining ""-track"" specification.", ""); tdec = cv_dec_check_ (arg, code); /* convert to dec. for check */ if code ^= 0 then go to bad_arg; /* must be numeric */ if tdec ^= 7 & tdec ^= 9 then go to bad_arg; /* and only 7 or 9 */ if dfm_data.attach_copy then /* if track specification of copy tape */ c_att_desc = rtrim (c_att_desc) || " -track " || arg; /* insert leading blank */ else dfm_data.t_att_desc = rtrim (dfm_data.t_att_desc) || " -track " || arg; end; else do; bad_arg: call complain (dfm_datap, wrapup, error_table_$bad_arg, "^a", arg); end; end; if ^dfm_data.attach_copy /* if ^copy */ & ^dfm_data.deckfile_sw /* & ^deckfile */ & ^dfm_data.firmware_sw /* & ^firmware only */ then dfm_data.deckfile_sw = true; /* default is to use the deckfile */ if ^dfm_data.firmware_sw & dfm_data.deckfile_sw /* if ^firmware & deckfile */ then dfm_data.firmware_sw = true; /* default is to create firmware segs */ if dfm_data.tape_name = "" then do; call complain (dfm_datap, print, error_table_$noarg, "A tape name must be supplied", ""); query_message = "Enter the name of the tape, ifad or 6670bdt, to be mounted."; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter : "); dfm_data.t_att_desc = "tape_nstd_ " || user_reply; /* start attach description */ tape_name = before (user_reply, ","); /* If comma, use stuff before */ dfm_data.l_att_desc = "vfile_ " || dfm_data.tape_name; /* start listing attach description */ end; if dfm_data.tape_name = "" then call complain (dfm_datap, wrapup, code, "^/Usage:^-load_from_tape reel_id {-control_args}", ""); call ssu_$get_temp_segment (sci_ptr, "tape buffer", dfm_data.bptr); /* get temp segs for tape buffer */ call ssu_$get_temp_segment (sci_ptr, "catalog buffer", dfm_data.catp); /* get temp segs for catalog buffer */ call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.lcatp); /* get temp seg for catalog keys */ call get_files; /* attach and open needed files */ call add_name (dfm_data.tape_name); do while (^dfm_data.eot); /* read tape until 2 eofs */ call dfm_util_$read_deck (dfm_datap, eof, err); /* read in next object deck */ if err | (eof & one_eof) | dfm_data.eot then do; /* if error condition or 2 eofs */ dfm_data.eot = true; /* thats all there is to do */ if dfm_data.attach_copy then call dfm_util_$copy_eof (dfm_datap); /* if we are copying tape,write out 2nd eof */ if dfm_data.fnp_tape & ^err & ^dfm_data.list then do; /* write out fnp catalog record */ dfm_data.current_key = "cata." || rtrim (dfm_data.cat_key); /* form completed key */ call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.catp, length (unspec (cata)), dfm_data.current_key); /* and write catalog to deck file */ call dfm_util_$update_list (dfm_datap, cata_list_type); /* add catalog record to listing file */ end; end; else if eof then do; /* if eof */ one_eof = true; /* set flag */ if dfm_data.attach_copy then /* if we are copying tape */ if ^dfm_data.copy_at_eof then /* and copy tape is not already at end of file */ call dfm_util_$copy_eof (dfm_datap); /* go write eof on copy tape */ if dfm_data.cat_build & ^dfm_data.fnp_tape then do; /* if we were building catalog */ dfm_data.cat_build, dfm_data.first_deck = false; /* reset flags */ if index (dfm_data.cat_key, "itr.") ^= 0 then do; /* if building itr catalog */ if id_blk.type = "itr" | id_blk.type = "mdr" then do; /* last entry must be firmware */ call complain (dfm_datap, print, 0, "Last object deck on itr file is not firmware", ""); call complain (dfm_datap, wrapup, 0, "Last object card image is:^/""^a""", dfm_data.obj_card); end; else do; /* no errors form catalog name */ do i = cata.n_entries to 1 by -1 while (index (cata.key (i), ".") > 4); end; /* find first firmware deck */ cata.n_entries = cata.n_entries + 1; dfm_data.cat_key = rtrim (dfm_data.cat_key) || substr (cata.key (i + 1), 8, 6) || "." || substr (cata.key (i + 1), 20, 2); end; end; dfm_data.current_key = "cata." || rtrim (dfm_data.cat_key); /* set current key */ call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.catp, length (unspec (cata)), dfm_data.current_key); /* and write catalog to deck file */ call dfm_util_$update_list (dfm_datap, cata_list_type); /* add catalog record to listing file */ end; end; else do; one_eof = false; /* reset eof flag if set */ if dfm_data.list then /* if just producing listing, take all decks */ call dfm_util_$update_list (dfm_datap, data_list_type); /* go add entry to listing file */ else if dfm_data.fnp_tape /* no applicability check for fnp decks */ | (dfm_util_$ck_applic (dfm_datap) /* check for Multics applicibilty */ & dfm_data.deckfile_sw) then call file_deck (dfm_data.bptr, dfm_data.dlen * 4); /* just loading firmware, don't insert deck into deckfile */ end; end; call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lcatp, length (unspec (lcata)), "ls.cata." || dfm_data.ls_type || ".list"); call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, "ls.cata." || dfm_data.ls_type || ".list"); call wrap_up; return; %page; /* merge_deckfiles - entry to merge two or more tandd_deck_files */ merge_deckfiles: entry (P_sci_ptr, P_dfm_infop); call setup_part1; call setup_part2; dfm_data.mdf = true; call ssu_$arg_count (sci_ptr, nargs); dkf_path_idx = 1; /* point to first path */ do i = 1 to nargs; call ssu_$arg_ptr (sci_ptr, i, ap, al); if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true; /* user doesn't want unnecessary nessages */ else if arg = "-output_file" | arg = "-of" then do; i = i + 1; call ssu_$arg_ptr (sci_ptr, i, ap, al); if al = 0 then call complain (dfm_datap, wrapup, code, "obtaining ""-output_file"" specification.", ""); else of_path = arg; end; else if dkf_path_idx > hbound (dkf_path, 1) then call complain (dfm_datap, wrapup, error_table_$bad_arg, "More than ^d deck files to be merged", hbound (dkf_path, 1)); else do; dkf_path (dkf_path_idx) = arg; dkf_path_idx = dkf_path_idx + 1; end; end; if dkf_path (1) = "" then do; call complain (dfm_datap, print, error_table_$noarg, "At least one input deckfile path is required", ""); query_message = "Input deckfile path may be either a path or -working_dir or -system"; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter : "); dkf_path (1) = user_reply; end; if of_path = "" & dfm_info.deckfile_dir = "" then do; call complain (dfm_datap, print, error_table_$noarg, "An output deckfile path is required", ""); query_message = "Output deckfile path may be either a path or -working_dir or -system"; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter : "); of_path = user_reply; end; if dkf_path (1) = "" | of_path = "" then call complain (dfm_datap, wrapup, error_table_$noarg, "Both an input and output deckfile path are required", ""); do i = lbound (dkf_path, 1) to hbound (dkf_path, 1); if dkf_path (i) = "-working_dir" | dkf_path (i) = "-wd" then dkf_path (i) = rtrim (dir) || deckfile; else if dkf_path (i) = "-system" | dkf_path (i) = "-sys" then dkf_path (i) = system_dir || deckfile; if of_path = "-working_dir" | of_path = "-wd" then of_path = rtrim (dir) || ">" || deckfile; else if of_path = "-system" | of_path = "-sys" then of_path = system_dir || ">" || deckfile; if of_path = dkf_path (i) then dkf_path (i) = ""; end; call get_files; call ssu_$get_temp_segment (sci_ptr, "temp data buffer", dfm_data.bptr); /* get temp segs for data buffer */ call ssu_$get_temp_segment (sci_ptr, "list catalog", dfm_data.lcatp); /* get temp segs for list catalog */ do i = lbound (dfm_data.dkf_iocbp, 1) to hbound (dfm_data.dkf_iocbp, 1); if dfm_data.dkf_iocbp (i) ^= null & dfm_data.of_iocbp ^= null then call dfm_util_$merge_files (dfm_datap, dfm_data.dkf_iocbp (i), dfm_data.of_iocbp); end; do i = lbound (list_types, 1) to hbound (list_types, 1); dfm_data.list_key = list_types (i); call dfm_util_$find_key (dfm_datap, dfm_data.of_iocbp, dfm_data.list_key, dfm_data.lcatp, code); if code ^= 0 then dfm_data.list_key = ""; if dfm_data.list_key ^= "" then call dfm_util_$print_list (dfm_datap, dfm_data.of_iocbp, dfm_data.list_key); end; call wrap_up; return; %page; /* patch_deck - entry to add/delete a hex or octal patch card(s) into a deck in a deckfile and if it is a firmware deck create a firmware segment */ patch_deck: entry (P_sci_ptr, P_dfm_infop); call setup_part1; call setup_part2; dfm_data.pd = true; dl_patch = false; on cleanup call wrap_up; call ssu_$arg_count (sci_ptr, nargs); if nargs > 0 then do i = 1 to nargs; call ssu_$arg_ptr (sci_ptr, i, ap, al); if arg = "-brief" | arg = "-bf" then dfm_data.bf_sw = true; /* user doesn't want unnecessary nessages */ else if arg = "-deckfile" | arg = "-df" then do; i = i + 1; call ssu_$arg_ptr (sci_ptr, i, ap, al); if al = 0 then call complain (dfm_datap, wrapup, code, "obtaining ""-deckfile"" specification.", ""); else deckfile_path = arg; end; else if arg = "-delete" | arg = "-dl" then dl_patch = true; else if deck_tb_patched = "" then deck_tb_patched = arg; else call complain (dfm_datap, wrapup, error_table_$bad_arg, "only one deck may be patched"); end; if deck_tb_patched = "" then do; call complain (dfm_datap, print, error_table_$noarg, "A search key for deck to be patched is required", ""); query_message = "Enter a key or partial key to specify the deck to be patched."; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter : "); deck_tb_patched = user_reply; end; call ssu_$get_temp_segment (sci_ptr, "temp buffer", dfm_data.bptr); /* get temp seg for temp buffer */ call ssu_$get_temp_segment (sci_ptr, "catalog keys", dfm_data.dfkp); /* get temp seg for deckfile keys */ call ssu_$get_temp_segment (sci_ptr, "list catalog", dfm_data.lcatp); /* get temp segs for list catalog */ df_keys.n_entries = 0; /* initialy set to 0 entries */ lcata.n_entries = 0; dfm_data.deckfile_sw = true; /* deckfile is required */ call get_files; call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr, "ls.cata.ifad.list", dfm_data.lcatp, dfm_data.lksp, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "can't get list catalog", ""); call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, deck_tb_patched, dfm_data.dfkp, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", deck_tb_patched); term = false; if df_keys.n_entries > 1 then do j = 1 to df_keys.n_entries while (^term); call command_query_$yes_no (yes_sw, 0, pname, "^d^2s entries matched the key given", "key given matched ^d entries.^/ Entry ^d is ^a - Is this the deck to be patched?", df_keys.n_entries, j, df_keys.key (j)); if yes_sw then do; term = true; j = j - 1; /* adjust to correct value */ end; end; else j = 1; if j > df_keys.n_entries & ^term then call complain (dfm_datap, wrapup, 0, "There is no file to be patched", ""); deck_tb_patched = df_keys.key (j); term = false; if ^dl_patch then do i = lbound (dfm_data.opatches, 1) to hbound (dfm_data.opatches, 1) while (^term); query_message = "Patch type may either be delete, chex, rhex or octal."; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter patch type: "); if user_reply = "delete" | user_reply = "dl" then dl_patch, term = true; else if user_reply = "octal" | user_reply = "mask" then do; ascii_cardp = addr (dfm_data.opatches (i)); o_patch = " "; o_patch.type = user_reply; query_message = "Enter the octal address of this patch."; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter beginning address: "); o_patch.add = user_reply; query_message = "Enter the patches. Consecutive locations maybe separated by a (,) up to 10 patches"; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter patch data: "); o_patch.p_fld = user_reply; call ioa_$rsnnl ("^6a ^5a^[60a^;^3x^57a^]^12x", patch_word, patch_length, convert (add_pic, o_patch.add), o_patch.type, (o_patch.type = "mask"), o_patch.p_fld); call command_query_$yes_no (yes_sw, 0, pname, "Is this patch correct", "Patch entered: ^/^a^/Is this correct? ", patch_word); if yes_sw then string (opatches (i)) = patch_word; else i = i - 1; call command_query_$yes_no (yes_sw, 0, pname, "MORE PATCHES?", "Are there anymore patches?"); if ^yes_sw then term = true; patch_ptr = addr (dfm_data.opatches); npatches = i; end; else if user_reply = "chex" | user_reply = "rhex" then do; ascii_cardp = addr (dfm_data.hpatches (i)); h_patch = " "; h_patch.type = user_reply; query_message = "Enter the hex address of this patch."; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter address: "); h_patch.add = "0000"; substr (h_patch.add, 5 - length (user_reply)) = user_reply; query_message = "Enter the hex patch for this location."; query_info.explanation_len = length (rtrim (query_message)); query_info.explanation_ptr = addr (query_message); call command_query_ (query_info_ptr, user_reply, pname, "Enter patch data: "); h_patch.inst = "0000"; substr (h_patch.inst, 5 - length (user_reply)) = user_reply; call ioa_$rsnnl ("^4a ^4a^5x^4a^61x", patch_word, patch_length, h_patch.add, h_patch.type, h_patch.inst); call command_query_$yes_no (yes_sw, 0, pname, "Is this patch correct", "Patch entered ^/^a^/Is this correct? ", patch_word); if yes_sw then string (dfm_data.hpatches (i)) = patch_word; else i = i - 1; call command_query_$yes_no (yes_sw, 0, pname, "MORE PATCHES?", "Are there anymore patches?"); if ^yes_sw then term = true; patch_ptr = addr (dfm_data.hpatches); npatches = i; end; end; if dl_patch then npatches = 0; call dfm_util_$find_dkend (dfm_datap, deck_tb_patched, patch_ptr, npatches, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "attempting to patch file ^a", deck_tb_patched); call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lcatp, length (unspec (lcata)), "ls.cata.ifad.list"); call dfm_util_$detach_file (dfm_datap, dfm_data.liocb_ptr); dfm_data.liocb_ptr = iox_$user_output; dfm_data.terminal_out = true; dfm_data.list_key = "ls." || rtrim (deck_tb_patched); call dfm_util_$find_key (dfm_datap, dfm_data.fiocb_ptr, dfm_data.list_key, dfm_data.lcatp, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", dfm_data.list_key); call dfm_util_$print_list (dfm_datap, dfm_data.fiocb_ptr, rtrim (lcata.key (1))); call wrap_up; return; %page; /* pi_handler - entry called by ssu_'s pi handler */ pi_handler: entry (P_sci_ptr); sci_ptr = P_sci_ptr; dfm_infop = ssu_$get_info_ptr (sci_ptr); dfm_datap = dfm_info.dfm_data_ptr; call wrap_up; return; %page; /* quit - entry to quit the request loop and exit the ssu envirnoment */ quit: entry (P_sci_ptr, P_dfm_infop); call setup_part1; call wrap_up; call ssu_$abort_subsystem (sci_ptr); return; %page; /* add name - int proc to add a name onto the current deckfile of list file */ add_name: proc (aname); dcl aname char (*); if dfm_data.deckfile_sw then do; call hcs_$chname_file (dkf_dir (1), dkf_entry (1), "", rtrim (aname) || ".deckfile", code); if code ^= 0 & code ^= error_table_$segnamedup then call complain (dfm_datap, wrapup, code, "adding name ^a^/^-to ^a>^a", rtrim (aname) || ".deckfile", dfm_data.dir, dfm_data.entry); if ^dfm_data.bf_sw & code = 0 then call complain (dfm_datap, print, 0, "added name ^a^/^-to ^a>^a", rtrim (aname) || ".deckfile", dfm_data.dir, dfm_data.entry); call hcs_$chname_file (lsf_dir, lsf_entry, "", rtrim (aname) || ".list", code); if code ^= 0 & code ^= error_table_$segnamedup then call complain (dfm_datap, wrapup, code, "adding name ^a^/^-to ^a>^a", rtrim (aname) || ".list", lsf_dir, lsf_entry); if ^dfm_data.bf_sw & code = 0 then call complain (dfm_datap, print, 0, "added name ^a^/^-to ^a>^a", rtrim (aname) || ".list", lsf_dir, lsf_entry); end; end add_name; %page; /* file_deck - internal proc to file a deck into a deckfile */ file_deck: proc (fptr, dlen); dcl dlen fixed bin (21); dcl fptr ptr; if dfm_data.lft & cata.n_entries = 0 then do; call dfm_util_$get_cata (dfm_datap, dfm_data.fiocb_ptr, "cata." || rtrim (dfm_data.cat_key), dfm_data.catp, dfm_data.cksp, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "Attempting to do a get catalog for cata.^a", rtrim (dfm_data.cat_key)); end; call dfm_util_$make_key (dfm_datap); /* produce insertion key */ call dfm_util_$insert_deck (dfm_datap, dfm_data.fiocb_ptr, fptr, dlen, dfm_data.current_key); /* copy current deck into deckfile */ call dfm_util_$update_list (dfm_datap, data_list_type); /* add current deck entry to listing file */ end file_deck; %page; /* get_files internal proc to attach & open files depending on the operation performed. */ get_files: proc (); /* attach and open tandd_deck_file */ if dfm_data.deckfile_sw then do; if deckfile_path ^= "" then do; if deckfile_path = "-working_dir" | deckfile_path = "-wd" then deckfile_path = rtrim (dir) || deckfile; else if deckfile_path = "-system" | deckfile_path = "-sys" then deckfile_path = system_dir || deckfile; call expand_pathname_ (deckfile_path, dkf_dir (1), dkf_entry (1), code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "encountered while expanding path ^a", deckfile_path); end; else if dfm_info.deckfile_dir ^= "" then do; dkf_dir (1) = dfm_info.deckfile_dir; dkf_entry (1) = dfm_info.deckfile_entry; end; else do; dkf_dir (1) = dfm_data.dir; dkf_entry (1) = "tandd_deck_file"; end; call dfm_util_$find_file (dfm_datap, dkf_dir (1), dkf_entry (1)); dfm_data.dir = dkf_dir (1); dfm_data.entry = dkf_entry (1); if dfm_data.list then vfile_open_mode = Keyed_sequential_input; else vfile_open_mode = Keyed_sequential_update; call dfm_util_$open_file (dfm_datap, "dk_file_sw", "vfile_ " || rtrim (dkf_dir (1)) || ">" || rtrim (dkf_entry (1)), vfile_open_mode, dfm_data.fiocb_ptr); end; /* attach and open tandd_deck_files for merging */ else if dfm_data.mdf then do; do i = lbound (dkf_path, 1) to hbound (dkf_path, 1) while (dkf_path (i) ^= ""); call expand_pathname_ ((dkf_path (i)), dkf_dir (i), dkf_entry (i), code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "encountered while expanding path ^a", dkf_path (i)); if dkf_path (i) ^= "" then do; call dfm_util_$open_file (dfm_datap, "dkf_sw" || ltrim (char (i)), "vfile_ " || rtrim (dkf_dir (i)) || ">" || rtrim (dkf_entry (i)), Keyed_sequential_input, dfm_data.dkf_iocbp (i)); end; end; if of_path ^= "" then do; call expand_pathname_ (of_path, of_dir, of_entry, code); if code ^= 0 then call complain (dfm_datap, wrapup, code, "encountered while expanding path ^a", of_path); end; else if dfm_info.deckfile_dir ^= "" then do; of_dir = dfm_info.deckfile_dir; of_entry = dfm_info.deckfile_entry; end; else do; of_dir = dfm_data.dir; of_entry = "tandd_deck_file"; end; call dfm_util_$find_file (dfm_datap, of_dir, of_entry); dfm_data.dir = of_dir; dfm_data.entry = of_entry; call dfm_util_$open_file (dfm_datap, "of_sw", "vfile_ " || rtrim (of_dir) || ">" || of_entry, Keyed_sequential_update, dfm_data.of_iocbp); end; /* attach and open copy tape using the "tape_nstd_" io module */ if dfm_data.attach_copy then do; /* only attach copy if indicated */ call dfm_util_$open_file (dfm_datap, "copy_sw", rtrim (c_att_desc) || " -write", Sequential_output, dfm_data.ciocb_ptr); end; /* attach and open listing file */ if (dfm_data.deckfile_sw | dfm_data.mdf) & ^dfm_data.terminal_out then do; if of_dir ^= "" then lsf_dir = of_dir; else if dkf_dir (1) ^= "" then lsf_dir = dkf_dir (1); else if dfm_info.deckfile_dir ^= "" then lsf_dir = dfm_info.deckfile_dir; else lsf_dir = dfm_data.dir; lsf_entry = "deckfile.list"; call dfm_util_$find_file (dfm_datap, lsf_dir, lsf_entry); if ^dfm_data.mdf & ^dfm_data.list then call dfm_util_$open_file (dfm_datap, "list_sw", rtrim ("vfile_ " || rtrim (lsf_dir) || ">" || rtrim (lsf_entry) || " -extend"), Stream_input_output, dfm_data.liocb_ptr); else if dfm_data.mdf | dfm_data.list then call dfm_util_$open_file (dfm_datap, "list_sw", rtrim ("vfile_ " || rtrim (lsf_dir) || ">" || rtrim (lsf_entry)), Stream_output, dfm_data.liocb_ptr); end; /* attach and open tape using the "tape_nstd_" io module */ if dfm_data.lft then call dfm_util_$open_file (dfm_datap, "tape_sw", dfm_data.t_att_desc, Sequential_input, dfm_data.tiocb_ptr); end get_files; %page; /* setup_part1 - internal proc to set variables required by all entries */ setup_part1: proc; sci_ptr = P_sci_ptr; dfm_infop = P_dfm_infop; dfm_datap = dfm_info.dfm_data_ptr; dfm_data.infop = dfm_infop; dfm_data.sci_ptr = sci_ptr; pname = ssu_$get_subsystem_and_request_name (sci_ptr); end; %page; /* setup_part2 - internal proc to initialize variables required by some entries */ setup_part2: proc; dfm_info.flags.request_active = true; call date_time_ (clock (), dfm_data.time_string); /* Convert date and time. */ dfm_data.gtime_string = date_time_$format ("^yc^my^dm", clock (), "system_zone", "system_lang"); dfm_data.dir = get_wdir_ (); /* Get working directory. */ dfm_data.bptr = null; dfm_data.catp = null; dfm_data.ciocb_ptr = null; dfm_data.dcatp = null; dfm_data.dfkp = null; do i = lbound (dfm_data.dkf_iocbp, 1) to hbound (dfm_data.dkf_iocbp, 1); dfm_data.dkf_iocbp (i) = null; end; dfm_data.fiocb_ptr = null; dfm_data.hbuff_p = null; dfm_data.lbuff_p = null; dfm_data.lcatp = null; dfm_data.liocb_ptr = null; dfm_data.mca_wksp = null; dfm_data.mcatp = null; dfm_data.of_iocbp = null; dfm_data.tiocb_ptr = null; dfm_data.dd = false; dfm_data.allow_0_cksum = false; dfm_data.attach_copy = false; dfm_data.cat_build = false; dfm_data.cd_sw = false; dfm_data.copy_at_eof = false; dfm_data.deckfile_sw = false; dfm_data.finished = false; dfm_data.eot = false; dfm_data.first_deck = false; dfm_data.first_write = false; dfm_data.firmware_sw = false; dfm_data.fnp_tape = false; dfm_data.hdr_sw = true; dfm_data.lfd = false; dfm_data.lft = false; dfm_data.list = false; dfm_data.one_eof = false; dfm_data.mdf = false; term = false; dfm_data.terminal_out = false; deck_tb_patched = ""; deckfile_path = ""; dfm_data.current_key = ""; dfm_data.cat_key = ""; dfm_data.list_key = ""; dfm_data.tape_name = ""; dfm_data.crec = 0; dfm_data.denno = 0; dfm_data.fnp_key = 0; n_diskettes_tb_read = 0; dfm_data.cfile = 1; /* set first file number */ dfm_data.pfile = 1; /* set first file number */ dfm_data.page_no = dfm_info.page_number; /* and the page number */ dkf_dir = ""; dkf_entry = ""; dkf_dir = ""; dkf_entry = ""; dkf_path = ""; of_dir = ""; of_entry = ""; of_path = ""; query_info_ptr = addr (query_info); query_info.yes_or_no_sw = false; query_info.version = query_info_version_6; query_info.suppress_name_sw = false; query_info.suppress_spacing = false; query_info.cp_escape_control = "11"b; query_info.literal_sw = false; query_info.prompt_after_explanation = true; query_info.padding = false; query_info.status_code = 0; query_info.question_iocbp, query_info.answer_iocbp = null (); query_info.repeat_time = 0; end; %page; /* wrap_up - int proc to perform request clean up */ wrap_up: proc (); if ^dfm_info.flags.request_active then return; dfm_info.page_number = dfm_data.page_no; /* save page number if needed later */ if dfm_data.liocb_ptr ^= null & ^dfm_data.terminal_out then call dfm_util_$detach_file (dfm_datap, dfm_data.liocb_ptr); dfm_data.liocb_ptr = null; if dfm_data.ciocb_ptr ^= null then call dfm_util_$detach_file (dfm_datap, dfm_data.ciocb_ptr); dfm_data.ciocb_ptr = null; do i = lbound (dfm_data.dkf_iocbp, 1) to hbound (dfm_data.dkf_iocbp, 1); if dfm_data.dkf_iocbp (i) ^= null then call dfm_util_$detach_file (dfm_datap, dfm_data.dkf_iocbp (i)); dfm_data.dkf_iocbp (i) = null; end; if dfm_data.fiocb_ptr ^= null then call dfm_util_$detach_file (dfm_datap, dfm_data.fiocb_ptr); dfm_data.fiocb_ptr = null; if dfm_data.of_iocbp ^= null then call dfm_util_$detach_file (dfm_datap, dfm_data.of_iocbp); dfm_data.of_iocbp = null; if dfm_data.tiocb_ptr ^= null then call dfm_util_$detach_file (dfm_datap, dfm_data.tiocb_ptr); dfm_data.tiocb_ptr = null; if dfm_data.lbuff_p ^= null then free dfm_data.lbuff_p -> lbuff in (free_area); dfm_data.lbuff_p = null; if dfm_data.hbuff_p ^= null then free dfm_data.hbuff_p -> hbuff in (free_area); dfm_data.hbuff_p = null; if dfm_data.m_attached then do; if ^mca_status.maj & mca_sub.data_p then call mca_$read_data (dfm_data.mca_ioi_idx, dfm_data.mca_wksp, max_words_to_rd, rl, "0"b, 0); call dfm_util_$mca_detach (dfm_datap); end; if dfm_data.bptr ^= null then call ssu_$release_temp_segment (sci_ptr, dfm_data.bptr); dfm_data.bptr = null; if dfm_data.catp ^= null then call ssu_$release_temp_segment (sci_ptr, dfm_data.catp); dfm_data.catp = null; if dfm_data.dcatp ^= null then call ssu_$release_temp_segment (sci_ptr, dfm_data.dcatp); dfm_data.dcatp = null; if dfm_data.dfkp ^= null then call ssu_$release_temp_segment (sci_ptr, dfm_data.dfkp); dfm_data.dfkp = null; if dfm_data.mca_wksp ^= null then call ssu_$release_temp_segment (sci_ptr, dfm_data.mca_wksp); dfm_data.mca_wksp = null; if dfm_data.lcatp ^= null then call ssu_$release_temp_segment (sci_ptr, dfm_data.lcatp); dfm_data.lcatp = null; if dfm_data.mcatp ^= null then call ssu_$release_temp_segment (sci_ptr, dfm_data.mcatp); dfm_data.mcatp = null; dfm_data.finished = true; dfm_info.flags.request_active = false; end; %page; %include dfm_info; %page; %include dfm_data; %page; %include iox_modes; %page; %include mca_diskette; %page; %include query_info; %page; %include sub_err_flags; end dfm_;  dfm_util_.pl1 10/21/92 1023.4rew 10/21/92 1020.2 674802 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Bull Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-21,Fakoury), approve(86-08-21,MCR7515), audit(87-01-07,Farley), install(87-01-08,MR12.0-1263): Originally coded 0682 by Rick Fakoury for MR12. 2) change(87-01-13,Fakoury), approve(87-01-13,MCR7515), audit(87-01-14,Martinson), install(87-01-14,MR12.0-1278): PBF to correct a missing blank else statement in ck_applic. 3) change(87-01-22,Fakoury), approve(87-01-22,MCR7515), audit(87-01-22,Martinson), install(87-01-23,MR12.0-1291): Fixed a problem encountered merging a deckfile that contained a patch. 4) change(88-05-30,Fakoury), approve(90-10-03,MCR8147), audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049): to Fixed a bug in the merging of a deleted file. 5) change(89-02-06,Fakoury), approve(90-10-03,MCR8147), audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049): to to increase block count size and to allow a tape copy to be run without using a deck_file or list segment. 6) change(89-06-01,Fakoury), approve(90-10-03,MCR8147), audit(90-10-03,Parisek), install(90-10-25,MR12.4-1049): to to increase the size of att_desc from 64 to 181 for TR21336. 7) change(90-10-30,Fakoury), approve(90-11-28,MCR8219), audit(90-11-28,Schroth), install(90-11-28,MR12.4-1051): PBF correction to previous installation: correct and cleanup logic in ck_applic internal proc. END HISTORY COMMENTS */ /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */ dfm_util_: proc (); return; /* not a valid entry */ /* AUTOMATIC */ dcl at_bot bit (1); dcl att_desc char (181); dcl bcard bit (540); /* binary card */ dcl bcnt fixed bin (18); /* block count */ dcl bcwp ptr; /* block cont word p */ dcl bit_count fixed bin (24); dcl c_rtrycnt fixed bin; /* copy retry count */ dcl cbcwp ptr; /* current block cont word ptr */ dcl cden char (5); /* copy density */ dcl code fixed bin (35); dcl cx fixed bin; /* catalog index */ dcl cvp ptr; /* convert ptr */ dcl cvp1 ptr; /* cpnvert ptr hold */ dcl dk_end bit (1); dcl dk_type char (6); dcl dkend_card char (80); dcl ename char (32); /* entry name */ dcl file_found bit (1); dcl first_patch bit (1); dcl first_rcd bit (1); /* first record */ dcl glrp ptr; /* gcos log rec ptr */ dcl glrbp ptr; /* gcos logical record block ptr */ dcl gki (20) bit (36); dcl gprp ptr; /* gcos physical record ptr */ dcl header_key char (24) varying; dcl hbuff_len fixed bin (21); /* header buffer length */ dcl i fixed bin; dcl id_ld bit (1); dcl ident_buf (40) bit (36) aligned; /* load buffer */ dcl info (20) bit (36); dcl info_ptr ptr; dcl iocbp ptr; dcl j fixed bin; dcl k fixed bin; dcl lbuff_len fixed bin (21); /* line buffer length */ dcl line_count fixed bin; dcl lx fixed bin; /* load index */ dcl m fixed bin; dcl merge_key char (24) varying; dcl mode fixed bin; dcl mvp ptr; /* move ptr */ dcl nbcwp ptr; /* new blk cont wrd ptr */ dcl new_iocbp ptr; dcl npatches fixed bin; /* num of patches */ dcl nwds fixed bin; /* num of words */ dcl obj_card_found bit (1); dcl ocardp ptr; /* octal card ptr */ dcl old_iocbp ptr; dcl patch_key char (24) varying; dcl pbuf_size fixed bin (21); /* patch buffer size */ dcl pptr ptr; /* patch ptr */ dcl psz fixed bin; /* pad size */ dcl px fixed bin; /* patch index */ dcl rcode fixed bin (35); dcl rec_len fixed bin (21); dcl rtrycnt fixed bin; dcl scode fixed bin (35); dcl segp ptr; dcl svp ptr; dcl sw_name char (64); dcl t_stat bit (12) aligned; dcl term bit (1); dcl type fixed bin (2); dcl user_access fixed bin (5); dcl v_patch bit (1); /* valid patch */ dcl wcatp ptr; dcl wksp ptr; dcl work_key char (24) varying; dcl yes_sw bit (1); /* BUILTINS */ dcl addr builtin; dcl addrel builtin; dcl after builtin; dcl before builtin; dcl bin builtin; dcl char builtin; dcl convert builtin; dcl currentsize builtin; dcl fixed builtin; dcl index builtin; dcl hbound builtin; dcl lbound builtin; dcl length builtin; dcl ltrim builtin; dcl null builtin; dcl ptr builtin; dcl rel builtin; dcl rtrim builtin; dcl string builtin; dcl substr builtin; dcl translate builtin; dcl unspec builtin; dcl verify builtin; /* CONSTANTS */ dcl bcd_dkend bit (72) int static options (constant) init ("532020202020202442254524"b3); /* "$ dkend" in bcd */ dcl bcd_media_code fixed bin (4) int static options (constant) init (2); dcl bcd_obj bit (78) int static options (constant) init ("53202020202020462241252363"b3); /* "$ object" in bcd */ dcl binary_media_code fixed bin (4) int static options (constant) init (1); dcl bof fixed bin int static options (constant) init (-1); /* beginning of file */ dcl buf_size fixed bin (21) int static options (constant) init (4 * 1024); /* 1k buffer is plenty */ dcl current_ring fixed bin int static options (constant) init (-1); dcl density (5) char (5) int static options (constant) init ("d6250", "d1600", "d800", "d556", "d200"); dcl false bit (1) int static options (constant) init ("0"b); dcl fnp_355_edit_name char (4) int static options (constant) init ("0300"); dcl fnp_355_type char (4) int static options (constant) init ("6600"); dcl fnp_18x_edit_name char (4) int static options (constant) init ("2000"); dcl fnp_6670_type char (4) int static options (constant) init ("6670"); dcl fmt1 char (53) int static options (constant) init ("^[^5-^12s^; ^[^6x^1s^;^6a^] ^4a ^4a ^2a/^2a/^2a "); dcl fmt2 char (33) int static options (constant) init ("^[^6a ^6a ^2a^s^;^3s^4a^2-^]^]"); dcl fmt3 char (62) int static options (constant) init ("^-^[ ^[^;^[yes^;no ^]^]^;^2s^64t^24a ^2d ^6o ^8d^]^/"); dcl g_label bit (72) int static options (constant) init /* = "ge 600 btl " in bcd */ ("272520200600002022634320"b3); dcl hdra char (18) int static options (constant) init ("Edit Deck Assm"); dcl hdrb char (42) int static options (constant) init ("N__a_m_e T__y_p_e D__a_t_e"); dcl hdra1 char (5) int static options (constant) init ("Ident"); dcl hdrb1 char (46) int static options (constant) init ("C__o_d_e M__o_d_e_l R__e_v._"); dcl hdrb2 char (12) int static options (constant) init ("T__y_p_e"); dcl hdrb3 char (111) int static options (constant) init ("S__e_a_r_c_h K__e_y C__o_m_p O__f_f_s_e_t L__e_n_g_t_h (_B__y_t_e_s)_"); dcl hdra2 char (2) int static options (constant) init ("SS"); dcl hdra3 char (40) int static options (constant) init ("Record Location Record"); dcl hdra4 char (7) int static options (constant) init ("Multics"); dcl hdrb4 char (30) int static options (constant) init ("A__p_p_l_i_c_a_b_l_e"); dcl max_retrys fixed bin int static options (constant) init (10); dcl mpcbot bit (36) int static options (constant) init ("444723224663"b3); dcl NL char (1) int static options (constant) init (" "); dcl no_chase_sw fixed bin (1) int static options (constant) init (0); dcl no_type fixed bin (2) int static options (constant) init (-1); dcl print bit (1) int static options (constant) init ("0"b); dcl rec_cont_wrd bit (36) int static options (constant) init ("000016000200"b3); dcl sys_dir char (21) int static options (constant) init (">system_library_tandd"); dcl true bit (1) int static options (constant) init ("1"b); dcl whitespace char (2) int static options (constant) init /* TAB and SPACE */ (" "); dcl wrapup bit (1) int static options (constant) init ("1"b); /* BASED and STRUCTURES */ dcl 1 bcw based (bcwp) aligned, (2 bsn fixed bin (18), 2 blk_size fixed bin (18)) unsigned unaligned; dcl bit_buf bit (rec_len * 9) based (gprp); dcl 1 cur_bcw like bcw aligned based (cbcwp); dcl data_move char (dfm_data.dlen * 4) based (dfm_data.bptr); dcl 1 catalog based (c_ptr) aligned, 2 n_entries fixed bin, 2 key (1 refer (catalog.n_entries)) char (24); dcl free_area area based (get_system_free_area_ ()); dcl 1 glr based (glrp) aligned like gc_log_rec; dcl glrb bit (glr.rcw.rsize * 36) based (glrbp); dcl 1 gpr based (gprp) aligned like gc_phy_rec; dcl id_bbuf bit (108) based (cvp); dcl 1 new_bcw like bcw aligned based (nbcwp); dcl 1 o_card based (ocardp) aligned, /* template for an object card */ (2 pad1 char (15), 2 library char (6), /* col 16 - either "hmpcj1" or "htnd " */ 2 ld_type char (1), /* col 22, module type */ 2 ss_type char (1), /* col 23, subsystem type */ 2 pad2 char (3), 2 m_applic char (1), /* Multics applicability, non blank means not applicable */ 2 pad3 char (15), 2 model char (6), /* for hmpcj1 decks, controller model # */ 2 version char (6), /* for hmpcj1 decks, model version # */ 2 pad4 char (5), 2 assem char (1), /* "m" for mpc assembler, "g" for gmap */ 2 call_name char (6), /* module call name, or gecall name */ 2 ttl_date char (6), /* date module assembled */ 2 edit_name char (4), /* module edit name */ 2 pad5 char (4)) unaligned; dcl 1 p_blk aligned int static, /* patch card image storage */ 2 p_cnt fixed bin, /* number of valid patches */ 2 p_card (200) char (80); /* patch card image */ dcl 1 r_card based (dfm_data.cptr) aligned, /* template for a binary card image */ (2 type bit (12), /* card type */ 2 count fixed bin (5), /* number of wds controlled */ 2 ld_add bit (18), /* loading address */ 2 pad (psz) bit (36), 2 data (r_card.count) bit (36), 2 nxt_c_wd bit (36)) unaligned; /* to get nxt control wd */ dcl 1 rsi like rs_info aligned; /* auto copy of record status info */ dcl 1 wcata based (wcatp), /* working catalog */ 2 n_entries fixed bin, /* number of catalog entries */ 2 key (1 refer (wcata.n_entries)) char (24); /* entry search keys */ /* EXTERNAL ENTRIES */ dcl add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; dcl bcd_to_ascii_ entry options (variable); dcl command_query_$yes_no entry () options (variable); dcl dfm_$complain entry () options (variable); dcl get_system_free_area_ entry () returns (ptr); dcl gload_ entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl gload_$allow_zero_checksums entry entry (char (*), char (*), char (*), ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl (ioa_, ioa_$ioa_switch, ioa_$rs) entry () options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$delete_record 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)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$seek_key entry entry options (variable); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl mca_$attach_mca entry (char (*), fixed bin (71), fixed bin, fixed bin (35)); dcl mca_$detach_mca entry (fixed bin, fixed bin (35)); dcl mca_$diskette_read entry (fixed bin, char (*), fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35)); dcl mca_$read_data entry (fixed bin, ptr, fixed bin (21), fixed bin (21), bit (72), fixed bin (35)); dcl opr_query_ entry () options (variable); dcl tolts_alm_util_$ascii_to_bcd_ entry (char (*), bit (*)); /* EXTERNAL */ dcl error_table_$fatal_error fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$no_file fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$tape_error fixed bin (35) ext static; /* PARAMETERS */ dcl P_dfm_datap ptr; %page; /* ck_applic - entry to check for current deck Multics Applicability. If a deck is appicable, "1"b is returned. If deck is the first deck of an "itr" a catalog build is begun */ ck_applic: entry (P_dfm_datap) returns (bit (1)); dfm_datap = P_dfm_datap; ocardp = addr (dfm_data.obj_card); if o_card.m_applic ^= " " then do; /* only take deck if Multics applicable */ if o_card.library = "hmpcj1" then /* if itr deck */ if id_blk.type = "itr" then /* space to nxt file */ call space_file (); /* space to nxt file */ else if o_card.ss_type = "h" then /* space over heals files */ call space_file (); /* space to nxt file */ return (false); /* return false */ end; else do; /* Multics applicable */ if o_card.library = "hmpcj1" then do; /* if itr, mdr or firmware deck */ if id_blk.type = "mdr" then /* if current deck an mdr */ if dfm_data.firmware_sw & ^dfm_data.deckfile_sw then do; dfm_data.eot = true; /* and we are only loading firmware, thats it */ return (false); end; else ; else if id_blk.type ^= "itr" /* else if firmware deck */ & dfm_data.firmware_sw then /* and not just loading deckfile */ call ld_fw_deck (dfm_data.bptr); /* go load core image for BOS */ if ^dfm_data.first_deck then do; /* if first deck of current file */ dfm_data.cat_build, dfm_data.first_deck = true; /* set flag so we don't come back */ cata.n_entries = 0; /* reset number of catalog entries */ dfm_data.cat_key = id_blk.type || "."; /* form suffix part of catalog key */ if id_blk.type = "mdr" then do; /* if building mdr catalog */ if o_card.ss_type = "t" then dfm_data.sstype = "tape "; /* tape catalog */ else if o_card.ss_type = "p" then dfm_data.sstype = "print"; /* printer catalog */ else if o_card.ss_type = "c" then dfm_data.sstype = "card "; /* card catalog */ else if o_card.ss_type = "d" then dfm_data.sstype = "disk "; /* disk catalog */ else do; call dfm_$complain (dfm_datap, print, 0, /* unknown type */ "Unknown subsystem type (col 23) on $ object card ^/Last $ object card image is: ^/""^a""", dfm_data.obj_card); dfm_data.first_deck = false; /* check next $ object card */ return (true); end; dfm_data.cat_key = rtrim (dfm_data.cat_key) || dfm_data.sstype; /* complete mdr catalog key */ end; end; end; end; return (true); /* return true */ %page; /* copy_eof - entry to write end of file mark on copy tape */ copy_eof: entry (P_dfm_datap); dfm_datap = P_dfm_datap; call iox_$control (dfm_data.ciocb_ptr, "write_eof", null, code); dfm_data.copy_at_eof = true; /* set copy eof flag */ return; %page; /* delete_deck - entry to delete a deck in the T & D deckfile */ delete_deck: entry (P_dfm_datap, work_key, rcode); dfm_datap = P_dfm_datap; rcode = 0; /* reset abort flag */ call iox_$seek_key (dfm_data.fiocb_ptr, work_key, rec_len, code); /* set key for deletion */ if code ^= 0 then do; rcode = code; return; end; call iox_$delete_record (dfm_data.fiocb_ptr, code); if code ^= 0 then do; rcode = code; return; end; term = false; allocate lbuff in (free_area) set (dfm_data.lbuff_p); lbuff = ""; dfm_data.list_key = "ls." || rtrim (work_key); call iox_$seek_key (dfm_data.fiocb_ptr, dfm_data.list_key, rec_len, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek key ^a ", dfm_data.list_key); call iox_$read_record (dfm_data.fiocb_ptr, dfm_data.lbuff_p, rec_len, lbuff_len, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to read a keyed record ^a", dfm_data.list_key); call ioa_$rs ("^a^86t^7a ^14a^/", lbuff, lbuff_len, substr (lbuff, 1, index (lbuff, rtrim (work_key)) + length (rtrim (work_key))), "DELETED", substr (dfm_data.time_string, 1, 14)); call insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lbuff_p, lbuff_len, (dfm_data.list_key)); free dfm_data.lbuff_p -> lbuff in (free_area); dfm_data.lbuff_p = null; return; %page; /* detach_file - entry to close and detach file */ detach_file: entry (P_dfm_datap, iocb_ptr); dcl iocb_ptr ptr; dfm_datap = P_dfm_datap; call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); iocb_ptr = null; return; %page; /* find_dkend - entry to find either a $deckend card or a patch card */ find_dkend: entry (P_dfm_datap, work_key, pptr, npatches, rcode); dfm_datap = P_dfm_datap; abort, dk_end, end_file, first_rcd, first_patch = false; /* reset flags */ id_ld, obj_card_found = false; p_blk.p_cnt = 0; /* initialize patch count */ cvp, cvp1 = null; call iox_$seek_key (dfm_data.fiocb_ptr, work_key, rec_len, code); if code ^= 0 then do; rcode = 0; return; end; unspec (rsi) = "0"b; rsi.version = rs_info_version_2; call iox_$control (dfm_data.fiocb_ptr, "record_status", addr (rsi), code); if code ^= 0 then do; rcode = 0; return; end; bcwp, gprp, mvp = rsi.record_ptr; cbcwp = dfm_data.bptr; pbuf_size = rec_len; do while (^dk_end); /* loop until entire deck is read in */ if ^first_rcd then do; /* if first record of deck */ bcnt = gpr.bcw.bsn; /* load block serial number */ first_rcd = true; end; else do; /* if not first record, check BSN */ bcnt = bcnt + 1; /* increment our block count */ if gpr.bcw.bsn ^= bcnt then /* something wrong here */ call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error, "Block serial number error at record ^d, file ^d ^/Block serial number was ^d, S/B ^d", dfm_data.crec, dfm_data.cfile, gpr.bcw.bsn, bcnt); end; glrp = addr (gpr.gc_phy_rec_data (1)); /* get pointer to first logical record */ nwds = 0; do while (nwds < gpr.bcw.blk_size); /* iterate through all logical records */ if glr.rcw.media_code = 2 then do; /* bcd card image */ glrbp = addr (glr.gc_log_rec_data); if substr (glrb, 1, 78) = bcd_obj then do; /* object card */ call bcd_to_ascii_ (glrb, dfm_data.obj_card); /* convert to ascii */ obj_card_found = true; /* indicate that we have gotten object card */ ocardp = addr (dfm_data.obj_card); end; else do; if o_card.library = "hmpcj1" & ^id_ld then do; /* if hmpcj1 lib and we haven't been here */ id_ld = true; /* set flag so we don't come back */ if cvp1 = null then cvp1 = cvp; /* if only 1 binary card */ call load_ident; /* load ident block */ end; if ck_patch (glrb) then do; /* go check for patch card */ if ^first_patch then do; dfm_data.dlen = fixed (rel (glrp)) - fixed (rel (mvp)); data_move = mvp -> data_move; /* move data from begin to patch */ mvp = addrel (mvp, dfm_data.dlen); dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen); first_patch = true; end; call command_query_$yes_no (yes_sw, 0, "Patch Deck", "A patch card has been found in the deck. Do you want to retain it?", "Patch: ^/^a^/Found in deck ^a.^/Do you wish to retain it?", dfm_data.ascii_card, work_key); if yes_sw then do; dfm_data.dlen = glr.rcw.rsize + 1; /* move the patch */ data_move = mvp -> data_move; mvp = addrel (mvp, dfm_data.dlen); dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen); end; else do; mvp = addrel (mvp, glr.rcw.rsize + 1); /* adjust the ptr past the patch */ call remove_patch; end; end; if substr (glrb, 1, 72) = bcd_dkend then do; /* dkend card */ call bcd_to_ascii_ (glrb, dkend_card); /* convert to ascii */ dk_end = true; if ^first_patch then do; dfm_data.dlen = fixed (rel (glrp)) - fixed (rel (mvp)); data_move = mvp -> data_move; mvp = addrel (mvp, dfm_data.dlen); dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen); end; if npatches > 0 then do i = 1 to npatches; if dfm_data.opatches (i).type = "octal" | dfm_data.opatches (i).type = "mask " then do; dfm_data.opatches (i).dtime = dfm_data.gtime_string; dfm_data.opatches (i).label = o_card.edit_name; call tolts_alm_util_$ascii_to_bcd_ (string (dfm_data.opatches (i)), bcard); if ^ck_patch (bcard) then call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error, "patch: ^/^a^/ is an invalid patch"); bcard = rec_cont_wrd || substr (bcard, 1, 504); mvp = addr (bcard); dfm_data.dlen = 15; data_move = mvp -> data_move; dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen); end; else if substr (dfm_data.hpatches (i).type, 2) = "hex" then do; dfm_data.hpatches (i).dtime = dfm_data.gtime_string; dfm_data.hpatches (i).lbl = o_card.edit_name; dfm_data.hpatches (i).prg_id = string (id_blk.revision); dfm_data.hpatches (i).rev = string (id_blk.revision); dfm_data.hpatches (i).lbl = o_card.edit_name; call tolts_alm_util_$ascii_to_bcd_ (string (dfm_data.hpatches (i)), bcard); if ^ck_patch (bcard) then call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error, "patch: ^/^a^/ is an invalid patch", dfm_data.opatches (i)); bcard = rec_cont_wrd || substr (bcard, 1, 504); mvp = addr (bcard); dfm_data.dlen = 15; data_move = mvp -> data_move; dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen); end; end; substr (dkend_card, 67, 6) = dfm_data.gtime_string; call tolts_alm_util_$ascii_to_bcd_ (dkend_card, bcard); bcard = rec_cont_wrd || substr (bcard, 1, 504); mvp = addr (bcard); dfm_data.dlen = 15; data_move = mvp -> data_move; dfm_data.bptr = addrel (dfm_data.bptr, dfm_data.dlen); nbcwp = dfm_data.bptr; new_bcw.blk_size = (fixed (rel (dfm_data.bptr)) - 1) - fixed (rel (cbcwp)); if new_bcw.blk_size > 308 then do; cur_bcw.blk_size = 308; new_bcw.blk_size = new_bcw.blk_size - 308; new_bcw.bsn = cur_bcw.bsn + 1; end; else cur_bcw.blk_size = new_bcw.blk_size; call insert_deck (dfm_datap, dfm_data.fiocb_ptr, ptr (dfm_data.bptr, 0), fixed (rel (dfm_data.bptr)) * 4, work_key); if o_card.library = "hmpcj1" & id_blk.type ^= "itr" then call ld_fw_deck (ptr (dfm_data.bptr, 0)); term = false; dfm_data.list_key = "ls." || rtrim (work_key); allocate lbuff in (free_area) set (dfm_data.lbuff_p); lbuff = ""; call iox_$control (dfm_data.fiocb_ptr, "record_status", addr (rsi), code); call iox_$seek_key (dfm_data.fiocb_ptr, rtrim (dfm_data.list_key), rec_len, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek key ^a ", rtrim (dfm_data.list_key)); call iox_$read_record (dfm_data.fiocb_ptr, dfm_data.lbuff_p, rec_len, lbuff_len, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to read a keyed record ^a", rtrim (dfm_data.list_key)); call ioa_$rs ("^a^86t^2d^90t^6o^103t^8d^[ PATCHED ^14a^;^s]^/", lbuff, lbuff_len, substr (lbuff, 1, index (lbuff, rtrim (work_key)) + length (rtrim (work_key))), addr (rsi.descriptor) -> rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18), rsi.record_length, (p_blk.p_cnt > 0), substr (dfm_data.time_string, 1, 20)); call insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lbuff_p, lbuff_len, (dfm_data.list_key)); free dfm_data.lbuff_p -> lbuff in (free_area); dfm_data.lbuff_p = null; if p_blk.p_cnt > 0 then call put_patch; term = true; end; end; end; else if glr.rcw.media_code = 1 then /* binary card image */ if ^obj_card_found then /* but no $ object card yet */ call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error, "Binary card image preceeds $ object card at record ^d, file ^d", dfm_data.crec, dfm_data.cfile); else do; cvp1 = cvp; /* save ptr to last logical record */ cvp = glrp; /* save ptr to current logical record */ end; else call dfm_$complain (dfm_datap, wrapup, /* not a bcd or binary card image */ error_table_$fatal_error, "Card type ^o detected at record ^d, file ^d", glr.rcw.media_code, dfm_data.crec, dfm_data.cfile); nwds = nwds + glr.rcw.rsize + 1; /* increment number of words */ glrp = addrel (glrp, currentsize (glr)); /* set next logical record */ end; dfm_data.crec = dfm_data.crec + 1; /* increment current record number */ gprp = addrel (gprp, currentsize (gpr)); /* append next block */ cbcwp = addrel (cbcwp, bcw.blk_size + 1); bcwp = gprp; end; return; %page; /* find_file - entry to find the correct file */ find_file: entry (P_dfm_datap, d_name, e_name); dcl e_name char (*); dcl d_name char (*); dfm_datap = P_dfm_datap; type = no_type; /* set to novalid value */ file_found = false; yes_sw = false; term = false; do while (^term); call hcs_$status_minf (d_name, e_name, no_chase_sw, type, bit_count, code); if code ^= 0 then do; /* err or noentry */ if code ^= error_table_$noentry then /* error */ call dfm_$complain (dfm_datap, wrapup, code, "looking for ^a in ^a", e_name, d_name); else do; /* no entry */ if accessible (d_name, "", SMA_ACCESS_BIN) then do; /* dir access? */ call command_query_$yes_no (yes_sw, 0, "Find File", "^a does not exist in ^a. Do you wish to create it?", "File ^a does not exist in ^a. ^/Create it? ", e_name, d_name); if yes_sw then do; /* okey - create */ file_found, term = true; if index (ename, ".list") ^= 0 then /* if creating new list */ dfm_data.page_no = 0; end; else if d_name ^= sys_dir then /* haven't tried >firmware */ d_name = sys_dir; /* try it */ else goto exit_ff_loop; /* user doesn't want any of these choices */ end; else goto exit_ff_loop; /* not enough access */ end; end; else if type = Directory then do; /* entry exists - dir (msf) */ if accessible (d_name, "", SMA_ACCESS_BIN) then /* dir access? */ if d_name = sys_dir then /* sys dir - ask */ if accessible (d_name, e_name, RW_ACCESS_BIN) & ^dfm_data.list then do; call command_query_$yes_no (yes_sw, 0, "Find File", "^a does not exist in working dir. Use the one found in ^a?", "You have access to modify ^a in ^a.^/Use it?", e_name, sys_dir); if ^yes_sw then goto exit_ff_loop; end; file_found, term = true; /* must be ok */ end; else if type = Link then do; /* entry exist & link */ call hcs_$get_link_target (d_name, e_name, /* get dir & entry */ d_name, e_name, code); if code ^= 0 then do; if code ^= error_table_$noentry then /* error */ call dfm_$complain (dfm_datap, wrapup, code, "chasing link to ^a", d_name, e_name); else if accessible (d_name, "", SMA_ACCESS_BIN) then do; call command_query_$yes_no (yes_sw, 0, "Find File", "^a is a link in your working dir.^/Use the one found in ^a?", "You have access to create ^a in ^a. ^/Create it?", e_name, d_name); if yes_sw then do; /* okey - got it */ file_found, term = true; if index (ename, ".list") ^= 0 then /* if creating new list */ dfm_data.page_no = 0; end; else goto exit_ff_loop; end; else goto exit_ff_loop; /* need more access */ end; else if accessible (d_name, e_name, RW_ACCESS_BIN) & ^dfm_data.list then do; call command_query_$yes_no (yes_sw, 0, "Find File", "^a is a link in your working dir. ^/Use the one found in ^a?", "You have access to modify ^a in ^a. ^/Use it?", e_name, d_name); if yes_sw then /* okey - got it */ file_found, term = true; else goto exit_ff_loop; /* suer doesn't want it */ end; else file_found, term = true; /* must be ok */ end; else if type = Segment /* single segment deckfile */ & index (e_name, ".list") = 0 then do; if d_name = sys_dir then /* sys dir - ask */ if accessible (d_name, e_name, RW_ACCESS_BIN) & ^dfm_data.list then do; call command_query_$yes_no (yes_sw, 0, "Find File", "^a does not exist in working dir. Use the one found in ^a?", "You have access to modify ^a in ^a.^/Use it?", e_name, sys_dir); if ^yes_sw then goto exit_ff_loop; end; file_found, term = true; /* must be ok */ end; else if index (e_name, ".list") ^= 0 & accessible (d_name, e_name, RW_ACCESS_BIN) then /* must be a listing seg */ file_found, term = true; else goto exit_ff_loop; /* seg not valid */ end; exit_ff_loop: if ^file_found then /* can't continue */ call dfm_$complain (dfm_datap, wrapup, error_table_$no_file, "using ^a>^a", rtrim (d_name), rtrim (e_name)); if ^dfm_data.bf_sw & file_found then call dfm_$complain (dfm_datap, print, 0, "using ^a>^a", rtrim (d_name), rtrim (e_name)); return; %page; /* find_key - entry to find all search keys, given search key head */ find_key: entry (P_dfm_datap, iocbp, c_name, c_ptr, rcode); dcl c_ptr ptr; dcl c_name char (24) varying; dfm_datap = P_dfm_datap; rcode = 0; ename = c_name; /* copy search name */ info_ptr = addr (info); unspec (info) = "0"b; common_sl_info.version = sl_info_version_0; common_sl_info.list_type = 1; /* set to reuse subset */ common_sl_info.output_descriptors = true; /* want descriptors */ common_sl_info.array_limit = 1; /* 1 element array */ common_sl_info.desc_arrayp = null; /* let vfile_ allocate area for storage */ hi_sl_info.first_head (1).length, hi_sl_info.last_head (1).length = length (rtrim (ename)); hi_sl_info.first_head (1).kptr, hi_sl_info.last_head (1).kptr = addr (ename); call iox_$control (iocbp, "select", info_ptr, code); /* get select info */ if code ^= 0 then do; /* problem with select */ rcode = code; return; end; call iox_$position (iocbp, bof, 0, code); /* position to beginning of file */ if code ^= 0 then do; /* problem with select */ rcode = code; return; end; catalog.n_entries = common_sl_info.count; /* copy number of descriptors */ gk_info_ptr = addr (gki); /* set info ptr */ unspec (gki) = "0"b; /* clear structure first */ gk_info.input_desc = true; /* using input descriptors */ gk_info.reset_pos = true; /* don't change position */ do i = 1 to common_sl_info.count; /* find each key */ gk_info.descrip = desc_array (i); /* insert each descriptor */ call iox_$control (iocbp, "get_key", gk_info_ptr, code); if code ^= 0 then do; /* error */ rcode = code; return; end; catalog.key (i) = gk_info.key; /* copy key */ end; common_sl_info.list_type = 0; /* set to reuse subset */ common_sl_info.subset_no = 0; common_sl_info.array_limit = 0; /* 0 element array */ common_sl_info.desc_arrayp = null; /* let vfile_ allocate area for storage */ call iox_$control (iocbp, "select", info_ptr, code); /* reset current subset */ rcode = 0; /* If we get this far insure 0 code is returned */ return; /* thats it folks */ %page; /* get_cata - entry to search a deckfile for a catalog. If one exists it is read out, else a new one is initialized. */ get_cata: entry (P_dfm_datap, iocbp, cata_name, wcatp, wksp, rcode); dcl rec_length fixed bin (21); dcl cata_name char (24) varying; dfm_datap = P_dfm_datap; call iox_$seek_key (iocbp, cata_name, rec_length, code); if code ^= 0 then do; if code = error_table_$no_record then do; wcata.key = " "; wcata.n_entries = 0; code = 0; end; end; else call iox_$read_record (iocbp, wcatp, rec_length, rec_len, code); wksp = addr (wcata.key (1)); rcode = code; return; %page; /* insert_deck - entry to insert current deck into the T & D deckfile */ insert_deck: entry (P_dfm_datap, iocbp, bufp, buf_len, work_key); dcl bufp ptr; dcl buf_len fixed bin (21); dfm_datap = P_dfm_datap; if ^dfm_data.deckfile_sw & ^dfm_data.mdf then return; /* not using a deckfile - return */ call iox_$seek_key (iocbp, work_key, rec_length, code); /* set key for insertion */ if code ^= error_table_$no_record then do; /* if record already exists */ if code = 0 then do; /* check for common itr */ call iox_$rewrite_record (iocbp, bufp, buf_len, code); /* write the record */ if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, /* fatal error - set abort flag */ "attempting to rewrite record whose key is ""^a"" to the ^a>^a", work_key, dfm_data.dir, dfm_data.entry); return; end; else if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, /* fatal error - set abort flag */ "attempting to rewrite record whose key is ""^a"" to the ^a>^a", work_key, dfm_data.dir, dfm_data.entry); end; call iox_$write_record (iocbp, bufp, buf_len, code); /* write the record */ if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, /* fatal error - set abort flag */ "attempting to write record whose key is ""^a"" to the ^a>^a", work_key, dfm_data.dir, dfm_data.entry); return; %page; /* make_key - entry to make up a key for insertion into the deckfile based on object card info */ make_key: entry (P_dfm_datap); dfm_datap = P_dfm_datap; ocardp = addr (dfm_data.obj_card); dfm_data.current_key = ""; /* initialize key first */ if dfm_data.fnp_tape then do; /* make special key for fnp bin deck tapes */ dfm_data.fnp_key = dfm_data.fnp_key + 1; /* increment fnp key number */ dfm_data.current_key = "fnp." || dfm_data.fnp_type || ".pol." || ltrim (char (dfm_data.fnp_key)) || "." || substr (o_card.edit_name, 1, 2); end; else if lfd then do; if index (dfm_data.current_filename, "cata.") ^= 0 then do; dfm_data.current_key = rtrim ("cata.nio." || substr (dfm_data.current_filename, 6)); if index (dfm_data.current_filename, "mca") = 0 & index (mcata_key_string, dfm_data.current_key) = 0 then do; mcata.n_entries = mcata.n_entries + 1; mcata.key (mcata.n_entries) = dfm_data.current_key; end; end; else do; dfm_data.current_key = "nio." || rtrim (dfm_data.current_filename); if index (dcata_key_string, dfm_data.current_key) = 0 then do; dcata.n_entries = dcata.n_entries + 1; dcata.key (dcata.n_entries) = dfm_data.current_key; end; end; return; end; else if o_card.library = "hmpcj1" then do; /* if mpc deck */ if id_blk.type ^= "itr" & id_blk.type ^= "mdr" then/* if firmware deck */ dfm_data.current_key = string (id_blk.type_code); /* set firmware identification */ else dfm_data.current_key = id_blk.type; /* itr or mdr */ dfm_data.current_key = rtrim (dfm_data.current_key) || "." || id_blk.ident; dfm_data.current_key = rtrim (dfm_data.current_key) || "." || o_card.edit_name; dfm_data.current_key = rtrim (dfm_data.current_key) || "." || id_blk.rev; /* set revision */ end; else do; /* must be htnd deck */ if o_card.ss_type = "s" then /* take care of special cases first */ dfm_data.current_key = "pas." || substr (o_card.edit_name, 1, 3); /* isolts deck */ else if o_card.ss_type = "u" then /* utility deck */ dfm_data.current_key = "utl." || o_card.call_name; else dfm_data.current_key = o_card.ss_type || "lt." || o_card.call_name; /* most common case */ return; end; if index (cata_key_string, dfm_data.current_key) = 0 then do; cata.n_entries = cata.n_entries + 1; /* increment number of catalog entries */ cata.key (cata.n_entries) = dfm_data.current_key; /* and add current entry to catalog */ end; return; %page; /* mca_attach - entry to attach an MCA for diskette reads */ mca_attach: entry (P_dfm_datap, mca_id); dcl mca_id char (4); dfm_datap = P_dfm_datap; if dfm_data.m_attached then return; call mca_$attach_mca (mca_id, 0, dfm_data.mca_ioi_idx, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "Attempting to attach mca ^a", mca_id); dfm_data.m_attached = true; return; %page; /* mca_detach - entry to detach an MCA */ mca_detach: entry (P_dfm_datap); dfm_datap = P_dfm_datap; if ^dfm_data.m_attached then return; call mca_$detach_mca (dfm_data.mca_ioi_idx, code); if code ^= 0 then call dfm_$complain (dfm_datap, print, code, "Attempting to detach the mca", ""); dfm_data.m_attached = false; return; %page; /* merge deckfiles - entry to merge two deckfiles */ merge_files: entry (P_dfm_datap, old_iocbp, new_iocbp); dfm_datap = P_dfm_datap; unspec (rsi) = "0"b; rsi.version = rs_info_version_2; allocate lbuff in (free_area) set (dfm_data.lbuff_p); lbuff = ""; do i = lbound (list_types, 1) to hbound (list_types, 1); dfm_data.list_key = list_types (i); call find_key (dfm_datap, old_iocbp, (dfm_data.list_key), dfm_data.lcatp, code); if code ^= 0 then dfm_data.list_key = ""; if dfm_data.list_key ^= "" then do; call get_cata (dfm_datap, old_iocbp, dfm_data.list_key, dfm_data.lcatp, dfm_data.lksp, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to find catalog for ^a", dfm_data.list_key); do j = 1 to lcata.n_entries; call iox_$seek_key (old_iocbp, /* get the ls. key entry */ rtrim (lcata.key (j)), rec_len, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek key ^a ", lcata.key (j)); call iox_$read_record (old_iocbp, dfm_data.lbuff_p, rec_len, lbuff_len, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to read a keyed record ^a", lcata.key (j)); if index (lbuff, "DELETED") = 0 & index (lcata.key (j), ".hdr") = 0 /* if not hdr */ & index (lcata.key (j), ".P.") = 0 then do; /* or patch headr move data */ merge_key = substr (lcata.key (j), verify (lcata.key (j), "ls.")); call iox_$seek_key (old_iocbp, merge_key, rec_length, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek key ^a ", merge_key); call iox_$read_record (old_iocbp, dfm_data.bptr, rec_length, rec_len, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to read a keyed record ^a", merge_key); call insert_deck (dfm_datap, new_iocbp, dfm_data.bptr, rec_len, merge_key); call iox_$control (new_iocbp, "record_status", addr (rsi), code); /* get record position */ call ioa_$rs ("^a^86t^2d^5x^6o^4x^8d^/", lbuff, lbuff_len, substr (lbuff, 1, index (lbuff, rtrim (merge_key)) + length (rtrim (merge_key))), addr (rsi.descriptor) -> rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18), rsi.record_length); end; else do; /* update time & pathname */ if after (lcata.key (j), ".hdr") = "1" then /* time */ call ioa_$rs ("^a^61tTime - ^a", lbuff, lbuff_len, before (lbuff, "Time"), dfm_data.time_string); else if after (lcata.key (j), ".hdr") = "2" then /* pathname */ call ioa_$rs ("^a^51tStored in ^a>^a", lbuff, lbuff_len, before (lbuff, "Stored"), dfm_data.dir, dfm_data.entry); end; call insert_deck (dfm_datap, new_iocbp, /* write the ls entry */ dfm_data.lbuff_p, lbuff_len, (lcata.key (j))); end; call insert_deck (dfm_datap, new_iocbp, dfm_data.lcatp, length (unspec (lcata)), dfm_data.list_key); end; end; free dfm_data.lbuff_p -> lbuff in (free_area); dfm_data.lbuff_p = null; return; %page; /* mount diskette - entry to instruct the operator to mount an MCA diskette */ mount_diskette: entry (P_dfm_datap, diskette_name, header_ptr) returns (bit (1)); dcl diskette_name char (8) varying; dfm_datap = P_dfm_datap; opr_query_info.prim = "0 or 1"; opr_query_info.alt = "unable"; opr_query_info.r_comment = ""; term = false; do i = 0 to 1 while (^term); dfm_data.disk_num = i; read_diskette_hdr: call read_diskette (dfm_datap, "HDR", header_ptr, rec_len, "0"b, code); if code = 0 then do; if substr (header.unique_id, 1, 3) = substr (diskette_name, 1, 3) then do; term = true; opr_query_info.q_sw = false; call opr_query_ (addr (opr_query_info), "Reading diskette ^a on drive ^d", header.unique_id, dfm_data.disk_num); return (true); end; end; end; if ^term then do; ask_opr: call ioa_ ("requesting mount of ^a", diskette_name); opr_query_info.q_sw = true; opr_query_info.r_comment = "disk # used or unable"; call opr_query_ (addr (opr_query_info), "Please mount diskette ^a and reply with", diskette_name); if opr_query_info.answer = "unable" then do; call ioa_ ("unable to mount MCA diskette ^a", diskette_name); return (false); end; else do; dfm_data.disk_num = convert (dfm_data.disk_num, opr_query_info.answer); if disk_num < 0 | dfm_data.disk_num > 1 then do; call ioa_ ("operator returned incorrect reply - retrying"); goto ask_opr; end; else goto read_diskette_hdr; /* read hdr and display message */ end; end; return (false); /* should never happen */ %page; /* open_file - entry to attach and open files */ open_file: entry (P_dfm_datap, sw_name, att_desc, mode, iocbp); dfm_datap = P_dfm_datap; call iox_$attach_name (sw_name, iocbp, att_desc, null, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attaching ^a", sw_name); call iox_$open (iocbp, mode, "0"b, code); /* open per mode */ if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "opening ^a for ^a", sw_name, iox_modes (mode)); return; %page; /* print_list - entry to generate a listing of the contents of a deckfile */ print_list: entry (P_dfm_datap, iocbp, work_key); dfm_datap = P_dfm_datap; if ^dfm_data.deckfile_sw & ^dfm_data.mdf then return; call iox_$position (iocbp, bof, 0, code); /* position to beginning of file */ if index (work_key, ".list") = 0 then call find_key (dfm_datap, iocbp, (dfm_data.list_key), dfm_data.lcatp, code); else call get_cata (dfm_datap, iocbp, work_key, dfm_data.lcatp, dfm_data.lksp, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to find keys for ^a", work_key); k = 1; line_count = 0; allocate hbuff in (free_area) set (dfm_data.hbuff_p); allocate lbuff in (free_area) set (dfm_data.lbuff_p); hbuff = ""; do j = 1 to lcata.n_entries; lbuff = ""; call iox_$seek_key (iocbp, rtrim (lcata.key (j)), rec_len, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek key ^a ", lcata.key (j)); call iox_$read_record (iocbp, dfm_data.lbuff_p, rec_len, lbuff_len, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to read a keyed record"); if index (lcata.key (j), ".hdr") ^= 0 then do; hbuff (k) = ""; if k = 1 then do; /* Need to add page# */ dfm_data.page_no = dfm_data.page_no + 1; line_count = 1; call ioa_$rs ("^a, Page - ^d", lbuff, lbuff_len, before (lbuff, NL), dfm_data.page_no); end; hbuff (k) = rtrim (lbuff); k = k + 1; end; if dfm_data.terminal_out then lbuff = substr (lbuff, verify (lbuff, whitespace)); call iox_$put_chars (dfm_data.liocb_ptr, dfm_data.lbuff_p, length (rtrim (lbuff)), code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to ^[add to the deckfile.list^;display list output^]", ^dfm_data.terminal_out); if k = hbound (hbuff, 1) + 1 then do; call ioa_$ioa_switch (dfm_data.liocb_ptr, "^/"); k = 1; end; line_count = line_count + 1; if j < lcata.n_entries & lcata.n_entries > 1 then if index (lcata.key (j + 1), ".hdr") = 0 & (index (lbuff, "cata") ^= 0 | line_count > 25) then do; line_count = 0; dfm_data.page_no = dfm_data.page_no + 1; call ioa_$rs ("^a, Page - ^d", hbuff (1), hbuff_len, before (before (hbuff (1), NL), ", Page"), dfm_data.page_no); do i = lbound (hbuff, 1) to hbound (hbuff, 1); call iox_$put_chars (dfm_data.liocb_ptr, addr (hbuff (i)), length (rtrim (hbuff (i))), code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to ^[write list data^;display list output^]", ^dfm_data.terminal_out); end; call ioa_$ioa_switch (dfm_data.liocb_ptr, "^/"); end; end; free dfm_data.lbuff_p -> lbuff in (free_area); dfm_data.lbuff_p = null; free dfm_data.hbuff_p -> hbuff in (free_area); dfm_data.hbuff_p = null; return; %page; /* read_deck - entry to read in the next sequential object deck from the tape */ read_deck: entry (P_dfm_datap, end_file, abort); dcl (end_file, abort) bit (1); dfm_datap = P_dfm_datap; at_bot = true; /* initialize flags */ abort, dk_end, end_file = false; first_rcd, id_ld, obj_card_found = false; p_blk.p_cnt = 0; /* initialize patch count */ if dfm_data.pfile < dfm_data.cfile then dfm_data.pfile = dfm_data.cfile; /* update listing file designator if necessary */ gprp = dfm_data.bptr; /* set initial blk ptr to base of tape buff */ cvp, cvp1 = null; do while (^dk_end); /* loop until entire deck is read in */ rtrycnt = 0; /* reset retries */ retry_rd: call iox_$read_record (dfm_data.tiocb_ptr, gprp, buf_size, rec_len, code); if code ^= 0 then do; if code ^= error_table_$end_of_info then /* if not end of file */ if code = error_table_$tape_error then do; if at_bot then do; /* still at bot probably wrong density */ dfm_data.denno = dfm_data.denno + 1; /* increment density number */ if dfm_data.denno > hbound (density, 1) then /* can't set it so abort */ go to get_stat; call iox_$control (dfm_data.tiocb_ptr, "rewind", null, code); call iox_$control (dfm_data.tiocb_ptr, density (dfm_data.denno), null, code); /* set density */ go to retry_rd; /* and go try again */ end; rtrycnt = rtrycnt + 1; /* increment retry count */ if rtrycnt > max_retrys then do; /* if we have retried max number of times */ get_stat: call iox_$control (dfm_data.tiocb_ptr, "saved_status", addr (t_stat), scode); call dfm_$complain (dfm_datap, wrapup, code, "Tape status = ^4.3b, while reading record ^d, file ^d after 10 retries", t_stat, dfm_data.crec, dfm_data.cfile); /* set abort indicator */ end; call iox_$control (dfm_data.tiocb_ptr, "backspace_record", null, code); go to retry_rd; end; else call dfm_$complain (dfm_datap, wrapup, code, /* not a tape error report it and abort */ "While reading record ^d, file ^d", dfm_data.crec, dfm_data.cfile); else do; /* end of file */ end_file = true; /* set eof indicator */ dfm_data.cfile = dfm_data.cfile + 1; /* increment position indicators */ dfm_data.crec = 0; return; end; end; if rec_len = 56 then /* check for partial hdr label (GCOS EOV) */ if substr (bit_buf, 1, 72) = g_label then if substr (bit_buf, 145, 216) = "0"b then do;/* if true, partial hdr label */ dfm_data.eot = true; /* set EOV flags */ return; end; if ^first_rcd then do; /* if first record of deck */ bcnt = gpr.bcw.bsn; /* load block serial number */ first_rcd = true; end; else do; /* if not first record, check BSN */ bcnt = bcnt + 1; /* increment our block count */ if gpr.bcw.bsn ^= bcnt then /* something wrong here */ call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error, "Block serial number error at record ^d, file ^d^/Block serial number was ^d, S/B ^d", dfm_data.crec, dfm_data.cfile, gpr.bcw.bsn, bcnt); /* set abort flag */ end; glrp = addr (gpr.gc_phy_rec_data (1)); /* get pointer to first logical record */ nwds = 0; do while (nwds < gpr.bcw.blk_size); /* iterate through all logical records */ if glr.rcw.media_code = bcd_media_code then do; /* bcd card image */ glrbp = addr (glr.gc_log_rec_data); if substr (glrb, 1, 78) = bcd_obj then do; /* object card */ call bcd_to_ascii_ (glrb, dfm_data.obj_card); /* convert to ascii */ obj_card_found = true; /* indicate that we have gotten object card */ ocardp = addr (dfm_data.obj_card); if (o_card.edit_name = fnp_18x_edit_name | o_card.edit_name = fnp_355_edit_name) & at_bot then do; /* get set to build fnp catalog key */ if o_card.edit_name = fnp_18x_edit_name then /* is this an 18x fnp */ dfm_data.fnp_type = fnp_6670_type; /* yes, set type */ else if o_card.edit_name = fnp_355_edit_name then /* is it a 355 fnp */ dfm_data.fnp_type = fnp_355_type; else call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error, /* neither one, can't be fnp tape */ "First object deck image has an edit name ^a which is not a valid first deck a binary deck tape", o_card.edit_name); dfm_data.fnp_tape = true; dfm_data.cat_key = "fnp.pol." || dfm_data.fnp_type; /* start catalog key */ dfm_data.l_att_desc = rtrim (dfm_data.l_att_desc) || ".fnp." || dfm_data.fnp_type; end; end; else do; /* must be dkend or patch card */ if o_card.library = "hmpcj1" & ^id_ld then do; /* if hmpcj1 lib and we haven't been here */ id_ld = true; /* set flag so we don't come back */ if cvp1 = null then /* if only 1 binary card */ cvp1 = cvp; call load_ident; /* load ident block */ end; if substr (glrb, 1, 72) = bcd_dkend then /* dkend card */ dk_end = true; /* set terminate condition */ else if ^ck_patch (glrb) then /* go check for patch card */ call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error, "BCD card image at record ^d, file ^d is not $ object, $ dkend, or valid patch card:^/""^a""", dfm_data.crec, dfm_data.cfile, dfm_data.ascii_card); /* if error, get out */ end; end; else if glr.rcw.media_code = binary_media_code then /* binary card image */ if ^obj_card_found then /* but no $ object card yet */ call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error, "Binary card image preceeds $ object card at record ^d, file ^d", dfm_data.crec, dfm_data.cfile); else do; cvp1 = cvp; /* save ptr to last logical record */ cvp = glrp; /* save ptr to current logical record */ end; else call dfm_$complain (dfm_datap, wrapup, error_table_$fatal_error, /* not a bcd or binary card image */ "Card type ^o detected at record ^d, file ^d", glr.rcw.media_code, dfm_data.crec, dfm_data.cfile); at_bot = false; nwds = nwds + glr.rcw.rsize + 1; /* increment number of words */ glrp = addrel (glrp, currentsize (glr)); /* set next logical record */ end; dfm_data.crec = dfm_data.crec + 1; /* increment current record number */ gprp = addrel (gprp, currentsize (gpr)); /* append next block */ end; dfm_data.dlen = fixed (rel (gprp)) + 1; /* set total deck length in words */ return; %page; /* read_diskette - entry to read a specified diskette file */ read_diskette: entry (P_dfm_datap, filename, data_bufp, total_chars, mstat, rcode); dcl mca_buf_size fixed bin (21) init (16 * 1024); dcl (current_ptr, data_bufp) ptr; dcl filename char (*); dcl mstat bit (72); dcl ret_len fixed bin (21); dcl total_chars fixed bin (21); dfm_datap = P_dfm_datap; ret_len, total_chars = 0; code = 0; current_ptr = data_bufp; call mca_$diskette_read (dfm_data.mca_ioi_idx, filename, dfm_data.disk_num, current_ptr, mca_buf_size, ret_len, mstat, code); rd_loop: rcode = code; dfm_data.statp = addr (mstat); dfm_data.sub_ptr = addr (mca_status.sub); if code ^= 0 then do; if mca_status.maj = "0"b & mca_sub.data_p then call mca_$read_data (dfm_data.mca_ioi_idx, current_ptr, mca_buf_size, ret_len, "0"b, 0); return; end; current_ptr = add_char_offset_ (current_ptr, ret_len); total_chars = total_chars + ret_len; if mca_sub.data_p then do; call mca_$read_data (dfm_data.mca_ioi_idx, current_ptr, mca_buf_size, ret_len, mstat, code); goto rd_loop; end; else return; %page; /* update_list - entry to add current deck entry to listing file */ update_list: entry (P_dfm_datap, ltype); dcl ltype fixed bin (2); dfm_datap = P_dfm_datap; ocardp = addr (dfm_data.obj_card); unspec (rsi) = "0"b; rsi.version = rs_info_version_2; dfm_data.lib = false; /* reset lib rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18), rsi.record_length); end; else call ioa_$rs (fmt1 || fmt2 || fmt3, lbuff, lbuff_len, (ltype = cata_list_type), dfm_data.fnp_tape, o_card.call_name, o_card.edit_name, dfm_data.dtype, substr (o_card.ttl_date, 1, 2), substr (o_card.ttl_date, 3, 2), substr (o_card.ttl_date, 5, 2), dfm_data.lib, id_blk.ident, o_card.model, id_blk.rev, dfm_data.sstype, dfm_data.list, dfm_data.fnp_tape, (o_card.m_applic = " "), dfm_data.current_key, addr (rsi.descriptor) -> rs_desc.comp_num, fixed (rel (rsi.record_ptr), 18), rsi.record_length); dfm_data.list_key = "ls." || rtrim (dfm_data.current_key); if index (lcata_key_string, dfm_data.list_key) = 0 /* entry not in the cata */ | lib then do; /* mpc cata build */ lcata.n_entries = lcata.n_entries + 1; lcata.key (lcata.n_entries) = dfm_data.list_key; end; call insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lbuff_p, lbuff_len, dfm_data.list_key); free dfm_data.lbuff_p -> lbuff in (free_area); dfm_data.lbuff_p = null; if p_blk.p_cnt ^= 0 then /* if patches exist... */ call put_patch; /* list them too */ if dfm_data.attach_copy then /* if we are writing copy tape */ if ltype ^= cata_list_type then /* and this is not a catalog record */ call write_copy (); /* copy this deck too */ return; %page; /* valid_diskette - entry to verify a diskette as a valid diskette type */ valid_diskette: entry (P_dfm_datap, diskette) returns (bit (1)); dcl diskette char (8) varying; dfm_datap = P_dfm_datap; if index (string (valid_diskettes), substr (translate (diskette, lc, uc), 1, 3)) > 0 then return (true); else return (false); %page; /* accessible - int function that will check the user's access to system gates & data bases */ accessible: proc (dir, entry, lowest_access) returns (bit (1)); dcl dir char (*); dcl entry char (*); dcl lowest_access fixed bin (5); call hcs_$get_user_effmode (dir, entry, "", current_ring, user_access, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attemping to get user access to ^a>^a.", dir, entry); if user_access >= lowest_access then return (true); else return (false); /* if we made it - all ok */ end accessible; %page; /* ck_patch - int proc to check a bcd card image for a valid patch card */ ck_patch: proc (bcd_card) returns (bit (1)); dcl bcd_card bit (*); call bcd_to_ascii_ (bcd_card, dfm_data.ascii_card); ascii_cardp = addr (dfm_data.ascii_card); v_patch = false; /* reset patch flag */ if h_patch.type = "chex" | h_patch.type = "rhex" then /* for cs or r/w mem */ if o_card.assem = "m" then /* and deck produced with mpc assembler */ if h_patch.lbl = o_card.edit_name then /* if label matches */ if h_patch.rev = string (id_blk.revision) then /* and rev matches */ v_patch = true; /* valid hex patch */ if ^v_patch then /* if it wasn't hex patch */ if o_patch.type = "octal" | o_patch.type = "mask" then v_patch = true; /* valid octal patch */ if v_patch then do; /* if one of the above */ p_blk.p_cnt = p_blk.p_cnt + 1; /* increment patch count */ p_blk.p_card (p_blk.p_cnt) = dfm_data.ascii_card; /* copy image */ end; return (v_patch); end ck_patch; %page; /* ld_fw_deck - int proc to load core image of firmware deck into a segment named "fw..." */ ld_fw_deck: proc (fw_dkp); dcl fw_dkp ptr; ename = "fw." || id_blk.ident || "." || o_card.edit_name || "." || id_blk.rev; /* form firmware seg name */ call hcs_$initiate (dfm_data.dir, ename, "", 0, 0, segp, code); /* attempt to initiate seg */ if segp = null then do; /* seg does not exist, create it */ call hcs_$make_seg (dfm_data.dir, ename, "", 01010b, segp, code); if segp = null then /* error creating segment */ call dfm_$complain (dfm_datap, wrapup, code, "Unable to create ^a>^a", dfm_data.dir, ename); end; if dfm_data.allow_0_cksum then call gload_$allow_zero_checksums ("dfm_util_", dfm_data.dir, ename, fw_dkp, segp, 0, addr (gload_data), code); /* load the core image */ else call gload_ (fw_dkp, segp, 0, addr (gload_data), code); /* load the core image */ if code ^= 0 then /* loading error */ call dfm_$complain (dfm_datap, wrapup, code, "^a^/attempting to load core image of ^a>^a", gload_data.diagnostic, dfm_data.dir, ename); call hcs_$set_bc_seg (segp, fixed (gload_data.text_len) * 36, code); /* set bit count of fw seg */ if code ^= 0 then /* error setting bit count */ call dfm_$complain (dfm_datap, wrapup, code, "Unable to set bit count of ^a>^a", dfm_data.dir, ename); end ld_fw_deck; %page; /* load_ident - int proc to load last 2 binary card images of hmpcj1 deck and extract the ident block */ load_ident: proc; lx = 0; /* set initial load index */ ident_buf = ""b; svp = glrp; glrp = cvp1; do while (glr.rcw.media_code = 1); /* process only binary cards */ dfm_data.cptr = addrel (glrp, 1); psz = 4; /* set initial pad size to 4 */ m = r_card.count; /* set initial count */ term = false; do while (^term); /* load all words on card */ do i = 1 to r_card.count; ident_buf (lx + i) = r_card.data (i); /* copy data */ end; lx = lx + r_card.count; /* update load index */ if substr (r_card.nxt_c_wd, 1, 12) ^= "2005"b3 | m = glr.rcw.rsize - 8 then term = true; /* all done */ else do; dfm_data.cptr = addr (r_card.nxt_c_wd); /* set for nxt control word */ psz = 0; /* pad size = 0 */ m = m + r_card.count; /* increment counter */ end; end; glrp = addrel (glrp, currentsize (glr)); /* set next logical record */ if glr.rcw.media_code ^= binary_media_code & glr.rcw.media_code ^= bcd_media_code then /* ck for new blk */ if glrp -> gpr.bcw.bsn = bcnt then /* if looks like bcw */ glrp = addrel (glrp, 1); /* go to nxt word */ end; /* we have all of the ident block loaded, now lets find the words we are interested in */ term = false; do i = lbound (ident_buf, 1) to hbound (ident_buf, 1) while (^term); if ident_buf (i) = mpcbot then /* if word = "mpcbot" in bcd */ term = true; end; cvp = addr (ident_buf (i - 10)); /* cvp pts to beginning of ident block */ call bcd_to_ascii_ (id_bbuf, dfm_data.id_buf); /* convert ident block to ascii */ glrp = svp; end load_ident; %page; /* put_hdr - int proc to output a listing page header */ put_hdr: proc (); if lcata.n_entries = 0 & (dfm_data.deckfile_sw | dfm_data.mdf) then do; call get_cata (dfm_datap, dfm_data.fiocb_ptr, "ls.cata." || dfm_data.ls_type || ".list", dfm_data.lcatp, dfm_data.lksp, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "can't get list catalog", ""); end; allocate hbuff in (free_area) set (dfm_data.hbuff_p); hbuff = ""; if dfm_data.lfd then do; call ioa_$rs ("^| ^- Library - MCA ^61tTime - ^a", /* page# added during output */ hbuff (1), hbuff_len, dfm_data.time_string); call ioa_$rs ("^10t Contents of MCA Diskette - ^a^51tStored in ^a>^a ", hbuff (2), hbuff_len, dfm_data.current_disk_name, dfm_data.dir, dfm_data.entry); call ioa_$rs ("^9t File ^24t DATE ^45t SS ^66t Record ^87t Location ^96t Record", hbuff (3), hbuff_len); call ioa_$rs ("^9t N__a_m_e ^20t M__o_d_i_f_i_e_d ^32t _t_y_p_e ^65t S__e_a_r_c_h K__e_y ^82t C__o_m_p O__f_f_s_e_t L__e_n_g_t_h (B__y_t_e_s)", hbuff (4), hbuff_len); end; else do; call ioa_$rs ("^|^-^a ^[POL^s^;^a ^] ^61tTime - ^a", /* page# added during output */ hbuff (1), hbuff_len, "Library -", dfm_data.fnp_tape, o_card.library, dfm_data.time_string); call ioa_$rs ("^a ^[FNP ^a ^a^1s^;^2s^a^] ^a^51tStored in ^a>^a", hbuff (2), hbuff_len, "Contents of", dfm_data.fnp_tape, dfm_data.fnp_type, "Binary Deck Tape", "ITR, Firmware And Diagnostic (IFAD) Tape", dfm_data.tape_name, dfm_data.dir, dfm_data.entry); call ioa_$rs (" ^[ Call^; ^] ^a ^[^a^2-^s^;^s ^a^2-^]^-^[ ^[^a^]^;^2s ^a^]", hbuff (3), hbuff_len, (o_card.call_name ^= "" & ^dfm_data.fnp_tape), hdra, dfm_data.lib, hdra1, hdra2, dfm_data.list, ^dfm_data.fnp_tape, hdra4, hdra3); call ioa_$rs (" ^[ N__a_m_e^; ^] ^a ^[^a^s^;^s^a^2-^]^-^[^[^a^]^;^2s ^a^]", hbuff (4), hbuff_len, (o_card.call_name ^= "" & ^dfm_data.fnp_tape), hdrb, dfm_data.lib, hdrb1, hdrb2, dfm_data.list, ^dfm_data.fnp_tape, hdrb4, hdrb3); end; if dfm_data.deckfile_sw | dfm_data.mdf then do i = lbound (hbuff, 1) to hbound (hbuff, 1); header_key = "ls." || rtrim (dfm_data.lib_type) || "." || rtrim (dfm_data.dtype) || ".hdr" || ltrim (char (i)); call insert_deck (dfm_datap, dfm_data.fiocb_ptr, addr (hbuff (i)), length (rtrim (hbuff (i))), header_key); if index (lcata_key_string, header_key) = 0 then do; lcata.n_entries = lcata.n_entries + 1; lcata.key (lcata.n_entries) = header_key; end; end; free dfm_data.hbuff_p -> hbuff in (free_area); dfm_data.hbuff_p = null; dfm_data.hdr_sw = false; /* do header only once */ end put_hdr; %page; /* put_patch - int proc to add patch card images to listing file */ put_patch: proc; allocate lbuff in (free_area) set (dfm_data.lbuff_p); lbuff = ""; call ioa_$rs ("^/The following patch cards are contained in the above deck:^/", lbuff, lbuff_len); patch_key = "ls." || rtrim (work_key) || ".P.0"; do i = 0 to p_blk.p_cnt; /* output all patches */ cx = index (lcata_key_string, rtrim (patch_key)) / 24 + 1; /* see if patch exists */ if cx = 1 then do; /* no patch found */ cx = index (lcata_key_string, rtrim (work_key)) / 24 + 1; /* find entry for deck */ lcata.n_entries = lcata.n_entries + 1; /* bump total */ do j = lcata.n_entries to cx + i + 1 by -1; /* make a slot */ lcata.key (j) = lcata.key (j - 1); end; lcata.key (cx + i + 1) = rtrim (patch_key); /* insert new key in slot */ end; else lcata.key (cx) = rtrim (patch_key); /* key there - overwrite it */ call insert_deck (dfm_datap, dfm_data.fiocb_ptr, dfm_data.lbuff_p, length (rtrim (lbuff)), rtrim (patch_key)); if i < p_blk.p_cnt then do; /* set up for next patch */ call ioa_$rs ("^5t^a^/", lbuff, lbuff_len, rtrim (p_blk.p_card (i + 1))); patch_key = "ls." || rtrim (work_key) || ".P." || ltrim (char (i + 1)); end; end; free dfm_data.lbuff_p -> lbuff in (free_area); dfm_data.lbuff_p = null; p_blk.p_cnt = 0; /* initialize count */ end put_patch; %page; /* remove_patch - int proc to remove a patch from deckfile */ remove_patch: proc (); px = p_blk.p_cnt; do i = 1 to px; /* now remove the patch */ p_blk.p_card (i) = p_blk.p_card (i + 1); end; p_blk.p_cnt = p_blk.p_cnt - 1; /* from patch block */ patch_key = "ls." || rtrim (work_key) || ".P.1"; dl_patch: cx = index (lcata_key_string, rtrim (patch_key)) / 24; do i = 1 to lcata.n_entries - 1 - cx; /* move all entries down */ lcata.key (cx + i) = lcata.key (cx + 1 + i); end; lcata.key (lcata.n_entries) = ""; lcata.n_entries = lcata.n_entries - 1; if index (patch_key, ".P.0") = 0 & p_blk.p_cnt > 0 then do i = 1 to px; /* change the key names */ lcata.key (cx + i) = lcata.key (cx + i); lcata.key (cx + i) = "ls." || rtrim (work_key) || ".P." || ltrim (char (i)); end; call iox_$seek_key (dfm_data.fiocb_ptr, patch_key, rec_len, code); /* set key for deletion */ if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to seek ^a", patch_key); call iox_$delete_record (dfm_data.fiocb_ptr, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "attempting to delete ^a", patch_key); if p_blk.p_cnt = 0 & index (patch_key, ".P.0") = 0 then do; /* cnt = 0 patch key not header */ patch_key = "ls." || rtrim (work_key) || ".P.0"; goto dl_patch; end; end remove_patch; %page; /* space_file - int proc to formward space to nxt tape file */ space_file: proc (); call iox_$control (dfm_data.tiocb_ptr, "forward_file", null, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "while spacing a tape file", ""); dfm_data.cfile = dfm_data.cfile + 1; /* set correct position */ dfm_data.crec = 0; dfm_data.one_eof = true; /* set eof flag */ end space_file; %page; /* write_copy - int proc to write current deck to copy tape */ write_copy: proc (); if ^dfm_data.first_write then do; /* if this is the first time thru, set density */ dfm_data.first_write = true; /* set flag so we don't come back */ if dfm_data.cd_sw | dfm_data.denno ^= 0 then do; /* if user specified density */ if dfm_data.denno ^= 0 & ^dfm_data.cd_sw then /* if master tape not standard density */ cden = density (dfm_data.denno); /* set copy to same (if not user specified) */ call iox_$control (dfm_data.ciocb_ptr, cden, null, code); if code ^= 0 then call dfm_$complain (dfm_datap, wrapup, code, "while setting copy tape density", ""); end; end; gprp = dfm_data.bptr; /* set block ptr to first phy. record */ do while (bin (rel (gprp)) < dfm_data.dlen - 1 & ^dfm_data.eot); /* wrt entire deck */ c_rtrycnt = 0; /* initialize retry count */ retry_cp: call iox_$write_record (dfm_data.ciocb_ptr, gprp, (gpr.bcw.blk_size + 1) * 4, code); if code ^= 0 then /* if error */ if code = error_table_$tape_error then do; /* if write error */ c_rtrycnt = c_rtrycnt + 1; /* increment retry count */ if c_rtrycnt > max_retrys then do; /* exceeded error threshold */ call iox_$control (dfm_data.ciocb_ptr, "saved_status", addr (t_stat), scode); call dfm_$complain (dfm_datap, print, code, "Tape status = ^4.3b, while writing copy tape after 10 retrys", t_stat); dfm_data.eot = true; end; else do; call iox_$control (dfm_data.ciocb_ptr, "backspace_record", null, scode); call iox_$control (dfm_data.ciocb_ptr, "erase", null, scode); go to retry_cp; end; end; else do; /* not a tape error */ call dfm_$complain (dfm_datap, print, code, "while writing copy tape", ""); dfm_data.eot = true; /* set abort flag */ end; else gprp = addrel (gprp, currentsize (gpr)); /* no error advance to next block */ end; dfm_data.copy_at_eof = false; /* we are no longer at an eof mark */ end write_copy; %page; %include access_mode_values; %page; %include ak_info; %page; %include dfm_data; %page; %include gcos_ssf_records; %page; %include gload_data; %page; %include iox_modes; %page; %include mca_area; %page; %include mca_config_file; %page; %include mca_constants; %page; %include mca_data_area; %page; %include mca_diskette; %page; %include opr_query_info; %page; %include status_structures; %page; %include select_info; end dfm_util_;  dfm_request_table_.alm 10/21/92 1023.4rew 10/21/92 1020.0 16137 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1986 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-11-12,Fakoury), approve(86-11-12,MCR7515), " audit(87-01-07,Farley), install(87-01-08,MR12.0-1263): " Originally coded 06/82 by R. Fakoury " END HISTORY COMMENTS name dfm_request_table_ " Request definitions for Multics deck_file_manager command include ssu_request_macros " begin_table dfm_request_table_ " action requests request delete_deck, dfm_$delete_deck, (dd), (Deletes a deckfile deck.), flags.allow_command request list, dfm_$list, (ls), (Create a deckfile.list from a tandd_deck_file.), flags.allow_command request list_diskette_types, dfm_$list_diskette_types, (ldt), (Lists valid diskette types accepted by lfd.), flags.allow_command request load_from_diskette, dfm_$load_from_diskette, (lfd), (Read mca diskettes into the deckfile.), flags.allow_command request load_from_tape, dfm_$load_from_tape, (lft), (Read a Binary Deck File / IFAD tape into the deckfile), flags.allow_command request merge_deckfiles, dfm_$merge_deckfiles, (mdf), (Merge two or more deckfiles into one deckfile.), flags.allow_command request patch_deck, dfm_$patch_deck, (pd), (Patches a selected deck.), flags.allow_command request quit, dfm_$quit, (q), (Exits the deckfile_manager request loop.), flags.allow_command end_table dfm_request_table_ end bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved