PDP-10 Archive: traffic/demonstration/filepr.cbl from BB-5372D-BM

Trailing-Edge - PDP-10 Archives - BB-5372D-BM - traffic/demonstration/filepr.cbl
There is 1 other file named filepr.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID. FILEPR.
*
*  THIS PROGRAM PERFORMS ALL THE FILE PROCESSING FUNCTIONS WHICH
*  ARE REQUIRED BY THE TERMINAL INTERACTION PROGRAMS (ITERM).
*
*  FUNCTIONS WHICH MAY BE REQUESTED OF THIS PROGRAM ARE:
*    ADD     (1) - DEFINE A NEW ENTRY IN THE FILE
*    EXAMINE (2) - RETURN INFORMATION WHICH EXISTS IN THE FILE
*
*  ACTION CODES WHICH MAY BE RETURNED BY THIS PROGRAM ARE:
*    0 - FUNCTION PERFORMED SUCCESSFULLY
*    1 - INVALID FUNCTION REQUESTED
*    2 - KEY ALREADY EXISTS IN THE FILE
*    3 - KEY DOES NOT EXIST IN THE FILE
*
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
    SELECT DATA-FILE  ASSIGN TO DSK
    ACCESS IS INDEXED
    SYMBOLIC KEY IS IPCF-KEY
    RECORD KEY IS FILE-KEY.
DATA DIVISION.
FILE SECTION.
FD  DATA-FILE
    BLOCK CONTAINS 1 RECORDS
    VALUE OF IDENTIFICATION IS "DTFILEIDX".
*INDEX FILE IS BLOCKED 42
01  FILE-RECORD  USAGE DISPLAY-7.
    02 FILE-KEY  PIC X(5).
    02 FILE-DATA PIC X(50).
WORKING-STORAGE SECTION.
77  ERROR-CODE PIC S9(10) COMP.
77  HOLD-ERROR PIC S9(10) COMP.
77  WAIT-CODE PIC S9(10) COMP.
77  RESUME-COND PIC S9(10) COMP.
77  I PIC S9(10) COMP.
77  READ-COUNT  PIC S9(10) COMP VALUE 0.
77  WRITE-COUNT PIC S9(10) COMP VALUE 0.
77  OTHER-INDEX PIC S9(10) COMP.
77  MY-ID PIC X(14) VALUE "FILE-PROCESSOR".
77  TERM-MSG PIC X(7) USAGE DISPLAY-7.
01  IPCF-ROUTINE-TABLE  USAGE DISPLAY-7.
    02  IPCF-ROUTINE-NAME PIC X(6) OCCURS 8 TIMES
                                   INDEXED BY IPCF-ROUTINE-INDEX.
01  IPCF-ROUTINE-INDEXES.
    02  IPCRID-INDEX PIC S9(10) COMP VALUE 1.
    02  IPDLID-INDEX PIC S9(10) COMP VALUE 2.
    02  IPCRDX-INDEX PIC S9(10) COMP VALUE 3.
    02  IPDLDX-INDEX PIC S9(10) COMP VALUE 4.
    02  IPSEND-INDEX PIC S9(10) COMP VALUE 5.
    02  IPRECV-INDEX PIC S9(10) COMP VALUE 6.
    02  IPWAIT-INDEX PIC S9(10) COMP VALUE 7.
    02  IPRUNI-INDEX PIC S9(10) COMP VALUE 8.
*
*  DEFINE EXTERNAL PROGRAM INTERFACE
*
01  FILE-PROCESSOR-INFO  USAGE DISPLAY-7.
    02  FILE-RETURN-OK        PIC 99 VALUE 00.
    02  FILE-RETURN-INVALID   PIC 99 VALUE 01.
    02  FILE-RETURN-DUPLICATE PIC 99 VALUE 02.
    02  FILE-RETURN-NONE      PIC 99 VALUE 03.
    02  FILE-FUNCTION         PIC 99.
        88  FILE-ADD        VALUE 01.
        88  FILE-EXAMINE    VALUE 02.
01  IPCF-MESSAGE  USAGE DISPLAY-7.
    02  IPCF-CODE PIC 99.
    02  IPCF-KEY PIC X(5).
    02  IPCF-DATA PIC X(50).
    66  IPCF-RECORD RENAMES IPCF-KEY THRU IPCF-DATA.
PROCEDURE DIVISION.
START.
    MOVE "IPCRIDIPDLIDIPCRDXIPDLDXIPSENDIPRECVIPWAITIPRUNI" TO
                                  IPCF-ROUTINE-TABLE.
*
*  LET MY IDENTIFICATION BE KNOWN SO THAT THE TERMINAL INTERACTION
*  PROGRAMS CAN SEND MESSAGES TO ME.
*
	DISPLAY "THIS PROGRAM WILL HANDLE FILE PROCESSING ".
	DISPLAY "FOR REQUESTS FROM INDEPENDENT PROGRAMS. ".
	DISPLAY "IT IS A SAMPLE ONLY".
CREATE-MY-ID.
    MOVE IPCRID-INDEX TO IPCF-ROUTINE-INDEX.
    ENTER MACRO IPCRID USING MY-ID,ERROR-CODE.
    IF ERROR-CODE NOT = 0
        PERFORM DISPLAY-IPCF-ERROR
        STOP RUN.
    OPEN I-O  DATA-FILE.
    DISPLAY " FILE PROCESSOR INITIALIZED".
    DISPLAY " ".
*
*  MAIN PROGRAM WHICH WAITS FOR IPCF OR TERMINAL INPUT, PROCESSES THAT
*  INPUT, AND WAITS FOR NEXT EVENT.
*
MAIN-LOOP.
    SET WAIT-CODE TO ZERO.
    SET RESUME-COND TO 3.
    PERFORM WAIT-FOR-SOMETHING.
    IF WAIT-CODE = 1
        PERFORM TERM-INPUT THRU TERM-INPUT-EXIT
        GO TO MAIN-LOOP.
    PERFORM IPCF-INPUT THRU IPCF-INPUT-EXIT.
    GO TO MAIN-LOOP.
*
*  PROCESS TERMINAL INPUT
*
TERM-INPUT.
    ACCEPT TERM-MSG.
    IF TERM-MSG = "EXIT" OR "E"
        GO TO TERMINATE-GRACEFULLY.
    IF TERM-MSG = "HELP" OR "H"
        PERFORM HELP-THAT-USER
        GO TO TERM-INPUT-EXIT.
    IF TERM-MSG = "STATUS" OR "S"
        PERFORM DISPLAY-CURRENT-STATUS
        GO TO TERM-INPUT-EXIT.
    DISPLAY "? ILLEGAL COMMAND".
TERM-INPUT-EXIT.
    EXIT.
*
*  PROCESS IPCF MESSAGES
*
IPCF-INPUT.
    MOVE IPRECV-INDEX TO IPCF-ROUTINE-INDEX.
    ENTER MACRO IPRECV USING IPCF-MESSAGE, OTHER-INDEX, ERROR-CODE.
    IF ERROR-CODE NOT = 0
        PERFORM DISPLAY-IPCF-ERROR
        GO TO IPCF-INPUT-EXIT.
    MOVE IPCF-CODE TO FILE-FUNCTION.
    MOVE FILE-RETURN-OK TO IPCF-CODE.
    IF FILE-ADD
        PERFORM NEW-FILE-RECORD
        GO TO IPCF-INPUT-1.
    IF FILE-EXAMINE
        PERFORM READ-FILE-RECORD
        GO TO IPCF-INPUT-1.
    MOVE FILE-RETURN-INVALID TO IPCF-CODE.
IPCF-INPUT-1.
    PERFORM IPCF-SEND.
*  SINCE INDEX VALUE DOESN'T MEAN ANYTHING TO US, RELEASE IT.
    MOVE IPDLDX-INDEX TO IPCF-ROUTINE-INDEX.
    ENTER MACRO IPDLDX USING OTHER-INDEX, ERROR-CODE.
    IF ERROR-CODE NOT = 0
        PERFORM DISPLAY-IPCF-ERROR.
IPCF-INPUT-EXIT.
    EXIT.
*
*  SEND RECORD IPCF-MESSAGE AS AN IPCF MESSAGE
*
IPCF-SEND.
    SET ERROR-CODE TO -1.
    PERFORM IPCF-SEND-1 VARYING I FROM 1 BY 1
        UNTIL I > 5  OR  ERROR-CODE = 0.
    MOVE IPSEND-INDEX TO IPCF-ROUTINE-INDEX.
    IF ERROR-CODE NOT = 0
        PERFORM DISPLAY-IPCF-ERROR.
IPCF-SEND-1.
    ENTER MACRO IPSEND USING IPCF-MESSAGE, OTHER-INDEX,
                                               ERROR-CODE.
*  IF CAPACITY EXCEEDED, WAIT BEFORE RETRYING.
    IF ERROR-CODE = 12 OR 13 OR 14
        MOVE ERROR-CODE TO HOLD-ERROR
        SET WAIT-CODE TO 3000
        SET RESUME-COND TO 0
        PERFORM WAIT-FOR-SOMETHING
        MOVE HOLD-ERROR TO ERROR-CODE.
*
*  WAIT FOR A SIGNIFICANT EVENT
*
WAIT-FOR-SOMETHING.
    MOVE IPWAIT-INDEX TO IPCF-ROUTINE-INDEX.
    ENTER MACRO IPWAIT USING WAIT-CODE, RESUME-COND, ERROR-CODE.
    IF ERROR-CODE NOT = 0
        PERFORM DISPLAY-IPCF-ERROR
        GO TO TERMINATE-GRACEFULLY.
*
*  DISPLAY IPCF ERROR CODE AND ROUTINE WHICH WAS CALLED
*
DISPLAY-IPCF-ERROR.
    DISPLAY "  IPCF ERROR " ERROR-CODE " FROM ROUTINE "
            IPCF-ROUTINE-NAME (IPCF-ROUTINE-INDEX).
*
*  TERMINATE PROCESSING
*
TERMINATE-GRACEFULLY.
    CLOSE DATA-FILE
    PERFORM DISPLAY-CURRENT-STATUS
    STOP RUN.
*
*  DISPLAY HELP MESSAGE
*
HELP-THAT-USER.
    DISPLAY " ".
    DISPLAY "THE VALID COMMANDS ARE:".
    DISPLAY " EXIT    OR".
    DISPLAY " E       TO TERMINATE THE PROGRAM".
    DISPLAY " HELP    OR".
    DISPLAY " H       TO PRINT THIS MESSAGE".
    DISPLAY " STATUS  OR".
    DISPLAY " S       TO DISPLAY CURRENT FILE STATUS".
    DISPLAY " ".
*
*  DISPLAY CURRENT FILE STATUS
*
DISPLAY-CURRENT-STATUS.
    DISPLAY " ".
    DISPLAY " CURRENT FILE STATUS IS:".
    DISPLAY "  TOTAL VALID FILE READS PERFORMED  " READ-COUNT.
    DISPLAY "  TOTAL VALID FILE WRITES PERFORMED " WRITE-COUNT.
    DISPLAY " ".
    DISPLAY " ".
*
*  ADD A NEW RECORD TO THE FILE
*
NEW-FILE-RECORD.
    MOVE IPCF-DATA TO FILE-DATA.
    ADD 1 TO WRITE-COUNT.
    WRITE FILE-RECORD INVALID KEY
        MOVE FILE-RETURN-DUPLICATE TO IPCF-CODE
        SUBTRACT 1 FROM WRITE-COUNT.
*
*  READ AN EXISTING RECORD FROM THE FILE
*
READ-FILE-RECORD.
    ADD 1 TO READ-COUNT.
    READ DATA-FILE INTO IPCF-RECORD INVALID KEY
        MOVE FILE-RETURN-NONE TO IPCF-CODE
        SUBTRACT 1 FROM READ-COUNT.