AS400 RPGLE Color Source Code

***CL***

 

  START: PGM PARM(&IN01)/**/ DCL VAR(&IN01) TYPE(*CHAR) LEN(10)/**/ MONMSG MSGID(CPF0000 RPG0000)/**/ CHECK: IF COND(&IN01 *EQ ' ') THEN(GOTO CMDLBL(END))/**/ CRTPF: CRTPF FILE(QTEMP/TMP0101201) SRCFILE(QPLFSRC) + OPTION(*NOSRC *NOLIST) SIZE(*NOMAX) + LVLCHK(*NO) RCVMSG MSGTYPE(*EXCP) RMV(*YES) RCVMSG MSGTYPE(*DIAG) RMV(*YES)/**/ QDDSSRC: DSPFD FILE(&IN01/QDDSSRC) TYPE(*MBRLIST) + OUTPUT(*OUTFILE) + OUTFILE(QTEMP/TMP0101202) OUTMBR(*FIRST *ADD)/**/ QPLFSRC: DSPFD FILE(&IN01/QPLFSRC) TYPE(*MBRLIST) + OUTPUT(*OUTFILE) + OUTFILE(QTEMP/TMP0101202) OUTMBR(*FIRST *ADD)/**/ QRPGLESRC: DSPFD FILE(&IN01/QRPGLESRC) TYPE(*MBRLIST) + OUTPUT(*OUTFILE) + OUTFILE(QTEMP/TMP0101202) OUTMBR(*FIRST *ADD)/**/RUN: CALL PGM(*LIBL/P01012R) /**/END: ENDPGM

 

***RPGLE***

H********************************************************************************************* H* Usage......: 9x : Dummy H********************************************************************************************* H/COPY H_DFT F********************************************************************************************* FTMP0101201IF E K DISK USROPN INFSR(*PSSR) D********************************************************************************************* D/COPY D_ERRDS D/COPY D_LDADS D/COPY D_MSGDS D/COPY D_PSDS D/COPY D_PSSR D* D Working DS INZ *Working variables D xxSTAT 100A INZ(' ') *SQL statement C********************************************************************************************* C/COPY C_PSSR C********************************************************************************************* C* *INZSR = Program initialization. C********************************************************************************************* CSR *INZSR BEGSR C* C/COPY C_START *Starting step C* C EXSR /OPEN *Open file C EXSR /MAIN *Main process C* C EVAL *INLR = *ON *End of program C RETURN C* CSR ENDSR C********************************************************************************************* C* /OPEN = Open file. C********************************************************************************************* CSR /OPEN BEGSR C* C OPEN TMP0101201 C* CSR ENDSR C********************************************************************************************* C* /MAIN = Main process. C********************************************************************************************* CSR /MAIN BEGSR C* C*--- Clear old data in TMP0101201. C* C/EXEC SQL delete from TMP0101201 C/END-EXEC C* C*--- Add data into TMP0101201. C* C/EXEC SQL insert into TMP0101201 select MLLIB, MLFILE, MLNAME, MLSEU2 C+ from TMP0101202 C/END-EXEC C* C*--- Color source code. C* C *LOVAL SETLL(E) TMP0101201 C READ TMP0101201 9999 C*B1 C DOW not *IN99 C*B2 C SELECTW1 C WHEN X1TYPE = 'DSPF' C EXSR /COLORW2 C WHEN X1TYPE = 'LF' C EXSR /COLORW3 C WHEN X1TYPE = 'PF' C EXSR /COLORW4 C WHEN X1TYPE = 'PRTF' C EXSR /COLORW5 C WHEN X1TYPE = 'RPGLE' C EXSR /COLORW6 C WHEN X1TYPE = 'SQLRPGLE' C EXSR /COLORE2 C ENDSL C* C READ TMP0101201 9999 C*E1 C ENDDO C* C EVAL *IN99 = *OFF C* CSR ENDSR C********************************************************************************************* C* /COLOR = Color source code. C********************************************************************************************* CSR /COLOR BEGSR C* C*--- Create alias. C* /free xxSTAT = 'create alias QTEMP/AA for ' + %trim(X1LIB) + '/' + %trim(X1FILE) + '(' + %trim(X1MBR) + ')' ; /end-free C* C/EXEC SQL prepare xxSQL from :xxSTAT C/END-EXEC C* C/EXEC SQL execute xxSQL C/END-EXEC C* C*--- Color source code. C*B1 C SELECTW1 C WHEN (X1TYPE = 'DSPF') or (X1TYPE = 'PRTF') C/EXEC SQL update QTEMP/AA set SRCDTA=substr(SRCDTA,1,4)||X'22'|| C+ substr(SRCDTA,6,94) where substr(SRCDTA,6,2) = 'A*' C/END-EXEC C* C/EXEC SQL update QTEMP/AA set SRCDTA=substr(SRCDTA,1,4)||X'3B'|| C+ substr(SRCDTA,6,94) where substr(SRCDTA,6,2) = 'A ' and C+ substr(SRCDTA,17,2) = 'R ' C/END-EXECW2 C WHEN (X1TYPE = 'LF') or (X1TYPE = 'PF') C/EXEC SQL update QTEMP/AA set SRCDTA=substr(SRCDTA,1,4)||X'22'|| C+ substr(SRCDTA,6,94) where substr(SRCDTA,6,2) = 'A*' C/END-EXEC C* C/EXEC SQL update QTEMP/AA set SRCDTA=substr(SRCDTA,1,4)||X'3B'|| C+ substr(SRCDTA,6,94) where substr(SRCDTA,6,2) = 'A ' and C+ substr(SRCDTA,17,2) = 'R ' C/END-EXEC C* C/EXEC SQL update QTEMP/AA set SRCDTA=substr(SRCDTA,1,4)||X'29'|| C+ substr(SRCDTA,6,94) where substr(SRCDTA,6,2) = 'A ' and C+ substr(SRCDTA,17,2) in ('K ', 'S ', 'O ', 'J ') C/END-EXECW3 C WHEN (X1TYPE = 'RPGLE') or C (X1TYPE = 'SQLRPGLE') C/EXEC SQL update QTEMP/AA set SRCDTA=substr(SRCDTA,1,4)||X'22'|| C+ substr(SRCDTA,6,94) where substr(SRCDTA,7,1) = '*' C/END-EXEC C* C/EXEC SQL update QTEMP/AA set SRCDTA=substr(SRCDTA,1,4)||X'29'|| C+ substr(SRCDTA,6,94) where substr(SRCDTA,12,6) in C+ ('*ENTRY', '*INZSR') C/END-EXEC C* C/EXEC SQL update QTEMP/AA set SRCDTA=substr(SRCDTA,1,4)||X'3B'|| C+ substr(SRCDTA,6,94) where substr(SRCDTA,26,5) in C+ ('BEGSR', 'ENDSR') C/END-EXECE1 C ENDSL C* C*---Drop alias. C* C/EXEC SQL drop alias QTEMP/AA C/END-EXEC C* C*--- Color code. C* C* Hex Description C* ----- ------------------------------------------------------------------------- C* X'20' Green C* X'21' Green, reverse image C* X'22' White C* X'23' White, reverse image C* X'24' Green, underscore C* X'25' Green, underscore, reverse image C* X'26' White, underscore C* X'27' Nondisplay C* X'28' Red C* X'29' Red, reverse image C* X'2A' Red, high intensity C* X'2B' Red, high intensity, reverse image C* X'2C' Red, underscore C* X'2D' Red, underscore, reverse image C* X'2E' Red, underscore, blink C* X'2F' Nondisplay C* X'30' Turquoise, column separator C* X'31' Turquoise, column separator, reverse image C* X'32' Yellow, column separator C* X'33' White, reverse image, column separator C* X'34' Turquoise, underscore, column separator C* X'35' Turquoise, underscore, reverse image, column separator C* X'36' Yellow, underscore, column separator C* X'37' Nondisplay C* X'38' Pink C* X'39' Pink, reverse image C* X'3A' Blue C* X'3B' Blue, reverse image C* X'3C' Pink, underscore C* X'3D' Pink, underscore, reverse iamge C* X'3E' Blue, underscore C* X'3F' Nondisplay C* CSR ENDSR

***PLF***

A R X1R A*========================================================================= A X1LIB 10A TEXT('Library Name') A X1FILE 10A TEXT('File Name') A X1MBR 10A TEXT('Member Name') A X1TYPE 10A TEXT('Member Type') A*========================================================================= A K X1LIB A K X1FILE A K X1MBR