Code:
- /*--------------------------------------------------------------------------*/
- /* This program is free software, you can redistribute it and/or modify it */
- /* under the terms of the GNU General Public License as published by */
- /* the Free Software Foundation. See GNU General Public License for detail. */
- /* Copyright (C) 2008 Craig Rutledge <www.jcrcmds.com> */
- /*--------------------------------------------------------------------------*/
- /* JCRPRTF - Generate External Print File - Command Definition */
- /* Craig Rutledge */
- /*--------------------------------------------------------------------------*/
- /* Command Summary: */
- /* The command reads RPG4 source code and generates a PRTF source */
- /* member matching the O specs from the program. */
- /*--------------------------------------------------------------------------*/
- /* Related Objects: */
- /* JCRPRTFH PNLGRP Generate external print file - help text */
- /* JCRPRTFR RPGLE Generate PRTF DDS from RPG4 O specs */
- /* JCRRECGETR RPGLE Record format/file xref for RPG source */
- /* JCRFLDCPYR RPGLE Get source names from /copy for processing */
- /* JCRFLDGETR RPGLE Get field attributes from RPG4 programs */
- /* JCRPRTFRV RPGLE Validity checker with allocate object */
- /* JCRPRTF CMD Generate external print file from RPG Ospecs */
- /*--------------------------------------------------------------------------*/
- CMD PROMPT('Generate External Print File')
-
- PARM KWD(RPGMBR) TYPE(*NAME) MIN(1) PROMPT('RPG4 +
- source member:')
-
- PARM KWD(RPGSRCFIL) TYPE(QUAL1) PROMPT('Source +
- file:')
-
- PARM KWD(PRTFMBR) TYPE(*NAME) MIN(1) PROMPT('DDS +
- member to generate:')
-
- PARM KWD(PRTFSRCFIL) TYPE(QUAL2) PROMPT('Source +
- file:')
-
- PARM KWD(USEREFFLD) TYPE(*CHAR) LEN(4) RSTD(*YES) +
- DFT(*NO) VALUES(*YES *NO) PROMPT('Use +
- REFFLD field references:')
-
- /*-------------------------------------------------------------------*/
- QUAL1: QUAL TYPE(*NAME) DFT(QRPGLESRC)
- QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) +
- PROMPT('Library')
-
- QUAL2: QUAL TYPE(*NAME) DFT(QDDSSRC) SPCVAL((QDDSSRC))
- QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) +
- PROMPT('Library')
-
-
- ****JCRPRTFH****
- .*-------------------------------------------------------------------*
- .* This program is free software, you can redistribute it and/or *
- .* modify it under the terms of the GNU General Public License as *
- .* published by the Free Software Foundation. See GNU General *
- .* Public License for detail. *
- .* Copyright (C) 2008 Craig Rutledge <www.jcrcmds.com> *
- .*-------------------------------------------------------------------*
- .* JCRPRTF - Generate External Print File - Help Text *
- .* Craig Rutledge *
- .*-------------------------------------------------------------------*
- :PNLGRP.
- :HELP NAME='JCRPRTF'.
- Generate External Print File (JCRPRTF) - Help
- :P.
- The Generate External Print File (JCRPRTF) command allows you to
- generate a DDS external print file source member from the selected RPG4
- (RPGLE or SQLRPGLE) program's O specs.
- :P.Please be aware of the following special circumstances:
- :ul compact.
- :li.Multiple internal spooled files will be consolidated into
- a single external member.
- :li.Array elements will be converted but will require changing as
- these are not allowed in PRTF.
- :li.If entire array name (not indexed) is used, it will be
- converted, but will require conversion to non-array name.
- :li.Control indicators L0-L9 are converted but will have to be
- manually changed as they are not allowed in an external print file.
- :li.Duplicate fields within the same record format must be
- manually changed after the generation.
- :EUL.
- :P.The command
- gets the name of the RPG source member whose O specs are to
- used, the name and location where the generated DDS print file
- member is supposed to go, and whether or not REFFLDs should be
- used in the external print file.
- :NT.This command does not alter the original RPG code in any way.:ENT.
-
- :P.The validity checker program verifies the member exists.
- The command processing program overrides to the selected member and
- runs the RPG program to generate an external print file.
- :NT.The command will create a new DDS source member if one does not
- exists by the name selected. If the DDS member already exists, it
- will be overlayed with the generated code.:ENT.
- .*--------------------------------------------------------------------
- :LINES.
- The objects used by this command are:
- JCRPRTF *CMD Command Prompt
- JCRPRTFC *PGM CLP Command processing program
- JCRPRTFR *PGM RPGLE Generate PRTF DDS from RPG4 O specs
- JCRFLDGETR *PGM RPGLE Get field attributes for RPG4 fields
- JCRRECGETR *PGM RPGLE Get record format data
- JCRFLDCPYR *PGM RPGLE Process /copy members
- JCRPRTFRV *PGM RPGLE Validity checker
- JCRPRTFH *PNLGRP Help Text
- :ELINES.
- :P.Craig Rutledge
- :EHELP.
- .*--------------------------------------------------------------------
- .* HELP TEXT FOR RPGMBR PARAMETER
- .*--------------------------------------------------------------------
- :HELP name='JCRPRTF/RPGMBR'.
- RPG source member(RPGMBR) - Help
- :XH3.RPG source member(RPGMBR)
- :P.
- Specifies the name of the program whose internal O specs will be used
- to generate the external print file DDS source.
- :P.
- This is a required parameter.
- :PARML.
- :PT.program-name
- :PD.Specify the program name.
- :EPARML.
- :EHELP.
- .*--------------------------------------------------------------------
- .* HELP TEXT FOR RPGSRCFIL
- .*--------------------------------------------------------------------
- :HELP name='JCRPRTF/RPGSRCFIL'.
- Source file - Help
- :XH3.Source file (RPGSRCFIL)
- :P.Specifies the name of the source file that contains the source
- program member.
- .*
- :PARML.
- :PT.:PK def.QRPGSRC:EPK.
- :PD.The default source file, QRPGSRC, contains the RPG source program
- to be used.
- .*
- :PT.source-file-name
- :PD.Enter the source file name that contains the RPG source program to
- be used.
- .*
- :PT.:PK def.*LIBL:EPK.
- :PD.The system searches the library list to find the library where the
- source file is located.
- .*
- :PT.library-name
- :PD.Enter the name of the library where the source file is located.
- :EPARML.
- :EHELP.
- .*--------------------------------------------------------------------
- .* HELP TEXT FOR PRTFMBR PARAMETER
- .*--------------------------------------------------------------------
- :HELP name='JCRPRTF/PRTFMBR'.
- DDS member to generate(PRTFMBR) - Help
- :XH3.DDS member to generate(PRTFMBR)
- :P.
- Specifies the DDS member name of the external print file that is
- be generated.
- :P.
- This is a required parameter.
- :PARML.
- :PT.member-name
- :PD.Specify the DDS member name.
- :EPARML.
- :EHELP.
- .*--------------------------------------------------------------------
- .* HELP TEXT FOR PRTFSRCFIL
- .*--------------------------------------------------------------------
- :HELP name='JCRPRTF/PRTFSRCFIL'.
- Source file - Help
- :XH3.Source file (PRTFSRCFIL)
- :P.Specifies the name of the source file that contains the external
- print file member.
- .*
- :PARML.
- :PT.:PK def.QDDSSRC:EPK.
- :PD.The default source file, QDDSSRC, will contain the DDS source
- member to be generated
- .*
- :PT.source-file-name
- :PD.Enter the source file name that will contain the DDS source member.
- .*
- :PT.:PK def.*LIBL:EPK.
- :PD.The system searches the library list to find the library where the
- source file is located.
- .*
- :PT.library-name
- :PD.Enter the name of the library where the source file is located.
- :EPARML.
- :EHELP.
- .*--------------------------------------------------------------------
- .* HELP TEXT FOR USEREFFLD PARAMETER
- .*--------------------------------------------------------------------
- :HELP name='JCRPRTF/USEREFFLD'.
- Use REFFLD field references - Help
- :XH3.Use REFFLD field references (USEREFFLD)
- :P.Specifies whether the external print file is be generated using
- REFFLD or internal field descriptions.
- .*
- :PARML.
- :PT.:PK def.*NO:EPK.
- :PD.Specifies that REFFLDs are not to used in external print file.
- .*
- :PT.*YES
- :PD.Specifies that REFFLD definitions are to used were possible.
- :EPARML.
- :EHELP.
- :EPNLGRP.
-
-
-
- ****JCRPRTFR****
- //---------------------------------------------------------
- // This program is free software, you can redistribute it and/or modify it
- // under the terms of the GNU General Public License as published by
- // the Free Software Foundation. See GNU General Public License for detail.
- // Copyright (C) 2008 Craig Rutledge <www.jcrcmds.com>
- //---------------------------------------------------------
- // JCRPRTFR - Generate External Print File
- // Craig Rutledge
- // Interesting note: RPG o specs use record level spacing/skipping. O specs allow the
- // same record name to be defined multiple times with different spacing and skipping..
- // DDS allows the record format to be defined only once. This requires conversion from
- // the record level definitions in RPG to field level spacing/skipping in the DDS. Ughh..
- //
- // SkipB and SpaceB will coded after the first IPP line after the IPO line..
- // SkipA and SpaceA will coded after the last IPP line in an IPO group.
- //---------------------------------------------------------
- // Program Summary:
- // call program to load field names & attributes into IMPORTed array
- // load output arrays with Positional field data and field names
- //
- // Read RPG o specs
- // Generate DDS PRTF source code
- //---------------------------------------------------------
- H/Define ProgramHeaderSpecs
- H/COPY JCRCMDS,JCRCMDSCPY
- H/UnDefine ProgramHeaderSpecs
-
- Fqrpgsc if f 112 disk ExtFile(i_ExtFile) ExtMbr(i_RpgMbr) input source file
- F usropn
- Fqddssc o a f 92 disk ExtFile(o_ExtFile) ExtMbr(i_DDsMbr) write out DDS
- F usropn
-
- //--*STAND ALONE-------------------------------------------
- D jj s 5u 0 inz
- D kk s 5u 0 inz
- D ps s 5u 0 inz (
- D pe s 5u 0 inz )
- D xd s 5u 0 inz )
- D yy s 5u 0 inz
- D xx s 5u 0 inz
- D vspos s 5i 0 inz
- D Field s 15a inz
- D pStart s 5u 0 inz (
- D vswork s 5i 0 inz
- D Commas s 1a inz
- D SrcSeq s 6s 2 inz
- D oooFMT s like(O_Constant) inz
- D IsWrite s n inz(*off)
- D FileError s 10a inz
- D i_ExtFile s 21a inz
- D o_ExtFile s 21a inz
- D LenActual s 5u 0 inz
- D WriteLine s 1a inz
- D DecimalPos s 1s 0 inz
- D LookupName s 15a inz
- D LinePosSav s like(PrtfDDs.LinePosition) inz
- D HaveFields s 27a inz before control
- D JustDidFmt s 27a inz
- D CommaResult s 5u 0 inz
- D FloatDollar s 3a inz('''$''')
- D TotalLineCnt s 5u 0 inz
- D NewEndingPos s 5u 0 inz
- D EditCodeArry s 1a dim(16) ctdata perrcd(1)
- D EditDataArry s 2a dim(16) alt(EditCodeArry)
- D NegativeType s 1a inz
- D RpgSourceLib s 10a inz
- D DDsSourceLib s 10a inz
- D KeywordSkipa s like(PrtfDDs.Keyword) inz skip after save
- D KeywordSkipb s like(PrtfDDs.Keyword) inz skip before sav
- D DetailLineCnt s 5u 0 inz
- D ExceptLineCnt s 5u 0 inz
- D HeaderLineCnt s 5u 0 inz
- D RpgSourceFile s 10a inz
- D DDsSourceFile s 10a inz
- D KeywordSpacea s like(PrtfDDs.Keyword) inz space after save
- D KeywordSpaceb s like(PrtfDDs.Keyword) inz space before save
- D CommaRemainder s 5u 0 inz
- D LastExceptName s 15a inz
-
- //--*COPY DEFINES------------------------------------------
- D/Define constants
- D/Define ApiErrorDS
- D/Define FieldAttrbDS
- D/Define ArryOfFields
- D/Define f_GetQual
- D/Define f_SndEscapeMsg
- D/Define f_SndCompMsg
- D/Define f_BuildString
- D/Define f_FakeEditWord
- D/Define p_JCRPRTFR
- D/Define p_JCRFLDCPYR
- D/COPY JCRCMDS,JCRCMDSCPY
-
- //--*DATA STRUCTURES---------------------------------------
- D DimSizeA ds
- D DimSize 5s 0 inz numeric dim size
-
- D PlusSignPos ds
- D PlusSignPosN 5s 0 inz
- D
- // Define fields from the different spec types.
- D ds inz
- D SrcDta 1 80a
- // OUTPUT SPECS
- D Comment 7 7a
- D Commentln 8 80a
- D andor 16 18a
- D LineType 17 17a
- D ind 21 29a
- D spaceb 42 42a
- D spacea 45 45a
- D skipb 47 48a
- D skipa 50 51a
- D o_ename 30 43a
- D EditCode 44 44a
- D EndPos 47 51a
- D EndPosN 47 51s 0
- D uppercase 1 51a
- D O_Constant 53 80a
- // DDS SPECS
- D PrtfDDs ds qualified inz
- D SourceType 6 6a
- D AndOr 7 7a
- D CommentLine 8 80a
- D Indicator 8 16a
- D FormatR 17 17a
- D FormatName 19 28a
- D Referenced 29 29a
- D Length 31 34a
- D DataType 35 35a
- D DecimalPos 37 37a
- D LinePosition 42 44a
- D Keyword 45 80a
-
- //--*ENTRY PARMS-------------------------------------------
- D p_JCRPRTFR PI
- D i_RpgMbr 10a
- D i_RpgFileQual 20a
- D i_DDsMbr 10a
- D i_DDsFileQual 20a
- D i_RefFields 4a
-
- //--*INPUT SPECS-------------------------------------------
- Iqrpgsc ns lr 13 c* 14 c* 15 c
- I or 13 c* 14 c* 15 cc named array
- I or 13 c* 14 c* 15 cC named array
- I ns 01 18 cO 19nc/
- I or 18 co 19nc/
- I 13 92 SrcDta
- I ns 03
- I 13 14 Src
- I 18 18 SpecType
- //---------------------------------------------------------
- /free
-
- exsr srInputParms;
- exsr srGetProgramFieldAttributes;
- exsr srReadSource;
-
- f_SndCompMsg('Generation of PRTF for ' +
- %trimr(i_DDsMbr) + ' in ' +
- %trimr(o_ExtFile) + ' - completed.');
-
- *inlr = *on;
- return;
-
- //---------------------------------------------------------
- begsr srInputParms;
- RpgSourceFile = %subst(i_RpgFileQual: 1: 10);
- RpgSourceLib = %subst(i_RpgFileQual: 11: 10);
- DDsSourceFile = %subst(i_DDsFileQual: 1: 10);
- DDsSourceLib = %subst(i_DDsFileQual: 11: 10);
- i_ExtFile = f_GetQual(i_RpgFileQual);
- o_ExtFile = f_GetQual(i_DDsFileQual);
- endsr;
-
- //---------------------------------------------------------
- begsr srGetProgramFieldAttributes;
- // process copy books and selected source
- // load field names and attributes to IMPORT array
- callp p_JCRFLDCPYR(
- i_ExtFile:
- i_RpgMbr:
- 'JCRPRTF ':
- FileError);
-
- // if file-not-found error, send message
- 1b if FileError <> *blanks;
- f_SndEscapeMsg(
- f_BuildString('*ERROR* External file & +
- not found in *Libl.': %trimr(FileError)));
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- begsr srReadSource;
- // open input file and output
- open qrpgsc;
- open qddssc;
-
- read qrpgsc;
- 1b dow not %eof;
- 2b if *inlr //into arrays
- or Src = '**' //compile time array
- or SpecType = 'P' //procedure
- or SpecType = 'p';
- 1v leave;
- 2e endif;
-
- 2b if *in01; //NOT EJECT
-
- //---------------------------------------------------------
- // If comment lines, then translate over as is...
- //---------------------------------------------------------
- 3b if Comment = '*'; //COMMENT LINE
- PrtfDDs.AndOr = Comment; //LOAD DS
- PrtfDDs.CommentLine = Commentln; //LOAD DS
- exsr srWriteSourceCode;
- 3x else;
-
- //---------------------------------------------------------
- uppercase = %xlate(lo: up: uppercase);
-
- 4b if LineType <> *blanks and //IPO LINES D,E,H
- andor <> 'OR ' and //IPO LINES D,E,H
- andor <> 'AND'; //IPO LINES D,E,H
- exsr srFormatLine;
- 4x else; //FIELD/LITERAL
- exsr srFieldLine;
- 4e endif;
- 3e endif;
- 2e endif;
-
- *in01 = *off;
- *in03 = *off;
- read qrpgsc;
- 1e enddo;
-
- // all processed.
- exsr srSpaceAfter;
- close qrpgsc;
- close qddssc;
- endsr;
-
- //---------------------------------------------------------
- // Generate record format code for either except lines
- // or when a new line is coded in the original RPG.
- //---------------------------------------------------------
- begsr srFormatLine;
- IsWrite = *on;
-
- //---------------------------------------------------------
- // If the previous record format had no printable fields
- // or constants defined, then generate the space/skip
- // BEFORE code at record format level.
- //---------------------------------------------------------
- 1b if HaveFields = 'Record Format had no fields';
- exsr srSpaceBefore;
- 1e endif;
-
- exsr srSpaceAfter;
-
- 1b if LineType = 'E'; //EXCPT
- 2b if o_ename <> *blanks
- and o_ename = LastExceptName; //SAME NAMED LINE
- IsWrite = *off;
- 2x else;
-
- 3b if o_ename = *blanks;
- ExceptLineCnt += 1;
- o_ename = %trimr('EXP') +
- %triml(%editc(ExceptLineCnt:'3'));
- 3e endif;
-
- PrtfDDs.FormatName = o_ename;
- LastExceptName = o_ename;
- 2e endif;
-
- 1x elseif LineType = 'H'; //HEADER LINE
- HeaderLineCnt += 1; //HEADER LINE CNT
- PrtfDDs.FormatName = %trimr('HDR') +
- %triml(%editc(HeaderLineCnt:'3'));
- clear LastExceptName;
-
- 1x elseif LineType = 'D'; //DETAIL
- DetailLineCnt += 1;
- PrtfDDs.FormatName = %trimr('DTL') +
- %triml(%editc(DetailLineCnt:'3'));
- clear LastExceptName;
-
- 1x elseif LineType = 'T'; //TOTAL
- TotalLineCnt += 1;
- PrtfDDs.FormatName = %trimr('TOT') +
- %triml(%editc(TotalLineCnt:'3'));
- clear LastExceptName;
- 1e endif;
-
- 1b if IsWrite;
- PrtfDDs.FormatR = 'R';
- exsr srWriteSourceCode;
- 1e endif;
-
- //---------------------------------------------------------
- // Space or Skip before must after the first field
- // (or constant) defined after the record format record.
- // They are saved for after the first field in the recfmt.
- //---------------------------------------------------------
- 1b if spaceb > ' '; //SPACE BEFORE
- KeywordSpaceb = %trimr('SPACEB(') + spaceb+')';
- 1e endif;
-
- 1b if skipb > ' '; //SKIP BEFORE
- KeywordSkipb = %trimr('SKIPB(') + skipb + ')';
- 1e endif;
-
- //---------------------------------------------------------
- // Space or Skip after must go at the end of each group.
- // Checked at the beginning of each record format.
- //---------------------------------------------------------
- 1b if spacea > ' '; //SPACE AFTER
- KeywordSpacea = %trimr('SPACEA(') + spacea+')';
- 1e endif;
-
- 1b if skipa > ' '; //SKIP AFTER
- KeywordSkipa = %trimr('SKIPA(') + skipa+')';
- 1e endif;
-
- clear vspos; //reset EndPos
- HaveFields = 'Record Format had no fields';
- JustDidFmt = 'Just did the record format ';
- endsr;
-
- //---------------------------------------------------------
- // Generate Skip or Space before DDs code.
- //---------------------------------------------------------
- begsr srSpaceBefore;
- 1b if KeywordSpaceb <> *blanks; //SPACE BEFORE
- PrtfDDs.Keyword = KeywordSpaceb;
- exsr srWriteSourceCode;
- 1e endif;
-
- 1b if KeywordSkipb <> *blanks; //SKIP BEFORE
- PrtfDDs.Keyword = KeywordSkipb;
- exsr srWriteSourceCode;
- 1e endif;
-
- clear KeywordSpaceb;
- clear KeywordSkipb;
- endsr;
-
- //---------------------------------------------------------
- // Generate Skip or Space after DDs code.
- //---------------------------------------------------------
- begsr srSpaceAfter;
- 1b if KeywordSpacea <> *blanks; //SPACE AFTER
- PrtfDDs.Keyword = KeywordSpacea;
- exsr srWriteSourceCode;
- 1e endif;
-
- 1b if KeywordSkipa <> *blanks; //SKIP AFTER
- PrtfDDs.Keyword = KeywordSkipa;
- exsr srWriteSourceCode;
- 1e endif;
-
- clear KeywordSpacea;
- clear KeywordSkipa;
- endsr;
-
- //---------------------------------------------------------
- // Determine whether a field name or constant is to be loaded.
- //---------------------------------------------------------
- begsr srFieldLine; //IPP SPECS
- clear LenActual;
- HaveFields = 'Record Format has fields ';
-
- 1b if o_ename <> *blanks; //FIELD NAMES
- WriteLine = 'N'; //SET TO NO
-
- Field = o_ename;
-
- //---------------------------------------------------------
- // There could be an indexed array name as an output field.
- // Do a lookup with the array name to get the attributes.
- //---------------------------------------------------------
- LookupName = o_ename;
- aa = %scan('(': LookupName: 1);
- 2b if aa <> 0;
- LookupName = %subst(LookupName: 1: aa - 1);
- 2e endif;
- aa = %lookup(LookupName: ArryFieldNames: 1:
- ArryOfFields_NumberOfEntries);
- 2b if aa > 0;
- FieldAttrbDS = ArryFieldAttrb(aa);
- 3b if FieldAttrbDS.DecimalPos = *blanks;
- DecimalPos = 0;
- 3x else;
- DecimalPos = FieldAttrbDS.DecimalPosN;
- 3e endif;
- PrtfDDs.FormatName = o_ename;
-
- //---------------------------------------------------------
- // Back to the array fun! It could be that an
- // that an un-indexed array name was coded on output.
- // The JCRFLDCPYR program brings in the array definitions
- // in two parts. Multiply element length by num elements.
- //---------------------------------------------------------
- ps = %scan('DIM(': FieldAttrbDS.Text: 1);
- 3b if ps <> 0 //start of DIM(
- and LookupName = o_ename; //not indexed
- pe = %scan(')': FieldAttrbDS.Text: ps);
- 4b if pe <> 0; //end of )
-
- xd = (pe - 1) - 4;
- pStart = 6 - xd;
- DimSizeA = *blanks;
- %subst(dimsizea: pStart: xd) =
- %subst(FieldAttrbDS.Text: 5: xd);
- 5b if DimSizeA = *blanks;
- DimSize = 0;
- 5e endif;
- FieldAttrbDS.Length = FieldAttrbDS.Length * dimsize;
- 4e endif;
- 3e endif;
- //---------------------------------------------------------
- // if ename = 'PAGE ' PAGE CONV
- // PrtfDDs.FormatName = orgfld
- // endif
- PrtfDDs.Indicator = ind;
-
- //---------------------------------------------------------
- // If field was defined via an external file definition and
- // the user specified that field references should be used,
- // use the REFFLD keyword, otherwise hardcode the actual field
- // characteristics.
- //---------------------------------------------------------
- 3b if FieldAttrbDS.FromFile <> ' ' and //INTERNALLY DESC
- i_RefFields = '*YES'; //USE REFERENCES
- PrtfDDs.Referenced = 'R';
-
- PrtfDDs.Keyword = 'REFFLD(' + %trimr(PrtfDDs.FormatName) +
- ' *LIBL/' + %trimr(FieldAttrbDS.FromFile) + ')';
- 3x else;
-
- //---------------------------------------------------------
- // Hard code fields that are not referenced.
- //---------------------------------------------------------
- 4b if FieldAttrbDS.DataType = 'A';
- evalr PrtfDDs.Length = %editc(FieldAttrbDS.Length:'4');
- clear PrtfDDs.DataType;
- clear PrtfDDs.DecimalPos;
-
- 4x elseif FieldAttrbDS.DataType = 'D'
- or FieldAttrbDS.DataType = 'T'
- or FieldAttrbDS.DataType = 'Z';
- clear PrtfDDs.Length;
- 5b if FieldAttrbDS.DataType = 'D';
- PrtfDDs.DataType = 'L';
- 5x else;
- PrtfDDs.DataType = FieldAttrbDS.DataType;
- 5e endif;
- clear PrtfDDs.DecimalPos;
-
- 4x else;
- evalr PrtfDDs.Length = %editc(FieldAttrbDS.Length:'4');
- clear PrtfDDs.DataType;
- PrtfDDs.DecimalPos = %editc(DecimalPos:'3');
- 4e endif;
- WriteLine = 'Y';
- 3e endif;
-
- 2e endif;
-
- //---------------------------------------------------------
- // Calculate starting Position of either field or constant.
- //---------------------------------------------------------
- LenActual = FieldAttrbDS.Length;
-
- 2b if EditCode > ' ';
- exsr srAllowForEditCode;
-
- 2x elseif O_Constant <> *blanks; //GET CONST LENGT
-
- 3b if FieldAttrbDS.DataType = 'D'
- or FieldAttrbDS.DataType = 'T'
- or FieldAttrbDS.DataType = 'Z';
- exsr srMakeLikeAnEditWord;
- 3e endif;
-
- kk = %checkr(' ': O_Constant);
- LenActual = kk - 2; //CALC LENGTH
- 2e endif;
- //---------------------------------------------------------
- // If ending Position is blank, load +0 and let
- // the calc ending subroutine handle it . if there
- // is a + sign in the end Position, then calc ending pos.
- //---------------------------------------------------------
- 2b if EndPos = *blanks;
- EndPos = ' +0';
- 2e endif;
- bb = %scan('+': Endpos: 1);
- 2b if bb <> 0;
- exsr srCalcEndingPos; //found one
- 2e endif;
- //---------------------------------------------------------
- vspos = EndPosN;
- vswork = vspos;
- vswork = vswork - LenActual;
- vswork += 1;
- evalr PrtfDDs.LinePosition = %editc(vswork:'4');
-
- //---------------------------------------------------------
- // Handle exception of UDATE. The entire line is cleared and
- // the starting Position and the new DATE keyword are written.
- //---------------------------------------------------------
- 2b if PrtfDDs.FormatName = 'UDATE '; //RESERVED WORD
- LinePosSav = PrtfDDs.LinePosition;
- WriteLine = 'N';
-
- clear PrtfDDs; //CLEAR OUTPUT
- PrtfDDs.LinePosition = LinePosSav; //RELOAD
- PrtfDDs.Keyword = 'DATE'; //LOAD KEYWORD
- 2e endif;
-
- 2b if WriteLine <> 'Y';
- exsr srWriteSourceCode;
- 2e endif;
-
- //---------------------------------------------------------
- // If floating dollar sign, include in EDTCDE keyword)
- //---------------------------------------------------------
- 2b if EditCode > ' ';
- PrtfDDs.Keyword = 'EDTCDE(' + EditCode + ')';
- 3b if O_Constant = FloatDollar;
- PrtfDDs.Keyword = 'EDTCDE(' + EditCode + ' $)';
- 3e endif;
- exsr srWriteSourceCode;
- clear WriteLine;
-
- 2x elseif O_Constant <> *blanks; //EDTWRD SPECIFID
- 3b if FieldAttrbDS.DataType = 'D'
- or FieldAttrbDS.DataType = 'T'
- or FieldAttrbDS.DataType = 'Z';
- PrtfDDs.Keyword = oooFMT;
- 3x else;
- PrtfDDs.Keyword = 'EDTWRD(' + %trimr(O_Constant) +')';
- 3e endif;
- exsr srWriteSourceCode;
- clear WriteLine;
- 2e endif;
-
- 2b if WriteLine = 'Y';
- exsr srWriteSourceCode;
- 2e endif;
-
- 1x elseif O_Constant <> *blanks; //CONSTANTS
- jj = %checkr(' ': O_Constant);
- PrtfDDs.Indicator = ind;
- //---------------------------------------------------------
- 2b if EndPos = *blanks;
- EndPos = ' +0';
- 2e endif;
- bb = %scan('+': Endpos: 1);
- 2b if bb <> 0;
- exsr srCalcEndingPos; //found one
- 2e endif;
- //---------------------------------------------------------
- vspos = EndPosN;
- vswork = vspos; //CALC
- vswork -= jj; //STARTING
- vswork += 3; //Position.
- evalr PrtfDDs.LinePosition = %editc(vswork:'4'); //LOAD FLD LENGTH
- PrtfDDs.Keyword = O_Constant; //LOAD CONSTANT
- exsr srWriteSourceCode;
- 1e endif;
-
- //---------------------------------------------------------
- 1b if JustDidFmt = 'Just did the record format ';
- exsr srSpaceBefore;
- JustDidFmt = 'Not ';
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // New to O specs is the ability to format date, time and
- // and timestamp fields. I have decided the best way to
- // handle it would be to
- // create a fake edit word based on type field and
- // and type formating selected.
- //---------------------------------------------------------
- begsr srMakeLikeAnEditWord;
- clear oooFMT;
- 1b if FieldAttrbDS.DataType = 'Z';
- 1x else;
- O_Constant = %xlate(lo: up: O_Constant);
-
- 2b if FieldAttrbDS.DataType = 'T';
- oooFMT = 'TIMFMT(' + %trimr(O_Constant) + ')';
-
- 2x elseif FieldAttrbDS.DataType = 'D';
- oooFMT = 'DATFMT(' + %trimr(O_Constant) + ')';
-
- 2e endif;
- 1e endif;
- O_Constant = f_FakeEditWord(O_Constant: FieldAttrbDS.DataType);
- endsr;
-
- //---------------------------------------------------------
- // Allow for the effects of edit codes on overall field length.
- //---------------------------------------------------------
- begsr srAllowForEditCode;
- 1b if EditCode = 'Y';
-
- 2b if FieldAttrbDS.Length = 3
- or FieldAttrbDS.Length = 4;
- LenActual += 1;
- 2x elseif FieldAttrbDS.Length >= 5
- and FieldAttrbDS.Length <= 9;
- LenActual += 2;
- 2e endif;
-
- 1x else;
- jj = %lookup(EditCode: EditCodeArry: 1);
- 2b if jj > 0;
- Commas = %subst(EditDataArry(jj): 1: 1); //USE COMMAS?
- NegativeType = %subst(EditDataArry(jj): 2: 1); //WHAT TYPE NEG
-
- 3b if O_Constant = FloatDollar; //FLOATING $
- LenActual += 1;
- 3e endif;
-
- 3b if DecimalPos > 0; //ADJUST FOR DEC
- LenActual += 1;
- 3e endif;
-
- 3b if NegativeType = '-'; //MINUS SIGN
- LenActual += 1;
- 3x elseif NegativeType = 'C'; //CR SIGN
- LenActual += 2;
- 3e endif;
-
- 3b if Commas = 'Y'; //ALLOW FOR COMMA
- CommaResult = FieldAttrbDS.Length - DecimalPos;
- CommaResult = %div(CommaResult: 3); //HOW MANY COMMAS
- CommaRemainder = %rem(CommaResult: 3); //HOW MANY COMMAS
-
- 4b if CommaRemainder = 0 and CommaResult > 0; //EVENLY DIVIDED
- CommaResult -= 1;
- 4e endif;
-
- LenActual += CommaResult;
- 3e endif;
- 2e endif;
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // Write records to the DDs member.
- //---------------------------------------------------------
- begsr srWriteSourceCode;
- PrtfDDs.SourceType = 'A';
- SrcSeq += .01;
- except DDsout; //WRITE DDs
- clear PrtfDDs;
- endsr;
-
- //---------------------------------------------------------
- // CALCULATE ENDING Position
- //---------------------------------------------------------
- begsr srCalcEndingPos;
- yy = 2;
- xx = 0;
-
- 1b if o_ename <> ' '
- and %subst(O_Constant: 1: 1) <> ' '
- and O_Constant <> FloatDollar;
- 2b dow %subst(O_Constant: yy: 1) <> '''';
- xx += 1;
- yy += 1;
- 2e enddo;
-
- 1x elseif o_ename = ' '
- and %subst(O_Constant: 1: 1) <> ' ';
- 2b dow yy < 29
- and %subst(O_Constant: yy: 1) <> '''';
- xx += 1;
- yy += 1;
- 2e enddo;
- 1e endif;
-
- // Positions between fields
- clear PlusSignPos;
- %subst(PlusSignPos: bb + 1) = %subst(EndPos: bb + 1);
-
- // new ending Position
- NewEndingPos = vspos + PlusSignPosn+ xx;
-
- 1b if xx = 0; //no edit word
- NewEndingPos += LenActual;
- 1e endif;
-
- EndPosN = NewEndingPos;
- endsr;
- /end-free
- Oqddssc eadd DDsout
- O SrcSeq 6
- O PrtfDDs 92
- //
- *EDIT CODE COMMAS (Y/N) TYPE SIGN(None,Cr,or -)
- **
- 1YN 1
- 2YN 2
- 3NN 3
- 4NN 4
- AYC 5
- BYC 6
- CNC 7
- DNC 8
- JY- 9
- KY- 10
- LN- 11
- MN- 12
- NY- 13
- OY- 14
- PN- 15
- QN- 16
-
-
-
-
- ****JCRRECGETR****
- //---------------------------------------------------------
- // This program is free software, you can redistribute it and/or modify it
- // under the terms of the GNU General Public License as published by
- // the Free Software Foundation. See GNU General Public License for detail.
- // Copyright (C) 2008 Craig Rutledge <www.jcrcmds.com>
- //---------------------------------------------------------
- // JCRRECGETR - Get file info for files used in RPG source
- // Craig Rutledge
- //---------------------------------------------------------
- // Program Summary:
- // read Rpg F specs
- // optionally read D specs for external DS names
- // call apis to extract record format names.
- // call api to extract based on physical file name
-
- // INCLUDE logic is difficult to follow.
- // an Include is really an explicit IGNORE.
- // 1. need to know if a file has an INCLUDE statement.
- // 2. need to know what record formats to include.
- // 3. need to figure out what formats to IGNORE.
- //
- // Will have to wait till aLL formats are loaded into previous
- // array then then spin back through and remove the ones for
- // files that have an include and are not included.
- // Ughh..
- // Build an array of all INCLUDE file/record formats
- //
- // 1. an array of just file names to select files with includes
- // 2. an array of file||recordformat names for look up to see they are in the include array.
- //---------------------------------------------------------
- // api (application program interfaces) used:
- // qdbrtvfd Retrieve File Desc
- // quslrcd List Record Formats
- // tstbts MI Test Bits
- //---------------------------------------------------------
- H/Define ProgramHeaderSpecs
- H/COPY JCRCMDS,JCRCMDSCPY
- H/UnDefine ProgramHeaderSpecs
-
- Fqrpgsc if f 112 disk ExtFile(i_ExtFile) ExtMbr(i_ExtMbr)
- F usropn
-
- //--*STAND ALONE-------------------------------------------
- D cc s like(aa) inz
- D ff s 5u 0 inz include indexes
- D vl s like(aa) inz
- D vi s like(aa) inz
- D fff s 5u 0 inz include indexes
- D Index s 3u 0 inz
- D arrsort s 100a dim(300) ascend inz Sorted Names & Data
- D FileText s 50a inz
- D SavPrefix s 10a inz
- D BasedOnPF s 10a inz
- D BitOffset s 10u 0 inz(2)
- D FldPrefix s 10a inz
- D SavPrefix_ s 1s 0 inz
- D SaveDSname s 15a inz
- D RecordType s 1a inz
- D FileFormat s 35a inz
- D FileDSname s 25a inz
- D ForCounter s like(aa) inz
- D IsIncluded s n inz(*off)
- D RenamedFmt s 10a inz
- D FilNamSave s 10a inz
- D SavKeyWord4 s like(KeyWord4) inz
- D IsContinued s n inz(*off)
- D ForCounter1 s like(aa) inz
- D BeingRenamed s 10a inz
- D Beingignored s 10a inz
- D IsFirstRecFmt s n inz(*off)
- D Beingincluded s 10a inz
- D UserSpaceName s 20a inz('JCRCMDS QTEMP ')
- D ReturnFileQual s 20a inz
- D IncludedFormat s 35a dim(300) inz
- D WorkFileAndLib s 20a inz
- D FilesWithInclude...
- D s 25a dim(300) inz
-
- //--*COPY DEFINES------------------------------------------
- D/Define tstbts
- D/Define quslrcd
- D/Define qdbrtvfd
- D/Define constants
- D/Define ApiErrorDS
- D/Define fild0100DS
- D/Define ParseElemDS
- D/Define ListHeaderDS
- D/Define UserSpaceHeaderDS
- D/Define f_Quscrtus
- D/Define p_JCRRECGETR
- D/COPY JCRCMDS,JCRCMDSCPY
-
- //--*DATA STRUCTURES---------------------------------------
- // define element of array to process record formats
- D replacea ds
- D replacec 1s 0 inz replace prefix
-
- //---------------------------------------------------------
- // Record formats to include or ignore
- // returned by f_GetRecFmts.
- //---------------------------------------------------------
- D ArryOfRecFmts s 10a dim(15) inz
-
- //--*FUNCTION PROTOTYPES-----------------------------------
- D f_ExtractFmts PR 10a dim(15)
- Da like(KeyWord4) const
-
- //--*ENTRY PARMS-------------------------------------------
- D p_JCRRECGETR PI
- D i_ExtFile 21a
- D i_ExtMbr 10a
- D i_CmdSwitch 10a const
- D i_Mbrtyp 4a const
- D i_ReturnFiles 30000a
-
- //--*INPUT SPECS-------------------------------------------
- Iqrpgsc ns
- I a 13 14 ArrayLineType
- I a 18 18 LineType
- I a 19 19 Asterisk
- // rpg 4 locations
- I a 19 28 FileName
- I a 19 33 defFieldName
- I a 29 29 Usage I U O
- I a 34 34 EorF E or F
- I a 36 37 Defds Data structure defn
- I a 48 55 Device DISK, PRINTER, etc
- I a 56 92 KeyWord4 Rename(a:b)
- // rpg 3 locations
- I a 19 26 FileName3
- I a 27 27 Usage3 I U O
- I a 31 31 eorf3 E or F
- I a 52 58 Device3 DISK, PRINTER, etc
- I a 31 40 BeingRenamed3 KRENAME
- I a 65 71 KeyWord3 KRENAME
- I a 72 81 Renamed3 KRENAME
-
- /free
- //---------------------------------------------------------
- // create user space for the api.
- //---------------------------------------------------------
- clear i_ReturnFiles;
- GenericHeaderPtr = f_Quscrtus(UserSpaceName);
-
- //---------------------------------------------------------
- open qrpgsc;
- read qrpgsc;
- 1b dow not %eof;
-
- // finished with F and D specs
- 2b if ArrayLineType = '**'
- or LineType = 'C'
- or LineType = 'c'
- or LineType = 'O'
- or LineType = 'o'
- or LineType = 'P'
- or LineType = 'p';
- 1v leave;
- 2e endif;
-
- 2b if not (Asterisk = '*'
- or Asterisk = '/');
- ParseElemDS.SortSequence = '1';
-
- 3b if LineType = 'F'
- or LineType = 'f';
- exsr srFileSpec;
-
- 3x elseif LineType = 'D'
- or LineType = 'd';
- 4b if i_CmdSwitch = 'JCRRFIL ';
- 1v leave;
- 4x else;
- exsr srDefinitionSpec;
- 4e endif;
- 3e endif;
- 2e endif;
-
- read qrpgsc;
- 1e enddo;
-
- exsr srLoadReturnParm;
- close qrpgsc;
- *inlr = *on;
- return;
-
- //---------------------------------------------------------
- // load the fields from the f spec externally described fields.
- //---------------------------------------------------------
- begsr srFileSpec;
- clear RenamedFmt;
- clear SaveDSname;
- 1b if i_Mbrtyp = 'RPG4';
- FileName = %xlate(lo: up: FileName);
- eorf = %xlate(lo: up: eorf);
- Device = %xlate(lo: up: Device);
- Usage = %xlate(lo: up: Usage);
- 1x else;
- FileName = FileName3;
- eorf = eorf3;
- Device = Device3;
- Usage = Usage3;
- 1e endif;
- //---------------------------------------------------------
- 1b if FileName <> *blanks
- and eorf = 'E'
- and (Device = 'DISK '
- or (i_CmdSwitch <> 'JCRRFIL '
- and (Device = 'PRINTER '
- or Device = 'WORKSTN ')));
-
- 2b if Device = 'PRINTER '
- or Device = 'WORKSTN ';
- ParseElemDS.SortSequence = '2'; //process last
- 2e endif;
-
- FilNamSave = FileName;
- RecordType = 'F';
- exsr srLoadFileFields;
- 1e endif;
- //---------------------------------------------------------
- 1b if i_Mbrtyp = 'RPG4' and //check for Renames
- KeyWord4 > *blanks;
- KeyWord4 = %xlate(lo: up: KeyWord4);
- exsr srCheckRenamedFormat4;
- exsr srCheckIgnoredFormat4;
- exsr srCheckIncludedFormat4;
- 2b if i_CmdSwitch <> 'JCRRFIL ';
- exsr srCheckPrefixFormat4;
- 2e endif;
- 1e endif;
- //---------------------------------------------------------
- 1b if i_Mbrtyp = 'RPG3'; //check for Renames
- 2b if KeyWord3 = 'KRENAME';
- BeingRenamed = BeingRenamed3;
- RenamedFmt = Renamed3;
- exsr srOverlayRenamedFormats;
- 2x elseif KeyWord3 = 'KIGNORE';
- Beingignored = BeingRenamed3;
- exsr srRemoveIgnoredFormats;
- 2e endif;
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // Load externally described Data Structures file information
- // This gets complex as File name could either be DS name
- // or an EXTNAME( defined either on the same line as the DS or
- // on one of the subsequent lines.
- //---------------------------------------------------------
- begsr srDefinitionSpec;
- eorf = %xlate(lo: up: eorf);
- Defds = %xlate(lo: up: Defds);
- defFieldName = %xlate(lo: up: defFieldName);
- KeyWord4 = %xlate(lo: up: KeyWord4);
-
- //---------------------------------------------------------
- // First pass, assume no EXTNAME( exists. Go to file load
- // subroutine with the data structure name as the file.
- //---------------------------------------------------------
- 1b if eorf = 'E'
- and Defds = 'DS';
- SaveDSname = %triml(defFieldName);
- FileName = SaveDSname;
- FilNamSave = SaveDSname;
- IsFirstRecFmt = *on;
- RecordType = 'D';
- exsr srLoadFileFields;
- IsFirstRecFmt = *off;
- 1e endif;
-
- //---------------------------------------------------------
- // If there is a EXTNAME(, then things get a little messy again.
- // It can have the format of extname(xxx) which means use the
- // first record format of this file or extname(xxxx:recfmt)
- // which means to use selected record format.
- // On top of this, I have already written an array element
- // when I tried using only DS name in previous section.
- // On top of this, I MAY have updated the array element
- // with the PREFIX so I gotta Save it and reload it.
- //---------------------------------------------------------
- aa = %scan('EXTNAME(': KeyWord4);
- 1b if aa > 0;
- ParseElemDs = arrsort(vl);
- SavPrefix = ParseElemDS.Prefix;
- SavPrefix_ = ParseElemDS.Prefix_chr;
- clear arrsort(vl);
- vl -= 1;
-
- cc = %scan(':': KeyWord4: aa);
- bb = %scan(')': KeyWord4: aa);
- 2b if cc = 0 or cc > bb; //use *first recordfmt
- IsFirstRecFmt = *on;
- FileName = %triml(%subst(KeyWord4: aa + 8: (bb - aa) - 8));
- FilNamSave = FileName;
- 2x else;
-
- //---------------------------------------------------------
- // extname(xxx:recfmt). This is as messy as it gets.
- // If a record format is selected, that is an implicit
- // INCLUDE. I am going to dummy up an INCLUDE
- // statement, so the file processor can
- // automatically only load this record format.
- // First, extract filename and record format name.
- //---------------------------------------------------------
- FileName = %subst(KeyWord4: aa + 8: (cc - aa) - 8);
- Beingincluded = %subst(KeyWord4: cc + 1: (bb - cc) - 1);
- SavKeyWord4 = KeyWord4;
- KeyWord4 = 'INCLUDE('+ %trimr(Beingincluded) + ')';
- FilNamSave = FileName;
- exsr srCheckIncludedFormat4;
- KeyWord4 = SavKeyWord4;
- 2e endif;
- exsr srLoadFileFields;
- clear SavPrefix;
- clear SavPrefix_;
- IsFirstRecFmt = *off;
- 1e endif;
- //---------------------------------------------------------
- 1b if KeyWord4 > *blanks;
- KeyWord4 = %xlate(lo: up: KeyWord4);
- exsr srCheckPrefixFormat4;
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // load fields from either e DS or regular DS.
- //---------------------------------------------------------
- begsr srLoadFileFields;
-
- //---------------------------------------------------------
- // load the user space with information similar to
- // *basatr option on dspfd command. Pointers are used
- // to load the data structures.
- //---------------------------------------------------------
- callp QUSLRCD(
- UserSpaceName :
- 'RCDL0200' :
- FileName + '*LIBL ':
- '1' :
- ApiErrDS);
-
- 1b if ApiErrDS.BytesReturned = 0; //found it!
- exsr srCallJCRDbrr; //get based on files
-
- //---------------------------------------------------------
- // Process data from user space.
- // GenericHeader.ListEntryCount contains the number of data blocks to get.
- // Move pointer to user space to 'retrieve' each entry.
- // Note: some processes only want the first record format.
- // so only do the 1 record format for those.
- //---------------------------------------------------------
- 2b if IsFirstRecFmt;
- GenericHeader.ListEntryCount = 1;
- 2e endif;
-
- quslrcdPtr = GenericHeaderPtr + GenericHeader.OffSetToList;
- 2b for ForCounter = 1 to GenericHeader.ListEntryCount;
-
- // Load array
- vl += 1;
- ParseElemDS.FileName = FileName;
- ParseElemDS.FormatName = quslrcdDS.RecordFormat;
- ParseElemDS.FormatRename = *blanks;
- ParseElemDS.BasedOnPF = BasedOnPF;
- ParseElemDS.HowUsed = Usage;
-
- 3b if quslrcdDS.FormatText <> *blanks;
- ParseElemDS.FileText = quslrcdDS.FormatText;
- 3x else;
- ParseElemDS.FileText = FileText;
- 3e endif;
- ParseElemDS.IsDataStruct = RecordType;
- ParseElemDS.DSname = SaveDSname;
- ParseElemDS.Prefix = SavPrefix;
- ParseElemDS.Prefix_chr = SavPrefix_;
- arrsort(vl) = ParseElemDs;
-
- quslrcdPtr += GenericHeader.ListEntrySize;
- 2e endfor;
- // ---ERROR OCCURRED------------------------
- 1x else;
- vl += 1;
- clear ParseElemDs;
- ParseElemDS.FileName = FileName;
- ParseElemDS.FormatRename = RenamedFmt;
- ParseElemDS.BasedOnPF = '*NOT FOUND';
- ParseElemDS.FileText = '*FILE NOT FOUND';
- ParseElemDS.IsDataStruct = RecordType;
- ParseElemDS.DSname = SaveDSname;
- arrsort(vl) = ParseElemDs;
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // extract the RENAME values from RPG4 code.
- //---------------------------------------------------------
- begsr srCheckRenamedFormat4;
- bb = %scan('RENAME(': KeyWord4);
- 1b if bb > 0;
- aa = %scan(':': KeyWord4: bb);
- BeingRenamed = %subst(KeyWord4: bb + 7: aa - (bb + 7));
- bb = %scan(')': KeyWord4: aa);
- RenamedFmt = %subst(KeyWord4: aa + 1: (bb - aa) - 1);
- exsr srOverlayRenamedFormats;
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // Check if record formats should be IGNORED from this file.
- // Note : multiple formats could be in one statement separated by : .
- // The element in the Save file will be cleared for this record format.
- //---------------------------------------------------------
- begsr srCheckIgnoredFormat4;
- IsContinued = *off;
- bb = %scan('IGNORE(': KeyWord4);
- 1b if bb > 0;
-
- 2b dou not IsContinued;
- ArryOfRecFmts = f_ExtractFmts(KeyWord4);
- 3b for Index = 1 to %elem(ArryOfRecFmts);
- 4b if ArryOfRecFmts(Index) = *blanks;
- 3v leave;
- 4e endif;
- Beingignored = ArryOfRecFmts(Index);
- exsr srRemoveIgnoredFormats;
- 3e endfor;
-
- // check for continuation
- IsContinued = (%scan(')': KeyWord4) = 0);
- 3b If IsContinued;
- read qrpgsc;
- KeyWord4 = %xlate(lo: up: KeyWord4);
- 3e endif;
- 2e enddo;
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // Several commands are concerned with file Prefix statements.
- // This subroutine extracts the Prefix value and any
- // number-char-to-replace values.
- //---------------------------------------------------------
- begsr srCheckPrefixFormat4;
- aa = %scan('PREFIX(': KeyWord4);
- 1b if aa > 0;
- cc = %scan(':': KeyWord4: aa);
- bb = %scan(')': KeyWord4: aa);
- 2b if cc = 0 or cc > bb; //: not found OR 0 (other:func)
- FldPrefix = %subst(KeyWord4: aa + 7: (bb - aa) - 7);
- clear replacec;
- 2x else;
- FldPrefix = %subst(KeyWord4: aa + 7: (cc - aa) - 7);
- replacea = %subst(KeyWord4: cc + 1: 1);
- 3b if replacea = ' ';
- replacec = 0;
- 3e endif;
- 3b if replacec < %len(%trimr(FldPrefix));
- replacec = %len(%trimr(FldPrefix));
- 3e endif;
- 2e endif;
-
- //---------------------------------------------------------
- // If match is found, load PREFIX data.
- //---------------------------------------------------------
- 2b for aa = 1 to vl;
- ParseElemDs = arrsort(aa);
- 3b if ParseElemDS.FileName = FilNamSave
- and ParseElemDS.DSname = SaveDSname;
- ParseElemDS.Prefix = FldPrefix;
- ParseElemDS.Prefix_chr = replacec;
- arrsort(aa) = ParseElemDs;
- 3e endif;
- 2e endfor;
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // remove IGNORE record formats from array.
- // If a match is found on an Ignored record format,
- // clear the array element.
- //---------------------------------------------------------
- begsr srRemoveIgnoredFormats;
- 1b for aa = 1 to vl;
- ParseElemDs = arrsort(aa);
- 2b if ParseElemDS.FormatName = Beingignored
- and ParseElemDS.FileName = FilNamSave;
- clear arrsort(aa);
- 1v leave;
- 2e endif;
- 1e endfor;
- endsr;
-
- //---------------------------------------------------------
- // Check to see what record formats are INCLUDED for this file.
- // Note : multiple formats could be in one statement separated by : .
- //---------------------------------------------------------
- begsr srCheckIncludedFormat4;
- IsContinued = *off;
- bb = %scan('INCLUDE(': KeyWord4);
- 1b if bb > 0;
-
- 2b dou not IsContinued;
- ArryOfRecFmts = f_ExtractFmts(KeyWord4);
- 3b for Index = 1 to %elem(ArryOfRecFmts);
- 4b if ArryOfRecFmts(Index) = *blanks;
- 3v leave;
- 4e endif;
- Beingincluded = ArryOfRecFmts(Index);
- exsr srSaveIncludedFormats;
- 3e endfor;
-
- // check for continuation
- IsContinued = (%scan(')': KeyWord4) = 0);
- 3b If IsContinued;
- read qrpgsc;
- KeyWord4 = %xlate(lo: up: KeyWord4);
- 3e endif;
- 2e enddo;
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // This is kinda hard to follow. The idea is, after all
- // records have been processed, spin through FilesWithInclude array to
- // get all the files that have includes. Then if file
- // does have an include, lookup from the ArrSort
- // into the IncludedFormat array.
- // if the entry is not found, then remove the arrsort entry.
- // Here I am only loading the file and file format arrays.
- //---------------------------------------------------------
- begsr srSaveIncludedFormats;
- FileDSname = FilNamSave + SaveDSname;
- 1b if %lookup(FileDSname: FilesWithInclude) = 0;
- ff += 1;
- FilesWithInclude(ff) = FilNamSave + SaveDSname;
- 1e endif;
- fff += 1;
- IncludedFormat(fff) = Beingincluded + FilNamSave + SaveDSname;
- endsr;
-
- //---------------------------------------------------------
- // Load renamed record formats into ARRAY.
- // Spin back though array looking for match with original
- // recfmt name. When found, update array with Renamed fmt name.
- //---------------------------------------------------------
- begsr srOverlayRenamedFormats;
- 1b for aa = 1 to vl;
- ParseElemDs = arrsort(aa);
- 2b if ParseElemDS.FormatName = BeingRenamed
- and ParseElemDS.FileName = FilNamSave;
- ParseElemDS.FormatRename = RenamedFmt;
- arrsort(aa) = ParseElemDs;
- 1v leave;
- 2e endif;
- 1e endfor;
- endsr;
-
- //---------------------------------------------------------
- // if the selected file is a logical, the based-on-physical name
- // is extracted and processing continues as if a physical had
- // been selected.
- //---------------------------------------------------------
- begsr srCallJCRDbrr;
- clear BasedOnPF;
- 1b if Device = 'DISK ';
- WorkFileAndLib = FileName + '*LIBL ';
-
- callp QDBRTVFD(
- FileHeader :
- %size(FileHeader):
- ReturnFileQual:
- 'FILD0100' :
- WorkFileAndLib:
- '*FIRST ':
- '0' :
- '*LCL ':
- '*EXT ':
- ApiErrDS);
-
- 2b if ApiErrDS.BytesReturned > 0;
- BasedOnPF = 'NOT FOUND ';
- 2x else;
- fscopePtr = FileHeaderPtr + FileHeader.OffsFileScope;
- 3b if tstbts(FileHeader.TypeBits: BitOffset) = 1;
- BasedOnPF = FileScopeArry.BasedOnPf;
- 3e endif;
-
- ListHeaderPtr = GenericHeaderPtr + GenericHeader.OffSetToHeader;
- FileText = ListHeaderDS.FileText;
- 2e endif;
- 1e endif;
- 1b if Device <> 'DISK ';
- FileText = Device;
- 1e endif;
- endsr;
-
- //---------------------------------------------------------
- // load the output parm from the array.
- //---------------------------------------------------------
- begsr srLoadReturnParm;
- cc = 1;
-
- sorta arrsort;
- ForCounter1 = %elem(arrsort);
- vi = ForCounter1 - vl + 1;
-
- 1b for aa = vi to ForCounter1;
-
- 2b if arrsort(aa) <> *blanks;
- ParseElemDs = arrsort(aa);
- //---------------------------------------------------------
- // This nasty little section is used to filter rcdfmts
- // that are not INCLUDED. Use file name to look up array
- // of file names that had an include. If file name is
- // found, use file record format name to lookup
- // file/included recfmt array. If NOT found, EXCLUDE.
- //---------------------------------------------------------
- IsIncluded = *on;
- FileDSname = ParseElemDS.FileName + ParseElemDS.DSname;
- 3b if %lookup(FileDSname: FilesWithInclude) > 0;
- FileFormat = ParseElemDS.FormatName +
- ParseElemDS.FileName + ParseElemDS.DSname;
- 4b if %lookup(FileFormat: IncludedFormat) = 0;
- IsIncluded = *off;
- 4e endif;
- 3e endif;
-
- 3b if IsIncluded;
- %subst(i_ReturnFiles: cc: 100) = ParseElemDs;
- cc += 100;
- 3e endif;
- 2e endif;
- 1e endfor;
- endsr;
- /end-free
-
- //--*FUNCTIONS START HERE--------------------------------------
-
- //---------------------------------------------------------
- // The idea here is extract all the formats that
- // that can be included or excluded and return
- // them in an array of record formats.
- //---------------------------------------------------------
- P f_ExtractFmts B
- D f_ExtractFmts PI 10a dim(15)
- D KeyWord like(KeyWord4) const
- D ArryOfRecFmts s 10a dim(15)
- D aa s like(KeyWord4)
- D xx s 3u 0 inz
- D Index s 3u 0 inz
- /free
- ArryOfRecFmts(*) = *blanks;
- aa = KeyWord4;
- Index = 0;
-
- // remove prefix
- xx = %scan('IGNORE(': aa);
- 1b if xx > 0;
- aa = %subst(aa: xx + 7);
- 1x else;
- xx = %scan('INCLUDE(': aa);
- 2b if xx > 0;
- aa = %subst(aa: xx + 8);
- 2e endif;
- 1e endif;
-
- // remove all ':'
- xx = 1;
- 1b dou xx = 0;
- xx = %scan(':': aa: xx);
- 2b if xx > 0;
- %subst(aa: xx: 1) = ' ';
- 2e endif;
- 1e enddo;
-
- // remove final ')'
- xx = %scan(')': aa);
- 1b if xx > 0;
- %subst(aa: xx: 1) = ' ';
- 1e endif;
-
- aa = %triml(aa);
-
- //---------------------------------------------------------
- // There are many ways an include/ignore can be coded.
|
|