list_tape_contents.pl1 04/19/88 0829.1rew 04/19/88 0823.2 176922 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(76-05-01,Phillipps), approve(), audit(), install(): old history comments. Written by J.B. Phillipps. change 76-09-01 Phillipps. change 78-06-01 Jordan. change 78-10-01 Jordan. change 80-06-01 Jordan to remove backspace characters from usage message. change 81-06-01 Jordan to fix some bugs. 2) change(85-10-01,GWMay), approve(84-02-29,MCR7154), audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1191): Complete Rewrite - changed to use mtape_ instead of the tape_ansi_ and tape_ibm_ i/o modules. Removed the -io_module(iom) control by undocumenting it and replaced it with the -volume_type(-vt) control arg when -iom is used -vt is assumed. Removed the -retain control by undocumenting and ingnoring the control in the code. 3) change(88-02-17,GWMay), approve(88-03-14,MCR7856), audit(88-03-15,Wallman), install(88-04-19,MR12.2-1039): Changed to use -next_file for first open call. END HISTORY COMMENTS */ %page; /****^ PROGRAM DESCRIPTION: Command to list tape characteristics and file attributes of OS and ANSI standard labeled volumes. END PROGRAM DESCRIPTION */ list_tape_contents: ltc: procedure; /* based storage */ dcl arg char (Larg) aligned based (Parg); /* builtin functions */ dcl (addr, char, fixed, length, null, rtrim, search, substr) builtin; /* conditions */ dcl (cleanup, command_error) condition; /* automatic storage */ dcl 1 lto aligned, 2 print_mode fixed bin, /* 1 - long info; 2 - brief info; */ /* 3 - default info */ 2 list_limit fixed bin (24), /* list list_limit number */ 2 volid char (6); /* volume-set name */ dcl Larg fixed bin, Lcurrent_line fixed bin, Parg_list ptr, Parg ptr, Piocb ptr, Sprint_banner bit(1), cmd_name char (18), code fixed bin (35), number_of_like_files fixed bin initial (0), 1 current_file aligned like mtape_fst, current_file_no fixed bin (24), current_line char(256) varying, input_attach_args char (270) aligned varying, mtape_attach_desc char (270) aligned varying, mtape_open_desc char (270) aligned varying, n_args fixed bin, next_arg fixed bin, previous_line char(256) varying, tape_io_switch char (26), temp fixed bin(24); /* constants */ dcl ANSI_TAPE_ATTACH_DESC char (104) internal static options (constant) init ("mtape_ -volume_type ansi -no_display -density 1600 -track 9 -error -device 1 -label -no_system -no_wait "), ANSI_TAPE_OPEN_DESC char (46) internal static options (constant) init ("-no_display -not_last_file -next_file"), BRIEF fixed bin (2) internal static options (constant) init (2), DEFAULT fixed bin (2) internal static options (constant) init (3), FALSE bit(1) internal static options (constant) init ("0"b), IBM_TAPE_ATTACH_DESC char (103) internal static options (constant) init ("mtape_ -volume_type ibm -no_display -density 1600 -track 9 -error -device 1 -label -no_system -no_wait "), IBM_TAPE_OPEN_DESC char (69) internal static options (constant) init ("-no_display -not_last_file -next_file -no_system_use -ndos"), LONG fixed bin (2) internal static options (constant) init (1), TRUE bit(1) internal static options (constant) init ("1"b); /* error codes */ dcl (error_table_$bad_arg, error_table_$bad_volid, error_table_$noarg, error_table_$nodescr, error_table_$no_file, error_table_$not_detached) fixed bin (35) ext; /* external procedures */ dcl com_err_ entry options (variable), convert_date_to_binary_ entry (char(*), fixed bin(71), fixed bin(35)), cu_$arg_count entry (fixed bin), cu_$arg_list_ptr entry (ptr), cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr), cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)), date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var), ioa_ entry() options(variable), ioa_$rsnnl entry() options(variable), iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)), iox_$close_file entry (ptr, char(*), fixed bin(35)), iox_$control entry (ptr, char(*), ptr, fixed bin(35)), iox_$detach entry (ptr, char(*), fixed bin(35)), iox_$open_file entry (ptr, fixed bin, char(*), bit(1) aligned, fixed bin(35)), requote_string_ entry (char (*)) returns (char (*)); %page; /* ************************************************************************ */ /* */ /* Begin Execution Here: */ /* 1) set up condition handlers. */ /* 2) set up work area. */ /* 3) check for arguments, if none found abort. */ /* 4) check arguments for conditional input of first argument. It must be*/ /* either "-volume", "-vol" or a value that does not begin with a "-". */ /* 5) If the first input value is the volume identifier, prefice it with */ /* the word " -volume ". */ /* */ /* ************************************************************************ */ program_setup: do; cmd_name = "list_tape_contents"; Piocb = null(); on cleanup call janitor; mtape_attach_desc = ANSI_TAPE_ATTACH_DESC; mtape_open_desc = ANSI_TAPE_OPEN_DESC; temp = 0; lto.print_mode = DEFAULT; lto.list_limit = 99999; /* set to no limit */ /* set the default IO module */ current_file_no = 0; /* default start -next_file */ Sprint_banner = TRUE; number_of_like_files = 0; current_file.version = fst_version_1; call cu_$arg_count (n_args); /* get number of args typed in */ if n_args = 0 then code = error_table_$noarg; else do; call cu_$arg_list_ptr (Parg_list); next_arg = 1; call get_arg_ptr; if length (arg) = 0 then code = error_table_$noarg; else do; if substr(arg, 1, length("-")) = "-" then if arg = "-volume" | arg = "-vol" then if get_another_arg () then; else code = error_table_$noarg; else code = error_table_$bad_volid; end; end; %page; if code = 0 then do; input_attach_args = " -volume "; lto.volid = arg; tape_io_switch = cmd_name || "." || lto.volid; if search (arg, """ ") ^= 0 then input_attach_args = input_attach_args || requote_string_ ((arg)); else input_attach_args = input_attach_args || arg; end; else do; call com_err_ (code, cmd_name, " Usage: list_tape_contents vn1 {-comment c1} ... vnN {-comment cN} {-attach_args} {-control_args} attach_args: any combination of mtape_ attach control arguments."); call ioa_ (" control_args: -volume_type (""ansi""|""ibm""), -vt (""ansi""|""ibm"") -from file_number, 0 < file_number < 10000 -to file_number, 0 < file_number < 10000 -long, -lg -brief, -bf"); return; end; end program_setup; %page; /* ************************************************************************ */ /* */ /* Argument Processing Loop: */ /* 1) get the next arg. */ /* 2) if found, check for a length > 0. */ /* 3) if ok, then check to see if it is a control for ltc. If so, */ /* evaluate it. */ /* if not, pass it along to mtape_ for evaluation. */ /* */ /* ************************************************************************ */ process_input_arg_loop: do while (get_another_arg ()); if arg = "-long" | arg = "-lg" then lto.print_mode = LONG; else if arg = "-brief" | arg = "-bf" then lto.print_mode = BRIEF; /* convert to binary */ /* only up to 4 digit file sequence */ /* numbers allowed */ else if arg = "-from" then from_ctl: do; if get_another_arg () then do; temp = fixed (cv_dec_check_ ((arg), code), 17); if code = 0 then if temp > 0 & temp < 10000 then current_file_no = temp; else call com_err_ (error_table_$bad_arg, cmd_name, " -from ^a value must be an integer from 1 to 9999.", arg); else call com_err_ (error_table_$bad_arg, cmd_name, " -from ^a value must be an integer from 1 to 9999.", arg); end; else call com_err_ (error_table_$noarg, cmd_name, " -from requires an operand of an integer from 1 to 9999."); end from_ctl; /* convert to binary */ /* only up to 4 digit file sequence */ /* numbers allowed */ else if arg = "-to" then to_ctl: do; if get_another_arg () then do; temp = fixed (cv_dec_check_ ((arg), code), 17); if code = 0 then if temp > 0 & temp < 10000 then lto.list_limit = temp; else call com_err_ (error_table_$bad_arg, cmd_name, " -to ^a value must be an integer from 1 to 9999.", arg); else call com_err_ (error_table_$bad_arg, cmd_name, " -to ^a value must be an integer from 1 to 9999.", arg); end; else call com_err_ (error_table_$noarg, cmd_name, " -to requires an operand of an integer from 1 to 9999."); end to_ctl; else if arg = "-io_module" | arg = "-iom" then iom_ctl: do; if get_another_arg () then if arg = "tape_ansi_" then do; mtape_attach_desc = ANSI_TAPE_ATTACH_DESC; mtape_open_desc = ANSI_TAPE_OPEN_DESC; end; else if arg = "ibm" then do; mtape_attach_desc = IBM_TAPE_ATTACH_DESC; mtape_open_desc = IBM_TAPE_OPEN_DESC; end; else call com_err_ (error_table_$bad_arg, cmd_name, " -io_module(-iom) ^a operand value must be ""tape_ansi_"" or ""tape_ibm_"".", arg); else call com_err_ (error_table_$noarg, cmd_name, " -io_module(-iom) requires an operand of ""tape_ansi_"" or ""tape_ibm_""."); end iom_ctl; else if arg = "volume_type" | arg = "-vt" then vt_ctl: do; if get_another_arg () then if arg = "tape_ansi_" then do; mtape_attach_desc = ANSI_TAPE_ATTACH_DESC; mtape_open_desc = ANSI_TAPE_OPEN_DESC; end; else if arg = "ibm" then do; mtape_attach_desc = IBM_TAPE_ATTACH_DESC; mtape_open_desc = IBM_TAPE_OPEN_DESC; end; else call com_err_ (error_table_$bad_arg, cmd_name, " -volume_type(-vt) ^a operand must be ""ansi"" or ""ibm"".", arg); else call com_err_ (error_table_$noarg, cmd_name, " -volume_type(-vt) requires an operand value of ""ansi"" or ""ibm""."); end vt_ctl; else if arg = "-retain" | arg = "-ret" then retain_ctl: do; if get_another_arg () then; end retain_ctl; else mtape_ctls: do; /* all remaining input arguments are*/ /* passed along to mtape_ for */ /* evaluation. */ input_attach_args = input_attach_args || " "; if search (arg, """ ") ^= 0 then input_attach_args = input_attach_args || requote_string_ ((arg)); else input_attach_args = input_attach_args || arg; end mtape_ctls; end process_input_arg_loop; /* If any of the arguments were found to be in error, then stop the */ /* program. */ if code ^= error_table_$nodescr then return; %page; /* ************************************************************************ */ /* */ /* Attach mtape_ to the requested volume set. */ /* 1) establish a condition handler to trap mtape_ errors. */ /* */ /* ************************************************************************ */ mtape_attach_desc = mtape_attach_desc || input_attach_args; on command_error code=0; call iox_$attach_ioname (tape_io_switch, Piocb, (mtape_attach_desc), code); if code = error_table_$not_detached | code = 0 then; else do; /* unable to attach tape file */ call com_err_ (code, cmd_name, " While attaching file number ^d, volume ^a. Attach description:^/^a", current_file_no, lto.volid, mtape_attach_desc); call janitor; return; end; %page; /* ************************************************************************ */ /* Print information about the files in the volume set */ /* ************************************************************************ */ print_loop: do while (current_file_no <= lto.list_limit & code = 0); if current_file_no > 0 then call iox_$open_file (Piocb, 4, (mtape_open_desc || " -number" || char(current_file_no)), "0"b, code); else call iox_$open_file (Piocb, 4, (mtape_open_desc), "0"b, code); if code = 0 then call iox_$control (Piocb, "file_status", addr (current_file), code); if code = 0 then print_file_info: do; if lto.print_mode = BRIEF then brief_print_mode: do; if Sprint_banner then do; call ioa_ (" ID Number "); Sprint_banner = FALSE; end; call ioa_ ("^32a^3x^5d", current_file.file_id, current_file.file_seq); end brief_print_mode; else if lto.print_mode = LONG then long_print_mode: do; call ioa_$rsnnl ("Section:^5x^4d Created:^1x^8a^20tExpires:^1x^8a^40tGeneration:^1x^4d^58tVersion:^5x^4d ^[Format:^2x^4a^20tMode:^4x^6a^40tBlksize:^3x^5d^58tLrecl:^4x^7d^]", current_line, Lcurrent_line, current_file.begin_vol_index, cv_date (current_file.creation), cv_date (current_file.expiration), current_file.generation, current_file.gen_version, current_file.file_format ^= "", current_file.file_format, current_file.recording_mode, current_file.block_len, current_file.reclen); if current_line = previous_line then number_of_like_files = number_of_like_files + 1; else if number_of_like_files > 0 then do; call ioa_ (" The last ^d files have the same characteristics.", number_of_like_files + 1); number_of_like_files = 0; end; call ioa_ (" ID: ^32a^40tNumber:^4x^5d^[^58t^a^]", current_file.file_id, current_file.file_seq, current_line ^= previous_line, current_line); previous_line = current_line; end long_print_mode; else default_print_mode: do; if Sprint_banner then do; call ioa_ (" ID Number Format Blksize Lrecl Mode Created Expires "); Sprint_banner = FALSE; end; call ioa_$rsnnl ("^[****^6x****^4x****^4x**** ^s4" || "^;^3a^5x^5d^2x^7d^3x^6a^]^2x^8a^2x^8a", current_line, Lcurrent_line, current_file.file_format = "", current_file.file_format, current_file.block_len, current_file.reclen, current_file.recording_mode, cv_date (current_file.creation), cv_date (current_file.expiration)); if current_line = previous_line then number_of_like_files = number_of_like_files + 1; else if number_of_like_files > 0 then do; call ioa_ (" The last ^d files have the same characteristics.", number_of_like_files + 1); number_of_like_files = 0; end; call ioa_ ("^[^17a^;^a^/^17x^]^5d^[^7x^a^]", length (rtrim (current_file.file_id)) < 18, current_file.file_id, current_file.file_seq, current_line ^= previous_line, current_line); previous_line = current_line; end default_print_mode; call iox_$close_file (Piocb, "-no_display -close_position leave", code); end print_file_info; current_file_no = current_file_no + 1; end print_loop; if code = error_table_$no_file | code = 0 then; else call com_err_ (code, cmd_name, " While processing file number ^d, volume ^a Attach description:^/^a", current_file_no, lto.volid, mtape_attach_desc); call janitor; if number_of_like_files > 0 then call ioa_ (" The last ^d files have the same characteristics.", number_of_like_files + 1); if lto.list_limit = 99999 then; else if lto.list_limit > current_file_no then call ioa_ (" Warning: file listing limit ^d, specified exceeds the number of files on the tape, ^d.", lto.list_limit, current_file_no); %page; /* ************************************************************************ */ /* sees if 2nd part of two-part option exists */ /* ************************************************************************ */ get_another_arg: procedure returns (bit (1)); if next_arg + 1 > n_args then do; code = error_table_$nodescr; return (FALSE); end; else do; /* 2nd part does exist */ next_arg = next_arg + 1; /* increment the option index */ call get_arg_ptr; if code ^= 0 then return (FALSE); else return (TRUE); end; end get_another_arg; /* ************************************************************************ */ get_arg_ptr: procedure; code = 0; call cu_$arg_ptr_rel (next_arg, Parg, Larg, code, Parg_list); return; end get_arg_ptr; %page; /* ************************************************************************ */ janitor: procedure; /* cleanup control file, temp, obj, */ /* and status segments */ if Piocb ^= null () then do; call iox_$close_file (Piocb, "-no_display -close_position leave", code); call iox_$detach (Piocb, "-no_display -rewind", code); end; return; end janitor; %page; /* ************************************************************************ */ cv_date: proc (julian) returns (char (8) aligned); /* date in form: yyddd */ dcl julian char(6) aligned; dcl clock_value fixed bin (71), code fixed bin (35); call convert_date_to_binary_ (("January 1, 19" || substr(julian, 2, length("yy")) || " +" || substr(julian, 4, length("ddd")) || "days -1day"), clock_value, code); if code ^= 0 then return (" unknown"); return (date_time_$format ("multics_date", clock_value, "", "")); end cv_date; %page; %include mtape_file_status; end list_tape_contents;  tape_io.rd 03/17/86 1520.3rew 03/17/86 1430.1 332478 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* tape_inout: Created 3/15/76 by J.B. Phillipps */ /* Modified extensively 6/79 by Michael R. Jordan to fix many bugs */ /* Modified extensively 4/82 by J. A. Bush for installation in MR10.0 */ /* format: style4 */ /*++ BEGIN / /Error (1) /RETURN\ newVol /Volume : /build_vcb LEX (2) /Volume\ / /Error (2) /RETURN\ / / /RETURN\ Volume / /[ii = 1] [vcb.volid(ii) = token_value] LEX (1) /morevols\ / /Error (6) NEXT_STMT /global\ / / /notoken\ nextvol / /[ii = ii + 1] [if ii <= hbound (vcb.volid, 1) then vcb.volid(ii) = token_value] [else if ii = hbound (vcb.volid, 1)+1 then call Error (25)] LEX (1) /morevols\ / /Error (6) NEXT_STMT /global\ / / /notoken\ morevols /"-comment" /LEX (1) /comment\ /"-com" /LEX (1) /comment\ / / /ck_pun\ / / /notoken\ comment / /[vcb.comment (ii) = token_value] LEX (1) /ck_pun\ / /[vcb.comment (ii) = token_value] LEX (1) /ck_pun\ / /[vcb.comment (ii) = token_value] LEX (1) /ck_pun\ / / /notoken\ ck_pun /; /[vcb.nvols = min (ii, hbound (vcb.volid, 1))] LEX (1) /global\ /, /LEX (1) /nextvol\ / /Error (5) NEXT_STMT /global\ / / /notoken\ global /File : /LEX (2) build_fcb (vcb.first_fcb_ptr, current_fcb_ptr) [fcb.file_token_ptr = Ptoken] [if current_default_fcb_ptr ^= null then fcb.default_fcb_ptr = current_default_fcb_ptr] /File\ /End ; /end_vcb LEX (2) /newVol\ /Volume : /Error (4) end_vcb /newVol\ /Tape : /[if vcb.tape_type ^= 0 then call Error (20)] LEX (2) /Tape\ /Density : /[if vcb.density ^= 0 then call Error (14)] LEX (2) /Density\ / /PUSH (global) [if ^build_default_fcb then do; call build_fcb (vcb.first_default_fcb_ptr, current_default_fcb_ptr); build_default_fcb = "1"b; end] /gloop\ / / /notoken\ gloop /Storage : /LEX (2) /Storage\ /Expiration : /LEX (2) /Expires\ /Mode : /LEX (2) /Mode\ /Format : /LEX (2) /Format\ /Block : /LEX (2) /Block\ /Record : /LEX (2) /Record\ /mode : /Error (50) NEXT_STMT /STACK_POP\ /storage : /Error (50) NEXT_STMT /STACK_POP\ /expiration : /Error (50) NEXT_STMT /STACK_POP\ /number : /Error (50) NEXT_STMT /STACK_POP\ /replace : /Error (50) NEXT_STMT /STACK_POP\ /modify ; /Error (50) NEXT_STMT /STACK_POP\ /generate ; /Error (50) NEXT_STMT /STACK_POP\ /tape_extend ; /Error (50) NEXT_STMT /STACK_POP\ /storage_extend ; /Error (50) NEXT_STMT /STACK_POP\ /format : /Error (50) NEXT_STMT /STACK_POP\ /block : /Error (50) NEXT_STMT /STACK_POP\ /record : /Error (50) NEXT_STMT /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ Tape /ANSI ; /[if vcb.tape_type ^= 0 then call Error (20)] [else vcb.tape_type = 1] LEX (2) /global\ /ansi ; /[if vcb.tape_type ^= 0 then call Error (20)] [else vcb.tape_type = 1] LEX (2) /global\ /IBMSL ; /[if vcb.tape_type ^= 0 then call Error (20)] [else vcb.tape_type = 2] LEX (2) /global\ /ibmsl ; /[if vcb.tape_type ^= 0 then call Error (20)] [else vcb.tape_type = 2] LEX (2) /global\ /IBMNL ; /[if vcb.tape_type ^= 0 then call Error (20)] [else vcb.tape_type = 3] LEX (2) /global\ /ibmnl ; /[if vcb.tape_type ^= 0 then call Error (20)] [else vcb.tape_type = 3] LEX (2) /global\ /IBMDOS ; /[if vcb.tape_type ^= 0 then call Error (20)] [else vcb.tape_type = 4] LEX (2) /global\ /ibmdos ; /[if vcb.tape_type ^= 0 then call Error (20)] [else vcb.tape_type = 4] LEX (2) /global\ / ; /Error (21) LEX (2) /global\ / /Error (5) NEXT_STMT /global\ / / /notoken\ Density /6250 ; /[if vcb.density ^= 0 then call Error (14)] [else vcb.density = 4] LEX (2) /global\ /4 ; /[if vcb.density ^= 0 then call Error (14)] [else vcb.density = 4] LEX (2) /global\ /1600 ; /[if vcb.density ^= 0 then call Error (14)] [else vcb.density = 3] LEX (2) /global\ /3 ; /[if vcb.density ^= 0 then call Error (14)] [else vcb.density = 3] LEX (2) /global\ /800 ; /[if vcb.density ^= 0 then call Error (14)] [else vcb.density = 2] LEX (2) /global\ /2 ; /[if vcb.density ^= 0 then call Error (14)] [else vcb.density = 2] LEX (2) /global\ / ; /Error (7) LEX (2) /global\ / /Error (5) NEXT_STMT /global\ / / /notoken\ Storage /unstructured ; /[if fcb.segment.format ^= 0 then call Error (33)] [else fcb.segment.format = 1] LEX (2) /STACK_POP\ /sequential ; /[if fcb.segment.format ^= 0 then call Error (33)] [else fcb.segment.format = 2] LEX (2) /STACK_POP\ / ; /Error (12) LEX (2) /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ / / /notoken\ Expires / ; /[if fcb.tape.expiration ^= "" "" then call Error (34)] [else fcb.tape.expiration = token_value] LEX (2) /STACK_POP\ / ; /Error (22) LEX (2) /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ / / /notoken\ Mode /ascii ; /[if fcb.tape.cmode ^= 0 then call Error (44)] [else fcb.tape.cmode = 1] LEX (2) /STACK_POP\ /ASCII ; /[if fcb.tape.cmode ^= 0 then call Error (44)] [else fcb.tape.cmode = 1] LEX (2) /STACK_POP\ /ebcdic ; /[if fcb.tape.cmode ^= 0 then call Error (44)] [else fcb.tape.cmode = 2] LEX (2) /STACK_POP\ /EBCDIC ; /[if fcb.tape.cmode ^= 0 then call Error (44)] [else fcb.tape.cmode = 2] LEX (2) /STACK_POP\ /binary ; /[if fcb.tape.cmode ^= 0 then call Error (44)] [else fcb.tape.cmode = 3] LEX (2) /STACK_POP\ /BINARY ; /[if fcb.tape.cmode ^= 0 then call Error (44)] [else fcb.tape.cmode = 3] LEX (2) /STACK_POP\ / ; /Error (8) LEX (2) /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ / / /notoken\ Format /U ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 1] LEX (2) /STACK_POP\ /u ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 1] LEX (2) /STACK_POP\ /F ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 2] LEX (2) /STACK_POP\ /f ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 2] LEX (2) /STACK_POP\ /FB ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 5] LEX (2) /STACK_POP\ /fb ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 5] LEX (2) /STACK_POP\ /D ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 3] LEX (2) /STACK_POP\ /d ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 3] LEX (2) /STACK_POP\ /DB ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 6] LEX (2) /STACK_POP\ /db ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 6] LEX (2) /STACK_POP\ /S ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 8] LEX (2) /STACK_POP\ /s ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 8] LEX (2) /STACK_POP\ /SB ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 9] LEX (2) /STACK_POP\ /sb ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 9] LEX (2) /STACK_POP\ /V ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 4] LEX (2) /STACK_POP\ /v ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 4] LEX (2) /STACK_POP\ /VB ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 7] LEX (2) /STACK_POP\ /vb ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 7] LEX (2) /STACK_POP\ /VS ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 10] LEX (2) /STACK_POP\ /vs ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 10] LEX (2) /STACK_POP\ /VBS ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 11] LEX (2) /STACK_POP\ /vbs ; /[if fcb.tape.format ^= 0 then call Error (45)] [else fcb.tape.format = 11] LEX (2) /STACK_POP\ / ; /Error (9) LEX (2) /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ / / /notoken\ Block / ; /[if fcb.tape.blklen ^= 0 then call Error (46)] [else fcb.tape.blklen = token.Nvalue] LEX (2) /STACK_POP\ / ; /Error (10) LEX (2) /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ / / /notoken\ Record / ; /[if fcb.tape.reclen ^= 0 then call Error (47)] [else fcb.tape.reclen = token.Nvalue] LEX (2) /STACK_POP\ / ; /Error (11) LEX (2) /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ / / /notoken\ File / ; /[fcb.tape.file_id = token_value] [build_default_fcb = "0"b] LEX (2) /local\ / ; /Error (37) LEX (2) /local\ / /Error (5) NEXT_STMT /local\ / / /notoken\ local / /PUSH (local) /lloop\ / / /notoken\ lloop /path : /LEX (2) /path\ /mode : /LEX (2) /Mode\ /storage : /LEX (2) /Storage\ /expiration : /LEX (2) /Expires\ /number : /LEX (2) /number\ /replace : /LEX (2) /replace\ /format : /LEX (2) /Format\ /block : /LEX (2) /Block\ /record : /LEX (2) /Record\ /modify ; /[if fcb.tape.output_mode ^= 0 then call Error (38)] [else fcb.tape.output_mode = 2] LEX (2) /STACK_POP\ /generate ; /[if fcb.tape.output_mode ^= 0 then call Error (38)] [else fcb.tape.output_mode = 3] LEX (2) /STACK_POP\ /tape_extend ; /[if fcb.tape.output_mode ^= 0 then call Error (38)] [else fcb.tape.output_mode = 1] LEX (2) /STACK_POP\ /storage_extend ; /[if fcb.segment.extend ^= 0 then call Error (27)] [fcb.segment.extend = 2] LEX (2) /STACK_POP\ /File : /POP /global\ /End /POP /global\ /Storage : /POP /global\ /Expiration : /POP /global\ /Mode : /POP /global\ /Format : /POP /global\ /Block : /POP /global\ /Record : /POP /global\ / /Error (5) NEXT_STMT /STACK_POP\ / / /notoken\ path / ; /[if fcb.segment.ename ^= "" "" then call Error (23)] [fcb.segment.dirname = dirname] [fcb.segment.ename = ename] LEX (2) /STACK_POP\ / ; /Error (13) LEX (2) /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ / / /notoken\ number / ; /[if fcb.tape.sequence ^= 0 then call Error (51)] [else fcb.tape.sequence = token.Nvalue] LEX (2) /STACK_POP\ / ; /Error (48) LEX (2) /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ / / /notoken\ replace / ; /[if fcb.tape.output_mode ^= 0 then call Error (38)] [else fcb.tape.output_mode = 4] [fcb.tape.replace_id = token_value] LEX (2) /STACK_POP\ / ; /Error (37) LEX (2) /STACK_POP\ / /Error (5) NEXT_STMT /STACK_POP\ notoken / /Error (3) /RETURN\ ++*/ tape_io: procedure; /* CONSTANTS */ dcl ANSI fixed bin internal static options (constant) init (1); dcl IBMNL fixed bin internal static options (constant) init (3); dcl DEFAULT_DENSITY (4) fixed bin internal static options (constant) init (2, 3, 3, 3); dcl SERROR_CONTROL bit (2) internal static options (constant) init ("10"b); dcl USAGE_MESSAGE char (115) internal static options (constant) init ("^a^/Usage: ^a tcl_path {-control_args}^/where control args are: -check, -ck, -force, -fc, -severityN, -svN, -ring"); dcl sys_info$max_seg_size fixed bin (35) external static; /* maximum segment size in words */ dcl 1 EMPTY_FCB aligned static internal options (constant), 2 file_token_ptr ptr init (null), /* none */ 2 next_fcb_ptr ptr init (null), /* none */ 2 prev_fcb_ptr ptr init (null), /* none */ 2 default_fcb_ptr ptr init (null), /* none */ 2 segment, 3 dirname char (168) init ((168)" "), 3 ename char (32) init ((32)" "), 3 format fixed bin init (0), /* not specified */ 3 extend fixed bin init (0), /* not specified */ 3 truncate_lines fixed bin init (0), /* not specified */ 2 tape, 3 cmode fixed bin init (0), /* not specified */ 3 format fixed bin init (0), /* not specified */ 3 output_mode fixed bin init (0), /* not specified */ 3 file_id char (17) init (""), /* not specified */ 3 replace_id char (17) init (""), /* not specified */ 3 expiration char (16) init (""), /* not specified */ 3 sequence fixed bin init (0), /* not specified */ 3 blklen fixed bin init (0), /* not specified */ 3 reclen fixed bin (21) init (0); /* not specified */ dcl 1 EMPTY_VCB aligned static internal options (constant), 2 volume_token_ptr ptr init (null), /* none */ 2 next_vcb_ptr ptr init (null), /* none */ 2 first_fcb_ptr ptr init (null), /* none */ 2 first_default_fcb_ptr ptr init (null), /* none */ 2 nvols fixed bin init (0), /* no volumes */ 2 volid (64) char (32) init ((64) (32)" "), 2 comment (64) char (64) init ((64) (64)" "), 2 tape_type fixed bin init (0), /* not specified */ 2 density fixed bin init (0); /* not specified */ /* STATIC STORAGE */ dcl breaks char (128) varying aligned internal static; /* break characters for lex_string_ */ dcl ignored_breaks char (128) varying aligned internal static; /* ignored breaks for lex_string_ */ dcl init_req bit (1) internal static initial ("1"b); /* initialization switch: 0-not required; 1-required */ dcl lex_control_chars char (128) varying aligned internal static; /* control characters for lex_string_ */ dcl lex_delims char (128) varying aligned internal static; /* delimiters for lex_string_ */ /* AUTOMATIC STORAGE */ dcl 1 tid like tape_io_data aligned; dcl 1 ai like area_info aligned; dcl aL fixed bin; dcl aP ptr; dcl arg_num fixed bin; dcl clk_val fixed bin (71); dcl bc fixed bin (24); dcl code fixed bin (35); dcl current_default_fcb_ptr ptr init (null); dcl current_fcb_ptr ptr init (null); dcl dfcbp ptr; dcl dirname char (168); dcl ename char (32); dcl error_count fixed bin; dcl ii fixed bin; dcl j fixed bin; dcl max_severity_num fixed bin; /* max severity printed by lex_error_ */ dcl name char (8); /* command name */ dcl nargs fixed bin; dcl serror_printed (dimension (error_control_table, 1)) bit (1) unaligned; /* is "1"b if error msg printed prev. */ dcl temp_ptr ptr; dcl writing bit (1); /* ON => tape_out */ dcl build_default_fcb bit (1) aligned init ("0"b); /* BASED STORAGE */ dcl arg char (aL) based (aP); dcl my_area area based (tape_io_data.temp (1)); /* ERROR CODES */ dcl error_table_$active_function fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$not_act_fnc fixed bin (35) ext static; dcl error_table_$translation_failed fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (addr, collate, dimension, divide, hbound, min, mod, null, substr, unspec) builtin; /* CONDITIONS */ dcl cleanup condition; /* EXTERNAL PROCEDURES */ dcl active_fnc_err_ entry options (variable); dcl com_err_ ext entry options (variable); dcl convert_date_to_binary_ ext entry (char (*), fixed bin (71), fixed bin (35)); dcl cu_$af_arg_count ext entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl translator_temp_$get_next_segment entry (ptr, ptr, fixed bin (35)); dcl translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35)); dcl translator_temp_$release_segment entry (ptr, fixed bin (35)); dcl define_area_ entry (ptr, fixed bin (35)); dcl release_area_ entry (ptr); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname ext entry (ptr, fixed bin (35)); dcl ioa_ ext entry options (variable); dcl lex_error_ ext entry options (variable); dcl lex_string_$init_lex_delims ext entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) varying aligned, char (*) varying aligned, char (*) varying aligned, char (*) varying aligned); dcl lex_string_$lex ext entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) varying aligned, char (*) varying aligned, char (*) varying aligned, char (*) varying aligned, ptr, ptr, fixed bin (35)); dcl tape_io_interpret_ entry (ptr); tape_in: tin: entry; name = "tape_in"; /* set command name */ writing = "0"b; /* not writing tape */ go to common_code; /* begin processing */ tape_out: tout: entry; name = "tape_out"; /* set command name */ writing = "1"b; /* writing tape */ common_code: tape_io_data_ptr = addr (tid); tape_io_data.temp (*) = null; tape_io_data.first_vcb_ptr = null; tape_io_data.source.dirname = ""; tape_io_data.source.ename = ""; tape_io_data.source.ptr = null; tape_io_data.control.ck = "0"b; tape_io_data.control.force = "0"b; tape_io_data.control.ring = "0"b; tape_io_data.control.writing_tape = writing; tape_io_data.control.max_severity = 0; call cu_$af_arg_count (nargs, code); if code = error_table_$not_act_fnc then code = 0; else if code = 0 then do; call active_fnc_err_ (error_table_$active_function, name); return; end; else do; call com_err_ (code, name); return; end; if nargs < 1 then do; call com_err_ (error_table_$noarg, name, USAGE_MESSAGE, "Control file pathname is missing.", name); return; end; call cu_$arg_ptr (1, aP, aL, (0)); call expand_pathname_$add_suffix (arg, "tcl", tape_io_data.source.dirname, tape_io_data.source.ename, code); if code ^= 0 then do; call com_err_ (code, name, "^a", arg); return; end; on cleanup call Cleaner; call hcs_$initiate_count (tape_io_data.source.dirname, tape_io_data.source.ename, "", bc, 0, tape_io_data.source.ptr, code); if tape_io_data.source.ptr = null then do; call com_err_ (code, name, "^a^[>^]^a", tape_io_data.source.dirname, (tape_io_data.source.dirname ^= ">"), tape_io_data.source.ename); return; end; 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 = name; ai.size = sys_info$max_seg_size; ai.version_of_area = area_info_version_1; ai.areap = null; call define_area_ (addr (ai), code); /* get an area */ if code ^= 0 then do; call com_err_ (code, name, "Cannot define an area"); go to EXIT; end; tape_io_data.temp (1) = ai.areap; /* copy area ptr */ call translator_temp_$get_segment ((name), tape_io_data.temp (2), code); if code = 0 then call translator_temp_$get_next_segment (tape_io_data.temp (2), tape_io_data.temp (3), code); if tape_io_data.temp (2) = null | tape_io_data.temp (3) = null then do; call com_err_ (code, name, "Cannot allocate necessary temporary segments."); go to EXIT; end; do arg_num = 2 repeat arg_num + 1 while (arg_num <= nargs); call cu_$arg_ptr (arg_num, aP, aL, (0)); if arg = "-check" | arg = "-ck" then tape_io_data.control.ck = "1"b; else if arg = "-severity" | arg = "-sv" then do; arg_num = arg_num + 1; if arg_num > nargs then do; call com_err_ (error_table_$noarg, name, "Severity level missing following ^a.", arg); goto EXIT; end; call cu_$arg_ptr (arg_num, aP, aL, (0)); tape_io_data.control.max_severity = cv_dec_check_ (arg, code); if code ^= 0 then go to bad_arg; end; else if arg = "-force" | arg = "-fc" then tape_io_data.control.force = "1"b; /* force all file expiration dates */ else if arg = "-ring" then tape_io_data.control.ring = "1"b; else do; bad_arg: call com_err_ (error_table_$badopt, name, "^a", arg); goto EXIT; end; end; error_count = 0; /* initialize syntatical error counter */ if init_req then do; /* initialize static values if necessary */ breaks = substr (collate, 1, 33); /* control characters */ breaks = breaks || ":;, "; /* my definitions */ breaks = breaks || substr (collate, 128, 1); /* ....and the null (pad) character */ ignored_breaks = substr (collate, 1, 8); /* control characters.... */ ignored_breaks = ignored_breaks || substr (collate, 10, 24); /* ....excluding backspace */ ignored_breaks = ignored_breaks || substr (collate, 128, 1); /* and null character */ init_req = "0"b; /* initialization no longer necessary */ end; call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "1"b, /* initialize the lexing routine */ breaks, ignored_breaks, lex_delims, lex_control_chars); /* call to parse character string input into tokens */ /* chained list of token descriptors generated in temp seg pointed to by temp (2) */ call lex_string_$lex (tape_io_data.source.ptr, divide (bc, 9, 21, 0), 0, tape_io_data.temp (2), "1"b, """", """", "/*", "*/", ";", breaks, ignored_breaks, lex_delims, lex_control_chars, Pstmt, Pthis_token, code); if code ^= 0 then call com_err_ (code, name); if Pthis_token = null then do; call com_err_ (error_table_$translation_failed, name, "The source file is uninterpretable."); goto EXIT; end; /* invoke subroutine which translates tokens */ max_severity_num = 0; /* initialize */ call SEMANTIC_ANALYSIS (); if max_severity_num > 1 then do; call com_err_ (error_table_$translation_failed, name); goto EXIT; end; /* if user only wants syntax checking then that's all here */ if ^tape_io_data.control.ck then call tape_io_interpret_ (tape_io_data_ptr); /* go do the requested I/O */ else call ioa_ ("^/^a: Translation finished; Number of errors encountered was ^d", name, error_count); EXIT: call Cleaner; return; Cleaner: procedure; if tape_io_data.source.ptr ^= null then call hcs_$terminate_noname (tape_io_data.source.ptr, 0); if tape_io_data.temp (1) ^= null then call release_area_ (tape_io_data.temp (1)); if tape_io_data.temp (2) ^= null then call translator_temp_$release_segment (tape_io_data.temp (2), code); if tape_io_data.temp (3) ^= null then call translator_temp_$release_segment (tape_io_data.temp (3), code); end Cleaner; Error: proc (en); /* subroutine to check severify before printing errors */ dcl en fixed bin; dcl pstmt ptr; if Ptoken = null () then pstmt = null (); else pstmt = token.Pstmt; if error_control_table (en).severity >= tape_io_data.control.max_severity then call lex_error_ (en, serror_printed (en), error_control_table (en).severity, max_severity_num, pstmt, null (), SERROR_CONTROL, error_control_table (en).message, error_control_table (en).brief_message); error_count = error_count + 1; end Error; valid_block_sizep: procedure returns (bit (1) aligned); /* defines token */ token.Nvalue = cv_dec_check_ (token_value, code); if code ^= 0 then return ("0"b); if token.Nvalue < 18 then return ("0"b); /* not valid if too small */ if token.Nvalue > 99996 then return ("0"b); /* not valid if too large */ return ("1"b); /* valid */ end valid_block_sizep; valid_file_namep: procedure returns (bit (1) aligned); /* defines valid_file_namep */ if token.Lvalue < 1 then return ("0"b); if token.Lvalue > 17 then return ("0"b); return ("1"b); end valid_file_namep; valid_file_numberp: procedure returns (bit (1) aligned); /* defines token */ if token_value = "*" then do; /* file number not specified */ token.Nvalue = -1; return ("1"b); end; token.Nvalue = cv_dec_check_ (token_value, code); if code ^= 0 then return ("0"b); if token.Nvalue > 9999 then return ("0"b); if token.Nvalue <= 0 then return ("0"b); return ("1"b); /* valid */ end valid_file_numberp; valid_pathnamep: procedure returns (bit (1) aligned); /* defines token */ call expand_pathname_ (token_value, dirname, ename, code); return (code = 0); end valid_pathnamep; valid_record_sizep: procedure returns (bit (1) aligned); /* defines token */ token.Nvalue = cv_dec_check_ (token_value, code); if code ^= 0 then return ("0"b); if token.Nvalue < 1 then return ("0"b); /* not valid if 0 (or negative) */ if token.Nvalue > sys_info$max_seg_size * 4 then return ("0"b); /* not valid if > segment size in chars */ return ("1"b); /* meets requirements */ end valid_record_sizep; valid_volidp: procedure returns (bit (1) aligned); /* defines token */ if token.Lvalue > 32 then return ("0"b); /* not if greater than 32 characters */ if token.Lvalue < 1 then return ("0"b); /* not if less than 1 character */ return ("1"b); /* no other requirements */ end valid_volidp; valid_datep: procedure returns (bit (1) aligned); /* defines token */ call convert_date_to_binary_ (token_value, clk_val, code); /* convert date */ return (code = 0); end valid_datep; build_vcb: procedure; /* procedure to build a vcb */ allocate vcb in (my_area) set (temp_ptr); if tid.first_vcb_ptr = null then tid.first_vcb_ptr = temp_ptr; else vcb.next_vcb_ptr = temp_ptr; vcb_ptr = temp_ptr; vcb = EMPTY_VCB; /* Initialize the vcb */ end build_vcb; end_vcb: procedure; /* procedure to add defaults to VCBs and FCBs */ if vcb.tape_type = 0 then vcb.tape_type = ANSI; if vcb.density = 0 then /* Must set the default density */ vcb.density = DEFAULT_DENSITY (vcb.tape_type); if vcb.first_fcb_ptr = null then do; /* no file-groups in this volume-group */ Ptoken = vcb.volume_token_ptr; /* no source line to be printed */ call Error (52); return; end; do fcb_ptr = vcb.first_fcb_ptr repeat fcb.next_fcb_ptr while (fcb_ptr ^= null ()); call Complete_FCB (); /* add defaults to FCB */ call Check_FCB (); /* and validate FCB */ end; end end_vcb; build_fcb: procedure (head, tail); /* procedure to allocate and initialize an FCB */ dcl (head, tail) ptr; /* ptr to head & tail of FCB chain */ allocate fcb in (my_area) set (temp_ptr); if head = null then head = temp_ptr; else tail -> fcb.next_fcb_ptr = temp_ptr; fcb_ptr = temp_ptr; fcb = EMPTY_FCB; /* reset for next */ if tail ^= null then fcb.prev_fcb_ptr = tail; /* set backward fcb thread */ tail = temp_ptr; /* and update fcb tail for next allocation */ end build_fcb; Complete_FCB: procedure; /* procedure to add defaults to FCB */ /* first, add in global default values, if any */ do dfcbp = fcb.default_fcb_ptr repeat dfcbp -> fcb.prev_fcb_ptr while (dfcbp ^= null); if fcb.tape.blklen = 0 then fcb.tape.blklen = dfcbp -> fcb.tape.blklen; if fcb.tape.reclen = 0 then fcb.tape.reclen = dfcbp -> fcb.tape.reclen; if fcb.tape.format = 0 then fcb.tape.format = dfcbp -> fcb.tape.format; if fcb.tape.cmode = 0 then fcb.tape.cmode = dfcbp -> fcb.tape.cmode; if fcb.tape.expiration = "" then fcb.tape.expiration = dfcbp -> fcb.tape.expiration; if fcb.segment.format = 0 then fcb.segment.format = dfcbp -> fcb.segment.format; end; /* Set the defaults up according to what kind of tape is to be processed */ if vcb.tape_type = ANSI then do; /* If ANSI tape, set the ANSI defaults */ if fcb.tape.cmode = 0 then /* if recording mode not specified.. */ fcb.tape.cmode = 1; /* set ANSI default to ASCII */ if tape_io_data.control.writing_tape then do;/* if tape output */ if fcb.tape.format = 0 then /* if tape format not specified.. */ fcb.tape.format = 6; /* set ANSI default to DB */ if fcb.tape.blklen = 0 then /* if block length not specified.. */ fcb.tape.blklen = 2048; /* set ANSI default */ if fcb.tape.reclen = 0 then /* if Record length not specified.. */ fcb.tape.reclen = 2048; /* set ANSI default */ end; end; else do; /* No, its an IBMSL, IBMNL, or IBMDOS tape */ if fcb.tape.cmode = 0 then /* if recording mode not specified.. */ fcb.tape.cmode = 2; /* set IBM default to EBCDIC */ if tape_io_data.control.writing_tape then do;/* if tape output */ if fcb.tape.format = 0 then /* if tape format not specified.. */ fcb.tape.format = 7; /* set IBM default to VB */ if fcb.tape.blklen = 0 then /* if block length not specified.. */ fcb.tape.blklen = 8192; /* set IBM default */ if fcb.tape.reclen = 0 then /* if Record length not specified.. */ fcb.tape.reclen = 8188; /* set IBM default */ end; end; /* Now do the common defaults */ if tape_io_data.control.writing_tape then /* if tape output */ if fcb.tape.output_mode = 0 then /* if no output mode specified... */ fcb.tape.output_mode = 4; /* The default is "Create or Replace" */ if fcb.segment.format = 0 then /* if no segment format specified... */ fcb.segment.format = 1; /* The default is "Unstructured" */ if fcb.segment.extend = 0 then /* if no extend action specified... */ fcb.segment.extend = 1; /* The default is "Truncate" */ if fcb.segment.truncate_lines = 0 then /* if no long lines action specified... */ fcb.segment.truncate_lines = 1; /* The default is to "Fold" long lines */ end Complete_FCB; Check_FCB: procedure; /* procedure to validate the FCB for completness */ Ptoken = null; /* no source line to be printed */ if fcb.segment.dirname = "" | fcb.segment.ename = "" then /* no "path" statement */ call Error (24); if fcb.tape.file_id = "" then /* No file statement */ call Error (18); if fcb.tape.sequence = -1 then /* if number statement specified as "*".. */ if fcb.tape.output_mode ^= 4 then /* mode has to be append */ call Error (49); if vcb.tape_type ^= ANSI then do; /* tape volume.tape_type not ANSI */ if fcb.tape.output_mode = 3 then /* generate option not supported by IBM */ call Error (19); if fcb.tape.output_mode > 0 then /* some output option specified */ if fcb.tape.blklen ^= 0 then /* block size specified */ if mod (fcb.tape.blklen, 4) ^= 0 then /* blklen not word multiple */ call Error (28); if fcb.tape.blklen > 32760 then /* block size too large for tape_ibm_ */ call Error (10); end; if vcb.tape_type = IBMNL then do; /* unlabeled volume specified */ if fcb.tape.file_id ^= "*" then /* file names not allowed with unlabled volumes */ call Error (29); if fcb.tape.sequence = 0 then /* if no file sequence number specified */ call Error (31); if fcb.tape.replace_id ^= "" then /* replace statement specified for unlabeled tape */ call Error (30); if fcb.tape.output_mode = 1 then /* extend specified for unlabeled tape */ call Error (32); else if fcb.tape.output_mode = 2 then /* modify specified for unlabeled tape */ call Error (55); if fcb.tape.expiration ^= "" then /* expires specified for unlabeled tape */ call Error (56); if tape_io_data.control.force then /* -force option specified for unlabeled tape */ call Error (35); end; else do; /* ANSI and labeled IBM checks */ if fcb.tape.output_mode = 4 then /* ANSI and IBM checks - create */ if fcb.tape.file_id = "*" then /* invalid file id for create */ call Error (53); else ; else if fcb.tape.output_mode = 0 then do; /* tape input mode */ if fcb.tape.format = 0 then /* no format specified on input */ if fcb.tape.reclen > 0 | fcb.tape.blklen > 0 then /* reclen or blklen illegal */ call Error (42); if fcb.tape.format > 1 then /* if format was specified, record and/or block */ if fcb.tape.reclen = 0 | fcb.tape.blklen = 0 then /* length must be specified */ call Error (42); end; else if fcb.tape.output_mode < 3 then do; /* output mode is extend or modify */ if fcb.tape.expiration ^= "" then /* and expiration specified */ if fcb.tape.output_mode = 1 then /* if extend.. */ call Error (39); else call Error (40); /* if modify */ end; if fcb.tape.sequence = 0 | fcb.tape.sequence = -1 then /* no explicit sequence or "*" */ if fcb.tape.file_id = "*" then /* and no */ call Error (41); end; go to test (fcb.tape.format); /* now go validate the format */ test (1): /* U-format */ if fcb.tape.reclen ^= 0 then fcb.tape.reclen = 0; /* reclen must be zero */ if fcb.tape.blklen = 0 then do; call Error (43); call ioa_ ("Tape file block size is ^d", fcb.tape.blklen); end; go to out; test (2): /* F-format */ test (5): /* FB-format */ if fcb.tape.blklen ^= 0 & fcb.tape.reclen ^= 0 then do; /* non zero block & record length */ if fcb.tape.format = 5 then do; /* FB check */ if mod (fcb.tape.blklen, fcb.tape.reclen) ^= 0 then do; call Error (16); call ioa_ ("Tape file record size is ^d", fcb.tape.reclen); call ioa_ ("Tape file block size is ^d", fcb.tape.blklen); end; end; else if fcb.tape.blklen ^= fcb.tape.reclen then do; /* F format check */ call Error (15); call ioa_ ("Tape file record size is ^d", fcb.tape.reclen); call ioa_ ("Tape file block size is ^d", fcb.tape.blklen); end; end; go to out; test (3): /* D-format */ test (4): /* V-format */ test (6): /* DB-format */ test (7): /* VB-format */ if fcb.tape.blklen ^= 0 & fcb.tape.reclen ^= 0 then do; /* d/v format */ if vcb.tape_type = ANSI then j = 0; /* don't allow for BDW if ANSI */ else j = 4; /* IBM - allow for 4 byte BDW */ if fcb.tape.format > 4 then do; /* blocked: reclen must be <= blklen */ if fcb.tape.blklen < fcb.tape.reclen + j then do; call Error (17); call ioa_ ("Tape file record size is ^d", fcb.tape.reclen); call ioa_ ("Tape file block size is ^d", fcb.tape.blklen); end; end; else if fcb.tape.blklen ^= fcb.tape.reclen + j then do; /* V-format, D-format */ call Error (15); call ioa_ ("Tape file record size is ^d", fcb.tape.reclen); call ioa_ ("Tape file block size is ^d", fcb.tape.blklen); end; end; test (8): test (9): test (10): test (11): /* S, SB, VS, VB, VS, VBS formats, all is possible */ test (0): /* for reading, format code is 0 */ out: return; end Check_FCB; %include tape_io_data; %include area_info; %include tape_io_errors;  tape_io_interpret_.pl1 04/19/88 0829.1rew 04/19/88 0824.0 313389 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-04-13,TLNguyen), approve(87-04-13,MCR7664), audit(87-06-08,GWMay), install(87-07-15,MR12.1-1040): make tape_in able to read imcomplete ANSI tapes. 2) change(88-02-03,GWMay), approve(88-02-03,MCR7837), audit(88-04-12,Farley), install(88-04-19,MR12.2-1039): Reformatted and simplified error messages. changed to pass the value of abort_sw to the close_tape_file routine. END HISTORY COMMENTS */ tape_io_interpret_: proc (arg_tape_io_data_ptr); /* format: style4 */ /* tape_io_interpret_ - This module interprets the Volume Control Blocks (VCBs) and File Control Blocks (FCBs) created from the tcl file by tape_io.rd (with the aid of the reduction compiler package), and does the actual tape to SS file (tape_in) or SS file to tape (tape_out) I/O. Modification History: Created circa 1979 by M. R. Jordan by extracting required functionality from tape_io.rd Completed and extensively modified 4/82 by J. A. Bush for understandability and to make it easier to convert to future improved tape software. Modfied 10/26/82 by J. A. Bush to fix bugs (phx10501, phx13989) */ /* PARAMETERS */ dcl arg_tape_io_data_ptr ptr; /* BASED STORAGE */ dcl 1 input_record based (wt_ptr) unaligned, /* template for writing input record */ 2 cw char (amrl), /* number of chars to write */ 2 next_char bit (0); /* to allow setting ptr to end of last record */ /* AUTOMATIC STORAGE */ dcl 1 ads like device_status; /* auto copy of device_status structure */ dcl 1 atfs like tape_file_status; /* auto copy of tape_file_status structure */ dcl 1 tape_attach_descp aligned, /* iox_ attachment descption structure for tape */ 2 vol_string char (256) varying, /* volume portion of attach desc */ 2 file_string char (256) varying, /* file portion of attach desc */ 2 string char (512) varying; /* full attach description */ dcl 1 vfile_info aligned, /* structure for vfile_status_ */ 2 info_version fixed, 2 type fixed, 2 records fixed (34), 2 flags aligned, 3 lock_status bit (2) unaligned, 3 pad bit (34) unaligned, 2 version fixed, 2 action fixed, 2 max_rec_len fixed (21); /* automatic storage */ dcl add_specified_attributes bit (1); dcl abort_sw bit (1) aligned; dcl amrl fixed bin (21); /* number of chars requested/transmitted per io xfer */ dcl answer char (128) varying; dcl blkl picture "zzzzzzz9"; dcl recl picture "zzzzzzz9"; dcl secq picture "zzz9"; dcl blockl fixed bin (21); dcl char_cnt fixed bin (21); /* number of characters transferred per fcb io action */ dcl code fixed bin (35); /* error code */ dcl cont_sw bit (1); dcl control_sw bit (1); dcl db_sw bit (1) init ("0"b); dcl end_of_data bit (1); /* EOD detected bit */ dcl end_of_tape bit (1); /* EOT detected bit */ dcl file_count fixed bin; dcl fileid char (17) varying; dcl fnbr fixed bin; dcl i fixed bin; /* temporary storage */ dcl longinfo char (100) aligned; dcl name char (8) varying; /* command name */ dcl pathname char (168) varying; dcl rcode fixed bin (35); dcl ring_sw bit (1); /* switch to make sure a ring gets in tape mounted for sqi */ dcl (blen, rlen, wlen, b_offset) fixed bin (21); dcl wt_ptr ptr; dcl shortinfo char (8) aligned; dcl ss_atd char (256); dcl ss_iocbp ptr initial (null); dcl ss_open_mode fixed bin; dcl ss_switch char (26); /* file switch name */ dcl tape_iocbp ptr; dcl tape_switch char (26); /* tape_switch name */ dcl tstring char (256) varying; dcl vol_init bit (1); /* ON => develop volume portion of attach desc */ dcl writeff_sw bit (1); dcl zlck bit (1) aligned; dcl cant_cont bit (1) aligned; dcl output bit (1) aligned; /* shorter form of tape_io_data.control.writing */ dcl io_started bit (1) aligned; /* CONSTANTS */ dcl IBMNL fixed bin internal static options (constant) init (3); dcl IBMDOS fixed bin internal static options (constant) init (4); dcl q_mess1 char (57) int static options (constant) init ("ride the control file and read the storage system file as"); dcl q_mess2 char (56) int static options (constant) init ("write this storage system file by changing its format to"); dcl DENSITY (4) char (4) varying internal static options (constant) init ("", "800", "1600", "6250"); dcl FORMAT (11) char (3) varying internal static options (constant) init ("u", "f", "d", "v", "fb", "db", "vb", "s", "sb", "vs", "vbs"); dcl MODE (3) char (8) varying internal static options (constant) init ("ascii", "ebcdic", "binary"); dcl IO_MODULE_NAME (4) char (12) varying internal static options (constant) init ("tape_ansi_", "tape_ibm_", "tape_ibm_", "tape_ibm_"); dcl OUTPUT_MODE (4) char (12) varying internal static options (constant) init (" -extend ", " -modify ", " -generate ", " -create "); dcl sys_info$max_seg_size fixed bin (35) external static; /* maximum segment size in words */ dcl wks_ptr ptr int static init (null); /* I/O buffer pointer */ dcl (tape_attached, tape_opened, ss_file_attached, ss_file_opened) bit (1) aligned int static init ("0"b); dcl cleanup condition; /* ERROR CODES */ dcl error_table_$dirseg fixed bin (35) ext static; dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$eov_on_write fixed bin (35) ext static; dcl error_table_$file_busy fixed bin (35) ext static; dcl error_table_$insufficient_open fixed bin (35) ext static; dcl error_table_$moderr fixed bin (35) ext static; dcl error_table_$no_file fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$short_record fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl addr builtin; dcl fixed builtin; dcl ltrim builtin; dcl min builtin; dcl null builtin; dcl rtrim builtin; dcl substr builtin; /* EXTERNAL PROCEDURES */ dcl com_err_ ext entry options (variable); dcl command_query_ ext entry options (variable); dcl convert_status_code_ ext entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl cu_$cl entry; dcl ioa_ ext entry options (variable); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); 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_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl vfile_status_ entry (char (*), char (*), ptr, fixed (35)); %page; tape_io_data_ptr = arg_tape_io_data_ptr; /* copy arg */ output = tape_io_data.control.writing_tape; /* makes program easier to read */ if output then /* if writing tape, this is tape_out */ name = "tape_out"; else name = "tape_in"; call get_temp_segment_ ((name), wks_ptr, code); /* get a buffer segment */ if code ^= 0 then do; call com_err_ (code, name, "Attempting to get tape I/O buffer segment"); return; end; query_info.version = query_info_version_4; /* set version number */ vfile_info.info_version = 1; /* set vfile_status_ info structure version */ file_count = 0; ss_switch = name || "_" || "ss_file"; /* initialize the SS file switch */ abort_sw, writeff_sw = "0"b; ss_iocbp, tape_iocbp = null; blen = sys_info$max_seg_size * 4; /* set buffer size to max */ ring_sw = output | tape_io_data.control.ring; on cleanup call Cleaner (); /* establish cleanup handler */ do vcb_ptr = first_vcb_ptr repeat vcb.next_vcb_ptr while (vcb_ptr ^= null () & ^abort_sw); vol_init = "1"b; /* set the init flag for each volume-group */ fnbr = 0; /* reset the file number */ tape_switch = name || "_" || vcb.volid (1); do fcb_ptr = vcb.first_fcb_ptr repeat fcb.next_fcb_ptr while (fcb_ptr ^= null () & ^abort_sw); call fcb_worker; /* perform requested io */ end; end; if ^abort_sw then call ioa_ ("^/^a: Completed processing of ^a>^a: ^d ^[file^;files^] transferred.", name, tape_io_data.source.dirname, tape_io_data.source.ename, file_count, (file_count = 1)); call Cleaner (); /* close and detach resources still opened or attached */ return; %page; fcb_worker: procedure; /* performs io */ char_cnt, blockl = 0; end_of_data, abort_sw, control_sw, cont_sw = "0"b;/* (re-) set */ if fcb.tape.file_id ^= "*" then /* set fileid for error msg */ fileid = rtrim (fcb.tape.file_id); else do; /* if name = * then use file number for error msg */ secq = fixed (fcb.tape.sequence); fileid = "#" || ltrim (secq); end; goto FORMAT (fcb.tape.format); /* dispatch on format */ FORMAT (0): /* not specified */ amrl = sys_info$max_seg_size * 4; /* assume the worst */ goto COMMON_WORK; FORMAT (1): /* U */ amrl = fcb.tape.blklen; /* U - try to get blklen characters */ goto COMMON_WORK; FORMAT (2): /* F */ FORMAT (5): /* FB */ amrl = fcb.tape.reclen; /* F or FB - try to get reclen characters */ goto COMMON_WORK; FORMAT (3): /* D */ FORMAT (4): /* V */ FORMAT (6): /* DB */ FORMAT (7): /* VB */ amrl = fcb.tape.reclen - 4; /* D, V, DB or VB - try to get reclen - rcw/rdw characters */ goto COMMON_WORK; FORMAT (8): /* S */ FORMAT (9): /* SB */ FORMAT (10): /* VS */ FORMAT (11): /* VBS */ amrl = min (fcb.tape.reclen, sys_info$max_seg_size * 4); COMMON_WORK: if fcb.segment.dirname = ">" then /* special case the root dir */ pathname = ">" || fcb.segment.ename; else pathname = rtrim (fcb.segment.dirname) || ">" || fcb.segment.ename; if output then call write_tape (); /* tape write logic */ else call read_tape (); /* tape read logic */ if char_cnt = 0 & io_started then /* if no date xfered, tell user */ if output then call ioa_ ("^a: Storage system file ""^a"", transfer to tape file ^a of volume-set ^a has zero length.", name, pathname, fcb.tape.file_id, vcb.volid (1)); else call ioa_ ("^a: Tape file ""^a"" transfer to storage system file ""^a"" has zero length.", name, fileid, pathname); return; /* exit */ end fcb_worker; %page; /* read_tape - subroutine to read tape file into SS file */ read_tape: proc; call check_ss_file; /* check SS file for access and consistency */ call build_tape_attach; /* create tape attach description */ call open_tape_file; /* attach and open tape file */ call open_ss_file; /* attach and open SS file */ /* main processing loop, read tape/write ss file */ do while (^end_of_data & ^abort_sw & ^cont_sw); /* do until no more data */ call iox_$read_record (tape_iocbp, wks_ptr, blen, rlen, code); if code = error_table_$end_of_info then /* EOF detected */ end_of_data = "1"b; /* set terminate condition */ else if code ^= 0 then /* we have a real tape error */ call check_tape_status; /* go report it, and determine what to do */ else do; /* good read, write the data into SS file */ wt_ptr = wks_ptr; /* start at beginning of buffer */ b_offset = 0; if rlen = 0 then /* special case for zero length records */ zlck = "1"b; else zlck = "0"b; /* not a zero length record */ do while ((b_offset < rlen | zlck) & ^abort_sw & ^cont_sw); /* do while data to write */ zlck = "0"b; /* only one iteration for zero length records */ wlen = min (amrl, rlen - b_offset);/* set length of record to write */ ss_wrt_retry: call iox_$write_record (ss_iocbp, wt_ptr, wlen, code); /* write the SS file record */ if code ^= 0 then do; /* if error writing to SS file */ call check_ss_file_status; /* go report it and determine what to do */ if control_sw then /* if user fixed problem */ go to ss_wrt_retry; end; else do; /* no error */ char_cnt = char_cnt + wlen; /* increment file character count */ if fcb.segment.truncate_lines = 2 then /* if user want to chop of line.. */ b_offset = rlen; /* set so we only go through once */ else b_offset = b_offset + wlen; /* increment input record char offset */ wt_ptr = addr (input_record.next_char); /* increment input data ptr */ end; end; end; end; call close_ss_file; /* close and detach SS file */ call close_tape_file (abort_sw); /* close and detach tape file */ end read_tape; %page; /* write_tape - subroutine to write tape file from SS file */ write_tape: proc; call check_ss_file; /* check SS file for access and consistency */ if fcb.tape.sequence = -1 then do; /* if "tape_extend" was specified */ if fnbr = 0 then /* and this is the first attachment for this volume */ call position_to_end; /* position tape to end of last file on tape */ else do; /* otherwise increment the file number */ fnbr = fnbr + 1; fcb.tape.sequence = fnbr; /* set the valid sequence number */ end; end; else fnbr = fnbr + 1; call build_tape_attach; /* create tape attach description */ call open_tape_file; /* attach and open tape file */ call open_ss_file; /* attach and open SS file */ /* main processing loop, read SS file/write tape */ do while (^end_of_data & ^abort_sw & ^cont_sw); /* do until no more data */ ss_rd_retry: call iox_$read_record (ss_iocbp, wks_ptr, blen, rlen, code); if code = error_table_$end_of_info then /* EOF detected */ end_of_data = "1"b; /* set terminate condition */ else if code ^= 0 & code ^= error_table_$short_record then do; /* if some error.. */ call check_ss_file_status; /* go report it, and determine what to do */ if control_sw then /* if user fixed problem */ go to ss_rd_retry; /* go retry read */ end; else do; /* good read, write the date into the tape file */ wt_ptr = wks_ptr; /* start at beginning of buffer */ b_offset = 0; if rlen = 0 then /* special case for zero length records */ zlck = "1"b; else zlck = "0"b; /* not a zero length record */ do while ((b_offset < rlen | zlck) & ^abort_sw & ^cont_sw); /* do while data to write */ zlck = "0"b; /* only one iteration for zero length records */ wlen = min (amrl, rlen - b_offset);/* set length of record to write */ call iox_$write_record (tape_iocbp, wt_ptr, wlen, code); /* write the tape record */ if code ^= 0 then /* if error writing to tape file */ call check_tape_status; /* go report it and determine what to do */ else do; /* no error */ char_cnt = char_cnt + wlen; /* increment file character count */ if fcb.segment.truncate_lines = 2 then /* if user want to chop of line.. */ b_offset = rlen; /* set so we only go through once */ else b_offset = b_offset + wlen; /* increment input record char offset */ wt_ptr = addr (input_record.next_char); /* increment input data ptr */ end; end; end; end; call close_ss_file; /* close and detach SS file */ call close_tape_file (abort_sw); /* close and detach tape file */ end write_tape; %page; /* open_tape_file - procedure to attach and open tape file */ open_tape_file: proc; if abort_sw | cont_sw then return; /* if a bad error has already ocurred, bail out */ code = 0; do while (code = 0 & ^tape_opened); call iox_$attach_name (tape_switch, tape_iocbp, (tape_attach_descp.string), null, code); if code ^= 0 then do; /* attach failed */ call com_err_ (code, name, " Unable to attach tape file ^a of volume-set ^a. Attach description is: ""^a""", fileid, vcb.volid (1), tape_attach_descp.string); call cntl_cont_abort ("0"b); return; end; tape_attached = "1"b; /* set flag for cleanup handler */ if output then /* tape_out command: users want to write to the tape */ call iox_$open (tape_iocbp, Sequential_output, "0"b, code); /* open for output */ else /* tape_in command: users want to read from tape files */ call iox_$open (tape_iocbp, Sequential_input, "0"b, code); /* open for input */ if code = 0 then tape_opened = "1"b; /* set flag for cleanup handler */ else do; /* open failed */ if code = error_table_$insufficient_open then do; /* special case of tape_in command. */ if add_specified_attributes then do; /* because the tape doesn't contain info, */ /* so add info from TCL file. Then try to attach and open again */ call iox_$detach_iocb (tape_iocbp, (0)); call ioa_ (" tape_in: WARNING because the volume name ""^a"" cannot be read as recorded, the structure attributes specified in the TCL file will be used.", vcb.volid (1)); recl = fixed (fcb.tape.reclen); tape_attach_descp.string = tape_attach_descp.string || " -record " || ltrim (recl) || " -block " || ltrim (blkl) || " -format " || FORMAT (fcb.tape.format); add_specified_attributes = "0"b; code = 0; end; end; if code ^= 0 then do; call com_err_ (code, name, " Unable to open tape file ^a of volume-set ^a for ^[output^;input^]. Attach description is: ""^a""", fileid, vcb.volid (1), output, tape_attach_descp.string); call cntl_cont_abort ("0"b); return; end; end; end; end open_tape_file; %page; /* close_tape_file - procedure to close and detach tape file */ close_tape_file: proc (force_detach); dcl force_detach bit (1) aligned; if tape_opened then do; /* if the tape was opened, close it */ /* see if any more this volume. If not, or if cleanup, take down tape */ if fcb.next_fcb_ptr = null | force_detach then call iox_$control (tape_iocbp, "retain_none", null, (0)); /* cause tape to be demounted */ call iox_$close (tape_iocbp, (0)); /* close the file */ tape_opened = "0"b; /* reset flag */ end; if tape_attached then do; /* if the tape was attached, detach it */ call iox_$detach_iocb (tape_iocbp, (0)); file_count = file_count + 1; /* increment file count */ tape_attached = "0"b; /* reset flag */ end; end close_tape_file; %page; /* open_ss_file - procedure to attach and open storage system file */ open_ss_file: proc; if abort_sw | cont_sw then return; /* if a bad error has already ocurred, bail out */ if fcb.segment.format = 1 then /* if stream file, use record_stream_ */ ss_atd = "record_stream_ -target vfile_ " || pathname; /* to convert stream <--> record */ else ss_atd = "vfile_ " || pathname; /* structured file, attach vfile_ directly */ if fcb.segment.extend = 2 then /* if extending existing SS file */ ss_atd = rtrim (ss_atd) || " -extend"; /* put it in attach desc */ control_sw = "1"b; /* allow at least one iteration */ do while (control_sw); control_sw = "0"b; call close_ss_file; /* make sure file switch is closed/detached first */ call iox_$attach_name (ss_switch, ss_iocbp, ss_atd, null, code); /* attach SS file */ if code ^= 0 then do; call com_err_ (code, name, " Unable to attach storage system file ""^a"" for ^[input^;output^] (file ^a of volume-set ^a). Attach description is: ""^a"".", pathname, output, fileid, vcb.volid (1), ss_atd); call cntl_cont_abort ("1"b); /* go ask user what to do */ if ^control_sw then return; /* give up */ end; else do; /* attempt opening if no errors */ ss_file_attached = "1"b; /* set flag for cleanup handler */ if output then /* if writing tape/reading ss file */ ss_open_mode = Sequential_input; else ss_open_mode = Sequential_output; /* reading tape/writing ss file */ call iox_$open (ss_iocbp, ss_open_mode, "0"b, code); /* open storage file for write */ if code ^= 0 then do; call com_err_ (code, name, " Unable to open storage system file ""^a"" for ^a (file ^a on volume-set ^a). Attach description is: ""^a"".", pathname, iox_modes (ss_open_mode), fileid, vcb.volid (1), ss_atd); call cntl_cont_abort ("1"b); if ^control_sw then return; end; else do; ss_file_opened = "1"b; /* set flag for cleanup handler, if no errors */ io_started = "1"b; /* I/O ready to start */ end; end; end; end open_ss_file; %page; /* check_ss_file - procedure to check storage system file for access etc. */ check_ss_file: proc; io_started = "0"b; /* No I/O started yet */ control_sw = "1"b; /* allow at least one iteration */ do while (control_sw); control_sw = "0"b; query_info.yes_or_no_sw = "1"b; call vfile_status_ ((fcb.segment.dirname), (fcb.segment.ename), addr (vfile_info), code); if code ^= 0 then do; if code = error_table_$moderr then call com_err_ (code, name, " Storage system file ""^a"" has incorrect access for status check.", pathname); else if code = error_table_$dirseg then call com_err_ (code, name, " Storage system file ""^a"" is a directory.", pathname); else if code = error_table_$noentry then/* if file does not exist */ if output then /* if writing tape/reading ss file */ call com_err_ (code, name, " Storage system file ""^a"" does not already exist.", pathname); else if fcb.segment.extend = 2 then/* cannot extend non-existant file */ call com_err_ (code, name, " Cannot extend storage system file, ""^a"", as it does not already exist.", pathname); else return; /* return, no problems */ else call com_err_ (code, name, " Cannot get status of storage system file ""^a"".", pathname); go to ask_user; /* see what user wants to do */ end; if ^output & fcb.segment.extend ^= 2 then do;/* reading tape/writing SS file */ call command_query_ (addr (query_info), answer, name, "Storage system file ""^a"" already exists.^/Do you wish to overwrite it? ", pathname); if answer = "no" then go to ask_user; /* go ask user what to do */ end; if vfile_info.type = 1 then do; /* unstructured file */ if fcb.segment.format = 2 then do; /* error if specified structured file */ call ioa_ ("^a: Storage system file ""^a"" exists as an unstructured file.", name, pathname); call command_query_ (addr (query_info), answer, name, "Do you wish to over^[^a unstructured^s^;^s^a structured^]? ", output, q_mess1, q_mess2); if answer = "yes" then do; if output then /* if writing tape/reading SS file */ fcb.segment.format = 1; else if fcb.segment.extend = 2 then /* if reading tape/writing SS file */ fcb.segment.extend = 1; /* change file format by creating new file */ end; else go to ask_user; /* no, go see what user wants to do */ end; end; else if vfile_info.type = 2 then do; /* sequential file */ if vfile_info.flags.lock_status ^= "00"b then do; code = error_table_$file_busy; call com_err_ (code, name, " Storage system file, ""^a"", is locked.", pathname); go to ask_user; /* go see what user wants to do */ end; if fcb.segment.format ^= 2 then do; /* error if specified unstructured file */ call ioa_ ("^a: Storage system file ""^a"" already exists as a sequential file.", name, pathname); call command_query_ (addr (query_info), answer, name, "Do you wish to over^[^a sequential^s^;^s^a unstructured^]? ", output, q_mess1, q_mess2); if answer = "yes" then do; if output then /* if writing tape/reading SS file */ fcb.segment.format = 2; else if fcb.segment.extend = 2 then /* if reading tape/writing SS file */ fcb.segment.extend = 1; /* change file format by creating new file */ end; else go to ask_user; /* no, go see what user wants to do */ end; end; else do; /* error-- no other types supproted */ call com_err_ (0, name, " Storage system file ""^a"" is not unstructured or sequential.", pathname); ask_user: call cntl_cont_abort ("1"b); /* see what user wnats to do */ if ^control_sw then return; end; end; end check_ss_file; /* Cleaner - procedure to close and detach resources when processing completed or on a cleanup condition */ Cleaner: proc; if wks_ptr ^= null then do; /* if we have a buffer segment assigned.. */ call release_temp_segment_ ((name), wks_ptr, (0)); /* release it */ wks_ptr = null; /* reset the ptr */ end; call close_ss_file; /* close and detach Storage system file */ call close_tape_file ("1"b); /* close and demount tape volume */ end Cleaner; /* close_ss_file - procedure to close and detach storage system file */ close_ss_file: proc; if ss_file_opened then do; /* if the file is opened.. */ call iox_$close (ss_iocbp, (0)); /* close it unconditionaly */ ss_file_opened = "0"b; /* and reset flag */ end; if ss_file_attached then do; /* if the file is attached.. */ call iox_$detach_iocb (ss_iocbp, (0)); /* detach it unconditionaly */ ss_file_attached = "0"b; /* and reset flag */ end; end close_ss_file; %page; /* check_ss_file_status - procedure to check storage system file status errors */ check_ss_file_status: proc; call com_err_ (code, name, " Error ^[reading from^;writing to^] storage system file ""^a"" (file ^a of volume-set ^a).", output, pathname, fileid, vcb.volid (1)); call cntl_cont_abort ("1"b); end check_ss_file_status; /* check_tape_status - procedure to check tape errors */ check_tape_status: proc; end_of_data = "1"b; /* Will not continue I/O on this tape volume */ call iox_$control (tape_iocbp, "file_status", addr (atfs), rcode); if atfs.state > 0 then blockl = atfs.cur_blkcnt; if code = error_table_$eov_on_write then do; /* End-of-Tape has been detected */ char_cnt = char_cnt + rlen; /* add chars which were output to total count. */ call com_err_ (0, name, " End-of-Tape detected while writing tape file ^a of volume-set ^a (storage system file ""^a""). ^d characters have been written to ^d blocks.", fileid, vcb.volid (1), pathname, char_cnt, blockl); end_of_tape = "1"b; /* indicate we had EOT condition */ end; /* format: off */ else call com_err_ (code, name, " Error while ^[writing^;reading^] tape file ^a of volume set ^a (storage system file ""^a""). ^d characters have been ^[written to^;read from^] ^d blocks. The volume-set will be detached.", output, fileid, vcb.volid (1), pathname, char_cnt, output, blockl); /* format: on */ call error_report; /* go give the user the real status */ call cntl_cont_abort ("0"b); /* ask user what he wants to do */ end check_tape_status; %page; /* internal procedure to move tape to end of files for appending a new file */ /* enter here if fcb.tape.sequence = -1 and fnbr = 0 */ position_to_end: procedure; if abort_sw | cont_sw then return; /* if a bad error has already ocurred, bail out */ do fnbr = 1 by 1; secq = fixed (fnbr); /* file number as char string */ call build_tape_attach; /* go build positioning attach desc */ if writeff_sw then writeff_sw = "0"b; /* cant write 1st file as file 1 in append mode */ call iox_$attach_name (tape_switch, tape_iocbp, (tape_attach_descp.string), null, rcode); if rcode ^= 0 then do; /* unable to attach tape file */ bad_position: call com_err_ (rcode, name, " Error while positioning to append to volume-set. Attach description is: ""^a""", tape_attach_descp.string); call error_report; call cntl_cont_abort ("0"b); fnbr = 0; return; end; call iox_$open (tape_iocbp, Sequential_input, "0"b, rcode); /* open tape file for read */ if rcode = error_table_$no_file then fcb.tape.sequence = fnbr; /* this is the file number we will use to append as */ else if rcode ^= 0 then goto bad_position; call iox_$close (tape_iocbp, rcode); /* close the tape file */ call iox_$detach_iocb (tape_iocbp, rcode); if rcode ^= 0 then /* error closing or detaching */ go to bad_position; if fcb.tape.sequence ^= -1 then do; rcode = 0; call ioa_ ("^a: Tape file ""^a"" will be appended as file #^d", name, fileid, fnbr); return; end; end; end position_to_end; /* error_report - procedure to report the hardware status in English */ error_report: proc; call iox_$control (tape_iocbp, "status", addr (ads), code); if code = 0 then do; call ioa_ ("^/^a: Description of error follows: ^/", name); do i = 1 to ads.n_minor; /* loop and print all minor status codes */ call convert_status_code_ (ads.minor (i), shortinfo, longinfo); call ioa_ ("^a^/", longinfo); end; end; end error_report; %page; build_tape_attach: procedure; add_specified_attributes = "1"b; if abort_sw | cont_sw then return; /* if a bad error has already ocurred, bail out */ tstring = ""; /* initialize */ if vol_init then do; /* only do this once per */ if output then if fcb.tape.sequence = 0 then writeff_sw = "1"b; tstring = IO_MODULE_NAME (vcb.tape_type); do i = 1 to vcb.nvols; /* up to vcb.nvols volumes per set allowed */ if substr (vcb.volid (i), 1, 1) = "-" then do; tstring = tstring || " " || "-volume " || rtrim (vcb.volid (i)); end; else tstring = tstring || " " || rtrim (vcb.volid (i)); if vcb.comment (i) ^= " " then tstring = tstring || " -comment " || requote_string_ (rtrim (vcb.comment (i))); end; tstring = tstring || " -density " || DENSITY (vcb.density); if vcb.tape_type = IBMNL then tstring = tstring || " -no_labels"; else if vcb.tape_type = IBMDOS then tstring = tstring || " -dos"; vol_init = "0"b; /* reset for rest of */ tape_attach_descp.vol_string = tstring; /* copy volume portion of attach desc. */ end; tstring = " -retain all"; /* keep volume mounted between attachments */ if writeff_sw then do; /* set up so 1st file written will be file 1 on the tape */ fcb.tape.sequence = 1; /* will start at file 1 on tape */ secq = fixed (fcb.tape.sequence); writeff_sw = "0"b; /* reset so we don't come back */ end; if ring_sw then /* if writing or "-ring" control arg */ tstring = tstring || " -ring"; if fcb.tape.sequence = -1 then /* if tape positioning required.. */ tstring = tstring || " -number " || secq; else do; /* no tape positioning required */ if fcb.tape.cmode > 0 then tstring = tstring || " -mode " || MODE (fcb.tape.cmode); if fcb.tape.file_id ^= "*" then /* start options check now */ tstring = tstring || " -name " || rtrim (fcb.tape.file_id); if fcb.tape.sequence > 0 then do; secq = fixed (fcb.tape.sequence); tstring = tstring || " -number " || ltrim (secq); end; blkl = fixed (fcb.tape.blklen); /* convert block length to char data */ if output | vcb.tape_type = IBMNL | vcb.tape_type = IBMDOS then do; /* don't set for input on SL tapes */ if fcb.tape.reclen > 0 then do; /* set up the real attach desc. */ recl = fixed (fcb.tape.reclen); tstring = tstring || " -record " || ltrim (recl); end; if fcb.tape.blklen > 0 then tstring = tstring || " -block " || ltrim (blkl); if fcb.tape.format > 0 then tstring = tstring || " -format " || FORMAT (fcb.tape.format); add_specified_attributes = "0"b; end; else if fcb.tape.blklen > 8192 then /* unless large block wanted */ tstring = tstring || " -block " || ltrim (blkl); if output then do; /* only add output options if writing tape */ if tape_io_data.control.force then tstring = tstring || " -force "; if fcb.tape.expiration ^= "" then tstring = tstring || " -expires " || fcb.tape.expiration; if fcb.tape.replace_id ^= "" then tstring = tstring || " -replace " || fcb.tape.replace_id; if fcb.tape.output_mode > 0 then tstring = tstring || OUTPUT_MODE (fcb.tape.output_mode); end; end; tape_attach_descp.file_string = tstring; tape_attach_descp.string = tape_attach_descp.vol_string || tape_attach_descp.file_string; if db_sw then call ioa_ ("Attach desc: ""^a""", tape_attach_descp.string); end build_tape_attach; %page; /* internal procedure to help user direct the processing of his control file after the occurrence of an error or other interruption in execution. */ cntl_cont_abort: procedure (idx); dcl idx bit (1) aligned; query_info.yes_or_no_sw = "0"b; /* not looking for yes or no answer */ abort_sw, control_sw, cont_sw = "0"b; /* reset switches */ cant_cont = (fcb.next_fcb_ptr = null & vcb.next_vcb_ptr = null); /* determine if continuation is possible */ if ^idx then /* if not control option and */ if cant_cont then do; /* no file/volume groups left to process */ abort_sw = "1"b; /* the only possible action is to abort */ call ioa_ ("^a: Control file exhausted, aborting.", name); return; end; call ioa_ ("^a: Do you wish to ^[^a^[,^] ^;^2s^]^[^[^/^-^]^a ^]or abort the control file?", name, idx, "control the process", (idx & ^cant_cont), ^cant_cont, (idx & ^cant_cont), "continue to the next "); ASK1: call command_query_ (addr (query_info), answer, name, "Please answer either ^[""control"", ^]^[""continue"", ^]or ""abort"":", idx, ^cant_cont); if answer = "control" & idx then do; call ioa_ ("^a: You may now take action to correct the problem.^/^a", name, "Type ""start"" (or ""sr""), when you are ready to resume operations."); control_sw = "1"b; call cu_$cl (); /* pass control to get_to_cl_$unclaimed_signal */ end; else if answer = "continue" & ^cant_cont then cont_sw = "1"b; else if answer = "abort" then abort_sw = "1"b; else go to ASK1; end cntl_cont_abort; %page; %include tape_file_status; %page; %include tape_io_data; %page; %include device_status; %include iox_modes; %page; %include query_info_; end tape_io_interpret_; 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