CL reading files

CLPs can read database files.

CLP reading a file

The code listed on this page represents a CL program (CLP) I wrote as a pre-compiler for RPG programs. Typically, an RPG programmer might perform some file override operations before compiling a program. I stuck formatted text in the RPG source file, and wrote this program to read the source code and perform any file override operations before compiling the RPG program. It sends messages to the user if the compile was successful, or not. It does not remove the old program object unless the compile is successful.

/*===================================================================*/
/* Program and Declarative Section:                                  */
/*===================================================================*/
             PGM        PARM(&PGM &OBJLIB &SRCFILE &SRCLIB &SRCMBR)

             DCL        VAR(&PGM) TYPE(*CHAR) LEN(10)
             DCL        VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
             DCL        VAR(&SRCFILE) TYPE(*CHAR) LEN(10)
             DCL        VAR(&OBJLIB) TYPE(*CHAR) LEN(10)
             DCL        VAR(&SRCMBR) TYPE(*CHAR) LEN(10)
             DCL        VAR(&FMFILE) TYPE(*CHAR) LEN(10)
             DCL        VAR(&TOFILE) TYPE(*CHAR) LEN(10)
             DCL        VAR(&CNT) TYPE(*DEC) LEN(3 0)
             DCL        VAR(&LEN) TYPE(*DEC) LEN(3 0)
             DCL        &ERRORSW *LGL
             DCL        &MSGID *CHAR LEN(7)
             DCL        &MSGDTA *CHAR LEN(100)
             DCLF       FILE(*LIBL/QRPGSRC)

/*===================================================================*/
/* Define Global Monitor Messages:                                   */
/*   Define monitor messages to prevent a process from sending CPF   */
/*   error messages to the user, or operator. Point to a error       */
/*   handling section of the program.                                */
/*===================================================================*/

             MONMSG     MSGID(CPF0000) EXEC(GOTO ERROR)

             IF         COND(&SRCMBR *EQ '*PGM') THEN(CHGVAR +
                          VAR(&SRCMBR) VALUE(&PGM))

             OVRDBF     FILE(QRPGSRC) TOFILE(&SRCLIB/&SRCFILE) +
                          MBR(&SRCMBR)

/*-------------------------------------------------------------------*/
/* Read the data base file, EOF go to END. This example shows a      */
/* simple read of a record, with a monitor for end-of-file.          */
/*-------------------------------------------------------------------*/

 READ:       RCVF
             MONMSG     MSGID(CPF0864) EXEC(GOTO CMDLBL(COMPILE))
             MONMSG     MSGID(CPF0859)
             MONMSG     MSGID(CPF0860)
             MONMSG     MSGID(CPF0861)
             CHGVAR     VAR(&CNT) VALUE(9)
             CHGVAR     VAR(&LEN) VALUE(0)

             IF         COND(%SST(&SRCDTA 6 1) *EQ 'F') THEN(GOTO +
                          CMDLBL(COMPILE))

/*-------------------------------------------------------------------*/
/* Test the source record to see if an override spec has been found  */
/*-------------------------------------------------------------------*/

             IF         COND(%SST(&SRCDTA 7 3) *EQ '*V:') THEN(DO)
 NEXT:       CHGVAR     VAR(&CNT) VALUE(&CNT + 1)
             CHGVAR     VAR(&LEN) VALUE(&LEN + 1)
             IF         COND(&LEN *GT 21) THEN(GOTO CMDLBL(READ))
             IF         COND(%SST(&SRCDTA &CNT 1) = '.') THEN(DO)
                  CHGVAR  VAR(&LEN) VALUE(&LEN - 1)
                  CHGVAR  VAR(&FMFILE) VALUE(%SST(&SRCDTA 10 &LEN))
                  CHGVAR  VAR(&CNT) VALUE(&CNT + 1)
                  CHGVAR  VAR(&TOFILE) VALUE(%SST(&SRCDTA &CNT 10))
OVRDBF     FILE(&FMFILE) TOFILE(*LIBL/&TOFILE)
             GOTO       CMDLBL(READ)
             ENDDO
             GOTO       NEXT
             ENDDO

             GOTO       CMDLBL(READ)

COMPILE:

/*------------------------------------------------------------------*/
/* Compile the program into QTEMP. If the compile fails send error  */
/* message and escape. If the compile was successful, remove the    */
/* superceded program and move the new program from QTEMP to the    */
/* object library.                                                  */
/*------------------------------------------------------------------*/

             CRTRPGPGM  PGM(QTEMP/&PGM) SRCFILE(&SRCLIB/&SRCFILE) +
                          SRCMBR(&SRCMBR) USRPRF(*USER)
             MONMSG     MSGID(QRG9001) EXEC(GOTO CMDLBL(PGMERR))

             DLTPGM     PGM(&OBJLIB/&PGM)
             MONMSG     MSGID(CPF2105)

             MOVOBJ     OBJ(QTEMP/&PGM) OBJTYPE(*PGM) TOLIB(&OBJLIB)
             SNDPGMMSG  MSG('Program compile completed normally ') +
                          MSGTYPE(*COMP)
             RETURN

/*==================================================================*/
/* Error Handling Section:                                          */
/*   Define a method of sending diagnostic and escape messages      */
/*   to prevent CPF messages from being passed to the user for      */
/*   reply, or action, (C G I R D S).                               */
/*==================================================================*/

ERROR:
             IF         COND(&ERRORSW) THEN(SNDPGMMSG MSGID(CPF9999) +
                          MSGF(*LIBL/QCPFMSG) MSGTYPE(*ESCAPE)) /* +
                          Func chk */
             CHGVAR     VAR(&ERRORSW) VALUE('1')

PGMERR:    SNDPGMMSG MSGID(CPD0006) +
             MSGF(*LIBL/QCPFMSG) MSGDTA('0000Program object ' *CAT +
             &PGM *TCAT ' not created in ' *CAT &OBJLIB) +
             MSGTYPE(*DIAG)
             SNDPGMMSG  MSGID(CPF0002) MSGF(*LIBL/QCPFMSG) +
                          MSGTYPE(*ESCAPE)

 ESCAPE:     RCVMSG     MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID)
             SNDPGMMSG  MSGID(&MSGID) MSGF(*LIBL/QCPFMSG) +
                          MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)

ENDPGM  

CLP reading based on key

In the sample below the CLP is designed to read from a database file based on a specific key. Unlike RPG, where there is a SETLL op code, CL must perform an override to the file. The override instruction tells the program there are two keys, for a length of twenty characters. When the file is open, it should be positioned so they RCVF fetches the first record that matches the keys values provided for the variables.

/*********************************************************************/
/* PROGRAM NAME - SC0380CL                                           */
/*                                                                   */
/* FUNCTION     - This program was created for the workbench program */
/*                to allow objects to be compiled.                   */
/*                                                                   */
/* PROGRAMMER   - STEVE CROY           99/99/9999 iSoftwerks, Inc    */
/*********************************************************************/
/*********************************************************************/
/*                   MODIFICATION LOG                                */
/*                                                                   */
/*   DATE    PROGRAMMER      DESCRIPTION                             */
/*********************************************************************/
             PGM        PARM(&OBJNAM &OBJTYP)

             DCL        VAR(&LNGTEXT) TYPE(*CHAR) LEN(255) +
                          VALUE('Object not found. Press ENTER to +
                          continue.')
             DCL        VAR(&TEXTLEN) TYPE(*INT)
             DCL        VAR(&TXTTITLE) TYPE(*CHAR) LEN(7)
             DCL        VAR(&TXTMSGF) TYPE(*CHAR) LEN(20)
             DCL        VAR(&ERRCODE) TYPE(*CHAR) LEN(16)
             DCL        VAR(&MSGTTLE) TYPE(*CHAR) LEN(27)
             DCL        VAR(&OBJTYP) TYPE(*CHAR) LEN(10)
             DCL        VAR(&OBJNAM) TYPE(*CHAR) LEN(10)
             DCL        VAR(&JOBTYP) TYPE(*CHAR) LEN(1)
             DCL        VAR(&FILEKEY) TYPE(*CHAR) LEN(20)
             DCL        VAR(&EXISTS) TYPE(*LGL)
             DCL        VAR(&DFTLIB) TYPE(*CHAR) LEN(10)
             DCLF SCOBJSPF

             MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(EXITPGM))

             RTVJOBA    TYPE(&JOBTYP)
             RTVDTAARA  DTAARA(SC0000DA) RTNVAR(&DFTLIB)

             CHGVAR     VAR(&TEXTLEN) VALUE(42)
             CHGVAR     VAR(%SST(&FILEKEY 1 10)) VALUE(&OBJNAM)
             CHGVAR     VAR(%SST(&FILEKEY 11 10)) VALUE(&OBJTYP)

             OVRDBF     FILE(SCOBJSPF) TOFILE(SCOBJSPF) +
                          POSITION(*KEYAE 2 *N &FILEKEY)
             RCVF
             MONMSG     MSGID(CPF0864) EXEC(DO)
             CALLSUBR   SUBR(@MESSAGES)
             GOTO EXITPGM
             ENDDO

             SELECT
             WHEN       COND(&OBJTYP *EQ 'PF') +
                          THEN(CALLSUBR SUBR(@PFILES))
             WHEN       COND(&OBJTYP *EQ 'LF') +
                          THEN(CALLSUBR SUBR(@LOGICAL))
             WHEN       COND(%SST(&OBJTYP 1 4) *EQ 'DSPF') +
                          THEN(CALLSUBR SUBR(@DISPLAY))
             WHEN       COND(&OBJTYP *EQ 'MNUCMD') +
                          THEN(CALLSUBR SUBR(@MENUS))
             WHEN       COND(&OBJTYP *EQ 'PRTF') +
                          THEN(CALLSUBR SUBR(@PRINTER))
             WHEN       COND(&OBJTYP *EQ 'CMD') THEN(CALLSUBR +
                          SUBR(@COMMANDS))
             WHEN       COND(&EXOBSR *EQ 'QPNLSRC') THEN(CALLSUBR +
                          SUBR(@PNLGROUP))
             OTHERWISE  CMD(CALLSUBR SUBR(@PROGRAMS))
             ENDSELECT

 EXITPGM:    RETURN

             DLTOVR     FILE(EXPOBJPF)

/*===================================================================*/
/* BEGIN SUBROUTINE SEGMENT OF PROGRAM -- CREATE FILES               */
/*===================================================================*/

 FILES:      SUBR       SUBR(@PFILES)

             CHGVAR     VAR(&EXISTS) VALUE('1')

             CHKOBJ     OBJ(&DFTLIB/&EXOBNM) OBJTYPE(*FILE)
             MONMSG     MSGID(CPF9801) EXEC(CHGVAR VAR(&EXISTS) +
                          VALUE('0'))

             IF         COND(&EXISTS)   THEN(DO)
             CHGPF      FILE(&DFTLIB/&EXOBNM) +
                          SRCFILE(EXPLIB/&EXOBSR) SRCMBR(&EXOMBR)
             ENDDO

             IF         COND(*NOT &EXISTS) THEN(DO)
             ?          CRTPF FILE(&DFTLIB/&EXOBNM) +
                          SRCFILE(&DFTLIB/&EXOBSR) RECOVER(*AFTIPL) +
                          SIZE(*NOMAX)
             ENDDO
             ENDSUBR
/*===================================================================*/
/* CREATE VIEWS                                                      */
/*===================================================================*/
 VIEWS:      SUBR       SUBR(@LOGICAL)

             DLTF       FILE(&DFTLIB/&EXOBNM)
             MONMSG     MSGID(CPF0000)
             ?          CRTLF FILE(&DFTLIB/&EXOBNM) +
                          SRCFILE(&DFTLIB/QDDSSRC) RECOVER(*AFTIPL)
             ENDSUBR

/*===================================================================*/
/* CREATE DISPLAY FILES                                              */
/*===================================================================*/
 DISPLAY:    SUBR       SUBR(@DISPLAY)

             IF         COND(&OBJTYP *EQ 'DSPF36') THEN(CRTS36DSPF +
                          DSPFILE(&DFTLIB/&EXOBNM) SRCMBR(&EXOMBR) +
                          SRCFILE(&DFTLIB/QS36SRC) REPLACE(*YES))
             ELSE       CMD(DO)
             ?          CRTDSPF FILE(&DFTLIB/&EXOBNM) +
                          SRCFILE(&DFTLIB/&EXOBSR) SRCMBR(&EXOMBR)
             ENDDO

             ENDSUBR
/*===================================================================*/
/* CREATE PRINTER FILES                                              */
/*===================================================================*/
 PRINTER:    SUBR       SUBR(@PRINTER)
             ?          CRTPRTF FILE(&DFTLIB/&EXOBNM) +
                          SRCFILE(&DFTLIB/&EXOBSR)
             ENDSUBR
/*===================================================================*/
/* CREATE COMMANDS                                                   */
/*===================================================================*/
 COMMAND:    SUBR       SUBR(@COMMANDS)
             ?          CRTCMD CMD(&DFTLIB/&EXOBNM) +
                          SRCFILE(&DFTLIB/QCMDSRC)
             ENDSUBR
/*===================================================================*/
/* CREATE SDA MENUS                                                  */
/*===================================================================*/
SDAMENUS:    SUBR       SUBR(@MENUS)
             ?          CRTMNU MENU(&DFTLIB/&EXOBNM) TYPE(*DSPF) +
                          CMDLIN(*NONE)
             ENDSUBR
/*===================================================================*/
/* CREATE PANEL GROUP                                                */
/*===================================================================*/
PNLGROUP:    SUBR       SUBR(@PNLGROUP)
             ?          CRTPNLGRP PNLGRP(&DFTLIB/&EXOBNM) +
                          SRCFILE(&DFTLIB/QPNLSRC)
             ENDSUBR
/*===================================================================*/
/* CREATE PROGRAM OBJECTS                                            */
/*===================================================================*/
 PROGRAMS:   SUBR       SUBR(@PROGRAMS)

             SELECT
             WHEN       COND(&EXOBTP *EQ 'CLP') THEN(CRTCLPGM +
                          PGM(&DFTLIB/&EXOBNM) SRCFILE(&DFTLIB/QCLSRC))
             WHEN       COND(&EXOBTP *EQ 'CLLE') THEN(CRTBNDCL +
                          PGM(&DFTLIB/&EXOBNM) SRCFILE(&DFTLIB/QCLSRC))
             OTHERWISE  CMD(DO)
             ?          CRTPGMOBJ PGM(&DFTLIB/&EXOBNM) +
                          SRCFILE(&DFTLIB/&EXOBSR) OBJECTTYP(&EXOBTP)
                          ENDDO
             ENDSELECT
             ENDSUBR
/*===================================================================*/
/* GENERIC MESSAGE PANEL                                             */
/*===================================================================*/
 MESSAGES:   SUBR       SUBR(@MESSAGES)
             CALL       PGM(QUILNGTX) PARM(&LNGTEXT &TEXTLEN +
                          &TXTTITLE &TXTMSGF &ERRCODE)
             ENDSUBR

             ENDPGM