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