read_tape_and_query.pl1 07/28/87 0923.2rew 07/28/87 0918.9 198423 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * ******************************************** */ /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-05-28,TLNguyen), approve(87-05-28,MCR7692), audit(87-07-15,Blair), install(87-07-28,MR12.1-1048): convert read_tape_and_query (rtq) nonstandard subsystem to a standard ssu_ subsystem: initialize intermediate variables. Get optional control arguments and their required partners (e.g. -comment STR). Establish cleanup and program_interrupt conditions. Create an invocation of rtq subsystem. Add the 2nd ssu_ request table to the list of tables. Add the 2nd ssu_ info directory to the list of directoies. Get the default request processor options for rtq. Set prompt string for rtq. Set up fields of the "rtq_structure_ info" record structure. Call "rtq_$set_up" external procedure. Set up for "-quit". Set up for "-request" and handle its possible errors. Invoke "ssu_$listen" and handle its possible error. Invoke "terminate_null_ref_name" to terminate file if already initiated. Invoke "read_tape_and_query_janitor" to detach and close tape and file. Finally, invoke "ssu_$destroy_invocation" to destroy invocation if already created. END HISTORY COMMENTS */ /* read_tape_and_query - written Sept 1977 by James A. Bush Modified 9/10/79 by J. A. Bush for installation in MR8.0 Modified 3/11/80 by P. B. Kelley to: 1) Fix bug preventing use of "-track". 2) Remove automatic large buffer if user has access to rcp_sys_. 3) Implement the "-block" control argument. 4) Fixes bug which caused rtq to return if a tape mark was encountered while attempting to determine the correct density. Modified 7/30/80 by J. A. Bush to: 1) Fix several tape positioning bugs. 2) Implement the "-density" and "-no_prompt" control arguments. 3) Add the "list_tape_contents" and "bof" requests. 4) Add tape label/trailer record recognition and display capabilities. 5) Add the "-count" argument to the "read_record" and "read_file" requests. Modified 01/02/81 by J. A. Bush to: 1) Recognize and diplay version 2 standard Multics tape labels. 2) Fix bug with "-skip" read_file request argument. 3) Implement the "-multics", "-nnl" and "-extend" read_file request arguments. 4) Implement the "-ring" control argument. Modified 4/82 by J. A. Bush to fix some bugs Modified 11/82 by J. A. Bush to fix some more bugs */ read_tape_and_query: rtq: proc; /* formated by default */ dcl abbrev_specified_flg bit (1); dcl arg_count fixed bin; dcl arg_length fixed bin (21); dcl arg_ptr ptr; dcl arg_dex fixed bin; dcl array_index fixed bin; dcl bit_count fixed bin (24); dcl (blocksize, code) fixed bin (35); dcl buf_size fixed bin (21); /* default buffer size */ dcl ddec fixed bin (35); /* density decimal */ dcl dir_name char (168); dcl entry_name char (32); dcl match bit (1) aligned; dcl no_prompt_specified_flg bit (1); dcl profile_ptr ptr; dcl prompt_length fixed bin (21); dcl prompt_ptr ptr; dcl quit_specified_flg bit (1); dcl request_line_length fixed bin (21); dcl request_line_ptr ptr; dcl request_loop_specified_flg bit (1); dcl request_specified_flg bit (1); dcl rtq_info_ptr ptr; dcl sci_ptr ptr; dcl tape_name char (8); dcl tape_atd char (200); dcl tdec fixed bin (35); /* track decimal */ dcl var_prompt_string char (64) varying; dcl wd_buf_size fixed bin; /* default buffer size in words */ /* based */ dcl arg char (arg_length) based (arg_ptr); dcl prompt_string char (prompt_length) based (prompt_ptr); dcl request_line char (request_line_length) based (request_line_ptr); dcl 1 rtq_info aligned like rtq_structure_info based (rtq_info_ptr); /* builtin */ dcl (addr, char, divide, fixed, hbound, ltrim, mod, null, rtrim, substr) builtin; /* condition */ dcl (cleanup, program_interrupt) condition; /* constants */ dcl DEFAULT_BUFFER_SIZE fixed bin static options (constant) init (2800); dcl NEXT_POS_IN_THE_LIST_OF_TABLES fixed bin static options (constant) init (2); dcl NINE_TRACK fixed bin static options (constant) init (9); dcl NUMBER_OF_CHARACTER_PER_WORD fixed bin static options (constant) init (4); dcl SEVEN_TRACK fixed bin static options (constant) init (7); dcl density (5) char (5) static options (constant) init ("d800", "d1600", "d6250", "d556", "d200"); dcl info_dir char (168) int static options (constant) init (">doc>subsystem>read_tape_and_query"); dcl rtq_version_1 char (8) static options (constant) init ("rtq.1"); dcl pname char (19) int static options (constant) init ("read_tape_and_query"); dcl whoami char (32) static options (constant) init ("rtq"); /* entries */ dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); 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 expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_ entry options (variable); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl rtq_$set_up entry (ptr, ptr, fixed bin (35)); dcl requote_string_ entry (char (*)) returns (char (*)); 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_$get_default_rp_options entry (ptr, char (8), ptr, fixed bin (35)); dcl ssu_$listen entry (ptr, ptr, fixed bin (35)); dcl ssu_$set_prompt_mode entry (ptr, bit (*)); dcl ssu_$set_prompt entry (ptr, char (64) varying); dcl ssu_$set_request_processor_options entry (ptr, ptr, fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); /* external */ dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$badcall fixed bin (35) ext static; dcl error_table_$inconsistent fixed bin (35) ext static; dcl rtq_request_table_$rtq_request_table_ fixed bin (35) external static; dcl ssu_et_$subsystem_aborted fixed bin (35) external static; dcl ssu_et_$null_request_line fixed bin (35) ext static; dcl ssu_et_$program_interrupt 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 fixed bin (35) external; %page; /* initialized intermediate variables */ call init_intermediate_variables; /* get users 's optional control arguments */ call get_users_optional_control_args; if code ^= 0 then do; call terminate_null_ref_name; return; end; /* establish cleanup condition */ on cleanup goto FINISH_SUBSYSTEM; /* establish program_interrupt condition */ on program_interrupt goto INVOKE_LISTEN; /* create a invocation of a subsystem */ call ssu_$create_invocation (whoami, rtq_version_1, addr (rtq_structure_info), addr (rtq_request_table_$rtq_request_table_), info_dir, sci_ptr, code); if code ^= 0 then do; call com_err_ (code, pname, "Creating subsystem invocation."); goto DESTROY_INVOCATION; end; /* add ssu_request_table_ as the 2nd request table in the list of tables */ call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), NEXT_POS_IN_THE_LIST_OF_TABLES, code); if code ^= 0 then do; call com_err_ (code, pname, "Adding standard ssu_ request table as the 2nd table."); goto DESTROY_INVOCATION; end; /* add standard ssu_info_directories at the 2nd position in the info directories*/ call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests, NEXT_POS_IN_THE_LIST_OF_TABLES, code); if code ^= 0 then do; call com_err_ (code, pname, "Adding standard ssu_ request info segs."); goto DESTROY_INVOCATION; end; /* get the default request processor options for the rtq subsystem */ if abbrev_specified_flg then do; call ssu_$get_default_rp_options (sci_ptr, RP_OPTIONS_VERSION_1, addr (local_rpo), (0)); local_rpo.abbrev_info.expand_request_lines = "1"b; local_rpo.abbrev_info.default_profile_ptr = profile_ptr; local_rpo.abbrev_info.profile_ptr = profile_ptr; call ssu_$set_request_processor_options (sci_ptr, addr (local_rpo), (0)); end; /* set prompt string for the rtq subsystem */ if no_prompt_specified_flg | prompt_length = -1 then call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT); else if prompt_length > 0 then do; /* set user_specified prompt */ var_prompt_string = prompt_string; call ssu_$set_prompt (sci_ptr, var_prompt_string); /* make it varying for ssu_ */ end; else call ssu_$set_prompt_mode (sci_ptr, PROMPT); /* by default */ /* make things ready before performing user's requests */ rtq_info_ptr = addr (rtq_structure_info); call fill_in_fields_of_rtq_stru_info; call rtq_$set_up (sci_ptr, rtq_info_ptr, code); if code ^= 0 then goto DESTROY_INVOCATION; /* don't want additional message. */ if quit_specified_flg then goto FINISH_SUBSYSTEM; if request_specified_flg 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 then goto INVOKE_LISTEN; else if code = ssu_et_$subsystem_aborted then goto FINISH_SUBSYSTEM; else do; call com_err_ (code, whoami); goto FINISH_SUBSYSTEM; end; end; end; /* invokes listen */ INVOKE_LISTEN: call ssu_$listen (sci_ptr, null (), code); if code ^= ssu_et_$subsystem_aborted then call com_err_ (code, pname, "Calling the listener."); /* finishes subsystem */ FINISH_SUBSYSTEM: call read_tape_and_query_janitor (sci_ptr, rtq_info_ptr); DESTROY_INVOCATION: call terminate_null_ref_name; call ssu_$destroy_invocation (sci_ptr); return; /**************************************************************************/ %page; fill_in_fields_of_rtq_stru_info: proc (); /* fill in "rtq_structure_info" structure's field values after processing */ /* control argument and got the structure's address. */ rtq_structure_info.atd_sw, rtq_structure_info.buf_ful, rtq_structure_info.eof, rtq_structure_info.eov = "0"b; rtq_info.eof_request_flg = "0"b; rtq_structure_info.extend_sw, rtq_structure_info.f_attached, rtq_structure_info.fw_file = "0"b; rtq_structure_info.last_job_deck_flg, rtq_structure_info.one_eof, rtq_structure_info.return_subsys_loop_flg = "0"b; rtq_info.records_in_file_flg = "0"b; rtq_structure_info.set_bin, rtq_structure_info.set_nine, rtq_structure_info.tmr, rtq_structure_info.two_eofs = "0"b; rtq_structure_info.bits, rtq_structure_info.block_size, rtq_structure_info.clen, rtq_structure_info.cvbl = 0; rtq_structure_info.l_type, rtq_structure_info.rec_len = 0; rtq_structure_info.c_file, rtq_structure_info.c_mode, rtq_structure_info.c_rec = 1; rtq_structure_info.cbufp, rtq_structure_info.cdkp, rtq_structure_info.cdptr, rtq_structure_info.cfptr = null; rtq_structure_info.cvp, rtq_structure_info.cvbp, rtq_structure_info.fiocb_ptr, rtq_structure_info.lblp = null; rtq_structure_info.rptr, rtq_structure_info.rtq_area_ptr, rtq_structure_info.tiocb_ptr, rtq_structure_info.tptr = null; rtq_structure_info.c_den, rtq_structure_info.filename, rtq_structure_info.filepath = ""; rtq_structure_info.buf_size = buf_size; rtq_structure_info.ddec = ddec; rtq_structure_info.density = density; rtq_structure_info.tape_atd = tape_atd; rtq_structure_info.tape_name = tape_name; rtq_structure_info.tdec = tdec; rtq_structure_info.Version = rtq_version_1; rtq_structure_info.wd_buf_size = wd_buf_size; end fill_in_fields_of_rtq_stru_info; /**************************************************************************/ %page; get_nxt_arg: proc returns (bit (1) aligned); /* get_nxt_arg - function to get next command line argument */ dcl old_arg char (32) init (""); /* begin coding */ old_arg = arg; /* copy arg for error messages */ arg_dex = arg_dex + 1; call cu_$arg_ptr (arg_dex, arg_ptr, arg_length, code); /* get comment arg */ if code ^= 0 then do; /* error */ call com_err_ (code, pname, "obtaining ""^a"" specification.", old_arg); return ("0"b); end; return ("1"b); /* return ok */ end get_nxt_arg; /***********************************************************************/ %page; get_users_optional_control_args: proc; /* the 1st input argument typed in must be reel identifier */ call cu_$arg_count (arg_count, code); call cu_$arg_ptr (1, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, pname, "Getting reel_id."); call ioa_ ("Usage: read_tape_and_query (rtq) reel_id {-control_args}"); call ioa_ ("^/CONTROL ARGUMENTS ^/-abbrev, -ab ^/-block N, -bk N ^/-comment STR ^/-density N, -den N" || "^/-no_abbrev, -nab ^/-no_prompt ^/-no_request_loop, -nrql ^/-profile PATH, -pf PATH ^/-prompt STR" || "^/-quit ^/-request STR, -rq STR ^/-request_loop, -rql ^/-ring ^/-track N, -tk N"); return; end; /* save reel number and establish tape attach description */ tape_name = arg; tape_atd = "tape_nstd_ " || arg; /* process all optional input control arguments if they are specified */ do arg_dex = 2 by 1 to arg_count while (code = 0); call cu_$arg_ptr (arg_dex, arg_ptr, arg_length, code); /* look for more arguments */ if code ^= 0 then ; /* if args exhausted, look no further */ else if arg = "-comment" | arg = "-com" then do; /* User wants to send OPR message */ if ^get_nxt_arg () then return; /* if some problem with required arg, quit */ tape_atd = rtrim (tape_atd) || " -comment " || requote_string_ ((arg)); /* put in quoted comment */ end; else if arg = "-track" | arg = "-tk" then do;/* next arg must be 7 or 9 */ if ^get_nxt_arg () then return; /* if some problem with required arg, quit */ tdec = cv_dec_check_ (arg, code); /* convert to dec. for check */ if code ^= 0 then go to bad_arg; /* must be numeric */ if tdec ^= SEVEN_TRACK & tdec ^= NINE_TRACK then go to bad_arg; /* and only 7 or 9 */ tape_atd = rtrim (tape_atd) || " -track " || ltrim (char (tdec)); /* insert leading blank */ end; else if arg = "-block" | arg = "-bk" then do;/* next arg must be blocksize */ if ^get_nxt_arg () then return; /* if some problem with required arg, quit */ blocksize = cv_dec_check_ (arg, code); if code ^= 0 then go to bad_arg; tape_atd = rtrim (tape_atd) || " -block " || ltrim (char (blocksize)); buf_size = blocksize + mod (blocksize, NUMBER_OF_CHARACTER_PER_WORD); /* set buffer size in chars, mod 4 */ wd_buf_size = divide (buf_size, NUMBER_OF_CHARACTER_PER_WORD, 17, 0); /* and in words */ end; else if arg = "-density" | arg = "-den" then do; /* next arg must be density value */ if ^get_nxt_arg () then return; /* if some problem with required arg, quit */ ddec = cv_dec_check_ (arg, code); if code ^= 0 then go to bad_arg; match = "0"b; do array_index = 1 to hbound (density, 1) while (^match); if ddec = fixed (substr (density (array_index), 2, 4)) then do; match = "1"b; tape_atd = rtrim (tape_atd) || " -density " || ltrim (char (ddec)); end; end; if ^match then go to bad_arg; end; else if arg = "-prompt" then do; arg_dex = arg_dex + 1; call cu_$arg_ptr (arg_dex, prompt_ptr, prompt_length, code); if code ^= 0 then do; call com_err_ (code, pname, "Trying to get the prompt string."); return; end; if prompt_length = 0 then prompt_length = -1; end; else if arg = "-no_prompt" then no_prompt_specified_flg = "1"b; else if arg = "-ring" | arg = "-rg" then /* user wants to attach tape with write ring */ tape_atd = rtrim (tape_atd) || " -write"; else if arg = "-request_loop" | arg = "-rql" then do; if quit_specified_flg then do; INCONSISTENT: call com_err_ (error_table_$inconsistent, pname, "-request_loop and -quit"); return; end; else request_loop_specified_flg = "1"b; end; else if arg = "-no_request_loop" | arg = "-nrql" then request_loop_specified_flg = "0"b; else if arg = "-abbrev" | arg = "-ab" then abbrev_specified_flg = "1"b; else if arg = "-no_abbrev" | arg = "-nab" then abbrev_specified_flg = "0"b; else if arg = "-profile" | arg = "-pf" then do; abbrev_specified_flg = "1"b; arg_dex = arg_dex + 1; call cu_$arg_ptr (arg_dex, arg_ptr, arg_length, code); if code ^= 0 then goto bad_arg; call expand_pathname_$add_suffix (arg, "profile", dir_name, entry_name, code); if code ^= 0 then goto bad_arg; call initiate_file_ (dir_name, entry_name, R_ACCESS, profile_ptr, bit_count, code); if profile_ptr = null then do; call com_err_ (code, pname, "Initiating the profile: ", pathname_ (dir_name, entry_name)); return; end; end; else if arg = "-quit" then do; if request_loop_specified_flg then goto INCONSISTENT; else quit_specified_flg = "1"b; end; else if arg = "-request" | arg = "-rq" then do; if request_specified_flg then do; call com_err_ (error_table_$badcall, pname, "Only one request line allowed."); return; end; else do; request_specified_flg = "1"b; arg_dex = arg_dex + 1; call cu_$arg_ptr (arg_dex, request_line_ptr, request_line_length, code); if code ^= 0 then do; call com_err_ (code, pname, "Trying to get the request line."); return; end; end; end; else do; if substr (arg, 1, 1) = "-" then do; bad_arg: call com_err_ (error_table_$bad_arg, pname, "argument number ^d: ""^a""", arg_dex, arg); return; end; end; end; /* do argdex = 2 by 1 while code = 0 */ end get_users_optional_control_args; /***********************************************************************/ %page; init_intermediate_variables: proc (); /* begin coding */ abbrev_specified_flg, no_prompt_specified_flg, quit_specified_flg, request_loop_specified_flg, request_specified_flg = "0"b; arg_length, arg_dex, blocksize, code, ddec, prompt_length, request_line_length, tdec = 0; arg_ptr, profile_ptr, prompt_ptr, request_line_ptr, rtq_info_ptr, sci_ptr = null; dir_name, entry_name, tape_name, tape_atd, var_prompt_string = ""; buf_size = DEFAULT_BUFFER_SIZE * NUMBER_OF_CHARACTER_PER_WORD; wd_buf_size = DEFAULT_BUFFER_SIZE; end init_intermediate_variables; /***********************************************************************/ %page; read_tape_and_query_janitor: proc (sci_ptr, rtq_info_ptr); /* detach_tape_file - internal procedure to detach and close tape and file */ dcl release_area_ entry (ptr); dcl (rtq_info_ptr, sci_ptr) ptr; /* close and detach tape switch which was attached and opened early */ if rtq_info.tiocb_ptr ^= null then do; call iox_$close (rtq_info.tiocb_ptr, (0)); call iox_$detach_iocb (rtq_info.tiocb_ptr, (0)); end; if rtq_info.rtq_area_ptr ^= null then call release_area_ (rtq_info.rtq_area_ptr); /* if file was attached then detach it */ if rtq_info.f_attached then do; call iox_$close (rtq_info.fiocb_ptr, (0)); call iox_$detach_iocb (rtq_info.fiocb_ptr, (0)); rtq_info.last_job_deck_flg, rtq_info.f_attached = "0"b; end; end read_tape_and_query_janitor; /************************************************************************/ %page; terminate_null_ref_name: proc (); /* begin coding */ code = 0; /* prevent code was previously not zero */ if profile_ptr ^= null then call terminate_file_ (profile_ptr, bit_count, TERM_FILE_TERM, code); if code ^= 0 then call com_err_ (code, pname, "Terminating profile segment."); return; end terminate_null_ref_name; /************************************************************************/ %page; %include rtq_structure_info; %page; %include access_mode_values; %page; %include terminate_file; %page; %include iox_modes; %page; %include ssu_prompt_modes; %include ssu_rp_options; dcl 1 local_rpo like rp_options; %include area_info; end read_tape_and_query;  rtq_.pl1 07/28/87 1527.0rew 07/28/87 1524.5 1198836 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * ******************************************** */ /****^ HISTORY COMMENTS: 1) change(87-05-28,TLNguyen), approve(87-05-28,MCR7692), audit(87-07-15,Blair), install(87-07-28,MR12.1-1048): convert read_tape_and_query (rtq) nonstandard subsystem to a standard ssu_ subsystem. 2) change(87-07-14,TLNguyen), approve(87-07-14,MCR7701), audit(87-07-15,Blair), install(87-07-28,MR12.1-1048): bug fixes. 3) change(87-07-14,TLNguyen), approve(87-07-14,MCR7727), audit(87-07-15,Blair), install(87-07-28,MR12.1-1048): add two new requests: "eof" and "rif". 4) change(87-07-28,TLNguyen), approve(87-07-28,PBF7701), audit(87-07-28,Blair), install(87-07-28,MR12.1-1050): PBF to ID1048: expand file names'declaration from char (32) to char (168) and attach output description (specified by -ods) from char (64) to char (200). END HISTORY COMMENTS */ rtq_: proc (); /* formated by default */ /* external entries */ dcl bcd_to_ascii_ entry (bit (*), char (*)); dcl comp_8_to_ascii_ entry (bit (*), char (*)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl ebcdic_to_ascii_ entry (char (*), char (*)); dcl ebcdic8_to_ascii_ entry (bit (*), char (*)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl 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_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin); dcl ssu_$get_subsystem_and_request_name entry (ptr) returns (char (72) var); dcl ssu_$print_message entry () options (variable); /* condition */ dcl (cleanup, conversion, program_interrupt) condition; /* builtin */ dcl (addr, addrel, bin, char, currentsize, divide, fixed, hbound, index, length, ltrim, mod, null, rtrim, revert, search, substr, translate, unspec) builtin; /* automatic storage */ dcl BINARY_MODE fixed bin static options (constant) init (1); dcl LABEL (0:6) char (9) int static options (constant) init ("unlabeled", "Multics", "Multics", "GCOS", "IBM", "ANSI", "CP5"); dcl NL char (1) int static options (constant) init (" "); dcl NINE_MODE fixed bin static options (constant) init (3); dcl NUMB_OF_CHARS_PER_WORD fixed bin static options (constant) init (4); dcl YES_FLG bit (1) aligned; dcl Nargs fixed bin; /* number of input arguments */ dcl al fixed bin; /* argument length */ dcl ansid bit (1) aligned; /* ANSI db format */ dcl ansi_mode fixed bin; /* ANSI mode */ dcl ap ptr; /* argument pointer */ dcl arg_dex fixed bin; dcl att_desc char (200); /* 168 chars for pathname + 32 chars for "vfile_ " */ dcl attach_desc_output char (200) varying; dcl bcnt fixed bin (24); /* block count */ dcl binck bit (1) aligned; /* binary card */ dcl blocksize fixed bin (35); /* block size */ dcl (c_b_a, c_c_a, c_e_a, cont, cp5) bit (1) aligned; /* convert bcd; comp8; ebcdic; continuing ; cp5 */ dcl code fixed bin (35); dcl dec_sw bit (1) aligned; /* DEC switch */ dcl direction bit (1) aligned; dcl eoj_card char (14) static options (constant) init ("$ endjob "); dcl first_record_flg bit (1) aligned; dcl g_label bit (72) int static options (constant) init /* = "ge 600 btl " in bcd */ ("272520200600002022634320"b3); dcl gssf bit (1) aligned; /* Gcos standard system format */ dcl (i, j) fixed bin; /* indices */ dcl ibm_label fixed bin int static options (constant) init (4); dcl ibmv bit (1) aligned; /* IBM vb format */ dcl imcv bit (1) aligned; /* suffix name of $ snumb card in Gcos standard format */ dcl it_cnt fixed bin; /* count it */ dcl iterations fixed bin (35); dcl l_cnt fixed bin (35); /* loop count */ dcl l_rec bit (1) aligned; /* logical record */ dcl l_rec_len fixed bin (35); /* logical record length */ dcl last_record_flg bit (1) aligned; dcl lrp ptr; /* logical record pointer */ dcl mode (3) char (7) int static options (constant) init ("binary", "bcd", "nine"); dcl mssf bit (1) aligned; /* Multics standard system format */ dcl nchars fixed bin (21); /* number of characters */ dcl nnl_sw bit (1) aligned; /* no new line switch */ dcl n_ops fixed bin; /* number of operations */ dcl nunits fixed bin (35); /* number of units */ dcl nwds fixed bin (35); /* number of words to dump */ dcl open_mode fixed bin; dcl order char (16); dcl pname char (19) int static options (constant) init ("read_tape_and_query"); dcl rf bit (1) aligned; /* file requests (e.g. bsf, fsf) */ dcl rpt bit (1) aligned; /* space requests (e.g. bsf, bsr, fsf, fsr) */ dcl rtq_info_ptr ptr; dcl s_filename char (32) varying; /* source file name */ dcl save_status_code fixed bin (35); dcl sci_ptr ptr; dcl scode fixed bin (35); dcl schar fixed bin (35); /* skip characters */ dcl spill fixed bin (21); dcl status_story char (100) varying; dcl t_stat bit (12) aligned; /* tape status */ dcl temp_logical_rec_len fixed bin (21); dcl time_string char (24); dcl tr_cnt fixed bin (35); /* truncate count */ dcl trim_trailing_blanks_log_rec_len fixed bin (21); dcl trunc_sw bit (1) aligned; /* truncate switch */ dcl who_asked char (32) varying; /* external static */ dcl (error_table_$end_of_info, error_table_$not_closed, error_table_$not_detached, error_table_$tape_error) fixed bin (35) ext; dcl iox_$user_output ptr ext; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl tape_status_table_$tape_status_table_ ext static; /* based */ dcl 1 ansi_db_lrec based (rtq_info.rptr) unaligned, /* template for ansi "DB" formated records */ 2 lrl char (4), /* log rec length in ascii chars */ 2 alrd char (l_rec_len), /* log rec data */ 2 nxt_lrec bit (0); /* to get to nxt record */ dcl 1 conv_buf based (lrp), /* conversion buffer, no logical records */ 2 skip_char char (schar), /* characters to skip */ 2 conv_dta char (rtq_info.rec_len - schar + 1); /* good char data */ dcl 1 cp5_phy_rec based (rtq_info.tptr) aligned, /* cp5 standard tape record */ ( 2 pbs fixed bin (18) unsigned, /* previous block size */ 2 nky fixed bin (18) unsigned, /* number of log records in this block */ 2 first bit (1)) unaligned;/* to get to first log record */ dcl 1 cp5_log_rec based (rtq_info.rptr) aligned, /* cp5 variable logical record */ ( 2 pad1 bit (36), /* not used - yet */ 2 pad2 fixed bin, /* ditto */ 2 rlen fixed bin (18) unsigned, /* size of record in bytes */ 2 cp5_log_rec_data char (1 refer (cp5_log_rec.rlen))) unaligned; /* data bytes in EBCDIC */ dcl 1 dec_mult (it_cnt) based (lrp) aligned, /* convert DEC to Multics word */ ( 2 first_32 bit (32), /* first 32 bits */ 2 last_4 bit (4)) unaligned;/* last four bits */ dcl 1 dec_tape_raw based (rtq_info.tptr) aligned, /* strange format for DEC tape */ 2 ps_wd (it_cnt) unaligned,/* pseudo DEC word (40 bits) */ 3 first_32 bit (32), /* first 32 bits of word */ 3 pad bit (4), /* next 4 bits ignored */ 3 last_4 bit (4); /* last 4 bits */ dcl 1 ibm_log_rec based (rtq_info.rptr) unaligned, /* IBM VB log record */ 2 rdw, /* record data word */ 3 pad1 bit (1), 3 msl bit (8), /* most sign. 8 bits of length */ 3 pad2 bit (1), 3 lsl bit (8), /* least sign. 8 bits of length */ 3 pad3 bit (18), 2 ilrd char (l_rec_len), /* ebcdic data */ 2 nxt_lrec bit (0); /* to get to nxt log record */ dcl 1 ibm_phy_rec based (rtq_info.tptr) aligned, /* IBM VB phy record */ ( 2 bdw, /* block data word */ 3 pad1 bit (1), 3 msl bit (8), /* most sign. 8 bits of length */ 3 pad2 bit (1), 3 lsl bit (8), /* least sign. 8 bits of length */ 3 pad3 bit (18), 2 iprd char (blocksize - 4)) unaligned; dcl 1 lrec_cbuf based (lrp), /* logical record template */ 2 skip_char char (schar), 2 chcv_buf (it_cnt) char (l_rec_len); dcl 1 mult based (rtq_info.tptr) unaligned, 2 lab_id bit (36), /* this will be 670314355245 in octal */ 2 pad (7) bit (36), /* we ignore this */ 2 vol_info like volume_identifier; /* mstr.incl.pl1 must be included */ dcl 1 gcos based (rtq_info.tptr) unaligned, 2 lab_id bit (72), /* this will be "GE 600 BTL " in bcd */ 2 pad bit (36), /* we ignore this */ 2 vol_id bit (36); /* this is in bcd */ dcl 1 ibm_ansi based (rtq_info.tptr) unaligned, /* IBM or ANSI label structure */ 2 lab_id bit (32), /* this will be "VOL1" in ebcdic or 8 bit ascii */ 2 vol_id bit (48); /* this is in ebcdic or 8 bit ascii */ dcl 1 cp5_lab based (rtq_info.tptr) unaligned, /* CP5 label structure */ 2 lab_id bit (32), /* This will be ":LBL" in 8 bit ebcdic */ 2 vol_id bit (32); /* this is 8 bit ebcdic */ dcl arg char (al) based (ap); dcl bit_buf bit (rtq_info.bits) based (rtq_info.tptr); /* tape buffer in bits pointed by tape pointer */ dcl char_buf char (rtq_info.rec_len) based (rtq_info.tptr); /* tape buffer in characters pointed by tape pointer */ dcl cdkbuf char (136) based (rtq_info.cdkp); dcl cbuf char (rtq_info.buf_size) based (rtq_info.cbufp); dcl cv_buf char (rtq_info.cvbl) based (rtq_info.cvbp); dcl gssf_ascii char (gc_log_rec.rcw.rsize * 4) based (rtq_info.cvp); dcl lab_buf char (rtq_info.rec_len) based (rtq_info.lblp); dcl mult_move char (rtq_info.clen) based; dcl 1 rtq_info aligned like rtq_structure_info based (rtq_info_ptr); dcl rtq_area area based (rtq_info.rtq_area_ptr); dcl sentinel char (4) based (rtq_info.lblp); /* like statement */ dcl 1 ai like area_info aligned; /***************************************************************************/ %page; set_up: entry (sci_ptr, rtq_info_ptr, code); /* initiate variables and area info block. Establish */ /* cleanup and program_interrupt conditions. Get an area and save its */ /* pointer. Get temporary segments for rtq subsubsystem. Attach and */ /* open tape using the "tape_nstd_" i/o module. Set conversion buffer */ /* to maximum size. Determine an user's density. If the density is */ /* valid then report to an user and determine the tape types. Report */ /* the tape type to users. Invoke "check_mode" internal procedure if */ /* the tape type is either IBM label or ANSI label. Perform the */ /* "forward_record" control order to the HDR2 label record and read it */ /* in by invoking "read_tape_record" internal procedure. Check the */ /* input/output eof argument value. If not end of file then report to */ /* users and invoke the "valid_label_record". Report to user, perform */ /* the "forward_file" control order and return. If end of file */ /* encountered, report to users, perform the "rewind" control order and */ /* return. If the given density is invalid then set the density to the */ /* default density, report to users, and return. */ /* constant */ dcl NUMB_OF_BITS_PER_BYTE fixed bin static options (constant) init (9); dcl NUMB_OF_BYTES_PER_WORD fixed bin static options (constant) init (4); dcl CP5_label bit (32) int static options (constant) init /* ":LBL" in 8 bit ebcdic */ ("72D3C2D3"b4); dcl a_label bit (32) int static options (constant) init /* "VOL1" in 8 bit ascii (ansi stand label) */ ("564F4C31"b4); dcl ansi_label fixed bin int static options (constant) init (5); dcl cp5_label fixed bin int static options (constant) init (6); dcl i_label bit (32) int static options (constant) init /* "VOL1" in 8 bit ebcdic (ibm stand label) */ ("E5D6D3F1"b4); dcl (v1_mult_label init (1), v3_mult_label init (2)) fixed bin int static options (constant); /* automatic storage */ dcl get_line_length fixed bin; dcl rcd_volid char (32); dcl terminate_read_sw bit (1); /* base */ dcl blab (0:15) bit (9) unaligned based (addr (rcd_volid)); /* external entry */ dcl define_area_ entry (ptr, fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); /* begin coding */ mssf = "0"b; /* initialize Multics standard system format flag */ rcd_volid = ""; unspec (ai) = "0"b; /* clear out area info */ ai.version = area_info_version_1; /* set up area info block */ ai.control.extend = "1"b; ai.control.zero_on_alloc = "1"b; ai.owner = pname; ai.size = sys_info$max_seg_size; ai.version_of_area = area_info_version_1; ai.areap = null; /* set up clean up handler */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); /* establish program_interrupt (pi) handler */ on program_interrupt goto SET_UP_EXIT; /* find terminal line length */ get_line_length = get_line_length_$switch (null, scode); if get_line_length < 118 & scode = 0 then rtq_info.short_output_flg = "1"b; /* set short output switch */ else rtq_info.short_output_flg = "0"b; /* otherwise long output */ /* get an area */ call define_area_ (addr (ai), code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Cannot define an area"); return; end; rtq_info.rtq_area_ptr = ai.areap; /* get a temporary segment for our tape buffer */ call get_temp_segment_ (pname, rtq_info.tptr, code); if code ^= 0 then do; /* can't alocate buffer */ call ssu_$print_message (sci_ptr, code, "Getting temporary tape buffer segment"); call detach_tape_file (sci_ptr, rtq_info_ptr); return; end; /* allocate intermediate buffers */ allocate cv_buf in (rtq_area); allocate cdkbuf in (rtq_area); allocate cbuf in (rtq_area); /* attach and open tape using the "tape_nstd_" io module */ TRY_AGAIN: call iox_$attach_name ("tape_sw", rtq_info.tiocb_ptr, (rtq_info.tape_atd), null, code); if code ^= 0 then do; if code = error_table_$not_detached then do; call iox_$detach_iocb (rtq_info.tiocb_ptr, code); if code ^= error_table_$not_closed then do; call ssu_$print_message (sci_ptr, code); return; end; else do; call iox_$close (rtq_info.tiocb_ptr, (0)); goto TRY_AGAIN; end; end; else do; call ssu_$print_message (sci_ptr, code, "^/ Attempting to attach tape."); call detach_tape_file (sci_ptr, rtq_info_ptr); /* go cleanup */ return; end; end; call iox_$open (rtq_info.tiocb_ptr, Sequential_input, "0"b, code); /* open for seq. input */ if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "^/Opening tape for sequential input"); call detach_tape_file (sci_ptr, rtq_info_ptr); return; end; /* set conversion buffer to max size */ rtq_info.cvbl = divide (rtq_info.buf_size * NUMB_OF_BITS_PER_BYTE, NUMB_OF_BYTES_PER_WORD, 21, 0); /* loop through the array index from 1 to 5 to find the matched density value if an user specifies a density value */ j = hbound (rtq_info.density, 1); terminate_read_sw = "0"b; do i = 1 to j while (^terminate_read_sw); call iox_$control (rtq_info.tiocb_ptr, (rtq_info.density (i)), null, scode); if scode = 0 then do; call iox_$read_record (rtq_info.tiocb_ptr, rtq_info.tptr, rtq_info.buf_size, rtq_info.rec_len, code); if code ^= error_table_$tape_error then do; /* if some other type of error, then warn users */ if (code ^= 0) & (code ^= error_table_$end_of_info) then call ssu_$print_message (sci_ptr, code, "^/Attempting to determine density of tape volume ^a", rtq_info.tape_name); terminate_read_sw = "1"b;/* set terminate condition */ end; call iox_$control (rtq_info.tiocb_ptr, "rewind", null, scode); end; /* scode = 0 */ end; /* do i = 1 to 5 */ /* use the default density if could not find the valid density; otherwise, get it */ rtq_info.tmr = terminate_read_sw; if ^rtq_info.tmr | (code ^= 0 & code ^= error_table_$end_of_info) then do; if rtq_info.ddec ^= 0 then rtq_info.c_den = "d" || ltrim (char (rtq_info.ddec)); /* if density was specified.. */ else rtq_info.c_den = rtq_info.density (1); /* otherwise use default */ /* perform a density control order on an i/o switch */ call iox_$control (rtq_info.tiocb_ptr, (rtq_info.c_den), null, scode); /* display a warning message */ call ssu_$print_message (sci_ptr, 0, "Unable to determine density of tape volume ^a.^/ Density is currently set to ^a (bpi).", rtq_info.tape_name, substr (rtq_info.c_den, 2)); code = 0; scode = 0; /* since it is not an error, so want to continue */ end; /* report the density to users and determine the tape label types */ else do; rtq_info.c_den = rtq_info.density (i - 1); /* save current density */ call ioa_ ("Tape density is ^a bpi", substr (rtq_info.density (i - 1), 2)); call determine_tape_label_types; if rtq_info.return_subsys_loop_flg then do; rtq_info.return_subsys_loop_flg = "0"b; return; end; end; SET_UP_EXIT: return; /***************************************************************************/ %page; bof_request: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt conditions. Invoke the */ /* "ssu_$arg_count" standard system subroutine. Print out an usage */ /* message if users specify any control arguments. Invoke the */ /* "process_control_order" internal procedure to the beginning of the file */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto BOF_EXIT; call ssu_$arg_count (sci_ptr, Nargs); if Nargs ^= 0 then do; call ssu_$print_message (sci_ptr, 0, "Usage: bof"); return; end; /* initialization */ scode = 0; l_cnt = 1; rf, rpt = "1"b; direction = "0"b; order = "begin_file"; /* process control order */ call process_control_order (order, rpt, direction, rf, l_cnt); BOF_EXIT: return; /***************************************************************************/ %page; bsf_request: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt handlers. Invoke the */ /* "ssu_$arg_count" standard system subroutine. Print out an usage */ /* message if users specify two or more control arguments. */ /* Process the specified control argument. Invoke the */ /* "process_control_order" internal procedure to backspace N files. */ /* The default is to backspace 1 file. */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto BSF_EXIT; /* initialization */ l_cnt = 1; scode = 0; rf, rpt = "1"b; direction = "0"b; order = "backspace_file"; /* find number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); if Nargs >= 2 then do; ERROR_BSF: call ssu_$print_message (sci_ptr, scode, "^/ Usage: bsf {n}"); return; end; /* then validate them */ do arg_dex = 1 to Nargs; call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al); l_cnt = cv_dec_check_ (arg, scode); if scode ^= 0 then goto ERROR_BSF; end; /* go process control order */ call process_control_order (order, rpt, direction, rf, l_cnt); /* must reset the flag fields of the "rtq_info" structure before returning to rtq request loop */ rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b; BSF_EXIT: return; /***************************************************************************/ %page; bsr_request: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt handlers. Invoke the */ /* "ssu_$arg_count" standard system subroutine. Print out an usage */ /* message if users specify two or more 2 control arguments. */ /* Process the specified control argument. Invoke the */ /* "process_control_order" internal procedure to backspace N records. */ /* The default is to backspace 1 record. */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto BSR_EXIT; /* initialization */ l_cnt = 1; scode = 0; rpt = "1"b; rf, direction = "0"b; order = "backspace_record"; /* find number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); if Nargs >= 2 then do; ERROR_BSR: call ssu_$print_message (sci_ptr, scode, "Usage: bsr {N}"); return; end; /* then validate them */ do arg_dex = 1 to Nargs; call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al); l_cnt = cv_dec_check_ (arg, scode); if scode ^= 0 then goto ERROR_BSR; else ; end; /* go process control order */ call process_control_order (order, rpt, direction, rf, l_cnt); BSR_EXIT: return; /***************************************************************************/ %page; density_request: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt handlers. Invoke the */ /* "ssu_$arg_count" standard system subroutine. Print out an usage */ /* message if users specify no CA or two or more control arguments. */ /* Validate the control argument which is the density. Display an usage */ /* message for the invalid density. Otherwise, invoke the */ /* "process_control_order" internal procedure to perform the specified */ /* density control order. */ dcl array_index fixed bin; dcl match bit (1) aligned; /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto DENSITY_EXIT; /* initialization */ l_cnt = 1; match = "0"b; scode = 0; rpt, rf, direction = "0"b; /* reset command flags */ /* find the number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); if Nargs = 0 | Nargs >= 2 then do; ERROR_DENSITY: call ssu_$print_message (sci_ptr, scode, "Usage: density (den) <6250 | 1600 | 800 | 556 | 200>"); return; end; /* then validate the tape density */ call ssu_$arg_ptr (sci_ptr, Nargs, ap, al); do array_index = 1 to 5 while (^match); if arg = substr (rtq_info.density (array_index), 2, 4) then match = "1"b; end; if ^match then goto ERROR_DENSITY; else do; rtq_info.ddec = cv_dec_check_ (arg, scode); if scode ^= 0 then goto ERROR_DENSITY; else rtq_info.c_den, order = "d" || ltrim (char (rtq_info.ddec)); end; /* go process control order */ call process_control_order (order, rpt, direction, rf, l_cnt); DENSITY_EXIT: return; /***************************************************************************/ %page; dot_request: entry (sci_ptr, rtq_info_ptr); /* displays the request name read_tape_and_query with its short name, rtq, */ /* in parentheses. */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto RETURNS_TO_SUBSYS; /* find number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); if Nargs ^= 0 then do; call ssu_$print_message (sci_ptr, 0, "No argument is allowed for this request."); return; end; /* response to user's request */ call ioa_ ("read_tape_and_query (rtq): Reading tape volume ""^a"" in ""^a"" mode.^/ Currently positioned to Physical file ^d, record ^d.", rtq_info.tape_name, mode (rtq_info.c_mode), rtq_info.c_file, rtq_info.c_rec); RETURNS_TO_SUBSYS: return; /***************************************************************************/ %page; dump_record_request: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt handlers. Initialize */ /* intermediate variables. Get optional control arguments and process */ /* them by invoking the "set_dump_fmt" internal procedure. */ /* Dump the tape record in the requested format by invoking the */ /* "dump_segment_" standard system subroutine. */ /* external entry */ dcl dump_segment_ entry (ptr, ptr, fixed bin, fixed bin (35), fixed bin (35), bit (*)); /* automatic storage */ dcl NUMB_OF_BITS_PER_CHAR fixed bin static options (constant) init (9); dcl NUMB_OF_BITS_PER_WORD fixed bin static options (constant) init (36); dcl doffset fixed bin; /* dump off set */ dcl dump_index fixed bin; dcl format (4) bit (11); dcl n_words_specified_flg bit (1) aligned; dcl ndumps fixed bin; /* number of dumps */ dcl offset_specified_flg bit (1) aligned; /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto WANTS_TO_EXIT; /* validate data */ if ^rtq_info.buf_ful then do; /* we don't have any data yet */ call ssu_$print_message (sci_ptr, 0, "Record buffer empty"); return; end; /* set up for dump request */ scode = 0; ndumps = 1; /* set defaults first (entire buffer in octal format) */ doffset = 0; format (1) = "01000000000"b; nwds = divide (rtq_info.rec_len * NUMB_OF_BITS_PER_CHAR + 35, NUMB_OF_BITS_PER_WORD, 35, 0); offset_specified_flg, n_words_specified_flg = "0"b; /* find number of arguments */ call ssu_$arg_count (sci_ptr, Nargs); /* then validate them */ do arg_dex = 1 to Nargs; /* user specifies some input args */ call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);/* process each argument */ if substr (arg, 1, 1) ^= "-" then do; /* some number spec */ if ^offset_specified_flg then do; /* offset spec must be first */ offset_specified_flg = "1"b; /* set switch so we don't come back */ doffset = cv_oct_check_ (arg, scode); /* convert ascii to oct */ if scode ^= 0 then do; ERROR_DUMP: call ssu_$print_message (sci_ptr, scode, "^/ Usage: dump {offset (oct)} {n_words (oct)} {-bcd} {-ascii} {-ebcdic} {-hex}"); return; end; nwds = nwds - doffset; /* correct number of words to dump */ end; /* if ^offset_specified_flg then do */ else if ^n_words_specified_flg then do; /* user wants to specify number of words */ n_words_specified_flg = "1"b; /* set switch so we won't be back */ nwds = cv_oct_check_ (arg, scode); if scode ^= 0 then goto ERROR_DUMP; /* tell user what to do, he goofed */ end; /* else if ^n_words_specified_flg */ else goto ERROR_DUMP; /* ditto */ end; /* if substr (arg, 1, 1) ^= "-" */ else if arg = "-bcd" then /* requesting bcd dump */ call set_dump_fmt ("01010000000"b); else if arg = "-ascii" then /* user requesting ascii dump */ call set_dump_fmt ("01001000000"b); else if arg = "-ebcdic" then do; /* user wants ebcdic dump */ if rtq_info.c_mode = 3 then /* if in 9 bit mode */ call set_dump_fmt ("01000010000"b); else call set_dump_fmt ("01000001000"b); /* else 8 bit mode */ end; else if arg = "-hex" then do; /* user wants hex dump */ if rtq_info.c_mode = 3 then /* if in 9 bit mode */ call set_dump_fmt ("01000000001"b); else call set_dump_fmt ("01000000010"b); /* else 8 bit mode */ end; else goto ERROR_DUMP; /* user goofed tell him how to use dump request */ end; /* do arg_dex = 1 to Nargs */ if ndumps > 1 then ndumps = ndumps - 1; /* correct number of dumps */ do dump_index = 1 to ndumps; /* dump requested number of formats */ call ioa_ (" "); call dump_segment_ (iox_$user_output, addrel (rtq_info.tptr, doffset), 0, 0, nwds, format (dump_index)); end; WANTS_TO_EXIT: return; set_dump_fmt: proc (fmt); /* sets dump type */ dcl fmt bit (11); /* begin coding */ format (ndumps) = fmt; /* set desired format */ ndumps = ndumps + 1; /* increment number of dumps to do */ if ndumps > (hbound (format, 1) + 1) then /* user wants to many */ goto ERROR_DUMP; /* tell him what he can do */ end set_dump_fmt; /***************************************************************************/ %page; eof_request: entry (sci_ptr, rtq_info_ptr); /* positions to the end of the current physical tape file, after the last */ /* record. Establish cleanup and program_interrupt handlers. No */ /* optional control arguments are allowed. Perform "forward_record" */ /* control orders until end of file encountered. Note that the current */ /* record is incremented by one until end of file reached. */ /* Then perform "backspace_record" order to position before end of file */ /* mark since the last forward record order positioned the tape after end */ /* of file mark. Report to users after the request is successfully done. */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto SUBSYSTEM_RETURNED; /* display an error message if any optional control argument is specified */ call ssu_$arg_count (sci_ptr, Nargs); if Nargs ^= 0 then do; call ssu_$print_message (sci_ptr, 0, "Usage: eof"); return; end; /* initialization */ rtq_info.eof_request_flg = "1"b; scode = 0; order = "forward_record"; rpt = "1"b; direction = "1"b; rf = "0"b; l_cnt = 1; /* perform several "forward_record" orders until end of current file reached */ do while (scode ^= error_table_$end_of_info); call process_control_order (order, rpt, direction, rf, l_cnt); if scode = 0 then rtq_info.c_rec = rtq_info.c_rec + 1; /* to find the last record in the current file */ if scode = error_table_$tape_error then do; /* exit loop if tape error occured */ call ssu_$print_message (sci_ptr, scode, "Attempting to perform ""forward_record"" order"); rtq_info.eof_request_flg = "0"b; return; end; end; /* perform the "backspace_record" control order to position to the end of the current file */ direction = "0"b; /* must reset intermediate variables */ rpt = "0"b; rf = "0"b; l_cnt = 1; order = "backspace_record"; call process_control_order (order, rpt, direction, rf, l_cnt); /* report to users after the "eof" request is successfully done */ if rtq_info.c_rec = 1 then /* case of an empty file or a file has no data record */ call ssu_$print_message (sci_ptr, 0, "Positioned the tape to the beginning of the current file # ^d which has no data record.", rtq_info.c_file); /* case of a file contains 1 data record or more */ else call ssu_$print_message (sci_ptr, 0, "Positioned the tape to the end of the current file # ^d, after the last record # ^d.", rtq_info.c_file, rtq_info.c_rec - 1); rtq_info.one_eof = "0"b; /* must reset these flags before returning to rtq request loop */ rtq_info.eof_request_flg = "0"b; SUBSYSTEM_RETURNED: return; /****************************************************************************/ %page; fsf_request: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt handlers. Invoke the */ /* "ssu_$arg_count" standard system subroutine. Print out an usage */ /* message if users specify at least 2 control arguments. */ /* Process the specified control argument. Invoke the */ /* "process_control_order" internal procedure to forward space N files. */ /* The default is to forward space 1 file. */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto RETURNS_TO_REQUEST_LOOP; /* initialization */ scode = 0; l_cnt = 1; direction, rpt, rf = "1"b; order = "forward_file"; /* find number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); if Nargs >= 2 then do; ERROR_FSF: call ssu_$print_message (sci_ptr, scode, "Usage: fsf {N}"); return; end; /* then validate them */ do arg_dex = 1 to Nargs; call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al); l_cnt = cv_dec_check_ (arg, scode); if scode ^= 0 then goto ERROR_FSF; else ; end; /* go process control order */ call process_control_order (order, rpt, direction, rf, l_cnt); RETURNS_TO_REQUEST_LOOP: return; /*****************************************************************************/ %page; fsr_request: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt handlers. Invoke the */ /* "ssu_$arg_count" standard system subroutine. Print out an usage */ /* message if users specify more than one control arguments. */ /* Process the specified control argument. Invoke the */ /* "process_control_order" internal procedure to forward space N record. */ /* The default is to forward space 1 record. */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); /* set up clean up handler */ on program_interrupt goto FSR_RETURN; /* initialization */ scode = 0; l_cnt = 1; direction, rpt = "1"b; rf = "0"b; order = "forward_record"; /* find number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); if Nargs >= 2 then do; ERROR_FSR: call ssu_$print_message (sci_ptr, scode, "Usage: fsr {N}"); return; end; /* then validate them */ do arg_dex = 1 to Nargs; call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al); l_cnt = cv_dec_check_ (arg, scode); if scode ^= 0 then goto ERROR_FSR; else ; end; /* go process control order */ call process_control_order (order, rpt, direction, rf, l_cnt); FSR_RETURN: return; /*****************************************************************************/ %page; list_tape_contents: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt handlers. Initialize both */ /* intermediate global and local variables. Find terminal line length. */ /* Get optional control arguments and process them. Position tape to the */ /* beginning of tape if not already there. If the tape type is either */ /* MULTICS or GCOS tape then set mode to binary mode. Set to nine mode for */ /* IBM or ANSI tape. Report the mode to users. Read in each tape record in */ /* the tape until end of tape is encountered: this can be done by invoking */ /* the "read_tape_record" internal procedure. Set up nessary things if */ /* want to return to subsystem request loop. If not end of file then if */ /* this is the first record of the file then report the current file read to */ /* users. Determine the record type. If the record read is not a label */ /* record then if the record read is the first record of the file then */ /* assign the number of bits to last record length, reset the number of */ /* records to zero, and increment logical file number by one. Report to */ /* users if tape type is a label tape or Multics tape. If the number of */ /* bits of the record read is the same as the last record length then */ /* increment the number of record by one. Otherwise, report to users. */ /* If the record read is a nonlabel record then assign zero to the last */ /* record length. If end of file is encountered then report to user, reset */ /* record number and logical file flag and set up appropriate mode for the */ /* next file to be read. When end of tape is encountered, perform the */ /* "rewind" control order to the beginning of tape and then report to users. */ dcl logical_file_num fixed bin; dcl label_flg bit (1) aligned; dcl last_length fixed bin; dcl logical_file_flg bit (1) aligned; dcl long_list_flg bit (1) aligned; dcl nrecords fixed bin (35); dcl unlabeled fixed bin int static options (constant) init (0); /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto SUBSYSTEM_REQUEST_LOOP; /* clear global switches */ scode = 0; mssf = "0"b; iterations = 1; /* set default iterations to 1 */ rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.set_bin, rtq_info.set_nine, rtq_info.two_eofs = "0"b; /* initialize local flags and variables */ long_list_flg, label_flg, logical_file_flg = "0"b; logical_file_num, last_length, nrecords = 0; /* find number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); /* process optional control arguments */ do arg_dex = 1 to Nargs; call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);/* process them */ if arg = "-long" | arg = "-lg" then long_list_flg = "1"b; /* user wants long list */ else if arg = "-label" | arg = "-lbl" then if rtq_info.l_type = unlabeled then do; /* illegal on unlabeled tapes */ call ssu_$print_message (sci_ptr, 0, """-label"" argument not allowed on unlabeled tapes"); return; end; else label_flg = "1"b; /* user only wants label rcds */ else do; call ssu_$print_message (sci_ptr, 0, "Usage: list_tape_contents (ltc) {-long (-lg)} {-label (-lbl)}"); return; end; end; /* do arg_dex = 1 to Nargs */ /* position to bot if not already there */ if rtq_info.c_rec ^= 1 | rtq_info.c_file ^= 1 then call process_control_order ("rewind", "0"b, "0"b, "0"b, 1); else ; /* for Multics or Gcos tape, set to binary mode */ if rtq_info.l_type > 0 & rtq_info.l_type <= 3 then call check_mode (BINARY_MODE); /* for IBM or ANSI tape, set to nine mode */ else if rtq_info.l_type > 3 then call check_mode (NINE_MODE); /* report to users */ call ioa_ ("Listing tape contents of tape volume ^a in ^a mode.^/ Starting at BOT (physical file# 1, record# 1)^/ ", rtq_info.tape_name, mode (rtq_info.c_mode)); /* read until the end of tape is encountered */ do while (^rtq_info.two_eofs); call read_tape_record ("skip", rtq_info.eof, "1"b, mssf); /* read next record */ if rtq_info.return_subsys_loop_flg then do; rtq_info.return_subsys_loop_flg = "0"b; revert cleanup; call ssu_$abort_line (sci_ptr); end; if ^rtq_info.eof then do; /* if not end of file */ if rtq_info.c_rec = 2 then /* if first record of this file */ call ioa_ ("Physical tape file # ^d.", rtq_info.c_file); if ^valid_label_record (long_list_flg) then do; /* and not label record */ if rtq_info.c_rec = 2 then do; /* if this is first record of file */ last_length = rtq_info.bits; /* set for equal record processing */ nrecords = 0; logical_file_num = logical_file_num + 1; /* increment logical file number */ if rtq_info.l_type > 1 then do; /* if not unlabeled or Multics tape */ call ioa_ ("Logical tape file # ^d.^[^/ ^]", logical_file_num, ^label_flg); logical_file_flg = "1"b; end; else call ioa_ (" "); /* otherwise just write blank line */ end; /* first record of the file */ if last_length = rtq_info.bits then /* this record length is the same as the last record length */ nrecords = nrecords + 1; /* just tally it */ else do; /* otherwise, display a message */ if nrecords = 0 then nrecords = 1; /* set up for at least 1 record */ if ^label_flg then call record_information (nrecords, (last_length), "1"b); last_length = rtq_info.bits; /* restart tally */ nrecords = 0; end; /* the current record length is different from the last record length */ end; /* if ^valid_label_record (long_list_flg) */ else last_length = 0; /* a label record */ end; /* if ^eof */ else do; /* tape end of file */ if last_length > 0 & ^rtq_info.two_eofs then do; /* only display valid records */ if nrecords = 0 then nrecords = 1; /* set up for at least 1 record */ if ^label_flg then call record_information (nrecords, (last_length), "1"b); end; call ioa_ ("End of physical tape file # ^d, ^[(^a # ^d),^[^/ ^; ^]^;^3s^]^a: ^d.^/ ", rtq_info.c_file - 1, logical_file_flg, "logical tape file", logical_file_num, rtq_info.short_output_flg, "total records read", rtq_info.c_rec - 1); logical_file_flg = "0"b; rtq_info.c_rec = 1; /* reset record number */ if rtq_info.set_bin & ^label_flg then do; /* if we need to switch next file to bin mode */ call check_mode (BINARY_MODE); call ioa_ (" "); /* write blank line */ rtq_info.set_bin = "0"b; /* reset switch */ end; else if rtq_info.set_nine & ^label_flg then do; /* switch back to nine mode */ call check_mode (NINE_MODE); call ioa_ (" "); /* write blank line */ rtq_info.set_nine = "0"b;/* reset switch */ end; /* else if */ end; /* eof */ end; /* do while (^two_eofs) */ /* position to beginning of tape (bot) */ call process_control_order ("rewind", "0"b, "0"b, "0"b, 1); /* report to users */ call ioa_ ("Logical end of tape, positioning to BOT"); SUBSYSTEM_REQUEST_LOOP: return; /*****************************************************************************/ %page; mode_request: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt handlers. Get and process the */ /* optional control argument. Perform the specified mode control order by */ /* invoking the "process_control_order" internal procedure. Note that if */ /* control argument is given then set "binary" mode as the defaulf mode. */ dcl mode_dex fixed bin; /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto WANTS_TO_RETURN; /* initialization */ scode = 0; l_cnt = 1; /* 1 iteration default */ rpt, rf, direction = "0"b; /* reset command flags */ /* find number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); if Nargs >= 2 then do; ERROR_MODE: call ssu_$print_message (sci_ptr, 0, "Usage: mode "); return; end; /* then validate them */ if Nargs = 0 then do; order = "binary"; /* default mode */ rtq_info.c_mode = 1; /* subscript of "bin" mode value */ end; else ; do arg_dex = 1 to Nargs; call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al); if arg = "bcd" | arg = "bin" | arg = "nine" then do; do mode_dex = 1 to 3; /* try to find the right mode */ if substr (arg, 1, 3) = substr (mode (mode_dex), 1, 3) then rtq_info.c_mode = mode_dex; else ; end; order = mode (rtq_info.c_mode); end; else goto ERROR_MODE; end; /* go process control order */ call process_control_order (order, rpt, direction, rf, l_cnt); WANTS_TO_RETURN: return; /***************************************************************************/ %page; position_request: entry (sci_ptr, rtq_info_ptr); /* The rtq "position" request displays the current physical tape file and */ /* record position to the user. */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto SUBSYS_QUERY; /* find number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); if Nargs ^= 0 then do; call ssu_$print_message (sci_ptr, 0, "No argument is allowed for this request."); return; end; /* response to user's request */ call ssu_$print_message (sci_ptr, 0, "Reading tape volume ""^a"" in ""^a"" mode.^/Currently positioned to physical file ^d, record ^d.", rtq_info.tape_name, mode (rtq_info.c_mode), rtq_info.c_file, rtq_info.c_rec); SUBSYS_QUERY: return; /*****************************************************************************/ %page; quit_request: entry (sci_ptr, rtq_info_ptr); /* returns to the command line */ call ssu_$abort_subsystem (sci_ptr, 0); return; /*****************************************************************************/ %page; read_file_request: entry (sci_ptr, rtq_info_ptr); /* reads the current tape file into the segment described by the optional */ /* control argument: Initialize intermediate global and local variables. */ /* Detach the file if already attached. Get and process optional control */ /* arguments. Check for argument inconsistencies. Perform the */ /* "begin_file" control order to position to the beginning of the file if */ /* not already there. Do 1 to multilple files if was asked while not end of */ /* tape mark. Note that read in one file (by default). Report the */ /* current file which will be read in to the user. Set the open mode to the */ /* default mode. If the user wants output attach description then query the */ /* user for it by invoking the "get_output_descript_and_attach" internal */ /* procedure. Invoke the " read_in_the_entire_file" internal procedure */ /* to read in the entire current file. Check essential flags. If we have */ /* written file already then increment file name by one, expand this file */ /* name and reset the written file switch. Read in the next file and do */ /* the same operations until end of tape mark is encountered. Finally, */ /* invoke the "detach_file_if_attached" internal procedure if the "-extend" */ /* is specified to detach the file if already attached. Return to the */ /* subsystem request. */ dcl conversion_flg bit (1) aligned; /* begin coding */ conversion_flg, first_record_flg, last_record_flg = "0"b; /* set up cleanup handler and program_interrupt (pi) command */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto RETURN; rtq_info.return_subsys_loop_flg = "0"b; /* make the read_record request happy */ /* the following flgs of "rtq_info" structure must reset so that if users already deleted some data record */ /* in specified files then his can read them back beyond the tape mark */ rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b; rtq_info.atd_sw, rtq_info.extend_sw, rtq_info.fw_file, rtq_info.last_job_deck_flg, rtq_info.set_bin = "0"b; rtq_info.filename = ""; /* find number of arguments */ call ssu_$arg_count (sci_ptr, Nargs); /* set up for processing input arguments */ scode = 0; iterations = 1; /* set default iteration set to 1 */ s_filename = ""; prptr, lrp = rtq_info.tptr; /* set equivilent pointers */ n_ops, schar = 0; cont, trunc_sw, cp5, ibmv, ansid, dec_sw, gssf, mssf, nnl_sw, l_rec, c_e_a, c_b_a, c_c_a, imcv = "0"b; /* just in case we had a file attached */ call detach_file_if_attached; /* process optional control arguments */ call read_file_get_control_args; if scode ^= 0 | rtq_info.return_subsys_loop_flg then goto SUBSYSTEM_LOOP_RETURN; /* check for argument inconsistancies */ if (n_ops > 1) & ^(l_rec & (c_e_a | c_b_a | c_c_a)) then do; call ssu_$print_message (sci_ptr, 0, "Inconsistent combination of optional control arguments."); return; end; /* position to the beginning of the tape file */ if rtq_info.c_rec > 1 then call process_control_order ("begin_file", "1"b, "0"b, "1"b, 1); /* read multiple files if required */ do nunits = 1 to iterations while (^rtq_info.two_eofs); call ioa_ ("Reading tape file # ^d in ^a mode", rtq_info.c_file, mode (rtq_info.c_mode)); open_mode = Stream_output; /* set open mode to default mode */ /* if users want output attach description then ask for it */ if (rtq_info.atd_sw & rtq_info.fw_file) | (rtq_info.atd_sw & nunits = 1) then do; call get_output_descript_and_attach; if rtq_info.return_subsys_loop_flg then goto SUBSYSTEM_LOOP_RETURN; end; /* read in the entire tape file */ call read_in_the_entire_file; if conversion_flg then return; if rtq_info.return_subsys_loop_flg then do; SUBSYSTEM_LOOP_RETURN: rtq_info.return_subsys_loop_flg = "0"b; return; end; /* if we have written file already */ if rtq_info.fw_file & ^rtq_info.extend_sw then do; if s_filename = "" then s_filename = rtq_info.filename; /* save filename on first iteration */ rtq_info.filename = rtrim (s_filename) || "." || ltrim (char (nunits + 1)); /* increment file name */ if ^valid_pathname ((rtq_info.filename), "") then do; call ssu_$print_message (sci_ptr, scode, "^/ Expanding pathname for file name ""^a""", rtq_info.filename); return; end; rtq_info.fw_file = "0"b; /* reset switch */ end; /* if fw_file & ^extend_sw */ end; /* do nunits = 1 to iterations while (^two_eofs) */ /* if this is end, detach it */ if rtq_info.extend_sw then call detach_file_if_attached; /* just in case we had a file attached */ RETURN: return; /***************************************************************************/ %page; read_record_request: entry (sci_ptr, rtq_info_ptr); /* reads the current record into a temporary buffer. */ /* Establish cleanup and program_interrupt handlers. Initialize */ /* intermediate global and local variables. Find the terminal line */ /* length. Get and process optional control arguments. */ /* Do 1 to N records while not end of tape mark . */ /* Report the current record of the file to user before reading it in. */ /* Invoke the "read_tape_record" internal procedure to read in the tape */ /* record. If not end of file then report information of each record read */ /* to user. Read in the next record and do the same operations until */ /* end of tape mark is encountered. Return to the subsystem request. */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto SUBSYS_REQUEST_LOOP; rtq_info.return_subsys_loop_flg = "0"b; /* make the read_record request happy */ /* the following flgs of "rtq_info" structure must be reset so that if users already deleted some data record */ /* from specified files then he can read them back beyond the tape mark */ rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b; /* initialize global variables */ scode = 0; /* must initialize scode value */ mssf = "0"b; /* reset Multics standard system format flag */ iterations = 1; /* set default iteration set to 1 */ /* find number of input arguments */ call ssu_$arg_count (sci_ptr, Nargs); /* then process them */ do arg_dex = 1 to Nargs; call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al); if arg = "-count" | arg = "-ct" then do; /* user wants to read mutiple rcds */ if arg_dex < Nargs then do; arg_dex = arg_dex + 1; call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al); iterations = cv_dec_check_ (arg, scode); /* check for rdrec iterations */ if scode ^= 0 then goto ERROR_RDREC; end; else goto ERROR_RDREC; /* missing N for -count */ end; /* -count (-cnt) */ else do; /* no other control arg allowed */ ERROR_RDREC: call ssu_$print_message (sci_ptr, scode, "^/ Usage: read_record (rdrec) {-count (-ct) N}"); return; end; end; /* do arg_dex = 1 to Nargs */ do nunits = 1 to iterations while (^rtq_info.two_eofs); call ssu_$print_message (sci_ptr, 0, "Reading record ^d, File ^d in ^a mode", rtq_info.c_rec, rtq_info.c_file, mode (rtq_info.c_mode)); call read_tape_record ("stop", rtq_info.eof, "0"b, mssf); /* go read tape record */ if rtq_info.return_subsys_loop_flg then do; rtq_info.return_subsys_loop_flg = "0"b; return; end; if ^rtq_info.eof then call record_information (1, rtq_info.bits, "0"b); /* display record length info */ end; /* do nunits = 1 to iterations while (^two_eofs) */ SUBSYS_REQUEST_LOOP: return; /***************************************************************************/ %page; records_in_file_request: entry (sci_ptr, rtq_info_ptr); /* is a request which will report to users the number of records in the */ /* current file. Establish cleanup and program_interrupt handlers. */ /* Report to users if any optional control argument is specified. */ /* Set up for reading records in the current file. Read them in until */ /* end of file encountered. Report the total records counted and the tape */ /* position to users. Invoke the "process_control_order" existing */ /* internal procedure to backspace to the original tape position. Reset */ /* the "one_eof" and "records_in_file_flg" flag fields of the "rtq_info" */ /* structure before returning to the rtq request loop. */ dcl end_file_flg bit (1) aligned; dcl numb_of_recs_to_be_backspaced fixed bin; dcl save_current_record fixed bin; dcl save_current_file fixed bin; /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto RETURNED; call ssu_$arg_count (sci_ptr, Nargs); if Nargs ^= 0 then do; call ssu_$print_message (sci_ptr, 0, "Usage: records_in_file, rif"); return; end; /* set up for reading records of the current file */ rtq_info.eov, rtq_info.two_eofs, rtq_info.one_eof = "0"b; /* must reset in case they were previously set */ scode = 0; rtq_info.records_in_file_flg = "1"b; rtq_info.return_subsys_loop_flg = "0"b; /* make the records_in_file request happy */ save_current_record = rtq_info.c_rec; save_current_file = rtq_info.c_file; end_file_flg = "0"b; mssf = "0"b; /* read in each record in the current file until end of file encountered */ do while (^end_file_flg); call read_tape_record ("skip", end_file_flg, "1"b, mssf); end; /* report the number of records counted in the current file */ call ioa_ ("The current file # ^d contains ^d record^[s^]." || "^/Repositioned the tape to its original position: record # ^d, file # ^d.", save_current_file, rtq_info.c_rec - 1, (rtq_info.c_rec > 1), save_current_record, save_current_file); rtq_info.c_file = rtq_info.c_file - 1; /* the actual current file number */ /* perform the "backspace_record" control order to its original position */ order = "backspace_record"; rpt = "1"b; direction = "0"b; rf = "0"b; numb_of_recs_to_be_backspaced = rtq_info.c_rec - save_current_record; /* case of file containing no data record */ if numb_of_recs_to_be_backspaced = 0 then call iox_$control (rtq_info.tiocb_ptr, order, null, (0)); /* case of a file containing 1 data record or more */ else call process_control_order (order, rpt, direction, rf, (numb_of_recs_to_be_backspaced)); rtq_info.one_eof = "0"b; /* reset after the tape is repositioned to its original position */ rtq_info.records_in_file_flg = "0"b; /* reset this flg after the request is done. */ RETURNED: return; /***************************************************************************/ %page; rewind_request: entry (sci_ptr, rtq_info_ptr); /* Establish cleanup and program_interrupt handlers. Display an usage */ /* message if any control argument is given. Perform the "rewind" control */ /* order by invoking the "process_control_order" internal procedure. */ /* Return to the subsystem request loop. */ /* begin coding */ on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); on program_interrupt goto PI_RETURN; call ssu_$arg_count (sci_ptr, Nargs); if Nargs ^= 0 then do; call ssu_$print_message (sci_ptr, 0, "Usage: rewind (rew)"); return; end; /* initialization */ scode = 0; l_cnt = 1; /* 1 iteration default */ rpt, rf, direction = "0"b; /* reset command flags */ order = "rewind"; call process_control_order (order, rpt, direction, rf, l_cnt); /* go process control order */ /* must reset the following flags if they were previously set */ rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b; PI_RETURN: return; /****************************************************************************/ %page; ANSI_DB_records: proc (conversion_flg); /* process each ANSI DB record of the input tape file for the "rdfile" request */ dcl conversion_flg bit (*) aligned; /* begin coding */ nchars = 0; rtq_info.rptr = rtq_info.tptr; /* set first log record ptr */ on conversion begin; call ssu_$print_message (sci_ptr, 0, "Conversion condition detected attempting to convert ANSI log rec len (""^a"") to binary", ansi_db_lrec.lrl); conversion_flg = "1"b; goto BACK_TO_RTQ_REQUEST_LOOP; /* return to rtq subsystem request loop */ end; do while (nchars < rtq_info.rec_len - 3); /* process entire block */ l_rec_len = bin (ansi_db_lrec.lrl) - NUMB_OF_CHARS_PER_WORD; /* compute logical record size */ if l_rec_len = 0 then do; /* if null record, write empty line */ call write_file (addr (NL), 1, s_filename); if rtq_info.return_subsys_loop_flg then return; end; else do; /* record contains data */ if c_e_a then /* if ebcdic record */ call ebcdic_to_ascii_ (ansi_db_lrec.alrd, rtq_info.cbufp -> cbuf); else rtq_info.cbufp -> cbuf = ansi_db_lrec.alrd; /* otherwise, copy it */ trim_trailing_blanks_log_rec_len = length (rtrim (rtq_info.cbufp -> cbuf)); if ^nnl_sw then do; /* add New Line character to each record */ trim_trailing_blanks_log_rec_len = trim_trailing_blanks_log_rec_len + 1; substr (rtq_info.cbufp -> cbuf, trim_trailing_blanks_log_rec_len, 1) = NL; end; call write_file (rtq_info.cbufp, trim_trailing_blanks_log_rec_len, s_filename); /* write out log record */ if rtq_info.return_subsys_loop_flg then return; end; /* record contains data */ rtq_info.rptr = addr (ansi_db_lrec.nxt_lrec); nchars = nchars + l_rec_len + NUMB_OF_CHARS_PER_WORD; /* increment total # of chars */ end; /* do while ... */ BACK_TO_RTQ_REQUEST_LOOP: return; end ANSI_DB_records; /****************************************************************************/ %page; CP5_variable_length_records: proc (); /* process each logical record of the input tape file in the CP5 standard */ /* system format for the read_file request. */ /* begin coding */ rtq_info.rptr = addr (cp5_phy_rec.first); /* get ptr to first record */ do i = 1 to cp5_phy_rec.nky; call ebcdic_to_ascii_ (cp5_log_rec.cp5_log_rec_data, rtq_info.cbufp -> cbuf); substr (rtq_info.cbufp -> cbuf, cp5_log_rec.rlen + 1, 1) = NL; /* add new line char to end */ call write_file (rtq_info.cbufp, cp5_log_rec.rlen + 1, s_filename); /* write out this logical record */ if rtq_info.return_subsys_loop_flg then return; rtq_info.rptr = addrel (rtq_info.rptr, currentsize (cp5_log_rec)); /* go to next one */ end; return; end CP5_variable_length_records; /****************************************************************************/ %page; DEC_tape_records: proc (); /* process each record of the input tape file in DEC standard system format */ /* for the read_file request. */ dcl DEC_40_bits_per_word fixed bin static options (constant) init (40); /* convert DEC to MULTICS standard words */ it_cnt = divide (rtq_info.bits, DEC_40_bits_per_word, 17, 0); /* get number of 40 bit words */ do i = 1 to it_cnt; /* each record is 512 40 bit words */ dec_mult (i).first_32 = dec_tape_raw.ps_wd (i).first_32; /* copy 1st 32 bits */ dec_mult (i).last_4 = dec_tape_raw.ps_wd (i).last_4; /* copy last 4 bits */ end; call write_file (lrp, it_cnt * 4, s_filename); /* write out this record */ return; end DEC_tape_records; /****************************************************************************/ %page; IBM_VB_records: proc (); /* process each IBM VB_formated variable_length record of the input tape */ /* file for the "rdfile" request. */ /* begin coding */ nchars = 0; blocksize = bin (bdw.msl || bdw.lsl) - NUMB_OF_CHARS_PER_WORD; rtq_info.rptr = addr (ibm_phy_rec.iprd); /* set first logical record ptr */ do while (nchars < blocksize); /* process entire block */ l_rec_len = bin (rdw.msl || rdw.lsl) - NUMB_OF_CHARS_PER_WORD; /* compute logical record size */ if c_e_a then /* if ebcdic record */ call ebcdic_to_ascii_ (ibm_log_rec.ilrd, rtq_info.cbufp -> cbuf); else rtq_info.cbufp -> cbuf = ibm_log_rec.ilrd; /* otherwise, copy it */ trim_trailing_blanks_log_rec_len = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rtq_info.rec_len))); if ^nnl_sw then do; /* add new line character to each record */ trim_trailing_blanks_log_rec_len = trim_trailing_blanks_log_rec_len + 1; substr (rtq_info.cbufp -> cbuf, trim_trailing_blanks_log_rec_len, 1) = NL; end; call write_file (rtq_info.cbufp, trim_trailing_blanks_log_rec_len, s_filename); /* write out log record */ if rtq_info.return_subsys_loop_flg then return; rtq_info.rptr = addr (ibm_log_rec.nxt_lrec); nchars = nchars + l_rec_len + NUMB_OF_CHARS_PER_WORD; /* increment total # of chars */ end; return; end IBM_VB_records; /****************************************************************************/ %page; GCOS_ssf: proc (cont, imcv, nchars, binck, first_record_flg, s_filename); /* process GCOS standard system format records. */ dcl binck bit (1) aligned; dcl card_cnt fixed bin; dcl cont bit (1) aligned; dcl dkend_card bit (1) aligned; dcl eoc bit (1) aligned; dcl (fc, fl) bit (1) aligned; dcl first_record_flg bit (1) aligned; dcl gcos_trans (9) char (6) static options (constant) init ("gmap ", "355map", "355sim", "algol ", "forta ", "forty ", "cobol ", "cob68 ", "jovial"); dcl imcv bit (1) aligned; dcl nchars fixed bin (21); /* will reference in get_file_name procedure */ dcl obj_card bit (1) aligned; dcl p_arg char (168) varying init (""); dcl s_filename char (32) var; /* save for calling write_file procedure */ /* based */ dcl 1 comdk aligned based (rtq_info.cdptr), /* structure of a comdeck card */ ( 2 type bit (12), /* bin card type, "5005"b3 for comdeck */ 2 bin_seq bit (24), /* binary sequence number */ 2 ckeck_sum bit (36), /* check sum word */ 2 data bit (21 * 36), /* 21 data words */ 2 h_seq (4) bit (12), /* holorith seq number */ 2 pad bit (12)) unaligned; dcl 1 com_fld unaligned based (rtq_info.cfptr), /* template for compression */ 2 f_len bit (6), /* field length */ 2 s_len bit (6), /* string length */ 2 bcd_str bit (fixed (com_fld.s_len, 6) * 6), /* bcd char string */ 2 nxt bit (6), /* field or card fence */ 2 nxt_fld bit (6); /* to get to next field */ /* begin coding */ if ^first_record_flg then do; /* if first record of file */ bcnt = gc_phy_rec.bcw.bsn; /* load block serial number */ first_record_flg = "1"b; end; else do; /* if not first record, check block serial number */ bcnt = bcnt + 1; /* increment our block count */ if gc_phy_rec.bcw.bsn ^= bcnt then do; /* something wrong here */ call ssu_$print_message (sci_ptr, 0, "Block serial number error; BSN was ^d, S/B ^d", gc_phy_rec.bcw.bsn, bcnt); YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop? Answer ""yes"" or ""no"".", "Stop?"); if YES_FLG then do; /* users want to stop */ call detach_file_if_attached; /* just in case we had a file attached */ rtq_info.return_subsys_loop_flg = "1"b; /* users want to return to subsystem request loop */ return; end; else bcnt = gc_phy_rec.bcw.bsn; /* reset block number */ end; /* something wrong */ end; /* not first record */ if gc_phy_rec.bcw.blk_size > rtq_info.wd_buf_size then do; /* is our buffer big enough? */ call ssu_$print_message (sci_ptr, 0, "Phyical record size (^d) is larger than buffer size (^d)", gc_phy_rec.bcw.blk_size, rtq_info.wd_buf_size); YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop? Answer ""yes"" or ""no"".", "Stop?"); if YES_FLG then do; /* users want to stop */ call detach_file_if_attached; /* just in case we had a file attached */ rtq_info.return_subsys_loop_flg = "1"b; /* users want to return to subsystem request loop */ return; end; end; /* our buffer is big enough */ lrptr = addr (gc_phy_rec.gc_phy_rec_data (1)); /* get pointer to first logical record */ nwds = 0; /* initialize number of words */ card_cnt = 1; /* set initial card count for this block */ obj_card, dkend_card = "0"b; /* clear bin card indicators */ do while (nwds < gc_phy_rec.bcw.blk_size); /* iterate through all logical records */ if ^cont then rtq_info.cbufp -> cbuf = ""; go to media_type (rcw.media_code); /* take appropriate action */ %page; /* media code 1 is binary card image */ media_type (1): /* Binary card image */ rtq_info.cdptr = addr (gc_log_rec.gc_log_rec_data); /* set ptr to data */ if comdk.type = "5005"b3 then do; /* compressed deck? */ rtq_info.cfptr = addr (comdk.data);/* lets decompress it */ fc = "0"b; /* reset terminate condition */ do while (^fc); /* go through entire card */ if ^cont then do; /* not continuing from last card */ nchars = 1; /* set line position to 1 */ rtq_info.cbufp -> cbuf = ""; /* add blanks to line buffer */ end; fl = "0"b; do while (^fl & ^fc); /* decompress each line */ i = fixed (f_len, 6); /* get field length */ j = fixed (s_len, 6); /* get string length */ if f_len = "77"b3 then do; /* end of line */ cont = "0"b; /* reset continue */ fl = "1"b; rtq_info.cfptr = addr (com_fld.s_len); /* skip over it */ end; /* end of line */ else if i < j | (i = 0 & j = 0) then do; /* end of card */ eoc, fc = "1"b; cont = "0"b; /* turn off continue flag */ end; /* end of card */ else do; eoc = "0"b; if j ^= 0 then do; rtq_info.cdkp -> cdkbuf = ""; call bcd_to_ascii_ (bcd_str, rtq_info.cdkp -> cdkbuf); /* convert string to ascii */ substr (rtq_info.cbufp -> cbuf, nchars + (i - j), j) = rtq_info.cdkp -> cdkbuf; /* set string in position */ end; /* not end of line and not end of card */ nchars = nchars + i; /* update line position */ if com_fld.nxt = "76"b3 then do; /* end of compressed deck */ fc = "1"b; cont = "0"b; /* turn off continue so we will write this line */ end; /* end of compressed deck */ else if com_fld.nxt = "77"b3 then do; /* end of this line */ fl = "1"b; /* set terminate condition */ cont = "0"b; /* not a continued line */ rtq_info.cfptr = addr (com_fld.nxt_fld); /* set ptr to skip line fence */ end; /* end of this line */ else if com_fld.nxt = "00"b3 then /* line continued in next card */ cont, fc = "1"b; else rtq_info.cfptr = addr (com_fld.nxt); /* otherwise just go to nxt field */ end; /* not end of line and not end of card */ end; /* do while ^fl &^fc */ if ^cont & ^eoc then do; /* line continues on next card */ substr (rtq_info.cbufp -> cbuf, nchars, 1) = NL; /* add new line to end of line */ call write_file (rtq_info.cbufp, nchars, s_filename); /* write out the line */ end; /* if line continues on next card */ end; /* do while not end of card */ end; /* compressed deck */ else do; /* user wants copy */ ck_obj: if obj_card then do; /* we have passed a $ object card */ obj_card = "0"b; if card_cnt ^= 2 then do;/* not first card of blk */ call ssu_$print_message (sci_ptr, 0, "$ object card not first card of blk"); rtq_info.return_subsys_loop_flg = "1"b; return; /* return to subsystem */ end; /* nchars = current card size + prev card size + bcw */ nchars = (rtq_info.cvp -> rcw.rsize + rcw.rsize + 3) * NUMB_OF_CHARS_PER_WORD; rtq_info.cvp = addrel (rtq_info.cvp, -1); /* don't forget bcw */ end; /* if we have passed a $ object card */ else if card_cnt = 1 then do; /* include only bcw */ nchars = (rcw.rsize + 2) * NUMB_OF_CHARS_PER_WORD; rtq_info.cvp = addrel (lrptr, -1); end; else do; /* include just this card */ nchars = (rcw.rsize + 1) * NUMB_OF_CHARS_PER_WORD; rtq_info.cvp = lrptr; end; call write_file (rtq_info.cvp, nchars, s_filename); if dkend_card then do; /* if last card of deck */ dkend_card = "0"b; call detach_file_if_attached; /* just in case we had a file attached */ end; /* last card of deck */ end; /* user wants copy */ go to gssf_end; %page; /* media codes 0, 2, 3, and 9 - bcd records */ media_type (0): /* Not a media conversion record */ media_type (2): /* BCD card image */ media_type (3): /* BCD print line image */ media_type (9): /* Bcd print line image (with user defined rpt code) */ call bcd_to_ascii_ (gc_log_rec_bits, rtq_info.cbufp -> cbuf); /* convert bcd to ascii */ rtq_info.cbufp -> cbuf = translate (rtq_info.cbufp -> cbuf, "='+)(", "#@&]%"); /* take care of stange conversion chars */ if rcw.media_code = 2 then do; /* if bcd card */ nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, 80))) + 1; /* set max length to 80 char */ if substr (rtq_info.cbufp -> cbuf, 1, 13) = "$ object" then do; /* and object card */ obj_card = "1"b; rtq_info.cvp = addrel (lrptr, currentsize (gc_log_rec)); /* look at nxt card */ if rtq_info.cvp -> rcw.media_code = 1 then do; /* if binary card */ binck = "1"b; /* set flag so we don't come back */ call detach_file_if_attached; /* this should not happen but ... */ call get_file_name ("obj", nchars); /* get filename */ if rtq_info.return_subsys_loop_flg then return; /* return to subsystem */ go to gssf_end;/* card will be written with next one */ end; /* binary card */ end; /* object card */ else if substr (rtq_info.cbufp -> cbuf, 1, 12) = "$ dkend" then /* dkend card */ if binck then do; /* process only if we have been doing something with bin cards */ if substr (rtq_info.cbufp -> cbuf, 16, 8) ^= "continue" then /* if continue card keep on going */ dkend_card = "1"b; go to ck_obj; /* copy this one too */ end; else ; else if substr (rtq_info.cbufp -> cbuf, 1, 12) = "$ snumb" then do; /* snumb card */ i = search (substr (rtq_info.cbufp -> cbuf, 16, 6), ","); /* if any commas, find out */ if i = 0 then /* no commas, use name as is */ p_arg = substr (rtq_info.cbufp -> cbuf, 16, 6); /* generate filename */ else p_arg = substr (rtq_info.cbufp -> cbuf, 16, i - 1); /* don't like commas in seg names */ if ^valid_pathname ((p_arg), "imcv") then do; rtq_info.return_subsys_loop_flg = "1"b; return; /* return to subsystem */ end; call detach_file_if_attached; /* detach old file, if attached */ imcv = "1"b; /* set indicator switch */ rtq_info.fw_file, cont = "0"b; /* reset so file name will appear on terminal */ end; /* snumb card */ else if ^imcv then do; /* a $ language card */ rtq_info.tmr = "0"b; /* reset terminate condition */ do i = 1 to hbound (gcos_trans, 1) while (^rtq_info.tmr); if substr (rtq_info.cbufp -> cbuf, 8, 6) = gcos_trans (i) then rtq_info.tmr = "1"b; end; if rtq_info.tmr then do; /* found a valid language card */ if rtq_info.f_attached then do; /* if we had a file attached before... */ call write_file (addr (eoj_card), length (eoj_card), s_filename); /* complete jcl */ if rtq_info.return_subsys_loop_flg then return; call detach_file_if_attached; end; call get_file_name ("ascii", nchars); /* get filename */ if rtq_info.return_subsys_loop_flg then return; rtq_info.last_job_deck_flg = "1"b; /* set flag for last job deck */ call ioa_$rsnnl ("$ snumb ^a^/$ ident^/^a^/$ limits 8,64k,,50000^/", rtq_info.cbufp -> cbuf, rtq_info.clen, substr (rtq_info.filename, 1, 3), substr (rtq_info.cbufp -> cbuf, 1, nchars)); call write_file (rtq_info.cbufp, rtq_info.clen, s_filename); /* write out jcl */ cont = "0"b; /* reset continue flag */ if rtq_info.return_subsys_loop_flg then return; go to gssf_end; end; /* a valid language card */ end; /* a $ language card */ end; /* a bcd card */ else if rcw.media_code = 9 then do; /* if user rpt code present */ rtq_info.cbufp -> cbuf = substr (rtq_info.cbufp -> cbuf, 3); /* wipe it out */ nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rcw.rsize * 6))) - 2; /* get length of string */ end; /* user rpt code */ else nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rcw.rsize * 6))) + 1; /* get length of string */ substr (rtq_info.cbufp -> cbuf, nchars, 1) = NL; /* append new line to end of string */ call write_file (rtq_info.cbufp, nchars, s_filename); /* write out this logical record */ if rtq_info.return_subsys_loop_flg then return; go to gssf_end; %page; /* media codes 6, 7, 10, and 13 are ascii records */ media_type (6): /* ssf ascii */ media_type (7): /* Ascii print line image */ media_type (10): /* Ascii card image */ media_type (13): /* Ascii print line image (with user defined rpt code) */ rtq_info.cvp = addr (gc_log_rec.gc_log_rec_data); if rcw.nchar_used ^= 0 then /* if we have a partial word */ nchars = ((rcw.rsize - 1) * NUMB_OF_CHARS_PER_WORD) + rcw.nchar_used + 1; else nchars = rcw.rsize * NUMB_OF_CHARS_PER_WORD + 1; rtq_info.cbufp -> cbuf = substr (gssf_ascii, 1, nchars - 1) || NL; if rcw.media_code = 13 then do; /* if user rpt code present */ rtq_info.cbufp -> cbuf = substr (rtq_info.cbufp -> cbuf, 3); /* wipe it out */ nchars = nchars - 2; end; call write_file (rtq_info.cbufp, nchars, s_filename); /* write out this logical record */ if rtq_info.return_subsys_loop_flg then return; /* return to subsystem */ go to gssf_end; /* media codes 4, 5, 11, 12, 14, and 15 are illegal media codes */ media_type (4): /* Reserved for user */ media_type (5): /* Tss ascii (before release E) */ media_type (11): /* Illegal media code */ media_type (12): /* Illegal media code */ media_type (14): /* Illegal media code */ media_type (15): /* Illegal media code */ call ssu_$print_message (sci_ptr, 0, "Illegal media code ^o detected in card number ^d of block ^d", rcw.media_code, card_cnt, bcnt); rtq_info.return_subsys_loop_flg = "1"b; return; /* this is not a gcos deck, return */ media_type (8): /* tss info record, ignore */ gssf_end: nwds = nwds + rcw.rsize + 1; /* increment number of words */ rtq_info.cvp = lrptr; /* save ptr to current logical record */ lrptr = addrel (lrptr, currentsize (gc_log_rec)); /* set next logical record */ card_cnt = card_cnt + 1; /* increment card count */ end; /* do while nwds < gc_phy_rec.bcw.blk_size */ end GCOS_ssf; /****************************************************************************/ %page; MULT_ssf: proc (first_record_flg, last_record_flg, s_filename); /* process MULTICS standard system format records. */ dcl first_record_flg bit (1) aligned; dcl last_record_flg bit (1) aligned; dcl s_filename char (32) varying; /* save for calling write_file procedure */ dcl 1 mult_buf based (rtq_info.tptr) aligned, /* buffer for MULTICS standard tape record */ 2 cur_rec (1040) bit (36), /* storage for current record */ 2 last_rec char (rtq_info.clen); /* storage for last record read */ /* begin coding */ mstrp = rtq_info.tptr; /* set Multics standard record ptr */ if ^first_record_flg then do; /* if this is the first rcd set flag */ first_record_flg = "1"b; bcnt = mstr.head.rec_within_file; /* set initial record number within file */ end; else if ^mstr.head.flags.repeat then do; /* if not repeat record */ bcnt = bcnt + 1; /* increment record counter */ if bcnt ^= mstr.head.rec_within_file & ^last_record_flg then do; /* sequence error */ call ssu_$print_message (sci_ptr, 0, "Record sequence number error; Record sequence number was ^d; S/B ^d", mstr.head.rec_within_file, bcnt); YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop? Answer ""yes"" or ""no"".", "Stop?"); if YES_FLG then do; /* users want to stop */ call detach_file_if_attached; /* just in case we had a file attached */ rtq_info.return_subsys_loop_flg = "1"b; /* users want to return to subsystem request loop */ return; end; else bcnt = mstr.head.rec_within_file; /* reset block number */ end; /* sequential error */ call write_file (addr (mult_buf.last_rec), rtq_info.clen, s_filename); /* write out last record */ if rtq_info.return_subsys_loop_flg then return; end; /* not repeat record */ if ^last_record_flg then do; /* if current record is not eof */ rtq_info.clen = divide (mstr.head.data_bits_used, 9, 17, 0); /* get char length */ addr (mult_buf.last_rec) -> mult_move = addr (mstr.data) -> mult_move; /* move it */ end; end MULT_ssf; /****************************************************************************/ %page; attach_and_open_output_file: proc; /* attach file */ RETRY: call iox_$attach_name ("file_sw", rtq_info.fiocb_ptr, att_desc, null, scode); if scode ^= 0 then do; if scode = error_table_$not_detached then do; call iox_$detach_iocb (rtq_info.fiocb_ptr, scode); if scode ^= error_table_$not_closed then goto ERR_ATTACHED; else do; call iox_$close (rtq_info.fiocb_ptr, scode); goto RETRY; end; end; else do; /* display error messages */ ERR_ATTACHED: call ssu_$print_message (sci_ptr, scode, "^/ Attempting to attach file.^/ Attach description: ^a", att_desc); rtq_info.return_subsys_loop_flg = "1"b; return; end; end; /* scode ^= 0 */ rtq_info.f_attached = "1"b; /* set attached switch */ /* open file */ call iox_$open (rtq_info.fiocb_ptr, open_mode, "0"b, scode); if scode ^= 0 then do; call ssu_$print_message (sci_ptr, scode, "^/ Opening ^a for ^a", att_desc, iox_modes (open_mode)); call detach_file_if_attached; /* just in case we had a file attached */ rtq_info.return_subsys_loop_flg = "1"b; return; end; end attach_and_open_output_file; /****************************************************************************/ %page; check_mode: proc (a_mode); /* check and set tape dim in a specified reading mode. */ dcl a_mode fixed bin; /* set desired mode if required and tell user what we have done */ if rtq_info.c_mode ^= a_mode then do; rtq_info.c_mode = a_mode; call ioa_ ("Setting tape dim to read in ^a mode", mode (rtq_info.c_mode)); call process_control_order (mode (rtq_info.c_mode), "0"b, "0"b, "0"b, 1); end; end check_mode; /**************************************************************************/ %page; command_query_no_entrypoint: proc (explain_to_users, ask_users_question) returns (char (200) varying); dcl ask_users_question char (*); dcl explain_to_users char (*); dcl get_users_answer char (64); /* external entry */ dcl command_query_ entry options (variable); %page; %include query_info; %page; /* begin coding */ who_asked = ssu_$get_subsystem_and_request_name (sci_ptr); unspec (query_info) = "0"b; /* clear out query_info structure */ query_info.version = query_info_version_6; query_info.prompt_after_explanation = "1"b; query_info.question_iocbp, query_info.answer_iocbp = null; query_info.explanation_ptr = addr (explain_to_users); query_info.explanation_len = length (explain_to_users); call command_query_ (addr (query_info), get_users_answer, (who_asked), ask_users_question); return (rtrim (get_users_answer)); end command_query_no_entrypoint; /**************************************************************************/ %page; command_query_yes_no: proc (interpretation_string, query_string) returns (bit (1) aligned); /* ask users for a yes or no answer. */ dcl A_YES_OR_NO_ANSWER bit (1) aligned; dcl interpretation_string char (95); dcl query_string char (28); /* external entry */ dcl command_query_$yes_no entry options (variable); /* begin coding */ A_YES_OR_NO_ANSWER = "0"b; who_asked = ssu_$get_subsystem_and_request_name (sci_ptr); call command_query_$yes_no (A_YES_OR_NO_ANSWER, 0, (who_asked), interpretation_string, query_string); return (A_YES_OR_NO_ANSWER); end command_query_yes_no; /**************************************************************************/ %page; detach_file_if_attached: proc (); /* detach an old file if it was already attached. */ /* begin coding */ if rtq_info.f_attached then do; call iox_$close (rtq_info.fiocb_ptr, (0)); call iox_$detach_iocb (rtq_info.fiocb_ptr, (0)); rtq_info.last_job_deck_flg, rtq_info.f_attached = "0"b; end; end detach_file_if_attached; /***************************************************************************/ %page; detach_tape_file: proc (sci_ptr, rtq_info_ptr); /* detach and close tape and file. */ dcl release_area_ entry (ptr); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl (rtq_info_ptr, sci_ptr) ptr; /* close and detach tape switch which was attached and opened earlier */ if rtq_info.tiocb_ptr ^= null then do; call iox_$close (rtq_info.tiocb_ptr, (0)); call iox_$detach_iocb (rtq_info.tiocb_ptr, (0)); rtq_info.tiocb_ptr = null; end; /* release temp segment if already allocated */ if rtq_info.tptr ^= null then call release_temp_segment_ (pname, rtq_info.tptr, (0)); /* release our tape buffer */ /* release an area which already assigned */ if rtq_info.rtq_area_ptr ^= null then do; call release_area_ (rtq_info.rtq_area_ptr); ai.areap = null; end; /* if file was attached then detach it */ call detach_file_if_attached; return; end detach_tape_file; /**************************************************************************/ %page; determine_tape_label_types: proc (); /* determine the tape label type and then process the specified tape type */ /* (e.g. MULTICS, GCOS, IBM, ANSI) */ /* begin code */ if rtq_info.tptr -> mult.lab_id = header_c1 then do; /* Multics standard tape */ rcd_volid = rtq_info.tptr -> mult.tape_reel_id; /* copy volume id directly */ rtq_info.l_type = v1_mult_label; end; /* MULTICS standard tape */ else if rtq_info.tptr -> mult.lab_id = label_c1 then do; /* is this a bootable MST? */ if (rtq_info.tptr -> mst_label.head.c1 = header_c1) & (rtq_info.tptr -> mst_label.head.label) then do; rcd_volid = rtq_info.tptr -> mst_label.tape_reel_id; /* copy volume id directly */ rtq_info.l_type = v3_mult_label; end; end; else if rtq_info.tptr -> gcos.lab_id = g_label then do; /* GCOS standard tape */ call bcd_to_ascii_ (rtq_info.tptr -> gcos.vol_id, rcd_volid); /* convert bcd */ rtq_info.l_type = 3; /* gcos_label value */ end; /* GCOS standard tape */ else if rtq_info.tptr -> ibm_ansi.lab_id = i_label then do; /* IBM standard tape */ call ebcdic8_to_ascii_ (rtq_info.tptr -> ibm_ansi.vol_id, rcd_volid); /* convert packed ebcdic to ascii */ rtq_info.l_type = ibm_label; end; /* IBM standard tape */ else if rtq_info.tptr -> ibm_ansi.lab_id = a_label then do; /* ANSI standard tape */ do i = 0 to 5; /* unpack 8bit ascii to 9bit ascii */ blab (i) = "0"b || substr (rtq_info.tptr -> ibm_ansi.vol_id, (i * 8) + 1, 8); end; rtq_info.l_type = ansi_label; end; /* ANSI standard tape */ else if rtq_info.tptr -> cp5_lab.lab_id = CP5_label then do; /* cp5 stand tape */ call ebcdic8_to_ascii_ (rtq_info.tptr -> cp5_lab.vol_id, rcd_volid); /* convert tape name */ rtq_info.l_type = cp5_label; end; /* CP5 standard tape */ else do; /* unlabeled tape */ call ioa_ ("Tape ^a is ^a or has unrecognized label.^/Tape will remain positioned at BOT.", rtq_info.tape_name, LABEL (rtq_info.l_type)); return; end; call ioa_ ("Tape ^a is a labeled ^a tape.^/Volume name recorded on tape label is ^a.", rtq_info.tape_name, LABEL (rtq_info.l_type), rcd_volid); if rtq_info.l_type = ibm_label | rtq_info.l_type = ansi_label then do; /* if IBM or ANSI tape */ call check_mode (NINE_MODE); /* set reading mode to nine */ call process_control_order ("forward_record", "1"b, "1"b, "0"b, 2); /* space to HDR2 record */ call read_tape_record ("stop", rtq_info.eof, "0"b, mssf); /* and read it in */ if rtq_info.return_subsys_loop_flg then return; if ^rtq_info.eof then do; /* if no error */ call ioa_ ("First data file format:"); if ^valid_label_record ("0"b) then /* if hdr2 rcd does not exist */ call ssu_$print_message (sci_ptr, 0, "Could not find ^a HDR2 record.", LABEL (rtq_info.l_type)); end; /* if ^eof */ else do; /* error reading hdr2 record */ call ssu_$print_message (sci_ptr, 0, "Error reading HDR2 record, tape will be rewound to BOT"); call process_control_order ("rewind", "0"b, "0"b, "0"b, 1); return; end; /* else do */ end; /* if l_type = ibm_label | l_type = ansi_label */ call ioa_ ("Positioning to beginning of physical tape file # 2, (logical file # 1)"); call process_control_order ("forward_file", "1"b, "1"b, "1"b, 1); return; end determine_tape_label_types; /***************************************************************************/ %page; get_file_name: proc (dtype, nchars); /* get file name from gcos card or query user. */ dcl dtype char (5); dcl nchars fixed bin (21); dcl output_filename char (168) aligned; /* begin coding */ if nchars >= 73 then /* if full card */ if substr (rtq_info.cbufp -> cbuf, 73, 4) ^= "" | substr (rtq_info.cbufp -> cbuf, 73, 4) ^= "0000" then do; /* and not garbage */ rtq_info.filename = rtrim (substr (rtq_info.cbufp -> cbuf, 73, 4)); /* extract name */ i = index (rtq_info.filename, NL); /* check for imbedded newline */ if i ^= 0 then /* remove it if so */ substr (rtq_info.filename, i) = substr (rtq_info.filename, i + 1); end; else ; else do; /* name not on card, query user */ call ioa_ ("^a", substr (rtq_info.cbufp -> cbuf, 1, 80)); /* display card image for user */ rtq_info.tmr = "0"b; /* initialize terminate condition */ output_filename = ""; do while (^rtq_info.tmr); /* if no filename */ output_filename = command_query_no_entrypoint ("Please enter an output file name.", "Ouput file name: "); rtq_info.tmr = valid_pathname ((output_filename), ""); if ^rtq_info.tmr then goto PATHNAME_ERROR; end; /* do while ^rtq_info.tmr */ end; /* else do */ if ^valid_pathname ((rtq_info.filename), dtype) then do; PATHNAME_ERROR: call ssu_$print_message (sci_ptr, scode, "Expanding pathname for file name ""^a""", rtq_info.filename); rtq_info.return_subsys_loop_flg = "1"b; return; /* return subsystem */ end; rtq_info.fw_file = "0"b; /* reset switch so we get message */ end get_file_name; /***************************************************************************/ %page; get_output_descript_and_attach: proc (); /* query users for the output attach description and an opening mode */ /* before invoke "attach_and_open_output_file" internal procedure. */ /* if file not attached already */ if ^rtq_info.f_attached then do; attach_desc_output = command_query_no_entrypoint ("Please enter an output attach description.", "Output attach description: "); att_desc = attach_desc_output; /* copy attach description */ attach_desc_output = command_query_no_entrypoint ("Please enter an opening mode.", "Opening mode: "); /* loop throught two given arrays of modes to find a matched mode */ do i = 1 to hbound (iox_modes, 1) while (attach_desc_output ^= iox_modes (i) & attach_desc_output ^= short_iox_modes (i)); end; if i > hbound (iox_modes, 1) then do; /* invalid mode specification */ call ssu_$print_message (sci_ptr, 0, "Invalid opening mode specification ""^a""", attach_desc_output); rtq_info.return_subsys_loop_flg = "1"b; return; end; /* set opening mode to user's specified mode */ open_mode = i; /* attach file now to make sure i/o module exists */ call attach_and_open_output_file; end; /* if ^rtq_info.f_attached */ return; end get_output_descript_and_attach; /***************************************************************************/ %page; get_tape_status: proc; /* get octal and English description of tape error. */ dcl analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72) aligned, bit (18) aligned); /* begin coding */ status_story = ""; /* clear old description first */ call iox_$control (rtq_info.tiocb_ptr, "saved_status", addr (t_stat), scode); call analyze_device_stat_$rsnnl (status_story, addr (tape_status_table_$tape_status_table_), (t_stat), ("0"b)); end get_tape_status; /****************************************************************************/ %page; process_control_order: proc (a_order, a_rpt, a_dir, a_rf, a_cnt); /* process control orders (non-data xfer tape commands) */ dcl a_cnt fixed bin (35); dcl a_dir bit (1) aligned; dcl a_order char (*); dcl a_rf bit (1) aligned; dcl a_rpt bit (1) aligned; dcl backspace_file_flg bit (1) aligned init ("0"b); dcl count fixed bin (35); dcl i fixed bin (35); dcl order char (16); /* begin coding */ order = a_order; /* copy control order */ count = a_cnt; /* copy count arg */ backspace_file_flg = "0"b; /* reset backspace file flag if set */ if a_rpt then do; /* if space cmd */ if ^a_dir then do; /* backspace cmd */ if a_rf then do; /* file cmd */ if rtq_info.c_file - count < 1 then do; /* can't backspace that far */ call ioa_ ("Tape will be positioned at BOT"); call process_control_order ("rewind", "0"b, "0"b, "0"b, 1); /* call ourselves recursively */ return; end; else do; /* backspace file, or begin file */ rtq_info.c_rec = 1; /* deterimine the first record in the file */ if order = "begin_file" then do; /* if begin file operation */ order = "backspace_file"; backspace_file_flg = "1"b; /* set backspace file flag */ end; else do; /* a real backspace file */ /* decrement file number to "count" time(s) and go back count + 1 files */ rtq_info.c_file = rtq_info.c_file - count; if rtq_info.c_file > 1 then backspace_file_flg = "1"b; count = count + 1; /* really going back n + 1 files */ end; /* else do */ end; /* else do */ end; /* a_rf */ else if rtq_info.c_rec - count < 1 then do; /* record cmd */ call ioa_ ("Tape will be positioned at beginning of file ^d", rtq_info.c_file); call process_control_order ("begin_file", "1"b, "0"b, "1"b, 1); /* call ourselves recursively */ return; end; /* else if c_rec - count < 1 */ else rtq_info.c_rec = rtq_info.c_rec - count; /* bsr ok, reset position */ end; /* ^a_dir */ else do; /* a_dir means a forward space cmd */ if a_rf then do; /* file cmd */ rtq_info.c_rec = 1; /* reset position counters */ rtq_info.c_file = rtq_info.c_file + count; end; else if ^rtq_info.eof_request_flg then rtq_info.c_rec = rtq_info.c_rec + count; /* fsr cmd */ end; /* else do */ end; /* if a_rpt means a space cmd */ if order = "rewind" then /* if order is rewind */ rtq_info.c_rec, rtq_info.c_file = 1; /* reset position */ do i = 1 to count; /* iterate control order requested times */ call iox_$control (rtq_info.tiocb_ptr, order, null, scode); if scode ^= 0 then do; if scode = error_table_$end_of_info & rtq_info.records_in_file_flg then do; scode = 0; /* must reset to zero so that the next if statement will false */ i = i - 1; /* want to reposition back to the original position */ end; if ^rtq_info.eof_request_flg & scode ^= 0 then do; save_status_code = scode; call get_tape_status; /* get English desc of tape error */ call ssu_$print_message (sci_ptr, save_status_code, "^/Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while executing iteration # ^d of ^a control order", t_stat, (status_story ^= ""), status_story, i, a_order); return; end; end; /* scode ^= 0 */ end; /* do i = 1 to count */ if backspace_file_flg then do; /* if a backspace file operation */ call iox_$control (rtq_info.tiocb_ptr, "forward_file", null, scode); /* position to beginning of next file */ if scode ^= 0 then do; save_status_code = scode; call get_tape_status; /* get English desc of tape error */ call ssu_$print_message (sci_ptr, save_status_code, "^/Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while forward spacing to beginning of file ^d", t_stat, (status_story ^= ""), status_story, rtq_info.c_file); return; end; end; /* a bsf command */ end process_control_order; /***************************************************************************/ %page; process_logical_record_length: proc (); /* users want each physical tape record to be written into several logical */ /* records of a specified length. So do it. */ /* begin coding */ it_cnt = divide (rtq_info.rec_len - schar, l_rec_len, 17, 0); /* determine # of logical records */ spill = mod (rtq_info.rec_len - schar, l_rec_len);/* get spill over if any */ do i = 1 to it_cnt; rtq_info.cbufp -> cbuf = chcv_buf (i); /* copy logical record */ temp_logical_rec_len = l_rec_len; if open_mode = Stream_output | open_mode = Stream_input_output then do; substr (rtq_info.cbufp -> cbuf, l_rec_len + 1, 1) = NL; /* add NL to its end */ temp_logical_rec_len = temp_logical_rec_len + 1; end; call write_file (rtq_info.cbufp, temp_logical_rec_len, s_filename); /* and write it out */ if rtq_info.return_subsys_loop_flg then return; end; if spill ^= 0 then do; /* if some left over */ it_cnt = it_cnt + 1; /* need 1 more subsrcipt for spill */ rtq_info.cbufp -> cbuf = substr (chcv_buf (it_cnt), 1, spill); if open_mode = Stream_output | open_mode = Stream_input_output then do; substr (rtq_info.cbufp -> cbuf, spill + 1, 1) = NL; /* copy spillover */ spill = spill + 1; /* for the NL */ end; call write_file (rtq_info.cbufp, spill, s_filename); /* and write it out too */ if rtq_info.return_subsys_loop_flg then return; end; /* process some record left over */ return; end process_logical_record_length; /***************************************************************************/ %page; read_file_get_control_args: proc (); /* process optional input control arguments for "read_file" request */ do arg_dex = 1 to Nargs; call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al); if arg = "-gcos" | arg = "-gc" then do; /* file in gcos standard system format */ gssf = "1"b; call check_mode (BINARY_MODE); /* must read data in binary mode */ n_ops = n_ops + 1; /* increment for inconsistancy check */ end; else if arg = "-multics" | arg = "-mult" then do; /* file in multics standard system format */ mssf = "1"b; call check_mode (BINARY_MODE); /* must read data in binary mode */ n_ops = n_ops + 1; /* increment for inconsistancy check */ end; else if arg = "-extend" then /* if file extend option desired */ rtq_info.extend_sw = "1"b; else if arg = "-nnl" then /* if user don't want new line on raw File */ nnl_sw = "1"b; else if arg = "-output_description" | arg = "-ods" then /* user wants to attach spec device */ rtq_info.atd_sw = "1"b; else if arg = "-cp5" then do; /* cp5 variable length records */ cp5 = "1"b; /* set flag */ call check_mode (NINE_MODE); /* must read data in nine bit mode */ n_ops = n_ops + 1; /* increment for inconsistancy check */ end; else if arg = "-dec" then do; /* DEC 40 bit word records */ lrp = rtq_info.cvbp; /* set conversion buffer pointer */ dec_sw = "1"b; /* set flag */ call check_mode (BINARY_MODE); /* must read data in binary mode */ n_ops = n_ops + 1; /* increment for inconsistancy check */ end; else if arg = "-ibm_vb" then do; /* IBM "VB" records */ ibmv = "1"b; /* set flag */ if arg_dex < Nargs then do; call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al); if substr (arg, 1, 1) ^= "-" then do; arg_dex = arg_dex + 1; if arg = "binary" | arg = "bin" then rtq_info.set_bin = "1"b; else if arg = "ebcdic" then c_e_a = "1"b; else if arg ^= "ascii" then do; IBM_VB_ERROR: call ssu_$print_message (sci_ptr, 0, " Usage: read_file (rdfile) {-ibm_vb {ascii | binary (bin) | ebcdic}}"); goto GET_CONTROL_ARG_ERROR; end; /* else if arg ^= "ascii" */ end; /* if substr (arg, 1, 1) ^= "-" */ else c_e_a = "1"b; /* ebcdic conversion by default */ end; /* arg_dex < Nargs */ else if arg_dex = Nargs then c_e_a = "1"b; /* ebcdic conversion by default */ else goto IBM_VB_ERROR; if rtq_info.set_bin then /* if we need to read in binary mode */ call check_mode (BINARY_MODE);/* go set it */ else call check_mode (NINE_MODE); /* otherwise read in nine mode */ n_ops = n_ops + 1; /* for inconsistancy check */ end; /* else if arg = "-ibm_vb" */ else if arg = "-ansi_db" then do; /* ANSI "DB" records */ ansid = "1"b; /* set flag */ if arg_dex < Nargs then do; call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al); if substr (arg, 1, 1) ^= "-" then do; arg_dex = arg_dex + 1; /* advance argument index */ if arg = "binary" | arg = "bin" then rtq_info.set_bin = "1"b; else if arg = "ebcdic" then c_e_a = "1"b; else if arg ^= "ascii" then do; ANSI_DB_ERROR: call ssu_$print_message (sci_ptr, 0, "Usage: read_file (rdfile) {-ansi_db {ascii | binary (bin) | ebcdic}}"); goto GET_CONTROL_ARG_ERROR; end; end; /* if substr (arg, 1, 1) ^= "-" */ end; /* arg_dex < Nargs */ else if arg_dex > Nargs then goto ANSI_DB_ERROR; else ; if rtq_info.set_bin then /* if we need to read in binary mode */ call check_mode (BINARY_MODE);/* go set it */ else call check_mode (NINE_MODE); /* otherwise read in nine mode */ n_ops = n_ops + 1; /* increment for inconsistancy check */ end; /* ANSI "DB" record */ else if arg = "-truncate" | arg = "-tc" then do; /* user wants to truncate phy records */ if arg_dex < Nargs then do; call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al); tr_cnt = cv_dec_check_ (arg, scode); if scode ^= 0 then do; TC_ERROR: call ssu_$print_message (sci_ptr, scode, "^/ Usage: read_file (rdfile) {-truncate (-tc) N}"); goto GET_CONTROL_ARG_ERROR; end; arg_dex = arg_dex + 1; /* advance argument index */ trunc_sw = "1"b; end; /* if arg_dex < Nargs */ else do; scode = 0; goto TC_ERROR; end; end; /* -truncate (-tc) */ else if arg = "-logical_record_length" | arg = "-lrl" then do; /* process log records */ if arg_dex < Nargs then do; call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al); l_rec_len = cv_dec_check_ (arg, scode); if scode ^= 0 then do; LRL_ERROR: call ssu_$print_message (sci_ptr, scode, "^/ Usage: read_file (rdfile) {-logical_record_length (-lrl) N}"); goto GET_CONTROL_ARG_ERROR; end; arg_dex = arg_dex + 1; /* advance argument index */ if l_rec_len > length (rtq_info.cbufp -> cbuf) then do; /* better to tell user of limitation */ call ssu_$print_message (sci_ptr, 0, "Logical record lengths > ^d characters not supported", length (rtq_info.cbufp -> cbuf)); goto GET_CONTROL_ARG_ERROR; end; l_rec = "1"b; n_ops = n_ops + 1; /* increment for inconsistancy check */ end; /* if arg_dex < Nargs */ else do; scode = 0; goto LRL_ERROR; end; end; /* -logical_record_length (-lrl) */ else if arg = "-count" | arg = "-ct" then do;/* user wants to read multiple files */ if arg_dex < Nargs then do; call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al); iterations = cv_dec_check_ (arg, scode); /* check for rdfile iterations */ if scode ^= 0 then do; CNT_ERROR: call ssu_$print_message (sci_ptr, scode, "^/ Usage: read_file (rdfile) {-count (-ct) N}"); goto GET_CONTROL_ARG_ERROR; end; arg_dex = arg_dex + 1; /* advance argument index */ end; /* if arg_dex < Nargs */ else do; /* missing N for -count */ scode = 0; goto CNT_ERROR; end; end; /* -count (-ct) */ else if arg = "-skip" then do; /* user wants to skip some initial chars */ if arg_dex < Nargs then do; call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al); schar = cv_dec_check_ (arg, scode); if scode ^= 0 then do; SKIP_ERROR: call ssu_$print_message (sci_ptr, scode, "^/ Usage: read_file (rdfile) {-skip N}"); goto GET_CONTROL_ARG_ERROR; end; arg_dex = arg_dex + 1; /* advance argument index */ end; /* if arg_dex < Nargs */ else do; scode = 0; goto SKIP_ERROR; end; end; /* -skip */ else if arg = "-convert" | arg = "-conv" then do; /* user wants to do some conversion */ if arg_dex < Nargs then do; call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al); arg_dex = arg_dex + 1; /* advance argument index */ if arg = "ebcdic_to_ascii" | arg = "ebcdic" then c_e_a = "1"b; /* convert ebcdic */ else if arg = "bcd_to_ascii" | arg = "bcd" then c_b_a = "1"b; /* convert bcd */ else if arg = "comp8_to_ascii" | arg = "comp8" then do; /* convert comp8 to ascii */ c_c_a = "1"b; call check_mode (NINE_MODE); /* must read data in nine bit mode */ end; /* com8_to_ascii (comp8) */ else do; CONV_ERROR: call ssu_$print_message (sci_ptr, 0, "Usage: read_file (rdfile) {-convert (-conv) ebcdic_to_ascii (ebcdic) | bcd_to_ascii (bcd) | comp8_to_ascii (comp8)}"); goto GET_CONTROL_ARG_ERROR; end; end; /* if arg_dex < Nargs */ else goto CONV_ERROR; lrp = rtq_info.cvbp; /* set conversion buffer pointer */ n_ops = n_ops + 1; /* increment for inconsistancy check */ end; /* -convert (-conv) */ else if arg = "-output_file" | arg = "-of" then do; /* user wants output file specified */ if arg_dex < Nargs then do; call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al); if substr (arg, 1, 1) ^= "-" then do; /* don't allow file name to begin with - */ arg_dex = arg_dex + 1; /* advance argument index */ if ^valid_pathname ((arg), "") then do; /* error expanding pathname */ OF_ERROR: call ssu_$print_message (sci_ptr, scode, "^/ Usage: read_file (rdfile) {-output_file (-of) FILE_NAME}"); goto GET_CONTROL_ARG_ERROR; end; end; end; /* arg_dex < Nargs */ else do; scode = 0; goto OF_ERROR; end; end; /* -output_file (-of) */ else do; call ssu_$print_message (sci_ptr, 0, "Invalid input optional control argument ""^a""", arg); goto GET_CONTROL_ARG_ERROR; end; end; /* do i = 1 to Nargs */ return; GET_CONTROL_ARG_ERROR: rtq_info.return_subsys_loop_flg = "1"b; return; end read_file_get_control_args; /***************************************************************************/ %page; read_in_the_entire_file: proc (); /* depending on the record format, process each record just read in until */ /* end of file encountered. If the file is in GCOS JCL then invoke */ /* the "write_file" internal procedure to write end of job card. */ /* Similarly, invoke the "MULT_ssf" to go flush buffer for Multics file. */ /* Finally, if not extend the file then invokes the */ /* "detach_file_if_attached" to detach the file if it was already attached.*/ /* begin code */ rtq_info.eof, binck = "0"b; do while (^rtq_info.eof); /* read entire file */ call read_tape_record ("skip", rtq_info.eof, "0"b, mssf); /* read the next record */ if rtq_info.return_subsys_loop_flg then return; if ^rtq_info.eof then do; /* if not end of file */ if valid_label_record ("0"b) then /* if label record */ goto nxt_rcd; /* then don't process */ if trunc_sw then rtq_info.rec_len = tr_cnt; /* wants truncate phy record */ if gssf then call GCOS_ssf (cont, imcv, nchars, binck, first_record_flg, s_filename); else if mssf then call MULT_ssf (first_record_flg, last_record_flg, s_filename); /* MULTICS standard tape */ else if cp5 then call CP5_variable_length_records; else if dec_sw then call DEC_tape_records; else if ibmv then call IBM_VB_records; else if ansid then do; conversion_flg = "0"b; call ANSI_DB_records (conversion_flg); if conversion_flg then return; end; else do; /* not known format, check for conversion */ if c_e_a then do; /* convert ebcdic to ascii */ if rtq_info.c_mode = NINE_MODE then /* if nine mode */ call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf); else do; rtq_info.rec_len = divide (rtq_info.bits + 8 - 1, 8, 21, 0); /* correct record length */ call ebcdic8_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf); end; end; /* covert ebcdic to ascii */ else if c_b_a then do; /* bcd to ascii conversion */ rtq_info.rec_len = divide (rtq_info.bits + 6 - 1, 6, 21, 0); /* correct record length */ call bcd_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf); end; /* convert bcd to ascii */ else if c_c_a then do; /* convert comp 8 to ascii */ rtq_info.rec_len = divide (rtq_info.bits + 4 - 1, 4, 21, 0); /* correct record length */ call comp_8_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf); end; /* convert comp 8 to ascii */ if l_rec then call process_logical_record_length; else if rtq_info.atd_sw | nnl_sw then /* let he writes to what he wants */ call write_file (addr (conv_buf.conv_dta), rtq_info.rec_len - schar, s_filename); else do; /* write a raw file by default */ substr (conv_buf.conv_dta, rtq_info.rec_len - schar + 1, 1) = NL; /* to prevent string range condition */ rtq_info.rec_len = (rtq_info.rec_len - schar) + 1; /* set correct record length */ call write_file (addr (conv_buf.conv_dta), rtq_info.rec_len, s_filename); end; end; /* unknown format */ end; /* if ^rtq_info.eof */ if rtq_info.return_subsys_loop_flg then return; nxt_rcd: end; /* do while ^rtq_info.eof */ if gssf then do; if rtq_info.last_job_deck_flg then do; call write_file (addr (eoj_card), length (eoj_card), s_filename); /* if gcos jcl, write eoj card */ if rtq_info.return_subsys_loop_flg then return; end; end; if mssf then do; /* if Multics standard system format */ last_record_flg = "1"b; /* don't forget last data in buffer */ call MULT_ssf (first_record_flg, last_record_flg, s_filename); /* go flush buffer */ if rtq_info.return_subsys_loop_flg then return; end; if ^rtq_info.extend_sw then /* if not extending this file */ call detach_file_if_attached; /* just in case we had a file attached */ end read_in_the_entire_file; /***************************************************************************/ %page; read_tape_record: proc (neg, end_file, quiet_sw, mssf); /* read in the next sequential tape record in the file. If the returned */ /* scode value is zero then increment the record number by 1, set buffer */ /* full flag so we can dump the record, calculate the record length in */ /* bits, and reset the end of file flag. If the returned scode value */ /* indicates end of file encountered then if end of file flag or end of */ /* volume flag was previously set then set end of tape flag, else set end */ /* of file flag. If not suppress output then display appropriate */ /* messages to users and adjust the record number to the first record in */ /* the file. Increment file number by 1, adjust the record length in */ /* bits to zero, and set end_file flag indicating end of file */ /* encountered. If the returned scode value indicates tape error then */ /* invoke "get_tape_status" to get tape error number and English */ /* description. If the tape error record is in Multics format then */ /* re-try to read it again up to 10 times before reporting to users. */ /* Ask users whether they want to retry again or to skip that error */ /* record or to return to the rtq request loop. */ /* automatic storage */ dcl auto_retry fixed bin; dcl end_file bit (1) aligned; dcl explanation_string char (95); dcl get_answer char (5) varying; /* max len is 5 characters */ dcl mssf bit (1) aligned; dcl neg char (6); dcl query_flg bit (1) aligned; dcl question_string char (20); dcl quiet_sw bit (1) aligned; /* begin coding */ if rtq_info.two_eofs then goto gleot; /* if gcos partial header label */ end_file = "0"b; /* reset eof indicator */ auto_retry = 0; /* intiialize auto retry count */ retry_rd: call iox_$read_record (rtq_info.tiocb_ptr, rtq_info.tptr, rtq_info.buf_size - NUMB_OF_CHARS_PER_WORD, rtq_info.rec_len, scode); /* minus 4 because must reserve 1 word for appending a New Line character after returning to the caller */ if scode ^= 0 then do; if scode ^= error_table_$end_of_info then do; save_status_code = scode; call get_tape_status; /* get English desc of tape error */ if mssf then do; /* reading a Multics standard system format tape */ auto_retry = auto_retry + 1; if auto_retry > 10 then do; /* exceeded error threshold */ call ssu_$print_message (sci_ptr, save_status_code, "^/Tape status = ^4.3b.^/^[""^a""^;^1s^] ^/ Therefore, skipping record ^d, file ^d, ^a.", t_stat, (status_story ^= ""), status_story, rtq_info.c_rec, rtq_info.c_file, "due to unrecoverable read error"); rtq_info.c_rec = rtq_info.c_rec + 1; /* increment record number */ end; /* exceeded error threshold */ else call iox_$control (rtq_info.tiocb_ptr, "backspace_record", null, scode); /* back it up */ go to retry_rd; /* and go read next record */ end; /* reading a MULTICS Standard Label tape */ call ssu_$print_message (sci_ptr, save_status_code, "Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while reading record ^d, file ^d", t_stat, (status_story ^= ""), status_story, rtq_info.c_rec, rtq_info.c_file); if neg ^= "stop" then do; /* neg = "skip" */ explanation_string = "Do you want to retry, skip to the next record, or stop? Answer ""retry"", ""skip"", or ""stop""."; question_string = "Retry, skip or stop?"; end; else do; /* neg = "stop" */ explanation_string = "Do you want to retry or stop? Answer ""retry"" or ""stop""."; question_string = "Retry or stop?"; end; get_answer = command_query_no_entrypoint (explanation_string, question_string); query_flg = "1"b; do while (query_flg); query_flg = "0"b; /* exit do loop */ if get_answer = "retry" then do; call iox_$control (rtq_info.tiocb_ptr, "backspace_record", null, scode); if scode = error_table_$end_of_info then goto END_OF_INFO_REACHED; else go to retry_rd; end; else if get_answer = "skip" then do; rtq_info.c_rec = rtq_info.c_rec + 1; /* increment record number */ go to retry_rd;/* and go read it */ end; else if get_answer = "stop" then do; rtq_info.return_subsys_loop_flg = "1"b; end_file = "1"b; /* indicate error */ return; /* return to request loop */ end; else do; get_answer = command_query_no_entrypoint (explanation_string, question_string); query_flg = "1"b; end; end; /* do while */ end; /* if scode ^= error_table_$end_of_info */ else do; /* end of file */ END_OF_INFO_REACHED: if rtq_info.one_eof | rtq_info.eov then rtq_info.two_eofs = "1"b; /* indicate physical end of tape */ else rtq_info.one_eof = "1"b; /* no set one eof indicator */ gleot: if ^quiet_sw then do; /* if not suppressing output */ if rtq_info.two_eofs then do; /* if at physical end of tape, tell user */ call ioa_ ("End of file encountered on file # ^d. No data read.", rtq_info.c_file); call ioa_ ("Logical end of tape at physical file # ^d", rtq_info.c_file); end; else do; if rtq_info.c_rec = 1 then do; call ioa_ ("End of file encountered on file # ^d. No data read.", rtq_info.c_file); call ioa_ ("Positioning to start of file # ^d.", rtq_info.c_file + 1); end; else do; call ioa_ ("End of file after ^d record^[s^] read from tape file # ^d", rtq_info.c_rec - 1, (rtq_info.c_rec > 2), rtq_info.c_file); call ioa_ ("Positioning to start of file # ^d.", rtq_info.c_file + 1); end; end; rtq_info.c_rec = 1; /* reset record number */ end; rtq_info.c_file = rtq_info.c_file + 1; /* increment file number */ rtq_info.bits = 0; /* reset number of bits */ end_file = "1"b; /* and turn on eof indicator */ end; /* end of file */ end; /* scode ^= 0 */ else do; /* scode = 0 */ rtq_info.c_rec = rtq_info.c_rec + 1; /* no tape errors, increment record number */ rtq_info.buf_ful = "1"b; /* set buffer ful switch so we can dump record */ rtq_info.bits = rtq_info.rec_len * 9; /* and calculate bit len of record */ rtq_info.one_eof = "0"b; /* reset one eof indicatior if set */ end; end read_tape_record; /***************************************************************************/ %page; record_information: proc (numrecs, nbits, rcd_tally); /* display a record length in bits, words, nine-bit bytes, eight-bit bytes, */ /* and in six-bit characters. */ dcl (bit6, bit8, bit9) fixed bin (35) init (0); dcl (nbits, numrecs) fixed bin (35); dcl rcd_tally bit (1); /* begin coding */ if ^rcd_tally then /* if called from rdrec request */ if valid_label_record ("1"b) then return; /* check for valid label record */ nwds = divide (nbits, 36, 35); bit9 = divide (nbits, 9, 35); bit8 = divide (nbits, 8, 35); bit6 = divide (nbits, 6, 35); call ioa_ ("^[ ^d record^[s^]:^;^2sRecord^] ^a ^d ^a, ^d ^a, ^d ^a,^[^/ ^-^[^- ^;^6x^]^;^1s ^] ^d ^a, ^d ^a", rcd_tally, numrecs, (numrecs > 1), "length =", nbits, "bits", nwds, "words", bit9, "nine bit bytes", rtq_info.short_output_flg, rcd_tally, bit8, "eight bit bytes", bit6, "six bit chars"); end record_information; /***************************************************************************/ %page; valid_label_record: proc (lg_ck) returns (bit (1) aligned); /* determines that the record is a LABEL/TRAILER record and displays its */ /* contents if it is. */ dcl ansi_hdr2_fmt char (108) int static options (constant) init ("Record format ^a^[^[B^]^;^1s^]; Block length ^d; Record length ^d; Mode ^[ASCII^;EBCDIC^;BINARY^;UNKNOWN^];"); dcl (eov, lg_ck) bit (1) aligned; /* begin coding */ go to lab_type (rtq_info.l_type); /* check for LABEL records first */ lab_type (1): /* check for MULTICS label records */ if rtq_info.tptr -> mstr.head.label then do; /* Multics tape label record */ call ioa_ ("^[^/^] ^a version ^[2^;1^] label record for volume ^a", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type), (unspec (substr (rtq_info.tptr -> mult.volume_set_id, 1, 1)) ^= "777"b3), rtq_info.tptr -> mult.tape_reel_id); if lg_ck then do; /* if user wants more info... */ if substr (rtq_info.tptr -> mstr.head.uid, 18, 1) then /* if uid generated by unique_bits_... */ call date_time_ (bin (substr (rtq_info.tptr -> mstr.head.uid, 19, 52), 71), time_string); else call date_time_ (bin (rtq_info.tptr -> mstr.head.uid, 71), time_string); call ioa_ ("Tape created on:^-^a", time_string); if rtq_info.tptr -> mult.installation_id ^= "" then /* and this exists then give it to him */ call ioa_ ("Tape created at:^-^a", rtq_info.tptr -> mult.installation_id); if unspec (substr (rtq_info.tptr -> mult.volume_set_id, 1, 1)) ^= "777"b3 then /* if version 2 label */ if rtq_info.tptr -> mult.volume_set_id ^= "" then /* and volume set exists.. */ call ioa_ ("Volume Set Name:^-^a", rtq_info.tptr -> mult.volume_set_id); end; /* if log_ck */ end; /* Multics tape LABEL record */ else if rtq_info.tptr -> mstr.head.eor then /* if end of reel record */ call ioa_ ("^[^/^] ^a end of reel record", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type)); else return ("0"b); /* not Multics tape label record */ return ("1"b); /* was label record, return true */ lab_type (2): /* check for version 2 Multics label records */ if rtq_info.c_file = 1 & rtq_info.tptr -> mst_label.head.label then do; /* if Multics tape label record */ call ioa_ ("^[^/^] ^a version ^d label record for volume ^a", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type), rtq_info.tptr -> mst_label.label_version, rtq_info.tptr -> mst_label.tape_reel_id); if lg_ck then do; /* if user wants more info */ if substr (rtq_info.tptr -> mst_label.head.uid, 18, 1) then /* if uid generated by unique_bits_... */ call date_time_ (bin (substr (rtq_info.tptr -> mst_label.head.uid, 19, 52), 71), time_string); else call date_time_ (bin (rtq_info.tptr -> mst_label.head.uid, 71), time_string); call ioa_ ("Tape created on:^-^a", time_string); if rtq_info.tptr -> mst_label.installation_id ^= "" then /* if one exists, print it */ call ioa_ ("Tape created at:^-^a", rtq_info.tptr -> mst_label.installation_id); if rtq_info.tptr -> mst_label.userid ^= "" then /* if one exists, print it */ call ioa_ ("Tape created by:^-^a", rtq_info.tptr -> mst_label.userid); if rtq_info.tptr -> mst_label.boot_pgm_path ^= "" then /* if one exists, print it */ call ioa_ ("Boot program path:^-^a", rtq_info.tptr -> mst_label.boot_pgm_path); if rtq_info.tptr -> mst_label.volume_set_id ^= "" then /* if this exists, print it */ call ioa_ ("Volume Set Name:^-^a", rtq_info.tptr -> mst_label.volume_set_id); if rtq_info.tptr -> mst_label.copyright ^= "" then /* if protection notice exits, print it */ call ioa_ ("Protection Notice:^-^a", rtq_info.tptr -> mst_label.copyright); end; /* if lg_ck */ end; /* it is file 1 and it is MULTICS tape Label record */ else if rtq_info.tptr -> mstr.head.eor then /* if end of reel record */ call ioa_ ("^[^/^] ^a end of reel record", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type)); else return ("0"b); /* not Multics tape label record */ return ("1"b); /* was label record, return true */ lab_type (3): /* check for GCOS Label records */ if rtq_info.bits = 504 then do; /* if gcos tape label or eof record */ call bcd_to_ascii_ (bit_buf, rtq_info.cbufp -> cbuf); /* convert bcd to ascii */ if gcos.lab_id = g_label then do; /* if header label */ if substr (bit_buf, 145, 216) = "0"b then do; /* partial hdr label */ rtq_info.eov, rtq_info.two_eofs = "1"b; /* logical end of tape */ j = 24; /* set character count */ end; else j = 60; /* normal hdr label */ call ioa_ ("^a ^[Partial ^]^[BTL ^]^a^[; Tape reel # ^a^;^1s^].^[^/(""^a"")^;^1s^]^[^/^]", LABEL (rtq_info.l_type), eov, (rtq_info.c_file = 1), "header label record", (rtq_info.c_file ^= 1), substr (rtq_info.cbufp -> cbuf, 19, 6), lg_ck, substr (rtq_info.cbufp -> cbuf, 1, j), eov); end; /* label header */ else call ioa_ ("^/^a ""^a"" label record. ^a ^d^[; Next reel # ^a^;^1s^].^[^/(""^a"")^;^1s^]", LABEL (rtq_info.l_type), substr (rtq_info.cbufp -> cbuf, 2, 3), "Block count of previous file", bin (substr (bit_buf, 37, 36)), (substr (rtq_info.cbufp -> cbuf, 79, 6) ^= ""), substr (rtq_info.cbufp -> cbuf, 79, 6), lg_ck, rtq_info.cbufp -> cbuf); return ("1"b); end; /* GCOS Label record */ else return ("0"b); /* not label record */ lab_type (4): /* check for IBM Label records */ if rtq_info.rec_len = 80 then do; /* it looks like a label record */ call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf); /* convert ebcdic to ascii */ rtq_info.lblp = rtq_info.cvbp; /* set label ptr */ go to ibm_asc_join; /* go join common code */ end; else return ("0"b); /* not label/trailer return false */ lab_type (5): /* check for ANSI Label records */ if rtq_info.rec_len = 80 then do; /* it looks like a label/trailer record */ rtq_info.lblp = rtq_info.tptr; /* set label ptr */ ibm_asc_join: /* code from now on common for ibm and ansi */ if substr (lab_buf, 1, 4) = "VOL1" then /* vol1 label */ call ioa_ ("^[^/^] ^a ^a label record. Volume serial number ^a^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), substr (lab_buf, 5, 6), lg_ck, lab_buf); else if substr (lab_buf, 1, 4) = "HDR1" then /* hdr1 label */ call ioa_ ("^[^/^] ^a ^a label record. Data set ID ^a^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), substr (lab_buf, 5, 17), lg_ck, lab_buf); else if substr (lab_buf, 1, 4) = "HDR2" then do; /* hdr2 label */ call ioa_ ("^a ^a label record. Next file format:", LABEL (rtq_info.l_type), substr (lab_buf, 1, 4)); if rtq_info.l_type = ibm_label then do; /* IBM HDR2 Label */ ibm_hdr2P = rtq_info.lblp; /* set structure ptr */ call ioa_ ("Record format ^a^a; Block length ^d; Record length ^d;", ibm_hdr2.format, ibm_hdr2.block_attribute, bin (ibm_hdr2.blksize), bin (ibm_hdr2.lrecl)); end; else do; /* ANSI HDR2 Label */ ansi_hdr2P = rtq_info.lblp; /* set structure ptr */ ansi_mode = index ("123", ansi_hdr2.mode); /* convert recording mode */ if ansi_mode = 0 then ansi_mode = 4; /* this is an unknown mode */ call ioa_ (ansi_hdr2_fmt, ansi_hdr2.format, (ansi_hdr2.blocked = "0" | ansi_hdr2.blocked = "1"), (ansi_hdr2.blocked = "1"), bin (ansi_hdr2.blklen), bin (ansi_hdr2.reclen), ansi_mode); if ansi_mode = 3 then /* if file in binary mode */ rtq_info.set_bin, rtq_info.set_nine = "1"b; /* set state switches */ end; /* ANSI HDR2 Label */ if lg_ck then call ioa_ ("(""^a"")", lab_buf); end; /* HDR2 Label */ else if substr (lab_buf, 1, 3) = "EOV" | substr (lab_buf, 1, 3) = "EOF" | substr (lab_buf, 1, 3) = "UHL" | substr (lab_buf, 1, 3) = "UTL" then do; /* one of these labels */ call ioa_ ("^[^/^] ^a ^a label record. ^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), lg_ck, lab_buf); if substr (lab_buf, 1, 3) = "EOV" then eov = "1"b; /* Logical End tape */ end; /* EOV Label or EOF Label or UHL Label or UTL Label */ else return ("0"b); /* none of known labels */ return ("1"b); /* if one of these: VOL1, HDR1, HDR2, EOV, EOF, UHL, and UTL labels */ end; /* if rtq_info.rec_len = 80 */ else return ("0"b); /* not a Label or Trailer record */ lab_type (6): /* check for CP5 Label records */ if substr (bit_buf, 1, 9) ^= "172"b3 then /* if first char not = ebcdic ":" */ return ("0"b); /* then its not label record */ call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf); /* convert ebcdic to ascii */ rtq_info.lblp = rtq_info.cvbp; /* set label ptr */ if sentinel = ":LBL" | sentinel = ":ACN" | sentinel = ":BOF" | sentinel = ":EOV" | sentinel = ":EOR" | sentinel = ":EOF" then do; call ioa_ ("^[^/^] ^a ^a label record^[; Volume id ^a^;^1s^].^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type), sentinel, (sentinel = ":LBL"), substr (lab_buf, 5, 4), lg_ck, lab_buf); return ("1"b); /* return true */ end; else return ("0"b); /* otherwise, return false */ lab_type (0): /* unlabeled tape, egnore looking at labels */ return ("0"b); /* not label record */ end valid_label_record; /***************************************************************************/ %page; valid_pathname: proc (pathname_argument, suffix) returns (bit (1) aligned); /* expands a specified entry name to a directory pathname and appends a */ /* specified suffix to an entry name. Returns a "1"b indicating success, */ /* otherwise, returns a "0"b. */ dcl p_dir char (168); dcl p_entry char (32); dcl pathname_argument char (*); dcl suffix char (*); /* begin coding */ call expand_pathname_$add_suffix (pathname_argument, suffix, p_dir, p_entry, scode); if scode ^= 0 then return ("0"b); else do; rtq_info.filename = p_entry; rtq_info.filepath = pathname_ (p_dir, p_entry); return ("1"b); end; end valid_pathname; /***************************************************************************/ %page; write_file: proc (bufptr, wrtchars, s_file_name); /* writes logical records to a specified file: If users don't specify a */ /* file then they will be asked for a file name. If users don't specify a */ /* file format then displays a warning message and query them before */ /* we write a raw file. Builds the attach description before attaching */ /* and opening the file using vfile_ i/o module. Reports to users if the */ /* output file has not been written yet. Depending on the open mode, */ /* writes each logical record to the output file. Queries users for */ /* re-trying to write again if the returned scode value is not a zero */ /* value. */ dcl bufptr ptr; dcl output_filename char (168) aligned; dcl s_file_name char (32) varying; dcl wrtchars fixed bin (21); /* written characters */ /* begin coding */ if ^rtq_info.f_attached then do; /* if file not attached */ if rtq_info.filename = "" then do; /* if no filename, go ask for it */ rtq_info.tmr = "0"b; /* initialize terminate condition */ do while (^rtq_info.tmr); /* if no filename */ output_filename = command_query_no_entrypoint ("Please enter an output file name.", "Output file name: "); rtq_info.tmr = valid_pathname ((output_filename), ""); if ^rtq_info.tmr then do; call ssu_$print_message (sci_ptr, scode, "Expanding pathname while writing to the ouput file name ""^a""", output_filename); rtq_info.return_subsys_loop_flg = "1"b; return; end; end; /* do while ^rtq_info.tmr */ end; /* if rtq_info.filename = "" */ if ^nnl_sw & n_ops = 0 & s_file_name = "" then do; /* warn user before we write raw file */ call ioa_ ("Warning: Tape file # ^d will be written to stream file ^a.^/A new line " || "character (octal 012) will be appended to the end of each physical record.", rtq_info.c_file, rtq_info.filename); YES_FLG = command_query_yes_no ("Do you want to add a new line character to each physical record? Answer ""yes"" or ""no"".", "Append a new line character?"); if ^YES_FLG then do; /* users said no */ rtq_info.return_subsys_loop_flg = "1"b; return; end; end; /* if ^nnl_sw & n_ops = 0 & s_file_name = "" */ att_desc = "vfile_ " || rtq_info.filepath; /* build attach description now */ /* attach and open the output file */ call attach_and_open_output_file; end; /* if ^rtq_info.f_attached */ if ^rtq_info.fw_file then do; /* if first record of file */ rtq_info.fw_file = "1"b; /* set switch */ if ^rtq_info.atd_sw then /* if user not using his own attach desc */ call ioa_ ("Writing file ""^a"".", rtq_info.filepath); end; RETRY_WRITE: if open_mode = Stream_output | open_mode = Stream_input_output then /* if open for "so" or "sio" */ call iox_$put_chars (rtq_info.fiocb_ptr, bufptr, wrtchars, scode); /* write out logical records */ else call iox_$write_record (rtq_info.fiocb_ptr, bufptr, wrtchars, scode); /* write out logical records */ if scode ^= 0 then do; call ssu_$print_message (sci_ptr, scode, "while writing to ""^a""", att_desc); YES_FLG = command_query_yes_no ("Do you want to retry? Answer ""yes"" or ""no"".", "Retry?"); if YES_FLG then /* users want to retry */ goto RETRY_WRITE; end; end write_file; /***************************************************************************/ %page; %include rtq_structure_info; %page; %include ibm_hdr2; %include ansi_hdr2; %page; %include mstr; %include gcos_ssf_records; %page; %include iox_modes; %include area_info; end rtq_;  rtq_request_table_.alm 07/28/87 0923.2rew 07/28/87 0918.5 28215 " ******************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " ******************************************** " HISTORY COMMENTS: " 1) change(87-05-28,TLNguyen), approve(87-05-28,MCR7692), " audit(87-07-15,Blair), install(87-07-28,MR12.1-1048): " implement read_tape_and_query (rtq) nonstandard subsystem as a standard " ssu_ subsystem. " rtq_request_table_.alm defines each request of read_tape_and_query " subsystem. " 2) change(87-07-10,TLNguyen), approve(87-07-10,MCR7727), " audit(87-07-15,Blair), install(87-07-28,MR12.1-1048): " Add two new requests: rif, eof. " END HISTORY COMMENTS name rtq_request_table_ include ssu_request_macros begin_table rtq_request_table_ request bof, rtq_$bof_request, (), (Position to the beginning of the current physical tape file) request bsf, rtq_$bsf_request, (), (Backspace N files) request bsr, rtq_$bsr_request, (), (Backspace N records) request density, rtq_$density_request, (den), (Sets the tape density to a N bit per inch) request dump, rtq_$dump_record_request, (), (Displays the contents of the record buffer on the users terminal) request eof, rtq_$eof_request, (), (Positions to the end of the current physical tape file, after the last record) request fsf, rtq_$fsf_request, (), (Forward space N files) request fsr, rtq_$fsr_request, (), (Forward space N records) request list_tape_contents, rtq_$list_tape_contents, (ltc), (Displays information about each record on the tape) request mode, rtq_$mode_request, (), (Sets the hardware mode for reading tape to STR) request position, rtq_$position_request, (pos), (Displays the current physical tape file and record position for the user) request quit, rtq_$quit_request, (q), (Detaches the tape and returns control to the current command processor) request read_file, rtq_$read_file_request, (rdfile), (Reads the current tape file into the segment described by args) request read_record, rtq_$read_record_request, (rdrec), (Reads the current record into a temporary buffer) request records_in_file, rtq_$records_in_file_request, (rif), (Counts the number of records in the current file) request rewind, rtq_$rewind_request, (rew), (Rewinds and positions the tape to the beginning of the tape marker) request ., rtq_$dot_request, (dot), (Displays the long name read_tape_and_query with its short name in parentheses) end_table rtq_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