This example shows you the steps necessary to package your product like IBM products. This program also works for OPM COBOL.
IDENTIFICATION DIVISION.
*****************************************************************
*****************************************************************
*
*Program Name: SFTWPRDEX
*
*Language: COBOL
*
*Descriptive Name: Software Product Example
*
*Description: This example shows you the steps necessary to
* package your product like IBM products.
*
*Header Files Included: QUSEC - Error Code Parameter
* QSZCRTPD - Create Product Definition API
* QSZCRTPL - Create Product Load API
* QSZPKGPO - Package Product Option API
*
*****************************************************************
*****************************************************************
*
PROGRAM-ID. SFTWPRDEX.
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.
*
* Create Product Definition API Include
*
COPY QSZCRTPD OF QSYSINC-QLBLSRC.
*
* Create Product Load API Include
*
COPY QSZCRTPL OF QSYSINC-QLBLSRC.
*
* Package Product Option API Include
*
COPY QSZPKGPO OF QSYSINC-QLBLSRC.
*
* Error message text
*
01 BAD-NEWS.
05 TEXT1 PIC X(14) VALUE "Failed in API ".
05 API-NAME PIC X(10).
05 TEXT2 PIC X(11) VALUE "with error ".
05 EXCEPTION-ID PIC X(07).
*
* Compile Time Array
*
01 OBJ-INFO.
05 ELEMENT-01 PIC X(41)
VALUE "ABCPGMMRM1*PGM 000050010ABCABCV3R1M0".
05 ELEMENT-02 PIC X(41)
VALUE "ABCPGMMRM2*PGM 000050010ABCABCV3R1M0".
05 ELEMENT-03 PIC X(41)
VALUE "ABCPGMMRI1*PGM 000029240ABCABCV3R1M0".
05 ELEMENT-04 PIC X(41)
VALUE "ABCPGMMRI2*PGM 000029240ABCABCV3R1M0".
05 ELEMENT-05 PIC X(41)
VALUE "ABCPGM *PGM 000050010ABCABCV3R1M0".
05 ELEMENT-06 PIC X(41)
VALUE "QCLSRC *FILE 000029240ABCABCV3R1M0".
05 ELEMENT-07 PIC X(41)
VALUE "ABCDSPF *FILE 000029240ABCABCV3R1M0".
05 ELEMENT-08 PIC X(41)
VALUE "ABCPF *FILE 000029240ABCABCV3R1M0".
05 ELEMENT-09 PIC X(41)
VALUE "ABCMSG *MSGF 000029240ABCABCV3R1M0".
05 ELEMENT-10 PIC X(41)
VALUE "ABC *CMD 000029240ABCABCV3R1M0".
05 ELEMENT-11 PIC X(41)
VALUE "ABCPNLGRP *PNLGRP 000029240ABCABCV3R1M0".
05 ELEMENT-12 PIC X(41)
VALUE "ABC0050 *PRDDFN 000050010ABCABCV3R1M0".
05 ELEMENT-13 PIC X(41)
VALUE "ABC0050 *PRDLOD 000050010ABCABCV3R1M0".
05 ELEMENT-14 PIC X(41)
VALUE "ABC0029 *PRDLOD 000029240ABCABCV3R1M0".
05 ELEMENT-15 PIC X(41)
VALUE "ABC *LIB 000050010ABCABCV3R1M0".
*
01 OBJECT-TABLE REDEFINES OBJ-INFO.
05 OBJ-INFO-I OCCURS 15 TIMES.
10 OBJ-NAME PIC X(10).
10 OBJ-TYPE PIC X(10).
10 PRD-OPT-ID PIC X(04).
10 PRD-OPT-LD PIC X(04).
10 LP-ID PIC X(13).
*
* Change Object Information parameter
*
01 COBJI.
05 NUMKEY PIC S9(09) VALUE 3 BINARY.
05 KEY13 PIC S9(09) VALUE 13 BINARY.
05 LEN13 PIC S9(09) VALUE 4 BINARY.
05 PID13 PIC X(04).
05 KEY12 PIC S9(09) VALUE 12 BINARY.
05 LEN12 PIC S9(09) VALUE 4 BINARY.
05 LID12 PIC X(04).
05 KEY5 PIC S9(09) VALUE 5 BINARY.
05 LEN5 PIC S9(09) VALUE 13 BINARY.
05 LP5 PIC X(13).
*
* Miscellaneous data
*
01 MISC.
05 FIRST-ERR PIC X(01) VALUE "0".
05 PROD-ID PIC X(07) VALUE "0ABCABC".
05 PROD-NAME PIC X(20) VALUE "ABC0050 ABC".
05 RLS-LVL PIC X(06) VALUE "V3R1M0".
05 NBR-OPTS PIC S9(09) VALUE 1 BINARY.
05 NBR-LANGS PIC S9(09) VALUE 1 BINARY.
05 TEXT-DESC PIC X(50) VALUE "ABC Product".
05 PUB-AUT PIC X(10) VALUE "*USE".
05 NBR-ADD-LB PIC S9(09) VALUE 0 BINARY.
05 NBR-PE PIC S9(09) VALUE 1 BINARY.
05 NBR-FLDRS PIC S9(09) VALUE 0 BINARY.
05 OBJNAM PIC X(20).
05 PROD-ID-NM PIC X(10).
05 SEC-LANG PIC X(10).
05 I PIC S9(09) BINARY.
05 RTN-LIB PIC X(10).
05 OBJ-TYPE-2 PIC X(10).
05 REPKG PIC X(04) VALUE "*YES".
05 ALWCHG PIC X(05) VALUE "*NO".
*
* Beginning of Mainline
*
PROCEDURE DIVISION.
MAIN-LINE.
*
* 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 LENGTH OF QUS-EC TO BYTES-PROVIDED OF QUS-EC.
*
* Create Product Definition Object - ABC0050
*
PERFORM PRDDFN. (1)
*
* Create Product Load Objects - ABC0050 (MRM) and ABC0029 (MRI)
*
PERFORM PRDLOD. (2)
*
* Change Object Description for all objects associated with
* ABC Product.
*
PERFORM COBJD. (3)
*
* Package the ABC Product so that all the SAVLICPGM, RSTLIBPGM,
* and DLTLICPGM commands work with the product.
*
PERFORM PKGPO. (4)
*
* All done, product is ready to ship.
*
STOP RUN.
*
* End of MAINLINE
*
*****************************************************************
*****************************************************************
*
* Subroutine: PRDDFN
*
* Descriptive Name: Create product definitions.
*
* Description: This subroutine will create the product definition
* ABC0050 for the ABC Product.
*
*****************************************************************
*****************************************************************
*
PRDDFN.
*
* Setup for Product Definition
* Fill Product Definition Information Parameter
*
MOVE PROD-ID OF MISC TO PID OF QSZ-PRD-INF.
MOVE RLS-LVL OF MISC TO RLS-LVL OF QSZ-PRD-INF.
MOVE "ABCMSG" TO MSG-FILE OF QSZ-PRD-INF.
MOVE "*CURRENT" TO FST-CPYRT OF QSZ-PRD-INF.
MOVE "*CURRENT" TO CUR-CPYRT OF QSZ-PRD-INF.
MOVE "941201" TO RLS-DATE OF QSZ-PRD-INF.
MOVE "*NO" TO ALW-MULT-RLS OF QSZ-PRD-INF.
MOVE "*PHONE" TO REG-ID-TYPE OF QSZ-PRD-INF.
MOVE "5072535010" TO REG-ID-VAL OF QSZ-PRD-INF.
*
* Fill Product Load Parameter
*
MOVE "0000" TO OPT OF QSZ-PRD-OPT.
MOVE "ABC0001" TO MSG-ID OF QSZ-PRD-OPT.
MOVE "*NODYNNAM" TO ALW-DYN-NAM OF QSZ-PRD-OPT.
MOVE "5001" TO COD-LOD OF QSZ-PRD-OPT.
MOVE SPACES TO RESERVED OF QSZ-PRD-OPT.
*
* Fill Language Load List Parameter
*
MOVE "2924" TO LNG-LOD OF QSZ-LNG-LOD.
MOVE "0000" TO OPT OF QSZ-LNG-LOD.
MOVE SPACES TO RESERVED OF QSZ-LNG-LOD.
*
* Create the Product Definition for the ABC Product
*
MOVE 1 TO NBR-OPTS.
MOVE 1 TO NBR-LANGS.
CALL "QSZCRTPD" USING PROD-NAME, QSZ-PRD-INF, QSZ-PRD-OPT,
NBR-OPTS, QSZ-LNG-LOD, NBR-LANGS,
TEXT-DESC, PUB-AUT, 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
MOVE "QSZCRTPD" TO API-NAME,
PERFORM ERRCOD.
*
*****************************************************************
*****************************************************************
*
* Subroutine: PRDLOD
*
* Descriptive Name: Create product loads.
*
* Description: This subroutine will create the product loads,
* ABC0050 and ABC0029, for the ABC Product.
*
*****************************************************************
*****************************************************************
*
PRDLOD.
*
* Setup for Product Load for MRM Objects
* Fill Product Load Information Parameter
*
MOVE PROD-ID OF MISC TO PID OF QSZ-LOD-INF.
MOVE RLS-LVL OF MISC TO RLS-LVL OF QSZ-LOD-INF.
MOVE "0000" TO OPT OF QSZ-LOD-INF.
MOVE "*CODE" TO LOD-TYPE OF QSZ-LOD-INF.
MOVE "*CODEDFT" TO LOD-ID OF QSZ-LOD-INF.
MOVE "*PRDDFN" TO REG-ID-TYPE OF QSZ-LOD-INF.
MOVE SPACES TO REG-ID-VAL OF QSZ-LOD-INF.
MOVE "*CURRENT" TO MIN-TGT-RLS OF QSZ-LOD-INF.
MOVE SPACES TO RESERVED OF QSZ-LOD-INF.
*
* Fill Principal Library Information Parameter
*
MOVE "ABC" TO DEV-LIB OF QSZ-LIB-INF.
MOVE "ABC" TO PRIM-LIB OF QSZ-LIB-INF.
MOVE "ABCPGMMRM2" TO POST-EXIT-PGM OF QSZ-LIB-INF.
*
* Fill Preoperation Exit Programs Parameter
*
MOVE "ABCPGMMRM1" TO PRE-EXT-PGM OF QSZ-PRE-EXT.
MOVE "ABC" TO DEV-LIB OF QSZ-PRE-EXT.
*
* Fill Additional Library List Parameter
* None
*
* Fill Folder List Parameter
* None
*
* Let's create the product load for the ABC Product - MRM Objects
*
MOVE "ABC0050" TO PROD-ID-NM.
MOVE SPACES TO SEC-LANG.
*
CALL "QSZCRTPL" USING PROD-ID-NM, QSZ-LOD-INF, SEC-LANG,
QSZ-LIB-INF, QSZ-ADD-LIB,
NBR-ADD-LB, QSZ-PRE-EXT, NBR-PE,
QSZ-FLR-LST, NBR-FLDRS, TEXT-DESC,
PUB-AUT, 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
MOVE "QSZCRTPL" TO API-NAME,
PERFORM ERRCOD.
*
* Setup for Product Load for MRI Objects
* Fill Product Load Information Parameter
*
MOVE "*LNG" TO LOD-TYPE OF QSZ-LOD-INF.
MOVE "2924" TO LOD-ID OF QSZ-LOD-INF.
*
* Fill Principal Library Information Parameter
*
MOVE "ABCPGMMRI2" TO POST-EXIT-PGM OF QSZ-LIB-INF.
*
* Fill Preoperation Exit Programs Parameter
*
MOVE "ABCPGMMRI1" TO PRE-EXT-PGM OF QSZ-PRE-EXT.
*
* Fill Additional Library List Parameter
* None
*
* Fill Folder List Parameter
* None
*
* Let's create the product load for the ABC Product - MRI Objects
*
MOVE "ABC0029" TO PROD-ID-NM.
MOVE "ABC2924" TO SEC-LANG.
*
CALL "QSZCRTPL" USING PROD-ID-NM, QSZ-LOD-INF, SEC-LANG,
QSZ-LIB-INF, QSZ-ADD-LIB,
NBR-ADD-LB, QSZ-PRE-EXT, NBR-PE,
QSZ-FLR-LST, NBR-FLDRS, TEXT-DESC,
PUB-AUT, 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
MOVE "QSZCRTPL" TO API-NAME,
PERFORM ERRCOD.
*
*****************************************************************
*****************************************************************
*
* Subroutine: COBJD
*
* Descriptive Name: Change object descriptions for ABC Product.
*
* Description: This subroutine will change the object
* descriptions for all objects that make up the
* ABC Product. Currently that is 15 objects. They
* are listed at the end of this program.
*
*****************************************************************
*****************************************************************
*
COBJD.
*
* Need to associate all objects with the ABC Product
*
PERFORM CHG-OBJD VARYING I FROM 1 BY 1 UNTIL I > 15.
*
CHG-OBJD.
STRING OBJ-NAME(I), "ABC" DELIMITED BY SIZE INTO OBJNAM.
MOVE LP-ID(I) TO LP5.
MOVE PRD-OPT-ID(I) TO PID13.
MOVE PRD-OPT-LD(I) TO LID12.
MOVE OBJ-TYPE(I) TO OBJ-TYPE-2.
*
CALL "QLICOBJD" USING RTN-LIB, OBJNAM, OBJ-TYPE-2,
COBJI, 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
MOVE "QLICOBJD" TO API-NAME,
PERFORM ERRCOD.
*****************************************************************
*****************************************************************
*
* Subroutine: PKGPO
*
* Descriptive Name: Package software ABC Product.
*
* Description: This subroutine will package the ABC Product.
* It makes sure that all objects exist that are
* associated with the product.
*
*****************************************************************
*****************************************************************
*
PKGPO.
*
* Setup for packing the ABC Product.
* Fill Product Option Information Parameter
*
MOVE "0000" TO OPT OF QSZ-PRD-OPT-INF.
MOVE PROD-ID OF MISC TO PID OF QSZ-PRD-OPT-INF.
MOVE RLS-LVL OF MISC TO RLS-LVL OF QSZ-PRD-OPT-INF.
MOVE "*ALL" TO LOD-ID OF QSZ-PRD-OPT-INF.
MOVE SPACES TO RESERVED OF QSZ-PRD-OPT-INF.
*
* Let's package the ABC Product.
*
CALL "QSZPKGPO" USING QSZ-PRD-OPT-INF, REPKG,
ALWCHG, 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
MOVE "QSZPKGPO" TO API-NAME,
PERFORM ERRCOD.
*
*****************************************************************
*****************************************************************
*
* Subroutine: ERRCOD
*
* Descriptive Name: Process API errors.
*
* Description: This subroutine will print a line to a spooled
* file if any errors are returned in the error code
* parameter.
*
*****************************************************************
*****************************************************************
*
ERRCOD.
*
* Process errors returned from the API.
*
* If first error found, then open QPRINT *PRTF
*
IF FIRST-ERR = "0"
OPEN OUTPUT LISTING,
MOVE "1" TO FIRST-ERR.
*
* Output the error and the API that received the error
*
MOVE EXCEPTION-ID OF QUS-EC TO EXCEPTION-ID OF BAD-NEWS.
WRITE LIST-LINE FROM BAD-NEWS.