Last active
August 9, 2016 14:59
-
-
Save JohnArchieMckown/d4af397cb47017fac8b4c972daca1864 to your computer and use it in GitHub Desktop.
Example combined LE condition handler and test program. For IBM z/OS Enterprise COBOL. Tested on z/OS 1.12, COBOL 3.4.1
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 000100 PROCESS LIB,QUOTE,NAME(ALIAS) 00010000 | |
| 000200************************************************* 00020000 | |
| 000300* * 00030000 | |
| 000400* IBM Language Environment for OS/390 & VM * 00040000 | |
| 000500* * 00050000 | |
| 000600* Licensed Materials - Property of IBM * 00060000 | |
| 000700* * 00070000 | |
| 000800* 5647-A01 5688-198 * 00080000 | |
| 000900* (C) Copyright IBM Corp. 1991, 1997 * 00090000 | |
| 001000* All Rights Reserved * 00100000 | |
| 001100* * 00110000 | |
| 001200* US Government Users Restricted Rights - Use, * 00120000 | |
| 001300* duplication or disclosure restricted by GSA * 00130000 | |
| 001400* ADP Schedule Contract with IBM Corp. * 00140000 | |
| 001500* * 00150000 | |
| 001600************************************************* 00160000 | |
| 001700*Module/File Name: IGZTHDLR 00170000 | |
| 001800*********************************************** 00180000 | |
| 001900** ** 00190000 | |
| 002000** CBLHDLR - Call CEEHDLR to register a user ** 00200000 | |
| 002100** condition handler ** 00210000 | |
| 002200** ** 00220000 | |
| 002300*********************************************** 00230000 | |
| 002400 IDENTIFICATION DIVISION. 00240000 | |
| 002500 PROGRAM-ID. CBLHDLR2 RECURSIVE. 00250000 | |
| 002600 DATA DIVISION. 00260000 | |
| 002700 WORKING-STORAGE SECTION. 00270000 | |
| 002800 01 ROUTINE PROCEDURE-POINTER. 00280000 | |
| 002900 01 WS-TOKEN PIC S9(9) BINARY. 00290000 | |
| 003000 01 SEV PIC S9(4) BINARY. 00300000 | |
| 003100 01 MSGNO PIC S9(4) BINARY. 00310000 | |
| 003200 01 CASE PIC S9(4) BINARY. 00320000 | |
| 003300 01 SEV2 PIC S9(4) BINARY. 00330000 | |
| 003400 01 CNTRL PIC S9(4) BINARY. 00340000 | |
| 003500 01 FACID PIC X(3). 00350000 | |
| 003600 01 ISINFO PIC S9(9) BINARY. 00360000 | |
| 003700 01 QDATA PIC S9(9) BINARY. 00370000 | |
| 003800 01 RECOVERY-AREA EXTERNAL. 00380000 | |
| 003900 05 RECOVERY-POINT POINTER. 00390000 | |
| 004000 05 ERROR-INDICATOR PIC X . 00400000 | |
| 004100 88 ERROR-OCCURRED VALUE IS HIGH-VALUES. 00410000 | |
| 004200 88 NO-ERROR-OCCURRED VALUE IS LOW-VALUES. 00420000 | |
| 004300 00430000 | |
| 004400 01 FC-HANDLER. 00440000 | |
| 004500 02 Condition-Token-Value. 00450000 | |
| 004600 COPY CEEIGZCT. 00460000 | |
| 004700 03 Case-1-Condition-ID. 00470000 | |
| 004800 04 Severity PIC S9(4) BINARY. 00480000 | |
| 004900 04 Msg-No PIC S9(4) BINARY. 00490000 | |
| 005000 03 Case-2-Condition-ID 00500000 | |
| 005100 REDEFINES Case-1-Condition-ID. 00510000 | |
| 005200 04 Class-Code PIC S9(4) BINARY. 00520000 | |
| 005300 04 Cause-Code PIC S9(4) BINARY. 00530000 | |
| 005400 03 Case-Sev-Ctl PIC X. 00540000 | |
| 005500 03 Facility-ID PIC XXX. 00550000 | |
| 005600 02 I-S-Info PIC S9(9) BINARY. 00560000 | |
| 005700 00570000 | |
| 005800 01 FC. 00580000 | |
| 005900 02 Condition-Token-Value. 00590000 | |
| 006000 COPY CEEIGZCT. 00600000 | |
| 006100 03 Case-1-Condition-ID. 00610000 | |
| 006200 04 Severity PIC S9(4) BINARY. 00620000 | |
| 006300 04 Msg-No PIC S9(4) BINARY. 00630000 | |
| 006400 03 Case-2-Condition-ID 00640000 | |
| 006500 REDEFINES Case-1-Condition-ID. 00650000 | |
| 006600 04 Class-Code PIC S9(4) BINARY. 00660000 | |
| 006700 04 Cause-Code PIC S9(4) BINARY. 00670000 | |
| 006800 03 Case-Sev-Ctl PIC X. 00680000 | |
| 006900 03 Facility-ID PIC XXX. 00690000 | |
| 007000 02 I-S-Info PIC S9(9) BINARY. 00700000 | |
| 007100 01 CONDTOK. 00710000 | |
| 007200 02 Condition-Token-Value. 00720000 | |
| 007300 COPY CEEIGZCT. 00730000 | |
| 007400 03 Case-1-Condition-ID. 00740000 | |
| 007500 04 Severity PIC S9(4) BINARY. 00750000 | |
| 007600 04 Msg-No PIC S9(4) BINARY. 00760000 | |
| 007700 03 Case-2-Condition-ID 00770000 | |
| 007800 REDEFINES Case-1-Condition-ID. 00780000 | |
| 007900 04 Class-Code PIC S9(4) BINARY. 00790000 | |
| 008000 04 Cause-Code PIC S9(4) BINARY. 00800000 | |
| 008100 03 Case-Sev-Ctl PIC X. 00810000 | |
| 008200 03 Facility-ID PIC XXX. 00820000 | |
| 008300 02 I-S-Info PIC S9(9) BINARY. 00830000 | |
| 008400 LINKAGE SECTION. 00840000 | |
| 008500 01 LS-TOKEN PIC S9(9) BINARY. 00850000 | |
| 008600 01 LS-RESULT PIC S9(9) BINARY. 00860000 | |
| 008700 88 RESUME VALUE 10. 00870000 | |
| 008800 01 CURCOND. 00880000 | |
| 008900 02 Condition-Token-Value. 00890000 | |
| 009000 COPY CEEIGZCT. 00900000 | |
| 009100 03 Case-1-Condition-ID. 00910000 | |
| 009200 04 Severity PIC S9(4) BINARY. 00920000 | |
| 009300 04 Msg-No PIC S9(4) BINARY. 00930000 | |
| 009400 03 Case-2-Condition-ID 00940000 | |
| 009500 REDEFINES Case-1-Condition-ID. 00950000 | |
| 009600 04 Class-Code PIC S9(4) BINARY. 00960000 | |
| 009700 04 Cause-Code PIC S9(4) BINARY. 00970000 | |
| 009800 03 Case-Sev-Ctl PIC X. 00980000 | |
| 009900 03 Facility-ID PIC XXX. 00990000 | |
| 010000 02 I-S-Info PIC S9(9) BINARY. 01000000 | |
| 010100 01 NEWCOND. 01010000 | |
| 010200 02 Condition-Token-Value. 01020000 | |
| 010300 COPY CEEIGZCT. 01030000 | |
| 010400 03 Case-1-Condition-ID. 01040000 | |
| 010500 04 Severity PIC S9(4) BINARY. 01050000 | |
| 010600 04 Msg-No PIC S9(4) BINARY. 01060000 | |
| 010700 03 Case-2-Condition-ID 01070000 | |
| 010800 REDEFINES Case-1-Condition-ID. 01080000 | |
| 010900 04 Class-Code PIC S9(4) BINARY. 01090000 | |
| 011000 04 Cause-Code PIC S9(4) BINARY. 01100000 | |
| 011100 03 Case-Sev-Ctl PIC X. 01110000 | |
| 011200 03 Facility-ID PIC XXX. 01120000 | |
| 011300 02 I-S-Info PIC S9(9) BINARY. 01130000 | |
| 011400 01140000 | |
| 011500 PROCEDURE DIVISION. 01150000 | |
| 011600 PARA-CBLHDLR. 01160000 | |
| 011700 SET ROUTINE TO ENTRY "HANDLER". 01170000 | |
| 011800 CALL "CEEHDLR" USING ROUTINE, WS-TOKEN, FC. 01180000 | |
| 011900 IF NOT CEE000 of FC THEN 01190000 | |
| 012000 DISPLAY "CEEHDLR failed with msg " 01200000 | |
| 012100 Msg-No of FC UPON CONSOLE 01210000 | |
| 012200 STOP RUN 01220000 | |
| 012300 END-IF. 01230000 | |
| 012400 01240000 | |
| 012500* RAISE A SIGNAL 01250000 | |
| 012600 01260000 | |
| 012700 PARA-CBLSGL. 01270000 | |
| 012800************************************************* 01280000 | |
| 012900** Call CEENCOD with the values assigned above ** 01290000 | |
| 013000** to build a condition token "CONDTOK" ** 01300000 | |
| 013100** Set CONDTOK to sev=3, msgno=1 facid=CEE. We ** 01310000 | |
| 013200** raise a sev 3 to ensure our handler is driven* 01320000 | |
| 013300************************************************* 01330000 | |
| 013400 MOVE 3 TO SEV. 01340000 | |
| 013500 MOVE 1 TO MSGNO. 01350000 | |
| 013600 MOVE 1 TO CASE. 01360000 | |
| 013700 MOVE 3 TO SEV2. 01370000 | |
| 013800 MOVE 1 TO CNTRL. 01380000 | |
| 013900 MOVE "CEE" TO FACID. 01390000 | |
| 014000 MOVE 0 TO ISINFO. 01400000 | |
| 014100 01410000 | |
| 014200 CALL "CEENCOD" USING SEV, MSGNO, CASE, 01420000 | |
| 014300 SEV2, CNTRL, FACID, ISINFO, CONDTOK, FC. 01430000 | |
| 014400 IF NOT CEE000 of FC THEN 01440000 | |
| 014500 DISPLAY "CEENCOD failed with msg " 01450000 | |
| 014600 Msg-No of FC UPON CONSOLE 01460000 | |
| 014700 STOP RUN 01470000 | |
| 014800 END-IF. 01480000 | |
| 014900 01490000 | |
| 015000************************************************* 01500000 | |
| 015100** Call CEESGL to signal the condition with ** 01510000 | |
| 015200** the condition token and qdata described ** 01520000 | |
| 015300** in CONDTOK and QDATA ** 01530000 | |
| 015400************************************************* 01540000 | |
| 015500 MOVE 0 TO QDATA. 01550000 | |
| 015600 CALL "CEESGL" USING CONDTOK, QDATA, FC. 01560000 | |
| 015700 IF NOT CEE000 of FC THEN 01570000 | |
| 015800 DISPLAY "CEESGL failed with msg " 01580000 | |
| 015900 Msg-No of FC UPON CONSOLE 01590000 | |
| 016000 STOP RUN 01600000 | |
| 016100 END-IF. 01610000 | |
| 016200 01620000 | |
| 016300 GOBACK. 01630000 | |
| 016400 ENTRY "HANDLER" 01640000 | |
| 016500 USING CURCOND, LS-TOKEN, LS-RESULT, NEWCOND 01650000 | |
| 016600 . 01660000 | |
| 016700* 01670000 | |
| 016800 01680000 | |
| 016900 PARA-HANDLER. 01690000 | |
| 017000 IF RECOVERY-POINT IS NOT EQUAL TO NULL THEN 01700000 | |
| 017100 SET ERROR-OCCURRED TO TRUE 01710000 | |
| 017200 CALL "CEEMRCE" USING RECOVERY-POINT, FC-HANDLER 01720000 | |
| 017300 END-IF 01730000 | |
| 017400 DISPLAY "Entered user handler for condition" 01740000 | |
| 017500 " with message number " Msg-No Of CURCOND 01750000 | |
| 017600 " -- will resume execution" 01760000 | |
| 017700 SET RESUME TO TRUE 01770000 | |
| 017800 01780000 | |
| 017900 GOBACK 01790000 | |
| 018000 . 01800000 | |
| 018100 END PROGRAM CBLHDLR2. 01810000 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment