|
|
|
|
|
Refactoring RPG - Part 1 Figure 3. CS8801.rpgle - Program to Refactor RPGLE Source Code
H DFTACTGRP(*NO) ACTGRP(*NEW)
//****************************************************************
// Description: Refactor RPGLE source code
//****************************************************************
FInputSrc IF F 132 DISK UsrOpn
FOutputSrc O F 132 DISK
FCspRemap IF E K DISK UsrOpn Prefix(rmap)
FCspFields UF A E K DISK UsrOpn
// Program Status Data Structure (PSDS).
D SDS
D psProgram 1 10a
// Prototypes of called procedures.
D spLoadRemaps PR
D spBuildFldRef PR
D spSetBltIns PR
D spSetFigCons PR
D spSetOpCode PR
D spZapFrmType PR
D spZapFirst5 PR
D spZapHiLites PR
D spCvtToBlkLn PR
D spSetDate PR
D spUpdCondits PR
D spCvtFldDefs PR
D spSuppression PR
D spMiscellaneous...
D PR
// Compile-time array(s).
// Using figCons to deal with "built-in" functions as well ... for now
D figCons S 10a Dim(83) CTDATA PerRcd(1)
// Externalized scan/replace tables.
D FromVal S 10a DIM(1000)
D ToVal S 10a Dim(1000)
// Miscellaneous data.
D outSRCSEQ S 6s 2
D outSRCDAT S 6s 0
D outSRCDTA S 120a
D newSrcDAT S 6s 0
D newSrcDTA S 120a
D i S 5u 0 Inz(0)
D j S 5u 0 Inz(0)
D iRemaps S 5u 0 Inz(0)
D pvFormType S 1a Inz(' ')
D FALSE C '0'
D TRUE C '1'
D pvStopFormat S 1a Inz(FALSE)
D pvSuppressLine S n Inz(*off)
// The following fields are used in convertion to free-format.
D firstDataSpec S n Inz(*on)
// *ENTRY parameter list.
D main PR ExtPgm('CS8801')
D cpZapFirst5 4a
D cpZapFrmType 4a
D cpSetDate 7a
D cpSetOpCodes 4a
D cpLowBltIns 4a
D cpLowFigCons 4a
D cpCvtToBlkLn 4a
D cpUpdCondits 4a
D cpZapHiLites 4a
D main PI
D cpZapFirst5 4a
D cpZapFrmType 4a
D cpSetDate 7a
D cpSetOpCodes 4a
D cpLowBltIns 4a
D cpLowFigCons 4a
D cpCvtToBlkLn 4a
D cpUpdCondits 4a
D cpZapHiLites 4a
*
IInputSrc NS
I s 1 6 2InSRCSEQ
I s 7 12 0InSRCDAT
I a 13 132 InSRCDTA
/free
// Beginning of Mainline
pvStopFormat = FALSE;
// Load the external remaps if remapping requested.
If (cpSetOpCodes = '*YES');
spLoadRemaps();
EndIf;
// Build file of field definitions.
spBuildFldRef();
Open InputSrc;
Read InputSrc;
DoW (NOT %eof);
pvSuppressLine = *off;
outSRCSEQ = InSRCSEQ;
outSRCDAT = InSRCDAT;
outSRCDTA = InSRCDTA;
If (pvStopFormat = FALSE);
Exsr srFormatLine;
EndIf;
If (NOT pvSuppressLine);
Except OutputRec;
EndIf;
Read InputSrc;
EndDo;
Close InputSrc;
// Normal termination.
*inLR = *on;
Return;
// End of Mainline
//*****************************************************************
// Subroutine: FormatLine
//*****************************************************************
begSr srFormatLine;
// Stop formatting once compile-time array data is encountered.
If (%subst(InSRCDTA:1:2) <> '**');
// Move field defs from calc spec to data spec.
If (%subst(InSRCDTA:6:1) = 'D' and firstDataSpec);
firstDataSpec = *off;
spCvtFldDefs();
EndIf;
// Replace hilighting characters with a blank.
If (cpZapHiLites = '*YES');
spZapHiLites();
EndIf;
// Zap (blank out) the 'form type' on comment lines.
If (cpZapFrmType = '*YES');
spZapFrmType();
EndIf;
// Zap (blank out) the first 5 bytes of source line.
If (cpZapFirst5 = '*YES');
spZapFirst5();
EndIf;
// Blank out a comment line that consists only of an asterisk.
If (cpCvtToBlkLn = '*YES');
spCvtToBlkLn();
EndIf;
// Set the source line date.
// *SAME is 0400101; *CURRENT is 0400102; *ZEROS is 0400203
If (cpSetDate <> '0400101');
spSetDate();
EndIf;
// Update RPG Conditionals to do compare to the right of the opcode.
If (cpUpdCondits = '*YES');
spUpdCondits();
EndIf;
// Convert the opcodes to predetermined, mixed-case letters.
If (cpSetOpCodes = '*YES');
spSetOpCode();
EndIf;
// Convert the built-in function names to lower-case letters.
If (cpLowBltIns = '*YES');
spSetBltIns();
EndIf;
// Convert the figurative constancts to lower-case letters.
If (cpLowFigCons = '*YES');
spSetFigCons();
EndIf;
// Check line to see if it should be suppressed.
spSuppression();
// Do miscellaneous changes that are not controlled by a flag.
spMiscellaneous();
// Compile-time array data encountered.
Else;
pvStopFormat = TRUE;
EndIf;
EndSr;
/end-free
// Output specifications.
OOutputSrc E OutputRec
O outSRCSEQ 6
O outSRCDAT 12
O outSRCDTA 132
OOutputSrc E newSrcRec
O outSRCSEQ 6
O newSRCDAT 12
O newSRCDTA 132
//****************************************************************
// Subprocedure: Blank out the form type on comment lines.
//****************************************************************
P spZapFrmType B
D up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D lo C 'abcdefghijklmnopqrstuvwxyz'
D isAlpha C 0
/free
// outSRCDTA = InSRCDTA;
If (%subst(outSRCDTA:7:1) = '*');
pvFormType = %subst(outSRCDTA:6:1);
// Convert to uppercase
pvFormType = %xlate(lo:up:pvFormType);
// Don't blank if non-alpha (i.e. keep highlighting)
If (%check(up:pvFormType) = isAlpha);
%subst(outSRCDTA:6:1) = ' ';
EndIf;
EndIf;
/end-free
P E
//****************************************************************
// Subprocedure: Blank out the first 5 bytes of RPG source,
// excluding compile-time arrays of coarse.
//****************************************************************
P spZapFirst5 B
/free
// outSRCDTA = InSRCDTA;
If (%subst(outSRCDTA:1:2) <> '**');
%subst(outSRCDTA:1:5) = ' ';
Else;
pvStopFormat = TRUE;
EndIf;
/end-free
P E
//****************************************************************
// Subprocedure: Replace hilights with blanks.
//****************************************************************
P spZapHiLites B
D hilites S 32a Inz(x'202122232425262728292A2B2C2D2E-
D 2F303132333435363738393A3B3C3D3E3F')
D char S 1a
/free
For i = 1 to 120;
char = %subst(outSRCDTA:i:1);
If (%scan(char:hilites) > 1);
%subst(outSRCDTA:i:1) = ' ';
EndIf;
EndFor;
/end-free
P E
//****************************************************************
// Subprocedure: Convert built-in functions to lower-case.
//****************************************************************
P spSetBltIns B
D up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D lo C 'abcdefghijklmnopqrstuvwxyz'
D char S 1a
D isBuiltIn S n Inz(*off)
D i S 10i 0
/free
For i = 1 to 120;
char = %subst(outSRCDTA:i:1);
//If (char = '%' or char = '*');
If (char = '%');
isBuiltIn = *on;
ElseIf (char = '(');
isBuiltIn = *off;
ElseIf (isBuiltIn);
If (%scan(char:up) > 0 or %scan(char:lo) > 0);
%subst(outSRCDTA:i:1) = %xlate(up:lo:char);
Else;
isBuiltIn = *off;
EndIf;
EndIf;
EndFor;
/end-free
P E
//****************************************************************
// Subprocedure: Convert figurative contants to lower-case.
//****************************************************************
P spSetFigCons B
D up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D lo C 'abcdefghijklmnopqrstuvwxyz'
D char S 1a
D line S Like(outSRCDTA)
D conLen S 10i 0
D i S 10i 0
D posn S 10i 0
/free
// Get an all lower-case version of line.
line = %xlate(up:lo:outSRCDTA);
For i = 1 to %elem(figCons);
conLen = %len(figCons(i)); // length of figurative constant
posn = %scan(figCons(i):line); // location of figurative constant in source line
DoW (posn > 0);
%subst(outSRCDTA:posn:conLen) = %trim(figCons(i));
posn = %scan(figCons(i):line:posn+conLen);
EndDo;
EndFor;
/end-free
P E
//****************************************************************
// Subprocedure: Convert comment lines that are blank to a
// completely blank line.
//****************************************************************
P spCvtToBlkLn B
/free
// outSRCDTA = InSRCDTA;
If (%subst(outSRCDTA:1:7) = ' *');
If (%subst(outSRCDTA:8:93) = *ALL' ');
%subst(outSRCDTA:7:1) = ' ';
EndIf;
EndIf;
/end-free
P E
//****************************************************************
// Subprocedure: Set Date based on the special value passed in.
//****************************************************************
P spSetDate B
/free
// *same is 0400101, so do nothing to the date.
// *current is 0400102
If (cpSetDate = '0400102');
outSRCDAT = %dec(%date():*ymd);
EndIf;
// *zeros is 0400103
If (cpSetDate = '0400103');
outSRCDAT = 0;
EndIf;
/end-free
P E
//****************************************************************
// Subprocedure: Replace Opcode with the "prefered" value.
//****************************************************************
P spSetOpCode B
D up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D lo C 'abcdefghijklmnopqrstuvwxyz'
/free
For i = 1 to iRemaps;
If (%xlate(lo:up:%subst(outSRCDTA:26:10)) = FromVal(i));
%subst(outSRCDTA:26:10) = ToVal(i);
EndIf;
EndFor;
/end-free
P E
//****************************************************************
// Subprocedure: Move logical comparisons out of the opcode and into
// factor2 to the right of the opcode.
//****************************************************************
P spUpdCondits B
D up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D lo C 'abcdefghijklmnopqrstuvwxyz'
D opCode S 10A
D factor1 S 14A
D factor2 S 14A
D comment S 20A
/free
comment = %subst(outSRCDTA:81:20);
factor1 = %subst(outSRCDTA:12:14);
factor2 = %subst(outSRCDTA:36:14);
opCode = %xlate(lo:up:%subst(outSRCDTA:26:10));
Select;
When opCode = 'IFEQ ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'If ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' = ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'IFNE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'If ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' <> ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'IFLT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'If ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' < ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'IFGT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'If ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' > ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'IFLE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'If ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' <= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'IFGE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'If ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' >= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOWEQ ';
%subst(outSRCDTA:12:14) = *ALL' ';
%Subst(outSRCDTA:26:10) = 'DoW ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' = ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOWNE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoW ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' <> ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOWLT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoW ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' < ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOWGT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoW ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' > ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOWLE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoW ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' <= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOWGE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoW ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' >= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOUEQ ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoU ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' = ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOUNE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoU ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' <> ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOULT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoU ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' < ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOUGT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoU ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' > ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOULE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoU ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' <= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'DOUGE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'DoU ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' >= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ANDEQ ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' = ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ANDNE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' <> ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ANDLT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' < ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ANDGT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' > ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ANDLE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' <= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ANDGE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'AND ' + %trim(factor1) + ' >= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'OREQ ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' = ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ORNE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' <> ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ORLT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' < ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ORGT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' > ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ORLE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' <= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'ORGE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = ' ';
%subst(outSRCDTA:36:64) = 'OR ' + %trim(factor1) + ' >= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'WHENEQ ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'When ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' = ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'WHENNE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'When ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' <> ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'WHENLT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'When ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' < ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'WHENGT ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'When ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' > ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'WHENLE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'When ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' <= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
When opCode = 'WHENGE ';
%subst(outSRCDTA:12:14) = *ALL' ';
%subst(outSRCDTA:26:10) = 'When ';
%subst(outSRCDTA:36:64) = %trim(factor1) + ' >= ' +
%trim(factor2);
%subst(outSRCDTA:81:20) = comment;
EndSl;
/end-free
P E
//****************************************************************
// Subprocedure: Load arrays of opcodes to be replaced with
// standardized case (upper vs. lower vs. mixed).
//****************************************************************
P spLoadRemaps B
D sourceType S 10a Inz('RPGLE ')
/free
//Load the customized from/to values.
i = 0;
j = 0;
Open CspRemap;
SetLL sourceType CspRemap;
ReadE sourceType CspRemap;
DoW (NOT %eof);
i += 1;
FromVal(i) = rmapFROMVAL;
ToVal(i) = rmapTOVAL;
ReadE sourceType CspRemap;
EndDo;
Close CspRemap;
iRemaps = i;
/end-free
P E
//****************************************************************
// Subprocedure: Perform suppression of deprecated lines.
//****************************************************************
P spSuppression B
D up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D lo C 'abcdefghijklmnopqrstuvwxyz'
D opCode S 10a
D factor1 S 14a
D lineSpec S 1a
/free
// Suppress *LIKE/DEFINES and *DTAARA/DEFINES,
// they have been moved to the data specs.
lineSpec = %xlate(lo:up:%subst(outSRCDTA:6:1));
opCode = %xlate(lo:up:%subst(outSRCDTA:26:10));
If (lineSpec = 'C' and opCode = 'DEFINE ');
factor1 = %xlate(lo:up:%subst(outSRCDTA:12:14));
If (factor1 = '*LIKE ' or factor1 = '*DTAARA ');
pvSuppressLine = *on;
EndIf;
EndIf;
/end-free
P E
//****************************************************************
// Subprocedure: Perform miscellaneous changes.
//****************************************************************
P spMiscellaneous...
P B
D up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D lo C 'abcdefghijklmnopqrstuvwxyz'
D opCode S 10a
D lineSpec S 1a
/free
// Remove "SR" following 'C'alculation line type.
// It is an obsolete way of identifying lines in a
// "S"ub"R"outine.
If (%xlate(lo:up:%subst(outSRCDTA:6:3)) = 'CSR');
%subst(outSRCDTA:6:3) = 'C ';
EndIf;
// Suppress field definition in calculation specs.
lineSpec = %xlate(lo:up:%subst(outSRCDTA:6:1));
opCode = %xlate(lo:up:%subst(outSRCDTA:26:10));
If (lineSpec = 'C');
%subst(outSRCDTA:64:7) = ' ';
EndIf;
/end-free
P E
//****************************************************************
// Subprocedure: Build a workfile of field reference information.
// i) Use file specs.
// ii) Use data declarations
// iii) Use calc spec field declarations
//****************************************************************
P spBuildFldRef B
D up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D lo C 'abcdefghijklmnopqrstuvwxyz'
D lineSpec S 1a
D commentCol S 1a
D defType S 2a
D fileFmt S 1a
D fileName S 10a
D lengthA S 7a
D fromA S 7a
D decimalsA S 2a
D opCode S 10a
D factor1 S 14a
D factor2 S 14a
D result S 14a
/free
Open InputSrc;
Open CspFields;
Read InputSrc;
DoW (NOT %eof);
lineSpec = %xlate(lo:up:%subst(inSRCDTA:6:1));
WhereDef = lineSpec;
commentCol = %subst(inSRCDTA:7:1);
// Skip lines that are commented out...
If (commentCol <> '*');
Select;
// Process a 'F'ile spec.
When (lineSpec = 'F');
// Next month we will add code here to load all the fields
// from a file in the file specifications.
// Process an 'I'nput spec.
When (lineSpec = 'I');
// Look for a field declaration or rename.
// Process a 'C'alculation spec.
When (lineSpec = 'C');
Clear CSRFIELDS;
factor1 = %xlate(lo:up:%subst(inSRCDTA:12:14));
factor2 = %xlate(lo:up:%subst(inSRCDTA:36:14));
result = %xlate(lo:up:%subst(inSRCDTA:50:14));
opCode = %xlate(lo:up:%subst(inSRCDTA:26:10));
WhereDef = lineSpec;
library = '*NONE';
file = '*NONE';
format = '*NONE';
// If a *LIKE DEFINE field definition...
If (opCode = 'DEFINE ' and factor1 = '*LIKE ');
fileType = '*LIKEDFN';
field = result;
newName = factor2;
dataType = ' ';
length = 0;
decimals = 0;
Write CSRFIELDS;
// If a *DTAARA DEFINE definition...
ElseIf (opCode = 'DEFINE ' and factor1 = '*DTAARA ');
fileType = '*DTAARA';
dataType = ' ';
If (factor2 = *blanks);
field = result;
Else;
field = factor2;
newName = result;
EndIf;
lengthA = %subst(inSRCDTA:64:5);
decimalsA = %subst(inSRCDTA:69:2);
// Character field...
If (decimalsA = *blanks and lengthA <> *blanks);
dataType = 'A';
Monitor;
length = %dec(%trim(lengthA):7:0);
On-Error;
length = 0;
decimals = 0;
EndMon;
// Packed decimal field...
ElseIf (decimalsA <> *blanks and lengthA <> *blanks);
dataType = 'P';
Monitor;
decimals = %dec(%trim(decimalsA):2:0);
length = %dec(%trim(lengthA):7:0);
On-Error;
length = 0;
decimals = 0;
EndMon;
EndIf;
Write CSRFIELDS;
// Plain 'ol 'C'alculation spec defined field...
Else;
fileType = '*CALCDFN';
field = %subst(inSRCDTA:50:14);
lengthA = %subst(inSRCDTA:64:5);
decimalsA = %subst(inSRCDTA:69:2);
// Character field...
If (decimalsA = *blanks and lengthA <> *blanks);
dataType = 'A';
Monitor;
length = %dec(%trim(lengthA):7:0);
Write CSRFIELDS;
On-Error;
// Definition unreliable; do not save.
EndMon;
// Packed decimal field...
ElseIf (decimalsA <> *blanks and lengthA <> *blanks);
dataType = 'P';
Monitor;
decimals = %dec(%trim(decimalsA):2:0);
length = %dec(%trim(lengthA):7:0);
Write CSRFIELDS;
On-Error;
// Definition unreliable; do not save.
EndMon;
EndIf;
EndIf;
// Process a 'D'ata spec.
When (lineSpec = 'D');
// Next month we will add code here to load all the fields
// that are defined in the data definition specifications.
EndSl;
EndIf; // Skip lines that are commented out...
Read InputSrc;
EndDo;
Close CspFields;
Close InputSrc;
/end-free
P E
//****************************************************************
// Subprocedure: Add data specs to replace calc spec field defs.
//****************************************************************
P spCvtFldDefs B
D up C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
D lo C 'abcdefghijklmnopqrstuvwxyz'
D lineSpec S 1a
D commentCol S 1a
D defType S 2a
D fileFmt S 1a
D fileName S 10a
D fldArray S 15a Dim(300)
D fldCount S 10i 0 Inz(0)
/free
Open CspFields;
Read CspFields;
DoW (NOT %eof(CspFields));
// Process Calc Spec field definitions.
If (fileType = '*CALCDFN' and fldCount < 96);
// Write out a couple of comment lines before the first definition.
If (fldCount = 0);
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
Except newSrcRec; // Write a blank source code line...
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
%subst(newSRCDTA:7) = '// Definitions added by REFACTOR command';
// %trim(psProgram);
Except newSrcRec; // Write a source code line...
EndIf;
// Confirm that the field has not already been added.
If (%lookup(%xlate(lo:up:Field):fldArray) = 0);
fldCount += 1;
fldArray(fldCount) = %xlate(lo:up:Field);
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
%subst(newSRCDTA:6) = 'D ' + Field;
%subst(newSRCDTA:24:1) = 'S';
%subst(newSRCDTA:33:7) = %editc(Length:'Z');
%subst(newSRCDTA:40:1) = %xlate(up:lo:DataType);
If (DataType = 'S' or DataType = 'P');
If (Decimals = 0);
%subst(newSRCDTA:42:1) = '0';
Else;
%subst(newSRCDTA:41:2) = %subst(%editc(Decimals:'Z'):4:2);
EndIf;
EndIf;
Except newSrcRec; // Write a source code line...
newSRCDTA = *ALL' ';
EndIf;
// Process *LIKE/DEFINE Calc Spec field definitions.
ElseIf (fileType = '*LIKEDFN' and fldCount < 96);
// Write out a couple of comment lines before the first definition.
If (fldCount = 0);
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
Except newSrcRec; // Write a blank source code line...
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
%subst(newSRCDTA:7) = '// Definitions added by REFACTOR command';
// %trim(psProgram);
Except newSrcRec; // Write a source code line...
EndIf;
// Confirm that the field has not already been added.
If (%lookup(%xlate(lo:up:Field):fldArray) = 0);
fldCount += 1;
fldArray(fldCount) = %xlate(lo:up:Field);
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
%subst(newSRCDTA:6) = 'D ' + Field;
%subst(newSRCDTA:24:1) = 'S';
%subst(newSRCDTA:44) = 'Like(' + %trim(newName) + ')';
Except newSrcRec; // Write a source code line...
newSRCDTA = *ALL' ';
EndIf;
// Process *DTAARA/DEFINE Calc Spec field definitions.
ElseIf (fileType = '*DTAARA' and fldCount < 96);
// Write out a couple of comment lines before the first definition.
If (fldCount = 0);
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
Except newSrcRec; // Write a blank source code line...
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
%subst(newSRCDTA:7) = '// Definitions added by FILTERRPG command';
// %trim(psProgram);
Except newSrcRec; // Write a source code line...
EndIf;
// Confirm that the field has not already been added.
If (%lookup(%xlate(lo:up:Field):fldArray) = 0);
fldCount += 1;
fldArray(fldCount) = %xlate(lo:up:Field);
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
If (newName <> *blanks);
%subst(newSRCDTA:6) = 'D ' + newName;
Else;
%subst(newSRCDTA:6) = 'D ' + Field;
ENDIF;
%subst(newSRCDTA:24:1) = 'S';
%subst(newSRCDTA:33:7) = %editc(Length:'Z');
%subst(newSRCDTA:40:1) = %xlate(up:lo:DataType);
If (DataType = 'S' or DataType = 'P');
If (Decimals = 0);
%subst(newSRCDTA:42:1) = '0';
Else;
%subst(newSRCDTA:41:2) = %subst(%editc(Decimals:'Z'):4:2);
EndIf;
EndIf;
%subst(newSRCDTA:44) = 'DtaAra(' + %trim(field) + ')';
Except newSrcRec; // Write a source code line...
newSRCDTA = *ALL' ';
EndIf;
EndIf;
Read CspFields;
EndDo;
// Write a blank line, sequence number permitting...
If (fldCount > 0 and fldCount < 98);
outSRCSEQ += .01;
newSRCDTA = *ALL' ';
Except newSrcRec; // Write a source code line...
EndIf;
Close CspFields;
/end-free
P E
** Figurative Constants
*blanks 1
*blank 2
*zeros 3
*zero 4
*off 5
*on 6
*hival 7
*loval 8
*in 9
*lda 10
*dtaara 11
*date 12
*user 13
*year 14
*month 15
*day 16
%abs 17
%addr 18
%alloc 19
%bitand 20
%bitnot 21
%bitor 22
%bitxor 23
%char 24
%checkr 25
%check 26
%date 27
%days 28
%dech 29
%decpos 30
%dec 31
%diff 32
%div 33
%editc 34
%editflt 35
%editw 36
%elem 37
%eof 38
%equal 39
%error 40
%fields 41
%float 42
%found 43
%graph 44
%handler 45
%hours 46
%int 47
%kds 48
%len 49
%lookup 50
%minutes 51
%months 52
%mseconds 53
%nullind 54
%occur 55
%open 56
%paddr 57
%parms 58
%realloc 59
%rem 60
%replace 61
%scan 62
%seconds 63
%shtdn 64
%size 65
%sqrt 66
%status 67
%str 68
%subarr 69
%subdt 70
%subst 71
%this 72
%timestamp 73
%time 74
%tlookup 75
%trim 76
%triml 77
%trimr 78
%ucs2 79
%uns 80
%xfoot 81
%xml 82
%years 83
|