This program retrieves exit point and exit program information. After retrieving the exit point information, the program calls each exit program. The Retrieve Exit Information API returns a continuation handle when it has more information to return than what fits in the receiver variable.
IDENTIFICATION DIVISION.
***************************************************************
***************************************************************
*
* Program: Retrieve Exit Point and Exit Program Information
*
* Language: OPM COBOL
*
* Description: This program retrieves exit point and exit
* program information. After retrieving the
* exit point information, the program calls each
* exit program.
*
* APIs Used: QUSCRTUS - Create User Space
* QUSPTRUS - Retrieve Pointer to User Space
* QUSRTVEI - Retrieve Exit Information
*
***************************************************************
***************************************************************
*
PROGRAM-ID. REGFAC2.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT LISTING ASSIGN TO PRINTER-QPRINT
ORGANIZATION IS SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD LISTING RECORD CONTAINS 132 CHARACTERS
LABEL RECORDS ARE STANDARD
DATA RECORD IS LIST-LINE.
01 LIST-LINE PIC X(132).
WORKING-STORAGE SECTION.
*
* Error Code parameter include. As this sample program
* uses COPY to include the error code structure, only the first
* 16 bytes of the error code structure are available. If the
* application program needs to access the variable length
* exception data for the error, the developer should physically
* copy the QSYSINC include and modify the copied include to
* define additional storage for the exception data.
*
COPY QUSEC OF QSYSINC-QLBLSRC.
*
* Error message text
*
01 BAD-EXIT-POINT.
05 TEXT1 PIC X(40)
VALUE "Attempt to retrieve information failed: ".
05 EXCEPTION-ID PIC X(07).
01 BAD-EXIT-PGM.
05 TEXT1 PIC X(42)
VALUE "Attempt to retrieve Exit Programs failed: ".
05 EXCEPTION-ID PIC X(07).
01 BAD-CREATE.
05 TEXT1 PIC X(37)
VALUE "Allocation of RCVVAR storage failed: ".
05 EXCEPTION-ID PIC X(07).
*
* Miscellaneous elements
*
01 MISC.
05 EXIT-POINT-NAME PIC X(20) VALUE "EXAMPLE_EXIT_POINT".
05 EXIT-PGM-NBR PIC S9(09) VALUE -1 BINARY.
05 EXIT-PARAMETERS PIC X(10).
05 FORMAT-NAME PIC X(08) VALUE "EXTI0100".
05 FORMAT-NAME-1 PIC X(08) VALUE "EXTI0200".
05 FORMAT-NAME-2 PIC X(08) VALUE "EXMP0100".
05 NBR-OF-SELECT-CRITERIA PIC S9(09) VALUE 0 BINARY.
05 CONTINUATION-HDL PIC X(16).
05 BASE-POINTER POINTER.
05 INFO-POINTER POINTER.
05 SPACE-NAME PIC X(20) VALUE "RCVVAR QTEMP ".
05 SPACE-ATTR PIC X(10).
05 SPACE-SIZE PIC S9(09) VALUE 3500 BINARY.
05 SPACE-VALUE PIC X(01) VALUE X"00".
05 SPACE-AUTH PIC X(10) VALUE "*USE".
05 SPACE-TEXT PIC X(50).
05 SPACE-REPLACE PIC X(10) VALUE "*NO".
05 SPACE-DOMAIN PIC X(10) VALUE "*USER".
*
LINKAGE SECTION.
*
* Variable to hold results of QUSRTVEI. The storage for this
* variable will be allocated by way of a User Space.
*
01 RCVVAR PIC X(3500).
*
* Registration Facility API include. These includes will be
* mapped over the RCVVAR (User Space) previously defined.
*
COPY QUSREG OF QSYSINC-QLBLSRC.
*
* Beginning of mainline
*
PROCEDURE DIVISION.
MAIN-LINE.
*
* Retrieve the exit point information first. If the current
* number of exit programs is not zero, retrieve the exit
* programs. It is not necessary to call for the exit point
* information to determine if the exit point has any exit
* programs. It is done here for illustrative purposes only.
* You can make one call to the API for the exit program
* information and check the number of exit program entries
* returned field to see if there are any exit programs to call.
*
* Initialize the error code to inform the API that all
* exceptions should be returned through the error code parameter.
*
MOVE 16 TO BYTES-PROVIDED OF QUS-EC.
*
* Create a User Space for RCVVAR.
*
CALL "QUSCRTUS" USING SPACE-NAME, SPACE-ATTR, SPACE-SIZE,
SPACE-VALUE, SPACE-AUTH, SPACE-TEXT,
SPACE-REPLACE, QUS-EC, SPACE-DOMAIN.
*
* If an exception occurs, the API returns the exception in the
* error code parameter. The bytes available field is set to
* zero if no exception occurs and greater than zero if an
* exception does occur.
*
IF BYTES-AVAILABLE OF QUS-EC > 0
IF EXCEPTION-ID OF QUS-EC = "CPF9870"
CONTINUE
ELSE
OPEN OUTPUT LISTING,
MOVE EXCEPTION-ID OF QUS-EC
TO EXCEPTION-ID OF BAD-CREATE,
WRITE LIST-LINE FROM BAD-CREATE,
STOP RUN.
*
* Assign BASE-POINTER to address RCVVAR
*
CALL "QUSPTRUS" USING SPACE-NAME, BASE-POINTER, QUS-EC.
*
* If an exception occurs, the API returns the exception in the
* error code parameter. The bytes available field is set to
* zero if no exception occurs and greater than zero if an
* exception does occur.
*
IF BYTES-AVAILABLE OF QUS-EC > 0
OPEN OUTPUT LISTING,
MOVE EXCEPTION-ID OF QUS-EC
TO EXCEPTION-ID OF BAD-CREATE,
WRITE LIST-LINE FROM BAD-CREATE,
STOP RUN.
*
SET ADDRESS OF RCVVAR TO BASE-POINTER.
*
* Blank out the continuation handle to let the API know that this
* is a first attempt at the retrieve operation.
*
MOVE SPACES TO CONTINUATION-HDL.
*
* Call the API to retrieve the exit programs
*
CALL "QUSRTVEI" USING CONTINUATION-HDL, RCVVAR,
BY CONTENT LENGTH OF RCVVAR,
FORMAT-NAME OF MISC,
EXIT-POINT-NAME OF MISC,
FORMAT-NAME-2, EXIT-PGM-NBR,
NBR-OF-SELECT-CRITERIA, QUS-EC.
*
* If an exception occurs, the API returns the exception in the
* error code parameter. The bytes available field is set to
* zero if no exception occurs and greater than zero if an
* exception does occur.
*
IF BYTES-AVAILABLE OF QUS-EC > 0
OPEN OUTPUT LISTING,
MOVE EXCEPTION-ID OF QUS-EC
TO EXCEPTION-ID OF BAD-EXIT-POINT,
WRITE LIST-LINE FROM BAD-EXIT-POINT,
STOP RUN.
*
* If the call to retrieve exit point information is successful,
* check to see if there are any exit programs to call.
*
SET ADDRESS OF QUS-EXTI0100 TO BASE-POINTER.
SET ADDRESS OF QUS-EXTI0200 TO BASE-POINTER.
*
IF NUMBER-POINTS-RETURNED OF QUS-EXTI0100 > 0
SET ADDRESS OF QUS-EXTI0100-ENTRY TO
ADDRESS OF RCVVAR((OFFSET-EXIT-POINT-ENTRY OF
QUS-EXTI0100 + 1):)
ELSE STOP RUN.
*
IF NUMBER-EXIT-PROGRAMS OF QUS-EXTI0100-ENTRY > 0
*
* There are some exit programs to call. Blank out the continuation
* handle to let the API know that this is a first attempt at the
* retrieve operation.
*
MOVE SPACES TO CONTINUATION-HDL,
*
* Call the exit programs
*
PERFORM CALL-EXIT-PROGRAMS,
*
* If the continuation handle field in the receiver variable is
* not set to blanks, the API has more information to return than
* what could fit in the receiver variable. Call the API for
* more exit programs to call.
*
PERFORM UNTIL CONTINUE-HANDLE OF QUS-EXTI0200 = SPACES
MOVE CONTINUE-HANDLE OF QUS-EXTI0200
TO CONTINUATION-HDL,
PERFORM CALL-EXIT-PROGRAMS,
END-PERFORM.
*
STOP RUN.
*
* End of MAINLINE
*
*
* Process exit programs in receiver variable
*
CALL-EXIT-PROGRAMS.
*
* Call the API to retrieve the exit program information
*
CALL "QUSRTVEI" USING CONTINUATION-HDL, RCVVAR,
BY CONTENT LENGTH OF RCVVAR,
FORMAT-NAME-1,
EXIT-POINT-NAME OF MISC,
FORMAT-NAME-2, EXIT-PGM-NBR,
NBR-OF-SELECT-CRITERIA, QUS-EC.
*
* If an exception occurs, the API returns the exception in the
* error code parameter. The bytes available field is set to
* zero if no exception occurs and greater than zero if an
* exception does occur.
*
IF BYTES-AVAILABLE OF QUS-EC > 0
OPEN OUTPUT LISTING,
MOVE EXCEPTION-ID OF QUS-EC
TO EXCEPTION-ID OF BAD-EXIT-PGM,
WRITE LIST-LINE FROM BAD-EXIT-PGM,
STOP RUN.
*
* If the call to retrieve exit program information is successful,
* check to see if there are any exit programs to call.
*
* The receiver variable offers enough room for a minimum of one
* exit program entry because the receiver variable was declared
* as 3500 bytes. Therefore, this example only checks the
* number of exit programs returned field. If the receiver
* variable were not large enough to hold at least one entry,
* the bytes available field would need to be checked as well as
* the number of exit programs returned field. If the number of
* exit programs returned field is set to zero and the bytes
* available field is greater than the bytes returned field, the
* API had at least one exit program entry to return but was
* unable to because the receiver variable was too small.
*
SET ADDRESS OF QUS-EXTI0200-ENTRY
TO ADDRESS OF RCVVAR(OFFSET-PROGRAM-ENTRY
OF QUS-EXTI0200 + 1:).
PERFORM CALL-PGMS
NUMBER-PROGRAMS-RETURNED OF QUS-EXTI0200 TIMES.
*
CALL-PGMS.
*
* Call the exit program while ignoring failures on the call
*
CALL PROGRAM-NAME OF QUS-EXTI0200-ENTRY USING
EXIT-PARAMETERS
ON EXCEPTION CONTINUE.
*
* Address the next exit program entry
*
SET ADDRESS OF QUS-EXTI0200-ENTRY
TO ADDRESS OF RCVVAR(OFFSET-NEXT-ENTRY
OF QUS-EXTI0200-ENTRY + 1:).