d IBM: PROC OPTIONS(MAIN);
,%INCLUDE SYS$ASSIGN;
%INCLUDE SYS$QIOW;
%include sys$getmsg;
X%INCLUDE PLI_FILE_DISPLAY;
%INCLUDE $STSDEF;
%INCLUDE GETFIX;
%INCLUDE GETCHAR;
%INCLUDE GETWORD;
L%INCLUDE TRIM;
%INCLUDE RTRIM;
%INCLUDE WORDDATE;
x%INCLUDE JULDATE;
%INCLUDE YYDDD;
@
%REPLACE MT$V_DENSITY BY 8;
%REPLACE MT$K_PE_1600 BY 4;
l%REPLACE MT$K_NRZI_800 BY 3;
4DCL (LIB$TRA_ASC_EBC,LIB$TRA_EBC_ASC,STR$UPCASE)
EXTERNAL ENTRY (CHAR(*),CHAR(*)) RETURNS (FIXED BIN (31));
` DCL (SS$_NORMAL,SS$_ENDOFFILE,SS$_ENDOFTAPE,IO$M_REVERSE,IO$_READLBLK,
IO$_REWIND,IO$_SENSEMODE,IO$_SETMODE,IO$_SKIPFILE,IO$_WRITELBLK,
(
IO$_WRITEOF) FIXED BIN(31) GLOBALREF VALUE;
DCL 1 IOSB,
T 2 VALUE FIXED BIN(15),
2 BYTES_TRANSFERRED FIXED BIN(15),
2 INFORMATION FIXED BIN(31);
DCL 1 TAPE_SET,
H
2 INFORMATION FIXED BIN(15),
2 BLOCK_BUFFER_SIZE FIXED BIN(15) INIT (0),
2 CHARACTERISTICS FIXED BIN(31) INIT(MT$K_PE_1600*2**MT$V_DENSITY);
t
DCL /* BIT FLIP FLOPS */
< FLIP_FLOP_1 (4) BIT (1),
FLIP_FLOP_2 (4) BIT (1);
hDCL 1 VARIABLE_LENGTH_CONTROL_WORD,
5 RECORD_DESCRIPTOR CHAR(2),
0 5 DESCRIPTOR_FILLER CHAR(2);
DCL RECORD_LENGTH FIXED BIN(15) BASED(OVERLAY_PTR);
\OVERLAY_PTR = ADDR(DESCRIPTOR_FILLER);
RECORD_LENGTH = 0;
$OVERLAY_PTR = ADDR(RECORD_DESCRIPTOR);
DCL VAX_FILE FILE RECORD;
PDCL SV FILE STREAM OUTPUT;
DCL BLOCK_BUFFER CHAR(BLKSIZE) BASED(BLOCK_LOC);
|DCL RECORD_BUFFER CHAR(LRECL) VARYING BASED(RECORD_LOC);
DCL CONVERSION_BUFFER CHAR(LRECL) BASED(CONVERSION_PTR);
D
DCL (VOLUME_HEADER,HEADER_LABEL1,HEADER_LABEL2,
TRAILER_LABEL1,TRAILER_LABEL2) CHAR(80);
p
DCL TAPE_CHANNEL FIXED BIN (15) INIT (0);
8
DCL (RECORD_COUNT,FILE_COUNT,BLOCK_COUNT,TRAILER_BLOCK_COUNT,
BYTE_COUNT,LRECL,BLKSIZE,DENSITY,I,SKIP_FILE_COUNT,RECORD_SIZE)
d FIXED BIN (31) INIT (0);
,DCL (CONVERSION_PTR,DISPLAY_LOC,BLOCK_LOC,RECORD_LOC,OVERLAY_PTR) POINTER;
DCL (STANDARD_LABEL,WRITING_TAPE,TRIM_RECORDS,ASCII_DATA,EBCDIC_DATA,UPPERCASE,REVERSE_BYTES,
X FILE_OPENED,FIXED_FLAG,EOF,EOT,VOLUME_LABEL_FOUND,VARIABLE_LENGTH) BIT (1) ALIGNED;
DCL VOLUME_SERIAL_NO CHAR(6),
CREATION_DATE CHAR(5),
DATA_SET_ID CHAR(17),
L RECORD_FORMAT CHAR(1),
DATA_FORMAT CHAR(8),
SEQUENCE_NUMBER CHAR(4),
x (FILE_NAME,ANSWER) CHAR(64) VARYING;
@ DCL PIC_4 PIC'9999',
PIC_5 PIC'99999',
PIC_6 PIC'999999';
l
DCL MSG_LENGTH FIXED BIN(15),
4! MSG_ERROR CHAR(256) INIT(' '),
! MSG_MISC_INFO (4) FIXED BIN(7);
d PUT EDIT('Westat Foreign Tape Utility--V1.4--',WORDDATE(JULDATE(DATE())))
(SKIP,2 A);
,PUT EDIT(' ')(SKIP,A);
ANSWER = GETWORD('Do you want information ? :','YES NO');
IF ANSWER = 'YES' THEN
X PUT EDIT(
' ',
'This utility is designed to perform I/O on foreign tapes.',
'Data may be copied to or from any standard VAX system file on disk or tape.',
' ',
L 'The utility currently supports:',
' ',
' 1. ASCII or EBCDIC data conversion.',
x ' 2. Nonlabelled or IBM standard labelled tapes.',
' 3. Fixed length or variable length records.',
@ ' 4. Delete trailing blanks from input records.',
' 5. Convert lowercase to uppercase.',
' ',
l 'Tape must be mounted with the commands:',
' ',
4 ' $ ALLOC MTA0: TAPE',
' $ MOUNT/FOREIGN MTA0:',
' ',
` ' before running this program.',
' ',
(
'Remember to insert a write ring before mounting a tape for output.',
' ',
'To report problems or for help contact Al Jaworski or Bruce Vivari.')
T (SKIP,A);
PUT SKIP;
ANSWER=GETWORD('Read or write the tape? :',
'READ WRITE');
H
IF ANSWER='WRITE' THEN WRITING_TAPE='1'B;
ELSE WRITING_TAPE='0'B;
t/* GET CHANNEL TO TAPE DRIVE AND REWIND TAPE */
<STS$VALUE=SYS$ASSIGN('TAPE',TAPE_CHANNEL,,);
IF STS$VALUE ^= SS$_NORMAL THEN DO;
STS$VALUE = SYS$GETMSG(STS$VALUE,MSG_LENGTH,MSG_ERROR,,MSG_MISC_INFO);
h PUT EDIT(MSG_ERROR)(SKIP,A);
PUT EDIT ('A tape has not been assigned to logical name TAPE.',
0 'Program is terminated.')
(SKIP,2(SKIP,A));
RETURN;
\END;
$CALL REWIND_TAPE;
IF WRITING_TAPE THEN CALL WRITE_TAPE;
PELSE CALL READ_TAPE;
CALL REWIND_TAPE;
|RETURN;
/* END OF MAIN PROGRAM */
d READ_TAPE: PROC;
,CALL TEST_STANDARD_LABEL;
IF STANDARD_LABEL THEN CALL READ_VOLUME_LABEL;
X
EOT='0'B;
FILE_COUNT=0;
FILE_LOOP: DO WHILE(^EOT);
L
ANSWER = GETWORD('Skip files ?: ','YES NO');
IF ANSWER = 'YES' THEN DO;
x SKIP_FILE_COUNT = GETFIX('Number of files ?: ','1-256');
IF STANDARD_LABEL THEN
@ SKIP_FILE_COUNT = SKIP_FILE_COUNT * 3;
ELSE
FILE_COUNT = FILE_COUNT + SKIP_FILE_COUNT;
l CALL SKIP_FILES;
END;
4
FILE_COUNT=FILE_COUNT+1;
IF STANDARD_LABEL THEN DO;
` CALL READ_HEADER_LABELS;
PUT EDIT('Data set number ',TRIM(CHAR(SEQUENCE_NUMBER)),
(
'Name is ',TRIM(CHAR(DATA_SET_ID)),
'Record format is ',TRIM(CHAR(RECORD_FORMAT)),
'Record size is ',TRIM(CHAR(LRECL)),
T 'Block size is ',TRIM(CHAR(BLKSIZE)))
(SKIP(2),2 A,4(SKIP,2 A));
END;
ELSE DO;
PUT EDIT('Data set number ',TRIM(CHAR(FILE_COUNT)))
H
(SKIP(2),2 A);
ANSWER = GETWORD('Input record length fixed or variable ?:')('FIXED VARIABLE');
IF ANSWER = 'FIXED' THEN
t VARIABLE_LENGTH = '0'B;
ELSE DO;
< VARIABLE_LENGTH = '1'B;
PUT EDIT ('Entry of record and block sizes should include',
'the 4 byte record and block descriptors.')(SKIP(2),A,SKIP,X(4),A);
h END;
LRECL=GETFIX('Input record size ?: ','14-32760');
0 BLKSIZE=GETFIX('Input block size ? :','14-32760');
IF VARIABLE_LENGTH THEN
DO WHILE (LRECL + 4 > BLKSIZE);
\ PUT EDIT('Record size must be at least 4 bytes < block size')(skip,a);
LRECL=GETFIX('Input record size ?: ','14-32760');
$ BLKSIZE=GETFIX('Input block size ? :','18-32760');
END;
ELSE
P DO WHILE(MOD(BLKSIZE,LRECL)^=0);
PUT EDIT(COPY(BYTE(7),3),'Block size must be a multiple of record size')
(SKIP,A);
| LRECL=GETFIX('Input record size ?:','14-32760');
BLKSIZE=GETFIX('Input block size ?:','14-32760');
D END;
ANSWER = GETWORD('ASCII or EBCDIC input ?:')('ASCII EBCDIC');
IF ANSWER = 'EBCDIC' THEN
p EBCDIC_DATA = '1'B;
END;
8 ANSWER=GETWORD(
'Variable or fixed-length output records ?: ',
'VARIABLE FIXED');
d IF ANSWER='FIXED' THEN
FIXED_FLAG = '1'B;
, ELSE DO;
FIXED_FLAG='0'B;
ANSWER=GETWORD(
X 'Trim trailing blanks ?: ',
'YES NO');
IF ANSWER='YES' THEN TRIM_RECORDS='1'B;
ELSE TRIM_RECORDS='0'B;
END;
L
ANSWER = GETWORD('Convert lower to uppercase ? :','YES NO');
IF ANSWER = 'YES' THEN
x UPPERCASE = '1'B;
ELSE
@ UPPERCASE = '0'B;
REVERSE_BYTES = '0'B;
l IF VARIABLE_LENGTH THEN DO;
ANSWER = GETWORD('Do the block/record control words need conversion ?: ',
4! 'YES NO');
! IF ANSWER = 'YES' THEN
! REVERSE_BYTES = '1'B;
`" END;
"
(# ON UNDEFINEDFILE(VAX_FILE) BEGIN;
# PUT EDIT(TRIM(FILE_NAME),' Cannot be opened.')
# (SKIP(2),2 A);
T$ FILE_OPENED='0'B;
$ END;
%
% FILE_OPENED='0'B;
% DO WHILE(^FILE_OPENED);
H& FILE_NAME=GETCHAR('Output file name?: ',64,'');
& FILE_OPENED='1'B;
' OPEN FILE(VAX_FILE) TITLE(FILE_NAME) OUTPUT
t' ENVIRONMENT(MAXIMUM_RECORD_SIZE(LRECL),
' FIXED_LENGTH_RECORDS(FIXED_FLAG));
<( END;
(
) ALLOCATE PLI_FILE_DISPLAY SET(DISPLAY_LOC);
h) CALL DISPLAY(VAX_FILE,DISPLAY_LOC->PLI_FILE_DISPLAY);
) PUT EDIT('Output file name is ',DISPLAY_LOC->EXPANDED_TITLE)
0* (SKIP,2 A);
*
* BLOCK_COUNT=0;
\+ RECORD_COUNT=0;
+ ALLOC BLOCK_BUFFER SET(BLOCK_LOC);
$, ALLOC RECORD_BUFFER SET(RECORD_LOC);
, ALLOC CONVERSION_BUFFER SET(CONVERSION_PTR);
,
P- PUT EDIT('Copying ...')(SKIP(2),A);
-
. /* Record reads start here */
|. STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_READLBLK,IOSB,,,
. BLOCK_LOC,BLKSIZE,,,,);
D/ IF ^VARIABLE_LENGTH & IOSB.BYTES_TRANSFERRED ^= BLKSIZE THEN DO;
/ PUT EDIT ('Block size read differs from your specification.',
0 'Tape block size is ',TRIM(CHAR(IOSB.BYTES_TRANSFERRED)),
p0 'Utility is terminated.')(SKIP,A,SKIP,A,A,SKIP,A);
0 STOP;
81 END;
1
2 DO WHILE(IOSB.VALUE^=SS$_ENDOFFILE);
d2 IF STS$VALUE ^= SS$_NORMAL THEN DO;
2 STS$VALUE = SYS$GETMSG(STS$VALUE,MSG_LENGTH,MSG_ERROR,,MSG_MISC_INFO);
,3 PUT EDIT('Tape processing error encountered ---> ',msg_error,
3 'Utility is terminated.')(SKIP(2),A,A,SKIP(2),A);
3 STOP;
X4 END;
4 IF IOSB.VALUE ^= SS$_NORMAL THEN DO;
5 STS$VALUE = SYS$GETMSG(IOSB.VALUE,MSG_LENGTH,MSG_ERROR,,MSG_MISC_INFO);
5 PUT EDIT ('Tape processing error has occurred ---> ',
5 msg_error,'Processing is terminated.')(skip,a,a,skip,a);
L6 STOP;
6 END;
7 BLOCK_COUNT=BLOCK_COUNT+1;
x7 record_descriptor = substr(block_buffer,1,2);
7 IF VARIABLE_LENGTH THEN
@8 BYTE_COUNT = 5;
8 ELSE
9 BYTE_COUNT = 1;
l9 DO WHILE(BYTE_COUNT < IOSB.BYTES_TRANSFERRED);
9 IF VARIABLE_LENGTH THEN DO;
4: IF REVERSE_BYTES THEN DO;
: SUBSTR(RECORD_DESCRIPTOR,2,1) = SUBSTR(BLOCK_BUFFER,BYTE_COUNT,1);
: SUBSTR(RECORD_DESCRIPTOR,1,1) = SUBSTR(BLOCK_BUFFER,BYTE_COUNT + 1,1);
`; END;
; ELSE
(< RECORD_DESCRIPTOR = SUBSTR(BLOCK_BUFFER,BYTE_COUNT,2);
< IF RECORD_LENGTH > LRECL THEN DO;
< PUT EDIT ('Record on tape exceeds user length specification.',
T= 'Length of record was ',TRIM(CHAR(RECORD_LENGTH)),
= 'Utility is terminated.')(SKIP,A,SKIP,A,A,SKIP,A);
> STOP;
> END;
> RECORD_BUFFER = SUBSTR(BLOCK_BUFFER,BYTE_COUNT + 4,RECORD_LENGTH - 4);
H? BYTE_COUNT = BYTE_COUNT + RECORD_LENGTH;
? END;
@ ELSE DO;
t@ RECORD_BUFFER=SUBSTR(BLOCK_BUFFER,BYTE_COUNT,LRECL);
@ BYTE_COUNT = BYTE_COUNT + LRECL;
PLI_FILE_DISPLAY);
PUT EDIT('Input file name is ',DISPLAY_LOC->EXPANDED_TITLE)
(SKIP,A);
`
IF STANDARD_LABEL THEN
(
DATA_SET_ID=GETCHAR('What is the tape data set name?: ',17,
'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.');
T ANSWER = GETWORD('Output records variable length ?: ','YES NO');
IF ANSWER = 'YES' THEN DO;
VARIABLE_LENGTH = '1'B;
PUT EDIT ('Entry of record and block sizes should include',
'the 4 byte record and block descriptors.')(SKIP(2),A,SKIP,X(4),A);
H
END;
ELSE
VARIABLE_LENGTH = '0'B;
t
LRECL=GETFIX('What is the tape output file record size?: ','14-32760');
< BLKSIZE=GETFIX('What is the tape output file block size? :','14-32760');
IF VARIABLE_LENGTH THEN
DO WHILE (LRECL + 4 > BLKSIZE);
h PUT EDIT ('Record size must be at least 4 bytes < block size.')(skip,a);
LRECL = GETFIX('Re-enter record size : ','14-32760');
0 BLKSIZE = GETFIX('Re-enter block size : ','18-32760');
END;
ELSE
\ DO WHILE(MOD(BLKSIZE,LRECL)^=0);
PUT EDIT(COPY(BYTE(7),3),'Block size must be a multiple of record size')
$ (SKIP,A);
LRECL=GETFIX('Record size? :','14-32760');
BLKSIZE=GETFIX('Block size? :','14-32760');
P END;
ANSWER=GETWORD('Convert lower to uppercase ?: ','YES NO');
| IF ANSWER = 'YES' THEN
UPPERCASE = '1'B;
D ELSE
UPPERCASE = '0'B;
p REVERSE_BYTES = '0'B;
IF VARIABLE_LENGTH THEN DO;
8 ANSWER = GETWORD('Do the block/record control words need conversion ?: ',
'YES NO');
IF ANSWER = 'YES' THEN
d REVERSE_BYTES = '1'B;
END;
,
FILE_COUNT = FILE_COUNT + 1;
X IF STANDARD_LABEL THEN CALL WRITE_HEADERS;
BLOCK_COUNT=0;
RECORD_COUNT=0;
EOF='0'B;
L ALLOC BLOCK_BUFFER SET(BLOCK_LOC);
ALLOC RECORD_BUFFER SET(RECORD_LOC);
ALLOC CONVERSION_BUFFER SET(CONVERSION_PTR);
x
ON ENDFILE (VAX_FILE) EOF='1'B;
@
READ FILE (VAX_FILE) INTO (RECORD_BUFFER);
l PUT EDIT('Copying ...')(SKIP(2),A);
4! DO WHILE(^EOF);
! BLOCK_BUFFER=' ';
! IF EBCDIC_DATA THEN
`" STS$VALUE = LIB$TRA_ASC_EBC(BLOCK_BUFFER,BLOCK_BUFFER);
" IF ^VARIABLE_LENGTH THEN DO;
(# BYTE_COUNT = 0;
# DO WHILE(^EOF & BYTE_COUNT < BLKSIZE);
# RECORD_SIZE = LENGTH(RECORD_BUFFER);
T$ IF RECORD_SIZE > LRECL THEN DO;
$ PUT EDIT ('Record size read > parameter supplied ',LRECL,
% 'Utility is terminated.')(SKIP,A,F(5),SKIP,A);
% STOP;
% END;
H& IF UPPERCASE THEN DO;
& CONVERSION_BUFFER = RECORD_BUFFER;
' STS$VALUE = STR$UPCASE(CONVERSION_BUFFER,CONVERSION_BUFFER);
t' RECORD_BUFFER = SUBSTR(CONVERSION_BUFFER,1,LENGTH(RECORD_BUFFER));
' END;
<( IF EBCDIC_DATA THEN DO;
( CONVERSION_BUFFER = RECORD_BUFFER;
) STS$VALUE = LIB$TRA_ASC_EBC(CONVERSION_BUFFER,CONVERSION_BUFFER);
h) RECORD_BUFFER = SUBSTR(CONVERSION_BUFFER,1,LENGTH(RECORD_BUFFER));
) END;
0* SUBSTR(BLOCK_BUFFER,BYTE_COUNT + 1,RECORD_SIZE) = RECORD_BUFFER;
* BYTE_COUNT = BYTE_COUNT + LRECL;
* RECORD_COUNT=RECORD_COUNT+1;
\+ READ FILE (VAX_FILE) INTO (RECORD_BUFFER);
+ END;
$, END;
, ELSE DO;
, BYTE_COUNT = 4;
P- RECORD_LENGTH = LENGTH(RECORD_BUFFER) + 4;
- DO WHILE (^EOF & BYTE_COUNT + RECORD_LENGTH <= BLKSIZE);
. RECORD_SIZE = RECORD_LENGTH;
|. IF RECORD_SIZE > LRECL - 4 THEN DO;
. PUT EDIT ('Record size read > parameter supplied ',LRECL,
D/ 'Utility is terminated.')(SKIP,A,F(5),SKIP,A);
/ STOP;
0 END;
p0 IF REVERSE_BYTES THEN DO;
0 SUBSTR(BLOCK_BUFFER,BYTE_COUNT + 1,1) = SUBSTR(RECORD_DESCRIPTOR,2,1);
81 SUBSTR(BLOCK_BUFFER,BYTE_COUNT + 2,1) = SUBSTR(RECORD_DESCRIPTOR,1,1);
1 SUBSTR(BLOCK_BUFFER,BYTE_COUNT + 3,2) = DESCRIPTOR_FILLER;
2 END;
d2 ELSE
2 SUBSTR(BLOCK_BUFFER,BYTE_COUNT + 1,4) = STRING(VARIABLE_LENGTH_CONTROL_WORD);
,3 IF UPPERCASE THEN DO;
3 CONVERSION_BUFFER = RECORD_BUFFER;
3 STS$VALUE = STR$UPCASE(CONVERSION_BUFFER,CONVERSION_BUFFER);
X4 RECORD_BUFFER = SUBSTR(CONVERSION_BUFFER,1,LENGTH(RECORD_BUFFER));
4 END;
5 IF EBCDIC_DATA THEN DO;
5 CONVERSION_BUFFER = RECORD_BUFFER;
5 STS$VALUE = LIB$TRA_ASC_EBC(CONVERSION_BUFFER,CONVERSION_BUFFER);
L6 RECORD_BUFFER = SUBSTR(CONVERSION_BUFFER,1,LENGTH(RECORD_BUFFER));
6 END;
7 SUBSTR(BLOCK_BUFFER,BYTE_COUNT + 5,RECORD_SIZE - 4) = RECORD_BUFFER;
x7 BYTE_COUNT = BYTE_COUNT + RECORD_SIZE;
7 RECORD_COUNT = RECORD_COUNT + 1;
@8 READ FILE (VAX_FILE) INTO (RECORD_BUFFER);
8 IF ^EOF THEN
9 RECORD_LENGTH = LENGTH(RECORD_BUFFER) + 4;
l9 END;
9 RECORD_LENGTH = BYTE_COUNT;
4: IF REVERSE_BYTES THEN DO;
: SUBSTR(BLOCK_BUFFER,1,1) = SUBSTR(RECORD_DESCRIPTOR,2,1);
: SUBSTR(BLOCK_BUFFER,2,1) = SUBSTR(RECORD_DESCRIPTOR,1,1);
`; SUBSTR(BLOCK_BUFFER,3,2) = DESCRIPTOR_FILLER;
; END;
(< ELSE
< SUBSTR(BLOCK_BUFFER,1,4) = STRING(VARIABLE_LENGTH_CONTROL_WORD);
< END;
T=
= STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_WRITELBLK,
> IOSB,,,BLOCK_LOC,
> BYTE_COUNT,,,,);
> IF STS$VALUE ^= SS$_NORMAL THEN DO;
H? STS$VALUE = SYS$GETMSG(STS$VALUE,MSG_LENGTH,MSG_ERROR,,MSG_MISC_INFO);
? PUT EDIT('Tape writing error detected ---> ',MSG_ERROR,
@ 'Utility is terminated.')(SKIP(2),A,A,SKIP(2),A);
t@ STOP;
@ END;
',MSG_ERROR,
hB 'Utility is terminated.')(SKIP(2),A,A,SKIP(2),A);
B STOP;
0C END;
C BLOCK_COUNT=BLOCK_COUNT+1;
C
\D END; /* END DO WHILE(^EOF) */
D
$E CLOSE FILE (VAX_FILE);
E FREE BLOCK_BUFFER;
E FREE RECORD_BUFFER;
PF
F IF STANDARD_LABEL THEN DO;
G CALL WRITE_TAPE_MARK;
|G CALL WRITE_TRAILERS;
G END;
DH
H CALL WRITE_TAPE_MARK;
I
pI PUT EDIT(TRIM(CHAR(BLOCK_COUNT)),' Tape blocks written.',
I TRIM(CHAR(RECORD_COUNT)),' Records written.')
8J (SKIP,2 A);
J
K ANSWER=GETWORD('Do you want to write another tape file?: ','YES NO');
dK IF ANSWER='NO' THEN EOT='1'B;
K
,LEND;
L
LEND WRITE_FILES;
XM
d WRITE_VOLUME_HEADER: PROC;
,VOLUME_SERIAL_NO=GETCHAR('What is the volume serial identifier?: ',
6,'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789');
XVOLUME_HEADER=' ';
PUT STRING(VOLUME_HEADER) EDIT
('VOL1',VOLUME_SERIAL_NO,'0','WESTAT/VAX')
(A(4),A(6),A(1),X(30),A(10));
L
PUT EDIT('Tape volume header is:',VOLUME_HEADER)
(SKIP,A);
x
IF EBCDIC_DATA THEN
@ STS$VALUE=LIB$TRA_ASC_EBC(VOLUME_HEADER,VOLUME_HEADER);
STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_WRITELBLK,
IOSB,,,ADDR(VOLUME_HEADER),80,,,,);
l
IF IOSB.VALUE = SS$_NORMAL THEN
4 PUT EDIT('Header written')(SKIP,A);
ELSE DO;
PUT EDIT('Unable to write header. Check for write ring in tape.')
` (SKIP,A);
STS$VALUE = SYS$GETMSG(IOSB.VALUE,MSG_LENGTH,MSG_ERROR,,MSG_MISC_INFO);
(
PUT EDIT (MSG_ERROR,' ','Utility terminating due to errors encountered.')
(SKIP,A);
STOP;
T END;
END WRITE_VOLUME_HEADER;
d WRITE_HEADERS: PROC;
,HEADER_LABEL1=' ';
SUBSTR(HEADER_LABEL1,1,4)='HDR1';
SUBSTR(HEADER_LABEL1,5,17)=DATA_SET_ID;
XSUBSTR(HEADER_LABEL1,28,4) = '0000';
PIC_4=DEC(FILE_COUNT,4);
SUBSTR(HEADER_LABEL1,32,4)=PIC_4;
SUBSTR(HEADER_LABEL1,43,5)=CREATION_DATE;
SUBSTR(HEADER_LABEL1,49,5)='00000';
LSUBSTR(HEADER_LABEL1,54,7)='0000000';
PUT EDIT('First data set header is:',HEADER_LABEL1)
x (SKIP,A);
@TRAILER_LABEL1 = HEADER_LABEL1;
IF EBCDIC_DATA THEN
STS$VALUE=LIB$TRA_ASC_EBC(HEADER_LABEL1,HEADER_LABEL1);
lSTS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_WRITELBLK,
IOSB,,,ADDR(HEADER_LABEL1),80,,,,);
4
HEADER_LABEL2=' ';
SUBSTR(HEADER_LABEL2,1,4)='HDR2';
` IF VARIABLE_LENGTH THEN
SUBSTR(HEADER_LABEL2,5,1) = 'V';
(
ELSE
SUBSTR(HEADER_LABEL2,5,1) = 'F'; /* Record format = Fixed */
PIC_5=DEC(BLKSIZE,5);
T SUBSTR(HEADER_LABEL2,6,5)=PIC_5;
PIC_5=DEC(LRECL,5);
SUBSTR(HEADER_LABEL2,11,5)=PIC_5;
IF DENSITY = 800 THEN
SUBSTR(HEADER_LABEL2,16,1) = '2';
H
ELSE
SUBSTR(HEADER_LABEL2,16,1) = '3';
SUBSTR(HEADER_LABEL2,17,1)='0'; /* Data set position=No volume switch */
tSUBSTR(HEADER_LABEL2,18,17) = 'WESTAT /VAXCOPY';
IF ^VARIABLE_LENGTH & LRECL ^= BLKSIZE THEN
< SUBSTR(HEADER_LABEL2,39,1)='B'; /* B for Blocked */
IF VARIABLE_LENGTH & LRECL + 4 < BLKSIZE THEN
SUBSTR(HEADER_LABEL2,39,1) = 'B';
h
PUT EDIT('Second data set header is:',HEADER_LABEL2)
0 (SKIP,A);
TRAILER_LABEL2 = HEADER_LABEL2;
\IF EBCDIC_DATA THEN
STS$VALUE=LIB$TRA_ASC_EBC(HEADER_LABEL2,HEADER_LABEL2);
$STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_WRITELBLK,IOSB,,,
ADDR(HEADER_LABEL2),80,,,,);
PCALL WRITE_TAPE_MARK;
END WRITE_HEADERS;
d WRITE_TRAILERS: PROC;
,SUBSTR(TRAILER_LABEL1,1,4)='EOF1';
PIC_6=DEC(BLOCK_COUNT,6);
SUBSTR(TRAILER_LABEL1,55,6)=PIC_6;
X
PUT EDIT('First data set trailer is:',TRAILER_LABEL1)
(SKIP,A);
IF EBCDIC_DATA THEN
L STS$VALUE=LIB$TRA_ASC_EBC(TRAILER_LABEL1,TRAILER_LABEL1);
STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_WRITELBLK,
IOSB,,,ADDR(TRAILER_LABEL1),80,,,,);
x
SUBSTR(TRAILER_LABEL2,1,4)='EOF2';
@
PUT EDIT('Second data set trailer is:',TRAILER_LABEL2)
(SKIP,A);
l
IF EBCDIC_DATA THEN
4 STS$VALUE=LIB$TRA_ASC_EBC(TRAILER_LABEL2,TRAILER_LABEL2);
STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_WRITELBLK,IOSB,,,
ADDR(TRAILER_LABEL2),80,,,,);
`
END WRITE_TRAILERS;
d GET_DENSITY: PROC;
,DENSITY = 0;
STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_SENSEMODE,IOSB,,,,,,,,);
XSTRING(FLIP_FLOP_1) = SUBSTR(UNSPEC(IOSB.INFORMATION),9,4);
DO I = 1 TO 4;
FLIP_FLOP_2 (5 - I) = FLIP_FLOP_1 (I);
END;
I = BIN(STRING(FLIP_FLOP_2),31);
LIF I = MT$K_NRZI_800 THEN
DENSITY = 800;
ELSE
x IF I = MT$K_PE_1600 THEN
DENSITY = 1600;
@ ELSE
PUT EDIT('Tape density cannot be determined.',
IOSB.INFORMATION,UNSPEC(IOSB.INFORMATION))
l (SKIP,A,F(10),X,A);
4IF DENSITY ^= 0 THEN
PUT EDIT ('Tape density is ',TRIM(CHAR(DENSITY)),' BPI')(SKIP,3 A);
` END GET_DENSITY;
d READ_VOLUME_LABEL: PROC;
,VOLUME_HEADER=' ';
VOLUME_SERIAL_NO = ' ';
VOLUME_LABEL_FOUND = '0'B;
XSTS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_READLBLK,IOSB,,,
ADDR(VOLUME_HEADER),80,,,,);
IF IOSB.VALUE ^= SS$_NORMAL THEN
RETURN;
IF SUBSTR(VOLUME_HEADER,1,4) = 'VOL1' THEN DO;
L ASCII_DATA = '1'B;
VOLUME_LABEL_FOUND = '1'B;
END;
xELSE DO;
STS$VALUE=LIB$TRA_EBC_ASC(VOLUME_HEADER,VOLUME_HEADER);
@ IF SUBSTR(VOLUME_HEADER,1,4) = 'VOL1' THEN DO;
EBCDIC_DATA = '1'B;
VOLUME_LABEL_FOUND = '1'B;
l END;
END;
4
IF VOLUME_LABEL_FOUND THEN DO;
VOLUME_SERIAL_NO=SUBSTR(VOLUME_HEADER,5,6);
` PUT EDIT ('Volume serial number is ',VOLUME_SERIAL_NO)(SKIP,A,A);
PUT EDIT ('Owner information is ',SUBSTR(VOLUME_HEADER,42,10))(SKIP,A,A);
(
END;
END READ_VOLUME_LABEL;
d READ_HEADER_LABELS: PROC;
,HEADER_LABEL1=' ';
HEADER_LABEL2=' ';
XSTS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_READLBLK,IOSB,,,
ADDR(HEADER_LABEL1),80,,,,);
IF EBCDIC_DATA THEN
STS$VALUE=LIB$TRA_EBC_ASC(HEADER_LABEL1,HEADER_LABEL1);
IF SUBSTR(HEADER_LABEL1,1,4) = 'HDR1' THEN DO;
L DATA_SET_ID=SUBSTR(HEADER_LABEL1,5,17);
SEQUENCE_NUMBER=SUBSTR(HEADER_LABEL1,32,4);
CREATION_DATE=SUBSTR(HEADER_LABEL1,43,5);
xEND;
@STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_READLBLK,IOSB,,,
ADDR(HEADER_LABEL2),80,,,,);
IF EBCDIC_DATA THEN
l STS$VALUE=LIB$TRA_EBC_ASC(HEADER_LABEL2,HEADER_LABEL2);
4IF STANDARD_LABEL THEN DO;
BLKSIZE=FIXED(SUBSTR(HEADER_LABEL2,6,5),15);
LRECL=FIXED(SUBSTR(HEADER_LABEL2,11,5),15);
` RECORD_FORMAT = SUBSTR(HEADER_LABEL2,5,1);
IF RECORD_FORMAT = 'F' THEN
(
VARIABLE_LENGTH = '0'B;
ELSE
IF RECORD_FORMAT = 'V' THEN
T VARIABLE_LENGTH = '1'B;
ELSE DO;
PUT EDIT('Record format not F or V. Format read was ',
RECORD_FORMAT,'Variable format assumed.')
(SKIP(2),A,A,SKIP,A);
H
VARIABLE_LENGTH = '1'B;
END;
END;
t
SKIP_FILE_COUNT = 1;
<CALL SKIP_FILES;
END READ_HEADER_LABELS;
h
d TEST_STANDARD_LABEL: PROC;
,STANDARD_LABEL='0'B;
ASCII_DATA = '0'B;
EBCDIC_DATA = '0'B;
XCALL GET_DENSITY;
IF DENSITY = 0 THEN
RETURN;
CALL READ_VOLUME_LABEL;
IF ^VOLUME_LABEL_FOUND THEN DO;
L PUT EDIT ('Tape does not have a volume label.')(SKIP,A);
CALL REWIND_TAPE;
RETURN;
xEND;
CALL READ_HEADER_LABELS;
@
IF SUBSTR(VOLUME_HEADER,1,3)='VOL' &
SUBSTR(HEADER_LABEL1,1,4)='HDR1' &
l SUBSTR(HEADER_LABEL2,1,4)='HDR2' THEN DO;
BLKSIZE=FIXED(SUBSTR(HEADER_LABEL2,6,5),15);
4 LRECL=FIXED(SUBSTR(HEADER_LABEL2,11,5),15);
IF EBCDIC_DATA THEN
DATA_FORMAT = 'EBCDIC';
` ELSE
DATA_FORMAT = 'ASCII';
(
PUT EDIT('Tape appears to have IBM Standard labels.',
'Data format is ',TRIM(CHAR(DATA_FORMAT)),
'Name of first data set is ',DATA_SET_ID,
T 'Record size is ',TRIM(CHAR(LRECL)),
'Block size is ',TRIM(CHAR(BLKSIZE)))
(SKIP,A,6(SKIP,2 A));
ANSWER=GETWORD('Do you want to bypass label processing?: ',
'YES NO');
H
IF ANSWER='YES' THEN STANDARD_LABEL='0'B;
ELSE STANDARD_LABEL='1'B;
END;
tELSE PUT EDIT('Tape does not have IBM standard labels.')
(SKIP,A);
<
CALL REWIND_TAPE;
hEND TEST_STANDARD_LABEL;
d READ_TRAILER_LABELS: PROC;
, STS$VALUE = SYS$QIOW(,TAPE_CHANNEL,IO$_READLBLK,IOSB,,,
ADDR(TRAILER_LABEL1),80,,,,);
IF IOSB.VALUE ^= SS$_NORMAL THEN DO;
X STS$VALUE = SYS$GETMSG(IOSB.VALUE,MSG_LENGTH,MSG_ERROR,,MSG_MISC_INFO);
PUT EDIT ('Tape processing error occurred during trailer label processing',
MSG_ERROR,'Utility is terminated.')
(SKIP,A);
STOP;
L END;
IF EBCDIC_DATA THEN
STS$VALUE = LIB$TRA_EBC_ASC(TRAILER_LABEL1,TRAILER_LABEL1);
x IF SUBSTR(TRAILER_LABEL1,1,4) = 'EOF1' THEN DO;
TRAILER_BLOCK_COUNT = FIXED(SUBSTR(TRAILER_LABEL1,55,6),31);
@ IF TRAILER_BLOCK_COUNT ^= BLOCK_COUNT THEN
PUT EDIT ('* WARNING * - Block count discrepancy encountered.',
'Block count from trailer label is ',TRIM(CHAR(TRAILER_BLOCK_COUNT)),
l 'Utility block count is ',TRIM(CHAR(BLOCK_COUNT)))
(SKIP,A,2(SKIP,A));
4 END;
ELSE
PUT EDIT ('Expected trailer label 1 not found.','Data read was ---> ',
` trailer_label1)(skip,a,skip,a,a);
SKIP_FILE_COUNT = 1;
(
CALL SKIP_FILES;
END READ_TRAILER_LABELS;
T
d SKIP_FILES: PROC;
, STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_SKIPFILE,
IOSB,,,SKIP_FILE_COUNT,,,,,);
IF IOSB.VALUE ^= SS$_NORMAL THEN DO;
X STS$VALUE = SYS$GETMSG(IOSB.VALUE,MSG_LENGTH,MSG_ERROR,,MSG_MISC_INFO);
PUT EDIT ('Tape processing error detected during file skipping:',
msg_error,'Utility is terminated.')(skip(2),a);
STOP;
END;
L
END SKIP_FILES;
x
WRITE_TAPE_MARK: PROC;
@
STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_WRITEOF,IOSB,,,,,,,,);
IF IOSB.VALUE ^= SS$_NORMAL THEN DO;
l STS$VALUE = SYS$GETMSG(IOSB.VALUE,MSG_LENGTH,MSG_ERROR,,MSG_MISC_INFO);
PUT EDIT ('Tape processing error detected during writing EOF.',
4 msg_error,'Utility is terminated.')(skip(2),a);
STOP;
END;
`
END WRITE_TAPE_MARK;
(
REWIND_TAPE: PROC;
T
STS$VALUE=SYS$QIOW(,TAPE_CHANNEL,IO$_REWIND,IOSB,,,,,,,,);
END REWIND_TAPE;
H
END IBM;