Example in OPM COBOL: Registering exit points and adding exit programs
This OPM COBOL program registers an exit point with the registration facility. After the successful completion of the registration, the program adds an exit program to the exit point.
Note: By using the code examples, you agree to the terms of the Code license and disclaimer information.
IDENTIFICATION DIVISION.
***************************************************************
***************************************************************
*
* Program: Register an Exit Point
* Add an Exit Program
*
* Language: OPM COBOL
*
* Description: This program registers an exit point with the
* registration facility. After the successful
* completion of the registration of the exit point,
* an exit program is added to the exit point.
*
* APIs Used: QUSRGPT - Register Exit Point
* QUSADDEP - Add Exit Program
*
***************************************************************
*
***************************************************************
PROGRAM-ID. REGFAC1.
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.
*
* Keyed Variable Length Record includes
*
COPY QUS OF QSYSINC-QLBLSRC.
*
* 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-REG.
05 TEXT1 PIC X(39)
VALUE "Attempt to register exit point failed: ".
05 EXCEPTION-ID PIC X(07).
01 BAD-ADD.
05 TEXT1 PIC X(36)
VALUE "Attempt to add exit program failed: ".
05 EXCEPTION-ID PIC X(07).
*
* Miscellaneous elements
*
01 VARREC.
05 NBR-RECORDS PIC S9(09) BINARY.
05 VAR-RECORDS PIC X(1000).
01 MISC.
05 VAR-OFFSET PIC S9(09) VALUE 1.
05 BINARY-NUMBER PIC S9(09) BINARY.
05 BINARY-CHAR REDEFINES BINARY-NUMBER PIC X(04).
05 X PIC S9(09) BINARY.
05 EXIT-POINT-NAME PIC X(20) VALUE "EXAMPLE_EXIT_POINT".
05 EXIT-PGM PIC X(20) VALUE "EXAMPLEPGMEXAMPLELIB".
05 EXIT-PGM-NBR PIC S9(09) VALUE 1 BINARY.
05 EXIT-PGM-DATA PIC X(25)
VALUE "EXAMPLE EXIT PROGRAM DATA".
05 FORMAT-NAME PIC X(08) VALUE "EXMP0100".
*
* Beginning of mainline
*
PROCEDURE DIVISION.
MAIN-LINE.
*
* Register the exit point with the registration facility. If the
* registration of the exit point is successful, add an exit
* program to the exit point.
*
* Initialize the error code parameter. To signal exceptions to
* this program by the API, you need to set the bytes provided
* field of the error code to zero. Because this program has
* exceptions sent back through the error code parameter, it sets
* the bytes provided field to the number of bytes it gives the
* API for the parameter.
*
MOVE 16 TO BYTES-PROVIDED.
*
* Set the exit point controls. Each control field is passed to
* the API using a variable length record. Each record must
* start on a 4-byte boundary.
*
* Set the total number of controls that are being specified on
* the call. This program lets the API take the default for the
* controls that are not specified.
*
MOVE 2 TO NBR-RECORDS.
*
* Set the values for the two controls that are specified:
* Maximum number of exit programs = 10
* Exit point description = 'EXIT POINT EXAMPLE'
*
MOVE 3 TO CONTROL-KEY OF QUS-VLEN-REC-4.
MOVE 4 TO LENGTH-DATA OF QUS-VLEN-REC-4.
MOVE 10 TO BINARY-NUMBER.
MOVE BINARY-CHAR TO VAR-RECORDS((VAR-OFFSET + 12):4).
PERFORM CALCULATE-NEXT-OFFSET.
MOVE 8 TO CONTROL-KEY OF QUS-VLEN-REC-4.
MOVE 50 TO LENGTH-DATA OF QUS-VLEN-REC-4.
MOVE "EXIT POINT EXAMPLE"
TO VAR-RECORDS((VAR-OFFSET + 12):50).
PERFORM CALCULATE-NEXT-OFFSET.
C*
C* Call the API to add the exit point.
C*
CALL "QUSRGPT" USING EXIT-POINT-NAME OF MISC,
FORMAT-NAME OF MISC,
VARREC, QUS-EC.
C*
C* If an exception occurs, the API returns the exception in the
C* error code parameter. The bytes available field is set to
C* zero if no exception occurs and greater than zero if an
C* exception does occur.
C*
IF BYTES-AVAILABLE OF QUS-EC > 0
OPEN OUTPUT LISTING,
MOVE EXCEPTION-ID OF QUS-EC
TO EXCEPTION-ID OF BAD-REG,
WRITE LIST-LINE FROM BAD-REG,
STOP RUN.
*
* If the call to register an exit point is successful, add
* an exit program to the exit point.
*
* Set the total number of exit program attributes that are being
* specified on the call. This program lets the API take the
* default for the attributes that are not specified. Each
* attribute record must be 4-byte aligned.
*
MOVE 2 TO NBR-RECORDS.
MOVE 1 TO VAR-OFFSET.
*
* Set the values for the two attributes that are being specified:
* Replace exit program = 1
* Exit program data CCSID = 37
*
MOVE 4 TO CONTROL-KEY OF QUS-VLEN-REC-4.
MOVE 1 TO LENGTH-DATA OF QUS-VLEN-REC-4.
MOVE 1 TO VAR-RECORDS((VAR-OFFSET + 12):1).
PERFORM CALCULATE-NEXT-OFFSET.
MOVE 3 TO CONTROL-KEY OF QUS-VLEN-REC-4.
MOVE 4 TO LENGTH-DATA OF QUS-VLEN-REC-4.
MOVE 37 TO BINARY-NUMBER.
MOVE BINARY-CHAR TO VAR-RECORDS((VAR-OFFSET + 12):4).
PERFORM CALCULATE-NEXT-OFFSET.
*
* Call the API to register the exit program.
*
CALL "QUSADDEP" USING EXIT-POINT-NAME OF MISC,
FORMAT-NAME OF MISC,
EXIT-PGM-NBR OF MISC,
EXIT-PGM OF MISC,
EXIT-PGM-DATA OF MISC,
BY CONTENT LENGTH OF EXIT-PGM-DATA OF MISC,
VARREC, 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-ADD,
WRITE LIST-LINE FROM BAD-ADD,
STOP RUN.
*
STOP RUN.
*
* End of MAINLINE
*
*
* Calculate 4-byte aligned offset for next variable length record
*
CALCULATE-NEXT-OFFSET.
COMPUTE BINARY-NUMBER = LENGTH-DATA OF QUS-VLEN-REC-4 + 12.
DIVIDE BINARY-NUMBER BY 4 GIVING BINARY-NUMBER REMAINDER X.
IF X = 0 COMPUTE LENGTH-VLEN-RECORD OF QUS-VLEN-REC-4 =
LENGTH-DATA OF QUS-VLEN-REC-4 + 12
ELSE COMPUTE LENGTH-VLEN-RECORD OF QUS-VLEN-REC-4 =
LENGTH-DATA OF QUS-VLEN-REC-4 + 12 +
( 4 - X ).
MOVE QUS-VLEN-REC-4 TO VAR-RECORDS(VAR-OFFSET:12).
COMPUTE VAR-OFFSET = VAR-OFFSET + LENGTH-VLEN-RECORD OF
QUS-VLEN-REC-4.