This program retrieves a file definition template to a user space.
Refer to Example in ILE C: Retrieving a file description to a user space for the original example. The following program also works with OPM COBOL.
IDENTIFICATION DIVISION.
***************************************************************
***************************************************************
*
* Program: RTVFD
*
* Language: COBOL
*
* Description: This program retrieves a file definition
* template to a user space.
*
* APIs Used: QDBRTVFD - Retrieve File Description
* QUSCRTUS - Create User Space
* QUSCUSAT - Change User Space Attributes
* QUSPTRUS - Retrieve a pointer to a User Space
*
***************************************************************
***************************************************************
PROGRAM-ID. RTVFD.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
DATA DIVISION.
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.
*
* Misc. 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 FILE-USED PIC X(20).
05 LIBRARY-NAME PIC X(10).
05 SPACE-SIZE PIC S9(09) BINARY.
05 SPACE-INIT PIC X(01) VALUE "X'00'".
05 SPACE-POINTER POINTER.
05 FORMAT-NAME-1 PIC X(08).
05 OVERRIDES PIC X(01) VALUE "0".
05 SYSTEM PIC X(10) VALUE "*LCL".
05 FORMAT-1 PIC X(10) VALUE "*INT".
05 EXT-ATTR PIC X(10).
05 SPACE-AUT PIC X(10) VALUE "*CHANGE".
05 SPACE-TEXT PIC X(50) VALUE "QDBRTVFD".
05 SPACE-REPLACE PIC X(10) VALUE "*YES".
05 SPACE-DOMAIN PIC X(10) VALUE "*USER".
05 API-NAME PIC X(10).
01 CHG-US-ATTR.
05 NBR-OF-ATTR PIC S9(09) VALUE 1 BINARY.
05 ATTR-KEY PIC S9(09) VALUE 3 BINARY.
05 DATA-SIZE PIC S9(09) VALUE 1 BINARY.
05 ATTR-DATA PIC X(01) VALUE "1".
*
LINKAGE SECTION.
01 SPACE-NAME PIC X(20).
01 FILE-NAME PIC X(20).
01 FORMAT-NAME-PARM PIC X(10).
*
* Retrieve File Description API include.
*
COPY QDBRTVFD OF QSYSINC-QLBLSRC.
*
* Beginning of mainline
*
PROCEDURE DIVISION USING SPACE-NAME, FILE-NAME,
FORMAT-NAME-PARM.
MAIN-LINE.
*
PERFORM INITIALIZE-SPACE.
PERFORM PROCESS-SPACE.
PERFORM PROGRAM-DONE.
*
* Start of subroutines
*
*****************************************************************
PROCESS-SPACE.
*
* The template returned from QDBRTVFD is now addressable by way
* of SPACE-POINTER; as an example the program will now display
* the access method for the file:
*
DISPLAY QDBFPACT OF QDB-QDBFH.
*
*****************************************************************
*
INITIALIZE-SPACE.
*
* One time initialization code for this program
*
* Set Error Code structure to not use exceptions
*
MOVE 16 TO BYTES-PROVIDED OF QUS-EC.
*
* Create a User Space for QDBRTVFD
*
MOVE 1024 TO SPACE-SIZE.
CALL "QUSCRTUS" USING SPACE-NAME, EXT-ATTR, SPACE-SIZE,
SPACE-INIT, SPACE-AUT, SPACE-TEXT,
SPACE-REPLACE, QUS-EC, SPACE-DOMAIN.
*
* Check for errors on QUSCRTUS
*
IF BYTES-AVAILABLE OF QUS-EC > 0
MOVE "QUSCRTUS" TO API-NAME,
PERFORM API-ERROR-FOUND.
*
* Change the User Space so that it is extendable
*
CALL "QUSCUSAT" USING LIBRARY-NAME, SPACE-NAME,
CHG-US-ATTR, QUS-EC.
*
* Check for errors on QUSCUSAT
*
IF BYTES-AVAILABLE OF QUS-EC > 0
MOVE "QUSCUSAT" TO API-NAME,
PERFORM API-ERROR-FOUND.
*
* Get a resolved pointer to the User Space
*
CALL "QUSPTRUS" USING SPACE-NAME, SPACE-POINTER, QUS-EC.
*
* Check for errors on QUSPTRUS
*
IF BYTES-AVAILABLE OF QUS-EC > 0
MOVE "QUSPTRAT" TO API-NAME,
PERFORM API-ERROR-FOUND.
*
* If no errors, then call QDBRTVFD passing the address of the
* User Space as the receiver variable. To accomplish this,
* assign the address of QDB-QDBFH to SPACE-POINTER and then
* pass QDB-QDBFH.
*
SET ADDRESS OF QDB-QDBFH TO SPACE-POINTER.
*
MOVE 16776704 TO SPACE-SIZE.
MOVE "FILD0100" TO FORMAT-NAME-1.
*
CALL "QDBRTVFD" USING QDB-QDBFH, SPACE-SIZE, FILE-USED,
FORMAT-NAME-1, FILE-NAME,
FORMAT-NAME-PARM, OVERRIDES,
SYSTEM OF MISC, FORMAT-1, QUS-EC.
*
* Check for errors on QDBRTVFD
*
IF BYTES-AVAILABLE OF QUS-EC > 0
MOVE "QDBRTVFD" TO API-NAME,
PERFORM API-ERROR-FOUND.
*****************************************************************
API-ERROR-FOUND.
*
* Log any error encountered, and exit the program
*
DISPLAY API-NAME.
DISPLAY EXCEPTION-ID OF QUS-EC.
PERFORM PROGRAM-DONE.
*****************************************************************
PROGRAM-DONE.
*
* Exit the program
*
STOP RUN.