Example: Using a COBOL/400 program to call APIs
This COBOL/400 program creates a pending run unit and sets an error handler for the pending run unit.
The program uses the example error handler in Error handler for the example COBOL/400 program.
Notes:
- The error-handling program, ACERRF24 (shown in Error handler for the example COBOL/400 program), must exist in the UTCBL library.
- By using the code examples, you agree to the terms of the Code license and disclaimer information.
IDENTIFICATION DIVISION.
PROGRAM-ID. ACF24.
**************************************************************
**************************************************************
*
* FUNCTION: SHOWS HOW TO CALL THE VARIOUS APIs, WHILE
* TESTING THAT THEY WORK PROPERLY.
*
* LANGUAGE: COBOL
*
* APIs USED: QLRRTVCE, QLRCHGCM, QLRSETCE
*
**************************************************************
**************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 old.
05 oldname PIC X(10).
05 oldlibr PIC X(10).
77 scope PIC X VALUE "P".
01 errparm.
05 input-l PIC S9(6) BINARY VALUE ZERO.
05 output-l PIC S9(6) BINARY VALUE ZERO.
05 exception-id PIC X(7).
05 reserved PIC X(1).
05 exception-data PIC X(50).
01 new.
05 newname PIC X(10) VALUE "ACERRF24".
05 newlibr PIC X(10) VALUE "UTCBL".
77 newlib PIC X(10).
PROCEDURE DIVISION.
main-proc.
DISPLAY "in ACF24".
PERFORM variation-01 THRU end-variation.
STOP RUN.
variation-01.
**************************************************************
* *
* This variation addresses the situation where there is no *
* pending COBOL main, so no pending error handler can exist. *
* *
**************************************************************
DISPLAY "no pending so expect nothing but error LBE7052".
MOVE SPACES TO old exception-id.
**************************************************************
* By setting error parm > 8, expect escape message *
* LBE7052 to be returned in error parameter. *
**************************************************************
MOVE LENGTH OF errparm TO input-l.
CALL "QLRRTVCE" USING old scope errparm.
IF exception-id IS NOT = "LBE7052" THEN
DISPLAY "** error - expected LBE7052"
ELSE
DISPLAY "LBE7052 was found"
END-IF.
**************************************************************
* Reset input-l to ZERO, thus any further errors will cause *
* COBOL program to stop. *
**************************************************************
MOVE 0 TO input-l.
MOVE SPACES TO old exception-id.
variation-02.
**************************************************************
* *
* This variation creates a pending run unit. It then makes *
* sure that no pending error handler has been set. *
* *
**************************************************************
DISPLAY "create pending run unit".
CALL "QLRCHGCM" USING errparm.
**************************************************************
* *
* No pending error handler exists so *NONE should be *
* returned. *
* *
************************************************************** CALL "QLRRTVCE" USING old scope errparm.
DISPLAY "Retrieved Error Handler is=" old.
IF oldname IS NOT = "*NONE" THEN
DISPLAY "** error - expected *NONE for error handler"
END-IF.
MOVE 0 TO input-l.
MOVE SPACES TO old exception-id.
variation-03.
**************************************************************
* *
* This variation sets an error handler for the pending *
* run unit and then does another check to make sure it *
* was really set. *
* *
**************************************************************
CALL "QLRSETCE" USING new scope newlib old errparm.
IF oldname IS NOT = "*NONE"
DISPLAY "** error in oldname "
END-IF.
IF newlib IS NOT = "UTCBL"
DISPLAY "** error in new library "
END-IF.
**************************************************************
* Call the retrieve API to check to make sure that the *
* set API worked. *
**************************************************************
MOVE SPACES TO old exception-id.
CALL "QLRRTVCE" USING old scope errparm.
DISPLAY "Retrieved Error Handler is=" old.
IF oldname IS NOT = "ACERRF24" OR oldlibr IS NOT = "UTCBL"
DISPLAY "** error - expected ACERRF24 error handler"
END-IF.
end-variation.Error handler for the example COBOL/400 program
This example error handler works with Example: Using a COBOL/400 program to call APIs.
IDENTIFICATION DIVISION.
PROGRAM-ID. ACERRF24.
**************************************************************
**************************************************************
*
* FUNCTION: Error handler for preceding example COBOL program
*
* LANGUAGE: COBOL
*
* APIs USED: None
*
**************************************************************
**************************************************************
SPECIAL-NAMES. SYSTEM-CONSOLE IS SYSCON.
DATA DIVISION.
WORKING-STORAGE SECTION.
77 scope PIC X VALUE "P".
01 errparm.
05 FILLER PIC X(30).
LINKAGE SECTION.
77 cobol-id PIC X(7).
77 valid-responses PIC X(6).
01 progr.
05 progname PIC X(10).
05 proglibr PIC X(10).
77 system-id PIC X(7).
77 len-text PIC S9(9) COMP-4.
01 subtext.
03 subchars PIC X OCCURS 1 TO 230 TIMES
DEPENDING ON len-text.
77 retcode PIC X(1).
PROCEDURE DIVISION USING cobol-id, valid-responses,
progr, system-id, subtext, len-text, retcode.
main-proc.
**********************************************************
* check for typical messages and take appropriate action *
**********************************************************
EVALUATE cobol-id
WHEN "LBE7604"
**********************************************************
* stop literal, let the user see the message *
**********************************************************
MOVE SPACE TO retcode
WHEN "LBE7208"
**********************************************************
* accept/display, recoverable problem answer G to continue
**********************************************************
MOVE "G" TO retcode
WHEN OTHER
**********************************************************
* for all other messages signal system operator and *
* end the current run unit *
**********************************************************
DISPLAY "COBOL Error Handler ACERRF24 "
"Found message " cobol-id
" Issued from program " progr
UPON syscon
DISPLAY " Ended current run unit"
UPON syscon
MOVE "C" TO retcode
END-EVALUATE.
GOBACK.