ansi_tape_io_.pl1 03/10/00 1540.4rew 03/10/00 1540.4 606213 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-06-07,GWMay), approve(85-06-07,MECR0125), audit(85-06-07,GDixon), install(): modified entry SETUP_NEW_FILE to call pfm_utils_$position_in_file to position to the beginning of the headers where it had previously positioned back one file. 2) change(85-10-24,GWMay), approve(85-10-24,MCR7256), audit(85-12-16,GDixon), install(85-12-17,MR12.0-1001): Formally install changes in MECR0125. Added use of the maxlength and substr functions and changed field sizes where possible to eliminate stringsize errors. 3) change(87-08-17,GWMay), approve(87-09-09,MECR0006), audit(87-09-04,Farley), install(87-09-09,MR12.1-1101): Removed set density call that was moved within mtape_. 4) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley), install(87-11-30,MR12.2-1006): Formally install MECR0006. 5) change(88-02-03,GWMay), approve(88-02-03,MCR7837), audit(88-04-12,Farley), install(88-04-19,MR12.2-1039): Changed to process user specified labels correctly. Changed to correctly set the RCP auth code in the header. 6) change(88-11-15,Farley), approve(88-11-16,MECR0004), audit(88-11-15,Beattie), install(88-11-16,MR12.2-1216): Changed to use the ANSI_L2_ID array for checking the ansi_hdr2 label_id, in the decode_file_labels entry. The check was using "ANSI_L1_IS(ANSI_HDR2)", which was never allowing the "HDR2" code to execute. 7) change(88-11-23,Farley), approve(88-12-14,MCR8031), audit(89-05-15,Parisek), install(89-05-16,MR12.3-1045): Official mr12.3 installation of previous change, MECR0004, for mr12.2. 8) change(00-01-26,Schroth), approve(00-01-26,MECR-Y2K): Changed expiry date checking to use new pfm_utils_$label_unexpired to verify if a file has expired. 9) change(00-03-10,Schroth), approve(00-03-10,MECR-MTAPE-LBLS): Added code to decode_file_labels to properly process pre-mtape_ ANSI HDR2 labels. END HISTORY COMMENTS */ ansi_tape_io_: procedure; /* format: style4 */ /* * This program is known as a tape Per-Format module and runs under * control of the mtape_ I/O module and is meant to process tape volumes * and files in ANSI standard format. * * This Per-Format module uses the following PFM dependent option flags: * * mtape_open_info.pfm_opt_sw (1) = "1"b = -generate * mtape_open_info.pfm_opt_sw (1) = "0"b = -no_generate * mtape_open_info.pfm_opt_sw (2) = "1"b = -buffer_offset * mtape_open_info.pfm_opt_sw (2) = "0"b = -no_buffer_offset * * Modification History: * * Created by J. A. Bush 11/01/82 * Modified by J. A. Bush 11/10/83 for performance improvements */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to the mtape data structure */ dcl arg_code fixed bin (35); /* Return error code */ dcl arg_info_ptr ptr; /* Pointer to Order data from iox_$control call */ dcl arg_io_call_infop ptr; /* Pointer to io_call control info structure */ dcl arg_order_name char (*); /* Name of Control order to be processed */ dcl arg_lr_ptr ptr; /* Pointer to current label record structure */ dcl arg_labno fixed bin; /* label record within label group */ dcl arg_type fixed bin; /* 1 => BOF; 2 => EOV; 3 => EOF */ dcl arg_convert fixed bin; /* Label record conversion indicator */ /* AUTOMATIC DATA */ dcl Schecked_labels bit (1) aligned; dcl buf_ptr ptr; /* Auto copy of users buffer pointer */ dcl buf_len fixed bin (21); /* Auto copy of users lrec buffer */ dcl rec_len fixed bin (21); /* Auto copy of logical record length */ dcl order_name char (32); /* Auto copy of order name */ dcl info_ptr ptr; /* Auto copy of order info pointer */ dcl install_id char (32); dcl user_label_data char (76); /* storage for user label data */ dcl auth_code char (3) aligned; dcl today char (6); dcl temp_fmt char (3); dcl temp_mode char (6); dcl (term, long_record, output) bit (1) aligned; dcl (nvp, nlp, move_ptr) ptr; dcl (i, desc_type, label_type, n_segs, uln, open_idx) fixed bin; dcl (move_len, crl, bytes_remaining, bytes_processed) fixed bin (21); dcl pic1 picture "9"; dcl pic2 picture "99"; dcl pic4 picture "9999"; dcl pic5 picture "99999"; dcl pic6 picture "999999"; dcl (code, fl_code) fixed bin (35); /* CONSTANT DATA */ dcl myname char (32) int static options (constant) init ("ansi_tape_io_"); dcl LABEL_LENGTH fixed bin (21) int static options (constant) init (80); /* length of label records in bytes */ dcl MAX_ANSI_RECORD_SIZE fixed bin int static options (constant) init (99999); dcl WRITING bit (1) aligned int static options (constant) init ("1"b); dcl OPENING bit (1) aligned int static options (constant) init ("0"b); dcl NON_MOD_FOUR fixed bin int static options (constant) init (1); dcl ANSI_ASCII_PAD_CHAR char (1) int static options (constant) init ("^"); dcl ANSI_EBCDIC_PAD_CHAR char (1) int static options (constant) init ("_"); dcl RCW_LENGTH fixed bin int static options (constant) init (4); /* Length of an RCW */ dcl SCW_LENGTH fixed bin int static options (constant) init (5); /* Length of an SCW */ dcl (SEG_B_E init (0), /* Record begins and ends in this segment */ SEG_B_NE init (1), /* Record begins but does not end in this segment */ SEG_NB_NE init (2), /* Record neither begins nor ends in this segment */ SEG_NB_E init (3)) /* Record ends but does not begin in this segment */ fixed bin int static options (constant); dcl DUMMY_LABEL char (76) int static options (constant) init /* dummy HDR1/EOF1 label, used for volume init */ ("!!DUMMY FILE ID!!******00010001000100 00000 00000 000000MULTICS ANSI2 "); dcl U_LABEL_ID (3) char (3) int static options (constant) init ("UHL", "UTL", "UTL"); dcl ANSI_FORMAT_CODES (0:7) char (3) int static options (constant) init (" ", "U ", "F ", "D ", "S ", "FB ", "DB ", "SB "); dcl LC char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl UC char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); /* EXTERNAL STATIC DATA */ 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_$long_record fixed bin (35) ext static; dcl error_table_$invalid_record_desc fixed bin (35) ext static; dcl error_table_$bad_file fixed bin (35) ext static; dcl error_table_$no_operation fixed bin (35) ext static; dcl error_table_$no_file fixed bin (35) ext static; dcl error_table_$no_next_volume fixed bin (35) ext static; dcl error_table_$data_seq_error fixed bin (35) ext static; dcl error_table_$invalid_file_set_format fixed bin (35) ext static; dcl error_table_$invalid_label_format fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$uninitialized_volume fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (addr, binary, copy, divide, fixed, hbound, index, lbound, length, maxlength, mod, null, rel, rtrim, size, substr, translate, verify) builtin; dcl conversion condition; dcl illegal_procedure condition; /* EXTERNAL ENTRIES */ dcl system_info_$installation_id entry (char (*)); dcl get_group_id_ entry () returns (char (32)); dcl authenticate_ entry (char (*)) returns (char (3) aligned); dcl ebcdic_to_ascii_ entry (char (*), char (*)); dcl ascii_to_ebcdic_ entry (char (*), char (*)); /* BASED VARIABLES */ dcl based_area area based (mtape_data.areap); dcl based_label_record char (LABEL_LENGTH) based (mtape_label_record.lab_ptr); dcl based_lrec_data char (move_len) based; /* to move data to/from users buffer */ dcl based_lrec_index (buf_len) char (1) based (mtape_data.arg_buf_ptr); /* to increment users buffer ptr */ dcl tblock char (mtape_data.length) unaligned based (mtape_data.cur_buf_ptr); /* block as char string */ dcl 1 native_bo_contents based (mtape_data.cur_buf_ptr), /* template for native buffer offset */ (2 block_size fixed dec (7, 0), /* size of block in bytes (including buffer offset) */ 2 block_number fixed dec (7, 0)) unaligned; /* block in current file (section), from 1 */ dcl 1 db_record unaligned based (mtape_data.log_record_ptr), /* Template for D/DB formated records */ 2 rcw char (4), /* record control word (length) */ 2 rdata char (move_len), /* logical record data */ 2 nxt_lrec char (1); /* to position to nxt record */ dcl 1 sb_record unaligned based (mtape_data.log_record_ptr), /* Template for S/SB formated records */ 2 scw, /* Segment control word */ 3 span_indicator char (1), /* controls of segments in record */ 3 rec_len char (4), /* length of logical record segment */ 2 rdata char (move_len), /* logical record data */ 2 nxt_lrec char (1); /* to position to nxt record */ %page; /* pfm_init - entry to initialize the Per-Format module, setting up file and volume processing parameters and determining correctness of current volume */ pfm_init: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ call CHECK_VERSION (mtdp, mtape_data_version_1, "mtape_data"); /* check version of this structure every time */ /* When the pfm_init entry is called for the first time we must allocate a label record structure to read tape labels into. We must also check the various structure versions to make sure we know what the caller is talking about. */ if mtape_data.tlb = null then do; mcip = mtape_data.close_info_ptr; /* set ptr to close into structure */ call pfm_utils_$init_label_record (mtdp, null, null, mtape_data.tlb, LABEL_LENGTH); call CHECK_VERSION (mtape_data.tlb, mtape_lr_version_1, "mtape_label_record"); call CHECK_VERSION (vs_ptr, mtape_vs_version_1, "mtape_vol_set"); call CHECK_VERSION (maip, mtape_attach_info_version_1, "mtape_attach_info"); call CHECK_VERSION (moip, mtape_open_info_version_1, "mtape_open_info"); call CHECK_VERSION (mcip, mtape_close_info_version_1, "mtape_close_info"); call CHECK_VERSION (mpfmip, mtape_pfm_info_version_1, "mtape_pfm_info"); call mtape_$alloc (mtdp, MTAPE_ALLOC_FI, null, 0, fi_ptr); /* allocate dummy file_info structure */ call CHECK_VERSION (fi_ptr, mtape_fi_version_1, "mtape_file_info"); /* and check its version */ free mtape_file_info in (based_area); /* we can free it now */ /* initialize the pfm_info structure for this PFM */ mtape_pfm_info.open_modes_allowed (1) = Sequential_input; mtape_pfm_info.open_modes_allowed (2) = Sequential_output; mtape_pfm_info.bof_prefix = "HDR"; mtape_pfm_info.eov_prefix = "EOV"; mtape_pfm_info.eof_prefix = "EOF"; mtape_pfm_info.module_id = "ANSI"; mtape_pfm_info.no_labels_ok = "0"b; mtape_pfm_info.multi_volumes_ok = "1"b; mtape_pfm_info.extended_error_recovery = "0"b; end; if mtape_vol_set.volume_type = Volume_ansi_tape then /* If an ansi tape.. */ call CHECK_VOL_LABELS (mtape_vol_set.volume_check); /* check the volume labels */ else do; /* Not an ansi tape, don't bother to read labels */ if mtape_vol_set.volume_type = Volume_blank | mtape_vol_set.volume_type = Volume_unreadable then mtape_vol_set.volume_check = BLANK_VOLUME; else if mtape_vol_set.volume_type = Volume_unknown_format then mtape_vol_set.volume_check = UNLABELED_VOLUME; else mtape_vol_set.volume_check = RECOG_FORMAT_VOLUME; mtape_data.lab_buf_len = LABEL_LENGTH; /* set in case subsequent volumes are labeled */ end; pfm_init_return: /* target of non-local gotos */ arg_code = code; return; %page; /* file_open - entry to do format specific processing in opening the file or file set (i.e. read and write file labels) */ file_open: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ call SET_OPEN_IDX; /* determine what type of processing to do */ call pfm_utils_$file_search (mtdp, fi_ptr, vs_ptr, code); /* search for the file */ if code ^= 0 & open_idx ^= 1 then /* if error and not creating file.. */ go to open_return; /* quit now */ go to open_action (open_idx); /* do the appropriate thing */ open_action (0): /* open for input */ call CHECK_USER_LABELS (BOF_LABEL); /* go see if user labels to be processed */ call SET_FILE_ATTRIBUTES; /* complete file attributes from open desc */ go to open_return; open_action (1): /* Open for output, creation */ if code = 0 | /* if no error */ code = error_table_$no_file | /* or if could not find file */ code = error_table_$uninitialized_volume then do; /* or if bad vol label */ if NEED_TO_INIT_VOLUME () then do; /* if volume requires initialization.. */ call INIT_VOL_LABELS; /* initialize the volume labels */ if code ^= 0 then go to open_return; end; code = 0; /* reset possible error code */ call SETUP_NEW_FILE; /* setup new file info structure */ if code ^= 0 then go to open_return; call pfm_utils_$write_file_labels (mtdp, BOF_LABEL, code); /* go write the file header labels */ if code = 0 then /* if no error */ if mtape_vol_set.volume_end then /* did we run out of tape? */ call EOV_ON_WRITE (OPENING); /* yes, do volume switch now */ end; go to open_return; open_action (2): /* open for output, extend existing file */ mtape_data.phy_block = mtape_file_info.block_count; /* preset block number */ open_action (3): /* open for output, modify existing file */ call pfm_utils_$truncate_file_set (mtdp); /* get rid of EOF labels if extend | modify */ mtape_file_info.gen_version = mod (mtape_file_info.gen_version, 100) + 1; /* increment version */ go to open_return; open_action (4): /* open for output, generate file */ call pfm_utils_$truncate_file_set (mtdp); /* get rid of EOF labels */ mtape_file_info.generation = mod (mtape_file_info.generation, 10000) + 1; /* increment generation number */ call pfm_utils_$write_file_labels (mtdp, BOF_LABEL, code); /* go write the file header labels */ if code = 0 then /* if no error */ if mtape_vol_set.volume_end then /* did we run out of tape? */ call EOV_ON_WRITE (OPENING); /* yes, do volume switch now */ open_return: arg_code = code; /* return error code */ return; %page; /* file_close - entry to do format specific processing in closing the file or file set (i.e. read and write file trailer labels) */ file_close: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ mcip = mtape_data.close_info_ptr; /* set up close info ptr too */ if mtape_open_info.open_mode = Sequential_input then /* input operation? */ output = "0"b; /* yes, reset output flag */ else output = "1"b; /* true if sqo or sqio */ if output & mtape_data.error_lock ^= error_table_$no_next_volume then do; /* if writing tape */ if mtape_data.error_lock = 0 then do; /* flush out only if possible */ if mtape_data.processed > mtape_data.buffer_offset then /* if we have some unwritten data */ call WRITE_BLOCK; /* write a short block */ call mtape_$flush_buffers (mtdp, code); /* write out all queued buffers */ if code ^= 0 then /* if some error writing data */ if code = error_table_$eov_on_write then /* Is it end of tape? */ call EOV_ON_WRITE (WRITING); /* Go close out volume and initiate volume switch */ if code ^= 0 then go to close_file_return; end; call pfm_utils_$write_file_labels (mtdp, EOF_LABEL, code); /* write out EOF labels */ if code ^= 0 then /* error writing labels.. */ go to close_file_return; end; else do; /* input operation, must make sure tape is stoped */ call mtape_$stop_tape (mtdp, code); if code ^= 0 then go to close_file_return; end; Schecked_labels = "0"b; /* USER trailers can only be returned when */ /* positioned after the file data */ if ^output & mtape_file_info.position_within_file = AT_EOF then do; call CHECK_USER_LABELS (EOF_LABEL); /* go see if user labels to be processed */ Schecked_labels = "1"b; end; if mtape_close_info.position ^= 0 then do; /* if not leaving tape where it is.. */ call pfm_utils_$position_in_file (mtdp, fi_ptr, vs_ptr, mtape_close_info.position, code); if ^output & code = 0 & ^Schecked_labels & mtape_file_info.position_within_file = AT_EOFH then call CHECK_USER_LABELS (EOF_LABEL); end; close_file_return: arg_code = code; /* copy return error code (if any) */ return; %page; /* read - entry to read format specific logical records from the current file */ read: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; /* If = null, return length of next record */ buf_len = mtape_data.arg_buf_len; code, rec_len = 0; /* initialize return record length */ long_record = "0"b; /* init long record flag */ if mtape_data.remain <= 0 then /* Do we need to read in a block? */ call GET_NXT_RECORD; /* yes, do it */ go to READ_TYPE (mtape_data.ad_file_format); /* process depending on file format */ READ_TYPE (1): /* Process "U" formated records */ crl, move_len = mtape_data.remain; /* user gets entire block */ move_ptr = mtape_data.log_record_ptr; /* set pointer to move data from */ call MOVE_TO_USER; /* move the data to the users buffer */ go to read_return; READ_TYPE (2): /* Process "F/FB" formated records */ if mtape_data.record_size > mtape_data.remain then/* don't try to move more than we have */ crl = mtape_data.remain; else crl = mtape_data.record_size; move_len = crl; move_ptr = mtape_data.log_record_ptr; /* set pointer to move data from */ call MOVE_TO_USER; /* give the user his data */ go to read_return; READ_TYPE (3): /* Process "D/DB" formated records */ if mtape_data.remain < RCW_LENGTH then /* in case we have mod 4 padded block */ call GET_NXT_RECORD; /* go read next block */ do while (tape_blk (mtape_data.processed + 1) = mtape_data.padding_char); call GET_NXT_RECORD; /* if rcw is pad, get next block */ end; on conversion call INV_DESC; /* if error converting rcw */ crl = binary (db_record.rcw, 21); /* compute record length */ revert conversion; /* revert conversion condition handling */ move_len = crl - RCW_LENGTH; move_ptr = addr (db_record.rdata); /* set pointer to move data from */ call MOVE_TO_USER; /* give the user his data */ go to read_return; %page; READ_TYPE (4): /* Process "S/SB" formated records */ if mtape_data.remain < SCW_LENGTH then /* in case we have mod 4 padded block */ call GET_NXT_RECORD; /* go read next block */ term = "0"b; /* reset terminate condition */ on conversion call INV_DESC; /* establish on unit for converting seg descriptors */ do n_segs = 1 by 1 while (^term); /* 1 record may be made up of several segments and blocks */ call CONVERT_DESC; /* convert segment descriptor */ if n_segs = 1 then /* if first pass through */ do while (desc_type ^= SEG_B_E & desc_type ^= SEG_B_NE); /* make sure we get new record */ mtape_data.remain = mtape_data.remain - crl; mtape_data.log_record_ptr = addr (sb_record.nxt_lrec); if mtape_data.remain <= 0 then /* Do we have to read in a new block? */ call GET_NXT_RECORD; call CONVERT_DESC; end; move_ptr = addr (sb_record.rdata); /* set ptr to move data */ call MOVE_TO_USER; /* give the user his data */ if desc_type = SEG_B_E | desc_type = SEG_NB_E then /* end of the record? */ term = "1"b; /* yes, set terminate condition */ else if mtape_data.remain <= 0 then /* No, New segment in next block? */ call GET_NXT_RECORD; /* yes, do it */ end; revert conversion; read_return: mtape_data.arg_rec_len = rec_len; /* give the user the length of the record */ if code = 0 then /* if no error but.. */ if long_record then /* we had a longer record than the users buffer */ code = error_table_$long_record; /* tell him about it */ arg_code = code; /* return error code */ return; %page; /* write - entry to write format specific logical records into the current file */ write: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* Copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; buf_len = mtape_data.arg_buf_len; code = 0; if buf_ptr = null then do; /* User wants to flush out buffers */ if mtape_data.processed > mtape_data.buffer_offset then /* if we have some unwritten data */ call WRITE_BLOCK; /* write a short block */ call mtape_$flush_buffers (mtdp, code); /* write out all queued buffers */ if code ^= 0 then /* if some error writing data */ if code = error_table_$eov_on_write then do; /* Is it end of tape? */ call LOAD_PTRS; /* load up structure pointers */ call EOV_ON_WRITE (WRITING); /* Go close out volume and initiate volume switch */ end; go to write_return; /* return to user */ end; go to WRITE_TYPE (mtape_data.ad_file_format); /* process depending on file format */ WRITE_TYPE (1): /* Write "U" formated records */ call LONG_RECORD_CHECK (buf_len, "0"b); /* check for long record */ move_len = buf_len; /* writes entire block */ move_ptr = mtape_data.log_record_ptr; /* set pointer to move data to */ call MOVE_TO_BUFFER (0, 0); /* move the data to the tape buffer */ go to write_return; WRITE_TYPE (2): /* Write "F/FB" formated records */ call LONG_RECORD_CHECK (buf_len, "1"b); /* check for long record */ if mtape_data.record_size > mtape_data.remain then/* don't try to move more than we have */ call WRITE_BLOCK; /* write out the current block */ move_len = buf_len; move_ptr = mtape_data.log_record_ptr; /* set pointer to move data from */ call MOVE_TO_BUFFER (0, 1); /* give the user his data */ go to write_return; WRITE_TYPE (3): /* Write "D/DB" formated records */ call LONG_RECORD_CHECK (buf_len, "1"b); /* check for long record */ if buf_len + RCW_LENGTH > mtape_data.remain then /* if record won't fit in this block */ call WRITE_BLOCK; /* write out the current block */ move_len = buf_len; /* set record length */ pic4 = move_len + RCW_LENGTH; /* convert RCW to ASCII */ db_record.rcw = pic4; /* set up RCW */ move_ptr = addr (db_record.rdata); /* set pointer to move data from */ call MOVE_TO_BUFFER (RCW_LENGTH, RCW_LENGTH); /* copy the users data */ go to write_return; %page; WRITE_TYPE (4): /* Write "S/SB" formated records */ call LONG_RECORD_CHECK (buf_len, "1"b); /* check for long record */ bytes_remaining = buf_len; /* set user buffer extents */ bytes_processed = 0; term = "0"b; /* reset terminate condition */ do n_segs = 1 by 1 while (^term); /* 1 record may be made up of several segments and blocks */ if bytes_remaining <= mtape_data.remain - SCW_LENGTH then do; /* will record fit in this block? */ term = "1"b; /* yes, set terminate condition */ if n_segs = 1 then /* entire record fit in 1st block? */ desc_type = SEG_B_E; /* Yes, record begins and ends in this segment */ else desc_type = SEG_NB_E; /* No, record ends but does not begin in this segment */ move_len = bytes_remaining; /* move last part (or all) of record */ end; else do; /* No, record will not fit in current block */ if n_segs = 1 then /* is this the first record segment? */ desc_type = SEG_B_NE; /* Yes, record begins but does not end in this segment */ else desc_type = SEG_NB_NE; /* No, record neither begins nor ends in this segment */ move_len = mtape_data.remain - SCW_LENGTH; /* use rest of or entire block */ bytes_remaining = bytes_remaining - move_len; /* decrement remaining bytes to process */ end; bytes_processed = bytes_processed + move_len;/* add up total moved so far */ pic4 = move_len + SCW_LENGTH; /* convert byte count for scw */ move_ptr = addr (sb_record.rdata); /* set ptr to move data */ pic1 = desc_type; /* convert descriptor */ sb_record.scw.rec_len = pic4; /* set record length */ sb_record.scw.span_indicator = pic1; /* and span indicator */ call MOVE_TO_BUFFER (SCW_LENGTH, SCW_LENGTH + 1); /* copy the users data */ buf_ptr = addr (based_lrec_index (bytes_processed + 1)); /* increment users buffer ptr */ end; write_return: arg_code = code; /* return error code */ return; %page; /* order - entry to process format specific control orders not recognized by mtape_ */ order: entry (arg_mtdp, arg_order_name, arg_info_ptr, arg_io_call_infop, arg_code); call SETUP; /* initialize our enviornment */ order_name = arg_order_name; info_ptr = arg_info_ptr; arg_code = error_table_$no_operation; /* ANSI PFM has no local control operations */ return; %page; /* decode_file_labels - entry to extract info contained in file labels, and fill in file_info structure */ decode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_code); call SETUP; /* initialize our enviornment */ lr_ptr = arg_lr_ptr; on conversion begin; /* set up handler for conversion errors */ code = error_table_$invalid_label_format; /* set appropriate error code */ call mtape_$error (mtdp, code, "^/Converting ANSI ^a^d label record to binary. Label contents:^/""^a""", substr (based_label_record, 1, 3), arg_labno, based_label_record); go to dfl_return; end; ansi_hdr1P, ansi_hdr2P = mtape_label_record.lab_ptr; /* set up both template ptrs */ go to LTYPE (arg_type); /* decode appropriate label type */ LTYPE (1): /* Beginning of file label */ if ansi_hdr1.label_id = ANSI_L1_ID (ANSI_HDR1) then do; /* ANSI HDR1 label */ if arg_labno ^= 1 then call mtape_$error (mtdp, error_table_$invalid_label_format, " Additional ANSI HDR1 label found while looking for ANSI ^a^d label for file ^a. Read continues using: ""^a""", substr (based_label_record, 1, 3), arg_labno, mtape_file_info.file_id, based_label_record); mtape_file_info.file_id = ansi_hdr1.file_id; mtape_file_info.file_set_id = ansi_hdr1.set_id; mtape_file_info.section = binary (ansi_hdr1.section, 17); mtape_file_info.seq_number = binary (ansi_hdr1.sequence, 17); mtape_file_info.generation = binary (ansi_hdr1.generation, 17); mtape_file_info.gen_version = binary (ansi_hdr1.version, 17); mtape_file_info.creation_date = ansi_hdr1.creation; mtape_file_info.expiration_date = ansi_hdr1.expiration; if ansi_hdr1.system = ANSI_SYS_CODE then /* tape recorded by this module? */ mtape_file_info.native_file = "1"b; /* yes, set flag */ end; else if ansi_hdr2.label_id = ANSI_L2_ID (ANSI_HDR2) then do; if arg_labno ^= 2 then /* ANSI HDR2 label */ call mtape_$error (mtdp, error_table_$invalid_label_format, " Additional ANSI HDR2 label found while looking for ANSI ^a^d label for file ^a. Read continues using: ""^a""", substr (based_label_record, 1, 3), arg_labno, mtape_file_info.file_id, based_label_record); mtape_file_info.buffer_offset = binary (ansi_hdr2.buffer_offset, 17); /* Fill in rest of file info */ if mtape_file_info.buffer_offset = 0 then /* if not using buffer offsets.. */ mtape_file_info.native_file = "0"b; /* revert this flag */ mtape_file_info.block_size = binary (ansi_hdr2.blklen, 21); mtape_file_info.record_size = binary (ansi_hdr2.reclen, 21); temp_fmt = ansi_hdr2.format; /* get first character of format */ mtape_file_info.length_mode = NON_MOD_FOUR; /* set special length mode as default */ if mtape_vol_set.volume_check < NON_MULT_VOLUME then do; /* check Multics specific stuff */ mtape_file_info.hdw_mode = MTAPE_HWM_NINE; /* set nine mode, as default */ mtape_file_info.conversion = MTAPE_NO_CONVERSION; /* set no conversion as default */ if ansi_hdr2.system_use.blocked ^= " " then do; /* this field moved with mtape_, allow old ones */ if ansi_hdr2.system_use.blocked = "1" then /* check blocking attribute */ temp_fmt = rtrim (temp_fmt) || "B"; go to set_mode (binary (ansi_hdr2.system_use.mode, 17)); /* set HDW and conversion modes */ end; else do; /* handle the pre-mtape_ system_use blocking and format */ if old_ansi_hdr2_system_use.blocked = "1" then /* check blocking attribute */ temp_fmt = rtrim (temp_fmt) || "B"; go to set_mode (binary (old_ansi_hdr2_system_use.mode, 17)); /* set HDW and conversion modes */ end; set_mode (3): /* ASCII, binary mode */ mtape_file_info.hdw_mode = MTAPE_HWM_BIN; go to set_mode_end; set_mode (2): /* EBCDIC, nine track mode */ mtape_file_info.conversion = MTAPE_CV_EBCDIC; /* convert EBCDIC <==> ASCII */ set_mode (1): /* ASCII, nine track mode (default) */ set_mode_end: end; mtape_file_info.file_code = temp_fmt; /* set file code */ do i = 0 to hbound (ANSI_FORMAT_CODES, 1); /* set the file format */ if temp_fmt = ANSI_FORMAT_CODES (i) then/* found it */ mtape_file_info.file_format = i; end; end; else if substr (based_label_record, 1, length (U_LABEL_ID (arg_type))) = U_LABEL_ID (arg_type) then /* user labels present */ mtape_file_info.user_labels_present = "1"b; return; LTYPE (2): /* End of volume label */ if arg_labno = 1 then /* if ANSI EOV1 label */ mtape_file_info.block_count = binary (ansi_hdr1.blkcnt, 35); /* extract block count */ else if arg_labno = 2 then do; /* if ANSI EOV2 label */ if mtape_vol_set.volume_check < NON_MULT_VOLUME then do; /* check Multics specific stuff */ if mtape_vol_set.next_vs_ptr = null then do; /* if no VS structure */ call mtape_$alloc (mtdp, MTAPE_ALLOC_VS, mtape_data.vs_tail, 0, nvp); mtape_data.vs_tail = nvp; end; else nvp = mtape_vol_set.next_vs_ptr; if nvp -> mtape_vol_set.volume_name ^= ansi_hdr2.system_use.next_volname then nvp -> mtape_vol_set.volume_name = ansi_hdr2.system_use.next_volname; end; end; else if substr (based_label_record, 1, length (U_LABEL_ID (arg_type))) = U_LABEL_ID (arg_type) then do; /* user labels present */ mtape_file_info.user_labels_present = "1"b; call CHECK_USER_LABELS (EOV_LABEL); end; return; LTYPE (3): /* End of file label */ /* if ANSI EOF1 label */ if ansi_hdr1.label_id = ANSI_L1_ID (ANSI_EOF1) then do; if arg_labno ^= 1 then call mtape_$error (mtdp, error_table_$invalid_label_format, " Additional ANSI EOF1 label found while looking for ANSI ^a^d label for file ^a. Read continues using: ""^a""", substr (based_label_record, 1, 3), arg_labno, mtape_file_info.file_id, based_label_record); mtape_file_info.block_count = binary (ansi_hdr1.blkcnt, 35); /* extract block count */ mtape_file_info.gen_version = binary (ansi_hdr1.version, 17); /* save in case modified | extended file */ end; else if substr (based_label_record, 1, length (U_LABEL_ID (arg_type))) = U_LABEL_ID (arg_type) then /* user labels present */ mtape_file_info.user_labels_present = "1"b; dfl_return: arg_code = code; return; %page; /* encode_file_labels - entry to fill in file labels from info obtained from file_info structure */ encode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_convert, arg_code); call SETUP; /* initialize our enviornment */ lr_ptr = arg_lr_ptr; based_label_record = ""; /* initialize to blanks first */ arg_convert = MTAPE_CV_UC_ASCII; /* set conversion to uper case ascii */ if arg_labno = 1 then do; /* init HDR1/EOV1/EOF1 label */ if arg_type = EOV_LABEL then /* if writing EOV sequence */ if mtape_vol_set.next_vs_ptr = null then do; /* and no next volume */ call mtape_$user_query (mtdp, Q_NO_NEXT_VOLUME, code); /* ask user for a new one */ if code ^= 0 then /* if he didn't want to continue */ go to efl_return; /* forget it */ end; ansi_hdr1P = mtape_label_record.lab_ptr; ansi_hdr1.label_id = ANSI_L1_ID (arg_type); /* Now fill it in */ /* Use substr to move the uneven length string */ ansi_hdr1.file_id = substr (mtape_file_info.file_id, 1, maxlength (ansi_hdr1.file_id)); ansi_hdr1.set_id = substr (mtape_file_info.file_set_id, 1, maxlength (ansi_hdr1.set_id)); pic4 = mtape_file_info.section; ansi_hdr1.section = pic4; pic4 = mtape_file_info.seq_number; ansi_hdr1.sequence = pic4; pic4 = mtape_file_info.generation; ansi_hdr1.generation = pic4; pic2 = mtape_file_info.gen_version; ansi_hdr1.version = pic2; ansi_hdr1.creation = mtape_file_info.creation_date; ansi_hdr1.expiration = mtape_file_info.expiration_date; ansi_hdr1.access = " "; /* Always unlimited access */ if arg_type > BOF_LABEL then do; /* if EOV/EOF label */ pic6 = mtape_file_info.block_count; /* fill in the block count */ ansi_hdr1.blkcnt = pic6; end; else ansi_hdr1.blkcnt = "000000"; /* used only for EOF/EOV1 records */ ansi_hdr1.system = ANSI_SYS_CODE; return; end; else if arg_labno = 2 then do; /* init HDR2/EOV2/EOF2 label */ ansi_hdr2P = mtape_label_record.lab_ptr; ansi_hdr2.label_id = ANSI_L2_ID (arg_type); /* Now fill it in */ ansi_hdr2.format = substr (ANSI_FORMAT_CODES (mtape_file_info.file_format), 1, 1); pic5 = mtape_file_info.block_size; ansi_hdr2.blklen = pic5; if mtape_file_info.record_size <= MAX_ANSI_RECORD_SIZE then do; /* if it will fit */ pic5 = mtape_file_info.record_size; ansi_hdr2.reclen = pic5; end; else ansi_hdr2.reclen = "00000"; if substr (ANSI_FORMAT_CODES (mtape_file_info.file_format), 2, 1) ^= "" then ansi_hdr2.system_use.blocked = "1"; else ansi_hdr2.system_use.blocked = "0"; if arg_type = EOV_LABEL then do; /* if at EOV */ if mtape_vol_set.next_vs_ptr ^= null then /* and if we have another volume */ ansi_hdr2.system_use.next_volname = mtape_vol_set.next_vs_ptr -> mtape_vol_set.volume_name; arg_convert = MTAPE_NO_CONVERSION; /* don't convert volume id */ end; if mtape_file_info.hdw_mode = MTAPE_HWM_BIN then /* if recording in binary mode */ ansi_hdr2.system_use.mode = "3"; else if mtape_file_info.conversion = MTAPE_CV_EBCDIC then /* if recording EBCDIC data */ ansi_hdr2.system_use.mode = "2"; else ansi_hdr2.system_use.mode = "1"; /* Standard ASCII NINE mode */ pic2 = mtape_file_info.buffer_offset; ansi_hdr2.buffer_offset = pic2; return; end; else if mtape_open_info.label_entry_present then /* if writing user labels */ if arg_labno < 12 then do; /* and not at max of 9 yet */ uln = arg_labno - 2; /* user labels start at 1 */ user_label_data = ""; call mtape_open_info.user_label (mtape_data.iocb_ptr, user_label_data, uln, arg_type, mtape_file_info.section, code); /* call the user label routine */ if code ^= 0 then /* if error indicated from user routine */ if code = error_table_$end_of_info then /* but it is normal termination */ go to efl_return; /* return with end of info indication */ else do; /* some other error report it */ call mtape_$error (mtdp, code, "^/Calling the user label processing routine to process the ^a^d label record.", U_LABEL_ID (arg_type), uln); code = error_table_$end_of_info; /* force user label termination */ go to efl_return; end; pic1 = uln; /* convert label number to ascii */ based_label_record = U_LABEL_ID (arg_type) || pic1 || user_label_data; /* form completed user label */ go to efl_return; end; code = error_table_$end_of_info; /* terminate label processing */ efl_return: arg_code = code; /* copy error code */ return; %page; /* CHECK_NEW_FILE_SECTION - internal procedure to check consistency of new file section */ CHECK_NEW_FILE_SECTION: proc; dcl per_file_overlay char (ov_len) based (addr (mtape_file_info.per_file_info)); dcl ov_len fixed bin; dcl pp ptr; code = 0; fi_ptr = mtape_file_info.next_fi_ptr; /* file info will be allocated if null */ call pfm_utils_$read_file_labels (mtdp, fi_ptr, vs_ptr, label_type, code); /* read new file sect. HDR labels */ if code ^= 0 then return; if label_type ^= BOF_LABEL then do; /* error if not header labels */ code = error_table_$bad_file; call mtape_$error (mtdp, code, "^/^[EOV^;EOF^] file label found where BOF label record expected", label_type); return; end; call SET_FILE_ATTRIBUTES; /* set up missing pieces */ pp = mtape_file_info.prev_fi_ptr; /* get prev file ptr */ ov_len = (binary (rel (addr (mtape_file_info.per_section_info))) - binary (rel (addr (mtape_file_info.per_file_info)))) * 4; if mtape_file_info.record_size ^= pp -> mtape_file_info.record_size then /* if record sizes */ if mtape_file_info.record_size = 0 then /* are ^=, but new section = 0 */ pp -> mtape_file_info.record_size = 0; /* make 1st section = 0 too */ if mtape_file_info.section ^= pp -> mtape_file_info.section + 1 | per_file_overlay ^= addr (pp -> mtape_file_info.per_file_info) -> per_file_overlay then do; code = error_table_$bad_file; /* set an appropriate error code */ call mtape_$error (mtdp, code, "^/New file section for File ""^a"" on volume ""^a"" is inconsistent with previous section", pp -> mtape_file_info.file_id, mtape_vol_set.volume_id); end; mtape_data.prev_block_no = 0; /* clear out block counter */ call mtape_$set_mode (mtdp, "data", mtape_data.hdw_mode, null, code); /* set hardware mode */ end CHECK_NEW_FILE_SECTION; %page; /* CHECK_USER_LABELS - procedure to check if user labels and a user label entry exist */ CHECK_USER_LABELS: proc (htype); dcl htype fixed bin; dcl flrp ptr; if mtape_file_info.user_labels_present then /* if file contains user labels */ if mtape_open_info.label_entry_present then do; /* and user wants to see them */ if htype > BOF_LABEL then /* trailer labels? */ flrp = mtape_file_info.first_file_trail_ptr; /* yes, search trailer list */ else flrp = mtape_file_info.first_file_lab_ptr; /* search header list */ do lr_ptr = flrp repeat mtape_label_record.next_lab_ptr /* search up to 1st user label */ while (substr (based_label_record, 1, 1) ^= "U"); end; do lr_ptr = lr_ptr repeat mtape_label_record.next_lab_ptr while (lr_ptr ^= null); /* send him all labels */ user_label_data = substr (based_label_record, 5); /* copy user data */ i = fixed (substr (based_label_record, 4, 1), 17); /* get label number */ call mtape_open_info.user_label (mtape_data.iocb_ptr, /* call the user label routine */ user_label_data, i, htype, mtape_file_info.section, (0)); /* ignore error code */ end; end; end CHECK_USER_LABELS; /* CHECK_VERSION - internal procedure to check struture version numbers */ CHECK_VERSION: proc (s_ptr, req_version, struc_name); dcl s_ptr ptr; dcl req_version char (8); dcl struc_name char (32); dcl 1 version_check based (s_ptr) aligned, /* generic structure to check verison number */ 2 version char (8); if version_check.version ^= req_version then do; /* they do not match */ code = error_table_$unimplemented_version; /* set error code */ call mtape_$error (mtdp, code, "^/^a: Expecting ""^a"" version for ^a structure. Version recorded in received structure is ""^a"".", myname, req_version, struc_name, version_check.version); go to pfm_init_return; /* take non-local goto and return to caller */ end; end CHECK_VERSION; %page; /* CHECK_VOL_LABELS - internal procedure to read volume label(s) of a known ANSI volume */ CHECK_VOL_LABELS: proc (ridx); dcl ridx fixed bin; call mtape_$order (mtdp, "rew", 0, null, code); /* Rewind to load point */ if code ^= 0 then do; call mtape_$error (mtdp, code, "While rewinding volume ^a prior to reading volume label(s)", mtape_vol_set.volume_id); return; end; nlp = mtape_vol_set.first_vl_ptr; /* arm the label record ptr */ ansi_vol1P = mtape_data.tlb -> mtape_label_record.lab_ptr; /* get pointer to VOL1 structure */ term = "0"b; /* get us through the first pass */ do i = 1 by 1 while (^term); /* read up to HDR1 label */ call mtape_$read_label (mtdp, mtape_data.tlb, code); /* read label record */ if code ^= 0 then do; call mtape_$error (mtdp, code, "Attempting to read ANSI volume label record from volume ^a.", mtape_vol_set.volume_id); return; end; if ansi_vol1.label_id = ANSI_VOL1 then do; /* if this is VOL1 label */ if ansi_vol1.owner_id.mult_id = MULTICS_ANSI_VERSION then /* only true if recorded by mtape_ */ ridx = MTAPE_VOLUME; else ridx = NON_MULT_VOLUME; /* volume recorded by other vendor */ end; else if ansi_vol1.label_id = ANSI_L1_ID (BOF_LABEL) then do; /* check if HDR1 label */ term = "1"b; /* this is the place to stop reading labels */ mtape_vol_set.number_of_vol_labels = i - 1; /* set number of vol labels */ ansi_hdr1P = ansi_vol1P; /* check expiration date of first file */ if ridx = NON_MULT_VOLUME then /* check if recorded by tape_ansi_ */ if substr (ansi_hdr1.system, 1, 12) = substr (ANSI_SYS_CODE, 1, 12) then ridx = MULT_PRIOR_VOLUME; /* yes, tape recorded by tape_ansi_ */ mtape_vol_set.first_file_unexpired = pfm_utils_$label_unexpired (ansi_hdr1.expiration); /* check expiry date */ end; if ^term then do; /* link in this label (if not HDR1) */ if nlp = null then /* if no label record structure exists.. */ call pfm_utils_$init_label_record (mtdp, mtape_vol_set.last_vl_ptr, mtape_vol_set.first_vl_ptr, lr_ptr, LABEL_LENGTH); else lr_ptr = nlp; /* it does exist, use it */ based_label_record = mtape_data.tlb -> mtape_label_record.lab_ptr -> based_label_record; nlp = mtape_label_record.next_lab_ptr; /* update pointer for next label */ end; end; call mtape_$order (mtdp, "bsr", 1, null, code); /* backspace in front of HDR1 */ if code ^= 0 then call mtape_$error (mtdp, code, "Attempting to backspace over ^a label record of volume ^a.", ansi_vol1.label_id, mtape_vol_set.volume_id); end CHECK_VOL_LABELS; %page; /* CONVERT_DESC - internal procedure to convert RDW for S/SB formated records */ CONVERT_DESC: proc; do while (sb_record.scw.span_indicator = mtape_data.padding_char); call GET_NXT_RECORD; /* if scw is pad, get next block */ end; desc_type = binary (sb_record.scw.span_indicator, 17); /* convert the span indicator */ crl = binary (sb_record.scw.rec_len, 21); /* compute the record length */ move_len = crl - SCW_LENGTH; if desc_type < SEG_B_E | desc_type > SEG_NB_E then/* invalid descriptor */ call INV_DESC; end CONVERT_DESC; %page; /* EOV_ON_WRITE - internal procedure to close out volume and initiate volume switch */ EOV_ON_WRITE: proc (who_called); dcl who_called bit (1) aligned; call pfm_utils_$write_file_labels (mtdp, EOV_LABEL, code); /* yes, write out the EOV labels */ if code ^= 0 then return; /* some problem with writing labels, give up */ mtape_vol_set.volume_end = "0"b; /* reset volume end flag */ nvp = mtape_vol_set.next_vs_ptr; /* copy pointer, in case its null */ call mtape_$volume_switch (mtdp, nvp, code); /* do the magic */ if code ^= 0 then do; /* could'nt do the switch */ call mtape_$error (mtdp, code, "Couldn't mount new volume at volume switch time"); return; end; vs_ptr = mtape_data.vs_current; /* point to new volume */ call INIT_VOL_LABELS; /* init volume labels */ if code ^= 0 then return; fi_ptr = null; /* this will ensure we get file_info struct allocated */ call pfm_utils_$setup_file (mtdp, fi_ptr, "1"b); /* set up new file section structure */ call pfm_utils_$write_file_labels (mtdp, BOF_LABEL, code); /* and write out the section header labels */ if code ^= 0 then return; /* if errors.. */ mtape_data.prev_block_no = 0; /* clear out block counter */ if who_called = WRITING then do; /* if actually writing data */ call mtape_$set_mode (mtdp, "data", mtape_data.hdw_mode, null, code); /* set hardware mode */ if code ^= 0 then return; call mtape_$set_mode (mtdp, "length", mtape_data.length_mode, null, code); /* and special len mode */ if code ^= 0 then return; if mtape_data.cur_buf_idx > lbound (mtape_data.buf_ptrs, 1) then do; /* if we have suspened bufs */ if mtape_data.native_file then do; /* if writing with buffer offsets */ do i = lbound (all_buf_ptrs, 1) to mtape_data.cur_buf_idx - 1; /* adjust block numbers */ all_buf_ptrs (i) -> native_bo_contents.block_number = i; end; end; call mtape_$flush_buffers (mtdp, code); /* flush out any suspended buffers */ end; end; end EOV_ON_WRITE; %page; /* GET_NXT_RECORD - subroutine to position to next logical record, reading nxt tape block if necessary */ GET_NXT_RECORD: proc; dcl term bit (1) aligned; dcl (block_no, i, j) fixed bin (21); term = "0"b; do while (^term); /* in case we have to read 1 block of new file section */ call mtape_$read_block (mtdp, code); /* so read it in */ if code ^= 0 then /* if some error */ if code = error_table_$end_of_info then do; /* if EOF, read trailer */ call LOAD_PTRS; /* Load up structure pointers */ call pfm_utils_$read_file_labels (mtdp, fi_ptr, vs_ptr, label_type, fl_code); if fl_code ^= 0 then do; /* some problem reading labels, abort */ code = fl_code; go to read_return; /* Take non-local goto and return */ end; if label_type = EOF_LABEL then /* is this really end of the data file? */ go to read_return; /* Take non-local goto and return */ else if label_type = EOV_LABEL then do; /* No, volume switch has already been done */ call CHECK_NEW_FILE_SECTION; /* go check out new file section labels */ if code ^= 0 then /* some error */ go to read_return; /* Take non-local goto and return */ end; else do; /* if label_type = BOF, this is error */ code = error_table_$bad_file; /* set appropriate error code */ call mtape_$error (mtdp, code, "^/ANSI HDR1 file label found where EOF1 or EOV1 file label record expected"); go to read_return; /* Take non-local goto and return */ end; end; else go to read_return; /* some other error, let user see what it is */ else do; /* successfully read the block */ term = "1"b; /* set terminate condition */ if mtape_data.native_file then do; /* tape written by this module? */ on illegal_procedure call INV_DEC_DATA; /* if garbage catch it */ mtape_data.cur_block.length = native_bo_contents.block_size; block_no = native_bo_contents.block_number; /* convert block number */ revert illegal_procedure; if block_no ^= mtape_data.prev_block_no + 1 then do; /* check seq. */ call mtape_$stop_tape (mtdp, code); code = error_table_$data_seq_error; /* set appropriate code */ call mtape_$error (mtdp, code, "Data block number was: ^d; S/B; ^d", block_no, mtape_data.prev_block_no + 1); go to read_return; /* Take non-local goto and return */ end; mtape_data.prev_block_no = block_no; /* save current block number */ mtape_data.remain = mtape_data.length - mtape_data.processed; /* reset, based on recorded len */ end; if mtape_data.ad_file_format = 2 then do; /* if F/FB format, check padding */ i = mod (mtape_data.remain, mtape_data.record_size); if i ^= 0 then /* if block not modulus record size */ if verify (substr (tblock, mtape_data.length - i + 1, i), mtape_data.padding_char) = 0 then mtape_data.length = mtape_data.length - i; j = divide ((mtape_data.length - mtape_data.processed), mtape_data.record_size, 21); do i = j to 1 by -1 while (verify (substr (tblock, mtape_data.processed + (i - 1) * mtape_data.record_size, mtape_data.record_size), mtape_data.padding_char) = 0); mtape_data.length = mtape_data.length - mtape_data.record_size; /* wipe record, if all pad */ end; mtape_data.remain = mtape_data.length - mtape_data.processed; /* recompute remaining chars */ end; end; end; end GET_NXT_RECORD; %page; /* INIT_VOL_LABELS - internal procedure to initialize and write the VOL1, UVL1 and dummy HDR1 and EOF1 label records */ INIT_VOL_LABELS: proc; if mtape_vol_set.first_file_unexpired then /* if not expired */ if ^mtape_open_info.force then do; /* and not ignoring expiration dates */ call mtape_$user_query (mtdp, Q_UNEXPIRED_VOLUME, code); /* ask user */ if code ^= 0 then return; /* user does not want labels destroyed */ end; call mtape_$order (mtdp, "den", 0, addr (mtape_attach_info.density), code); /* Rewind and set density */ if code ^= 0 then do; call mtape_$error (mtdp, code, "^/While rewinding and setting density to ^d BPI on volume ^a prior to volume initialization", mtape_attach_info.density, mtape_vol_set.volume_id); return; end; nlp = mtape_vol_set.first_vl_ptr; /* arm the label record ptr */ mtape_vol_set.volume_id = mtape_vol_set.volume_name; auth_code = authenticate_ ((mtape_vol_set.volume_id)); do i = 1 to 2; /* do it for both the VOL1 and UVL1 labels */ if nlp = null then /* if no label record structure exists.. */ call pfm_utils_$init_label_record (mtdp, mtape_vol_set.last_vl_ptr, mtape_vol_set.first_vl_ptr, lr_ptr, LABEL_LENGTH); else lr_ptr = nlp; /* it does exist, use it */ nlp = mtape_label_record.next_lab_ptr; /* update pointer for next label */ if i = 1 then do; /* init VOL1 label */ ansi_vol1P = mtape_label_record.lab_ptr; ansi_vol1.label_id = ANSI_VOL1; /* set label id */ ansi_vol1.volume_id = substr (mtape_vol_set.volume_id, 1, maxlength (ansi_vol1.volume_id)); /* set canonical volume name */ ansi_vol1.access = " "; /* set for unlimited access */ ansi_vol1.owner_id.auth_code = auth_code; /* set authentication code for RCP */ ansi_vol1.owner_id.mult_id = MULTICS_ANSI_VERSION; /* indicate recorded by mtape_ */ ansi_vol1.label_version = LABEL_STANDARD_VERSION; /* set ANSI version */ end; else do; /* initialize UVL1 label */ ansi_uvl1P = mtape_label_record.lab_ptr;/* set pointer */ ansi_uvl1.label_id = ANSI_UVL1; /* set label ID */ ansi_uvl1.auth_code = auth_code; /* set authentication code */ ansi_uvl1.init_date = pfm_utils_$julian_date (""); /* set current date */ call system_info_$installation_id (install_id); /* set installation name */ ansi_uvl1.installation_id = install_id; ansi_uvl1.user_id = get_group_id_ (); /* set user name */ end; call mtape_$write_label (mtdp, lr_ptr, code);/* write it out */ if code ^= 0 then do; /* if unrecoverable error */ call mtape_$error (mtdp, code, "Attempting to write ANSI ^[VOL1^;UVL1^] label record on volume ^a.", i, mtape_vol_set.volume_id); return; end; end; mtape_vol_set.number_of_vol_labels = 2; /* set this constant */ if mtape_vol_set.last_vl_ptr ^= lr_ptr then do; /* in case there were more labels before */ mtape_vol_set.last_vl_ptr = lr_ptr; /* truncate the chain */ mtape_label_record.next_lab_ptr = null; end; /* Now write the dummy HDR1 and EOF1 labels */ lr_ptr = mtape_data.tlb; based_label_record = ANSI_L1_ID (BOF_LABEL) || DUMMY_LABEL; /* start with HDR1 label */ do i = 1 to 2; /* write 2 labels */ call mtape_$write_label (mtdp, lr_ptr, code);/* write it out */ if code ^= 0 then do; /* if unrecoverable error */ call mtape_$error (mtdp, code, "^/While initializing volume ^a with dummy ANSI ^[HDR1^;EOF1^] label record", mtape_vol_set.volume_id, i); return; end; call mtape_$order (mtdp, "eof", 2, null, code); /* write 2 EOF marks */ if code ^= 0 then do; call mtape_$error (mtdp, code, "^/While writing 2 EOFs following dummy ANSI ^[HDR1^;EOF1^] label record on volume ^a", i, mtape_vol_set.volume_id); return; end; substr (based_label_record, 1, 4) = ANSI_L1_ID (EOF_LABEL); /* EOF1 for 2nd iteration */ end; mtape_vol_set.volume_density = mtape_attach_info.density; /* reset volume parameters to */ mtape_vol_set.volume_type = Volume_ansi_tape; /* reflect that its an ANSI volume recorded at */ mtape_vol_set.volume_check = MTAPE_VOLUME; /* requested density by mtape_ */ /* Position for writing first file */ call mtape_$order (mtdp, "rew", 0, null, code); /* Rewind to load point */ if code ^= 0 then do; call mtape_$error (mtdp, code, "^/While rewinding volume ^a after volume initialization", mtape_vol_set.volume_id); return; end; call mtape_$order (mtdp, "fsr", 2, null, code); /* position to write over dummy HDR1 label */ if code ^= 0 then call mtape_$error (mtdp, code, "^/While positioning for writing first file label on volume ^a", mtape_vol_set.volume_id); end INIT_VOL_LABELS; %page; /* INV_DEC_DATA - procedure to catch IPR faults which would result if block prefix block serial number and or block number were not in expected packed decimal format */ INV_DEC_DATA: proc; dcl blk_prefix_wds (2) fixed bin (35) based (mtape_data.cur_buf_ptr); code = error_table_$invalid_file_set_format; call mtape_$error (mtdp, code, "^/^a ^d block prefix words (^w ^w octal) from packed decimal to binary", "Attempting to convert block #", mtape_data.phy_block, blk_prefix_wds (1), blk_prefix_wds (2)); go to read_return; /* take non-local goto and return */ end INV_DEC_DATA; /* INV_DESC - procedure to catch conversion error and report it */ INV_DESC: proc; call LOAD_PTRS; /* Load structure pointers for exeception processing */ code = error_table_$invalid_record_desc; /* set appropriate error code */ call mtape_$error (mtdp, code, "^/^a ^a ^[R^;S^]CW at record ^d, block ^d, ^[of file section ^d ^;^s^]of file named ""^a"".", "Converting ANSI", ANSI_FORMAT_CODES (mtape_file_info.file_format), (mtape_data.ad_file_format = 3), mtape_data.log_record, mtape_data.phy_block, (mtape_file_info.section > 1), mtape_file_info.section, mtape_file_info.file_id); go to read_return; /* return to user with error */ end INV_DESC; /* LOAD_PTRS - procedure to load structure pointers for exeception processing of time critical external entries (read and write) */ LOAD_PTRS: proc; vs_ptr = mtape_data.vs_current; /* load up pertinent structure pointers */ fi_ptr = mtape_data.fi_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; end LOAD_PTRS; %page; /* LONG_RECORD_CHECK - procedure to check if a requested write of a logical record will fit */ LONG_RECORD_CHECK: proc (length, rec_blk_ck); dcl length fixed bin (21); dcl rec_blk_ck bit (1) aligned; if rec_blk_ck then do; /* comparing against record length */ if length > mtape_data.record_size then /* is it to big */ code = error_table_$long_record; /* yes, set code */ end; else if length > mtape_data.block_size then /* comparing against blk size, will it fit */ code = error_table_$long_record; /* no, set code */ if code ^= 0 then /* if we have a long record.. */ go to write_return; /* take non-local goto to write return exit */ end LONG_RECORD_CHECK; %page; /* MOVE_TO_BUFFER - subroutine to move user data to tape buffer on write, initiating a write of the buffer if full */ MOVE_TO_BUFFER: proc (cwl, min_len); dcl cwl fixed bin; /* control word length */ dcl min_len fixed bin; /* minimum length of next record */ dcl pad_chars fixed bin; dcl rcd_pad char (pad_chars) based (addr (tape_blk (mtape_data.processed + move_len + 1))); if mtape_data.conversion = MTAPE_CV_EBCDIC then /* if data recorded in ebcdic.. */ call ascii_to_ebcdic_ (buf_ptr -> based_lrec_data, move_ptr -> based_lrec_data); else move_ptr -> based_lrec_data = buf_ptr -> based_lrec_data; /* move data to tape buffer */ if (mtape_data.ad_file_format = 1) | (mtape_data.ad_file_format = 2) then /* If "U" or "F" or "FB" format */ if move_len < mtape_data.record_size then do;/* and record is not fUll */ pad_chars = mtape_data.record_size - move_len; /* pad record out with blanks */ rcd_pad = copy (" ", pad_chars); if mtape_data.conversion = MTAPE_CV_EBCDIC then /* make them ebcdic blanks */ call ascii_to_ebcdic_ (rcd_pad, rcd_pad); /* if appropriate */ move_len = mtape_data.record_size; /* reflect on all data moved */ end; mtape_data.processed = mtape_data.processed + move_len + cwl; /* add up bytes processed */ mtape_data.remain = mtape_data.block_size - mtape_data.processed; /* decrement remaining bytes */ if ^mtape_data.file_blocked then /* if not "FB", "DB", or "SB" format */ call WRITE_BLOCK; /* write the block out now */ else if mtape_data.remain < min_len then /* if blocked but block full.. */ call WRITE_BLOCK; /* write the block out now */ else mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); /* Not blocked, set for next lrec */ end MOVE_TO_BUFFER; %page; /* MOVE_TO_USER - subroutine to move data from tape buffer to user buffer on read */ MOVE_TO_USER: proc; if buf_ptr = null then /* if caller just wants length.. */ rec_len = rec_len + move_len; /* thats it */ else do; /* this is a real read */ if ^long_record then do; /* if we can still fit the data in */ if buf_len - move_len < 0 then do; long_record = "1"b; /* we have more data than user can take */ move_len = buf_len; /* move what we can */ end; buf_len = buf_len - move_len; /* and decrement length remaining in users buffer */ if move_len > 0 then do; /* if we have some data to move, move it */ if mtape_data.conversion = MTAPE_CV_EBCDIC then /* tape recorded in ebcdic */ call ebcdic_to_ascii_ (move_ptr -> based_lrec_data, buf_ptr -> based_lrec_data); else buf_ptr -> based_lrec_data = move_ptr -> based_lrec_data; /* move computed of bytes */ rec_len = rec_len + move_len; /* tell user how long record is anyway */ buf_ptr = addr (based_lrec_index (rec_len + 1)); /* increment users buffer ptr */ end; end; end; mtape_data.processed = mtape_data.processed + crl; mtape_data.remain = mtape_data.cur_block.length - mtape_data.processed; if mtape_data.remain > 0 then mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); end MOVE_TO_USER; %page; /* NEED_TO_INIT_VOLUME - function to determine if a tape volume requires initializaton */ NEED_TO_INIT_VOLUME: proc returns (bit (1) aligned); if mtape_vol_set.volume_check > NON_MULT_VOLUME then /* if this is not an ANSI volume */ return ("1"b); if mtape_open_info.modify | mtape_open_info.extend then /* if modifying or extending */ return ("0"b); /* existing file, do not init volume */ if ^mtape_data.first_file then do; /* if the first opening */ if mtape_open_info.seq_number = 1 then /* or we want file number 1 */ return ("1"b); if mtape_open_info.next_file then /* or next (first) file */ return ("1"b); end; return ("0"b); end NEED_TO_INIT_VOLUME; %page; /* SET_FILE_FORMAT - internal procedure to set file format in file info from open data */ SET_FILE_FORMAT: proc; temp_fmt = translate (mtape_open_info.file_format, UC, LC); /* file format in upper case */ mtape_file_info.file_code = temp_fmt; /* set file code */ do i = 0 to hbound (ANSI_FORMAT_CODES, 1); /* set the file format */ if temp_fmt = ANSI_FORMAT_CODES (i) then /* found it */ mtape_file_info.file_format = i; end; end SET_FILE_FORMAT; /* SET_OPEN_IDX - subroutine to determine what kind of opening this is */ SET_OPEN_IDX: proc; if mtape_open_info.open_mode = Sequential_input then do; /* input operation? */ output = "0"b; /* yes, reset output flag */ open_idx = 0; /* and set input open idx value */ end; else do; /* some type of output operation */ output = "1"b; /* true if sqo or sqio */ if mtape_open_info.pfm_opt_sw (1) then /* if generating a file */ open_idx = 4; else if mtape_open_info.modify then /* if modifying an existing file */ open_idx = 3; else if mtape_open_info.extend then /* if extending current file */ open_idx = 2; else open_idx = 1; /* otherwise create new file */ end; end SET_OPEN_IDX; /* SET_RECORD_SIZE - internal procedure to set record size either from defaults or as specified by the user */ SET_RECORD_SIZE: proc; if mtape_open_info.record_length = MTAPE_UNSPECIFIED then do; /* if no "-record" value specified by user */ if index (mtape_file_info.file_code, "S") ^= 0 then /* if Spanned format */ mtape_file_info.record_size = mtape_open_info.default_span_rlen; /* set default */ else if index (mtape_file_info.file_code, "D") ^= 0 then /* if variable format */ mtape_file_info.record_size = mtape_open_info.default_var_rlen; /* set default */ else mtape_file_info.record_size = mtape_open_info.default_fix_rlen; /* assume fixed or U format */ end; else mtape_file_info.record_size = mtape_open_info.record_length; /* if user specified it */ end SET_RECORD_SIZE; %page; /* SET_RECORDING_MODE - internal procedure to set the recording mode in the file_info structure */ SET_RECORDING_MODE: proc; mtape_file_info.conversion = MTAPE_NO_CONVERSION; /* set no conversion as default */ temp_mode = translate (mtape_open_info.recording_mode, UC, LC); /* mode to UC */ if temp_mode = "ASCII" then /* record in standard ascii mode */ mtape_file_info.hdw_mode = MTAPE_HWM_NINE; else if temp_mode = "EBCDIC" then do; /* record in ebcdic mode */ mtape_file_info.hdw_mode = MTAPE_HWM_NINE; mtape_file_info.conversion = MTAPE_CV_EBCDIC;/* set conversion for ASCII <==> EBCDIC */ end; else mtape_file_info.hdw_mode = MTAPE_HWM_BIN; /* Must be binary mode */ end SET_RECORDING_MODE; /* SETUP - internal procedure to set up enviornment for the external entries */ SETUP: proc; mtdp = arg_mtdp; /* get pointers to pertinient data */ vs_ptr = mtape_data.vs_current; fi_ptr = mtape_data.fi_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; arg_code, code = 0; /* and reset error codes */ end SETUP; %page; /* SETUP_NEW_FILE - procedure to create a file info structure and initialize it with open options */ SETUP_NEW_FILE: proc; if fi_ptr ^= null then /* if replacing existing file */ if ^mtape_open_info.force then /* and not ignoring expiration dates */ if pfm_utils_$label_unexpired ((mtape_file_info.expiration_date)) then do; /* if expiration date is in future */ call mtape_$user_query (mtdp, Q_UNEXPIRED_FILE, code); /* ask user what to do */ if code ^= 0 then return; /* abort file opening on "no" answer */ if mtape_file_info.position_within_file ^= AT_BOFH then do; call pfm_utils_$position_in_file (mtdp, fi_ptr, vs_ptr, AT_BOFH, code); if code ^= 0 then return; end; end; call pfm_utils_$setup_file (mtdp, fi_ptr, "0"b); /* do the common stuff first */ call SET_FILE_FORMAT; /* set the file format in file info structure */ call SET_RECORDING_MODE; /* set the recording mode */ if mtape_file_info.record_size = MTAPE_UNSPECIFIED then /* no record length */ call SET_RECORD_SIZE; /* either use given or default */ if mtape_open_info.pfm_opt_sw (2) then /* if buffer offset specified */ mtape_file_info.buffer_offset = size (native_bo_contents) * 4; /* set the size */ else do; mtape_file_info.native_file = "0"b; /* otherwise reset this flag */ mtape_file_info.buffer_offset = 0; /* and set for no buffer offset */ end; mtape_file_info.generation = 1; /* set up as constants for now */ mtape_file_info.gen_version = 0; mtape_file_info.creation_date = pfm_utils_$julian_date (""); /* set todays date */ if mtape_open_info.expiration ^= "" then /* if expiration specified.. */ mtape_file_info.expiration_date = pfm_utils_$julian_date ((mtape_open_info.expiration)); else mtape_file_info.expiration_date = " 00000"; /* no expiration specified */ SET_FILE_ATTRIBUTES: entry; /* to set file attributes if not already set */ if mtape_file_info.file_format = MTAPE_UNSPECIFIED then /* if file format not specified */ call SET_FILE_FORMAT; mtape_file_info.length_mode = NON_MOD_FOUR; /* set special length mode as default */ if mtape_file_info.hdw_mode = MTAPE_UNSPECIFIED then /* recording mode not set */ call SET_RECORDING_MODE; /* set it */ if mtape_file_info.block_size = MTAPE_UNSPECIFIED then /* no block size */ mtape_file_info.block_size = mtape_open_info.block_length; /* use given */ if mtape_file_info.record_size = MTAPE_UNSPECIFIED then /* no record length */ call SET_RECORD_SIZE; /* either use given or default */ if mtape_data.conversion = MTAPE_CV_EBCDIC then /* if converting to ebcdic */ mtape_data.padding_char = ANSI_EBCDIC_PAD_CHAR; /* set EBCDIC pad char */ else mtape_data.padding_char = ANSI_ASCII_PAD_CHAR; /* otherwise set ASCII pad char */ end SETUP_NEW_FILE; %page; /* WRITE_BLOCK - procedure to write out the current block when full */ WRITE_BLOCK: proc; if mtape_data.native_file then do; /* tape written entirely by this module? */ native_bo_contents.block_size = mtape_data.processed; /* yes, store block size */ native_bo_contents.block_number = mtape_data.phy_block + 1; /* store block serial number */ end; call mtape_$write_block (mtdp, code); if code ^= 0 then /* some error */ if code = error_table_$eov_on_write then do; /* Is it end of tape? */ call LOAD_PTRS; /* Load up structure pointers */ call EOV_ON_WRITE (WRITING); /* Go close out volume and initiate volume switch */ if code ^= 0 then go to write_return; /* If problem, take non-local goto and return */ end; else go to write_return; /* other error return to caller */ end WRITE_BLOCK; %page; %include mtape_includes; %page; %include rcp_volume_formats; %page; %include ansi_vol1; %include ansi_uvl1; %page; %include ansi_hdr1; %page; %include ansi_hdr2; %page; %include iox_modes; end ansi_tape_io_;  gcos_tape_io_.pl1 12/17/86 0926.1r w 12/17/86 0832.9 43893 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ gcos_tape_io_: procedure; /* format: style4 */ /* * This program runs under control of the mtape_ I/O module and is meant * to process data and file formats that are specific to GCOS * formated tapes, and is known as a Per-Format module. * * This Per-Format module is not fully implemented, and is only included * so that if a GCOS tape volume is mounted and recognized by * mtape_/RCP, a linkage error will not result. When this module is * called at its pfm_init entry, an error message is displayed * explaining that the GCOS Per-format module has not been * implemented, and an error code is returned. * * Modification History: * * Dummy version created by J. A. Bush 07/10/83 */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to the mtape data structure */ dcl arg_code fixed bin (35); /* Return error code */ dcl arg_info_ptr ptr; /* Pointer to Order data from iox_$control call */ dcl arg_io_call_infop ptr; /* Pointer to io_call control info structure */ dcl arg_order_name char (*); /* Name of Control order to be processed */ dcl arg_lr_ptr ptr; /* Pointer to current label record structure */ dcl arg_labno fixed bin; /* label record within label group */ dcl arg_type fixed bin; /* 1 => BOF; 2 => EOV; 3 => EOF */ dcl arg_convert fixed bin; /* Label record conversion indicator */ /* AUTOMATIC DATA */ dcl code fixed bin (35); dcl buf_ptr ptr; /* Auto copy of users buffer pointer */ dcl buf_len fixed bin (21); /* Auto copy of users lrec buffer */ dcl rec_len fixed bin (21); /* Auto copy of logical record length */ /* CONSTANT DATA */ /* EXTERNAL STATIC DATA */ dcl error_table_$unimplemented_version fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ /* EXTERNAL ENTRIES */ /* BASED VARIABLES */ %page; /* pfm_init - entry to initialize the Per-Format module, setting up file and volume processing parameters and determining correctness of current volume */ pfm_init: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ code = error_table_$unimplemented_version; /* This is for the dummy PFM */ call mtape_$error (mtdp, code, "^/The mtape_ GCOS Per-Format module has not been fully implemented."); arg_code = code; return; %page; /* file_open - entry to do format specific processing in opening the file or file set (i.e. read and write file labels) */ file_open: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* file_close - entry to do format specific processing in closing the file or file set (i.e. read and write file trailer labels) */ file_close: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* read - entry to read format specific logical records from the current file */ read: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; /* If = null, return length of next record */ buf_len = mtape_data.arg_buf_len; return; %page; /* write - entry to write format specific logical records into the current file */ write: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* Copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; buf_len = mtape_data.arg_buf_len; return; %page; /* order - entry to process format specific control orders not recognized by mtape_ */ order: entry (arg_mtdp, arg_order_name, arg_info_ptr, arg_io_call_infop, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* decode_file_labels - entry to extract info contained in file labels, and fill in file_info structure */ decode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* encode_file_labels - entry to fill in file labels from info obtained from file_info structure */ encode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_convert, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* SETUP - internal procedure to set up enviornment for the external entries */ SETUP: proc; mtdp = arg_mtdp; /* get pointers to pertinient data */ vs_ptr = mtape_data.vs_current; fi_ptr = mtape_data.fi_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; arg_code, code = 0; /* and reset error codes */ end SETUP; %page; %include mtape_includes; %page; %include rcp_volume_formats; end gcos_tape_io_;  ibm_tape_io_.pl1 01/27/00 1827.0r w 01/27/00 1827.0 579420 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-09-16,Farley), approve(88-10-06,MCR8003), audit(88-10-06,Fawcett), install(88-10-10,MR12.2-1152): Correct a problem of getting a hardware status of "Transmission parity alert" when writing the data to tape in ascii mode. This requires the zeroing of the reserved fields in the RDW, SDW and BDW structures. 2) change(00-01-26,Schroth), approve(00-01-26,MECR-Y2K): Changed expiry date checking to use new pfm_utils_$label_unexpired to verify if a file has expired. END HISTORY COMMENTS */ /****^ HIST ORY COMMENTS: 1) change(85-06-10,GWMay), approve(), audit(), install(): modified call to pfm_utils_$position_in_file to use the position constant required by the routine rather than a numeric value. 2) change(88-02-03,GWMay), approve(88-02-03,MCR7837), audit(88-04-12,Farley), install(88-04-19,MR12.2-1039): Changed to process user specified labels correctly. Changed to correctly set the RCP auth code in the header. END HISTORY COMMENTS */ ibm_tape_io_: procedure; /* format: style4 */ /* * This program is known as a tape Per-Format module and runs under * control of the mtape_ I/O module and is meant to process tape volumes * and files in IBM standard format. * * This Per-Format module uses the following PFM dependent option flags: * * mtape_open_info.pfm_opt_sw (1) = "1"b = -dos * mtape_open_info.pfm_opt_sw (1) = "0"b = -no_dos * mtape_open_info.pfm_opt_sw (2) = "1"b = -system_use * mtape_open_info.pfm_opt_sw (2) = "0"b = -no_system_use * * Modification History: * * Created by J. A. Bush 11/01/82 * Modified by J. A. Bush 11/10/83 for performance improvements * Modified by Greg Texada 11/21/84 to pad U format records too. */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to the mtape data structure */ dcl arg_code fixed bin (35); /* Return error code */ dcl arg_info_ptr ptr; /* Pointer to Order data from iox_$control call */ dcl arg_io_call_infop ptr; /* Pointer to io_call control info structure */ dcl arg_order_name char (*); /* Name of Control order to be processed */ dcl arg_lr_ptr ptr; /* Pointer to current label record structure */ dcl arg_labno fixed bin; /* label record within label group */ dcl arg_type fixed bin; /* 1 => BOF; 2 => EOV; 3 => EOF */ dcl arg_convert fixed bin; /* Label record conversion indicator */ /* AUTOMATIC DATA */ dcl Schecked_labels bit (1) aligned; dcl buf_ptr ptr; /* Auto copy of users buffer pointer */ dcl buf_len fixed bin (21); /* Auto copy of users lrec buffer */ dcl rec_len fixed bin (21); /* Auto copy of logical record length */ dcl order_name char (32); /* Auto copy of order name */ dcl info_ptr ptr; /* Auto copy of order info pointer */ dcl user_label_data char (76); /* storage for user label data */ dcl auth_code char (3) aligned; dcl today char (6); dcl temp_fmt char (3); dcl temp_mode char (6); dcl (term, long_record, output) bit (1) aligned; dcl (nvp, nlp, move_ptr) ptr; dcl (i, desc_type, label_type, n_segs, uln, open_idx, slab) fixed bin; dcl (move_len, crl, bytes_remaining, bytes_processed) fixed bin (21); dcl dbl bit (18); dcl pic1 picture "9"; dcl pic2 picture "99"; dcl pic4 picture "9999"; dcl pic5 picture "99999"; dcl pic6 picture "999999"; dcl (code, fl_code) fixed bin (35); /* CONSTANT DATA */ dcl myname char (32) int static options (constant) init ("ibm_tape_io_"); dcl LABEL_LENGTH fixed bin (21) int static options (constant) init (80); /* length of label records in bytes */ dcl MAX_IBM_RECORD_SIZE fixed bin int static options (constant) init (99999); dcl WRITING bit (1) aligned int static options (constant) init ("1"b); dcl OPENING bit (1) aligned int static options (constant) init ("0"b); dcl NON_MOD_FOUR fixed bin int static options (constant) init (1); dcl IBM_ASCII_PAD_CHAR char (1) int static options (constant) init (" "); dcl IBM_EBCDIC_PAD_CHAR char (1) int static options (constant) init ("_"); dcl CW_LENGTH fixed bin int static options (constant) init (4); /* Length of an record and segment descriptors */ dcl (SEG_B_E init (0), /* Record begins and ends in this segment */ SEG_B_NE init (1), /* Record begins but does not end in this segment */ SEG_NB_E init (2), /* Record ends but does not begin in this segment */ SEG_NB_NE init (3)) /* Record neither begins nor ends in this segment */ fixed bin int static options (constant); dcl U_LABEL_ID (3) char (3) int static options (constant) init ("UHL", "UTL", "UTL"); dcl IBM_FORMAT_CODES (0:7) char (3) int static options (constant) init (" ", "U ", "F ", "V ", "VS ", "FB ", "VB ", "VBS"); dcl LC char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl UC char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); /* EXTERNAL STATIC DATA */ 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_$long_record fixed bin (35) ext static; dcl error_table_$invalid_record_desc fixed bin (35) ext static; dcl error_table_$bad_file fixed bin (35) ext static; dcl error_table_$no_operation fixed bin (35) ext static; dcl error_table_$no_file fixed bin (35) ext static; dcl error_table_$no_next_volume fixed bin (35) ext static; dcl error_table_$invalid_label_format fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$uninitialized_volume fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (addr, binary, bit, copy, fixed, hbound, index, lbound, length, ltrim, mod, null, rel, size, substr, translate) builtin; dcl conversion condition; /* EXTERNAL ENTRIES */ dcl authenticate_ entry (char (*)) returns (char (3) aligned); dcl ebcdic_to_ascii_ entry (char (*), char (*)); dcl ascii_to_ebcdic_ entry (char (*), char (*)); /* BASED VARIABLES */ dcl based_area area based (mtape_data.areap); dcl based_label_record char (LABEL_LENGTH) based (mtape_label_record.lab_ptr); dcl based_lrec_data char (move_len) based; /* to move data to/from users buffer */ dcl based_lrec_index (buf_len) char (1) based (mtape_data.arg_buf_ptr); /* to increment users buffer ptr */ dcl 1 bdw unaligned based (mtape_data.cur_buf_ptr), /* block descriptor word */ 2 length bit (18), /* binary length of block */ 2 reserved fixed bin (17); /* reserved for future system use (MBZ) */ dcl 1 vb_record unaligned based (mtape_data.log_record_ptr), /* Template for V/VB formated records */ 2 rdw, /* record descriptor word */ 3 length bit (18), /* binary length of record */ 3 reserved fixed bin (17), /* reserved for future system use (MBZ) */ 2 rdata char (move_len); /* logical record data */ dcl 1 vbs_record unaligned based (mtape_data.log_record_ptr), /* Template for VS/VBS formated records */ 2 sdw, /* Segment descriptor word */ 3 length bit (18), /* binary length of record */ 3 span_indicator fixed bin (8), /* controls of segments in record */ 3 reserved fixed bin (8), /* reserved for future system use (MBZ) */ 2 rdata char (move_len), /* logical record data */ 2 nxt_lrec char (1); /* to position to nxt record */ %page; /* pfm_init - entry to initialize the Per-Format module, setting up file and volume processing parameters and determining correctness of current volume */ pfm_init: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ call CHECK_VERSION (mtdp, mtape_data_version_1, "mtape_data"); /* check version of this structure every time */ /* When the pfm_init entry is called for the first time we must allocate a label record structure to read tape labels into. We must also check the various structure versions to make sure we know what the caller is talking about. */ if mtape_data.tlb = null then do; mcip = mtape_data.close_info_ptr; /* set ptr to close into structure */ call pfm_utils_$init_label_record (mtdp, null, null, mtape_data.tlb, LABEL_LENGTH); mtape_data.tlb -> mtape_label_record.conversion = MTAPE_CV_UC_EBCDIC; /* IBM labels in EBCDIC */ call CHECK_VERSION (mtape_data.tlb, mtape_lr_version_1, "mtape_label_record"); call CHECK_VERSION (vs_ptr, mtape_vs_version_1, "mtape_vol_set"); call CHECK_VERSION (maip, mtape_attach_info_version_1, "mtape_attach_info"); call CHECK_VERSION (moip, mtape_open_info_version_1, "mtape_open_info"); call CHECK_VERSION (mcip, mtape_close_info_version_1, "mtape_close_info"); call CHECK_VERSION (mpfmip, mtape_pfm_info_version_1, "mtape_pfm_info"); call mtape_$alloc (mtdp, MTAPE_ALLOC_FI, null, 0, fi_ptr); /* allocate dummy file_info structure */ call CHECK_VERSION (fi_ptr, mtape_fi_version_1, "mtape_file_info"); /* and check its version */ free mtape_file_info in (based_area); /* we can free it now */ /* initialize the pfm_info structure for this PFM */ mtape_pfm_info.open_modes_allowed (1) = Sequential_input; mtape_pfm_info.open_modes_allowed (2) = Sequential_output; mtape_pfm_info.bof_prefix = "HDR"; mtape_pfm_info.eov_prefix = "EOV"; mtape_pfm_info.eof_prefix = "EOF"; mtape_pfm_info.module_id = "IBM"; mtape_pfm_info.no_labels_ok = "1"b; mtape_pfm_info.multi_volumes_ok = "1"b; mtape_pfm_info.extended_error_recovery = "0"b; end; if mtape_vol_set.volume_type = Volume_ibm_tape then /* If an ibm tape.. */ call CHECK_VOL_LABELS (mtape_vol_set.volume_check); /* check the volume labels */ else do; /* Not an ibm tape, don't bother to read labels */ if mtape_vol_set.volume_type = Volume_blank | mtape_vol_set.volume_type = Volume_unreadable then mtape_vol_set.volume_check = BLANK_VOLUME; else if mtape_vol_set.volume_type = Volume_unknown_format then mtape_vol_set.volume_check = UNLABELED_VOLUME; else mtape_vol_set.volume_check = RECOG_FORMAT_VOLUME; mtape_data.lab_buf_len = LABEL_LENGTH; /* set in case subsequent volumes are labeled */ end; pfm_init_return: /* target of non-local gotos */ arg_code = code; return; %page; /* file_open - entry to do format specific processing in opening the file or file set (i.e. read and write file labels) */ file_open: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ call SET_OPEN_IDX; /* determine what type of processing to do */ call pfm_utils_$file_search (mtdp, fi_ptr, vs_ptr, code); /* search for the file */ if code ^= 0 & open_idx ^= 1 then /* if error and not creating file.. */ go to open_return; /* quit now */ go to open_action (open_idx); /* do the appropriate thing */ open_action (0): /* open for input */ call CHECK_USER_LABELS (BOF_LABEL); /* go see if user labels to be processed */ call SET_FILE_ATTRIBUTES; /* complete file attributes from open desc */ go to open_return; open_action (1): /* Open for output, creation */ if code = 0 | /* if no error */ code = error_table_$no_file | /* or if could not find file */ code = error_table_$uninitialized_volume then do; /* or if bad vol label */ if NEED_TO_INIT_VOLUME () then do; /* if volume requires initialization.. */ call INIT_VOL_LABELS; /* initialize the volume labels */ if code ^= 0 then go to open_return; end; code = 0; /* reset possible error code */ call SETUP_NEW_FILE; /* setup new file info structure */ if code ^= 0 then go to open_return; call pfm_utils_$write_file_labels (mtdp, BOF_LABEL, code); /* go write the file header labels */ if code = 0 then /* if no error */ if mtape_vol_set.volume_end then /* did we run out of tape? */ call EOV_ON_WRITE (OPENING); /* yes, do volume switch now */ end; go to open_return; open_action (2): /* open for output, extend existing file */ mtape_data.phy_block = mtape_file_info.block_count; /* preset block number */ open_action (3): /* open for output, modify existing file */ call pfm_utils_$truncate_file_set (mtdp); /* get rid of EOF labels if extend | modify */ mtape_file_info.gen_version = mod (mtape_file_info.gen_version, 100) + 1; /* increment version */ open_return: arg_code = code; /* return error code */ return; %page; /* file_close - entry to do format specific processing in closing the file or file set (i.e. read and write file trailer labels) */ file_close: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ mcip = mtape_data.close_info_ptr; /* set up close info ptr too */ if mtape_open_info.open_mode = Sequential_input then /* input operation? */ output = "0"b; /* yes, reset output flag */ else output = "1"b; /* true if sqo or sqio */ if output & mtape_data.error_lock ^= error_table_$no_next_volume then do; /* if writing tape */ if mtape_data.error_lock = 0 then do; /* flush out only if possible */ if mtape_data.processed > mtape_data.buffer_offset then /* if we have some unwritten data */ call WRITE_BLOCK; /* write a short block */ call mtape_$flush_buffers (mtdp, code); /* write out all queued buffers */ if code ^= 0 then /* if some error writing data */ if code = error_table_$eov_on_write then /* Is it end of tape? */ call EOV_ON_WRITE (WRITING); /* Go close out volume and initiate volume switch */ if code ^= 0 then go to close_file_return; end; call pfm_utils_$write_file_labels (mtdp, EOF_LABEL, code); /* write out EOF labels */ if code ^= 0 then /* error writing labels.. */ go to close_file_return; end; else do; /* input operation, must make sure tape is stoped */ call mtape_$stop_tape (mtdp, code); if code ^= 0 then go to close_file_return; end; Schecked_labels = "0"b; /* USER trailers can only be returned when */ /* positioned after the file data */ if ^output & mtape_file_info.position_within_file = AT_EOF then do; call CHECK_USER_LABELS (EOF_LABEL); /* go see if user labels to be processed */ Schecked_labels = "1"b; end; if mtape_close_info.position ^= 0 then do; /* if not leaving tape where it is.. */ call pfm_utils_$position_in_file (mtdp, fi_ptr, vs_ptr, mtape_close_info.position, code); if ^output & code = 0 & ^Schecked_labels & mtape_file_info.position_within_file = AT_EOFH then call CHECK_USER_LABELS (EOF_LABEL); end; close_file_return: arg_code = code; /* copy return error code (if any) */ return; %page; /* read - entry to read format specific logical records from the current file */ read: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; /* If = null, return length of next record */ buf_len = mtape_data.arg_buf_len; code, rec_len = 0; /* initialize return record length */ long_record = "0"b; /* init long record flag */ if mtape_data.remain <= 0 then /* Do we need to read in a block? */ call GET_NXT_RECORD; /* yes, do it */ go to READ_TYPE (mtape_data.ad_file_format); /* process depending on file format */ READ_TYPE (1): /* Process "U" formated records */ crl, move_len = mtape_data.remain; /* user gets entire block */ move_ptr = mtape_data.log_record_ptr; /* set pointer to move data from */ call MOVE_TO_USER; /* move the data to the users buffer */ go to read_return; READ_TYPE (2): /* Process "F/FB" formated records */ if mtape_data.record_size > mtape_data.remain then/* don't try to move more than we have */ crl = mtape_data.remain; else crl = mtape_data.record_size; move_len = crl; move_ptr = mtape_data.log_record_ptr; /* set pointer to move data from */ call MOVE_TO_USER; /* give the user his data */ go to read_return; READ_TYPE (3): /* Process "V/VB" formated records */ if mtape_data.remain < CW_LENGTH then /* in case we have mod 4 padded block */ call GET_NXT_RECORD; /* go read next block */ if mtape_data.hdw_mode ^= MTAPE_HWM_BIN then do; /* if not binary mode */ dbl = vb_record.rdw.length; /* 9 bit mode, must shift rdw length */ substr (dbl, 10) = substr (dbl, 11); crl = binary (bit (substr (dbl, 1, 17), 17), 21); end; else crl = binary (vb_record.rdw.length, 21); /* binary mode copy length */ move_len = crl - CW_LENGTH; move_ptr = addr (vb_record.rdata); /* set pointer to move data from */ call MOVE_TO_USER; /* give the user his data */ go to read_return; %page; READ_TYPE (4): /* Process "VS/VBS" formated records */ if mtape_data.remain < CW_LENGTH then /* in case we have mod 4 padded block */ call GET_NXT_RECORD; /* go read next block */ term = "0"b; /* reset terminate condition */ do n_segs = 1 by 1 while (^term); /* 1 record may be made up of several segments and blocks */ call CONVERT_DESC; /* convert segment descriptor */ if n_segs = 1 then /* if first pass through */ do while (desc_type ^= SEG_B_E & desc_type ^= SEG_B_NE); /* make sure we get new record */ mtape_data.remain = mtape_data.remain - crl; mtape_data.log_record_ptr = addr (vbs_record.nxt_lrec); if mtape_data.remain <= 0 then /* Do we have to read in a new block? */ call GET_NXT_RECORD; call CONVERT_DESC; end; move_ptr = addr (vbs_record.rdata); /* set ptr to move data */ call MOVE_TO_USER; /* give the user his data */ if desc_type = SEG_B_E | desc_type = SEG_NB_E then /* end of the record? */ term = "1"b; /* yes, set terminate condition */ else if mtape_data.remain <= 0 then /* No, New segment in next block? */ call GET_NXT_RECORD; /* yes, do it */ end; read_return: mtape_data.arg_rec_len = rec_len; /* give the user the length of the record */ if code = 0 then /* if no error but.. */ if long_record then /* we had a longer record than the users buffer */ code = error_table_$long_record; /* tell him about it */ arg_code = code; /* return error code */ return; %page; /* write - entry to write format specific logical records into the current file */ write: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* Copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; buf_len = mtape_data.arg_buf_len; code = 0; if buf_ptr = null then do; /* User wants to flush out buffers */ if mtape_data.processed > mtape_data.buffer_offset then /* if we have some unwritten data */ call WRITE_BLOCK; /* write a short block */ call mtape_$flush_buffers (mtdp, code); /* write out all queued buffers */ if code ^= 0 then /* if some error writing data */ if code = error_table_$eov_on_write then do; /* Is it end of tape? */ call LOAD_PTRS; /* load up structure pointers */ call EOV_ON_WRITE (WRITING); /* Go close out volume and initiate volume switch */ end; go to write_return; /* return to user */ end; go to WRITE_TYPE (mtape_data.ad_file_format); /* process depending on file format */ WRITE_TYPE (1): /* Write "U" formated records */ call LONG_RECORD_CHECK (buf_len, "0"b); /* check for long record */ move_len = buf_len; /* writes entire block */ move_ptr = mtape_data.log_record_ptr; /* set pointer to move data to */ call MOVE_TO_BUFFER (0, 0); /* move the data to the tape buffer */ go to write_return; WRITE_TYPE (2): /* Write "F/FB" formated records */ call LONG_RECORD_CHECK (buf_len, "1"b); /* check for long record */ if mtape_data.record_size > mtape_data.remain then/* don't try to move more than we have */ call WRITE_BLOCK; /* write out the current block */ move_len = buf_len; move_ptr = mtape_data.log_record_ptr; /* set pointer to move data from */ call MOVE_TO_BUFFER (0, 1); /* give the user his data */ go to write_return; WRITE_TYPE (3): /* Write "V/VB" formated records */ call LONG_RECORD_CHECK (buf_len, "1"b); /* check for long record */ if buf_len + CW_LENGTH > mtape_data.remain then /* if record won't fit in this block */ call WRITE_BLOCK; /* write out the current block */ move_len = buf_len; /* set record length */ dbl = bit (binary (move_len + CW_LENGTH, 18), 18);/* convert byte count for scw */ if mtape_data.hdw_mode ^= MTAPE_HWM_BIN then /* if not binary mode */ substr (dbl, 2, 9) = substr (dbl, 3, 8) || "0"b; /* shift out 9th bit */ vb_record.rdw.length = dbl; /* set record length */ vb_record.rdw.reserved = 0; /* set MBZ field */ move_ptr = addr (vb_record.rdata); /* set pointer to move data from */ call MOVE_TO_BUFFER (CW_LENGTH, CW_LENGTH); /* copy the users data */ go to write_return; %page; WRITE_TYPE (4): /* Write "VS/VBS" formated records */ call LONG_RECORD_CHECK (buf_len, "1"b); /* check for long record */ bytes_remaining = buf_len; /* set user buffer extents */ bytes_processed = 0; term = "0"b; /* reset terminate condition */ do n_segs = 1 by 1 while (^term); /* 1 record may be made up of several segments and blocks */ if bytes_remaining <= mtape_data.remain - CW_LENGTH then do; /* will record fit in this block? */ term = "1"b; /* yes, set terminate condition */ if n_segs = 1 then /* entire record fit in 1st block? */ desc_type = SEG_B_E; /* Yes, record begins and ends in this segment */ else desc_type = SEG_NB_E; /* No, record ends but does not begin in this segment */ move_len = bytes_remaining; /* move last part (or all) of record */ end; else do; /* No, record will not fit in current block */ if n_segs = 1 then /* is this the first record segment? */ desc_type = SEG_B_NE; /* Yes, record begins but does not end in this segment */ else desc_type = SEG_NB_NE; /* No, record neither begins nor ends in this segment */ move_len = mtape_data.remain - CW_LENGTH; /* use rest of or entire block */ bytes_remaining = bytes_remaining - move_len; /* decrement remaining bytes to process */ end; bytes_processed = bytes_processed + move_len;/* add up total moved so far */ dbl = bit (binary (move_len + CW_LENGTH, 18), 18); /* convert byte count for scw */ move_ptr = addr (vbs_record.rdata); /* set ptr to move data */ if mtape_data.hdw_mode ^= MTAPE_HWM_BIN then /* if not binary mode */ substr (dbl, 2, 9) = substr (dbl, 3, 8) || "0"b; /* shift out 9th bit */ vbs_record.sdw.length = dbl; /* set record length */ vbs_record.sdw.span_indicator = desc_type; /* and span indicator */ vbs_record.sdw.reserved = 0; /* set MBZ field */ call MOVE_TO_BUFFER (CW_LENGTH, CW_LENGTH + 1); /* copy the users data */ buf_ptr = addr (based_lrec_index (bytes_processed + 1)); /* increment users buffer ptr */ end; write_return: arg_code = code; /* return error code */ return; %page; /* order - entry to process format specific control orders not recognized by mtape_ */ order: entry (arg_mtdp, arg_order_name, arg_info_ptr, arg_io_call_infop, arg_code); call SETUP; /* initialize our enviornment */ order_name = arg_order_name; info_ptr = arg_info_ptr; arg_code = error_table_$no_operation; /* IBM PFM has no local control operations */ return; %page; /* decode_file_labels - entry to extract info contained in file labels, and fill in file_info structure */ decode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_code); call SETUP; /* initialize our enviornment */ lr_ptr = arg_lr_ptr; on conversion begin; /* set up handler for conversion errors */ code = error_table_$invalid_label_format; /* set appropriate error code */ call mtape_$error (mtdp, code, "^/Converting IBM ^a^d label record to binary. Label contents:^/""^a""", substr (based_label_record, 1, 3), arg_labno, based_label_record); go to dfl_return; end; ibm_hdr1P, ibm_hdr2P = mtape_label_record.lab_ptr;/* set up both template ptrs */ go to LTYPE (arg_type); /* decode appropriate label type */ LTYPE (1): /* Beginning of file label */ if ibm_hdr1.label_id = IBM_L1_ID (IBM_HDR1) then do; /* IBM HDR1 label */ if arg_labno ^= 1 then call mtape_$error (mtdp, error_table_$invalid_label_format, " Additional IBM HDR1 label found while looking for IBM ^a^d label for file ^a. Read continues using: ""^a""", substr (based_label_record, 1, 3), arg_labno, mtape_file_info.file_id, based_label_record); mtape_file_info.file_id = ibm_hdr1.dataset_id; mtape_file_info.file_set_id = ibm_hdr1.dataset_serial; mtape_file_info.seq_number = binary (ibm_hdr1.dataset_sequence, 17); mtape_file_info.generation = binary (ibm_hdr1.generation, 17); mtape_file_info.gen_version = binary (ibm_hdr1.version, 17); mtape_file_info.creation_date = ibm_hdr1.creation; mtape_file_info.expiration_date = ibm_hdr1.expiration; mtape_file_info.section = 1; /* set for section 1 initially */ if mtape_file_info.prev_fi_ptr ^= null then /* if we have a previous file */ if mtape_file_info.prev_fi_ptr -> mtape_file_info.file_id = mtape_file_info.file_id then mtape_file_info.section = mtape_file_info.prev_fi_ptr -> mtape_file_info.section + 1; mtape_file_info.pfm_opt_sw (1) = "1"b; /* DOS file until proven otherwise */ if ibm_hdr1.system = IBM_SYS_CODE then /* tape recorded by this module? */ mtape_file_info.native_file = "1"b; /* yes, set flag */ end; else if ibm_hdr2.label_id = IBM_L2_ID (IBM_HDR2) then do; /* IBM HDR2 label */ if arg_labno ^= 2 then call mtape_$error (mtdp, error_table_$invalid_label_format, " Additional IBM HDR2 label found while looking for IBM ^a^d label for file ^a. Read continues using: ""^a""", substr (based_label_record, 1, 3), arg_labno, mtape_file_info.file_id, based_label_record); mtape_file_info.pfm_opt_sw (1) = "0"b; /* this is not a DOS file */ temp_fmt = ibm_hdr2.format || ibm_hdr2.block_attribute; /* form file format code */ if substr (temp_fmt, 2, 1) = "R" then /* if records are blocked and spanned */ substr (temp_fmt, 2, 2) = "BS"; /* correct format code */ if ibm_hdr2.format = "V" then /* if variable length format */ mtape_file_info.buffer_offset = size (bdw) * 4; /* compensate for block descriptor */ mtape_file_info.block_size = binary (ibm_hdr2.blksize, 21); mtape_file_info.record_size = binary (ibm_hdr2.lrecl, 21); mtape_file_info.length_mode = NON_MOD_FOUR; /* set special length mode as default */ mtape_file_info.hdw_mode = MTAPE_UNSPECIFIED; mtape_file_info.conversion = MTAPE_CV_EBCDIC;/* EBCDIC conversion by default */ if mtape_file_info.native_file then /* if recorded by mtape_ */ if ibm_system_use.mode ^= "" then do; /* and was recorded with "-system_use" */ if ibm_system_use.mode = "1" then do; /* if recorded in ASCII mode */ mtape_file_info.conversion = MTAPE_NO_CONVERSION; /* no conversion necessary */ mtape_file_info.hdw_mode = MTAPE_HWM_NINE; /* set nine mode */ end; else if ibm_system_use.mode = "2" then /* if recorded in EBCDIC */ mtape_file_info.hdw_mode = MTAPE_HWM_NINE; /* set nine mode */ else if ibm_system_use.mode = "3" then do; /* if recorded in binary mode.. */ mtape_file_info.conversion = MTAPE_NO_CONVERSION; /* no conversion necessary */ mtape_file_info.hdw_mode = MTAPE_HWM_BIN; end; end; mtape_file_info.file_code = temp_fmt; /* set file code */ do i = 0 to hbound (IBM_FORMAT_CODES, 1); /* set the file format */ if temp_fmt = IBM_FORMAT_CODES (i) then /* found it */ mtape_file_info.file_format = i; end; end; else if substr (based_label_record, 1, length (U_LABEL_ID (arg_type))) = U_LABEL_ID (arg_type) then /* user labels present */ mtape_file_info.user_labels_present = "1"b; return; LTYPE (2): /* End of volume label */ if arg_labno = 1 then /* if IBM EOV1 label */ mtape_file_info.block_count = binary (ibm_hdr1.blkcnt, 35); /* extract block count */ else if arg_labno = 2 then do; /* if IBM EOV2 label */ if mtape_vol_set.volume_check = MTAPE_VOLUME then /* check Multics specific stuff */ if ibm_system_use.next_volname ^= "" then do; /* if recorded with "-system_use" */ if mtape_vol_set.next_vs_ptr = null then do; /* if no VS structure */ call mtape_$alloc (mtdp, MTAPE_ALLOC_VS, mtape_data.vs_tail, 0, nvp); mtape_data.vs_tail = nvp; end; else nvp = mtape_vol_set.next_vs_ptr; if nvp -> mtape_vol_set.volume_name ^= ibm_system_use.next_volname then nvp -> mtape_vol_set.volume_name = ibm_system_use.next_volname; end; end; else if substr (based_label_record, 1, length (U_LABEL_ID (arg_type))) = U_LABEL_ID (arg_type) then do; /* user labels present */ mtape_file_info.user_labels_present = "1"b; call CHECK_USER_LABELS (EOV_LABEL); end; return; LTYPE (3): /* End of file label */ if ibm_hdr1.label_id = IBM_L1_ID (IBM_EOF1) then do; if arg_labno ^= 1 then call mtape_$error (mtdp, error_table_$invalid_label_format, " Additional IBM EOF1 label found while looking for IBM ^a^d label for file ^a. Read continues using: ""^a""", substr (based_label_record, 1, 3), arg_labno, mtape_file_info.file_id, based_label_record); mtape_file_info.block_count = binary (ibm_hdr1.blkcnt, 35); /* extract block count */ mtape_file_info.gen_version = binary (ibm_hdr1.version, 17); /* save in case modified | extended file */ end; else if substr (based_label_record, 1, length (U_LABEL_ID (arg_type))) = U_LABEL_ID (arg_type) then /* user labels present */ mtape_file_info.user_labels_present = "1"b; dfl_return: arg_code = code; return; %page; /* encode_file_labels - entry to fill in file labels from info obtained from file_info structure */ encode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_convert, arg_code); call SETUP; /* initialize our enviornment */ lr_ptr = arg_lr_ptr; based_label_record = ""; /* initialize to blanks first */ arg_convert = MTAPE_CV_UC_EBCDIC; /* set conversion to uper case ebcdic */ if arg_labno = 1 then do; /* init HDR1/EOV1/EOF1 label */ if arg_type = EOV_LABEL then /* if writing EOV sequence */ if mtape_vol_set.next_vs_ptr = null then do; /* and no next volume */ call mtape_$user_query (mtdp, Q_NO_NEXT_VOLUME, code); /* ask user for a new one */ if code ^= 0 then /* if he didn't want to continue */ go to efl_return; /* forget it */ end; ibm_hdr1P = mtape_label_record.lab_ptr; ibm_hdr1.label_id = IBM_L1_ID (arg_type); /* Now fill it in */ ibm_hdr1.dataset_id = substr (mtape_file_info.file_id, 1, length (ibm_hdr1.dataset_id)); ibm_hdr1.dataset_serial = substr (mtape_file_info.file_set_id, 1, length (ibm_hdr1.dataset_serial)); pic4 = mtape_vol_set.volume_index; ibm_hdr1.volume_sequence = pic4; pic4 = mtape_file_info.seq_number; ibm_hdr1.dataset_sequence = pic4; if mtape_file_info.generation = 0 then /* if not a file generation */ ibm_hdr1.generation, ibm_hdr1.version = ""; else do; pic4 = mtape_file_info.generation; ibm_hdr1.generation = pic4; pic2 = mtape_file_info.gen_version; ibm_hdr1.version = pic2; end; ibm_hdr1.creation = mtape_file_info.creation_date; ibm_hdr1.expiration = mtape_file_info.expiration_date; ibm_hdr1.security = "0"; /* Always unlimited access */ if arg_type > BOF_LABEL then do; /* if EOV/EOF label */ pic6 = mtape_file_info.block_count; /* fill in the block count */ ibm_hdr1.blkcnt = pic6; end; else ibm_hdr1.blkcnt = "000000"; /* used only for EOF/EOV1 records */ ibm_hdr1.system = IBM_SYS_CODE; return; end; else if arg_labno = 2 & ^mtape_file_info.pfm_opt_sw (1) then do; /* init HDR2/EOV2/EOF2 label */ ibm_hdr2P = mtape_label_record.lab_ptr; ibm_hdr2.label_id = IBM_L2_ID (arg_type); /* Now fill it in */ ibm_hdr2.format = substr (IBM_FORMAT_CODES (mtape_file_info.file_format), 1, 1); pic5 = mtape_file_info.block_size; ibm_hdr2.blksize = pic5; if mtape_file_info.record_size <= MAX_IBM_RECORD_SIZE then do; /* if it will fit */ pic5 = mtape_file_info.record_size; ibm_hdr2.lrecl = pic5; end; else ibm_hdr2.lrecl = "00000"; if mtape_file_info.file_format < 5 then /* if records are not blocked */ if mtape_file_info.file_format ^= 4 then/* and not spanned */ ibm_hdr2.block_attribute = " "; else ibm_hdr2.block_attribute = "S"; /* records are spanned but not blocked */ else if mtape_file_info.file_format ^= 7 then/* records are blocked but not spanned */ ibm_hdr2.block_attribute = "B"; else ibm_hdr2.block_attribute = "R"; /* records are both blocked and spanned */ if mtape_file_info.section > 1 then /* if a volume switch has ocurred */ ibm_hdr2.dataset_position = "1"; else ibm_hdr2.dataset_position = "0"; do i = 0 to hbound (MTAPE_VALID_DENSITIES, 1) - 1; /* set the density code */ if mtape_vol_set.volume_density = MTAPE_VALID_DENSITIES (i + 1) then pic1 = i; end; ibm_hdr2.density = pic1; ibm_hdr2.recording_technique = ""; /* odd parity, no translation */ ibm_hdr2.control_characters = " "; /* No control characters used */ ibm_hdr2.jobstep_id = "MULTICS /" || ltrim (mtape_file_info.creation_date); if mtape_file_info.pfm_opt_sw (2) then do; /* if "-system_use" specified */ if arg_type = EOV_LABEL then do; /* if at EOV */ if mtape_vol_set.next_vs_ptr ^= null then /* and if we have another volume */ ibm_system_use.next_volname = substr (mtape_vol_set.next_vs_ptr -> mtape_vol_set.volume_name, 1, length (ibm_system_use.next_volname)); arg_convert = MTAPE_CV_EBCDIC; /* don't convert volume id */ end; if mtape_file_info.hdw_mode = MTAPE_HWM_BIN then /* if recording in binary mode */ ibm_system_use.mode = "3"; else if mtape_file_info.conversion = MTAPE_CV_EBCDIC then /* if recording EBCDIC data */ ibm_system_use.mode = "2"; else ibm_system_use.mode = "1"; /* ASCII NINE mode */ end; return; end; else if mtape_open_info.label_entry_present then do; /* if writing user labels */ if mtape_file_info.pfm_opt_sw (1) then /* if DOS file */ slab = 1; /* only 1 system label */ else slab = 2; /* otherwise there is 2 */ if arg_labno < (10 + slab) then do; /* and not at max of 9 yet */ uln = arg_labno - slab; /* user labels start at 1 */ user_label_data = ""; call mtape_open_info.user_label (mtape_data.iocb_ptr, user_label_data, uln, arg_type, mtape_file_info.section, code); /* call the user label routine */ if code ^= 0 then /* if error indicated from user routine */ if code = error_table_$end_of_info then /* but it is normal termination */ go to efl_return; /* return with end of info indication */ else do; /* some other error report it */ call mtape_$error (mtdp, code, "^/Calling the user label processing routine to process the ^a^d label record.", U_LABEL_ID (arg_type), uln, slab); code = error_table_$end_of_info; /* force user label termination */ go to efl_return; end; pic1 = uln; /* convert label number to ascii */ based_label_record = U_LABEL_ID (arg_type) || pic1 || user_label_data; /* form completed user label */ go to efl_return; end; end; code = error_table_$end_of_info; /* terminate label processing */ efl_return: arg_code = code; /* copy error code */ return; %page; /* CHECK_NEW_FILE_SECTION - internal procedure to check consistency of new file section */ CHECK_NEW_FILE_SECTION: proc; dcl per_file_overlay char (ov_len) based (addr (mtape_file_info.per_file_info)); dcl ov_len fixed bin; dcl pp ptr; code = 0; fi_ptr = mtape_file_info.next_fi_ptr; /* file info will be allocated if null */ call pfm_utils_$read_file_labels (mtdp, fi_ptr, vs_ptr, label_type, code); /* read new file sect. HDR labels */ if code ^= 0 then return; if label_type ^= BOF_LABEL then do; /* error if not header labels */ code = error_table_$bad_file; call mtape_$error (mtdp, code, "^/^[EOV^;EOF^] file label found where BOF label record expected", label_type); return; end; call SET_FILE_ATTRIBUTES; /* set up missing pieces */ pp = mtape_file_info.prev_fi_ptr; /* get prev file ptr */ ov_len = (binary (rel (addr (mtape_file_info.per_section_info))) - binary (rel (addr (mtape_file_info.per_file_info)))) * 4; if mtape_file_info.record_size ^= pp -> mtape_file_info.record_size then /* if record sizes */ if mtape_file_info.record_size = 0 then /* are ^=, but new section = 0 */ pp -> mtape_file_info.record_size = 0; /* make 1st section = 0 too */ if mtape_file_info.section ^= pp -> mtape_file_info.section + 1 | per_file_overlay ^= addr (pp -> mtape_file_info.per_file_info) -> per_file_overlay then do; code = error_table_$bad_file; /* set an appropriate error code */ call mtape_$error (mtdp, code, "^/New file section for File ""^a"" on volume ""^a"" is inconsistent with previous section", pp -> mtape_file_info.file_id, mtape_vol_set.volume_id); end; call mtape_$set_mode (mtdp, "data", mtape_data.hdw_mode, null, code); /* set hardware mode */ end CHECK_NEW_FILE_SECTION; %page; /* CHECK_USER_LABELS - procedure to check if user labels and a user label entry exist */ CHECK_USER_LABELS: proc (htype); dcl htype fixed bin; dcl flrp ptr; if mtape_file_info.user_labels_present then /* if file contains user labels */ if mtape_open_info.label_entry_present then do; /* and user wants to see them */ if htype > BOF_LABEL then /* trailer labels? */ flrp = mtape_file_info.first_file_trail_ptr; /* yes, search trailer list */ else flrp = mtape_file_info.first_file_lab_ptr; /* search header list */ do lr_ptr = flrp repeat mtape_label_record.next_lab_ptr /* search up to 1st user label */ while (substr (based_label_record, 1, 1) ^= "U"); end; do lr_ptr = lr_ptr repeat mtape_label_record.next_lab_ptr while (lr_ptr ^= null); /* send him all labels */ user_label_data = substr (based_label_record, 5); /* copy user data */ i = fixed (substr (based_label_record, 4, 1), 17); /* get label number */ call mtape_open_info.user_label (mtape_data.iocb_ptr, /* call the user label routine */ user_label_data, i, htype, mtape_file_info.section, (0)); /* ignore error code */ end; end; end CHECK_USER_LABELS; /* CHECK_VERSION - internal procedure to check struture version numbers */ CHECK_VERSION: proc (s_ptr, req_version, struc_name); dcl s_ptr ptr; dcl req_version char (8); dcl struc_name char (32); dcl 1 version_check based (s_ptr) aligned, /* generic structure to check verison number */ 2 version char (8); if version_check.version ^= req_version then do; /* they do not match */ code = error_table_$unimplemented_version; /* set error code */ call mtape_$error (mtdp, code, "^/^a: Expecting ""^a"" version for ^a structure. Version recorded in received structure is ""^a"".", myname, req_version, struc_name, version_check.version); go to pfm_init_return; /* take non-local goto and return to caller */ end; end CHECK_VERSION; %page; /* CHECK_VOL_LABELS - internal procedure to read volume label(s) of a known IBM volume */ CHECK_VOL_LABELS: proc (ridx); dcl ridx fixed bin; call mtape_$order (mtdp, "rew", 0, null, code); /* Rewind to load point */ if code ^= 0 then do; call mtape_$error (mtdp, code, "While rewinding volume ^a prior to reading volume label(s)", mtape_vol_set.volume_id); return; end; nlp = mtape_vol_set.first_vl_ptr; /* arm the label record ptr */ ibm_vol1P = mtape_data.tlb -> mtape_label_record.lab_ptr; /* get pointer to VOL1 structure */ term = "0"b; /* get us through the first pass */ do i = 1 by 1 while (^term); /* read up to HDR1 label */ call mtape_$read_label (mtdp, mtape_data.tlb, code); /* read label record */ if code ^= 0 then do; call mtape_$error (mtdp, code, "Attempting to read IBM volume label record from volume ^a.", mtape_vol_set.volume_id); return; end; if ibm_vol1.label_id = IBM_VOL1 then do; /* if this is VOL1 label */ if ibm_vol1.owner_id.mult_id = MULTICS_IBM_VERSION then /* only true if recorded by mtape_ */ ridx = MTAPE_VOLUME; else ridx = NON_MULT_VOLUME; /* volume recorded by other vendor */ end; else if ibm_vol1.label_id = IBM_L1_ID (BOF_LABEL) then do; /* check if HDR1 label */ term = "1"b; /* this is the place to stop reading labels */ mtape_vol_set.number_of_vol_labels = i - 1; /* set number of vol labels */ ibm_hdr1P = ibm_vol1P; /* check expiration date of first file */ if ridx = NON_MULT_VOLUME then /* check if recorded by tape_ibm_ */ if substr (ibm_hdr1.system, 1, 12) = substr (IBM_SYS_CODE, 1, 12) then ridx = MULT_PRIOR_VOLUME; /* yes, tape recorded by tape_ibm_ */ mtape_vol_set.first_file_unexpired = pfm_utils_$label_unexpired (ibm_hdr1.expiration); /* check the label date and set the flag */ end; if ^term then do; /* link in this label (if not HDR1) */ if nlp = null then do; /* if no label record structure exists.. */ call pfm_utils_$init_label_record (mtdp, mtape_vol_set.last_vl_ptr, mtape_vol_set.first_vl_ptr, lr_ptr, LABEL_LENGTH); mtape_label_record.conversion = MTAPE_CV_UC_EBCDIC; /* IBM labels in EBCDIC */ end; else lr_ptr = nlp; /* it does exist, use it */ based_label_record = mtape_data.tlb -> mtape_label_record.lab_ptr -> based_label_record; nlp = mtape_label_record.next_lab_ptr; /* update pointer for next label */ end; end; call mtape_$order (mtdp, "bsr", 1, null, code); /* backspace in front of HDR1 */ if code ^= 0 then call mtape_$error (mtdp, code, "Attempting to backspace over ^a label record of volume ^a.", ibm_vol1.label_id, mtape_vol_set.volume_id); end CHECK_VOL_LABELS; %page; /* CONVERT_DESC - internal procedure to convert RDW for S/VBS formated records */ CONVERT_DESC: proc; if mtape_data.hdw_mode ^= MTAPE_HWM_BIN then do; /* if not binary mode */ dbl = vbs_record.sdw.length; /* 9 bit mode, must shift rdw length */ substr (dbl, 10) = substr (dbl, 11); crl = binary (bit (substr (dbl, 1, 17), 17), 21); end; else crl = binary (vbs_record.sdw.length, 21); /* binary mode copy length */ move_len = crl - CW_LENGTH; desc_type = vbs_record.sdw.span_indicator; /* get the control character */ if desc_type < SEG_B_E | desc_type > SEG_NB_NE then do; /* invalid descriptor */ code = error_table_$invalid_record_desc; /* set appropriate error code */ call mtape_$error (mtdp, code, "^/^a ^a SDW at record ^d, block ^d, ^[of file section ^d ^;^s^]of file named ""^a"".", "Converting IBM", IBM_FORMAT_CODES (mtape_file_info.file_format), mtape_data.log_record, mtape_data.phy_block, (mtape_file_info.section > 1), mtape_file_info.section, mtape_file_info.file_id); go to read_return; /* return to user with error */ end; end CONVERT_DESC; %page; /* EOV_ON_WRITE - internal procedure to close out volume and initiate volume switch */ EOV_ON_WRITE: proc (who_called); dcl who_called bit (1) aligned; call pfm_utils_$write_file_labels (mtdp, EOV_LABEL, code); /* yes, write out the EOV labels */ if code ^= 0 then return; /* some problem with writing labels, give up */ mtape_vol_set.volume_end = "0"b; /* reset volume end flag */ nvp = mtape_vol_set.next_vs_ptr; /* copy pointer, in case its null */ call mtape_$volume_switch (mtdp, nvp, code); /* do the magic */ if code ^= 0 then do; /* could'nt do the switch */ call mtape_$error (mtdp, code, "Couldn't mount new volume at volume switch time"); return; end; vs_ptr = mtape_data.vs_current; /* point to new volume */ call INIT_VOL_LABELS; /* init volume labels */ if code ^= 0 then return; fi_ptr = null; /* this will ensure we get file_info struct allocated */ call pfm_utils_$setup_file (mtdp, fi_ptr, "1"b); /* set up new file section structure */ call pfm_utils_$write_file_labels (mtdp, BOF_LABEL, code); /* and write out the section header labels */ if code ^= 0 then return; /* if errors.. */ if who_called = WRITING then do; /* if actually writing data */ call mtape_$set_mode (mtdp, "data", mtape_data.hdw_mode, null, code); /* set hardware mode */ if code ^= 0 then return; call mtape_$set_mode (mtdp, "length", mtape_data.length_mode, null, code); /* and special len mode */ if code ^= 0 then return; if mtape_data.cur_buf_idx > lbound (mtape_data.buf_ptrs, 1) then /* if we have suspened bufs */ call mtape_$flush_buffers (mtdp, code); /* flush out any suspended buffers */ end; end EOV_ON_WRITE; %page; /* GET_NXT_RECORD - subroutine to position to next logical record, reading nxt tape block if necessary */ GET_NXT_RECORD: proc; dcl term bit (1) aligned; term = "0"b; do while (^term); /* in case we have to read 1 block of new file section */ call mtape_$read_block (mtdp, code); /* so read it in */ if code ^= 0 then /* if some error */ if code = error_table_$end_of_info then do; /* if EOF, read trailer */ call LOAD_PTRS; /* Load up structure pointers */ call pfm_utils_$read_file_labels (mtdp, fi_ptr, vs_ptr, label_type, fl_code); if fl_code ^= 0 then do; /* some problem reading labels, abort */ code = fl_code; go to read_return; /* Take non-local goto and return */ end; if label_type = EOF_LABEL then /* is this really end of the data file? */ go to read_return; /* Take non-local goto and return */ else if label_type = EOV_LABEL then do; /* No, volume switch has already been done */ call CHECK_NEW_FILE_SECTION; /* go check out new file section labels */ if code ^= 0 then /* some error */ go to read_return; /* Take non-local goto and return */ end; else do; /* if label_type = BOF, this is error */ code = error_table_$bad_file; /* set appropriate error code */ call mtape_$error (mtdp, code, "^/IBM HDR1 file label found where EOF1 or EOV1 file label record expected"); go to read_return; /* Take non-local goto and return */ end; end; else go to read_return; /* some other error, let user see what it is */ else do; /* successfully read the block */ term = "1"b; /* set terminate condition */ if mtape_data.ad_file_format > 2 then do; /* if variable length records */ if mtape_data.hdw_mode ^= MTAPE_HWM_BIN then do; /* if not binary mode */ dbl = bdw.length; /* 9 bit mode, must shift bdw length */ substr (dbl, 10) = substr (dbl, 11); mtape_data.cur_block.length = binary (bit (substr (dbl, 1, 17), 17), 21); end; else mtape_data.cur_block.length = binary (bdw.length, 21); /* binary mode copy length */ mtape_data.remain = mtape_data.length - mtape_data.processed; /* reset, based on recorded len */ end; end; end; end GET_NXT_RECORD; %page; /* INIT_VOL_LABELS - internal procedure to initialize and write the VOL1 and dummy HDR1 label records */ INIT_VOL_LABELS: proc; if mtape_vol_set.first_file_unexpired then /* if not expired */ if ^mtape_open_info.force then do; /* and not ignoring expiration dates */ call mtape_$user_query (mtdp, Q_UNEXPIRED_VOLUME, code); /* ask user */ if code ^= 0 then return; /* user does not want labels destroyed */ end; call mtape_$order (mtdp, "den", 0, addr (mtape_attach_info.density), code); /* Rewind and set density */ if code ^= 0 then do; call mtape_$error (mtdp, code, "^/While rewinding and setting density to ^d BPI on volume ^a prior to volume initialization", mtape_attach_info.density, mtape_vol_set.volume_id); return; end; if ^mtape_attach_info.labeled then do; /* if unlabeled volume */ mtape_vol_set.number_of_vol_labels = 0; /* set up volume parameters */ mtape_vol_set.first_vl_ptr, mtape_vol_set.last_vl_ptr = null; /* in case they were'nt */ mtape_vol_set.volume_density = mtape_attach_info.density; /* reset volume parameters to */ mtape_vol_set.volume_type = Volume_unknown_format; /* reflect that its an unlabeled volume recorded at */ mtape_vol_set.volume_check = MTAPE_VOLUME; /* requested density */ return; /* thats all for an unlabeled volume */ end; nlp = mtape_vol_set.first_vl_ptr; /* arm the label record ptr */ mtape_vol_set.volume_id = mtape_vol_set.volume_name; auth_code = authenticate_ ((mtape_vol_set.volume_id)); if nlp = null then do; /* if no label record structure exists.. */ call pfm_utils_$init_label_record (mtdp, mtape_vol_set.last_vl_ptr, mtape_vol_set.first_vl_ptr, lr_ptr, LABEL_LENGTH); mtape_label_record.conversion = MTAPE_CV_UC_EBCDIC; /* IBM lables are always ebcdic */ end; else lr_ptr = nlp; /* it does exist, use it */ nlp = mtape_label_record.next_lab_ptr; /* update pointer for next label */ ibm_vol1P = mtape_label_record.lab_ptr; ibm_vol1.label_id = IBM_VOL1; /* set label id */ ibm_vol1.volume_serial = substr (mtape_vol_set.volume_id, 1, length (ibm_vol1.volume_serial)); /* set canonacical volume name */ ibm_vol1.owner_id.auth_code = auth_code; /* set authentication code for RCP */ ibm_vol1.owner_id.mult_id = MULTICS_IBM_VERSION; /* indicate recorded by mtape_ */ call mtape_$write_label (mtdp, lr_ptr, code); /* write it out */ if code ^= 0 then do; /* if unrecoverable error */ call mtape_$error (mtdp, code, "Attempting to write IBM VOL1 label record on volume ^a.", mtape_vol_set.volume_id); return; end; mtape_vol_set.number_of_vol_labels = 1; /* set this constant */ if mtape_vol_set.last_vl_ptr ^= lr_ptr then do; /* in case there were more labels before */ mtape_vol_set.last_vl_ptr = lr_ptr; /* truncate the chain */ mtape_label_record.next_lab_ptr = null; end; /* Now write the dummy HDR1 label */ lr_ptr = mtape_data.tlb; based_label_record = IBM_L1_ID (BOF_LABEL) || copy ("0", 76); call mtape_$write_label (mtdp, lr_ptr, code); /* write it out */ if code ^= 0 then do; /* if unrecoverable error */ call mtape_$error (mtdp, code, "^/While initializing volume ^a with dummy IBM HDR1 label record", mtape_vol_set.volume_id); return; end; call mtape_$order (mtdp, "eof", 1, null, code); /* write an EOF mark */ if code ^= 0 then do; call mtape_$error (mtdp, code, "^/While writing an EOF mark following dummy IBM HDR1 label record on volume ^a", mtape_vol_set.volume_id); return; end; mtape_vol_set.volume_density = mtape_attach_info.density; /* reset volume parameters to */ mtape_vol_set.volume_type = Volume_ibm_tape; /* reflect that its an IBM volume recorded at */ mtape_vol_set.volume_check = MTAPE_VOLUME; /* requested density by mtape_ */ /* Position for writing first file */ call mtape_$order (mtdp, "rew", 0, null, code); /* Rewind to load point */ if code ^= 0 then do; call mtape_$error (mtdp, code, "^/While rewinding volume ^a after volume initialization", mtape_vol_set.volume_id); return; end; call mtape_$order (mtdp, "fsr", 1, null, code); /* position to write over dummy HDR1 label */ if code ^= 0 then call mtape_$error (mtdp, code, "^/While positioning for writing first file label on volume ^a", mtape_vol_set.volume_id); end INIT_VOL_LABELS; /* LOAD_PTRS - procedure to load structure pointers for exeception processing of time critical external entries (read and write) */ LOAD_PTRS: proc; vs_ptr = mtape_data.vs_current; /* load up pertinent structure pointers */ fi_ptr = mtape_data.fi_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; end LOAD_PTRS; %page; /* LONG_RECORD_CHECK - procedure to check if a requested write of a logical record will fit */ LONG_RECORD_CHECK: proc (length, rec_blk_ck); dcl length fixed bin (21); dcl rec_blk_ck bit (1) aligned; if rec_blk_ck then do; /* comparing against record length */ if length > mtape_data.record_size then /* is it to big */ code = error_table_$long_record; /* yes, set code */ end; else if length > mtape_data.block_size then /* comparing against blk size, will it fit */ code = error_table_$long_record; /* no, set code */ if code ^= 0 then /* if we have a long record.. */ go to write_return; /* take non-local goto to write return exit */ end LONG_RECORD_CHECK; %page; /* MOVE_TO_BUFFER - subroutine to move user data to tape buffer on write, initiating a write of the buffer if full */ MOVE_TO_BUFFER: proc (cwl, min_len); dcl cwl fixed bin; /* control word length */ dcl min_len fixed bin; /* minimum length of next record */ dcl pad_chars fixed bin; dcl rcd_pad char (pad_chars) based (addr (tape_blk (mtape_data.processed + move_len + 1))); if mtape_data.conversion = MTAPE_CV_EBCDIC then /* if data recorded in ebcdic.. */ call ascii_to_ebcdic_ (buf_ptr -> based_lrec_data, move_ptr -> based_lrec_data); else move_ptr -> based_lrec_data = buf_ptr -> based_lrec_data; /* move data to tape buffer */ if (mtape_data.ad_file_format = 1) | (mtape_data.ad_file_format = 2) then /* If "U" or "F" or "FB" format */ if move_len < mtape_data.record_size then do;/* and record is not fUll */ pad_chars = mtape_data.record_size - move_len; /* pad record out with blanks */ rcd_pad = copy (" ", pad_chars); if mtape_data.conversion = MTAPE_CV_EBCDIC then /* make them ebcdic blanks */ call ascii_to_ebcdic_ (rcd_pad, rcd_pad); /* if appropriate */ move_len = mtape_data.record_size; /* reflect on all data moved */ end; mtape_data.processed = mtape_data.processed + move_len + cwl; /* add up bytes processed */ mtape_data.remain = mtape_data.block_size - mtape_data.processed; /* decrement remaining bytes */ if ^mtape_data.file_blocked then /* if not "FB", "VB", or "VBS" format */ call WRITE_BLOCK; /* write the block out now */ else if mtape_data.remain < min_len then /* if blocked but block full.. */ call WRITE_BLOCK; /* write the block out now */ else mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); /* Not blocked, set for next lrec */ end MOVE_TO_BUFFER; %page; /* MOVE_TO_USER - subroutine to move data from tape buffer to user buffer on read */ MOVE_TO_USER: proc; if buf_ptr = null then /* if caller just wants length.. */ rec_len = rec_len + move_len; /* thats it */ else do; /* this is a real read */ if ^long_record then do; /* if we can still fit the data in */ if buf_len - move_len < 0 then do; long_record = "1"b; /* we have more data than user can take */ move_len = buf_len; /* move what we can */ end; buf_len = buf_len - move_len; /* and decrement length remaining in users buffer */ if move_len > 0 then do; /* if we have some data to move, move it */ if mtape_data.conversion = MTAPE_CV_EBCDIC then /* tape recorded in ebcdic */ call ebcdic_to_ascii_ (move_ptr -> based_lrec_data, buf_ptr -> based_lrec_data); else buf_ptr -> based_lrec_data = move_ptr -> based_lrec_data; /* move computed of bytes */ rec_len = rec_len + move_len; /* tell user how long record is anyway */ buf_ptr = addr (based_lrec_index (rec_len + 1)); /* increment users buffer ptr */ end; end; end; mtape_data.processed = mtape_data.processed + crl; mtape_data.remain = mtape_data.cur_block.length - mtape_data.processed; if mtape_data.remain > 0 then mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); end MOVE_TO_USER; %page; /* NEED_TO_INIT_VOLUME - function to determine if a tape volume requires initializaton */ NEED_TO_INIT_VOLUME: proc returns (bit (1) aligned); if mtape_vol_set.volume_check > NON_MULT_VOLUME then /* if this is not an IBM volume */ return ("1"b); if mtape_open_info.modify | mtape_open_info.extend then /* if modifying or extending */ return ("0"b); /* existing file, do not init volume */ if ^mtape_data.first_file then do; /* if the first opening */ if mtape_open_info.seq_number = 1 then /* or we want file number 1 */ return ("1"b); if mtape_open_info.next_file then /* or next (first) file */ return ("1"b); end; return ("0"b); end NEED_TO_INIT_VOLUME; %page; /* SET_FILE_FORMAT - internal procedure to set file format in file info from open data */ SET_FILE_FORMAT: proc; temp_fmt = translate (mtape_open_info.file_format, UC, LC); /* file format in upper case */ mtape_file_info.file_code = temp_fmt; /* set file code */ do i = 0 to hbound (IBM_FORMAT_CODES, 1); /* set the file format */ if temp_fmt = IBM_FORMAT_CODES (i) then /* found it */ mtape_file_info.file_format = i; end; if substr (mtape_file_info.file_code, 1, 1) = "V" then /* if variable block size format */ mtape_file_info.buffer_offset = size (bdw) * 4; /* account for block data word offset */ end SET_FILE_FORMAT; /* SET_OPEN_IDX - subroutine to determine what kind of opening this is */ SET_OPEN_IDX: proc; if mtape_open_info.open_mode = Sequential_input then do; /* input operation? */ output = "0"b; /* yes, reset output flag */ open_idx = 0; /* and set input open idx value */ end; else do; /* some type of output operation */ output = "1"b; /* true if sqo or sqio */ if mtape_open_info.modify then /* if modifying an existing file */ open_idx = 3; else if mtape_open_info.extend then /* if extending current file */ open_idx = 2; else open_idx = 1; /* otherwise create new file */ end; end SET_OPEN_IDX; /* SET_RECORD_SIZE - internal procedure to set record size either from defaults or as specified by the user */ SET_RECORD_SIZE: proc; if mtape_open_info.record_length = MTAPE_UNSPECIFIED then do; /* if no "-record" value specified by user */ if index (mtape_file_info.file_code, "S") ^= 0 then /* if Spanned format */ mtape_file_info.record_size = mtape_open_info.default_span_rlen; /* set default */ else if index (mtape_file_info.file_code, "V") ^= 0 then /* if variable format */ mtape_file_info.record_size = mtape_open_info.default_var_rlen; /* set default */ else mtape_file_info.record_size = mtape_open_info.default_fix_rlen; /* assume fixed or U format */ end; else mtape_file_info.record_size = mtape_open_info.record_length; /* if user specified it */ end SET_RECORD_SIZE; %page; /* SET_RECORDING_MODE - internal procedure to set the recording mode in the file_info structure */ SET_RECORDING_MODE: proc; mtape_file_info.conversion = MTAPE_NO_CONVERSION; /* set no conversion as default */ temp_mode = translate (mtape_open_info.recording_mode, UC, LC); /* mode to UC */ if temp_mode = "ASCII" then /* record in standard ascii mode */ mtape_file_info.hdw_mode = MTAPE_HWM_NINE; else if temp_mode = "EBCDIC" then do; /* record in ebcdic mode */ mtape_file_info.hdw_mode = MTAPE_HWM_NINE; mtape_file_info.conversion = MTAPE_CV_EBCDIC;/* set conversion for ASCII <==> EBCDIC */ end; else mtape_file_info.hdw_mode = MTAPE_HWM_BIN; /* Must be binary mode */ end SET_RECORDING_MODE; /* SETUP - internal procedure to set up enviornment for the external entries */ SETUP: proc; mtdp = arg_mtdp; /* get pointers to pertinient data */ vs_ptr = mtape_data.vs_current; fi_ptr = mtape_data.fi_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; arg_code, code = 0; /* and reset error codes */ end SETUP; %page; /* SETUP_NEW_FILE - procedure to create a file info structure and initialize it with open options */ SETUP_NEW_FILE: proc; if fi_ptr ^= null then /* if replacing existing file */ if ^mtape_open_info.force then /* and not ignoring expiration dates */ if pfm_utils_$label_unexpired ((mtape_file_info.expiration_date)) then do; /* if expiration date is in future */ call mtape_$user_query (mtdp, Q_UNEXPIRED_FILE, code); /* ask user what to do */ if code ^= 0 then return; /* abort file opening on "no" answer */ if mtape_file_info.position_within_file ^= AT_BOFH then do; call pfm_utils_$position_in_file (mtdp, fi_ptr, vs_ptr, AT_BOFH, code); if code ^= 0 then return; end; end; call pfm_utils_$setup_file (mtdp, fi_ptr, "0"b); /* do the common stuff first */ call SET_FILE_FORMAT; /* set the file format in file info structure */ call SET_RECORDING_MODE; /* set the recording mode */ if mtape_file_info.record_size = MTAPE_UNSPECIFIED then /* no record length */ call SET_RECORD_SIZE; /* either use given or default */ mtape_file_info.gen_version = 0; mtape_file_info.creation_date = pfm_utils_$julian_date (""); /* set todays date */ if mtape_open_info.expiration ^= "" then /* if expiration specified.. */ mtape_file_info.expiration_date = pfm_utils_$julian_date ((mtape_open_info.expiration)); else mtape_file_info.expiration_date = " 00000"; /* no expiration specified */ mtape_file_info.pfm_opt_sw (1) = mtape_open_info.pfm_opt_sw (1); /* copy DOS flag */ mtape_file_info.pfm_opt_sw (2) = mtape_open_info.pfm_opt_sw (2); /* and system_use flag */ SET_FILE_ATTRIBUTES: entry; /* to set file attributes if not already set */ if mtape_file_info.file_format = MTAPE_UNSPECIFIED then /* if file format not specified */ call SET_FILE_FORMAT; mtape_file_info.length_mode = NON_MOD_FOUR; /* set special length mode as default */ if mtape_file_info.hdw_mode = MTAPE_UNSPECIFIED then /* recording mode not set */ call SET_RECORDING_MODE; /* set it */ if mtape_file_info.block_size = MTAPE_UNSPECIFIED then /* no block size */ mtape_file_info.block_size = mtape_open_info.block_length; /* use given */ if mtape_file_info.record_size = MTAPE_UNSPECIFIED then /* no record length */ call SET_RECORD_SIZE; /* either use given or default */ if mtape_data.conversion = MTAPE_CV_EBCDIC then /* if converting to ebcdic */ mtape_data.padding_char = IBM_EBCDIC_PAD_CHAR; /* set EBCDIC pad char */ else mtape_data.padding_char = IBM_ASCII_PAD_CHAR;/* otherwise set ASCII pad char */ end SETUP_NEW_FILE; %page; /* WRITE_BLOCK - procedure to write out the current block when full */ WRITE_BLOCK: proc; if mtape_data.ad_file_format > 2 then do; /* if variable length records */ dbl = bit (binary (mtape_data.processed, 18), 18); if mtape_data.hdw_mode ^= MTAPE_HWM_BIN then /* if not binary mode */ substr (dbl, 2, 9) = substr (dbl, 3, 8) || "0"b; /* 9 bit mode, must shift bdw length */ bdw.length = dbl; bdw.reserved = 0; /* set MBZ field */ end; call mtape_$write_block (mtdp, code); if code ^= 0 then /* some error */ if code = error_table_$eov_on_write then do; /* Is it end of tape? */ call LOAD_PTRS; /* Load up structure pointers */ call EOV_ON_WRITE (WRITING); /* Go close out volume and initiate volume switch */ if code ^= 0 then go to write_return; /* If problem, take non-local goto and return */ end; else go to write_return; /* other error return to caller */ end WRITE_BLOCK; %page; %include mtape_includes; %page; %include rcp_volume_formats; %page; %include ibm_vol1; %page; %include ibm_hdr1; %page; %include ibm_hdr2; %page; %include iox_modes; end ibm_tape_io_;  multics_tape_io_.pl1 12/17/86 0926.1r w 12/17/86 0832.4 44046 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ multics_tape_io_: procedure; /* format: style4 */ /* * This program runs under control of the mtape_ I/O module and is meant * to process data and file formats that are specific to Multics * formated tapes, and is known as a Per-Format module. * * This Per-Format module is not fully implemented, and is only included * so that if a Multics tape volume is mounted and recognized by * mtape_/RCP, a linkage error will not result. When this module is * called at its pfm_init entry, an error message is displayed * explaining that the Multics Per-format module has not been * implemented, and an error code is returned. * * Modification History: * * Dummy version created by J. A. Bush 07/10/83 */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to the mtape data structure */ dcl arg_code fixed bin (35); /* Return error code */ dcl arg_info_ptr ptr; /* Pointer to Order data from iox_$control call */ dcl arg_io_call_infop ptr; /* Pointer to io_call control info structure */ dcl arg_order_name char (*); /* Name of Control order to be processed */ dcl arg_lr_ptr ptr; /* Pointer to current label record structure */ dcl arg_labno fixed bin; /* label record within label group */ dcl arg_type fixed bin; /* 1 => BOF; 2 => EOV; 3 => EOF */ dcl arg_convert fixed bin; /* Label record conversion indicator */ /* AUTOMATIC DATA */ dcl code fixed bin (35); dcl buf_ptr ptr; /* Auto copy of users buffer pointer */ dcl buf_len fixed bin (21); /* Auto copy of users lrec buffer */ dcl rec_len fixed bin (21); /* Auto copy of logical record length */ /* CONSTANT DATA */ /* EXTERNAL STATIC DATA */ dcl error_table_$unimplemented_version fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ /* EXTERNAL ENTRIES */ /* BASED VARIABLES */ %page; /* pfm_init - entry to initialize the Per-Format module, setting up file and volume processing parameters and determining correctness of current volume */ pfm_init: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ code = error_table_$unimplemented_version; /* This is for the dummy PFM */ call mtape_$error (mtdp, code, "^/The mtape_ Multics Per-Format module has not been fully implemented."); arg_code = code; return; %page; /* file_open - entry to do format specific processing in opening the file or file set (i.e. read and write file labels) */ file_open: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* file_close - entry to do format specific processing in closing the file or file set (i.e. read and write file trailer labels) */ file_close: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* read - entry to read format specific logical records from the current file */ read: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; /* If = null, return length of next record */ buf_len = mtape_data.arg_buf_len; return; %page; /* write - entry to write format specific logical records into the current file */ write: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* Copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; buf_len = mtape_data.arg_buf_len; return; %page; /* order - entry to process format specific control orders not recognized by mtape_ */ order: entry (arg_mtdp, arg_order_name, arg_info_ptr, arg_io_call_infop, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* decode_file_labels - entry to extract info contained in file labels, and fill in file_info structure */ decode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* encode_file_labels - entry to fill in file labels from info obtained from file_info structure */ encode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_convert, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* SETUP - internal procedure to set up enviornment for the external entries */ SETUP: proc; mtdp = arg_mtdp; /* get pointers to pertinient data */ vs_ptr = mtape_data.vs_current; fi_ptr = mtape_data.fi_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; arg_code, code = 0; /* and reset error codes */ end SETUP; %page; %include mtape_includes; %page; %include rcp_volume_formats; end multics_tape_io_;  pfm_utils_.pl1 01/27/00 1827.0r w 01/27/00 1827.0 507816 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(82-11-29,Bush), approve(), audit(), install(): Created. 2) change(83-11-06,Bush), approve(), audit(), install(): Modified to fix bug causing repeatative opening of same file to not position to correct file. 3) change(85-06-07,GWMay), approve(85-06-07,MECR0125), audit(85-06-07,GDixon), install(): Changed arrays IFH_BKS_CNT and NLB_BKS_CNT to position to proper place on the tape in routine FILE_POSITION(1). 4) change(85-10-24,GWMay), approve(85-10-24,MCR7256), audit(85-12-16,GDixon), install(85-12-17,MR12.0-1001): Formally install changes in MECR0125. 5) change(87-08-17,GWMay), approve(87-09-09,MECR0006), audit(87-09-04,Farley), install(87-09-09,MR12.1-1101): Initialized pointers were needed and moved checks for pointers from a location where the pointer may not be set to a correct location. 6) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley), install(87-11-30,MR12.2-1006): Formally install MECR0006. 7) change(88-02-03,GWMay), approve(88-02-03,MCR7837), audit(88-04-12,Farley), install(88-04-19,MR12.2-1039): Fixed bug to allow unlabeled tapes to be read. 8) change(00-01-26,Schroth), approve(00-01-26,MECR-Y2K): Change julian_date to use "0" prefix for dates after 1999-12-31. Added label_unexpired entry to check if a date recorded in a label has expired. END HISTORY COMMENTS */ /* This procedure embodies a group of utility subroutines for the */ /* mtape_ per-format modules. */ pfm_utils_: procedure; /* format: style4 */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to the mtape_ data structure */ dcl link_head ptr; /* Pointer to the head of a linked list of structures */ dcl link_tail ptr; /* Pointer to the tail of a linked list of structures */ dcl arg_length fixed bin (21); /* length of label record in bytes */ dcl arg_lr_ptr ptr; /* Pointer to allocated label record structure */ dcl arg_code fixed bin (35); /* return error code */ dcl arg_ltype fixed bin; /* 1 => BOF; 2 => EOV; 3 => EOF */ dcl arg_fi_ptr ptr; /* Callers file info structure ptr */ dcl arg_vs_ptr ptr; /* Callers volume info structure */ dcl desired_position fixed bin; /* To position within file */ dcl new_section bit (1) aligned; /* "0"b => new file; "1"b => new file section */ /* AUTOMATIC DATA */ dcl (code, rfl_code, wfl_code) fixed bin (35); dcl (ver_ptr, nvp, nfip, nlp, pp) ptr; dcl (ltype, lab_num, bks_file_cnt, fwd_file_cnt, neofs, space_files, htype, target_position, convert, prev_seq) fixed bin; dcl (term, term1, term2, found, forward) bit (1) aligned; dcl pic4 picture "9999"; /* CONSTANT DATA */ dcl IFH_BKS_CNT (0:5) fixed bin int static options (constant) init (0, 0, 1, 2, 2, 2); /* files to bks to position to file hdr */ dcl NLB_BKS_CNT (0:5) fixed bin int static options (constant) init (0, 0, 0, 0, 1, 1); /* files to bks to position to BOF for unlabeled file */ dcl LC char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl UC char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); /* EXTERNAL STATIC DATA */ dcl error_table_$lost_device_position 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_$invalid_label_format fixed bin (35) ext static; dcl error_table_$invalid_file_set_format fixed bin (35) ext static; dcl error_table_$file_aborted fixed bin (35) ext static; dcl error_table_$uninitialized_volume fixed bin (35) ext static; dcl error_table_$no_file fixed bin (35) ext static; dcl error_table_$no_next_volume fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ dcl (clock, mod, null, substr, translate) builtin; /* EXTERNAL ENTRIES */ dcl mtape_$alloc entry (ptr, fixed bin, ptr, fixed bin (21), ptr); dcl mtape_$error entry options (variable); dcl mtape_$volume_switch entry (ptr, ptr, fixed bin (35)); dcl mtape_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35)); dcl mtape_$read_label entry (ptr, ptr, fixed bin (35)); dcl mtape_$user_query entry (ptr, fixed bin, fixed bin (35)); dcl mtape_$write_label entry (ptr, ptr, fixed bin (35)); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl datebin_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin); dcl datebin_$dayr_clk entry (fixed bin (71), fixed bin); /* BASED DATA */ dcl based_label_record char (mtape_label_record.lab_length) based (mtape_label_record.lab_ptr); dcl based_area area based (mtape_data.areap); %page; /* init_label_record - entry to allocate label record structure and storage for label record and link them in */ init_label_record: entry (arg_mtdp, link_tail, link_head, arg_lr_ptr, arg_length); mtdp = arg_mtdp; /* copy mtape_ data pointer */ call mtape_$alloc (mtdp, MTAPE_ALLOC_LR, link_tail, 0, lr_ptr); link_tail = lr_ptr; /* Link this label record in */ if link_head = null then /* if this is first time through */ link_head = lr_ptr; /* set link head also */ mtape_label_record.lab_length = arg_length; /* initialize the LR structure */ mtape_label_record.mode = MTAPE_HWM_NINE; /* ANSI labels are always nine track mode */ mtape_label_record.conversion = MTAPE_CV_UC_ASCII;/* convert to upper case for writting */ call mtape_$alloc (mtdp, MTAPE_ALLOC_STR, null, arg_length, mtape_label_record.lab_ptr); based_label_record = ""; /* initialize to all blanks */ arg_lr_ptr = lr_ptr; /* copy return argument */ return; /* and return to caller */ /* julian_date - entry to format date in form " yyddd" */ julian_date: entry (date_time) returns (char (6) unaligned); dcl date_time char (*); dcl clock_value fixed bin (71); dcl ddd picture "999"; /* day of year */ dcl yy picture "99"; /* year */ dcl temp fixed bin; /* temporary */ /* This entry formats a date string into julian date suitable for use in a tape label. The format of the label date is "cyyddd", where: c is a century indicator - " " --> 1900's - "0" --> 2000's. (We don't care about other centuries!) A label of "x99365" is a special flag date meaning forever. */ clock_value = clock (); /* Use todays date as default */ if date_time ^= "" then /* if date time given. */ call convert_date_to_binary_ (date_time, clock_value, code); /* Use that instead of today */ call datebin_$dayr_clk (clock_value, temp); /* get day of year */ ddd = temp; /* convert to characters */ call datebin_ (clock_value, 0, 0, 0, temp, 0, 0, 0, 0, 0); /* get year */ yy = mod (temp, 100); /* drop century and convert to characters */ if temp < 2000 then return (" " || yy || ddd); /* return formatted date */ else return ("0" || yy || ddd); /* return formatted date in 21st century */ /* label_unexpired - entry to check if expiry date still holds */ label_unexpired: entry (label_date) returns (bit (1) aligned); dcl label_date char (*); dcl today char (6); dcl EXPIRED bit (1) internal static options (constant) init ("0"b); dcl UNEXPIRED bit (1) internal static options (constant) init ("1"b); if label_date = " 00000" then /* " 00000" means no expiry set, i.e. expired */ return (EXPIRED); else if substr (label_date, 2, 5) = "99365" then /* "99365" is a keep forever date */ return (UNEXPIRED); else do; today = julian_date (""); if label_date > today then /* not expired yet */ return (UNEXPIRED); else return (EXPIRED); end; %page; /* position_in_file - entry to position tape to indicated position within file */ position_in_file: entry (arg_mtdp, arg_fi_ptr, arg_vs_ptr, desired_position, arg_code); mtdp = arg_mtdp; /* copy arg */ vs_ptr = arg_vs_ptr; fi_ptr = arg_fi_ptr; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; code = 0; if mtape_file_info.position_within_file = NOT_POSITIONED_IN_FILE then do; code = error_table_$lost_device_position; /* set appropriate error code */ call mtape_$error (mtdp, code, "^/^a ^a is not positioned within the file boundaries for file ^a", "Attempting to position within file and history indicates that tape volume", mtape_vol_set.volume_id, mtape_file_info.file_id); go to PIF_RETURN; end; fwd_file_cnt = 0; go to FILE_POSITION (desired_position); /* take apropriate action */ FILE_POSITION (1): /* position to beginning of data file */ if mtape_file_info.first_file_section_ptr ^= fi_ptr then do; /* we have to do volume switch */ fi_ptr = mtape_file_info.first_file_section_ptr; /* go to first file section */ vs_ptr = mtape_file_info.begin_vs_ptr; /* get ptr to VS structure of new volume */ call mtape_$volume_switch (mtdp, vs_ptr, code); /* do the switch */ if code ^= 0 then do; /* if some problem */ call mtape_$error (mtdp, code, /* report it */ "^/Attempting to mount volume ""^a"" on which the beginning of file ""^a"" is located.", mtape_vol_set.volume_id, mtape_file_info.file_id); return; /* and get out */ end; fwd_file_cnt = (mtape_file_info.phy_file - mtape_data.phy_file) + 1; /* files to forward space */ end; FILE_POSITION (3): /* position to beginning of file section */ if mtape_file_info.first_file_on_volume then do; /* if this is true, can rewind */ call REWIND_TO_BOF; /* go rewind the volume and space over vol labels */ if code ^= 0 then go to PIF_RETURN; fwd_file_cnt = 0; /* zero it out so we don't go forward */ end; else if fwd_file_cnt = 0 then do; /* not 1st file on vol, must bks */ fwd_file_cnt = 1; /* must also forward space 1 file */ if mtape_attach_info.labeled then /* if labeled tape */ bks_file_cnt = IFH_BKS_CNT (mtape_file_info.position_within_file); else bks_file_cnt = NLB_BKS_CNT (mtape_file_info.position_within_file); call mtape_$order (mtdp, "bsf", bks_file_cnt, null, code); /* backup desired files */ if code ^= 0 then do; call mtape_$error (mtdp, code, "^/^a ^[headers^;^;^;section^] for file ^a on volume ^a", "Attempting to backspace to the beginning of file", desired_position + 1, mtape_file_info.file_id, mtape_vol_set.volume_id); go to PIF_RETURN; end; end; if fwd_file_cnt > 0 then do; call mtape_$order (mtdp, "fsf", fwd_file_cnt, null, code); /* forward required files */ if code ^= 0 then do; call mtape_$error (mtdp, code, "^/^a ^[headers^;^;^;section^] for file ^a on volume ^a", "Attempting to forward space to the beginning of file", desired_position + 1, mtape_file_info.file_id, mtape_vol_set.volume_id); go to PIF_RETURN; end; end; if mtape_attach_info.labeled then /* if labeled volume */ mtape_file_info.position_within_file = AT_BOFH; /* set position indicator */ else mtape_file_info.position_within_file = AT_BOFD; /* set position indicator */ go to PIF_RETURN; FILE_POSITION (2): /* position to end of file */ if mtape_file_info.position_within_file = AT_EOF then /* if we are already there, forget it */ go to PIF_RETURN; htype = EOV_LABEL; /* preset to loop for EOV/BOF seq */ do while (htype ^= EOF_LABEL); /* loop until we reach EOF */ call mtape_$order (mtdp, "fsf", 1, null, code); /* go to end of current phy file */ if code ^= 0 then do; /* we loose */ call mtape_$error (mtdp, code, "^/While forward spacing to end of file ""^a"".", mtape_file_info.file_id); go to PIF_RETURN; end; htype = EOV_LABEL; /* preset to loop for EOV/BOF seq */ do while (htype = EOV_LABEL); /* loop on EOV */ call read_file_labels (mtdp, fi_ptr, vs_ptr, htype, code); if code ^= 0 then go to PIF_RETURN; if htype = EOV_LABEL then /* if new file section to be read */ fi_ptr = mtape_file_info.next_fi_ptr; /* set up for new section */ end; end; go to PIF_RETURN; FILE_POSITION (4): /* Position to end of file section */ if mtape_file_info.position_within_file = AT_EOF then /* if we have just written file, we are at EOF */ go to PIF_RETURN; fwd_file_cnt = (mtape_file_info.phy_file + FILES_PER_FILE_GRP) - mtape_data.phy_file; call mtape_$order (mtdp, "fsf", fwd_file_cnt, null, code); /* fwd space required files */ if code ^= 0 then do; /* if some problem */ call mtape_$error (mtdp, code, /* report it */ "^/While forward spacing to end of file section ""^a"".", mtape_file_info.file_id); go to PIF_RETURN; end; if mtape_file_info.next_fi_ptr ^= null then /* if another file info exists */ if mtape_file_info.next_fi_ptr -> mtape_file_info.first_file_section_ptr ^= mtape_file_info.first_file_section_ptr then /* not part of this file */ mtape_file_info.position_within_file = AT_EOF; /* reflect current position */ else mtape_file_info.position_within_file = AT_IFD; PIF_RETURN: arg_code = code; arg_vs_ptr = vs_ptr; arg_fi_ptr = fi_ptr; return; %page; /* truncate_file_set - entry to free file_info structures from structure tail backwards to current file_info structure */ truncate_file_set: entry (arg_mtdp); mtdp = arg_mtdp; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; term, term1, term2 = "0"b; /* reset terminate conditions */ do fi_ptr = mtape_data.fi_tail repeat mtape_file_info.prev_fi_ptr while (^term); if mtape_file_info.next_fi_ptr ^= null then do; /* if not last file info */ free mtape_file_info.next_fi_ptr -> mtape_file_info in (based_area); /* free it */ mtape_file_info.next_fi_ptr = null; end; if mtape_open_info.extend then do; /* if extending file, special case */ do lr_ptr = mtape_file_info.last_file_trail_ptr repeat mtape_label_record.prev_lab_ptr while (lr_ptr ^= null & ^term2); if term1 & /* already read 1st eof label */ substr (based_label_record, 1, 3) ^= mtape_pfm_info.eof_prefix then term2 = "1"b; /* if now past first eof label */ else do; /* get rid of these labels */ if substr (based_label_record, 1, 3) = mtape_pfm_info.eof_prefix then /* first eof label? */ term1 = "1"b; if mtape_label_record.next_lab_ptr ^= null then /* if not last label record */ free mtape_label_record.next_lab_ptr -> mtape_label_record in (based_area); free based_label_record in (based_area); /* free label contents */ end; end; if lr_ptr = null then /* if eof label was first trailer label.. */ mtape_file_info.first_file_trail_ptr, mtape_file_info.last_file_trail_ptr = null; else mtape_file_info.last_file_trail_ptr = lr_ptr; /* this is now the tail */ end; else do; /* not extending file, get rid of all trailer labels */ do lr_ptr = mtape_file_info.last_file_trail_ptr repeat mtape_label_record.prev_lab_ptr while (lr_ptr ^= null); if mtape_label_record.next_lab_ptr ^= null then /* if not last label record */ free mtape_label_record.next_lab_ptr -> mtape_label_record in (based_area); free based_label_record in (based_area); /* free label contents */ end; if mtape_file_info.first_file_trail_ptr ^= null then /* if not unlabeled volume set */ free mtape_file_info.first_file_trail_ptr -> mtape_label_record in (based_area); mtape_file_info.first_file_trail_ptr, mtape_file_info.last_file_trail_ptr = null; end; if fi_ptr = mtape_data.fi_current then /* are we done? */ term = "1"b; /* yes, set terminate condition */ else do; /* no, free somemore */ do lr_ptr = mtape_file_info.last_file_lab_ptr repeat mtape_label_record.prev_lab_ptr while (lr_ptr ^= null); if mtape_label_record.next_lab_ptr ^= null then /* if not last label record */ free mtape_label_record.next_lab_ptr -> mtape_label_record in (based_area); free based_label_record in (based_area); /* free label contents */ end; if mtape_file_info.first_file_lab_ptr ^= null then free mtape_file_info.first_file_lab_ptr -> mtape_label_record in (based_area); end; end; mtape_data.fi_current -> mtape_file_info.end_of_file_set = "1"b; /* this is end of file set now */ mtape_data.fi_tail = mtape_data.fi_current; /* truncate this chain also */ return; %page; /* read_file_labels - external entry to read and decode beginning and end of file labels */ read_file_labels: entry (arg_mtdp, arg_fi_ptr, arg_vs_ptr, arg_ltype, arg_code); mtdp = arg_mtdp; /* copy args */ fi_ptr = arg_fi_ptr; vs_ptr = arg_vs_ptr; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; ltype, rfl_code = 0; /* start out with good rfl_code */ ver_ptr = null; if mtape_attach_info.labeled then /* if a labeled volume set */ do lab_num = 1 by 1 while (rfl_code ^= error_table_$end_of_info); lr_ptr = mtape_data.tlb; /* set label record pointer */ call mtape_$read_label (mtdp, lr_ptr, rfl_code); /* read the label */ if rfl_code ^= 0 then do; /* some error lets check for EOF */ if rfl_code = error_table_$end_of_info then /* end of file set? */ if lab_num = 1 then do; /* yes, if first read (2 consecutive EOFs) */ fi_ptr = mtape_data.fi_tail; /* set for last file */ mtape_file_info.end_of_file_set = "1"b; /* Set marker */ call mtape_$order (mtdp, "bsf", 1, null, rfl_code); /* backspace 1 file mark */ if rfl_code ^= 0 then call mtape_$error (mtdp, rfl_code, "^/Positioning to tape mark prior to end of file set."); rfl_code = error_table_$end_of_info; /* reset EOF code */ go to RFL_RETURN; /* return with EOF code */ end; else ; else do; call mtape_$error (mtdp, rfl_code, "^/Attempting to read file labels on volume ^a", mtape_vol_set.volume_id); go to RFL_RETURN; end; end; else do; /* No error, check labels */ if lab_num = 1 then /* first file label of group */ if substr (based_label_record, 1, 3) = mtape_pfm_info.bof_prefix then do; /* if bof label */ ltype = BOF_LABEL; /* set label type */ if fi_ptr = null then /* does file exist? */ call CREATE_FILE_LINK; if mtape_file_info.prev_fi_ptr ^= null then mtape_file_info.prev_fi_ptr -> mtape_file_info.position_within_file = NOT_POSITIONED_IN_FILE; mtape_data.fi_current = fi_ptr; /* this is now current file */ ver_ptr = mtape_file_info.first_file_lab_ptr; /* set verify ptr */ end; else do; /* must be EOV or EOF label group */ if substr (based_label_record, 1, 3) = mtape_pfm_info.eov_prefix then do; ltype = EOV_LABEL; /* is it an EOV label group */ ver_ptr = mtape_file_info.first_file_trail_ptr; /* set verify ptr to look at trailers */ end; else if substr (based_label_record, 1, 3) = mtape_pfm_info.eof_prefix then do; ltype = EOF_LABEL; /* or an EOF label group */ ver_ptr = mtape_file_info.first_file_trail_ptr; /* set verify ptr to look at trailers */ end; else do; /* bad label */ rfl_code = error_table_$invalid_label_format; /* set appropriate error code */ call mtape_$error (mtdp, rfl_code, "^/Unrecognizable file label, reading file labels on volume ^a. Label contents:^/""^a""", mtape_vol_set.volume_id, based_label_record); go to RFL_RETURN; end; end; if ver_ptr = null then do; /* if label not stored, let PFM decode it */ call mtape_data.decode_file_labels (mtdp, lr_ptr, lab_num, ltype, rfl_code); if rfl_code ^= 0 then /* if conversion error */ go to RFL_RETURN; if ltype > BOF_LABEL then /* if EOF/EOV sequence */ call init_label_record (mtdp, mtape_file_info.last_file_trail_ptr, mtape_file_info.first_file_trail_ptr, lr_ptr, mtape_data.lab_buf_len); else do; /* bof label group */ call init_label_record (mtdp, mtape_file_info.last_file_lab_ptr, mtape_file_info.first_file_lab_ptr, lr_ptr, mtape_data.lab_buf_len); if lab_num = 1 then do; /* complete position info */ mtape_file_info.phy_file = mtape_data.position.phy_file; /* copy file number */ if mtape_file_info.section > 1 & mtape_file_info.prev_fi_ptr = null then mtape_file_info.section = 1; /* must be old section we are overwriting */ if mtape_file_info.section > 1 then do; /* not 1st file section, must be new vol */ mtape_file_info.first_file_on_volume = "1"b; /* set for later positioning */ mtape_file_info.first_file_section_ptr = mtape_file_info.prev_fi_ptr -> mtape_file_info.first_file_section_ptr; mtape_file_info.begin_vs_ptr = mtape_file_info.prev_fi_ptr -> mtape_file_info.begin_vs_ptr; end; else do; mtape_file_info.begin_vs_ptr = vs_ptr; /* beginning of new file */ mtape_file_info.first_file_section_ptr = fi_ptr; end; call LINK_VS_END; /* link in the end vol set ptr */ end; end; based_label_record = mtape_data.tlb -> mtape_label_record.lab_ptr -> based_label_record; ver_ptr = lr_ptr; /* set for compatibility */ end; else do; /* label already exists, compare it */ if based_label_record ^= ver_ptr -> mtape_label_record.lab_ptr -> based_label_record then do; rfl_code = error_table_$invalid_label_format; call mtape_$error (mtdp, rfl_code, "^/^a ^a ^a, physical file ^d, ^a^/""^a""^/New value:^/""^a""", mtape_pfm_info.module_id, "label record read from volume", mtape_vol_set.volume_id, mtape_data.phy_file, "does not agree with safe stored contents of same. Safe stored value:", ver_ptr -> mtape_label_record.lab_ptr -> based_label_record, based_label_record); go to RFL_RETURN; end; end; ver_ptr = ver_ptr -> mtape_label_record.next_lab_ptr; /* update for next compare */ end; end; else do; /* an unlabeled volume set */ call DECODE_UNLABELED_FILE; /* determine what and where of file */ if rfl_code ^= 0 then /* if some error */ go to RFL_RETURN; /* bail out */ end; if ltype = EOV_LABEL then do; /* if a volume switch is necessary, do it now */ mtape_file_info.position_within_file = NOT_POSITIONED_IN_FILE; nvp = mtape_vol_set.next_vs_ptr; /* copy pointer, in case its null */ call mtape_$volume_switch (mtdp, nvp, rfl_code); /* do the magic */ if rfl_code ^= 0 then do; /* could'nt do the switch */ call mtape_$error (mtdp, rfl_code, "^/Could not mount new volume at volume switch time"); go to RFL_RETURN; end; vs_ptr = mtape_data.vs_current; /* point to new volume */ end; else if ltype = EOF_LABEL then /* if reading EOF label group */ mtape_file_info.position_within_file = AT_EOF; else mtape_file_info.position_within_file = AT_BOFD; /* Header label group */ rfl_code = 0; /* reset code to not reflect EOF */ RFL_RETURN: arg_code = rfl_code; arg_ltype = ltype; /* return label group type */ arg_fi_ptr = fi_ptr; /* and file info ptr to caller */ arg_vs_ptr = mtape_data.vs_current; /* return possibly updated vs_ptr */ arg_mtdp = mtdp; /* in case of volume switch */ return; %page; /* write_file_labels - external entry to encode and write beginning and end of file labels */ write_file_labels: entry (arg_mtdp, arg_ltype, arg_code); mtdp = arg_mtdp; ltype = arg_ltype; vs_ptr = mtape_data.vs_current; fi_ptr = mtape_data.fi_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; arg_code, wfl_code = 0; if ltype > BOF_LABEL then do; /* if writing EOV/EOF, write file mark first */ mtape_file_info.block_count = mtape_data.phy_block; /* unload block count */ if mtape_attach_info.labeled then do; /* only if labeled tape */ call mtape_$order (mtdp, "eof", 1, null, wfl_code); if wfl_code ^= 0 then do; /* can't even write eof */ call mtape_$error (mtdp, wfl_code, "^/While writing an End of File mark."); call ABORT_FILE (wfl_code); /* ask user what to do */ go to WFL_RETURN; /* quit now */ end; end; mtape_file_info.position_within_file = AT_BOFT; /* reflect current file position */ neofs = 2; /* write 2 file marks after labels */ nlp = mtape_file_info.first_file_trail_ptr; /* init label structure ptr */ end; else do; /* Header label */ if ^mtape_attach_info.labeled then /* if unlabeled, don't write file mark */ neofs = 0; else neofs = 1; /* write only 1 eof after labels */ if mtape_file_info.position_within_file ^= AT_BOFH then do; /* not positioned to header */ call position_in_file (mtdp, fi_ptr, vs_ptr, AT_BOFH, wfl_code); /* do the positioning */ if wfl_code ^= 0 then /* return if error */ go to WFL_RETURN; end; nlp = mtape_file_info.first_file_lab_ptr; /* init label structure ptr */ end; call WRITE_LABEL_RECORDS (ltype, wfl_code); /* do the actual writing of labels */ if wfl_code ^= 0 then do; /* this is serious */ call ABORT_FILE (wfl_code); /* ask user what to do */ go to WFL_RETURN; end; if neofs > 0 then do; /* if we have some eofs to write */ call mtape_$order (mtdp, "eof", neofs, null, wfl_code); /* Now write file mark(s) */ if wfl_code ^= 0 then do; call mtape_$error (mtdp, wfl_code, "^/While writing an End of File mark."); call ABORT_FILE (wfl_code); /* ask user what to do */ go to WFL_RETURN; /* quit now if we can't write eof */ end; end; if ltype = EOF_LABEL then do; /* if writing EOF labels, position before last EOF */ mtape_file_info.end_of_file_set = "1"b; /* Set marker, this is end of file set */ call mtape_$order (mtdp, "bsf", 1, null, wfl_code); mtape_file_info.position_within_file = AT_EOF; /* we are positioned at EOF */ end; WFL_RETURN: if wfl_code = 0 then /* if no other error */ if arg_ltype ^= ltype then /* but we wrote EOF instead of EOV label */ wfl_code = error_table_$no_next_volume; /* tell user he is done */ arg_code = wfl_code; return; %page; /* file_search - external entry to search for desired file in file history, and/or on tape */ file_search: entry (arg_mtdp, arg_fi_ptr, arg_vs_ptr, arg_code); mtdp = arg_mtdp; /* copy args */ fi_ptr = arg_fi_ptr; vs_ptr = arg_vs_ptr; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; arg_code, code = 0; if mtape_attach_info.labeled then if mtape_vol_set.volume_check > NON_MULT_VOLUME then do; /* can't read this one */ code = error_table_$uninitialized_volume; /* Give caller an appropriate code */ go to FS_RETURN; end; if mtape_open_info.append then /* if appending file to end of FS */ target_position = AT_EOF; /* final position must be EOF of last file */ else if mtape_open_info.extend then /* if extending existing file */ target_position = AT_EOFD; /* final position must be prior to end of data file */ else if mtape_open_info.modify then /* if modifying existing file */ target_position = AT_BOFD; /* go directly to beginning of data */ else target_position = AT_BOFH; /* otherwise position to file hdr */ found = "0"b; fi_ptr = mtape_data.fi_head; /* start at first file */ do while (fi_ptr ^= null & ^found); found = DESIRED_FILE (0); /* check each file found for match */ if ^found then /* if no match, advance to next file */ fi_ptr = mtape_file_info.next_fi_ptr; end; if found then do; /* if we found the file in history */ call POSITION_TO_FILE (target_position); /* position to appropriate place */ if code ^= 0 then go to FS_RETURN; /* if error, quit now */ if target_position = AT_BOFH then do; /* if positioned to hdrs, read them */ call read_file_labels (mtdp, fi_ptr, vs_ptr, htype, code); if code ^= 0 then go to FS_RETURN; /* if error, quit now */ if htype ^= BOF_LABEL then do; /* if we found the wrong typw of label */ code = error_table_$invalid_file_set_format; /* set code */ call mtape_$error (mtdp, code, "^/^[EOV^;EOF^] ^a, for file ^d (physical file ^d) on volume ^a", htype, "file label found where BOF label expected", mtape_file_info.seq_number, mtape_file_info.phy_file + 1, mtape_vol_set.volume_id); end; end; if mtape_open_info.append then /* if appending file.. */ fi_ptr = mtape_file_info.next_fi_ptr; /* go to next file_info (should be null) */ end; else do; /* didn't find file in history, search tape */ fi_ptr = mtape_data.fi_tail; /* start at last known file */ if fi_ptr ^= mtape_data.fi_current then do; /* last file beyond current position? */ call POSITION_TO_FILE (AT_BOFH); /* position to beginning of last file */ if code ^= 0 then go to FS_RETURN; /* bail out if problems */ end; if fi_ptr ^= null then /* not first search? */ if mtape_file_info.position_within_file = AT_EOF then do; if mtape_file_info.end_of_file_set then /* and this is last file */ go to NF_RETURN; /* return file not found */ else fi_ptr = mtape_file_info.next_fi_ptr; /* At EOF, advance to next file */ end; else if mtape_file_info.position_within_file = AT_BOFH & /* if in hdr file */ mtape_data.phy_block ^= 0 then do; /* but not beginning */ call POSITION_TO_FILE (AT_BOFH); /* position to re-read hdr */ if code ^= 0 then go to FS_RETURN; end; else if mtape_file_info.position_within_file = AT_BOFD | /* read trailer if */ mtape_file_info.position_within_file = AT_IFD | /* one of these */ mtape_file_info.position_within_file = AT_EOFD | mtape_file_info.position_within_file = AT_EOFT | (mtape_file_info.position_within_file = AT_BOFT & mtape_data.phy_block ^= 0) then do; call POSITION_TO_FILE (AT_BOFT); /* position to read trailer label */ if code ^= 0 then go to FS_RETURN; end; do while (^found & code = 0); /* search until found it or end of file set */ call read_file_labels (mtdp, fi_ptr, vs_ptr, htype, code); /* read the label group */ if code = 0 | code = error_table_$end_of_info then do; /* if no error.. */ found = DESIRED_FILE (htype); /* is this the right file? */ if (found & code = error_table_$end_of_info & mtape_open_info.append) | /* if EOFS */ (^found & code = 0 & htype > BOF_LABEL) then /* or at end of file (section) */ fi_ptr = mtape_file_info.next_fi_ptr; /* advance the file pointer */ if ^found & code = 0 & htype = BOF_LABEL then do; /* No, forward space to trailer label group */ call POSITION_TO_FILE (AT_BOFT); if code ^= 0 then go to FS_RETURN; end; end; end; if ^found then do; /* could not find file on file set */ NF_RETURN: code = error_table_$no_file; fi_ptr = null; /* force file info ptr to null */ go to FS_RETURN; end; code = 0; /* reset possible EOF status */ if mtape_open_info.extend then /* if extending this file.. */ call POSITION_TO_FILE (AT_EOFD); /* position prior to file mark */ else if mtape_open_info.last_file | /* if not extending the last file */ mtape_open_info.modify then /* or modifying this file */ call POSITION_TO_FILE (AT_BOFD); /* position to beginning of file data */ end; FS_RETURN: arg_mtdp = mtdp; /* copy arguments back in case of volume switch */ arg_fi_ptr = fi_ptr; arg_vs_ptr = vs_ptr; arg_code = code; return; %page; /* setup_file - entry to create and setup the common attributes of a file from the open options */ setup_file: entry (arg_mtdp, arg_fi_ptr, new_section); mtdp = arg_mtdp; /* copy arguments */ fi_ptr = arg_fi_ptr; vs_ptr = mtape_data.vs_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; if fi_ptr = null then /* are we creating new file, or replacing old */ call CREATE_FILE_LINK; else call truncate_file_set (mtdp); /* get ride of file history from this point */ pp = mtape_file_info.prev_fi_ptr; /* set for previous file */ if new_section then do; /* if adding new file section... */ mtape_file_info.per_file_info = pp -> mtape_file_info.per_file_info; /* copy per-file info directly */ mtape_file_info.section = pp -> mtape_file_info.section + 1; /* increment section */ mtape_file_info.first_file_on_volume = "1"b; /* new sections are always 1st */ mtape_file_info.end_of_file_set = "1"b; /* currently is so */ pp -> mtape_file_info.end_of_file_set = "0"b;/* previous section is not end */ mtape_file_info.first_file_section_ptr = pp -> mtape_file_info.first_file_section_ptr; mtape_file_info.begin_vs_ptr = pp -> mtape_file_info.begin_vs_ptr; pp -> mtape_file_info.position_within_file = NOT_POSITIONED_IN_FILE; call LINK_VS_END; /* link in the end vs structture */ end; else do; /* An entirely new file */ if pp = null then do; /* if this is first file.. */ mtape_file_info.file_set_id = translate (mtape_vol_set.volume_id, UC, LC); /* use 1st volume name */ prev_seq = 0; /* set to zero */ end; else do; /* otherwise, get from last file */ mtape_file_info.file_set_id = pp -> mtape_file_info.file_set_id; pp -> mtape_file_info.end_of_file_set = "0"b; /* previous file no longer end */ prev_seq = pp -> mtape_file_info.seq_number; end; if mtape_open_info.seq_number ^= 0 then /* if sequence number was specified.. */ mtape_file_info.seq_number = mtape_open_info.seq_number; /* use it */ else mtape_file_info.seq_number = prev_seq + 1; /* otherwise use prev + 1 */ if mtape_open_info.file_name ^= "" then /* if file name specified.. */ mtape_file_info.file_id = mtape_open_info.file_name; /* use it */ else do; /* must fabricate it */ pic4 = mtape_file_info.seq_number; /* convert seq number */ mtape_file_info.file_id = "FILE" || pic4; end; mtape_file_info.section = 1; mtape_file_info.begin_vs_ptr, mtape_file_info.end_vs_ptr = mtape_data.vs_current; mtape_file_info.first_file_section_ptr = fi_ptr; mtape_file_info.block_size = mtape_open_info.block_length; mtape_file_info.record_size = mtape_open_info.record_length; mtape_file_info.end_of_file_set = "1"b; /* file set ends with this file */ mtape_file_info.native_file = "1"b; /* file recorded by this PFM */ mtape_file_info.unlabeled_file = ^mtape_attach_info.labeled; /* invert labeled flag */ end; arg_fi_ptr = fi_ptr; /* set file_info ptr for caller */ return; %page; /* ABORT_FILE - int procedure to handle errors when writing file labels and TMs */ ABORT_FILE: proc (acode); dcl acode fixed bin (35); acode = error_table_$invalid_file_set_format; /* set default return code */ call mtape_$user_query (mtdp, Q_ABORT_FILE, code);/* ask user what to do */ if code ^= 0 then do; /* user answered no */ call mtape_$order (mtdp, "eof", 2, null, code); /* try to write 2 EOFs anyway */ return; end; /* user wants to truncate current file section (yes answer) */ if mtape_file_info.section > 1 then do; /* case 1: truncate to end of previous section */ mtape_data.fi_current = mtape_file_info.prev_fi_ptr; /* point to previous section */ call truncate_file_set (mtdp); /* truncate to this section */ call CK_VOL_SWITCH (mtape_vol_set.prev_vs_ptr, "0"b); /* switch volumes */ if code ^= 0 then return; /* return if error */ fi_ptr = mtape_data.fi_current; /* reset file_info ptr */ mtape_file_info.end_vs_ptr = vs_ptr; /* reflect that this is last volume */ call POSITION_TO_FILE (AT_BOFT); /* position before EOV labels */ if code ^= 0 then return; /* return if error */ nlp = mtape_file_info.first_file_trail_ptr; /* init label structure ptr */ call WRITE_LABEL_RECORDS (EOF_LABEL, code); /* write out the EOF sequence */ if code ^= 0 then return; /* return if error */ call mtape_$order (mtdp, "eof", 2, null, code); /* write 2 EOF marks */ if code = 0 then /* if no errors.. */ acode = error_table_$file_aborted; /* set appropriate return code now */ return; /* and return */ end; else do; /* case 2: file on one volume */ call truncate_file_set (mtdp); /* truncate and trailers */ call POSITION_TO_FILE (AT_BOFH); /* position to BOF */ if code ^= 0 then return; /* bail out on error */ call mtape_$order (mtdp, "eof", 2, null, code); /* write 2 eofs */ if code ^= 0 then return; /* bail out on error */ acode = error_table_$file_aborted; /* can now safely change return code */ do lr_ptr = mtape_file_info.last_file_lab_ptr repeat mtape_label_record.prev_lab_ptr while (lr_ptr ^= null); if mtape_label_record.next_lab_ptr ^= null then /* if not last label record */ free mtape_label_record.next_lab_ptr -> mtape_label_record in (based_area); free based_label_record in (based_area);/* free label contents */ end; if mtape_file_info.first_file_lab_ptr ^= null then free mtape_file_info.first_file_lab_ptr -> mtape_label_record in (based_area); if mtape_file_info.prev_fi_ptr = null then do; /* first and only file? */ free mtape_file_info in (based_area); /* free up area storage */ mtape_data.fi_current, mtape_data.fi_head, mtape_data.fi_tail = null; /* wipe out all traces */ call mtape_$order (mtdp, "rew", 0, null, code); /* rewind to BOT */ end; else do; /* not first file */ fi_ptr, mtape_data.fi_current, mtape_data.fi_tail = mtape_file_info.prev_fi_ptr; free mtape_file_info.next_fi_ptr -> mtape_file_info in (based_area); mtape_file_info.next_fi_ptr = null; /* no next file structure */ mtape_file_info.end_of_file_set = "1"b; /* this is now end of FS */ call POSITION_TO_FILE (AT_EOF); /* position to the end of current file */ end; end; end ABORT_FILE; %page; /* DESIRED_FILE - procedure to check if current file is the one we are looking for */ DESIRED_FILE: proc (htype) returns (bit (1) aligned); dcl htype fixed bin; if htype ^= 0 then /* if called when searching tape.. */ if mtape_open_info.extend | /* and we want to extend a file */ mtape_open_info.append | /* or append a file */ mtape_open_info.modify | /* or modify a file */ mtape_open_info.last_file then /* or position to last file */ if htype ^= EOF_LABEL then /* but are not at end of file */ return ("0"b); /* force read of end of file labels first */ if (mtape_open_info.append | mtape_open_info.last_file) & /* if need to be at */ mtape_file_info.end_of_file_set then /* end of file set and we are there */ return ("1"b); /* We have found desired file */ else if mtape_open_info.seq_number ^= 0 | /* looking for sequence number? */ mtape_open_info.file_name ^= "" | /* looking for file name? */ mtape_open_info.replace_id ^= "" then do; /* looking for file name to replace? */ if mtape_file_info.seq_number = mtape_open_info.seq_number then return ("1"b); /* if they match, we have found desired file */ if mtape_file_info.file_id = mtape_open_info.file_name then return ("1"b); /* if they match, we have found desired file */ if mtape_file_info.file_id = mtape_open_info.replace_id then return ("1"b); /* if they match, we have found desired file */ end; else if mtape_open_info.next_file then do; /* if looking for next file.. */ if htype = BOF_LABEL then /* if searching tape, make sure we are looking at HDR GRP */ return ("1"b); /* We have found it */ if mtape_data.fi_current ^= null then /* if not first file */ if mtape_file_info.prev_fi_ptr = mtape_data.fi_current then return ("1"b); /* we have found it */ end; return ("0"b); /* No match, did not find desired file */ end DESIRED_FILE; %page; /* POSITION_TO_FILE - internal subroutine to position to a particular existing file (defined by mtape_file_info structure), and to the desired position within that file */ /* * Each logical file is made up of 3 physical files. The model * used in determining position within each file is shown below: * * ---------------------------------------------------- * | FILE | FILE | FILE | * | | | | * | HEADER | DATA | TRAILER | * | | | | * | | | | * ---------------------------------------------------- * /\ /\/\ /\ /\/\ /\/\ * | | | | | | | | * |__AT_BOFH | |__AT_BOFD |__AT_IFD | |__AT_BOFT | |__AT_EOF * | | | | * |__AT_EOFH |__AT_EOFD |__AT_EOFT */ POSITION_TO_FILE: proc (target_position); dcl target_position fixed bin; go to PTF (target_position); /* do the proper processing */ PTF (1): /* Position to Beginning of File Header (AT_BOFH) */ call CK_VOL_SWITCH (mtape_file_info.begin_vs_ptr, "0"b); /* Use 1st file section */ if code ^= 0 then return; PTF (9): /* Position to Beginning of File Section */ call FILE_RIGHT_POSITION (mtape_file_info.phy_file); /* position to right of file mark */ if code = 0 then /* if no error, set final position */ mtape_file_info.position_within_file = AT_BOFH; return; PTF (2): /* Position to End of File Header (AT_EOFH) */ call CK_VOL_SWITCH (mtape_file_info.begin_vs_ptr, "0"b); /* Use 1st file section */ if code ^= 0 then return; call FILE_LEFT_POSITION (mtape_file_info.phy_file + 1); /* position to left of file mark */ if code = 0 then /* if no error, set final position */ mtape_file_info.position_within_file = AT_EOFH; return; PTF (3): /* Position to Beginning of File Data (AT_BOFD) */ PTF (4): /* Position within file data, not beginning (AT_IFD) */ call CK_VOL_SWITCH (mtape_file_info.begin_vs_ptr, "0"b); /* Use 1st file section */ if code ^= 0 then return; call FILE_RIGHT_POSITION (mtape_file_info.phy_file + 1); /* position to right of file mark */ if code = 0 then /* if no error, set final position */ mtape_file_info.position_within_file = AT_BOFD; return; PTF (5): /* Position to End of File Data (AT_EOFD) */ call CK_VOL_SWITCH (mtape_file_info.end_vs_ptr, "1"b); /* Use last file section (if > 1) */ if code ^= 0 then return; call FILE_LEFT_POSITION (mtape_file_info.phy_file + 2); /* position to left of file mark */ if code = 0 then /* if no error, set final position */ mtape_file_info.position_within_file = AT_EOFD; return; PTF (6): /* Position to Beginning of file trailer (AT_BOFT) */ call CK_VOL_SWITCH (mtape_file_info.end_vs_ptr, "1"b); /* Use last file section (if > 1) */ if code ^= 0 then return; call FILE_RIGHT_POSITION (mtape_file_info.phy_file + 2); /* position to right of file mark */ if code = 0 then /* if no error, set final position */ mtape_file_info.position_within_file = AT_BOFT; return; PTF (7): /* Position to End of file trailer (AT_EOFT) */ call CK_VOL_SWITCH (mtape_file_info.end_vs_ptr, "1"b); /* Use last file section (if > 1) */ if code ^= 0 then return; call FILE_LEFT_POSITION (mtape_file_info.phy_file + 3); /* position to left of file mark */ if code = 0 then /* if no error, set final position */ mtape_file_info.position_within_file = AT_EOFT; return; PTF (8): /* Position to End of file (AT_EOF) */ call CK_VOL_SWITCH (mtape_file_info.end_vs_ptr, "1"b); /* Use last file section (if > 1) */ if code ^= 0 then return; PTF (10): /* Position to End of File Section */ call FILE_RIGHT_POSITION (mtape_file_info.phy_file + 3); /* position to right of file mark */ if code = 0 then /* if no error, set final position */ mtape_file_info.position_within_file = AT_EOF; end POSITION_TO_FILE; %page; /* CK_VOL_SWITCH - internal subroutine to check if a volume switch is necessary to get to desired position within file and adjust fi_ptr for proper file section */ CK_VOL_SWITCH: proc (nvp, last_file_section); dcl nvp ptr; dcl last_file_section bit (1) aligned; if nvp ^= mtape_data.vs_current then do; /* volume switch required? */ call mtape_$volume_switch (mtdp, nvp, code); /* yes, do it */ if code ^= 0 then do; /* no go? */ call mtape_$error (mtdp, code, "^/Could not switch to volume ""^a"" at volume switch time", nvp -> mtape_vol_set.volume_name); return; end; vs_ptr = mtape_data.vs_current; /* set vol ptr for new vol */ if ^last_file_section then /* if we went to BOF */ fi_ptr = mtape_file_info.first_file_section_ptr; /* set file ptr to first section */ else do; /* we went to EOF */ term = "0"b; do nfip = fi_ptr repeat nfip -> mtape_file_info.next_fi_ptr while (^term); if nfip -> mtape_file_info.first_file_section_ptr ^= mtape_file_info.first_file_section_ptr then do; term = "1"b; /* found it, it is last file info */ fi_ptr = nfip -> mtape_file_info.prev_fi_ptr; end; else if nfip -> mtape_file_info.next_fi_ptr = null then do; /* last file */ term = "1"b; fi_ptr = nfip; /* this is it */ end; end; end; end; end CK_VOL_SWITCH; /* FILE_LEFT_POSITION - internal procedure to position to left of desired file mark */ FILE_LEFT_POSITION: proc (target_file); dcl target_file fixed bin; call FILE_RIGHT_POSITION (target_file); /* first position to right of file */ if code = 0 then call mtape_$order (mtdp, "bsf", 1, null, code); /* now backspace 1 file to desired position */ end FILE_LEFT_POSITION; %page; /* FILE_RIGHT_POSITION - internal subroutine to position to the right of the specified file mark */ FILE_RIGHT_POSITION: proc (target_file); dcl target_file fixed bin; if target_file >= mtape_data.phy_file then do; /* Positioned before desired file? */ space_files = target_file - mtape_data.phy_file; /* yes, must position forward */ forward = "1"b; end; else do; /* No, Positioned past desired file */ if mtape_file_info.first_file_on_volume then do; /* if this is true, can rewind */ call REWIND_TO_BOF; /* rewind tape */ if code ^= 0 then return; space_files = target_file; end; else do; /* no must backspace */ space_files = mtape_data.phy_file - target_file; /* position backward */ if space_files ^= 0 then /* only back up if not at right position */ space_files = space_files + 1; /* must back up 1 more and fwd space 1 file to get to beginning of desired file */ forward = "0"b; end; end; if space_files ^= 0 then do; /* if we have to position.. */ if ^forward then do; /* go backward n files? */ call mtape_$order (mtdp, "bsf", space_files, null, code); if code = 0 then do; space_files = 1; /* must now forward space 1 file */ forward = "1"b; /* set switch for error message */ end; end; if code = 0 & space_files ^= 0 then call mtape_$order (mtdp, "fsf", space_files, null, code); if code ^= 0 then do; call mtape_$error (mtdp, code, "^/While ^[forward ^;back^]spacing ^d files to position to file ""^a"".", forward, space_files, mtape_file_info.file_id); return; end; end; mtape_data.fi_current = fi_ptr; /* reset external position indicator */ end FILE_RIGHT_POSITION; %page; /* REWIND_TO_BOF - internal procedure to rewind volume and forward space over volume labels */ REWIND_TO_BOF: proc; call mtape_$order (mtdp, "rew", 0, null, code); if code ^= 0 then do; call mtape_$error (mtdp, code, "^/Attempting to rewind volume ^a to position to beginning of file ^a", mtape_vol_set.volume_id, mtape_file_info.file_id); return; end; /* now space over volume labels */ if mtape_vol_set.number_of_vol_labels > 0 then do;/* only if a labeled volume */ call mtape_$order (mtdp, "fsr", mtape_vol_set.number_of_vol_labels, null, code); if code ^= 0 then call mtape_$error (mtdp, code, "^/Attempting to forward space over volume labels on volume ^a, to position to beginning of file ^a", mtape_vol_set.volume_id, mtape_file_info.file_id); end; end REWIND_TO_BOF; /* CREATE_FILE_LINK - internal procedure to create a file info structure and link it in */ CREATE_FILE_LINK: proc; call mtape_$alloc (mtdp, MTAPE_ALLOC_FI, mtape_data.fi_tail, 0, fi_ptr); mtape_data.fi_current, mtape_data.fi_tail = fi_ptr; /* Link this file info structure in */ if mtape_data.fi_head = null then do; /* if this is first file */ mtape_data.fi_head = fi_ptr; /* Set link head also */ mtape_file_info.first_file_on_volume = "1"b; /* set indicator for later positioning */ end; mtape_file_info.position_within_file = AT_BOFH; /* set initial position to hdr file */ mtape_file_info.phy_file = mtape_data.phy_file; /* and set file number of header */ end CREATE_FILE_LINK; /* LINK_VS_END - internal procedure to link in the file_info.vs_end ptr */ LINK_VS_END: proc; dcl prevp ptr; dcl term bit (1) aligned; term = "0"b; do prevp = fi_ptr repeat prevp -> mtape_file_info.prev_fi_ptr while (prevp ^= null & ^term); if prevp -> mtape_file_info.first_file_section_ptr ^= mtape_file_info.first_file_section_ptr then term = "1"b; else prevp -> mtape_file_info.end_vs_ptr = mtape_data.vs_current; end; end LINK_VS_END; /* WRITE_LABEL_RECORDS - int procedure to write out label records as specified by PFM */ WRITE_LABEL_RECORDS: proc (ltype, acode); dcl ltype fixed bin; dcl (acode, code) fixed bin (35); acode = 0; /* reset return code */ if mtape_attach_info.labeled then do; /* if a labeled tape */ RECODE_LABELS: /* target to change EOV to EOF labels */ code = 0; /* reset error code */ do lab_num = 1 by 1 while (code ^= error_table_$end_of_info); /* write until told to quit */ call mtape_data.encode_file_labels (mtdp, mtape_data.tlb, lab_num, ltype, convert, code); if code ^= 0 then /* if error from encode routine */ if code = error_table_$no_next_volume then /* user does not have another volume */ if ltype = EOV_LABEL then do; /* and it is for end of volume */ ltype = EOF_LABEL; /* then write EOF label */ go to RECODE_LABELS; /* instead */ end; if code = 0 then do; if nlp = null then do; /* if no previous label structure, allocate it */ if ltype > BOF_LABEL then /* if EOF or EOV labels.. */ call init_label_record (mtdp, mtape_file_info.last_file_trail_ptr, mtape_file_info.first_file_trail_ptr, lr_ptr, mtape_data.lab_buf_len); else call init_label_record (mtdp, mtape_file_info.last_file_lab_ptr, mtape_file_info.first_file_lab_ptr, lr_ptr, mtape_data.lab_buf_len); end; else lr_ptr = nlp; /* it does exist, use it */ nlp = mtape_label_record.next_lab_ptr; /* update ptr for next label */ mtape_label_record.conversion = convert; /* set conversion indicator & copy label */ based_label_record = mtape_data.tlb -> mtape_label_record.lab_ptr -> based_label_record; call mtape_$write_label (mtdp, lr_ptr, code); /* write it out */ if code ^= 0 then /* if unrecoverable error */ if code ^= error_table_$eov_on_write then do; /* but not EOV */ call mtape_$error (mtdp, code, "^/Attempting to write ^[BOF^;EOV^;EOF^] file label ^d on volume ^a.", ltype, lab_num, mtape_vol_set.volume_id); acode = code; /* report error to caller */ return; end; else code = 0; /* ignore EOV status for now */ end; end; end; end WRITE_LABEL_RECORDS; %page; /* DECODE_UNLABELED_FILE - internal procedure to determine file position and file in file info */ DECODE_UNLABELED_FILE: proc; if fi_ptr = null then do; /* if file_info does not exist.. */ ltype = BOF_LABEL; /* must be BOF */ call CREATE_FILE_LINK; /* create the file info structure */ mtape_file_info.phy_file = mtape_data.position.phy_file; /* copy file number */ pp = mtape_file_info.prev_fi_ptr; /* make lines shorter */ if pp ^= null then /* if there was a previous file */ if pp -> mtape_file_info.begin_vs_ptr ^= mtape_data.vs_current then do; /* new section */ mtape_file_info.section = pp -> mtape_file_info.section + 1; /* increment */ mtape_file_info.per_file_info = pp -> mtape_file_info.per_file_info; mtape_file_info.first_file_on_volume = "1"b; /* set for later positioning */ mtape_file_info.first_file_section_ptr = pp -> mtape_file_info.first_file_section_ptr; mtape_file_info.begin_vs_ptr = pp -> mtape_file_info.begin_vs_ptr; end; else ; else do; mtape_file_info.section = 1; /* beginning of new file */ if pp = null then do; /* first file? */ mtape_file_info.seq_number = 1; /* yes, init seq number */ mtape_file_info.first_file_on_volume = "1"b; /* set for more efficient positioning */ end; else mtape_file_info.seq_number = pp -> mtape_file_info.seq_number + 1; mtape_file_info.unlabeled_file = "1"b; /* set this indicator */ mtape_file_info.begin_vs_ptr = vs_ptr; mtape_file_info.first_file_section_ptr = fi_ptr; end; call LINK_VS_END; /* link in the end vol ptr */ end; else if mtape_data.phy_file = mtape_file_info.phy_file then do; /* currently positioned */ ltype = BOF_LABEL; /* within file, its beginning */ if mtape_file_info.prev_fi_ptr ^= null then mtape_file_info.prev_fi_ptr -> mtape_file_info.position_within_file = NOT_POSITIONED_IN_FILE; mtape_data.fi_current = fi_ptr; /* this is now current file */ end; else do; /* either EOF, EOV, or EOFS */ call mtape_$order (mtdp, "fsr", 1, null, rfl_code); /* forward space & ck for EOF status */ if rfl_code ^= 0 & rfl_code ^= error_table_$end_of_info then do; /* a real error */ call mtape_$error (mtdp, rfl_code, "^/^a ^a, file ^d to test for EOV", "Attempting to forward space a block on Unlabeled volume", mtape_vol_set.volume_name, mtape_data.phy_file); return; end; if rfl_code = 0 then do; /* if no eof status, we were at eof */ ltype = EOF_LABEL; call mtape_$order (mtdp, "bsr", 1, null, rfl_code); /* backspace 1 file mark */ if rfl_code ^= 0 then call mtape_$error (mtdp, rfl_code, "^/Positioning to the end of an unlabeled file"); end; else do; /* 2 consecutive EOF statuses; EOV or EOFS? */ if mtape_vol_set.next_vs_ptr ^= null then do; /* next volume defined? */ ltype = EOV_LABEL; /* yes, by definition, this is EOV */ rfl_code = 0; /* reset EOF status code */ end; else do; /* end of file set */ mtape_file_info.end_of_file_set = "1"b; /* Set marker */ call mtape_$order (mtdp, "bsf", 1, null, rfl_code); /* backspace 1 file mark */ if rfl_code ^= 0 then call mtape_$error (mtdp, rfl_code, "^/Positioning to the tape mark prior to the end of file set."); rfl_code = error_table_$end_of_info; /* reset EOF code */ end; end; end; end DECODE_UNLABELED_FILE; %page; %include mtape_data; %page; %include mtape_label_record; %include mtape_err_stats; %page; %include mtape_vol_set; %page; %include mtape_file_info; %page; %include mtape_attach_info; %include mtape_pfm_info; %page; %include mtape_open_close_info; %page; %include mtape_constants; end pfm_utils_;  raw_tape_io_.pl1 12/17/86 0926.1r w 12/17/86 0832.2 43830 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ raw_tape_io_: procedure; /* format: style4 */ /* * This program runs under control of the mtape_ I/O module and is meant * to process data and file formats that are specific to RAW * formated tapes, and is known as a Per-Format module. * * This Per-Format module is not fully implemented, and is only included * so that if a RAW tape volume is mounted and recognized by * mtape_/RCP, a linkage error will not result. When this module is * called at its pfm_init entry, an error message is displayed * explaining that the RAW Per-format module has not been * implemented, and an error code is returned. * * Modification History: * * Dummy version created by J. A. Bush 07/10/83 */ /* ARGUMENT DATA */ dcl arg_mtdp ptr; /* Pointer to the mtape data structure */ dcl arg_code fixed bin (35); /* Return error code */ dcl arg_info_ptr ptr; /* Pointer to Order data from iox_$control call */ dcl arg_io_call_infop ptr; /* Pointer to io_call control info structure */ dcl arg_order_name char (*); /* Name of Control order to be processed */ dcl arg_lr_ptr ptr; /* Pointer to current label record structure */ dcl arg_labno fixed bin; /* label record within label group */ dcl arg_type fixed bin; /* 1 => BOF; 2 => EOV; 3 => EOF */ dcl arg_convert fixed bin; /* Label record conversion indicator */ /* AUTOMATIC DATA */ dcl code fixed bin (35); dcl buf_ptr ptr; /* Auto copy of users buffer pointer */ dcl buf_len fixed bin (21); /* Auto copy of users lrec buffer */ dcl rec_len fixed bin (21); /* Auto copy of logical record length */ /* CONSTANT DATA */ /* EXTERNAL STATIC DATA */ dcl error_table_$unimplemented_version fixed bin (35) ext static; /* BUILTIN FUNCTIONS */ /* EXTERNAL ENTRIES */ /* BASED VARIABLES */ %page; /* pfm_init - entry to initialize the Per-Format module, setting up file and volume processing parameters and determining correctness of current volume */ pfm_init: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ code = error_table_$unimplemented_version; /* This is for the dummy PFM */ call mtape_$error (mtdp, code, "^/The mtape_ RAW Per-Format module has not been fully implemented."); arg_code = code; return; %page; /* file_open - entry to do format specific processing in opening the file or file set (i.e. read and write file labels) */ file_open: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* file_close - entry to do format specific processing in closing the file or file set (i.e. read and write file trailer labels) */ file_close: entry (arg_mtdp, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* read - entry to read format specific logical records from the current file */ read: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; /* If = null, return length of next record */ buf_len = mtape_data.arg_buf_len; return; %page; /* write - entry to write format specific logical records into the current file */ write: entry (arg_mtdp, arg_code); mtdp = arg_mtdp; /* Copy arguments */ buf_ptr = mtape_data.arg_buf_ptr; buf_len = mtape_data.arg_buf_len; return; %page; /* order - entry to process format specific control orders not recognized by mtape_ */ order: entry (arg_mtdp, arg_order_name, arg_info_ptr, arg_io_call_infop, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* decode_file_labels - entry to extract info contained in file labels, and fill in file_info structure */ decode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* encode_file_labels - entry to fill in file labels from info obtained from file_info structure */ encode_file_labels: entry (arg_mtdp, arg_lr_ptr, arg_labno, arg_type, arg_convert, arg_code); call SETUP; /* initialize our enviornment */ return; %page; /* SETUP - internal procedure to set up enviornment for the external entries */ SETUP: proc; mtdp = arg_mtdp; /* get pointers to pertinient data */ vs_ptr = mtape_data.vs_current; fi_ptr = mtape_data.fi_current; maip = mtape_data.attach_info_ptr; moip = mtape_data.open_info_ptr; mpfmip = mtape_data.pfm_info_ptr; arg_code, code = 0; /* and reset error codes */ end SETUP; %page; %include mtape_includes; %page; %include rcp_volume_formats; end raw_tape_io_; 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