Trailing-Edge
-
PDP-10 Archives
-
RMS_V2_840216
-
uetp/lib/rmtcbi.cbl
There are 4 other files named rmtcbi.cbl in the archive. Click here to see a list.
ID DIVISION.
PROGRAM-ID. RMTCBI.
* RMS TEST FOR COBOL.
* THIS IS A SIMPLE TEST OF THE VARIOUS RMS FUNCTIONS NEEDED FOR COBOL.
* IT TRIES TO TEST A LITTLE OF EVERYTHING FOR RMS INDEXED FILES, EXCEPT
* FOR APPLY BASIC-LOCKING.
*
* COPYRIGHT (c) 1984 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
*
ENVIRONMENT DIVISION.
I-O SECTION.
FILE-CONTROL.
SELECT FILE-1 ASSIGN TO DSK;
ORGANIZATION IS RMS INDEXED;
ACCESS MODE IS DYNAMIC;
RECORD KEY IS RK1;
ALTERNATE RECORD KEY IS AK1-1;
ALTERNATE RECORD KEY IS AK1-2 WITH DUPLICATES.
SELECT FILE-2 ASSIGN TO DSK;
ORGANIZATION IS RMS INDEXED;
ACCESS MODE IS SEQUENTIAL;
RECORD KEY IS RK2;
ALTERNATE RECORD KEY IS AK2-1;
ALTERNATE RECORD KEY IS AK2-2.
DATA DIVISION.
FILE SECTION.
FD FILE-1 VALUE OF ID IS "RMTF1 RMI".
01 REC-1 DISPLAY-7.
02 RK1 PIC X(5).
02 AK1-1 PIC X(5).
02 AK1-2 PIC 9(5).
02 FILLER PIC X(10).
FD FILE-2 VALUE OF ID IS "RMTF2 RMI".
01 REC-2.
02 FILLER PIC X(5).
02 RK2 PIC X(5).
02 AK2-1 PIC X(5).
02 AK2-2 PIC 9(5).
02 FILLER PIC X(5).
WORKING-STORAGE SECTION.
01 F1R1 PIC X(25) VALUE "AAAAADDDDD11111XXXXXXXXXX".
01 F1R2 PIC X(25) VALUE "BBBBBEEEEE11111XXXXXXXXXX".
01 F1R3 PIC X(25) VALUE "CCCCCFFFFF22222XXXXXXXXXX".
01 F1R4 PIC X(25) VALUE "DDDDDGGGGG22222XXXXXXXXXX".
01 F1R5 PIC X(25) VALUE "EEEEEHHHHH11111YYYYYYYYYY".
01 F2R1 PIC X(25) VALUE "XXXXXAAAAADDDDD55555XXXXX".
01 F2R2 PIC X(25) VALUE "YYYYYBBBBBEEEEE66666XYXYX".
01 F2R3 PIC X(25) VALUE "XXXXYCCCCCFFFFF77777XXYXX".
01 F2R4 PIC X(25) VALUE "XXYYXDDDDDGGGGG88888YXYXY".
01 F2R5 PIC X(25) VALUE "YYXXYEEEEEHHHHH99999YYYYX".
PROCEDURE DIVISION.
STARTER.
OPEN OUTPUT FILE-1.
OPEN OUTPUT FILE-2.
S-1.
WRITE REC-1 FROM F1R1
INVALID KEY DISPLAY "?S-1".
S-2.
WRITE REC-1 FROM F1R2
INVALID KEY DISPLAY "?S-2".
S-3.
WRITE REC-1 FROM F1R3
INVALID KEY DISPLAY "?S-3".
S-4.
WRITE REC-1 FROM F1R4
INVALID KEY DISPLAY "?S-4".
S-5.
WRITE REC-1 FROM F1R5
INVALID KEY DISPLAY "?S-5".
S-6.
CLOSE FILE-1.
OPEN INPUT FILE-1.
S-7.
WRITE REC-2 FROM F2R1
INVALID KEY DISPLAY "?S-7".
S-8.
WRITE REC-2 FROM F2R2
INVALID KEY DISPLAY "?S-8".
S-9.
WRITE REC-2 FROM F2R3
INVALID KEY DISPLAY "?S-9".
S-10.
WRITE REC-2 FROM F2R4
INVALID KEY DISPLAY "?S-10".
S-11.
WRITE REC-2 FROM F2R5
INVALID KEY DISPLAY "?S-11".
S-12.
CLOSE FILE-2.
OPEN INPUT FILE-2.
S-13.
MOVE F1R1 TO REC-1.
READ FILE-1 INVALID KEY DISPLAY "?S-13".
S-14.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-14".
S-15.
IF REC-1 NOT = F1R2 DISPLAY "?S-15".
S-16.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-16".
S-17.
IF REC-1 NOT = F1R3 DISPLAY "?S-17".
S-18.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-18".
S-19.
IF REC-1 NOT = F1R4 DISPLAY "?S-19".
S-20.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-20".
S-21.
IF REC-1 NOT = F1R5 DISPLAY "?S-21".
S-22.
READ FILE-1 NEXT RECORD AT END GO TO S-23.
DISPLAY "?S-22".
S-23.
CLOSE FILE-1.
OPEN I-O FILE-1.
S-24.
MOVE F1R4 TO REC-1.
START FILE-1 KEY = RK1 INVALID KEY DISPLAY "?S-24".
S-25.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-25".
S-25A.
IF REC-1 NOT = F1R4 DISPLAY "?S-25A".
S-26.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-26".
S-27.
MOVE F1R4 TO REC-1.
START FILE-1 KEY NOT LESS RK1 INVALID KEY DISPLAY "?S-27".
S-28.
READ FILE-1 NEXT AT END DISPLAY "?S-28".
S-29.
IF REC-1 NOT = F1R4 DISPLAY "?S-29".
S-30.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-30".
S-31.
MOVE F1R4 TO REC-1.
START FILE-1 KEY GREATER RK1 INVALID KEY DISPLAY "?S-31".
S-32.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-32".
S-33.
IF REC-1 NOT = F1R5 DISPLAY "?S-33".
S-34.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-34".
S-35.
IF REC-2 NOT = F2R1 DISPLAY "?S-35".
S-36.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-36".
S-37.
IF REC-2 NOT = F2R2 DISPLAY "?S-37".
S-38.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-38".
S-39.
IF REC-2 NOT = F2R3 DISPLAY "?S-39".
S-40.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-40".
S-41.
IF REC-2 NOT = F2R4 DISPLAY "?S-41".
S-42.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-42".
S-43.
IF REC-2 NOT = F2R5 DISPLAY "?S-43".
S-44.
READ FILE-2 NEXT RECORD AT END GO TO S-45.
DISPLAY "?S-44".
S-45.
MOVE F1R3 TO REC-1.
DELETE FILE-1 INVALID KEY DISPLAY "?S-45".
S-46.
MOVE F1R4 TO REC-1.
MOVE 00000 TO AK1-2.
REWRITE REC-1 INVALID KEY DISPLAY "?S-46".
S-47.
MOVE 00000 TO AK1-2.
START FILE-1 KEY = AK1-2 INVALID KEY DISPLAY "?S-47".
S-48.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-48".
S-48A.
IF AK1-2 NOT = 00000 DISPLAY "?S-48A".
S-49.
MOVE 22222 TO AK1-2.
IF REC-1 NOT = F1R4 DISPLAY "?S-49".
S-50.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-50".
S-51.
IF REC-1 NOT = F1R1 DISPLAY "?S-51".
S-52.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-52".
S-53.
IF REC-1 NOT = F1R2 DISPLAY "?S-53".
S-54.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-54".
S-55.
IF RK1 NOT = "EEEEE" DISPLAY "?S-55".
S-56.
MOVE "XXXXX" TO RK1.
READ FILE-1 INVALID KEY GO TO S-57.
DISPLAY "?S-56".
S-57.
MOVE F1R5 TO REC-1.
READ FILE-1 INVALID KEY DISPLAY "?S-57".
S-58.
MOVE "DDDDD" TO AK1-1.
REWRITE REC-1 INVALID KEY GO TO S-59.
DISPLAY "?S-58".
S-59.
CLOSE FILE-1, FILE-2.
S-60.
OPEN I-O FILE-1 FOR ANY OTHERS ANY
UNAVAILABLE DISPLAY "?S-60"
GO TO S-61.
CLOSE FILE-1.
S-61.
T-DONE.
DISPLAY "[RMS/COBOL - Completed test for Indexed Files]".
STOP RUN.