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:
       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.