Google
 

Trailing-Edge - PDP-10 Archives - cobol12c - keyrms.cbl
There are 4 other files named keyrms.cbl in the archive. Click here to see a list.
ID DIVISION.
PROGRAM-ID. KEYRMS - RMS/COBOL-74 PROGRAM.

**************************************************************
*                                                            *
*  This program demonstrates the following:                  *
*                                                            *
*    1. The use of RMS with COBOL in order to use RMS        *
*       indexed files.                                       *
*                                                            *
*    2. The use of a DECLARATIVES procedure to trap          *
*       an error (such as error number 508 for File          *
*       not found).                                          *
*                                                            *
*  This program can be keyed in and run to allow you to      *
*  become familiar with using files with more than one key.  *
*                                                            *
**************************************************************

ENVIRONMENT DIVISION.
I-O SECTION.
FILE-CONTROL.

**************************************************************
*                                                            *
*  To specify that the file is an RMS indexed file, you      *
*  can either specify "ORGANIZATION IS RMS INDEXED" or       *
*  "ALTERNATE RECORD KEY IS" or both.                        *
*                                                            *
*  This example indicates to the compiler that you want      *
*  an RMS indexed file.                                      *
*                                                            *
**************************************************************

	SELECT	RMS-INDEX-FILE ASSIGN TO DSK
		ORGANIZATION IS RMS INDEXED
		ACCESS IS DYNAMIC
		RECORDING MODE IS SIXBIT
		FILE STATUS IS FILE-STATUS-1, FILE-STATUS-2,
			IGNORE-FLAG
		RECORD KEY IS EMPLOYEE-NAME
		ALTERNATE RECORD KEY IS EMPLOYEE-NUMBER
			WITH DUPLICATES.

DATA DIVISION.
FILE SECTION.
FD	RMS-INDEX-FILE VALUE OF ID IS "RMSKY RMS".
01	RMS-INDEX-RECORD.
	02	EMPLOYEE-NAME PIC X(10).
	02	FILLER PIC X.
	02	EMPLOYEE-NUMBER PIC 9(6).
WORKING-STORAGE SECTION.

**************************************************************
*                                                            *
*  Establish the File Status errors you want to trap. RMS    *
*  File Status errors numbers are in the range from 500      *
*  to 550.                                                   *
*                                                            *
*  Refer to Chapter 3 for a complete description of RMS      *
*  File Status errors that can be trapped with the USE       *
*  statement.                                                *
*                                                            *
**************************************************************

01	ERR-FILE-NOT-FOUND INDEX VALUE 508.

01	FILE-STATUS-1 PIC 9(2).
01	FILE-STATUS-2 PIC 9(10).
01	FILE-STATUS-2-R REDEFINES FILE-STATUS-2.
	02	FILLER PIC X(7).
	02	FILE-STATUS-2-NUM PIC 9(3).
01	IGNORE-FLAG USAGE INDEX.

**************************************************************
*                                                            *
*  Define the commands that are used in this program to      *
*  work with RMS indexed files.                              *
*                                                            *
**************************************************************

01	COMMAND-WORD.
	02	COMMAND-LETTER PIC X.
		88	COMMAND-A VALUE "A".
		88	COMMAND-C VALUE "C".
		88	COMMAND-D VALUE "D".
		88	COMMAND-H VALUE "H".
		88	COMMAND-P VALUE "P".
		88	COMMAND-R VALUE "R".
		88	COMMAND-T VALUE "T".
		88	COMMAND-U VALUE "U".
		88	COMMAND-W VALUE "W".
	02	COMMAND-LET-2 PIC X.
		88	COMMAND-L2-R VALUE "R".
		88	COMMAND-L2-S VALUE "S".
PROCEDURE DIVISION.

DECLARATIVES.
DECLARE-ERROR SECTION.
	USE AFTER STANDARD ERROR PROCEDURE ON RMS-INDEX-FILE.

**************************************************************
*                                                            *
*  If the program gets an I/O error for RMS-INDEX-FILE,      *
*  this section will be executed. The file status items      *
*  will have been set by LIBOL.                              *
*                                                            *
*  If the error code from LIBOL is "File not found", a       *
*  flag is set. If the error code is not "File not found",   *
*  this procedure does not set the "IGNORE" flag and LIBOL   *
*  aborts this program (as if there were no USE procedure    *
*  at all).                                                  *
*                                                            *
**************************************************************

DECLARE1-1.
	IF FILE-STATUS-2-NUM NOT = ERR-FILE-NOT-FOUND
		GO TO DECLARE1-EXIT.

**************************************************************
*                                                            *
*  The "File not found" error has occurred. Set the file     *
*  status item "IGNORE-FLAG" to ignore the error, and to     *
*  return to the program.                                    *
*                                                            *
**************************************************************

	SET IGNORE-FLAG TO 1.

DECLARE1-EXIT.
	EXIT.
END DECLARATIVES.
BEGIN-RMS-PROGRAM.

	DISPLAY "[COBOL-RMS demonstration program]".

OPEN-RMS-FILE.

**************************************************************
*                                                            *
*  Attempt to open the file for I/O. If the file does not    *
*  exist, the error procedure traps the open error and       *
*  sets the file status item "IGNORE-FLAG" to 1.             *
*                                                            *
**************************************************************

	OPEN I-O RMS-INDEX-FILE.
	IF IGNORE-FLAG NOT = 0
		DISPLAY "[File not found-- creating empty file]"
		OPEN OUTPUT RMS-INDEX-FILE
		CLOSE RMS-INDEX-FILE
		OPEN I-O RMS-INDEX-FILE.

DISPLAY-OPEN-FOR-IO.

	DISPLAY "[File RMSKY.RMS open for I/O]".

**************************************************************
*                                                            *
*  This procedure displays the commands that can be used.    *
*                                                            *
**************************************************************

GET-HELP.

	DISPLAY SPACE.
	DISPLAY "Type command, one of the following:".
	DISPLAY "C = Close file and exit".
	DISPLAY "D = Delete a record".
	DISPLAY "RR = Do a read with random access".
	DISPLAY "RS = Do a read with sequential access".
	DISPLAY "W = Write a new record".
	DISPLAY "U = Update a record (will do a rewrite)".
	DISPLAY "T = Type all records in the file".
	DISPLAY "H = Type this list of commands".
**************************************************************
*                                                            *
*  Enter a command to close, delete, read, write, update,    *
*  or type an RMS record. Enter "H" to get help.             *
*                                                            *
**************************************************************

GET-COMMAND.

	DISPLAY SPACE.
	DISPLAY "COMMAND> " WITH NO ADVANCING.
	ACCEPT COMMAND-WORD.
	IF COMMAND-LETTER = SPACE GO TO GET-COMMAND.
	IF COMMAND-C GO TO CLOSE-RMS-FILE.
	IF COMMAND-D GO TO DELETE-RMS-RECORD.
	IF COMMAND-R GO TO READ-RMS-RECORD.
	IF COMMAND-W GO TO WRITE-RMS-RECORD.
	IF COMMAND-U GO TO UPDATE-RMS-RECORD.
	IF COMMAND-T GO TO TYPE-RMS-RECORD.
	IF COMMAND-H GO TO GET-HELP.

INVALID-COMMAND.

	DISPLAY "?Invalid command, type 'H' for help"
		GO TO GET-COMMAND.

**************************************************************
*                                                            *
*  The C command closes the RMS file and exits from the      *
*  program.                                                  *
*                                                            *
**************************************************************

CLOSE-RMS-FILE.

	CLOSE RMS-INDEX-FILE.
	STOP RUN.

**************************************************************
*                                                            *
*  The D command deletes an RMS record from the file.        *
*                                                            *
**************************************************************

DELETE-RMS-RECORD.

	PERFORM ACCEPT-RECORD-KEY.
	DELETE RMS-INDEX-FILE INVALID KEY
		DISPLAY "?Can't delete record: "
			WITH NO ADVANCING
		PERFORM TYPE-FILE-STATUS
		GO TO GET-COMMAND.
	DISPLAY "[Record deleted]".
	GO TO GET-COMMAND.
**************************************************************
*                                                            *
*  The U command updates an RMS record in the file.          *
*                                                            *
**************************************************************

UPDATE-RMS-RECORD.

	PERFORM ACCEPT-RECORD-KEY.
	READ RMS-INDEX-FILE INVALID KEY
		DISPLAY "?Can't read record: "
			WITH NO ADVANCING
		PERFORM TYPE-FILE-STATUS
		GO TO GET-COMMAND.
	DISPLAY "[Employee number is ",EMPLOYEE-NUMBER,"]".
	PERFORM ACCEPT-ALTERNATE-KEY.
	REWRITE RMS-INDEX-RECORD INVALID KEY
		DISPLAY "?Can't rewrite record: "
			WITH NO ADVANCING
		PERFORM TYPE-FILE-STATUS
		GO TO GET-COMMAND.
	DISPLAY "[Record rewritten]".
	GO TO GET-COMMAND.

**************************************************************
*                                                            *
*  The W command writes a new RMS record in the file.        *
*                                                            *
**************************************************************

WRITE-RMS-RECORD.

	PERFORM ACCEPT-RECORD-KEY.
	PERFORM ACCEPT-ALTERNATE-KEY.
	WRITE RMS-INDEX-RECORD INVALID KEY
		DISPLAY "?Can't write record: "
			WITH NO ADVANCING
		PERFORM TYPE-FILE-STATUS
		GO TO GET-COMMAND.
	DISPLAY "[Record written]".
	GO TO GET-COMMAND.
**************************************************************
*                                                            *
*  The following procedures allow you to either read RMS     *
*  records randomly with the "RR" command or read RMS        *
*  records sequentially with the "RS" command.               *
*                                                            *
**************************************************************

READ-RMS-RECORD.

	IF COMMAND-L2-R GO TO READ-RANDOM-RECORD.
	IF COMMAND-L2-S GO TO READ-SEQUENTIAL.
	GO TO INVALID-COMMAND.

READ-RANDOM-RECORD.

	DISPLAY "Which key? (P = primary, A = alternate): "
			WITH NO ADVANCING.
	ACCEPT COMMAND-LETTER.
	IF COMMAND-P GO TO ACCEPT-PRIMARY-KEY.
	IF COMMAND-A GO TO ACCEPT-SECONDARY-KEY.
	GO TO READ-RANDOM-RECORD.

ACCEPT-PRIMARY-KEY.

	PERFORM ACCEPT-RECORD-KEY.
	READ RMS-INDEX-FILE KEY IS EMPLOYEE-NAME INVALID KEY
		DISPLAY "?Can't read record: "
		PERFORM TYPE-FILE-STATUS
		GO TO GET-COMMAND.
	GO TO DISPLAY-RMS-RECORD.

ACCEPT-SECONDARY-KEY.

	PERFORM ACCEPT-ALTERNATE-KEY.
	READ RMS-INDEX-FILE KEY IS EMPLOYEE-NUMBER
			INVALID KEY
		DISPLAY "?Can't read record: "
		PERFORM TYPE-FILE-STATUS
		GO TO GET-COMMAND.
	GO TO DISPLAY-RMS-RECORD.

READ-SEQUENTIAL.

	READ RMS-INDEX-FILE NEXT RECORD AT END
		DISPLAY "?Can't read next record: "
		PERFORM TYPE-FILE-STATUS
		GO TO GET-COMMAND.
DISPLAY-RMS-RECORD.

	DISPLAY "[Record is:  !" WITH NO ADVANCING.
	DISPLAY RMS-INDEX-RECORD, "!]".
	GO TO GET-COMMAND.

**************************************************************
*                                                            *
*  The T command types all the records in the RMS file.      *
*  This command allows you the option to type the RMS file   *
*  in the order of the primary key or in the order of the    *
*  alternate key.                                            *
*                                                            *
*  The START statement is used here because of the current   *
*  positioning in the file. The current position may or      *
*  may not be the first record in the file.                  *
*                                                            *
**************************************************************

TYPE-RMS-RECORD.

	DISPLAY "In order of which key? " WITH NO ADVANCING.
	DISPLAY "(P = primary, A = alternate): "
		WITH NO ADVANCING.
	ACCEPT COMMAND-LETTER.
	IF COMMAND-P GO TO TYPE-START-PRIMARY.
	IF COMMAND-A GO TO TYPE-START-ALTERNATE.
	GO TO TYPE-RMS-RECORD.

TYPE-START-PRIMARY.

	MOVE LOW-VALUES TO EMPLOYEE-NAME.
	START RMS-INDEX-FILE KEY NOT LESS THAN EMPLOYEE-NAME
		INVALID KEY GO TO TYPE-RMS-RECORD-IK.
	GO TO TYPE-RMS-RECORD-R.

TYPE-START-ALTERNATE.

	MOVE LOW-VALUES TO EMPLOYEE-NUMBER
	START RMS-INDEX-FILE KEY NOT LESS THAN EMPLOYEE-NUMBER
		INVALID KEY GO TO TYPE-RMS-RECORD-IK.
	GO TO TYPE-RMS-RECORD-R.

TYPE-RMS-RECORD-R.

	READ RMS-INDEX-FILE NEXT RECORD AT END GO TO GET-COMMAND.
	DISPLAY RMS-INDEX-RECORD.
	GO TO TYPE-RMS-RECORD-R.

TYPE-RMS-RECORD-IK.

	DISPLAY "% Can't start reading file: " WITH NO ADVANCING.
	PERFORM TYPE-FILE-STATUS.
	GO TO GET-COMMAND.
**************************************************************
*                                                            *
*  This subroutine accepts the primary record key for        *
*  a random read.                                            *
*                                                            *
**************************************************************

ACCEPT-RECORD-KEY SECTION.

ACC-REC-KEY.

	DISPLAY "Type employee name X(10): "
			WITH NO ADVANCING.
	ACCEPT EMPLOYEE-NAME.

ACC-REC-KEY-EXIT.
	EXIT.

**************************************************************
*                                                            *
*  This subroutine accepts the alternate record key for a    *
*  random read.                                              *
*                                                            *
*  RMS allows up to 255 alternate record keys. Each key      *
*  can have up to 255 characters.                            *
*                                                            *
**************************************************************

ACCEPT-ALTERNATE-KEY SECTION.

ACC-ALT-KEY.
	DISPLAY "Type employee number 9(6): "
			WITH NO ADVANCING.
	ACCEPT EMPLOYEE-NUMBER.

ACC-ALT-KEY-EXIT.
	EXIT.
**************************************************************
*                                                            *
*  This subroutine types the file status. The file status    *
*  is contained in "FILE-STATUS-1".                          *
*                                                            *
**************************************************************

TYPE-FILE-STATUS SECTION.

TYPE-FILE-STATUS-1.
	DISPLAY "File status = ",FILE-STATUS-1,": "
			WITH NO ADVANCING.

	IF FILE-STATUS-1 = 0
		DISPLAY "Sucessful completion"
		GO TO TYPE-FILE-STATUS-EXIT.

	IF FILE-STATUS-1 = 23
		DISPLAY "Invalid key, record not found"
		GO TO TYPE-FILE-STATUS-EXIT.

	IF FILE-STATUS-1 = 30
		DISPLAY "Permanent error"
		GO TO TYPE-FILE-STATUS-EXIT.

	IF FILE-STATUS-1 = 22
		DISPLAY "Duplicate key"
		GO TO TYPE-FILE-STATUS-EXIT.

	IF FILE-STATUS-1 = 10
		DISPLAY "AT END, no next logical record"
		GO TO TYPE-FILE-STATUS-EXIT.

	DISPLAY "%% Unexpected error %%".

TYPE-FILE-STATUS-EXIT.
	EXIT.