|
midrange.com
I got this portion of instructions from a similar discussion in the past.
Hope it helps in something:
How to retrieve the RPGLE source
It is possible to retrieve source from RPG programs if the program has
been compiled with the correct parameters. The following procedure will
retrieve the source from single-module RPGLE programs compiled with
CRTBNDRPG with DBGVIEW(*LIST).
The program could be modified to handle RPG III programs compiled with
OPTION(*LSTDBG) and multiple module ILE programs. As far as the experts
know, the retrieval works with the exception of list directives (i.e.
/EJECT) and color/highlight special characters.
*****************************************************************
* RTVWORK Work file for RTVRPGLES *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * ** * * **
R RTVROKF
FILL01 2
HEXADR 6
HEXSTUFF 79
GOODSTUFF 32
TRAILER 13
/*--Program RTVRPGLES --Driver for Retrieve RPGLE source */
/* CPP for RTVRPGLES */
RTVRPGLES: PGM PARM(&PGMNAMLIB &SRCNAMLIB &MBRNAME)
DCL VAR(&PGMNAMLIB) TYPE(*CHAR) LEN(20)
DCL VAR(&SRCNAMLIB) TYPE(*CHAR) LEN(20)
DCL VAR(&OBJNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&OBJLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&SRCNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&MBRNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&PGMTYPE) TYPE(*CHAR) LEN(10)
DCL VAR(&NEWTEXT) TYPE(*CHAR) LEN(80)
DCL VAR(&ERROR) TYPE(*CHAR) LEN(1)
CHGVAR VAR(&OBJNAME) VALUE(%SST(&PGMNAMLIB 1 10))
CHGVAR VAR(&OBJLIB) VALUE(%SST(&PGMNAMLIB 11 10))
CHGVAR VAR(&SRCNAME) VALUE(%SST(&SRCNAMLIB 1 10))
CHGVAR VAR(&SRCLIB) VALUE(%SST(&SRCNAMLIB 11 10))
IF COND(&MBRNAME = '*PGM') THEN(CHGVAR +
VAR(&MBRNAME) VALUE(&OBJNAME))
RTVOBJD OBJ(&OBJLIB/&OBJNAME) OBJTYPE(*PGM) +
OBJATR(&PGMTYPE)
/*--Validate that requested object exists */
MONMSG MSGID(CPF9999) EXEC(DO)
SNDPGMMSG MSG('Requested program does not exist') +
MSGTYPE(*DIAG)
GOTO CMDLBL(ENDPGM)
ENDDO
/*--Validate that requested object is RPGLE */
IF COND(&PGMTYPE = 'RPGLE') THEN(DO)
SNDPGMMSG MSG('Requested program is not RPGLE') +
MSGTYPE(*DIAG)
GOTO CMDLBL(ENDPGM)
ENDDO
CHGVAR VAR(&NEWTEXT) VALUE('Retrieved source for ' || +
&OBJLIB |< '/' || &OBJNAME)
/*--Add requested output source member */
ADDPFM FILE(&SRCLIB/&SRCNAME) MBR(&MBRNAME) +
TEXT(&NEWTEXT) SRCTYPE(RPGLE)
MONMSG MSGID(CPF7306) EXEC(DO)
SNDPGMMSG MSG('Cannot add requested retrieval member') +
MSGTYPE(*DIAG)
GOTO CMDLBL(ENDPGM)
ENDDO
DMPOBJ OBJ(&OBJLIB/&OBJNAME) OBJTYPE(*PGM)
CRTDUPOBJ OBJ(RTVWORK) FROMLIB(*LIBL) OBJTYPE(*FILE) +
TOLIB(QTEMP)
MONMSG MSGID(CPF2130) EXEC(CLRPFM FILE(RTVWORK))
CPYSPLF FILE(QPSRVDMP) TOFILE(RTVWORK) SPLNBR(*LAST)
DLTSPLF FILE(QPSRVDMP) SPLNBR(*LAST)
CRTSRCPF FILE(QTEMP/QRPGLESRC) RCDLEN(112) MBR(*FILE) +
MAXMBRS(1)
MONMSG MSGID(CPF7302) EXEC(CLRPFM FILE(QTEMP/QRPGLESRC))
OVRDBF FILE(QRPGLESRC) TOFILE(QTEMP/QRPGLESRC) +
MBR(*FIRST)
OVRDBF FILE(RTVWORK) TOFILE(QTEMP/RTVWORK)
CALL PGM(RTVRPG) PARM(&ERROR)
DLTOVR FILE(QRPGLESRC)
DLTOVR FILE(RTVWORK)
IF COND(&ERROR = 'Y') THEN(DO)
CPYSRCF FROMFILE(QTEMP/QRPGLESRC) +
TOFILE(&SRCLIB/&SRCNAME) FROMMBR(*FIRST) +
TOMBR(&MBRNAME) MBROPT(*ADD) SRCOPT(*SEQNBR)
ENDDO
ELSE CMD(DO)
RMVM FILE(&SRCLIB/&SRCNAME) MBR(&MBRNAME)
SNDPGMMSG MSG('Requested program was not compiled with +
DBGVIEW(*LIST)') MSGTYPE(*DIAG)
ENDDO
CLRPFM FILE(QTEMP/RTVWORK)
CLRPFM FILE(QTEMP/QRPGLESRC)
ENDPGM: ENDPGM
H Option(*srcstmt)
*******************************************************************
*--RTVRPG Converts RPGLE program dump to source code
*******************************************************************
frtvwork if e disk
fqrpglesrc uf a e disk rename(qrpglesrc:qrpglesrcf)
usropn
d begsource c '*MODULE ENTRY'
d endsource c 'MAIN PROCEDURE -
d EXIT'
d up c 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
d lo c 'abcdefghijklmnopqrstuvwxyz'
d i s 3 0
d j s 3 0
d k s 3 0
d l s 3 0
d numout s 8 0
d skip# s 8 0
d ctarray# s 3 0 inz(0)
d temp80 s 80
d cursor s 3 0
d ipos s 2 0
d error s 1 inz('N')
d pmerror s 1
d hex s 1a dim(16) ctdata perrcd(16)
d goodstuff ds
d goodchr 1 dim(32)
d srcdta ds
d srcchr 1 dim(100)
d lindta ds
d linchr 1 dim(100)
d srcdatea ds
d datechr 1 dim(6)
d hexin ds
d hexchr 1 dim(6)
c *entry plist
c parm error pmerror
c open qrpglesrc
*--Locate beginning of source text
c read rtvwork
c eval ipos = %scan(begsource:goodstuff)
c dou ipos <> 0
c read rtvwork
c eval ipos = %scan(begsource:goodstuff)
*--If no start string, object was not rpgle compiled with *LSTDBG
c if %eof(rtvwork) = *on
c eval error = 'Y'
c seton lr
c return
c endif
c enddo
*--Determine offset to beginning of statement line
c eval cursor = 32 - ipos
c dou cursor > 136
c read rtvwork
c if hexstuff = *blank
c if %scan('LINES':hexstuff) <> 0
c exsr $SKIP
c do skip#
c eval cursor = cursor + 32
c enddo
c endif
c else
c eval cursor = cursor + 32
c endif
c enddo
c eval j = 6
c eval i = 32 - (cursor - 136) + 1
*--Load rpg code (field lindta fields 1-100)
c dow %eof(rtvwork) = *off
c dou i > 32
c if j < 101
c eval linchr(j) = goodchr(i)
c endif
*--Load line marking (field srcdta fields 1-5)
* Don't load if line copied from external def (pos 5 = '=')
c if j > 105 and j < 111
c and linchr(5) <> '='
c eval k = j - 105
c eval srcchr(k) = goodchr(i)
c endif
*--Load line dates (field srcdat)
c if j > 111 and j < 118
c eval k = j - 111
c eval datechr(k) = goodchr(i)
c endif
c eval i = i +1
c eval j = j +1
*--Test for end of input for this source line
c if j > 136
c eval j = 1
*--Test for end of input source file data
c if %scan(endsource:lindta) <> 0 and
c linchr(5) = '*'
c close qrpglesrc
c if ctarray# > *zero
c exsr $FIXARRAY
c endif
c seton lr
c return
c endif
*--Test for valid line date
c testn srcdatea 30
c if *in30 = *off
c eval srcdat = *zeros
c else
c move srcdatea srcdat
c endif
c*--Shift compile time arrays
c if linchr(5) <> '='
*--Count the number of compile time arrays
c if linchr(6) = 'd' or linchr(6) = 'D'
c lo:up xlate lindta temp80
c if %scan('CTDATA':temp80) <> 0 and
c linchr(7) <> '*'
c eval ctarray# = ctarray# + 1
c endif
c endif
c eval %subst(srcdta:6:95) =
%subst(lindta:6:95)
c exsr $RMVJUNK
c write qrpglesrcf
c else
c clear qrpglesrcf
c endif
c endif
c enddo
*--Test for end of input line
c if i > 32
c eval i = 1
c endif
*--Bypass records with no data
c dou hexadr <> *blank
c if %scan('LINES':hexstuff) <> 0
c exsr $SKIP
c endif
*--If 'SAME AS ABOVE' appears in input, act as if blank lines were
read
c if skip# > *zero
c eval skip# = skip# - 1
c eval hexstuff = *blank
c eval hexadr = 'FAKEIT'
c iter
c endif
c read rtvwork
c enddo
c enddo
*******************************************************************
*--$SKIP skip input based upon repeating lines
*******************************************************************
csr $SKIP begsr
c eval hexin = %subst(hexstuff:24:6)
c exsr $CVTHEX
c eval skip# = numout
c eval hexin = %subst(hexstuff:8:6)
c exsr $CVTHEX
c eval skip# = (skip# - numout + 1)/32
csr endsr
*******************************************************************
*--$RMVJUNK remove compiler generated junk
*******************************************************************
csr $RMVJUNK begsr
*--Get rid of '--' in c spec indicator fields
c if srcchr(6) = 'C' or srcchr(6) = 'c'
c dou k = 0
c eval k = %scan('--':srcdta:71)
c if k <> *zero
c eval srcdta = %replace(' ':srcdta:k)
c endif
c enddo
c endif
csr endsr
*******************************************************************
*--$FIXARRAY shift compile time arrays
*******************************************************************
csr $FIXARRAY begsr
c open qrpglesrc
c *hival setgt qrpglesrc
*--Position at beginning of last array
c readp qrpglesrc
c dou %eof(qrpglesrc) = *on or
c ctarray# = *zero
c if %subst(srcdta:6:2) = '**'
c eval ctarray# = ctarray# - 1
c endif
c readp qrpglesrc
c enddo
c read qrpglesrc
c exsr $SHIFT6L
csr endsr
*******************************************************************
*--$SHIFT6L shift line 6 pos to left (for compile time arrays)
*******************************************************************
csr $SHIFT6L begsr
c dou %eof(qrpglesrc) = *on
c eval %subst(srcdta:1:95) =
%subst(srcdta:6:95)
+
c ' '
c update qrpglesrcf
c read qrpglesrc
c enddo
csr endsr
*******************************************************************
*--$CVTHEX convert hex to numeric
*******************************************************************
csr $CVTHEX begsr
c eval numout = *zero
c 1 do 6 k
c eval l = 1
c hexchr(k) lookup hex(l) 30
c select
c when k = 1
c eval numout = numout + (l - 1) * 16**5
c when k = 2
c eval numout = numout + (l - 1) * 16**4
c when k = 3
c eval numout = numout + (l - 1) * 16**3
c when k = 4
c eval numout = numout + (l - 1) * 16**2
c when k = 5
c eval numout = numout + (l - 1) * 16
c when k = 6
c eval numout = numout + (l - 1)
c endsl
c enddo
c
csr endsr
**
0123456789ABCDEF
*****************************************************************
* RTVWORK Work file for RTVRPGLES *
* Created by Jim Friedman 01/26/04
* * * * * * * * * * * * * * * * * * * * * * * * * * * * ** * * **
R RTVROKF
FILL01 2
HEXADR 6
HEXSTUFF 79
GOODSTUFF 32
TRAILER 13
Peter Vidal
PALL Aeropower Corporation
SR Programmer Analyst
5775 Rio Vista Drive
Clearwater, FL 33760-3137
(727)539-8448
www.pall.com
"My religion consists of a humble admiration of the illimitable superior
spirit who reveals himself in the slight details we are able to perceive
with our frail and feeble mind."
Albert Einstein
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2025 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
