Trailing-Edge
-
PDP-10 Archives
-
BB-5372C-BM
-
demo/filepr.cbl
There is 1 other file named filepr.cbl in the archive. Click here to see a list.
00100 IDENTIFICATION DIVISION.
00200 PROGRAM-ID. FILEPR.
00300 *
00400 * THIS PROGRAM PERFORMS ALL THE FILE PROCESSING FUNCTIONS WHICH
00500 * ARE REQUIRED BY THE TERMINAL INTERACTION PROGRAMS (ITERM).
00600 *
00700 * FUNCTIONS WHICH MAY BE REQUESTED OF THIS PROGRAM ARE:
00800 * ADD (1) - DEFINE A NEW ENTRY IN THE FILE
00900 * EXAMINE (2) - RETURN INFORMATION WHICH EXISTS IN THE FILE
01000 *
01100 * ACTION CODES WHICH MAY BE RETURNED BY THIS PROGRAM ARE:
01200 * 0 - FUNCTION PERFORMED SUCCESSFULLY
01300 * 1 - INVALID FUNCTION REQUESTED
01400 * 2 - KEY ALREADY EXISTS IN THE FILE
01500 * 3 - KEY DOES NOT EXIST IN THE FILE
01600 *
01700 ENVIRONMENT DIVISION.
01800 INPUT-OUTPUT SECTION.
01900 FILE-CONTROL.
02000 SELECT DATA-FILE ASSIGN TO DSK
02100 ACCESS IS INDEXED
02200 SYMBOLIC KEY IS IPCF-KEY
02300 RECORD KEY IS FILE-KEY.
02400 DATA DIVISION.
02500 FILE SECTION.
02600 FD DATA-FILE
02700 BLOCK CONTAINS 9 RECORDS
02800 VALUE OF IDENTIFICATION IS "DTFILEIDX".
02900 *INDEX FILE IS BLOCKED 42
03000 01 FILE-RECORD USAGE DISPLAY-7.
03100 02 FILE-KEY PIC X(5).
03200 02 FILE-DATA PIC X(50).
03300 WORKING-STORAGE SECTION.
03400 77 ERROR-CODE PIC S9(10) COMP.
03500 77 HOLD-ERROR PIC S9(10) COMP.
03600 77 WAIT-CODE PIC S9(10) COMP.
03700 77 RESUME-COND PIC S9(10) COMP.
03800 77 I PIC S9(10) COMP.
03900 77 READ-COUNT PIC S9(10) COMP VALUE 0.
04000 77 WRITE-COUNT PIC S9(10) COMP VALUE 0.
04100 77 OTHER-INDEX PIC S9(10) COMP.
04200 77 MY-ID PIC X(14) VALUE "FILE-PROCESSOR".
04300 77 TERM-MSG PIC X(7) USAGE DISPLAY-7.
04400 01 IPCF-ROUTINE-TABLE USAGE DISPLAY-7.
04500 02 IPCF-ROUTINE-NAME PIC X(6) OCCURS 8 TIMES
04600 INDEXED BY IPCF-ROUTINE-INDEX.
04700 01 IPCF-ROUTINE-INDEXES.
04800 02 IPCRID-INDEX PIC S9(10) COMP VALUE 1.
04900 02 IPDLID-INDEX PIC S9(10) COMP VALUE 2.
05000 02 IPCRDX-INDEX PIC S9(10) COMP VALUE 3.
05100 02 IPDLDX-INDEX PIC S9(10) COMP VALUE 4.
05200 02 IPSEND-INDEX PIC S9(10) COMP VALUE 5.
05300 02 IPRECV-INDEX PIC S9(10) COMP VALUE 6.
05400 02 IPWAIT-INDEX PIC S9(10) COMP VALUE 7.
05500 02 IPRUNI-INDEX PIC S9(10) COMP VALUE 8.
05600 *
05700 * DEFINE EXTERNAL PROGRAM INTERFACE
05800 *
05900 01 FILE-PROCESSOR-INFO USAGE DISPLAY-7.
06000 02 FILE-RETURN-OK PIC 99 VALUE 00.
06100 02 FILE-RETURN-INVALID PIC 99 VALUE 01.
06200 02 FILE-RETURN-DUPLICATE PIC 99 VALUE 02.
06300 02 FILE-RETURN-NONE PIC 99 VALUE 03.
06400 02 FILE-FUNCTION PIC 99.
06500 88 FILE-ADD VALUE 01.
06600 88 FILE-EXAMINE VALUE 02.
06700 01 IPCF-MESSAGE USAGE DISPLAY-7.
06800 02 IPCF-CODE PIC 99.
06900 02 IPCF-KEY PIC X(5).
07000 02 IPCF-DATA PIC X(50).
07100 66 IPCF-RECORD RENAMES IPCF-KEY THRU IPCF-DATA.
07200 PROCEDURE DIVISION.
07300 START.
07400 MOVE "IPCRIDIPDLIDIPCRDXIPDLDXIPSENDIPRECVIPWAITIPRUNI" TO
07500 IPCF-ROUTINE-TABLE.
07600 *
07700 * LET MY IDENTIFICATION BE KNOWN SO THAT THE TERMINAL INTERACTION
07800 * PROGRAMS CAN SEND MESSAGES TO ME.
07900 *
08000 CREATE-MY-ID.
08100 MOVE IPCRID-INDEX TO IPCF-ROUTINE-INDEX.
08200 ENTER MACRO IPCRID USING MY-ID,ERROR-CODE.
08300 IF ERROR-CODE NOT = 0
08400 PERFORM DISPLAY-IPCF-ERROR
08500 STOP RUN.
08600 OPEN I-O DATA-FILE.
08700 DISPLAY " FILE PROCESSOR INITIALIZED".
08800 DISPLAY " ".
08900 *
09000 * MAIN PROGRAM WHICH WAITS FOR IPCF OR TERMINAL INPUT, PROCESSES THAT
09100 * INPUT, AND WAITS FOR NEXT EVENT.
09200 *
09300 MAIN-LOOP.
09400 SET WAIT-CODE TO ZERO.
09500 SET RESUME-COND TO 3.
09600 PERFORM WAIT-FOR-SOMETHING.
09700 IF WAIT-CODE = 1
09800 PERFORM TERM-INPUT THRU TERM-INPUT-EXIT
09900 GO TO MAIN-LOOP.
10000 PERFORM IPCF-INPUT THRU IPCF-INPUT-EXIT.
10100 GO TO MAIN-LOOP.
10200 *
10300 * PROCESS TERMINAL INPUT
10400 *
10500 TERM-INPUT.
10600 ACCEPT TERM-MSG.
10700 IF TERM-MSG = "EXIT" OR "E"
10800 GO TO TERMINATE-GRACEFULLY.
10900 IF TERM-MSG = "HELP" OR "H"
11000 PERFORM HELP-THAT-USER
11100 GO TO TERM-INPUT-EXIT.
11200 IF TERM-MSG = "STATUS" OR "S"
11300 PERFORM DISPLAY-CURRENT-STATUS
11400 GO TO TERM-INPUT-EXIT.
11500 DISPLAY "? ILLEGAL COMMAND".
11600 TERM-INPUT-EXIT.
11700 EXIT.
11800 *
11900 * PROCESS IPCF MESSAGES
12000 *
12100 IPCF-INPUT.
12200 MOVE IPRECV-INDEX TO IPCF-ROUTINE-INDEX.
12300 ENTER MACRO IPRECV USING IPCF-MESSAGE, OTHER-INDEX, ERROR-CODE.
12400 IF ERROR-CODE NOT = 0
12500 PERFORM DISPLAY-IPCF-ERROR
12600 GO TO IPCF-INPUT-EXIT.
12700 MOVE IPCF-CODE TO FILE-FUNCTION.
12800 MOVE FILE-RETURN-OK TO IPCF-CODE.
12900 IF FILE-ADD
13000 PERFORM NEW-FILE-RECORD
13100 GO TO IPCF-INPUT-1.
13200 IF FILE-EXAMINE
13300 PERFORM READ-FILE-RECORD
13400 GO TO IPCF-INPUT-1.
13500 MOVE FILE-RETURN-INVALID TO IPCF-CODE.
13600 IPCF-INPUT-1.
13700 PERFORM IPCF-SEND.
13800 * SINCE INDEX VALUE DOESN'T MEAN ANYTHING TO US, RELEASE IT.
13900 MOVE IPDLDX-INDEX TO IPCF-ROUTINE-INDEX.
14000 ENTER MACRO IPDLDX USING OTHER-INDEX, ERROR-CODE.
14100 IF ERROR-CODE NOT = 0
14200 PERFORM DISPLAY-IPCF-ERROR.
14300 IPCF-INPUT-EXIT.
14400 EXIT.
14500 *
14600 * SEND RECORD IPCF-MESSAGE AS AN IPCF MESSAGE
14700 *
14800 IPCF-SEND.
14900 SET ERROR-CODE TO -1.
15000 PERFORM IPCF-SEND-1 VARYING I FROM 1 BY 1
15100 UNTIL I > 5 OR ERROR-CODE = 0.
15200 MOVE IPSEND-INDEX TO IPCF-ROUTINE-INDEX.
15300 IF ERROR-CODE NOT = 0
15400 PERFORM DISPLAY-IPCF-ERROR.
15500 IPCF-SEND-1.
15600 ENTER MACRO IPSEND USING IPCF-MESSAGE, OTHER-INDEX,
15700 ERROR-CODE.
15800 * IF CAPACITY EXCEEDED, WAIT BEFORE RETRYING.
15900 IF ERROR-CODE = 12 OR 13 OR 14
16000 MOVE ERROR-CODE TO HOLD-ERROR
16100 SET WAIT-CODE TO 3000
16200 SET RESUME-COND TO 0
16300 PERFORM WAIT-FOR-SOMETHING
16400 MOVE HOLD-ERROR TO ERROR-CODE.
16500 *
16600 * WAIT FOR A SIGNIFICANT EVENT
16700 *
16800 WAIT-FOR-SOMETHING.
16900 MOVE IPWAIT-INDEX TO IPCF-ROUTINE-INDEX.
17000 ENTER MACRO IPWAIT USING WAIT-CODE, RESUME-COND, ERROR-CODE.
17100 IF ERROR-CODE NOT = 0
17200 PERFORM DISPLAY-IPCF-ERROR
17300 GO TO TERMINATE-GRACEFULLY.
17400 *
17500 * DISPLAY IPCF ERROR CODE AND ROUTINE WHICH WAS CALLED
17600 *
17700 DISPLAY-IPCF-ERROR.
17800 DISPLAY " IPCF ERROR " ERROR-CODE " FROM ROUTINE "
17900 IPCF-ROUTINE-NAME (IPCF-ROUTINE-INDEX).
18000 *
18100 * TERMINATE PROCESSING
18200 *
18300 TERMINATE-GRACEFULLY.
18400 CLOSE DATA-FILE
18500 PERFORM DISPLAY-CURRENT-STATUS
18600 STOP RUN.
18700 *
18800 * DISPLAY HELP MESSAGE
18900 *
19000 HELP-THAT-USER.
19100 DISPLAY " ".
19200 DISPLAY "THE VALID COMMANDS ARE:".
19300 DISPLAY " EXIT OR".
19400 DISPLAY " E TO TERMINATE THE PROGRAM".
19500 DISPLAY " HELP OR".
19600 DISPLAY " H TO PRINT THIS MESSAGE".
19700 DISPLAY " STATUS OR".
19800 DISPLAY " S TO DISPLAY CURRENT FILE STATUS".
19900 DISPLAY " ".
20000 *
20100 * DISPLAY CURRENT FILE STATUS
20200 *
20300 DISPLAY-CURRENT-STATUS.
20400 DISPLAY " ".
20500 DISPLAY " CURRENT FILE STATUS IS:".
20600 DISPLAY " TOTAL VALID FILE READS PERFORMED " READ-COUNT.
20700 DISPLAY " TOTAL VALID FILE WRITES PERFORMED " WRITE-COUNT.
20800 DISPLAY " ".
20900 DISPLAY " ".
21000 *
21100 * ADD A NEW RECORD TO THE FILE
21200 *
21300 NEW-FILE-RECORD.
21400 MOVE IPCF-DATA TO FILE-DATA.
21500 ADD 1 TO WRITE-COUNT.
21600 WRITE FILE-RECORD INVALID KEY
21700 MOVE FILE-RETURN-DUPLICATE TO IPCF-CODE
21800 SUBTRACT 1 FROM WRITE-COUNT.
21900 *
22000 * READ AN EXISTING RECORD FROM THE FILE
22100 *
22200 READ-FILE-RECORD.
22300 ADD 1 TO READ-COUNT.
22400 READ DATA-FILE INTO IPCF-RECORD INVALID KEY
22500 MOVE FILE-RETURN-NONE TO IPCF-CODE
22600 SUBTRACT 1 FROM READ-COUNT.