midrange.com code scratchpad
Name:
JCRPRTF - Generate PRTF from o-specs
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
05/21/2008 02:37:33 pm
IP:
Logged
Description:
This is Craig Rutledge's JCRPRTF command and programs in text list. For those who cannot download XMLPREVIEW
Code:
  1. /*--------------------------------------------------------------------------*/
  2. /* This program is free software, you can redistribute it and/or modify it  */
  3. /* under the terms of the GNU General Public License as published by        */
  4. /* the Free Software Foundation. See GNU General Public License for detail. */
  5. /* Copyright (C) 2008   Craig Rutledge  <www.jcrcmds.com>                   */
  6. /*--------------------------------------------------------------------------*/
  7. /* JCRPRTF - Generate External Print File - Command Definition              */
  8. /*   Craig Rutledge                                                         */
  9. /*--------------------------------------------------------------------------*/
  10. /* Command Summary:                                                         */
  11. /* The command reads RPG4 source code and generates a PRTF source           */
  12. /* member matching the O specs from the program.                            */
  13. /*--------------------------------------------------------------------------*/
  14. /* Related Objects:                                                         */
  15. /*  JCRPRTFH   PNLGRP     Generate external print file - help text          */
  16. /*  JCRPRTFR   RPGLE      Generate PRTF DDS from RPG4 O specs               */
  17. /*  JCRRECGETR RPGLE      Record format/file xref for RPG source            */
  18. /*  JCRFLDCPYR RPGLE      Get source names from /copy for processing        */
  19. /*  JCRFLDGETR RPGLE      Get field attributes from RPG4 programs           */
  20. /*  JCRPRTFRV  RPGLE      Validity checker with allocate object             */
  21. /*  JCRPRTF    CMD        Generate external print file from RPG Ospecs      */
  22. /*--------------------------------------------------------------------------*/
  23.              CMD        PROMPT('Generate External Print File')
  24.  
  25.              PARM       KWD(RPGMBR) TYPE(*NAME) MIN(1) PROMPT('RPG4 +
  26.                           source member:')
  27.  
  28.              PARM       KWD(RPGSRCFIL) TYPE(QUAL1) PROMPT('Source +
  29.                           file:')
  30.  
  31.              PARM       KWD(PRTFMBR) TYPE(*NAME) MIN(1) PROMPT('DDS +
  32.                           member to generate:')
  33.  
  34.              PARM       KWD(PRTFSRCFIL) TYPE(QUAL2) PROMPT('Source +
  35.                           file:')
  36.  
  37.              PARM       KWD(USEREFFLD) TYPE(*CHAR) LEN(4) RSTD(*YES) +
  38.                           DFT(*NO) VALUES(*YES *NO) PROMPT('Use +
  39.                           REFFLD field references:')
  40.  
  41. /*-------------------------------------------------------------------*/
  42.  QUAL1:      QUAL       TYPE(*NAME) DFT(QRPGLESRC)
  43.              QUAL       TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) +
  44.                           PROMPT('Library')
  45.  
  46.  QUAL2:      QUAL       TYPE(*NAME) DFT(QDDSSRC) SPCVAL((QDDSSRC))
  47.              QUAL       TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) +
  48.                           PROMPT('Library')                                   
  49.  
  50.  
  51. ****JCRPRTFH****
  52. .*-------------------------------------------------------------------*
  53. .* This program is free software, you can redistribute it and/or     *
  54. .* modify it under the terms of the GNU General Public License as    *
  55. .* published by the Free Software Foundation.  See GNU General       *
  56. .* Public License for detail.                                        *
  57. .* Copyright (C) 2008   Craig Rutledge  <www.jcrcmds.com>            *
  58. .*-------------------------------------------------------------------*
  59. .* JCRPRTF - Generate External Print File - Help Text                *
  60. .*   Craig Rutledge                                                  *
  61. .*-------------------------------------------------------------------*
  62. :PNLGRP.
  63. :HELP NAME='JCRPRTF'.
  64. Generate External Print File (JCRPRTF) - Help
  65. :P.
  66. The Generate External Print File (JCRPRTF) command allows you to
  67. generate a DDS external print file source member from the selected RPG4
  68. (RPGLE or SQLRPGLE) program's O specs.
  69. :P.Please be aware of the following special circumstances:
  70. :ul compact.
  71. :li.Multiple internal spooled files will be consolidated into
  72. a single external member.
  73. :li.Array elements will be converted but will require changing as
  74. these are not allowed in PRTF.
  75. :li.If entire array name (not indexed) is used, it will be
  76. converted, but will require conversion to non-array name.
  77. :li.Control indicators L0-L9 are converted but will have to be
  78. manually changed as they are not allowed in an external print file.
  79. :li.Duplicate fields within the same record format must be
  80. manually changed after the generation.
  81. :EUL.
  82. :P.The command
  83. gets the name of the RPG source member whose O specs are to
  84. used,  the name and location where the generated DDS print file
  85. member is supposed to go, and whether or not REFFLDs should be
  86. used in the external print file.
  87. :NT.This command does not alter the original RPG code in any way.:ENT.
  88.  
  89. :P.The validity checker program verifies the member exists.
  90. The command processing program overrides to the selected member and
  91. runs the RPG program to generate an external print file.
  92. :NT.The command will create a new DDS source member if one does not
  93. exists by the name selected.  If the DDS member already exists, it
  94. will be overlayed with the generated code.:ENT.
  95. .*--------------------------------------------------------------------
  96. :LINES.
  97. The objects used by this command are:
  98. JCRPRTF     *CMD             Command Prompt
  99. JCRPRTFC    *PGM    CLP      Command processing program
  100. JCRPRTFR   *PGM    RPGLE    Generate PRTF DDS from RPG4 O specs
  101. JCRFLDGETR  *PGM    RPGLE    Get field attributes for RPG4 fields
  102. JCRRECGETR  *PGM    RPGLE    Get record format data
  103. JCRFLDCPYR  *PGM    RPGLE    Process /copy members
  104. JCRPRTFRV   *PGM    RPGLE    Validity checker
  105. JCRPRTFH    *PNLGRP          Help Text
  106. :ELINES.
  107. :P.Craig Rutledge
  108. :EHELP.
  109. .*--------------------------------------------------------------------
  110. .* HELP TEXT FOR RPGMBR PARAMETER
  111. .*--------------------------------------------------------------------
  112. :HELP name='JCRPRTF/RPGMBR'.
  113. RPG source member(RPGMBR) - Help
  114. :XH3.RPG source member(RPGMBR)
  115. :P.
  116. Specifies the name of the program whose internal O specs will be used
  117. to generate the external print file DDS source.
  118. :P.
  119. This is a required parameter.
  120. :PARML.
  121. :PT.program-name
  122. :PD.Specify the program name.
  123. :EPARML.
  124. :EHELP.
  125. .*--------------------------------------------------------------------
  126. .* HELP TEXT FOR RPGSRCFIL
  127. .*--------------------------------------------------------------------
  128. :HELP name='JCRPRTF/RPGSRCFIL'.
  129. Source file - Help
  130. :XH3.Source file (RPGSRCFIL)
  131. :P.Specifies the name of the source file that contains the source
  132. program member.
  133. .*
  134. :PARML.
  135. :PT.:PK def.QRPGSRC:EPK.
  136. :PD.The default source file, QRPGSRC, contains the RPG source program
  137. to be used.
  138. .*
  139. :PT.source-file-name
  140. :PD.Enter the source file name that contains the RPG source program to
  141. be used.
  142. .*
  143. :PT.:PK def.*LIBL:EPK.
  144. :PD.The system searches the library list to find the library where the
  145. source file is located.
  146. .*
  147. :PT.library-name
  148. :PD.Enter the name of the library where the source file is located.
  149. :EPARML.
  150. :EHELP.
  151. .*--------------------------------------------------------------------
  152. .* HELP TEXT FOR PRTFMBR PARAMETER
  153. .*--------------------------------------------------------------------
  154. :HELP name='JCRPRTF/PRTFMBR'.
  155. DDS member to generate(PRTFMBR) - Help
  156. :XH3.DDS member to generate(PRTFMBR)
  157. :P.
  158. Specifies the DDS member name of the external print file that is
  159. be generated.
  160. :P.
  161. This is a required parameter.
  162. :PARML.
  163. :PT.member-name
  164. :PD.Specify the DDS member name.
  165. :EPARML.
  166. :EHELP.
  167. .*--------------------------------------------------------------------
  168. .* HELP TEXT FOR PRTFSRCFIL
  169. .*--------------------------------------------------------------------
  170. :HELP name='JCRPRTF/PRTFSRCFIL'.
  171. Source file - Help
  172. :XH3.Source file (PRTFSRCFIL)
  173. :P.Specifies the name of the source file that contains the external
  174. print file member.
  175. .*
  176. :PARML.
  177. :PT.:PK def.QDDSSRC:EPK.
  178. :PD.The default source file, QDDSSRC, will contain the DDS source
  179. member to be generated
  180. .*
  181. :PT.source-file-name
  182. :PD.Enter the source file name that will contain the DDS source member.
  183. .*
  184. :PT.:PK def.*LIBL:EPK.
  185. :PD.The system searches the library list to find the library where the
  186. source file is located.
  187. .*
  188. :PT.library-name
  189. :PD.Enter the name of the library where the source file is located.
  190. :EPARML.
  191. :EHELP.
  192. .*--------------------------------------------------------------------
  193. .* HELP TEXT FOR USEREFFLD PARAMETER
  194. .*--------------------------------------------------------------------
  195. :HELP name='JCRPRTF/USEREFFLD'.
  196. Use REFFLD field references - Help
  197. :XH3.Use REFFLD field references (USEREFFLD)
  198. :P.Specifies whether the external print file is be generated using
  199. REFFLD or internal field descriptions.
  200. .*
  201. :PARML.
  202. :PT.:PK def.*NO:EPK.
  203. :PD.Specifies that REFFLDs are not to used in external print file.
  204. .*
  205. :PT.*YES
  206. :PD.Specifies that REFFLD definitions are to used were possible.
  207. :EPARML.
  208. :EHELP.
  209. :EPNLGRP.                                                                
  210.  
  211.  
  212.  
  213. ****JCRPRTFR****
  214.       //---------------------------------------------------------
  215.       // This program is free software, you can redistribute it and/or modify it
  216.       // under the terms of the GNU General Public License as published by
  217.       // the Free Software Foundation. See GNU General Public License for detail.
  218.       // Copyright (C) 2008   Craig Rutledge  <www.jcrcmds.com>
  219.       //---------------------------------------------------------
  220.       // JCRPRTFR - Generate External Print File
  221.       //   Craig Rutledge
  222.       // Interesting note:  RPG o specs use record level spacing/skipping.  O specs allow the
  223.       // same record name to be defined multiple times with different spacing and skipping..
  224.       // DDS allows the record format to be defined only once.  This requires conversion from
  225.       // the record level definitions in RPG to field level spacing/skipping in the DDS.  Ughh..
  226.       //
  227.       // SkipB and SpaceB will coded after the first IPP line after the IPO line..
  228.       // SkipA and SpaceA will coded after the last IPP line in an IPO group.
  229.       //---------------------------------------------------------
  230.       // Program Summary:
  231.       // call program to load field names & attributes into IMPORTed array
  232.       // load output arrays with Positional field data and field names
  233.       //
  234.       // Read RPG o specs
  235.       // Generate DDS PRTF source code
  236.       //---------------------------------------------------------
  237.      H/Define ProgramHeaderSpecs
  238.      H/COPY JCRCMDS,JCRCMDSCPY
  239.      H/UnDefine ProgramHeaderSpecs
  240.  
  241.      Fqrpgsc    if   f  112        disk    ExtFile(i_ExtFile) ExtMbr(i_RpgMbr)    input source file
  242.      F                                     usropn
  243.      Fqddssc    o  a f   92        disk    ExtFile(o_ExtFile) ExtMbr(i_DDsMbr)    write out DDS
  244.      F                                     usropn
  245.  
  246.       //--*STAND ALONE-------------------------------------------
  247.      D jj              s              5u 0 inz
  248.      D kk              s              5u 0 inz
  249.      D ps              s              5u 0 inz                                  (
  250.      D pe              s              5u 0 inz                                  )
  251.      D xd              s              5u 0 inz                                  )
  252.      D yy              s              5u 0 inz
  253.      D xx              s              5u 0 inz
  254.      D vspos           s              5i 0 inz
  255.      D Field           s             15a   inz
  256.      D pStart          s              5u 0 inz                                  (
  257.      D vswork          s              5i 0 inz
  258.      D Commas          s              1a   inz
  259.      D SrcSeq          s              6s 2 inz
  260.      D oooFMT          s                   like(O_Constant) inz
  261.      D IsWrite         s               n   inz(*off)
  262.      D FileError       s             10a   inz
  263.      D i_ExtFile       s             21a   inz
  264.      D o_ExtFile       s             21a   inz
  265.      D LenActual       s              5u 0 inz
  266.      D WriteLine       s              1a   inz
  267.      D DecimalPos      s              1s 0 inz
  268.      D LookupName      s             15a   inz
  269.      D LinePosSav      s                   like(PrtfDDs.LinePosition) inz
  270.      D HaveFields      s             27a   inz                                  before control
  271.      D JustDidFmt      s             27a   inz
  272.      D CommaResult     s              5u 0 inz
  273.      D FloatDollar     s              3a   inz('''$''')
  274.      D TotalLineCnt    s              5u 0 inz
  275.      D NewEndingPos    s              5u 0 inz
  276.      D EditCodeArry    s              1a   dim(16) ctdata perrcd(1)
  277.      D EditDataArry    s              2a   dim(16) alt(EditCodeArry)
  278.      D NegativeType    s              1a   inz
  279.      D RpgSourceLib    s             10a   inz
  280.      D DDsSourceLib    s             10a   inz
  281.      D KeywordSkipa    s                   like(PrtfDDs.Keyword) inz            skip after save
  282.      D KeywordSkipb    s                   like(PrtfDDs.Keyword) inz            skip before sav
  283.      D DetailLineCnt   s              5u 0 inz
  284.      D ExceptLineCnt   s              5u 0 inz
  285.      D HeaderLineCnt   s              5u 0 inz
  286.      D RpgSourceFile   s             10a   inz
  287.      D DDsSourceFile   s             10a   inz
  288.      D KeywordSpacea   s                   like(PrtfDDs.Keyword) inz            space after save
  289.      D KeywordSpaceb   s                   like(PrtfDDs.Keyword) inz            space before save
  290.      D CommaRemainder  s              5u 0 inz
  291.      D LastExceptName  s             15a   inz
  292.  
  293.       //--*COPY DEFINES------------------------------------------
  294.      D/Define constants
  295.      D/Define ApiErrorDS
  296.      D/Define FieldAttrbDS
  297.      D/Define ArryOfFields
  298.      D/Define f_GetQual
  299.      D/Define f_SndEscapeMsg
  300.      D/Define f_SndCompMsg
  301.      D/Define f_BuildString
  302.      D/Define f_FakeEditWord
  303.      D/Define p_JCRPRTFR
  304.      D/Define p_JCRFLDCPYR
  305.      D/COPY JCRCMDS,JCRCMDSCPY
  306.  
  307.       //--*DATA STRUCTURES---------------------------------------
  308.      D DimSizeA        ds
  309.      D DimSize                        5s 0 inz                                  numeric dim size
  310.  
  311.      D PlusSignPos     ds
  312.      D PlusSignPosN                   5s 0 inz
  313.      D
  314.       // Define fields from the different spec types.
  315.      D                 ds                  inz
  316.      D  SrcDta                 1     80a
  317.       // OUTPUT SPECS
  318.      D  Comment                7      7a
  319.      D  Commentln              8     80a
  320.      D  andor                 16     18a
  321.      D  LineType              17     17a
  322.      D  ind                   21     29a
  323.      D  spaceb                42     42a
  324.      D  spacea                45     45a
  325.      D  skipb                 47     48a
  326.      D  skipa                 50     51a
  327.      D  o_ename               30     43a
  328.      D  EditCode              44     44a
  329.      D  EndPos                47     51a
  330.      D  EndPosN               47     51s 0
  331.      D  uppercase              1     51a
  332.      D  O_Constant            53     80a
  333.       //                DDS SPECS
  334.      D PrtfDDs         ds                  qualified inz
  335.      D  SourceType             6      6a
  336.      D  AndOr                  7      7a
  337.      D  CommentLine            8     80a
  338.      D  Indicator              8     16a
  339.      D  FormatR               17     17a
  340.      D  FormatName            19     28a
  341.      D  Referenced            29     29a
  342.      D  Length                31     34a
  343.      D  DataType              35     35a
  344.      D  DecimalPos            37     37a
  345.      D  LinePosition          42     44a
  346.      D  Keyword               45     80a
  347.  
  348.       //--*ENTRY PARMS-------------------------------------------
  349.      D p_JCRPRTFR      PI
  350.      D  i_RpgMbr                     10a
  351.      D  i_RpgFileQual                20a
  352.      D  i_DDsMbr                     10a
  353.      D  i_DDsFileQual                20a
  354.      D  i_RefFields                   4a
  355.  
  356.       //--*INPUT SPECS-------------------------------------------
  357.      Iqrpgsc    ns  lr   13 c*   14 c*   15 c
  358.      I         or        13 c*   14 c*   15 cc                                  named array
  359.      I         or        13 c*   14 c*   15 cC                                  named array
  360.      I          ns  01   18 cO   19nc/
  361.      I         or        18 co   19nc/
  362.      I                                 13   92  SrcDta
  363.      I          ns  03
  364.      I                                 13   14  Src
  365.      I                                 18   18  SpecType
  366.       //---------------------------------------------------------
  367.       /free
  368.  
  369.        exsr srInputParms;
  370.        exsr srGetProgramFieldAttributes;
  371.        exsr srReadSource;
  372.  
  373.        f_SndCompMsg('Generation of PRTF for ' +
  374.        %trimr(i_DDsMbr) + ' in ' +
  375.        %trimr(o_ExtFile) + ' - completed.');
  376.  
  377.        *inlr = *on;
  378.        return;
  379.  
  380.        //---------------------------------------------------------
  381.        begsr srInputParms;
  382.        RpgSourceFile = %subst(i_RpgFileQual: 1: 10);
  383.        RpgSourceLib = %subst(i_RpgFileQual: 11: 10);
  384.        DDsSourceFile = %subst(i_DDsFileQual: 1: 10);
  385.        DDsSourceLib = %subst(i_DDsFileQual: 11: 10);
  386.        i_ExtFile = f_GetQual(i_RpgFileQual);
  387.        o_ExtFile = f_GetQual(i_DDsFileQual);
  388.        endsr;
  389.  
  390.        //---------------------------------------------------------
  391.        begsr srGetProgramFieldAttributes;
  392.        // process copy books and selected source
  393.        // load field names and attributes to IMPORT array
  394.        callp p_JCRFLDCPYR(
  395.              i_ExtFile:
  396.              i_RpgMbr:
  397.              'JCRPRTF   ':
  398.              FileError);
  399.  
  400.        // if file-not-found error, send message
  401.  1b    if FileError <> *blanks;
  402.           f_SndEscapeMsg(
  403.           f_BuildString('*ERROR*  External file & +
  404.           not found in *Libl.': %trimr(FileError)));
  405.  1e    endif;
  406.        endsr;
  407.  
  408.        //---------------------------------------------------------
  409.        begsr srReadSource;
  410.        // open input file and output
  411.        open qrpgsc;
  412.        open qddssc;
  413.  
  414.        read qrpgsc;
  415.  1b    dow not %eof;
  416.  2b       if *inlr               //into arrays
  417.              or Src = '**'            //compile time array
  418.              or SpecType = 'P'      //procedure
  419.              or SpecType = 'p';
  420.  1v          leave;
  421.  2e       endif;
  422.  
  423.  2b       if *in01;  //NOT EJECT
  424.  
  425.              //---------------------------------------------------------
  426.              // If comment lines, then translate over as is...
  427.              //---------------------------------------------------------
  428.  3b          if Comment = '*';  //COMMENT LINE
  429.                 PrtfDDs.AndOr = Comment;  //LOAD DS
  430.                 PrtfDDs.CommentLine = Commentln;  //LOAD DS
  431.                 exsr srWriteSourceCode;
  432.  3x          else;
  433.  
  434.                 //---------------------------------------------------------
  435.                 uppercase = %xlate(lo: up: uppercase);
  436.  
  437.  4b             if LineType <> *blanks  and //IPO LINES D,E,H
  438.                    andor <> 'OR '  and     //IPO LINES D,E,H
  439.                    andor <> 'AND';  //IPO LINES D,E,H
  440.                    exsr srFormatLine;
  441.  4x             else;  //FIELD/LITERAL
  442.                    exsr srFieldLine;
  443.  4e             endif;
  444.  3e          endif;
  445.  2e       endif;
  446.  
  447.           *in01 = *off;
  448.           *in03 = *off;
  449.           read qrpgsc;
  450.  1e    enddo;
  451.  
  452.        // all processed.
  453.        exsr srSpaceAfter;
  454.        close qrpgsc;
  455.        close qddssc;
  456.        endsr;
  457.  
  458.        //---------------------------------------------------------
  459.        // Generate record format code for either except lines
  460.        // or when a new line is coded in the original RPG.
  461.        //---------------------------------------------------------
  462.        begsr srFormatLine;
  463.        IsWrite = *on;
  464.  
  465.        //---------------------------------------------------------
  466.        // If the previous record format had no printable fields
  467.        // or constants defined,  then generate the space/skip
  468.        // BEFORE code at record format level.
  469.        //---------------------------------------------------------
  470.  1b    if HaveFields = 'Record Format had no fields';
  471.           exsr srSpaceBefore;
  472.  1e    endif;
  473.  
  474.        exsr srSpaceAfter;
  475.  
  476.  1b    if LineType = 'E';  //EXCPT
  477.  2b       if o_ename <> *blanks
  478.              and o_ename = LastExceptName;  //SAME NAMED LINE
  479.              IsWrite = *off;
  480.  2x       else;
  481.  
  482.  3b          if o_ename = *blanks;
  483.                 ExceptLineCnt += 1;
  484.                 o_ename = %trimr('EXP') +
  485.                 %triml(%editc(ExceptLineCnt:'3'));
  486.  3e          endif;
  487.  
  488.              PrtfDDs.FormatName = o_ename;
  489.              LastExceptName = o_ename;
  490.  2e       endif;
  491.  
  492.  1x    elseif LineType = 'H';  //HEADER LINE
  493.           HeaderLineCnt += 1;  //HEADER LINE CNT
  494.           PrtfDDs.FormatName = %trimr('HDR') +
  495.           %triml(%editc(HeaderLineCnt:'3'));
  496.           clear LastExceptName;
  497.  
  498.  1x    elseif LineType = 'D';  //DETAIL
  499.           DetailLineCnt += 1;
  500.           PrtfDDs.FormatName = %trimr('DTL') +
  501.           %triml(%editc(DetailLineCnt:'3'));
  502.           clear LastExceptName;
  503.  
  504.  1x    elseif LineType = 'T';  //TOTAL
  505.           TotalLineCnt += 1;
  506.           PrtfDDs.FormatName = %trimr('TOT') +
  507.           %triml(%editc(TotalLineCnt:'3'));
  508.           clear LastExceptName;
  509.  1e    endif;
  510.  
  511.  1b    if IsWrite;
  512.           PrtfDDs.FormatR = 'R';
  513.           exsr srWriteSourceCode;
  514.  1e    endif;
  515.  
  516.        //---------------------------------------------------------
  517.        // Space or Skip before must after the first field
  518.        // (or constant) defined after the record format record.
  519.        // They are saved for after the first field in the recfmt.
  520.        //---------------------------------------------------------
  521.  1b    if spaceb > ' ';  //SPACE BEFORE
  522.           KeywordSpaceb = %trimr('SPACEB(') + spaceb+')';
  523.  1e    endif;
  524.  
  525.  1b    if skipb > ' ';  //SKIP BEFORE
  526.           KeywordSkipb = %trimr('SKIPB(') + skipb + ')';
  527.  1e    endif;
  528.  
  529.        //---------------------------------------------------------
  530.        // Space or Skip after must go at the end of each group.
  531.        // Checked at the beginning of each record format.
  532.        //---------------------------------------------------------
  533.  1b    if spacea > ' ';  //SPACE AFTER
  534.           KeywordSpacea = %trimr('SPACEA(') + spacea+')';
  535.  1e    endif;
  536.  
  537.  1b    if skipa > ' ';  //SKIP AFTER
  538.           KeywordSkipa = %trimr('SKIPA(') + skipa+')';
  539.  1e    endif;
  540.  
  541.        clear vspos;  //reset EndPos
  542.        HaveFields = 'Record Format had no fields';
  543.        JustDidFmt = 'Just did the record format ';
  544.        endsr;
  545.  
  546.        //---------------------------------------------------------
  547.        // Generate Skip or Space before DDs code.
  548.        //---------------------------------------------------------
  549.        begsr srSpaceBefore;
  550.  1b    if KeywordSpaceb <> *blanks;  //SPACE BEFORE
  551.           PrtfDDs.Keyword = KeywordSpaceb;
  552.           exsr srWriteSourceCode;
  553.  1e    endif;
  554.  
  555.  1b    if KeywordSkipb <> *blanks;  //SKIP BEFORE
  556.           PrtfDDs.Keyword = KeywordSkipb;
  557.           exsr srWriteSourceCode;
  558.  1e    endif;
  559.  
  560.        clear KeywordSpaceb;
  561.        clear KeywordSkipb;
  562.        endsr;
  563.  
  564.        //---------------------------------------------------------
  565.        // Generate Skip or Space after DDs code.
  566.        //---------------------------------------------------------
  567.        begsr srSpaceAfter;
  568.  1b    if KeywordSpacea <> *blanks;  //SPACE AFTER
  569.           PrtfDDs.Keyword = KeywordSpacea;
  570.           exsr srWriteSourceCode;
  571.  1e    endif;
  572.  
  573.  1b    if KeywordSkipa <> *blanks;  //SKIP AFTER
  574.           PrtfDDs.Keyword = KeywordSkipa;
  575.           exsr srWriteSourceCode;
  576.  1e    endif;
  577.  
  578.        clear KeywordSpacea;
  579.        clear KeywordSkipa;
  580.        endsr;
  581.  
  582.        //---------------------------------------------------------
  583.        // Determine whether a field name or constant is to be loaded.
  584.        //---------------------------------------------------------
  585.        begsr srFieldLine;  //IPP SPECS
  586.        clear LenActual;
  587.        HaveFields = 'Record Format has fields   ';
  588.  
  589.  1b    if o_ename <> *blanks;  //FIELD NAMES
  590.           WriteLine = 'N';  //SET TO NO
  591.  
  592.           Field = o_ename;
  593.  
  594.           //---------------------------------------------------------
  595.           // There could be an indexed array name as an output field.
  596.           // Do a lookup with the array name to get the attributes.
  597.           //---------------------------------------------------------
  598.           LookupName = o_ename;
  599.           aa = %scan('(': LookupName: 1);
  600.  2b       if aa <> 0;
  601.              LookupName = %subst(LookupName: 1: aa - 1);
  602.  2e       endif;
  603.           aa = %lookup(LookupName: ArryFieldNames: 1:
  604.           ArryOfFields_NumberOfEntries);
  605.  2b       if aa > 0;
  606.              FieldAttrbDS = ArryFieldAttrb(aa);
  607.  3b          if FieldAttrbDS.DecimalPos = *blanks;
  608.                 DecimalPos = 0;
  609.  3x          else;
  610.                 DecimalPos = FieldAttrbDS.DecimalPosN;
  611.  3e          endif;
  612.              PrtfDDs.FormatName = o_ename;
  613.  
  614.              //---------------------------------------------------------
  615.              // Back to the array fun!  It could be that an
  616.              // that an un-indexed array name was coded on output.
  617.              // The JCRFLDCPYR program brings in the array definitions
  618.              // in two parts.  Multiply element length by num elements.
  619.              //---------------------------------------------------------
  620.              ps = %scan('DIM(': FieldAttrbDS.Text: 1);
  621.  3b          if ps <> 0                    //start of DIM(
  622.                 and LookupName = o_ename;  //not indexed
  623.                 pe = %scan(')': FieldAttrbDS.Text: ps);
  624.  4b             if pe <> 0;  //end of )
  625.  
  626.                    xd = (pe - 1) - 4;
  627.                    pStart = 6 - xd;
  628.                    DimSizeA = *blanks;
  629.                    %subst(dimsizea: pStart: xd) =
  630.                    %subst(FieldAttrbDS.Text: 5: xd);
  631.  5b                if DimSizeA = *blanks;
  632.                       DimSize = 0;
  633.  5e                endif;
  634.                    FieldAttrbDS.Length = FieldAttrbDS.Length * dimsize;
  635.  4e             endif;
  636.  3e          endif;
  637.              //---------------------------------------------------------
  638.              //                   if       ename = 'PAGE '                                PAGE CONV
  639.              //                        PrtfDDs.FormatName = orgfld
  640.              //                   endif
  641.              PrtfDDs.Indicator = ind;
  642.  
  643.              //---------------------------------------------------------
  644.              // If field was defined via an external file definition and
  645.              // the user specified that field references should be used,
  646.              // use the REFFLD keyword, otherwise hardcode the actual field
  647.              // characteristics.
  648.              //---------------------------------------------------------
  649.  3b          if FieldAttrbDS.FromFile <> '        ' and  //INTERNALLY DESC
  650.                 i_RefFields = '*YES';  //USE REFERENCES
  651.                 PrtfDDs.Referenced = 'R';
  652.  
  653.                 PrtfDDs.Keyword = 'REFFLD(' + %trimr(PrtfDDs.FormatName) +
  654.                 ' *LIBL/' + %trimr(FieldAttrbDS.FromFile) + ')';
  655.  3x          else;
  656.  
  657.                 //---------------------------------------------------------
  658.                 // Hard code fields that are not referenced.
  659.                 //---------------------------------------------------------
  660.  4b             if FieldAttrbDS.DataType = 'A';
  661.                    evalr  PrtfDDs.Length = %editc(FieldAttrbDS.Length:'4');
  662.                    clear PrtfDDs.DataType;
  663.                    clear PrtfDDs.DecimalPos;
  664.  
  665.  4x             elseif FieldAttrbDS.DataType = 'D'
  666.                    or FieldAttrbDS.DataType = 'T'
  667.                    or FieldAttrbDS.DataType = 'Z';
  668.                    clear PrtfDDs.Length;
  669.  5b                if FieldAttrbDS.DataType = 'D';
  670.                       PrtfDDs.DataType = 'L';
  671.  5x                else;
  672.                       PrtfDDs.DataType = FieldAttrbDS.DataType;
  673.  5e                endif;
  674.                    clear PrtfDDs.DecimalPos;
  675.  
  676.  4x             else;
  677.                    evalr  PrtfDDs.Length = %editc(FieldAttrbDS.Length:'4');
  678.                    clear PrtfDDs.DataType;
  679.                    PrtfDDs.DecimalPos = %editc(DecimalPos:'3');
  680.  4e             endif;
  681.                 WriteLine = 'Y';
  682.  3e          endif;
  683.  
  684.  2e       endif;
  685.  
  686.           //---------------------------------------------------------
  687.           // Calculate starting Position of either field or constant.
  688.           //---------------------------------------------------------
  689.           LenActual = FieldAttrbDS.Length;
  690.  
  691.  2b       if EditCode > ' ';
  692.              exsr srAllowForEditCode;
  693.  
  694.  2x       elseif O_Constant <> *blanks;  //GET CONST LENGT
  695.  
  696.  3b          if FieldAttrbDS.DataType = 'D'
  697.                 or FieldAttrbDS.DataType = 'T'
  698.                 or FieldAttrbDS.DataType = 'Z';
  699.                 exsr srMakeLikeAnEditWord;
  700.  3e          endif;
  701.  
  702.              kk = %checkr(' ': O_Constant);
  703.              LenActual = kk - 2;  //CALC LENGTH
  704.  2e       endif;
  705.           //---------------------------------------------------------
  706.           // If ending Position is blank,  load +0 and let
  707.           // the calc ending subroutine handle it .  if there
  708.           //  is a + sign in the end Position,  then calc ending pos.
  709.           //---------------------------------------------------------
  710.  2b       if EndPos = *blanks;
  711.              EndPos = '   +0';
  712.  2e       endif;
  713.           bb = %scan('+': Endpos: 1);
  714.  2b       if bb <> 0;
  715.              exsr srCalcEndingPos;  //found one
  716.  2e       endif;
  717.           //---------------------------------------------------------
  718.           vspos = EndPosN;
  719.           vswork = vspos;
  720.           vswork = vswork - LenActual;
  721.           vswork += 1;
  722.           evalr  PrtfDDs.LinePosition = %editc(vswork:'4');
  723.  
  724.           //---------------------------------------------------------
  725.           // Handle exception of UDATE.  The entire line is cleared and
  726.           // the starting Position and the new DATE keyword are written.
  727.           //---------------------------------------------------------
  728.  2b       if PrtfDDs.FormatName = 'UDATE ';  //RESERVED WORD
  729.              LinePosSav = PrtfDDs.LinePosition;
  730.              WriteLine = 'N';
  731.  
  732.              clear PrtfDDs;  //CLEAR OUTPUT
  733.              PrtfDDs.LinePosition = LinePosSav;  //RELOAD
  734.              PrtfDDs.Keyword = 'DATE';  //LOAD KEYWORD
  735.  2e       endif;
  736.  
  737.  2b       if WriteLine <> 'Y';
  738.              exsr srWriteSourceCode;
  739.  2e       endif;
  740.  
  741.           //---------------------------------------------------------
  742.           // If floating dollar sign,  include in EDTCDE keyword)
  743.           //---------------------------------------------------------
  744.  2b       if EditCode > ' ';
  745.              PrtfDDs.Keyword = 'EDTCDE(' + EditCode + ')';
  746.  3b          if O_Constant = FloatDollar;
  747.                 PrtfDDs.Keyword = 'EDTCDE(' + EditCode + ' $)';
  748.  3e          endif;
  749.              exsr srWriteSourceCode;
  750.              clear WriteLine;
  751.  
  752.  2x       elseif O_Constant <> *blanks;  //EDTWRD SPECIFID
  753.  3b          if FieldAttrbDS.DataType = 'D'
  754.                 or FieldAttrbDS.DataType = 'T'
  755.                 or FieldAttrbDS.DataType = 'Z';
  756.                 PrtfDDs.Keyword = oooFMT;
  757.  3x          else;
  758.                 PrtfDDs.Keyword = 'EDTWRD(' + %trimr(O_Constant) +')';
  759.  3e          endif;
  760.              exsr srWriteSourceCode;
  761.              clear WriteLine;
  762.  2e       endif;
  763.  
  764.  2b       if WriteLine = 'Y';
  765.              exsr srWriteSourceCode;
  766.  2e       endif;
  767.  
  768.  1x    elseif O_Constant <> *blanks;  //CONSTANTS
  769.           jj = %checkr(' ': O_Constant);
  770.           PrtfDDs.Indicator = ind;
  771.           //---------------------------------------------------------
  772.  2b       if EndPos = *blanks;
  773.              EndPos = '   +0';
  774.  2e       endif;
  775.           bb = %scan('+': Endpos: 1);
  776.  2b       if bb <> 0;
  777.              exsr srCalcEndingPos;  //found one
  778.  2e       endif;
  779.           //---------------------------------------------------------
  780.           vspos = EndPosN;
  781.           vswork = vspos;  //CALC
  782.           vswork -= jj;  //STARTING
  783.           vswork += 3;  //Position.
  784.           evalr  PrtfDDs.LinePosition = %editc(vswork:'4');  //LOAD FLD LENGTH
  785.           PrtfDDs.Keyword = O_Constant;  //LOAD CONSTANT
  786.           exsr srWriteSourceCode;
  787.  1e    endif;
  788.  
  789.        //---------------------------------------------------------
  790.  1b    if JustDidFmt = 'Just did the record format ';
  791.           exsr srSpaceBefore;
  792.           JustDidFmt = 'Not   ';
  793.  1e    endif;
  794.        endsr;
  795.  
  796.        //---------------------------------------------------------
  797.        // New to O specs is the ability to format date, time and
  798.        // and timestamp fields.  I have decided the best way to
  799.        // handle it would be to
  800.        // create a fake edit word based on type field and
  801.        // and type formating selected.
  802.        //---------------------------------------------------------
  803.        begsr srMakeLikeAnEditWord;
  804.        clear oooFMT;
  805.  1b    if FieldAttrbDS.DataType = 'Z';
  806.  1x    else;
  807.           O_Constant = %xlate(lo: up: O_Constant);
  808.  
  809.  2b       if FieldAttrbDS.DataType = 'T';
  810.              oooFMT = 'TIMFMT(' + %trimr(O_Constant) + ')';
  811.  
  812.  2x       elseif FieldAttrbDS.DataType = 'D';
  813.              oooFMT = 'DATFMT(' + %trimr(O_Constant) + ')';
  814.  
  815.  2e       endif;
  816.  1e    endif;
  817.        O_Constant = f_FakeEditWord(O_Constant: FieldAttrbDS.DataType);
  818.        endsr;
  819.  
  820.        //---------------------------------------------------------
  821.        // Allow for the effects of edit codes on overall field length.
  822.        //---------------------------------------------------------
  823.        begsr srAllowForEditCode;
  824.  1b    if EditCode = 'Y';
  825.  
  826.  2b       if FieldAttrbDS.Length = 3
  827.              or FieldAttrbDS.Length = 4;
  828.              LenActual += 1;
  829.  2x       elseif FieldAttrbDS.Length >= 5
  830.              and FieldAttrbDS.Length <= 9;
  831.              LenActual += 2;
  832.  2e       endif;
  833.  
  834.  1x    else;
  835.           jj = %lookup(EditCode: EditCodeArry: 1);
  836.  2b       if jj > 0;
  837.              Commas = %subst(EditDataArry(jj): 1: 1);  //USE COMMAS?
  838.              NegativeType = %subst(EditDataArry(jj): 2: 1);  //WHAT TYPE NEG
  839.  
  840.  3b          if O_Constant = FloatDollar;  //FLOATING $
  841.                 LenActual += 1;
  842.  3e          endif;
  843.  
  844.  3b          if DecimalPos > 0;  //ADJUST FOR DEC
  845.                 LenActual += 1;
  846.  3e          endif;
  847.  
  848.  3b          if NegativeType = '-';  //MINUS SIGN
  849.                 LenActual += 1;
  850.  3x          elseif NegativeType = 'C';  //CR SIGN
  851.                 LenActual += 2;
  852.  3e          endif;
  853.  
  854.  3b          if Commas = 'Y';  //ALLOW FOR COMMA
  855.                 CommaResult = FieldAttrbDS.Length - DecimalPos;
  856.                 CommaResult = %div(CommaResult: 3);  //HOW MANY COMMAS
  857.                 CommaRemainder = %rem(CommaResult: 3);  //HOW MANY COMMAS
  858.  
  859.  4b             if CommaRemainder = 0 and CommaResult > 0;  //EVENLY DIVIDED
  860.                    CommaResult -= 1;
  861.  4e             endif;
  862.  
  863.                 LenActual += CommaResult;
  864.  3e          endif;
  865.  2e       endif;
  866.  1e    endif;
  867.        endsr;
  868.  
  869.        //---------------------------------------------------------
  870.        // Write records to the DDs member.
  871.        //---------------------------------------------------------
  872.        begsr srWriteSourceCode;
  873.        PrtfDDs.SourceType = 'A';
  874.        SrcSeq += .01;
  875.        except DDsout;  //WRITE DDs
  876.        clear PrtfDDs;
  877.        endsr;
  878.  
  879.        //---------------------------------------------------------
  880.        // CALCULATE ENDING Position
  881.        //---------------------------------------------------------
  882.        begsr srCalcEndingPos;
  883.        yy = 2;
  884.        xx = 0;
  885.  
  886.  1b    if o_ename <> ' '
  887.           and %subst(O_Constant: 1: 1) <> ' '
  888.           and O_Constant <> FloatDollar;
  889.  2b       dow %subst(O_Constant: yy: 1) <> '''';
  890.              xx += 1;
  891.              yy += 1;
  892.  2e       enddo;
  893.  
  894.  1x    elseif o_ename = ' '
  895.           and %subst(O_Constant: 1: 1) <> ' ';
  896.  2b       dow yy < 29
  897.              and %subst(O_Constant: yy: 1) <> '''';
  898.              xx += 1;
  899.              yy += 1;
  900.  2e       enddo;
  901.  1e    endif;
  902.  
  903.        // Positions between fields
  904.        clear PlusSignPos;
  905.        %subst(PlusSignPos: bb + 1) = %subst(EndPos: bb + 1);
  906.  
  907.        // new ending Position
  908.        NewEndingPos = vspos + PlusSignPosn+ xx;
  909.  
  910.  1b    if xx = 0;  //no edit word
  911.           NewEndingPos += LenActual;
  912.  1e    endif;
  913.  
  914.        EndPosN = NewEndingPos;
  915.        endsr;
  916.       /end-free
  917.      Oqddssc    eadd         DDsout
  918.      O                       SrcSeq               6
  919.      O                       PrtfDDs             92
  920.       //
  921.       *EDIT CODE  COMMAS (Y/N)  TYPE SIGN(None,Cr,or -)
  922. **
  923. 1YN             1
  924. 2YN             2
  925. 3NN             3
  926. 4NN             4
  927. AYC             5
  928. BYC             6
  929. CNC             7
  930. DNC             8
  931. JY-             9
  932. KY-            10
  933. LN-            11
  934. MN-            12
  935. NY-            13
  936. OY-            14
  937. PN-            15
  938. QN-            16 
  939.  
  940.  
  941.  
  942.  
  943. ****JCRRECGETR****
  944.       //---------------------------------------------------------
  945.       // This program is free software, you can redistribute it and/or modify it
  946.       // under the terms of the GNU General Public License as published by
  947.       // the Free Software Foundation. See GNU General Public License for detail.
  948.       // Copyright (C) 2008   Craig Rutledge  <www.jcrcmds.com>
  949.       //---------------------------------------------------------
  950.       // JCRRECGETR - Get file info for files used in RPG source
  951.       //   Craig Rutledge
  952.       //---------------------------------------------------------
  953.       // Program Summary:
  954.       // read Rpg F specs
  955.       // optionally read D specs for external DS names
  956.       // call apis to extract record format names.
  957.       // call api to extract based on physical file name
  958.  
  959.       // INCLUDE logic is difficult to follow.
  960.       // an Include is really an explicit IGNORE.
  961.       // 1. need to know if a file has an INCLUDE statement.
  962.       // 2. need to know what record formats to include.
  963.       // 3. need to figure out what formats to IGNORE.
  964.       //
  965.       // Will have to wait till aLL formats are loaded into previous
  966.       // array then then spin back through and remove the ones for
  967.       // files that have an include and are not included.
  968.       // Ughh..
  969.       // Build an array of all INCLUDE file/record formats
  970.       //
  971.       // 1.  an array of just file names to select files with includes
  972.       // 2.  an array of file||recordformat names for look up to see they are in the include array.
  973.       //---------------------------------------------------------
  974.       // api (application program interfaces) used:
  975.       // qdbrtvfd       Retrieve File Desc
  976.       // quslrcd        List Record Formats
  977.       // tstbts         MI Test Bits
  978.       //---------------------------------------------------------
  979.      H/Define ProgramHeaderSpecs
  980.      H/COPY JCRCMDS,JCRCMDSCPY
  981.      H/UnDefine ProgramHeaderSpecs
  982.  
  983.      Fqrpgsc    if   f  112        disk    ExtFile(i_ExtFile) ExtMbr(i_ExtMbr)
  984.      F                                     usropn
  985.  
  986.       //--*STAND ALONE-------------------------------------------
  987.      D cc              s                   like(aa) inz
  988.      D ff              s              5u 0 inz                                  include indexes
  989.      D vl              s                   like(aa) inz
  990.      D vi              s                   like(aa) inz
  991.      D fff             s              5u 0 inz                                  include indexes
  992.      D Index           s              3u 0 inz
  993.      D arrsort         s            100a   dim(300) ascend inz                  Sorted Names & Data
  994.      D FileText        s             50a   inz
  995.      D SavPrefix       s             10a   inz
  996.      D BasedOnPF       s             10a   inz
  997.      D BitOffset       s             10u 0 inz(2)
  998.      D FldPrefix       s             10a   inz
  999.      D SavPrefix_      s              1s 0 inz
  1000.      D SaveDSname      s             15a   inz
  1001.      D RecordType      s              1a   inz
  1002.      D FileFormat      s             35a   inz
  1003.      D FileDSname      s             25a   inz
  1004.      D ForCounter      s                   like(aa) inz
  1005.      D IsIncluded      s               n   inz(*off)
  1006.      D RenamedFmt      s             10a   inz
  1007.      D FilNamSave      s             10a   inz
  1008.      D SavKeyWord4     s                   like(KeyWord4) inz
  1009.      D IsContinued     s               n   inz(*off)
  1010.      D ForCounter1     s                   like(aa) inz
  1011.      D BeingRenamed    s             10a   inz
  1012.      D Beingignored    s             10a   inz
  1013.      D IsFirstRecFmt   s               n   inz(*off)
  1014.      D Beingincluded   s             10a   inz
  1015.      D UserSpaceName   s             20a   inz('JCRCMDS   QTEMP     ')
  1016.      D ReturnFileQual  s             20a   inz
  1017.      D IncludedFormat  s             35a   dim(300) inz
  1018.      D WorkFileAndLib  s             20a   inz
  1019.      D FilesWithInclude...
  1020.      D                 s             25a   dim(300) inz
  1021.  
  1022.       //--*COPY DEFINES------------------------------------------
  1023.      D/Define tstbts
  1024.      D/Define quslrcd
  1025.      D/Define qdbrtvfd
  1026.      D/Define constants
  1027.      D/Define ApiErrorDS
  1028.      D/Define fild0100DS
  1029.      D/Define ParseElemDS
  1030.      D/Define ListHeaderDS
  1031.      D/Define UserSpaceHeaderDS
  1032.      D/Define f_Quscrtus
  1033.      D/Define p_JCRRECGETR
  1034.      D/COPY JCRCMDS,JCRCMDSCPY
  1035.  
  1036.       //--*DATA STRUCTURES---------------------------------------
  1037.       // define element of array to process record formats
  1038.      D replacea        ds
  1039.      D replacec                       1s 0 inz                                  replace prefix
  1040.  
  1041.       //---------------------------------------------------------
  1042.       // Record formats to include or ignore
  1043.       // returned by f_GetRecFmts.
  1044.       //---------------------------------------------------------
  1045.      D ArryOfRecFmts   s             10a   dim(15) inz
  1046.  
  1047.       //--*FUNCTION PROTOTYPES-----------------------------------
  1048.      D f_ExtractFmts   PR            10a   dim(15)
  1049.      Da                                    like(KeyWord4) const
  1050.  
  1051.       //--*ENTRY PARMS-------------------------------------------
  1052.      D p_JCRRECGETR    PI
  1053.      D  i_ExtFile                    21a
  1054.      D  i_ExtMbr                     10a
  1055.      D  i_CmdSwitch                  10a   const
  1056.      D  i_Mbrtyp                      4a   const
  1057.      D  i_ReturnFiles             30000a
  1058.  
  1059.       //--*INPUT SPECS-------------------------------------------
  1060.      Iqrpgsc    ns
  1061.      I                             a   13   14  ArrayLineType
  1062.      I                             a   18   18  LineType
  1063.      I                             a   19   19  Asterisk
  1064.       // rpg 4 locations
  1065.      I                             a   19   28  FileName
  1066.      I                             a   19   33  defFieldName
  1067.      I                             a   29   29  Usage                           I U O
  1068.      I                             a   34   34  EorF                            E or F
  1069.      I                             a   36   37  Defds                           Data structure defn
  1070.      I                             a   48   55  Device                          DISK, PRINTER, etc
  1071.      I                             a   56   92  KeyWord4                        Rename(a:b)
  1072.       // rpg 3 locations
  1073.      I                             a   19   26  FileName3
  1074.      I                             a   27   27  Usage3                          I U O
  1075.      I                             a   31   31  eorf3                           E or F
  1076.      I                             a   52   58  Device3                         DISK, PRINTER, etc
  1077.      I                             a   31   40  BeingRenamed3                   KRENAME
  1078.      I                             a   65   71  KeyWord3                        KRENAME
  1079.      I                             a   72   81  Renamed3                        KRENAME
  1080.  
  1081.       /free
  1082.        //---------------------------------------------------------
  1083.        // create user space for the api.
  1084.        //---------------------------------------------------------
  1085.        clear i_ReturnFiles;
  1086.        GenericHeaderPtr = f_Quscrtus(UserSpaceName);
  1087.  
  1088.        //---------------------------------------------------------
  1089.        open qrpgsc;
  1090.        read qrpgsc;
  1091.  1b    dow not %eof;
  1092.  
  1093.           //  finished with F and D specs
  1094.  2b       if ArrayLineType = '**'
  1095.              or LineType = 'C'
  1096.              or LineType = 'c'
  1097.              or LineType = 'O'
  1098.              or LineType = 'o'
  1099.              or LineType = 'P'
  1100.              or LineType = 'p';
  1101.  1v          leave;
  1102.  2e       endif;
  1103.  
  1104.  2b       if not (Asterisk = '*'
  1105.              or Asterisk = '/');
  1106.              ParseElemDS.SortSequence = '1';
  1107.  
  1108.  3b          if LineType = 'F'
  1109.                 or LineType = 'f';
  1110.                 exsr srFileSpec;
  1111.  
  1112.  3x          elseif LineType = 'D'
  1113.                 or LineType = 'd';
  1114.  4b             if i_CmdSwitch = 'JCRRFIL  ';
  1115.  1v                leave;
  1116.  4x             else;
  1117.                    exsr srDefinitionSpec;
  1118.  4e             endif;
  1119.  3e          endif;
  1120.  2e       endif;
  1121.  
  1122.           read qrpgsc;
  1123.  1e    enddo;
  1124.  
  1125.        exsr srLoadReturnParm;
  1126.        close qrpgsc;
  1127.        *inlr = *on;
  1128.        return;
  1129.  
  1130.        //---------------------------------------------------------
  1131.        // load the fields from the f spec externally described fields.
  1132.        //---------------------------------------------------------
  1133.        begsr srFileSpec;
  1134.        clear RenamedFmt;
  1135.        clear SaveDSname;
  1136.  1b    if i_Mbrtyp = 'RPG4';
  1137.           FileName = %xlate(lo: up: FileName);
  1138.           eorf = %xlate(lo: up: eorf);
  1139.           Device = %xlate(lo: up: Device);
  1140.           Usage = %xlate(lo: up: Usage);
  1141.  1x    else;
  1142.           FileName = FileName3;
  1143.           eorf = eorf3;
  1144.           Device = Device3;
  1145.           Usage = Usage3;
  1146.  1e    endif;
  1147.        //---------------------------------------------------------
  1148.  1b    if FileName <> *blanks
  1149.           and eorf = 'E'
  1150.           and (Device = 'DISK   '
  1151.           or (i_CmdSwitch <> 'JCRRFIL '
  1152.           and (Device = 'PRINTER  '
  1153.           or Device = 'WORKSTN ')));
  1154.  
  1155.  2b       if Device = 'PRINTER  '
  1156.              or Device = 'WORKSTN ';
  1157.              ParseElemDS.SortSequence = '2';  //process last
  1158.  2e       endif;
  1159.  
  1160.           FilNamSave = FileName;
  1161.           RecordType = 'F';
  1162.           exsr srLoadFileFields;
  1163.  1e    endif;
  1164.        //---------------------------------------------------------
  1165.  1b    if i_Mbrtyp = 'RPG4'  and     //check for Renames
  1166.           KeyWord4 > *blanks;
  1167.           KeyWord4 = %xlate(lo: up: KeyWord4);
  1168.           exsr srCheckRenamedFormat4;
  1169.           exsr srCheckIgnoredFormat4;
  1170.           exsr srCheckIncludedFormat4;
  1171.  2b       if i_CmdSwitch <> 'JCRRFIL ';
  1172.              exsr srCheckPrefixFormat4;
  1173.  2e       endif;
  1174.  1e    endif;
  1175.        //---------------------------------------------------------
  1176.  1b    if i_Mbrtyp = 'RPG3';  //check for Renames
  1177.  2b       if KeyWord3 = 'KRENAME';
  1178.              BeingRenamed = BeingRenamed3;
  1179.              RenamedFmt = Renamed3;
  1180.              exsr srOverlayRenamedFormats;
  1181.  2x       elseif KeyWord3 = 'KIGNORE';
  1182.              Beingignored = BeingRenamed3;
  1183.              exsr srRemoveIgnoredFormats;
  1184.  2e       endif;
  1185.  1e    endif;
  1186.        endsr;
  1187.  
  1188.        //---------------------------------------------------------
  1189.        // Load externally described Data Structures file information
  1190.        // This gets  complex as  File name could either be  DS name
  1191.        // or an EXTNAME( defined either on the same line as the DS or
  1192.        // on one of the subsequent lines.
  1193.        //---------------------------------------------------------
  1194.        begsr srDefinitionSpec;
  1195.        eorf = %xlate(lo: up: eorf);
  1196.        Defds = %xlate(lo: up: Defds);
  1197.        defFieldName = %xlate(lo: up: defFieldName);
  1198.        KeyWord4 = %xlate(lo: up: KeyWord4);
  1199.  
  1200.        //---------------------------------------------------------
  1201.        // First pass,  assume no EXTNAME( exists.   Go to file load
  1202.        // subroutine with the data structure name as the file.
  1203.        //---------------------------------------------------------
  1204.  1b    if eorf = 'E'
  1205.           and Defds = 'DS';
  1206.           SaveDSname = %triml(defFieldName);
  1207.           FileName = SaveDSname;
  1208.           FilNamSave = SaveDSname;
  1209.           IsFirstRecFmt = *on;
  1210.           RecordType = 'D';
  1211.           exsr srLoadFileFields;
  1212.           IsFirstRecFmt = *off;
  1213.  1e    endif;
  1214.  
  1215.        //---------------------------------------------------------
  1216.        // If there is a EXTNAME(,  then things get a little messy again.
  1217.        // It can have the format of extname(xxx) which means use the
  1218.        // first record format of this file or extname(xxxx:recfmt)
  1219.        // which means to use selected record format.
  1220.        // On top of this, I have already written an array element
  1221.        // when I tried using only DS name in previous section.
  1222.        // On top of this, I MAY have updated the array element
  1223.        // with the PREFIX so I gotta Save it and reload it.
  1224.        //---------------------------------------------------------
  1225.        aa = %scan('EXTNAME(': KeyWord4);
  1226.  1b    if aa > 0;
  1227.           ParseElemDs = arrsort(vl);
  1228.           SavPrefix = ParseElemDS.Prefix;
  1229.           SavPrefix_ = ParseElemDS.Prefix_chr;
  1230.           clear arrsort(vl);
  1231.           vl -= 1;
  1232.  
  1233.           cc = %scan(':': KeyWord4: aa);
  1234.           bb = %scan(')': KeyWord4: aa);
  1235.  2b       if cc = 0  or cc > bb;  //use *first recordfmt
  1236.              IsFirstRecFmt = *on;
  1237.              FileName = %triml(%subst(KeyWord4: aa + 8: (bb - aa) - 8));
  1238.              FilNamSave = FileName;
  1239.  2x       else;
  1240.  
  1241.              //---------------------------------------------------------
  1242.              // extname(xxx:recfmt).  This is as messy as it gets.
  1243.              // If a record format is selected, that is an implicit
  1244.              // INCLUDE.  I am going to dummy up an INCLUDE
  1245.              // statement, so the file processor can
  1246.              // automatically only load this record format.
  1247.              // First, extract filename and record format name.
  1248.              //---------------------------------------------------------
  1249.              FileName = %subst(KeyWord4: aa + 8: (cc - aa) - 8);
  1250.              Beingincluded = %subst(KeyWord4: cc + 1: (bb - cc) - 1);
  1251.              SavKeyWord4 = KeyWord4;
  1252.              KeyWord4 = 'INCLUDE('+ %trimr(Beingincluded) +  ')';
  1253.              FilNamSave = FileName;
  1254.              exsr srCheckIncludedFormat4;
  1255.              KeyWord4 = SavKeyWord4;
  1256.  2e       endif;
  1257.           exsr srLoadFileFields;
  1258.           clear SavPrefix;
  1259.           clear SavPrefix_;
  1260.           IsFirstRecFmt = *off;
  1261.  1e    endif;
  1262.        //---------------------------------------------------------
  1263.  1b    if KeyWord4 > *blanks;
  1264.           KeyWord4 = %xlate(lo: up: KeyWord4);
  1265.           exsr srCheckPrefixFormat4;
  1266.  1e    endif;
  1267.        endsr;
  1268.  
  1269.        //---------------------------------------------------------
  1270.        // load fields from either e DS or regular DS.
  1271.        //---------------------------------------------------------
  1272.        begsr srLoadFileFields;
  1273.  
  1274.        //---------------------------------------------------------
  1275.        // load the user space with information similar to
  1276.        // *basatr option on dspfd command.  Pointers are used
  1277.        // to load the data structures.
  1278.        //---------------------------------------------------------
  1279.        callp QUSLRCD(
  1280.              UserSpaceName  :
  1281.              'RCDL0200'  :
  1282.              FileName + '*LIBL ':
  1283.              '1'         :
  1284.              ApiErrDS);
  1285.  
  1286.  1b    if ApiErrDS.BytesReturned = 0;  //found it!
  1287.           exsr srCallJCRDbrr;  //get based on files
  1288.  
  1289.           //---------------------------------------------------------
  1290.           // Process data from user space.
  1291.           // GenericHeader.ListEntryCount contains the number of data blocks to get.
  1292.           // Move pointer to user space to 'retrieve' each entry.
  1293.           // Note: some processes only want the first record format.
  1294.           // so only do the 1 record format for those.
  1295.           //---------------------------------------------------------
  1296.  2b       if IsFirstRecFmt;
  1297.              GenericHeader.ListEntryCount = 1;
  1298.  2e       endif;
  1299.  
  1300.           quslrcdPtr = GenericHeaderPtr + GenericHeader.OffSetToList;
  1301.  2b       for ForCounter = 1 to GenericHeader.ListEntryCount;
  1302.  
  1303.              // Load array
  1304.              vl += 1;
  1305.              ParseElemDS.FileName = FileName;
  1306.              ParseElemDS.FormatName = quslrcdDS.RecordFormat;
  1307.              ParseElemDS.FormatRename = *blanks;
  1308.              ParseElemDS.BasedOnPF = BasedOnPF;
  1309.              ParseElemDS.HowUsed = Usage;
  1310.  
  1311.  3b          if quslrcdDS.FormatText <> *blanks;
  1312.                 ParseElemDS.FileText = quslrcdDS.FormatText;
  1313.  3x          else;
  1314.                 ParseElemDS.FileText = FileText;
  1315.  3e          endif;
  1316.              ParseElemDS.IsDataStruct = RecordType;
  1317.              ParseElemDS.DSname = SaveDSname;
  1318.              ParseElemDS.Prefix = SavPrefix;
  1319.              ParseElemDS.Prefix_chr = SavPrefix_;
  1320.              arrsort(vl) = ParseElemDs;
  1321.  
  1322.              quslrcdPtr += GenericHeader.ListEntrySize;
  1323.  2e       endfor;
  1324.           // ---ERROR OCCURRED------------------------
  1325.  1x    else;
  1326.           vl += 1;
  1327.           clear ParseElemDs;
  1328.           ParseElemDS.FileName = FileName;
  1329.           ParseElemDS.FormatRename = RenamedFmt;
  1330.           ParseElemDS.BasedOnPF = '*NOT FOUND';
  1331.           ParseElemDS.FileText = '*FILE NOT FOUND';
  1332.           ParseElemDS.IsDataStruct = RecordType;
  1333.           ParseElemDS.DSname = SaveDSname;
  1334.           arrsort(vl) = ParseElemDs;
  1335.  1e    endif;
  1336.        endsr;
  1337.  
  1338.        //---------------------------------------------------------
  1339.        // extract the RENAME values from RPG4 code.
  1340.        //---------------------------------------------------------
  1341.        begsr srCheckRenamedFormat4;
  1342.        bb = %scan('RENAME(': KeyWord4);
  1343.  1b    if bb > 0;
  1344.           aa = %scan(':': KeyWord4: bb);
  1345.           BeingRenamed = %subst(KeyWord4: bb + 7: aa - (bb + 7));
  1346.           bb = %scan(')': KeyWord4: aa);
  1347.           RenamedFmt = %subst(KeyWord4: aa + 1: (bb - aa) - 1);
  1348.           exsr srOverlayRenamedFormats;
  1349.  1e    endif;
  1350.        endsr;
  1351.  
  1352.        //---------------------------------------------------------
  1353.        // Check if record formats should be IGNORED from this file.
  1354.        // Note : multiple formats could be in one statement separated by :  .
  1355.        // The element in the Save file will be cleared for this record format.
  1356.        //---------------------------------------------------------
  1357.        begsr srCheckIgnoredFormat4;
  1358.        IsContinued = *off;
  1359.        bb = %scan('IGNORE(': KeyWord4);
  1360.  1b    if bb > 0;
  1361.  
  1362.  2b       dou not IsContinued;
  1363.              ArryOfRecFmts = f_ExtractFmts(KeyWord4);
  1364.  3b          for Index = 1 to %elem(ArryOfRecFmts);
  1365.  4b             if ArryOfRecFmts(Index) = *blanks;
  1366.  3v                leave;
  1367.  4e             endif;
  1368.                 Beingignored = ArryOfRecFmts(Index);
  1369.                 exsr srRemoveIgnoredFormats;
  1370.  3e          endfor;
  1371.  
  1372.              // check for continuation
  1373.              IsContinued = (%scan(')': KeyWord4) = 0);
  1374.  3b          If IsContinued;
  1375.                 read qrpgsc;
  1376.                 KeyWord4 = %xlate(lo: up: KeyWord4);
  1377.  3e          endif;
  1378.  2e       enddo;
  1379.  1e    endif;
  1380.        endsr;
  1381.  
  1382.        //---------------------------------------------------------
  1383.        // Several commands are concerned with file  Prefix statements.
  1384.        // This subroutine extracts the Prefix value and any
  1385.        // number-char-to-replace values.
  1386.        //---------------------------------------------------------
  1387.        begsr srCheckPrefixFormat4;
  1388.        aa = %scan('PREFIX(': KeyWord4);
  1389.  1b    if aa > 0;
  1390.           cc = %scan(':': KeyWord4: aa);
  1391.           bb = %scan(')': KeyWord4: aa);
  1392.  2b       if cc = 0 or cc > bb;  //: not found   OR 0 (other:func)
  1393.              FldPrefix = %subst(KeyWord4: aa + 7: (bb - aa) - 7);
  1394.              clear replacec;
  1395.  2x       else;
  1396.              FldPrefix = %subst(KeyWord4: aa + 7: (cc - aa) - 7);
  1397.              replacea = %subst(KeyWord4: cc + 1: 1);
  1398.  3b          if replacea = ' ';
  1399.                 replacec = 0;
  1400.  3e          endif;
  1401.  3b          if replacec < %len(%trimr(FldPrefix));
  1402.                 replacec = %len(%trimr(FldPrefix));
  1403.  3e          endif;
  1404.  2e       endif;
  1405.  
  1406.           //---------------------------------------------------------
  1407.           // If  match is found, load PREFIX data.
  1408.           //---------------------------------------------------------
  1409.  2b       for aa = 1 to vl;
  1410.              ParseElemDs = arrsort(aa);
  1411.  3b          if ParseElemDS.FileName = FilNamSave
  1412.                 and ParseElemDS.DSname = SaveDSname;
  1413.                 ParseElemDS.Prefix = FldPrefix;
  1414.                 ParseElemDS.Prefix_chr = replacec;
  1415.                 arrsort(aa) = ParseElemDs;
  1416.  3e          endif;
  1417.  2e       endfor;
  1418.  1e    endif;
  1419.        endsr;
  1420.  
  1421.        //---------------------------------------------------------
  1422.        // remove IGNORE record formats from array.
  1423.        // If a match is found on an Ignored record format,
  1424.        // clear the array element.
  1425.        //---------------------------------------------------------
  1426.        begsr srRemoveIgnoredFormats;
  1427.  1b    for aa = 1 to vl;
  1428.           ParseElemDs = arrsort(aa);
  1429.  2b       if ParseElemDS.FormatName = Beingignored
  1430.              and ParseElemDS.FileName = FilNamSave;
  1431.              clear arrsort(aa);
  1432.  1v          leave;
  1433.  2e       endif;
  1434.  1e    endfor;
  1435.        endsr;
  1436.  
  1437.        //---------------------------------------------------------
  1438.        // Check to see what record formats are INCLUDED for this file.
  1439.        // Note : multiple formats could be in one statement separated by :  .
  1440.        //---------------------------------------------------------
  1441.        begsr srCheckIncludedFormat4;
  1442.        IsContinued = *off;
  1443.        bb = %scan('INCLUDE(': KeyWord4);
  1444.  1b    if bb > 0;
  1445.  
  1446.  2b       dou not IsContinued;
  1447.              ArryOfRecFmts = f_ExtractFmts(KeyWord4);
  1448.  3b          for Index = 1 to %elem(ArryOfRecFmts);
  1449.  4b             if ArryOfRecFmts(Index) = *blanks;
  1450.  3v                leave;
  1451.  4e             endif;
  1452.                 Beingincluded = ArryOfRecFmts(Index);
  1453.                 exsr srSaveIncludedFormats;
  1454.  3e          endfor;
  1455.  
  1456.              // check for continuation
  1457.              IsContinued = (%scan(')': KeyWord4) = 0);
  1458.  3b          If IsContinued;
  1459.                 read qrpgsc;
  1460.                 KeyWord4 = %xlate(lo: up: KeyWord4);
  1461.  3e          endif;
  1462.  2e       enddo;
  1463.  1e    endif;
  1464.        endsr;
  1465.  
  1466.        //---------------------------------------------------------
  1467.        // This is kinda hard to follow.  The idea is, after all
  1468.        // records  have been processed, spin through FilesWithInclude array to
  1469.        // get all the files that have includes.  Then if file
  1470.        // does have an include,  lookup from the ArrSort
  1471.        // into the IncludedFormat array.
  1472.        // if the entry is not found,  then remove the arrsort entry.
  1473.        // Here I am only loading the file and file format arrays.
  1474.        //---------------------------------------------------------
  1475.        begsr srSaveIncludedFormats;
  1476.        FileDSname = FilNamSave + SaveDSname;
  1477.  1b    if %lookup(FileDSname: FilesWithInclude) = 0;
  1478.           ff += 1;
  1479.           FilesWithInclude(ff) = FilNamSave + SaveDSname;
  1480.  1e    endif;
  1481.        fff += 1;
  1482.        IncludedFormat(fff) = Beingincluded + FilNamSave + SaveDSname;
  1483.        endsr;
  1484.  
  1485.        //---------------------------------------------------------
  1486.        // Load renamed record formats into ARRAY.
  1487.        // Spin back though array looking for match with original
  1488.        // recfmt name.  When found, update array with Renamed fmt name.
  1489.        //---------------------------------------------------------
  1490.        begsr srOverlayRenamedFormats;
  1491.  1b    for aa = 1 to vl;
  1492.           ParseElemDs = arrsort(aa);
  1493.  2b       if ParseElemDS.FormatName = BeingRenamed
  1494.              and ParseElemDS.FileName = FilNamSave;
  1495.              ParseElemDS.FormatRename = RenamedFmt;
  1496.              arrsort(aa) = ParseElemDs;
  1497.  1v          leave;
  1498.  2e       endif;
  1499.  1e    endfor;
  1500.        endsr;
  1501.  
  1502.        //---------------------------------------------------------
  1503.        // if the selected file is a logical,  the based-on-physical name
  1504.        // is extracted and processing continues as if a physical had
  1505.        // been selected.
  1506.        //---------------------------------------------------------
  1507.        begsr srCallJCRDbrr;
  1508.        clear BasedOnPF;
  1509.  1b    if Device = 'DISK ';
  1510.           WorkFileAndLib = FileName + '*LIBL  ';
  1511.  
  1512.           callp QDBRTVFD(
  1513.                 FileHeader      :
  1514.                 %size(FileHeader):
  1515.                 ReturnFileQual:
  1516.                 'FILD0100'  :
  1517.                 WorkFileAndLib:
  1518.                 '*FIRST    ':
  1519.                 '0'         :
  1520.                 '*LCL      ':
  1521.                 '*EXT      ':
  1522.                 ApiErrDS);
  1523.  
  1524.  2b       if ApiErrDS.BytesReturned > 0;
  1525.              BasedOnPF = 'NOT FOUND ';
  1526.  2x       else;
  1527.              fscopePtr = FileHeaderPtr + FileHeader.OffsFileScope;
  1528.  3b          if tstbts(FileHeader.TypeBits: BitOffset) = 1;
  1529.                 BasedOnPF = FileScopeArry.BasedOnPf;
  1530.  3e          endif;
  1531.  
  1532.              ListHeaderPtr = GenericHeaderPtr +  GenericHeader.OffSetToHeader;
  1533.              FileText = ListHeaderDS.FileText;
  1534.  2e       endif;
  1535.  1e    endif;
  1536.  1b    if Device <> 'DISK ';
  1537.           FileText = Device;
  1538.  1e    endif;
  1539.        endsr;
  1540.  
  1541.        //---------------------------------------------------------
  1542.        // load the output parm from the array.
  1543.        //---------------------------------------------------------
  1544.        begsr srLoadReturnParm;
  1545.        cc = 1;
  1546.  
  1547.        sorta  arrsort;
  1548.        ForCounter1 = %elem(arrsort);
  1549.        vi = ForCounter1 - vl + 1;
  1550.  
  1551.  1b    for aa = vi to ForCounter1;
  1552.  
  1553.  2b       if arrsort(aa) <> *blanks;
  1554.              ParseElemDs = arrsort(aa);
  1555.              //---------------------------------------------------------
  1556.              // This nasty little section is used to filter rcdfmts
  1557.              // that are not INCLUDED.  Use file name to look up array
  1558.              // of file names that had an include. If file name is
  1559.              // found,  use file record format name to lookup
  1560.              // file/included recfmt array.  If NOT found, EXCLUDE.
  1561.              //---------------------------------------------------------
  1562.              IsIncluded = *on;
  1563.              FileDSname = ParseElemDS.FileName + ParseElemDS.DSname;
  1564.  3b          if %lookup(FileDSname: FilesWithInclude) > 0;
  1565.                 FileFormat = ParseElemDS.FormatName +
  1566.                 ParseElemDS.FileName + ParseElemDS.DSname;
  1567.  4b             if %lookup(FileFormat: IncludedFormat) = 0;
  1568.                    IsIncluded = *off;
  1569.  4e             endif;
  1570.  3e          endif;
  1571.  
  1572.  3b          if IsIncluded;
  1573.                 %subst(i_ReturnFiles: cc: 100) = ParseElemDs;
  1574.                 cc += 100;
  1575.  3e          endif;
  1576.  2e       endif;
  1577.  1e    endfor;
  1578.        endsr;
  1579.       /end-free
  1580.  
  1581.       //--*FUNCTIONS START HERE--------------------------------------
  1582.  
  1583.       //---------------------------------------------------------
  1584.       // The idea here is extract all the formats that
  1585.       // that can be included or excluded and return
  1586.       // them in an array of record formats.
  1587.       //---------------------------------------------------------
  1588.      P f_ExtractFmts   B
  1589.      D f_ExtractFmts   PI            10a   dim(15)
  1590.      D KeyWord                             like(KeyWord4) const
  1591.      D ArryOfRecFmts   s             10a   dim(15)
  1592.      D aa              s                   like(KeyWord4)
  1593.      D xx              s              3u 0 inz
  1594.      D Index           s              3u 0 inz
  1595.       /free
  1596.        ArryOfRecFmts(*) = *blanks;
  1597.        aa = KeyWord4;
  1598.        Index = 0;
  1599.  
  1600.        // remove prefix
  1601.        xx = %scan('IGNORE(': aa);
  1602.  1b    if xx > 0;
  1603.           aa = %subst(aa: xx + 7);
  1604.  1x    else;
  1605.           xx = %scan('INCLUDE(': aa);
  1606.  2b       if xx > 0;
  1607.              aa = %subst(aa: xx + 8);
  1608.  2e       endif;
  1609.  1e    endif;
  1610.  
  1611.        // remove all ':'
  1612.        xx = 1;
  1613.  1b    dou xx = 0;
  1614.           xx = %scan(':': aa: xx);
  1615.  2b       if xx > 0;
  1616.              %subst(aa: xx: 1) = ' ';
  1617.  2e       endif;
  1618.  1e    enddo;
  1619.  
  1620.        // remove final ')'
  1621.        xx = %scan(')': aa);
  1622.  1b    if xx > 0;
  1623.           %subst(aa: xx: 1) = ' ';
  1624.  1e    endif;
  1625.  
  1626.        aa = %triml(aa);
  1627.  
  1628.        //---------------------------------------------------------
  1629.        // There are many ways an include/ignore can be coded.
© 2004-2019 by midrange.com generated in 0.014s valid xhtml & css