<?xml version="1.0" encoding="UTF-8"?>
<upload appname="JCRANZO" appauthor="Craig Rutledge" appblddate=" 3/03/2003">
<install_instructions><![CDATA[
//---------------------------------------------------------------------------
* 1. Upload entire XML to your AS/400 to a source file 112 long, into any mbr
* name not in this XML (suggest member name like ABCX or XYZX). The source
* file must be in the library where source and objects are to be installed.
*
* 2. If you have XMLPREVIEW installed, skip to step 3.
* Copy the text between the start tag <install_program> and the end
* tag </install_program> into any member name (your choice)
* in file QRPGLESRC member type RPGLE. CRTBNDRPG to compile.
* NOTE: You need extract the install program only once, this same program
* will install any upload on this page.
*
* 3. Call the install program (or execute XmlPrevew) passing these 3 parms.
* 'your-member-name you uploaded this text into'
* 'your-source-file-name the member is in'
* 'your-library-name the source file is in'
*
* The various source members will be extracted and the objects required
* for the application will be created in your-library-name.
*
* Members in this install: (to view or manually extract members, scan <mbr )
* JCRANZOH PNLGRP Print O spec report layout - help text jcr
* JCRANZOR RPGLE print O spec report layout with field names jcr
* JCRRECGETR RPGLE Record format/file xref for RPG source jcr
* JCRFLDCPYR RPGLE Get source names from /copy for processing jcr
* JCRFLDGETR RPGLE Get field attributes from RPG4 programs jcr
* JCRVALMBRV RPGLE Validity checker for mbr/file/lib jcr
* JCRANZO CMD Print O spec report layout with field names jcr
*
//---------------------------------------------------------------------------
]]> </install_instructions>
<install_program><![CDATA[
* /// START OF INSTALL PGM HERE ************************** ///
//-------------------------------------------------------------
// Parse / Install from xml text into source members and objects. v5r1
// Craig Rutledge < [URL unfurl="true"]www.jcrcmds.com[/URL] > Copyright (C) 2001
// Martin Rowe <martin@dbg400.net> scripting cmd prompts
// David George <webmaster@400times.co.uk> intellectual input
// Thomas Raddatz <thomas.raddatz@tools400.de> command mode/where allowed
// 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 details
// Use xml tags in text to trigger:
// 1. Parse text into source members (create srcfile & member if required).
// 2. Compile source into objects.
// 3. Send installation progress user messages.
// 4. Execute qcmdexc as required.
//-------------------------------------------------------------
Fxmlinput if f 112 disk extfile(extIfile) extmbr(ParseSrcMbr) uploaded text
F usropn
Fqxxxsrc o f 112 disk extfile(extOfile) extmbr(mbrname) parsed out
F usropn
//-------------------------------------------------------------
D extIfile s 21a
D extOfile s 21a
D vrcvar s 145a
D qm_msgid s 7a
D qm_msgtxt s 65a
D qm_msgq s 10a
D qm_msgtyp s 10a
D mbrname s 10a
D mbrtype s 10a
D mbrtext s 50a
D srcfile s 10a
D srclen s 5a
D srccssid s 5a
D bldexc s 500a
D IsWrite s n inz(*off)
D srcSeqno s 6s 2 inz(0)
D aa s 5u 0 inz(0)
D ll s 5u 0 inz(0)
D qs c ''''
// Error return code parm for APIs.
D vApiErrDs ds
D vbytpv 10i 0 inz(%size(vApiErrDs)) bytes provided
D vbytav 10i 0 inz(0) bytes returned
D vmsgid 7a error msgid
D vresvd 1a reserved
D vrpldta 50a replacement data
//-------------------------------------------------------------
D qusrmbrd PR ExtPgm('QUSRMBRD') MEMBER DESC
Db like(vrcvar) RCVR
D 10i 0 const RCVR LEN
D 8 const TYPE
D 20 const FILE LIB
D 10 MBR NAME
D 1 const OVERRIDE?
Db like(vApiErrDS)
D qmhsndpm PR ExtPgm('QMHSNDPM') SEND MESSAGE
D 7 ID
D 20 const FILE
Db like(qm_msgtxt) TEXT
D 10i 0 const LENGTH
D 10 const TYPE
D 10 QUEUE
D 10i 0 const STACK ENTRY
D 4 const KEY
Db like(vApiErrDS)
D qcmdexc PR ExtPgm('QCMDEXC')
D 500A options(*varsize)
D 15P 5 Const
//-----------------------------------------------
Ixmlinput ns
I 13 21 xmltag1
I 18 27 xmltag2
I 13 112 xmlcode
//-----------------------------------------------
C *entry plist
C parm ParseSrcMbr 10 source member
C parm ParseSrcFile 10 source file
C parm ParseSrcLib 10 source lib
// xmlpreview uses this parm to redirect to user selected source file. optional
C parm OvrSrcFile 10 override to source
/free
exsr srValidate; //make sure exists
// Set user selected library *first for remainder of program
bldexc = 'RMVLIBLE LIB('+%trimr(ParseSrcLib) + ')';
callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)));
bldexc = 'ADDLIBLE LIB('+
%trimr(ParseSrcLib) + ') POSITION(*FIRST)';
callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)));
// Override Input file to uploaded text file
extIfile = %trimr(ParseSrcLib)+'/'+ParseSrcFile;
open xmlinput;
read xmlinput;
1b dow not %eof;
// write records to outfile if flag is on
2b if IsWrite;
3b if xmltag2<>'</copysrc>';
srcSeqno=srcSeqno+1;
except write_one;
3x else;
IsWrite=*off;
close qxxxsrc;
3e endif;
// Extract values based on xml tags.
2x elseif xmltag1 = 'mbrname =';
mbrname = %subst(xmlcode:13:10);
2x elseif xmltag1 = 'mbrtype =';
mbrtype =%subst(xmlcode:13:10);
2x elseif xmltag1 = 'mbrtext =';
mbrtext =%subst(xmlcode:13:50);
2x elseif xmltag1 = 'srcfile =';
3b if %parms=4; //xmlpreview override
srcfile=OvrSrcFile;
3x else;
srcfile =%subst(xmlcode:13:10);
3e endif;
2x elseif xmltag1 = 'srclen =';
3b if %parms=4; //xmlpreview override
srclen='00112';
3x else;
srclen =%subst(xmlcode:13:5);
3e endif;
2x elseif xmltag1 = 'srccssid=';
srccssid=%subst(xmlcode:13:5);
// Start of data to copy. Create source files/mbrs as required.
2x elseif xmltag1='<copysrc>';
// crtsrcpf
bldexc = 'CRTSRCPF FILE(' +
%trimr(ParseSrcLib)+'/'+
%trimr(srcfile) + ') RCDLEN(' +
srclen + ') CCSID(' +
srccssid + ')';
callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)));
// addpfm
bldexc = 'ADDPFM FILE(' +
%trimr(ParseSrcLib)+'/'+
%trimr(srcfile) + ') MBR(' +
%trimr(mbrname) + ') SRCTYPE(' +
%trimr(mbrtype) + ') TEXT(' +
qs+%trimr(mbrtext)+qs + ')';
callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)));
3b if %error;
// chgpfm
bldexc = 'CHGPFM FILE(' +
%trimr(ParseSrcLib)+'/'+
%trimr(srcfile) + ') MBR(' +
%trimr(mbrname) + ') TEXT(' +
qs+%trimr(mbrtext)+qs + ')';
callp qcmdexc(bldexc:%len(%trimr(bldexc)));
// clr mbr
bldexc = 'CLRPFM FILE(' +
%trimr(ParseSrcLib)+'/'+
%trimr(srcfile) + ') MBR(' +
%trimr(mbrname) + ')';
callp qcmdexc(bldexc:%len(%trimr(bldexc)));
3e endif;
// ovr to outfile mbr
extOfile=%trimr(ParseSrcLib) +'/'+srcfile;
clear srcSeqno;
open qxxxsrc;
IsWrite = *on;
// ------------------------------------------------------
// Compile statement. Read next record and execute it.
// The subroutine srTolibToken will replace &tolib with the
// library the user has selected at run time.
// ------------------------------------------------------
2x elseif xmltag1 = '<compile>';
read xmlinput;
bldexc = %trimr(xmlcode);
exsr srTolibToken;
callp qcmdexc(bldexc:%len(%trimr(bldexc)));
// ------------------------------------------------------
// qcmdexc statement. Build statement from each record between start
// and stop tags. When stop tag is found, execute statement.
// if dltxxx command, allow errors to be ignored.
// ------------------------------------------------------
2x elseif xmltag1 = '<qcmdexc>';
clear bldexc;
aa=1;
read xmlinput;
3b dow xmltag2<>'</qcmdexc>';
%subst(bldexc:aa:100)=xmlcode;
aa=aa+100;
read xmlinput;
3e enddo;
exsr srTolibToken;
3b if %subst(bldexc:1:3)='DLT';
callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)));
3x else;
callp qcmdexc(bldexc:%len(%trimr(bldexc)));
3e endif;
// ------------------------------------------------------
// Send messages to user as program executes
// Extract message ID, Message Type, from <sendmsg>
// read a record and get the single line of message text.
// ------------------------------------------------------
2x elseif xmltag1 = '<sendmsg ';
qm_msgid = %subst(xmlcode:22:7);
qm_msgtyp = %subst(xmlcode:46:10);
read xmlinput;
qm_msgq = '*EXT ';
3b if qm_msgtyp='*COMP ';
qm_msgq = '*PGMBDY';
3e endif;
qm_msgtxt = xmlcode;
exsr srSndMessage;
2e endif;
read xmlinput;
1e enddo;
*inlr=*on;
return;
// ------------------------------------------------------
// Replace &tolib (no matter how many times it is in string)
// with whatever library the user has selected at run time.
// ------------------------------------------------------
begsr srTolibToken;
aa=%scan('&tolib':bldexc);
1b dow aa>0;
bldexc=%replace(%trimr(ParseSrcLib):bldexc:aa:6);
aa=%scan('&tolib':bldexc);
1e enddo;
// user has selected to override source, reset SRCFILE parm in bldexcs.
1b if %parms=4; //xmlpreview override
aa=%scan('SRCFILE(':bldexc);
2b if aa>0;
aa=%scan('/':bldexc:aa);
3b if aa>0;
ll=%scan(')':bldexc:aa);
bldexc=%replace(%trimr(OvrSrcFile):bldexc:aa+1:ll-(aa+1));
3e endif;
2e endif;
1e endif;
endsr;
// ------------------------------------------------------
// Check of file, lib, member exist.
begsr srValidate;
callp QUSRMBRD(vrcvar:145:'MBRD0100':
ParseSrcFile + ParseSrcLib:ParseSrcMbr:
'0':vapierrds);
// ------------------------------------------------------
// If error occurred on call, send appropriate message back to user.
1b if vBytav>0; //error occurred
2b if vmsgid = 'CPF9810'; // lib not found
qm_msgtxt = '0000 Library ' +
%trimr(ParseSrcLib) + ' was not found.';
2x elseif vmsgid = 'CPF9812'; // src file not found
qm_msgtxt = '0000 Source file ' +
%trimr(ParseSrcFile)+' was not found in ' +
%trimr(ParseSrcLib) + '.';
2x elseif vmsgid = 'CPF9815'; // member not found
qm_msgtxt = '0000 Member ' +
%trimr(ParseSrcMbr)+' was not found in ' +
%trimr(ParseSrcLib)+'/'+ %trimr(ParseSrcFile);
2x else; // unexpected
qm_msgtxt = '0000 Unexpected message ' +
vmsgid + ' received. ';
2e endif;
// send message
qm_msgid = 'CPD0006';
qm_msgtyp = '*DIAG';
qm_msgq = '*CTLBDY';
exsr srSndMessage;
qm_msgtxt = *blanks;
qm_msgid = 'CPF0002';
qm_msgtyp = '*ESCAPE';
exsr srSndMessage;
*inlr=*on;
return;
1e endif;
endsr;
// ------------------------------------------------------
begsr srSndMessage;
callp QMHSNDPM(qm_msgid:'QCPFMSG *LIBL ':
qm_msgtxt:%size(qm_msgtxt):qm_msgtyp:qm_msgq:
1:' ': vApiErrDS);
endsr;
/end-free
Oqxxxsrc e write_one
O srcSeqno 6
O 12 '000000'
O xmlcode 112
* /// END OF INSTALL PGM HERE /// do not copy past this point ********** ///
]]> </install_program>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Installing JCRANZOH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZOH "
mbrtype = "PNLGRP "
mbrtext = "Print O spec report layout - help text jcr "
srcfile = "QPNLSRC "
srclib = "selected "
srclen = "00112"
srccssid= "00037">
<copysrc><![CDATA[
.*-------------------------------------------------------------------*
.* JCRANZO - Print OSPEC Fields Report - Help Text *
.* By Craig Rutledge, 3/02/95 *
.*-------------------------------------------------------------------*
:PNLGRP.
:HELP NAME='JCRANZO'.
Analyze OSPEC Fields (JCRANZO) - Help
:P.The
Analyze OSPEC Fields (JCRANZO) command reads your RPG4 source O specs
to provide a representational report with the field name printed under the data.
This is a very easy way to determine which
fields are positioned where on the report without having to dig
through source code.
:NT.This command will only process rpg4.:ENT.
.*
:P.The LayoutOnly keyword was added to allow printing of a layout without the
print line data and field names. This could be used to generate a prototype
layout to show a user what the report will look like.
.*-------------------------------------------------------------------
:LINES.
The objects used by this command are:
JCRANZO *CMD Command Prompt
JCRANZOR *PGM RPGLE Report layout from RPG4 O specs
JCRFLDGETR *PGM RPGLE Get attributes of RPG4 fields.
JCRFLDCPYR *PGM RPGLE Process through /copy statements
JCRRECGETR *PGM RPGLE Get attributes of data files.
JCRANZOH *PNLGRP Help Text
JCRVALMBRV *PGM RPGLE Validity Checker
:ELINES.
:P.Craig Rutledge
:EHELP.
.*
.*--------------------------------------------------------------------
.* HELP TEXT FOR PGM PARAMETER
.*--------------------------------------------------------------------
:HELP name='JCRANZO/PGM'.
PGM source member name (PGM) - Help
:XH3.PGM source member name (PGM)
:P.
Specifies the name of the PGM for which the field list is to
be printed.
:P.
This is a required parameter.
:PARML.
:PT.Source-file-PGM-member-name
:PD.Specify the PGM member name.
:EPARML.
:EHELP.
.*--------------------------------------------------------------------
.* HELP TEXT FOR SRCFILE
.*--------------------------------------------------------------------
:HELP name='JCRANZO/SRCFILE'.
Source file - Help
:XH3.Source file (SRCFILE)
:P.Specifies the name of the source file that contains the source
PGM member.
.*
:PARML.
:PT.:PK def.QRPGSRC:EPK.
:PD.The default source file, QRPGSRC, contains the PGM source member
to be listed.
.*
:PT.source-file-name
:PD.Enter the source file name that contains the PGM source member to
be listed.
.*
: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 LAYOUTONLY PARAMETER
.*--------------------------------------------------------------------
:HELP name='JCRANZO/LAYOUTONLY'.
Exclude Record Formats & Field Names - Help
:XH3.Exclude Record Formats & Field Names (LAYOUTONLY)
:P.Specifies whether to exclude the print line names and field names from the
layout report.
.*
:PARML.
:PT.:PK def.*NO:EPK.
:PD.The print lines names/spacing information and the field names will be
included on the report
.*
:PT.*YES
:PD.Excludes the print line names/field names to generate a prototype
report layout as the user would see it.
:EPARML.
:EHELP.
:EPNLGRP.
]]> </copysrc>
</mbr>
<compile><![CDATA[
CRTPNLGRP PNLGRP(&tolib/JCRANZOH) SRCFILE(&tolib/QPNLSRC)
]]> </compile>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Installing JCRANZOR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZOR "
mbrtype = "RPGLE "
mbrtext = "print O spec report layout with field names jcr "
srcfile = "QRPGLESRC "
srclib = "selected "
srclen = "00112"
srccssid= "00037">
<copysrc><![CDATA[
H DFTACTGRP(*NO) ACTGRP(*CALLER) BNDDIR('QC2LE') EXPROPTS(*RESDECPOS)
H DATFMT(*ISO) TIMFMT(*ISO) OPTION(*NODEBUGIO)
H COPYRIGHT('02/12/1998 Craig Rutledge < [URL unfurl="true"]www.jcrcmds.com[/URL] > ')
//----------------------------------------------------------------
// JCRANZOR - generate report showing ospec spacing for RPG4
// 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.
//----------------------------------------------------------------
// 12/03/1999 - correctly stagger field names if descending
// 08/20/2000 - added report layout only
// 02/15/2001 - process - (minus sign) in position offset
// 12/04/2001 - use alloc memory instead of data queue method
// 12/05/2001 - corrected problem reported by Joe_Solis
// replace two single quotes with one single quote
// before calcing length of output constant.
//----------------------------------------------------------------
// program summary:
// allocate memory for fields names array
// call program to process fields in /copy books
// call program to load field names & attributes into memory
// unload memory into field definition arrays.
// read rpg source code specs
// load output arrays with positional field data and field names
// print
//----------------------------------------------------------------
Fqrpgsc if f 112 disk extfile(i_extfile) extmbr(i_smbr)
F usropn
Fqsysprt o f 198 printer oflind(*inof) usropn
//
D Formatted1 s 1 dim(198) PRINT LINE1
D Formatted2 s 198 FIELD NAMES
D Formatted3 s 198 NO OVERLAY FLD NAMES
D alpha135 s 135
D FilErr s 10a
D qs c '''' single quote
D memFields ds based(memptr1) align
D memNumEntries 5u 0
D memEntryLen 5u 0
D memPassPtr s * inz(*null)
D ArryRuler1 s 10 dim(19) RULER ON PAGE
D ArryRuler2 s 1 dim(198) RULER ON PAGE
D UnderLine s 198 inz(*all'_')
D FormatLine s 1 inz(*all'_') dim(198) h,t,d,e lines
D vEditMask s 256 EDIT MASK
//
//----------------------------------------------------------------
// emln - edit mask length
// rcvln - receiver variable length
// svlp - source variable precision
// svlp - source variable decimal position
//----------------------------------------------------------------
D vEdtMaskLn s 10i 0
D vRecvrLen s 10i 0
D vSrcVarPre s 10i 0
D vSrcVarDec s 10i 0
//----------------------------------------------------------------
// Error return code parm for APIs.
//----------------------------------------------------------------
D vApiErrDs ds
D vbytpv 10i 0 inz(%size(vApiErrDs)) bytes provided
D vbytav 10i 0 inz(0) bytes returned
D vmsgid 7a error msgid
D vresvd 1a reserved
D vrpldta 50a replacement data
//----------------------------------------------------------------
// Field attribute info
//----------------------------------------------------------------
D MapFldData ds inz
D MapFldLen 5 0
D MapDecPos 2
D MapdecposN 2s 0 overlay(mapdecpos)
D MapDtaTyp 1
D MapFldSrc 10
D MapFldTxt 25
D decpos s 1 0 inz(0)
//----------------------------------------------------------------
D vnines s 30 inz(*all'9') build pseudo number
D vzeros s 30 inz(*all'0')
//----------------------------------------------------------------
D xa s 5i 0
D xb s 5u 0
D xe s 5i 0
D xf s 3u 0 )
D xg s 3u 0 (
D xh s 3u 0 (
D xi s 5u 0
D xj s 5u 0 load index
D xk s 5u 0
D xm s 5i 0
D xo s 5u 0
D plen s 3u 0 )
D dummy s 5u 0
D ds inz
D DimSizeA 1 5 alpha array dim size
D DimSize 1 5s 0 numeric dim size
//
D FloatDollar s 3 inz('''$''')
D ds inz
D v30_9Alph 1 30
D v30_9DecZ 1 30s 9
D v30_9Dec s 30p 9 inz(0)
D vwhole s 21 whole part of number
D vdecim s 9 decimal part
D IntegerLength s 5u 0 inz(0)
D ds inz
D plspos 1 5
D plsposN 1 5s 0
D LoadNamFlg s 14 inz('Load Name Flag')
D LookUpName s 15 drop array index
D LastEndPos s 5u 0 inz(0)
D BuildEditd ds edit code returned
D ArryOfBld 1 dim(40)
D IPPfield s 12 IPP prompt data
D ArryOfFmt s 1 dim(84)
D up c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
D lo c const('abcdefghijklmnopqrstuvwxyz')
//----------------------------------------------------------------
D FieldNames s 15 dim(4000) FIELD NAMES & DTA
D FieldAttrb s 43 dim(%elem(FieldNames))
D ii s 5u 0 inz(0)
D vMemData s 58 based(memptr2)
D vrcvar s 256
//----------------------------------------------------------------
D FirstTime s 2 inz('XX')
D O_EndPosN s 5s 0 based(O_EndPtr)
D O_EndPtr s * inz(%addr(O_EndPos))
//----------------------------------------------------------------
// Create Prototypes for calls
//----------------------------------------------------------------
D JCRFLDCPYR PR ExtPgm('JCRFLDCPYR') process fields
D * memory allocation
D i_extfile 21A
D i_smbr 10A
D i_pcallingcmd 10A const
D i_perror 10A
//
// -------------------------------------------------------------
D qeccvtec PR ExtPgm('QECCVTEC') GENERATE EDIT MASK
D 256 RECEIVER VARIAB
D 10i 0 MASK LENGTH
D 10i 0 RECEIVER LENGTH
D 1 const 0 BALANCE FILE
D 1 EDIT CODE
D 1 const BLANK FILL
D 10i 0 const FIELD LENGTH
D 10i 0 const DECIMAL LOCATION
Db like(vApiErrDs)
// -------------------------------------------------------------
D qecedt PR ExtPgm('QECEDT') APPLY MASK
D 256 RECEIVER VARIAB
D 10i 0 MASK LENGTH
D 30p 9 TO BE EDITED
D 10 const TYPE
D 10i 0 const FIELD LENGTH
D 256 EDIT MASK
D 10i 0 MASK LENGTH
D 1 const 0 BALANCE FILE
Db like(vApiErrDs)
// -------------------------------------------------------------
D qmhsndpm PR ExtPgm('QMHSNDPM') SEND MESSAGES
D 7a const ID
D 20a const FILE
D 65a const TEXT
D 10i 0 const LENGTH
D 10a const TYPE
D 10a const QUEUE
D 10i 0 const STACK ENTRY
D 4a const KEY
Db like(vApiErrDS)
// -------------------------------------------------------------
D qusrmbrd PR ExtPgm('QUSRMBRD') RETRIEVE MBR DESC
D 135a RECEIVER
D 10i 0 const LENGTH OF RECVR
D 8a const UPLOAD TYPE
D 20a const FILE LIB
D 10a const MEMBER NAME
D 1a const PROCESS OVERIDE
Db like(vApiErrDS) error parm
// -------------------------------------------------------------
D system PR 10I 0 extproc('system')
D i_cmd * value options(*string)
// -------------------------------------------------------------
D main PR extpgm('JCRANZOR')
D 10A
D 20A
D 4A
// -------------------------------------------------------------
D main PI Input Parms
D i_smbr 10A
D i_sfil_slib 20A
D i_layout 4A
//
D i_sfil s 10A
D i_slib s 10A
D i_extfile s 21A
//
//----------------------------------------------------------------
Iqrpgsc ns
I 13 14 ArrayLineType
I 18 18 LineType
I 19 19 O_Comment
I 28 31 O_AndOr
I 29 29 O_LinType
I 33 41 O_Indicat
I 52 54 O_SpaceB
I 55 57 O_SpaceA
I 58 60 O_SkipB
I 61 63 O_SkipA
I 42 55 O_Ename
I 56 56 O_EditCode
I 59 63 O_EndPos
I 65 92 O_Constant
I 19 102 ArryOfFmt
//
//----------------------------------------------------------------
// Determine member type.
/free
callp QUSRMBRD(
alpha135:
135:
'MBRD0100':
i_sfil_slib:
i_smbr:
'0':
vapierrds);
1b if %subst(alpha135:49:10) = 'RPGLE ' or
%subst(alpha135:49:10) = 'SQLRPGLE ';
i_sfil = %subst(alpha135:9:10);
i_slib = %subst(alpha135:19:10);
i_extfile=%trimr(i_slib) + '/' + i_sfil;
// Send status message
callp QMHSNDPM(
'CPF9898':'QCPFMSG *LIBL ':
'O spec layout for '+
%trimr(i_extfile) + ' member ' +
%trimr(i_smbr) + ' - in progress':
65:'*STATUS':'*EXT': 1:' ':
vApiErrDS);
// Allocate memory for field attribute loader to use
// and initialize the entry counter and size fields
memptr1=%alloc(232004);
memNumEntries=0;
memEntryLen=58;
memPassPtr=memPtr1;
callp JCRFLDCPYR(memPassPtr:
i_extfile:
i_smbr:
'JCRANZO ':
FilErr);
// if file-not-found error, send message
2b if FilErr <> *blanks;
dealloc memptr1;
callp qmhsndpm('CPD0006':'QCPFMSG *LIBL ':
'0000 *ERROR* External file ' +
%trimr(FilErr) + ' not found in *libl.':
70:'*DIAG':'*CTLBDY':1:' ':vApiErrDS);
callp qmhsndpm('CPD0002':'QCPFMSG *LIBL ':
' ':
30:'*ESCAPE':'*CTLBDY':1:' ':vApiErrDS);
*inlr=*on;
return;
2e endif;
// override printer file
callp system('OVRPRTF FILE(QSYSPRT) '+
'PAGESIZE(66 198) CPI(15) SPLFNAME('+
%trimr(i_smbr)+')');
open qrpgsc;
open qsysprt;
*in50 = (i_LayOut = '*YES');
except Heading;
// -------------------------------------------
// Pull all entries from memory
// -------------------------------------------
2b for dummy = 1 to memNumEntries;
memptr2 =memPtr1 + (ii * memEntryLen)+5;
ii=ii+1;
FieldNames(ii)=%subst(vMemData:1:15);
FieldAttrb(ii)=%subst(vMemdata:16);
2e endfor;
dealloc memptr1;
// load ruler to print positions
2b for xa=1 to 198;
ArryRuler2(xa)=%subst(%editc(xa:'3'):5:1);
2e endfor;
2b for xa=1 to 19;
evalr ArryRuler1(xa)=%subst(%editc(xa:'3'):5:1);
2e endfor;
except RulerPrint;
xk=0;
// -------------------------------
//
read qrpgsc;
2b dow not %eof;
3b if ArrayLineType = '**' or
Linetype = 'P' or
Linetype = 'p';
2v leave;
3e endif;
3b if (LineType='O' or LineType='o') and
(not (o_comment ='*' or o_comment='/'));
// Determine type of Ospec and print.
O_AndOr=%xlate(lo:up:O_AndOr);
4b if O_LinType <> *blanks and
O_AndOr <> 'OR ' and
O_AndOr <> 'AND';
exsr srIPOLine;
4x else;
clear IPPfield;
exsr srGetFieldAttr;
exsr srFieldLoad;
4e endif;
3e endif;
read qrpgsc;
2e enddo;
//-------------------------------------------------------
// all processed.
except PrintLine;
close qrpgsc;
close qsysprt;
callp system('DLTOVR FILE(QSYSPRT)');
// send completion message
callp QMHSNDPM(
' ':' ':
'O spec layout for '+
%trimr(i_smbr) + ' in ' +
%trimr(i_extfile) + ' - completed':
65:'*INFO ':'*CTLBDY ': 1:' ':
vApiErrDS);
1e endif;
*inlr=*on;
return;
// -------------------------------------------------------
// First, print field data for previous line.
// Format the line data. Any space is loaded with a '_'
// then it is loaded into an array for printing.
// -------------------------------------------------------
begsr srIPOLine;
1b if FirstTime = 'NO';
except PrintLine;
clear formatted1;
clear formatted2;
clear formatted3;
clear xj;
clear LastEndPos;
1e endif;
FirstTime = 'NO';
// ---------------------------------------------------------
1b for xm= 1 to 84;
2b if ArryOfFmt(xm) = ' ';
ArryOfFmt(xm) = '_';
2e endif;
FormatLine(xm+1)=ArryOfFmt(xm);
1e endfor;
except NewLine;
endsr;
// -----------------------------------------------------------
// Load the data into the print array.
// -----------------------------------------------------------
begsr srFieldLoad;
// ---------------------------------------------------------
// end position = blank Load from the Left to right
// ---------------------------------------------------------
1b if O_Endpos = *blank;
xj = LastEndPos;
2b if
IPPfield = 'Constant ';
exsr srDoConstLeft;
2x elseif
IPPfield = 'Alpha Field ';
exsr srDoAlphaLeft;
2x elseif
IPPfield = 'Num EditWord';
exsr srDoConstLeft;
2x elseif
IPPfield = 'Num EditCode';
exsr srDoEditCodeLeft;
2e endif;
1x else;
// -----------------------------------------------------
// end position = + and some value load from left to right
// 2/15/01 check for - in endposition
// -----------------------------------------------------
clear xb;
xe = %scan('+':O_Endpos:1);
2b if xe = 0;
xb = %scan('-':O_Endpos:1);
2e endif;
2b if xe > 0 //plus
or xb > 0; //minus
clear plspos;
3b if xe > 0; //plus
%subst(plspos:xe+1) = %subst(O_endpos:xe+1); //drop plus sign
3x else;
%subst(plspos:xb+1) = %subst(O_endpos:xb+1); //drop minus sign
3e endif;
3b if plspos=*blanks;
xj=0;
3x else;
xj=plsposN;
3e endif;
3b if xe > 0; //plus
xj = LastEndPos + xj;
3x else;
xj = LastEndPos - xj;
3e endif;
3b if
IPPfield = 'Constant ';
exsr srDoConstLeft;
3x elseif
IPPfield = 'Alpha Field ';
exsr srDoAlphaLeft;
3x elseif
IPPfield = 'Num EditWord';
exsr srDoConstLeft;
3x elseif
IPPfield = 'Num EditCode';
exsr srDoEditCodeLeft;
3e endif;
// ----------------------------------------------
// end position is given, load from right to left
// ----------------------------------------------
2x else;
3b if O_EndPos=*blanks;
xj=0;
3x else;
xj=O_EndPosN;
3e endif;
3b if
IPPfield = 'Constant ';
exsr srDoConstRight;
3x elseif
IPPfield = 'Alpha Field ';
exsr srAlphaRight;
3x elseif
IPPfield = 'Num EditWord';
exsr srDoConstRight;
3x elseif
IPPfield = 'Num EditCode';
exsr srDoEditCodeRight;
3e endif;
2e endif;
1e endif;
endsr;
// -------------------------------------------------------
// load edit coded field with no endpos or + endpos.
// The BuildEditd field is the end result of an API edit mask apply.
// Blanks and zeros are filtered out. Also, filter the
// a decimal point '.' from zero decimal numbers.
// -------------------------------------------------------
begsr srDoEditCodeLeft;
exsr srGetEditCode;
LoadNamFlg = 'Start FldNam';
1b for xm = 1 to 40;
2b if (ArryOfBld(xm) > ' ' AND
ArryOfBld(xm) <> '0');
3b if (decpos = 0 AND
ArryOfBld(xm) = '.');
3x else;
xj = xj + 1;
4b if LoadNamFlg = 'Start FldNam';
exsr srLoadFieldName;
4e endif;
formatted1(xj) = ArryOfBld(xm);
3e endif;
2e endif;
1e endfor;
LastEndPos = xj; //reset last end pos
endsr;
// -------------------------------------------------------
// load edit coded field with end positions.
// Start at end position and work backwards.
// -------------------------------------------------------
begsr srDoEditCodeRight;
exsr srGetEditCode;
LastEndPos = xj;
xj=xj+1;
1b for xa=40 downto 1 by 1;
2b if (ArryOfBld(xa) > ' ' AND
ArryOfBld(xa) <> '0');
3b if (decpos = 0 AND
ArryOfBld(xa) = '.');
3x else;
xj = xj - 1;
formatted1(xj) = ArryOfBld(xa); //load edited field
3e endif;
2e endif;
1e endfor;
// -----------------------------------------------------
// set variables to to load field name into print arrays
// -----------------------------------------------------
xi=xj-1;
1b if xi <= 0;
xi = 1;
1e endif;
xk=xj;
exsr srStagger;
endsr;
// ----------------------------------------------------------
// Process numeric fields that have edit words or constants.
// The only difference is Edtwords have ' ' replaced with '9'.
// ----------------------------------------------------------
begsr srDoConstLeft;
LoadNamFlg = 'Start FldNam';
1b for xm= 2 to 28;
2b if %subst(O_Constant:xm:1) = qs;
1v leave;
2e endif;
xj = xj + 1;
2b if LoadNamFlg = 'Start FldNam';
exsr srLoadFieldName;
2e endif;
2b if %subst(O_Constant:xm:1) = ' ' and
IPPfield = 'Num EditWord';
3b if
MapDtaTyp='D';
formatted1(xj) = 'D';
3x elseif
MapDtaTyp='Z';
formatted1(xj) = 'Z';
3x elseif
MapDtaTyp='T';
formatted1(xj) = 'T';
3x else;
formatted1(xj) = '9'; //load edited field
3e endif;
2x else;
formatted1(xj) = %subst(O_Constant:xm:1); //load constants
2e endif;
1e endfor;
LastEndPos = xj;
endsr;
// -----------------------------------------
// Constants or Edit worded fields.
// Start at end position and work backwards.
// -----------------------------------------
begsr srDoConstRight;
// ---------
// per Joe_Solis, a RPG output constant uses two single
// quotes to specify that one single quote should be printed.
// This section replaces the two single quotes with one single
// quote before calculating the length of the constant.
xe=%scan(qs+qs:O_Constant:2);
1b dow xe>0;
O_Constant=%replace(qs:O_Constant:xe:2);
xe=%scan(qs+qs:O_Constant:xe+1);
1e enddo;
// ---------
xe=%checkr(' ':O_constant);
LastEndPos = xj;
xj=xj+1;
1b for xa = (xe-1) downto 2 by 1;
xj = xj - 1;
2b if %subst(O_Constant:xa:1) = ' ' and
IPPfield = 'Num EditWord';
3b if
MapDtaTyp='D';
formatted1(xj) = 'D';
3x elseif
MapDtaTyp='Z';
formatted1(xj) = 'Z';
3x elseif
MapDtaTyp='T';
formatted1(xj) = 'T';
3x else;
formatted1(xj) = '9'; //load edited field
3e endif;
2x else;
formatted1(xj) = %subst(O_Constant:xa:1); //load constants
2e endif;
1e endfor;
// ---------------------------------
// set variable to load field name.
// ---------------------------------
1b if o_ename <> *blanks;
xi=xj-1;
2b if xi <= 0;
xi = 1;
2e endif;
xk=xj;
exsr srStagger;
1e endif;
endsr;
// -----------------------------------------
// load edit coded field with end positions.
// -----------------------------------------
begsr srAlphaRight;
LastEndPos = xj;
xj=xj+1;
1b for dummy=1 to MapFldLen;
xj = xj - 1;
formatted1(xj) = 'X'; //load edited field
1e endfor;
// --------------------------------------
// set variables to load field name.
// --------------------------------------
xi=xj-1;
1b if xi <= 0;
xi = 1;
1e endif;
xk=xj;
exsr srStagger;
endsr;
// ------------------------------------------------
// Process alpha fields with no end postions or
// + postioning. load from front
// ------------------------------------------------
begsr srDoAlphaLeft;
// ------------------------------------------------
// set variables to load field name.
// ------------------------------------------------
xk=xj+1;
xi=xk-1;
1b if xi <= 0;
xi = 1;
1e endif;
exsr srStagger;
// ------------------------------------------------
// Load 'X's to positionally represent alpha field.
// ------------------------------------------------
1b for dummy=1 to MapFldLen;
xj = xj + 1;
formatted1(xj) = 'X';
2b if xj=198;
1v leave;
2e endif;
1e endfor;
LastEndPos = xj;
endsr;
// ------------------------------------------------
// Set values to load field name for this time variable.
// ------------------------------------------------
begsr srLoadFieldName;
xi=xj-1;
1b if xi <= 0;
xi = 1;
1e endif;
xk=xj;
exsr srStagger;
LoadNamFlg = 'Reset ';
endsr;
// -------------------------------------------------------
// The Formatted2 & Formatted3 business is to stagger field
// field names if short length fields.
// 9 99
// Fieldname 1
// Fieldname 2
// Also need to be careful of fields names that extend past 198.
// example: Field a123456789 is in position 197.. there is not
// enough room to load the entire field name.
// -------------------------------------------------------
begsr srStagger;
xo = %len(%trimr(o_ename));
1b if(m) (198-(xk-1)) < xo;
xo = (198-(xk-1));
1e endif;
1b if %subst(Formatted2:xi:xo+1) = *blanks;
%subst(Formatted2:xk:xo) = o_ename;
1x else;
%subst(Formatted3:xk:xo) = o_ename;
1e endif;
endsr;
// -----------------------------------------------------
// Get field name attributes.
// If a field name, then look up array to get attributes.
// -----------------------------------------------------
begsr srGetFieldAttr;
1b if O_Constant <> *blanks AND
O_Ename = *blanks;
IPPfield= 'Constant ';
1x else;
O_Ename=%xlate(lo:up: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;
xa = %scan('(':LookUpName:1);
2b if xa<>0;
lookupname = %subst(lookupname:1:xa-1);
2e endif;
// -----------------------------------------------------
xa=%lookup(LookUpName:FieldNames:1:ii);
2b if xa>0;
MapFldData = FieldAttrb(xa);
3b if mapdecpos = *blanks;
decpos =0;
3x else;
decpos =mapdecposN;
3e endif;
// -----------------------------------------------------
// Back to the array fun! It could be that an
// that an un-indexed array name was coded on output.
// The JCRFLDGETR program brings in the array definitions
// in two parts. Multiply element length by num elements.
// -----------------------------------------------------
xg = %scan('DIM(': MapFldTxt:1);
3b if xg <> 0 and
LookUpName = O_Ename; //not indexed
xf = %scan(')': MapFldTxt:xg);
4b if xf <> 0; //end of )
plen = (xf-1)-4;
xh = 6 - plen;
DimSizeA=*blanks;
%subst(DimSizeA:xh:plen) =
%subst(MapFldTxt:5:plen);
5b if DimSizeA=*blanks;
DimSize=0;
5e endif;
// make numeric
MapFldLen = MapFldLen * DimSize; //array size
4e endif;
3e endif;
// -----------------------------------------------------
3b if
MapDtaTyp = 'A';
IPPfield= 'Alpha Field ';
3x elseif
MapDtaTyp = 'D' or
MapDtaTyp = 'T' or
MapDtaTyp = 'Z';
IPPfield= 'Num EditWord';
exsr MakeLikeAnEditWord;
3x else;
4b if O_Constant <> *blanks and
O_Editcode = ' ';
IPPfield= 'Num EditWord';
4x else;
IPPfield= 'Num EditCode';
4e endif;
3e endif;
2e endif;
1e endif;
endsr;
// -----------------------------------------------------
// 6/13/2002 thanks to Andre Gheldof in .de .
// 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 dummy up the field length
// and create a fake edit word based on type field and
// and type formating selected.
// -----------------------------------------------------
begsr MakeLikeAnEditWord;
1b if
MapDtaTyp = 'Z';
O_Constant =qs+' - - - . . . '+qs;
1x elseif
MapDtaTyp = 'T';
O_Constant=%xlate(lo:up:O_Constant);
2b if
O_Constant='*USA';
O_Constant =qs+' . _XM'+qs;
2x elseif
O_Constant='*HMS' or
O_Constant='*JIS';
O_Constant =qs+' : : '+qs;
2x elseif
O_Constant='*ISO' or
O_Constant='*EUR';
O_Constant =qs+' . . '+qs;
2x else;
O_Constant =qs+' : : '+qs;
2e endif;
1x elseif
MapDtaTyp = 'D';
O_Constant=%xlate(lo:up:O_Constant);
2b if
O_Constant='*MDY' or
O_Constant='*YMD' or
O_Constant='*DMY';
O_Constant =qs+' / / '+qs;
2x elseif
O_Constant='*JUL';
O_Constant =qs+' / '+qs;
2x elseif
O_Constant='*ISO' or
O_Constant='*JIS';
O_Constant =qs+' - - '+qs;
2x elseif
O_Constant='*USA' or
O_Constant=' ';
O_Constant =qs+' / / '+qs;
2x elseif
O_Constant='*EUR';
O_Constant =qs+' . . '+qs;
2e endif;
1e endif;
endsr;
// -----------------------------------------------------
// Fill the whole number part of the number.
// Number of decimals is subtracted from field length to get number
// of digits in whole number. The correct amount of zeros and nines
// are loaded into the field
// The end result for a 9,2 field would be 000000000000009999999
// NOTE: Y editcodes are alway 99/99/99.
// -----------------------------------------------------
begsr srGetEditCode;
1b if O_EditCode = 'Y' or
O_EditCode = 'y';
BuildEditd = ' 99/99/99 ';
2b if MapFldLen = 8;
BuildEditd = ' 99/99/9999 ';
2e endif;
1x else;
IntegerLength = MapFldLen - decpos;
vwhole =
%subst(vzeros:1:(%size(vwhole)- IntegerLength)) +
%subst(vnines:1:IntegerLength);
// -------------------------------------------------------
// this expression is used to load the decimal part.
// The number of decimal places is used to load up left side
// side of field with 9's and fill out the remainder with zeros.
// The end result for a 9,2 field would be 990000000
// -------------------------------------------------------
2b if decpos = 0;
vdecim = *all'0';
2x else;
vdecim =
%subst(vnines:1:decpos) +
%subst(vzeros:decpos+1:%SIZE(vdecim)-decpos);
2e endif;
// -------------------------------------------------------
// Make a negative numeric so the edit code application
// can generate max size.
// -------------------------------------------------------
v30_9Alph = vwhole + vdecim;
v30_9Dec=V30_9DecZ; //make packed
v30_9Dec = -(v30_9Dec); //make negative
2b if O_EditCode = ' '; //Use 'Z' so mapper will work
O_EditCode = 'Z';
2x else;
O_EditCode=%xlate(lo:up:O_EditCode);
2e endif;
exsr srBuildEditMask;
// -------------------------------------------------------
// If API doesn't apply user defined edit codes, it returns blank.
// The next 3 lines will at least load the length of the field
// so it will show on the report.
// -------------------------------------------------------
2b if vrcvar = *blanks; //could not apply
vrcvar = %subst(vnines:2:MapFldLen);
2e endif;
BuildEditd = vrcvar;
// -------------------------------------------------------
// Load if field has a floating $ sign.
// -------------------------------------------------------
2b if o_constant = FloatDollar;
xe=%scan('9':BuildEditd:1);
3b if xe > 1;
xe=xe-1;
%subst(BuildEditd:xe:1) = '$';
3e endif;
2e endif;
1e endif;
endsr;
// -------------------------------------------------------
// Create the edit mask required to apply the edit code.
// -------------------------------------------------------
begsr srBuildEditMask;
callp QECCVTEC(
vrcvar:
vEdtMaskLn:
vRecvrLen:
' ':
O_EditCode:
' ':
30 :
9 :
vApiErrDs);
vEditMask = vrcvar;
exsr srApplyEditMask;
endsr;
// -------------------------------------------------------
// Apply the edit mask generated by the edit code
// see system programmer interface reference
// note: if you are using a leading 0 suppress in front of a
// constant, then you must make the field length parm 1
// bigger than the actual value of the field.
// -------------------------------------------------------
begsr srApplyEditMask;
clear vrcvar;
callp QECEDT(
vrcvar:
vRecvrLen:
v30_9Dec :
'*PACKED':
30 :
vEditMask:
vEdtMaskLn:
' ':
vApiErrDs);
endsr;
/end-free
Oqsysprt e Heading 2 01
O 23 'JCRANZO4R Member:'
O i_smbr 34
O 52 ' Source File:'
O i_sfil 63
O 85 'Source Library:'
O i_slib 96
O udate y 132
//
O e RulerPrint 1
O ArryRuler1 190
O e RulerPrint 1
O ArryRuler2 198
O e RulerPrint 2
O underline 198
//
O e NewLine 1 1
O n50 FormatLine 198
O e PrintLine 1
O formatted1 198
O e n50 PrintLine 1
O formatted2 198
O e n50 PrintLine 1
O formatted3 198
]]> </copysrc>
</mbr>
<compile><![CDATA[
CRTBNDRPG PGM(&tolib/JCRANZOR) SRCFILE(&tolib/QRPGLESRC) TGTRLS(*CURRENT)
]]> </compile>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Installing JCRRECGETR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRRECGETR"
mbrtype = "RPGLE "
mbrtext = "Record format/file xref for RPG source jcr "
srcfile = "QRPGLESRC "
srclib = "selected "
srclen = "00112"
srccssid= "00037">
<copysrc><![CDATA[
H DFTACTGRP(*NO) ACTGRP(*CALLER) EXPROPTS(*RESDECPOS)
H DATFMT(*ISO) TIMFMT(*ISO) OPTION(*NODEBUGIO)
H COPYRIGHT('03/06/1998 Craig Rutledge < [URL unfurl="true"]www.jcrcmds.com[/URL] > ')
//---------------------------------------------------------------
// JCRRECGETR - Get file info for files used in RPG source
// 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.
// 04/25/2000 - allow for multiple-record format environment IGNORE / INCLUDE
// 05/01/2000 - made this into called program for use by various commands.
// merged support for Prefix and External Data Structures to
// accomodate JCRRFLD command.
// 01/14/2002 - /free format
//---------------------------------------------------------------
// 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
//---------------------------------------------------------------
// api (application program interfaces) used:
// qdbrtvfd retrieve data base relations
// qusptrus retrieve pointer to user space
// quslrcd list record formats
// _TSTBTS MI test bits function
//---------------------------------------------------------------
Fqrpgsc if f 112 disk extfile(i_extfile) extmbr(i_extmbr)
F usropn
//
//---------------------------------------------------------------
// define array and element of that array to process record formats
//---------------------------------------------------------------
D arrsort s 100 dim(300) ascend SORTED NAMES& DTA
//
D arryelemds ds
D asortsequen 1a
D afilename 10a
D aformatname 10a
D arenamedfmt 10a
D abasedonpf 10a
D ausage 1a
D adesc 29a
D afileords 1a
D aprefix 10a
D aprefix_chr 1s 0
D adsname 15a
//
D savprefix s like(aprefix)
D savprefix_ s like(aprefix_chr)
D savkeyword4 s like(keyword4)
//
//--------------------------------------------------------