CL Programs with Subroutines

CL can use subroutines much like RPG.

Creating subroutines in a CLP

The Subroutine (SUBR) command may be used in a CL program or procedure, along with the End Subroutine (ENDSUBR) command, to encapsulate a group of commands that are specific to that subroutine. The name of the subroutine, used by the CALLSUBR command, is identified by the SUBR parameter on the SUBR command.

/*********************************************************************/
/* Program Name -CSG200CL                                            */
/*                                                                   */
/* Function     - This program was designed to read a directory and  */
/*                decrypt inbound files.                             */
/*                                                                   */
/*                                                                   */
/* Programmer   - Steve Croy                      99/99/9999         */
/*********************************************************************/

             PGM

             DCLPRCOPT  DFTACTGRP(*NO) ACTGRP(CSGRCV) +
                          BNDSRVPGM((ISI000SV))

             DCL   VAR(&IMPFOLDER) TYPE(*CHAR) LEN(200)
             DCL   VAR(&DIRECTORY) TYPE(*CHAR) LEN(200)
             DCL   VAR(&ARCFOLDER) TYPE(*CHAR) LEN(200)
             DCL   VAR(&ERRFOLDER) TYPE(*CHAR) LEN(200)
             DCL   VAR(&MSGKEY)    TYPE(*CHAR) LEN(4)
             DCL   VAR(&PGMNAME)   TYPE(*CHAR) LEN(10)
             DCL   VAR(&FUNCTION)  TYPE(*CHAR) LEN(25)
             DCL   VAR(&PROGRAM)   TYPE(*CHAR) LEN(15)
             DCL   VAR(&SENDER)    TYPE(*CHAR) LEN(80)
             DCL   VAR(&FILEPATH)  TYPE(*CHAR) LEN(200)
             DCL   VAR(&newPath)   TYPE(*CHAR) LEN(200)
             DCL   VAR(&JOBTYPE)   TYPE(*CHAR) LEN(1)
             DCL   VAR(&FILETYPE)   TYPE(*CHAR) LEN(1)
             DCL   VAR(&PHRASE)    TYPE(*CHAR) LEN(200)
             DCL   VAR(&CSGFTP)    TYPE(*CHAR) LEN(15) +
                          VALUE('CSGFTP')
             DCL   VAR(&SYSNAME)   TYPE(*CHAR) LEN(8)
             DCL        VAR(&POS) TYPE(*UINT) LEN(2)
             DCL        VAR(&QT) TYPE(*CHAR) LEN(1) VALUE('''')
             DCL        VAR(&G) TYPE(*UINT) LEN(2)
             DCL        VAR(&Z7CMD) TYPE(*CHAR) LEN(255)
             DCL        VAR(&SUBJECT) TYPE(*CHAR) LEN(50)  
             dcl        var(&message) type(*char) len(80)  
             dcl        var(&reason)  type(*char) len(80)  
             dcl        var(&error)   type(*lgl)  len(1)   
             dcl        var(&error)   type(*lgl)  len(1)   

             RTVJOBA    TYPE(&JOBTYPE)
             RTVNETA    SYSNAME(&SYSNAME)

/*-------------------------------------------------------------------*/
/* Get the program name                                              */
/*-------------------------------------------------------------------*/

             SNDPGMMSG  MSG(' ') TOPGMQ(*SAME) MSGTYPE(*INFO) +
                          KEYVAR(&MSGKEY)
             RCVMSG     PGMQ(*SAME) MSGTYPE(*INFO) RMV(*YES) +
                          SENDER(&SENDER)
             CHGVAR     VAR(&PGMNAME) VALUE(%SST(&SENDER 56 10))
             CHGVAR     VAR(&PROGRAM) VALUE(&PGMNAME)

/*-------------------------------------------------------------------*/
/* Add FTP manager library to the library list.                      */
/* Use SFTP to get the inbound data from CSG.                        */
/*-------------------------------------------------------------------*/

             IF         COND(&SYSNAME *EQ 'TEST400') THEN(GOTO +
                          CMDLBL(GETNAME))
             ADDLIBLE   LIB(ALLFTM100)
             MONMSG     MSGID(CPF0000)

             FTMSFTPEXC FTPDFN(CSGINBOUND) LCLFIL(' ') RMTFIL(' ')

/*-------------------------------------------------------------------*/
/* Get the folder where the CSG data is to be Archived               */
/*-------------------------------------------------------------------*/
GETNAME:
             ADDLIBLE   LIB(ALLFTM100)
             MONMSG     MSGID(CPF0000)
             CHGVAR     VAR(&FUNCTION) VALUE('IMPFOLDER')
             CALL       PGM(ISI005RP) PARM(&PROGRAM &FUNCTION &IMPFOLDER)
             CHGVAR     VAR(&DIRECTORY) VALUE(&IMPFOLDER)
             CHGVAR     VAR(&FUNCTION) VALUE('ARCFOLDER')
             CALL       PGM(ISI005RP) PARM(&PROGRAM &FUNCTION &ARCFOLDER)
             CHGVAR     VAR(&FUNCTION) VALUE('ERRFOLDER')
             CALL       PGM(ISI005RP) PARM(&PROGRAM &FUNCTION +
                          &ERRFOLDER) /* sac04 */
             CHGVAR     VAR(&FUNCTION) VALUE('PHRASE')
             CALL       PGM(ISI005RP) PARM(&CSGFTP &FUNCTION &PHRASE)

/*-------------------------------------------------------------------*/
/* Read the files in the folder and move them to archive             */
/*-------------------------------------------------------------------*/

 LIST:       CALL       PGM(ISI010RP) PARM(&IMPFOLDER)

 READ:       DOUNTIL    COND(&FILEPATH *EQ '*****')
             CALL       PGM(ISI020RP) PARM(&FILEPATH)
             IF         COND(&FILEPATH *NE '*****') THEN(DO)

/*-------------------------------------------------------------------*/
/* Check the file name to determine if the file needs decrypting.    */
/*-------------------------------------------------------------------*/

             CHGVAR     VAR(&FILETYPE) VALUE(' ')

 JOBFILE:    IF         COND(%SCAN('.job' &FILEPATH) *NE 0 *OR +
                          %SCAN('.JOB' &FILEPATH) *NE 0) +
                          THEN(CHGVAR VAR(&FILETYPE) VALUE('J'))
             IF         COND(&FILETYPE *EQ 'J') THEN(GOTO +
                          CMDLBL(CALLS)) 
 Decrypt:
             IF         COND(%SCAN('.pgp' &FILEPATH) *NE 0 *OR +
                          %SCAN('.PGP' &FILEPATH) *NE 0) +
                          THEN(CHGVAR VAR(&FILETYPE) VALUE('P'))
             IF         COND(&FILETYPE *EQ 'P') THEN(GOTO +
                          CMDLBL(CALLS)) 
 UNZIP:
             IF         COND(%SCAN('.zip' &FILEPATH) *NE 0 *OR +
                          %SCAN('.ZIP' &FILEPATH) *NE 0) +
                          THEN(CHGVAR VAR(&FILETYPE) VALUE('Z'))

 gzZIP:
             IF         COND(%SCAN('.gz' &FILEPATH) *NE 0 *OR +
                          %SCAN('.GZ' &FILEPATH) *NE 0) +
                          THEN(CHGVAR VAR(&FILETYPE) VALUE('G'))

CALLS:       

             SELECT
             WHEN       COND(&FILETYPE *EQ 'P') THEN(CALLSUBR +
                          SUBR(DECRYPTED)) /* 'PGP Encrypted' */
             WHEN       COND(&FILETYPE *EQ 'Z') THEN(CALLSUBR +
                          SUBR(UNZIPPED)) /* 'Zipped file' */
             WHEN       COND(&FILETYPE *EQ 'G') THEN(CALLSUBR +
                          SUBR(GUNZIP)) /* ' GZipped file' */
             WHEN       COND(&FILETYPE *EQ 'J') THEN(CALLSUBR +
                          SUBR(LOGJOB)) /* 'Job file' */
             ENDSELECT
 ENDIF:      ENDDO

 ENDLOOP:    ENDDO

             CHGVAR     VAR(&DIRECTORY) VALUE(&DIRECTORY *TCAT '*.*')
             CHGAUT     OBJ(&DIRECTORY) USER(*PUBLIC) DTAAUT(*RWX) +
                          OBJAUT(*ALL)

             SBMJOB     CMD(CALL PGM(CSG205CL)) JOB(MOVCSGDTA) +
                          JOBQ(CYCJOBQ)

 TERMINATE:
             RETURN
 /*-----------------------------------------------------------------*/
 PGPPROC:    SUBR       SUBR(DECRYPTED)

             PGPDECRYPT IFSFILE(&FILEPATH) PASSWORD(&PHRASE) +
                          BATCH(*YES) PGPVER(*PGPCL9) /* SAC02 */
             CALLSUBR   SUBR(ARCHIVED)

             CHGVAR     VAR(&POS) VALUE(%SCAN('.pgp' &FILEPATH))
             IF         COND(&POS *EQ 0) THEN(CHGVAR VAR(&POS) +
                          VALUE(%SCAN('.PGP' &FILEPATH)))
             IF         COND(&POS *GT 0) THEN(CHGVAR +
                          VAR(%SST(&FILEPATH &POS 4)) VALUE('    '))
             IF         COND(%SCAN('.zip' &FILEPATH) *GT 0 *OR +
                          %SCAN('.ZIP' &FILEPATH) *GT 0) +
                          THEN(CALLSUBR SUBR(UNZIPPED))
             IF         COND(%SCAN('.gz' &FILEPATH) *GT 0 *OR +
                          %SCAN('.GZ' &FILEPATH) *GT 0) +
                          THEN(CALLSUBR SUBR(GUNZIP))

             ENDSUBR
 /*-----------------------------------------------------------------*/
 /* Bypass return files -- required for testing period, not         */
 /* for production.                                                 */
 /*-----------------------------------------------------------------*/
 ZIPPROC: SUBR       SUBR(UNZIPPED)

             IF         COND(%SCAN('PSS' &FILEPATH) *GT 0 *OR +
                          %SCAN('PSS' &FILEPATH) *GT 0) THEN(GOTO +
                          CMDLBL(NOUNZIP))

             CHGVAR     VAR(&POS) VALUE(%SCAN('.zip' &FILEPATH))
             IF         COND(&POS *EQ 0) THEN(CHGVAR VAR(&POS) +
                          VALUE(%SCAN('.ZIP' &FILEPATH)))
             IF         COND(&POS *GT 0) THEN(UNZIPF +
                          ARCHIVE(&FILEPATH) DIR(&IMPFOLDER))

             CALLSUBR   SUBR(ARCHIVED)
  NOUNZIP:
             ENDSUBR

 /*-----------------------------------------------------------------*/
 GZIPPROC:   SUBR       SUBR(GUNZIP)

             ADDENVVAR  ENVVAR(QIBM_QSH_CMD_ESCAPE_MSG) VALUE(Y)
             MONMSG     MSGID(CPFA980)
             CHGVAR     VAR(&Z7CMD) VALUE(' ')
             CHGVAR     VAR(&Z7CMD) VALUE('7z x' *BCAT &FILEPATH)
             CHGVAR     VAR(&Z7CMD) VALUE(&Z7CMD *TCAT ' -o' *TCAT +
                          &IMPFOLDER)
             STRQSH     CMD(&Z7CMD)
             MONMSG     MSGID(QSH0005)
             CALLSUBR   SUBR(ARCHIVED)
             ENDSUBR

 /*-----------------------------------------------------------------*/
 JOBPROC:    SUBR       SUBR(LOGJOB)
             CALL       PGM(CSG201RP) PARM(&FILEPATH &NEWPATH)
             CALLSUBR   SUBR(ARCHIVED)
             ENDSUBR

 /*-----------------------------------------------------------------*/
 
ARCFILE:    SUBR       SUBR(ARCHIVED)
             MOV        OBJ(&FILEPATH) TODIR(&ARCFOLDER)
             MONMSG     MSGID(CPFA0A0) EXEC(DO)
             CALLSUBR   SUBR(ARCHIVESR)
             ENDDO
            ENDSUBR

/*==================================================================*/
/* move file to archive                                             */
/*==================================================================*/

             SUBR       SUBR(ARCHIVESR)
             CHGVAR     VAR(&message) VALUE(' ')
             CHGVAR     VAR(&SUBJECT) VALUE(' ')
             CHGVAR     VAR(&reason) VALUE(' ')
 RETRY:
             CHGVAR     VAR(&ERROR) VALUE('0')
             MOV        OBJ(&FILEPATH) TODIR(&ARCFOLDER)
             MONMSG     MSGID(CPFA0A0) EXEC(DO)
             CHGVAR     VAR(&ERROR) VALUE('1')
             CALL       PGM(CSG305RP) PARM(&FILEPATH &ARCFOLDER)
             ENDDO
             IF         COND(&ERROR) THEN(GOTO CMDLBL(RETRY))

             CHGVAR     VAR(&SUBJECT) VALUE('CSG200CL file  +
                          error')
             CHGVAR     VAR(&MESSAGE) VALUE('Error occurred on +
                          move to archive inbound file.')
             CHGVAR     VAR(&REASON) VALUE('Check the job log of +
                          CSGINBOUND for details.')
             CALL       PGM(CSG415CL) PARM(&SUBJECT &MESSAGE &REASON)

             ENDSUBR

             ENDPGM


The first SUBR command that is encountered in a program or procedure also marks the end of the mainline of that program or procedure. All commands from this point forward, with the exception of the ENDPGM command, must be contained within a subroutine, in other words, placed between a beginning (SUBR) and ending (ENDSUBR) commands. The SUBR and ENDSUBR commands must be matched pairs, and may not be nested. A subroutine may contain only one SUBR and ENDSUBR command. using a SUBR between the beginning and end of the subroutine is not permitted.