|
Code:
- * BUILDRG -- Utility to build programs by searching for compile statements
- * in the source code.
- * SCK 11/05/2007
- * Matt Tyler : 09/10/2014 added code to handle look up of data items for CMS create command
- *
- * To compile this utility:
- *
- *> CRTSQLRPGI OBJ(&L/BUILDRG) SRCFILE(&L/&F) DBGVIEW(&DV) OPTION(&EV)
- *
- *> CRTCMD CMD(&L/BUILD) PGM(*LIBL/BUILDRG) -
- *> MODE(*ALL) ALLOW(*ALL) -
- *> HLPPNLGRP(BUILDPG) HLPID(BUILD) -
- *> TEXT(&X)
- *
- * BUILDRG allows the following values to be substituted into
- * the command string:
- *
- * &O = Object library
- * &ON = Object name
- * &F = Source File
- * &L = Source Library
- * &N = Member name
- * &DV = Debug View (ILE)
- * &OV = Debug View (OPM)
- * &EV = *EVENTF or *NOEVENTF
- * &R = Replace *YES/*NO
- * &X = Source member text (single quotes added)
- * &CMSIDLIB = *IDLIB reference
- * &CMSOBJ = Object name in 10 character form
- * &CMSTYPE = Object Type as reference by SRC mbr Type
- * &CMSFILE = Source File
- * &CMSENV = Compile Environment Type
- * &CMSENVLIB = Compile Environment Lib
- *
- *
- /if defined(*CRTBNDRPG)
- H DFTACTGRP(*NO) ACTGRP(*CALLER)
- /endif
- H BNDDIR('QC2LE') OPTION(*SRCSTMT:*NODEBUGIO)
-
- FSOURCE IF F 256 DISK EXTFILE(SrcFile)
- F EXTMBR(SrcMbr)
- F INFDS(SrcAttr)
- F USROPN
-
- D BUILDRG PR
- D peObj 20a const
- D peSrcFile 20a const
- D peMbr 10a const
- D peDbgView 7a const
- D peReplace 4a const
- D peAllowF9 4a const
- D peOption 10a const
- D peUsecmscmd 1a const
- D peListings 1a const
- ** This is equivalent to *ENTRY PLIST:
- D BUILDRG PI
- D peObj 20a const
- D peSrcFile 20a const
- D peMbr 10a const
- D peDbgView 7a const
- D peReplace 4a const
- D peAllowF9 4a const
- D peOption 10a const
- D peUsecmscmd 1a const
- D peListings 1a const
-
- D QMHSNDPM PR ExtPgm('QMHSNDPM')
- D msgid 7a const
- D msgf 20a const
- D msgdta 32702a const options(*varsize)
- D dtalen 10i 0 const
- D msgtype 10a const
- D callstack 10a const
- D stackcount 10i 0 const
- D msgkey 4a
- D errorcode 8a const
-
- D QMHRSNEM PR ExtPgm('QMHRSNEM')
- D MsgKey 4A const
- D ErrorCode 8A const
- D ToStack 10a const
- D ToStackLen 10i 0 const
- D ToStackFmt 8a const
- D FromStack * const
- D FromStackCtr 10i 0 const
-
- D RSNM0100 ds qualified
- D Count 10i 0 inz(1)
- D modqual 10a inz('*NONE')
- D pgmqual 10a inz('*NONE')
- D len 10i 0 inz(10)
- D ident 10a inz('*PGMBDY')
-
- D QMHMOVPM PR ExtPgm('QMHMOVPM')
- D MsgKey 4A const
- D MsgTypes 40A const
- D NumMsgTypes 10I 0 const
- D ToStack 10A const
- D ToStackCnt 10I 0 const
- D ErrorCode 8A const
-
- D loadcmds pr 10i 0
- D cmd 32702a varying dim(MAX_CMD)
- D dosubs pr 10i 0
- D cmd 32702a varying
- D runcmds pr 1n
- D cmd 32702a varying dim(MAX_CMD)
- D count 10i 0 const
- D getSrcMbr PR 1n
- D SrcFile 21a const
- D SrcMbr 10a const
- D Text 52a varying options(*omit)
- D Type 10a options(*omit)
- D RtnLib 10a options(*omit)
- D replace PR
- D cmd 32702a varying
- D old 10a varying const
- D new 52a varying const
- D defaultcmds pr 10i 0
- D cmd 32702a varying dim(MAX_CMD)
- D usecmscmd n
- D liblist pr 10i 0
- D Libl 10a dim(250)
-
- D Cms Ds Qualified
- D Idlib 10A
- D Obj 10A
- D Type 10A
- D File 10A
- D Env 3A
- D Envlib 10A
- D Grp 10A
- D Prd 10A
- D Rls 10A
-
-
- D lda uds qualified dtaara(*LDA)
- D Lib 10A
- D Mbr 10A
-
- D SrcAttr ds qualified
- D RecLen 5I 0 overlay(SrcAttr:125)
- D MAX_CMD c const(100)
-
- D SrcLib s 10a
- D SrcObj s 10a
- D SrcFile s 21a
- D SrcMbr s 10a
- D SrcType s 10a
- D objname s 10a
- D objlib s 10a
-
- D count s 10i 0
- D cmd s 32702a varying dim(MAX_CMD)
- D x s 10i 0
- D SrcText s 52a varying
- D msgkey s 4a
- D msg s 132a varying
- D usecmscmd S n
-
-
- /free
-
-
- exec sql
- set option datfmt = *iso
- ,alwcpydta = *yes
- ,closqlcsr = *endmod
- ,DLYPRP = *yes
- ,commit = *none;
-
- SrcLib = %subst(peSrcFile:11:10);
- SrcObj = %subst(peSrcFile:1:10);
- SrcFile = %trim(SrcLib) + '/' + %trim(SrcObj);
- objlib = %subst(peObj:11:10);
- objname = %subst(peObj:1:10);
- lda.lib = objlib;
- lda.mbr = objname;
-
- if (peMbr = '*OBJ');
- SrcMbr = ObjName;
- else;
- SrcMbr = peMbr;
- endif;
-
- getSrcMbr( SrcFile: SrcMbr: SrcText: SrcType: SrcLib);
- SrcFile = %trim(SrcLib) + '/' + %trim(SrcObj);
-
-
- if peUsecmscmd = '0';
- count = loadcmds(cmd);
- else;
- count = 0;
- endif;
- if (count = 0);
- msg = 'No compile instructions found. +
- Default command used.';
- if peUsecmscmd = '0';
- QMHSNDPM( 'CPF9897'
- : 'QCPFMSG *LIBL'
- : msg
- : %len(msg)
- : '*COMP'
- : '*PGMBDY'
- : 1
- : msgkey
- : *ALLx'00' );
- endif;
- usecmscmd = lookupincms( objlib :objname :SrcType );
- count = defaultcmds( cmd :Usecmscmd );
- endif;
-
- for x = 1 to count;
- dosubs(cmd(x));
- endfor;
-
- if runcmds(cmd:count);
- msg = 'Commands in source code executed successfully.';
- QMHSNDPM( 'CPF9897'
- : 'QCPFMSG *LIBL'
- : msg
- : %len(msg)
- : '*COMP'
- : '*PGMBDY'
- : 1
- : msgkey
- : *ALLx'00' );
- endif;
-
- *inlr = *on;
- return;
- /end-free
-
-
- *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- * Load all of the build commands from the source member
- * into an array of commands.
- *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- P loadcmds B
- D loadcmds pi 10i 0
- D cmd 32702a varying dim(MAX_CMD)
-
- D QMHRCVPM PR ExtPgm('QMHRCVPM')
- D rcvvar 32767A options(*varsize)
- D rcvvarlen 10i 0 const
- D format 8a const
- D stack 10a const
- D stackctr 10i 0 const
- D type 10a const
- D msgkey 4a const
- D wait 10i 0 const
- D action 10a const
- D errorcode 8a const
-
- D RCVM0100 ds qualified
- D msgid 7a overlay(RCVM0100:13)
- D msgkey 4a overlay(RCVM0100:22)
- D msgdtalen 10i 0 overlay(RCVM0100:45)
- D msgdta 8000a overlay(RCVM0100:49)
-
- D LINE ds 256 qualified
- D seq 6a
- D date 6a
- D data 240a
-
- D id1 ds
- D 1a inz('*')
- D 1a inz('>')
- D id2 ds
- D 1a inz('<')
- D 1a inz('*')
- D pos s 10i 0
- D sublen s 10i 0
- D x s 10i 0
- D temp s 240a varying
- D len s 10i 0
-
- /free
-
- open SOURCE;
-
- // Remove the "Buffer length longer than record"
- // message from the job log.
-
- QMHRCVPM( RCVM0100: %size(RCVM0100): 'RCVM0100'
- : '*': 0: '*DIAG': *blanks
- : 0: '*REMOVE': x'00000008');
-
- // Scan through source for any commands to
- // build program with.
-
- setll *start SOURCE;
- read SOURCE LINE;
-
- dow not %eof(SOURCE);
-
- // look for start identifier
-
- pos = %scan(id1:%subst(Line.data:1:SrcAttr.RecLen));
- if (pos>0);
-
- // extract everything after start id
-
- pos += %len(id1);
- sublen = SrcAttr.reclen
- - %size(LINE.Seq)
- - %size(LINE.Date)
- - pos
- + 1;
- temp = %trim(%subst(line.data:pos:sublen));
-
- // if there's also an end id, strip if off.
-
- pos =%scan(id2: temp);
- if (pos>1);
- temp = %trimr(%subst(temp:1:pos-1));
- endif;
-
- // If line is not blank, add to the list of commands,
- // or to the end of the last command...
-
- if (%len(temp)>0 and temp<>*blanks);
-
- if (x>0 and %subst(cmd(x):%len(cmd(x)):1) = '-');
- len = %len(cmd(x)) - 1;
- %len(cmd(x)) = len;
- if (%subst(cmd(x):len:1) = ' ');
- cmd(x) = %trimr(cmd(x)) + ' ' + temp;
- else;
- cmd(x) = cmd(x) + temp;
- endif;
- else;
- x = x + 1;
- cmd(x) = temp;
- endif;
-
- endif;
- endif;
-
- read SOURCE LINE;
- enddo;
-
- close SOURCE;
- return x;
- /end-free
- P E
-
-
- *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- * dosubs(): This makes any necessary substitutions in the
- * command that's to be run.
- *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- P dosubs B
- D dosubs pi 10i 0
- D cmd 32702a varying
-
- D cmdname s 10a
- D temp s like(cmd)
- D DbgView s like(peDbgView)
- D OpmView s like(peDbgView)
- D pos s 10i 0
- /free
-
- temp = %xlate( 'abcdefghijklmnopqrstuvwxyz'
- : 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
- : cmd );
-
- pos = %scan(' ':temp);
- if (pos > 1);
- cmdname = %subst(temp:1:pos-1);
- endif;
-
- //------------------------------------------------------------
- // The embedded SQL precompiler only supports DBGVIEW(*SOURCE)
- // and DBGVIEW(*NONE) -- but it passes DBGVIEW(*ALL) to the
- // underlying HLL compiler.
- //
- // This works around this by switching the debug view to
- // *SOURCE when using the SQL precompiler.
- //------------------------------------------------------------
-
- DbgView = peDbgView;
- if (%subst(cmdname:1:9) = 'CRTSQLRPG'
- or %subst(cmdname:1:9) = 'CRTSQLCBL'
- or %subst(cmdname:1:7) = 'CRTSQLC'
- or cmdname = 'CRTSQLPLI');
- if (DbgView='*STMT' or DbgView='*NONE');
- DbgView='*NONE';
- else;
- DbgView='*SOURCE';
- endif;
- endif;
-
-
- //------------------------------------------------------------
- // WDSC requires option(*EVENTF) in order to return info
- // about why a compiler could not compile a program.
- //
- // If *EVENTF is specified, but no OPTION() was found in
- // the commands listed in the source member, tack on the
- // OPTION(*EVENTF) parameter.
- //------------------------------------------------------------
-
- if (peOption='*EVENTF');
- pos = %scan(' OPTION(': temp);
- if (pos = 0);
- if ( cmdname='CRTRPGMOD'
- or cmdname='CRTRPGPGM'
- or cmdname='CRTBNDRPG'
- or cmdname='CRTSQLRPGI'
- or cmdname='CRTCLMOD'
- or cmdname='CRTCLPGM'
- or cmdname='CRTBNDCL'
- or cmdname='CRTCBLMOD'
- or cmdname='CRTBNDCBL'
- or cmdname='CRTCPPMOD'
- or cmdname='CRTBNDCPP'
- or cmdname='CRTCMOD'
- or cmdname='CRTBNDC'
- or cmdname='CRTPF'
- or cmdname='CRTLF'
- or cmdname='CRTDSPF'
- or cmdname='CRTPRTF' );
- cmd += ' OPTION(*EVENTF)';
- endif;
- endif;
- endif;
-
- //------------------------------------------------------------
- // OPM programs use OPTION(*SRCDBG) or OPTION(*LSTDBG)
- // instead of DBGVIEW.
- //------------------------------------------------------------
- select;
- when DbgView = '*LIST' or DbgView='*ALL';
- OpmView = '*LSTDBG';
- when DbgView = '*SOURCE';
- OpmView = '*SRCDBG';
- other;
- OpmView = '*NOSRCDBG';
- endsl;
-
-
- //------------------------------------------------------------
- // Replace the various variables in the commands with the
- // proper values from this program.
- //
- // Note: Longer variables should be replaced first, to
- // avoid conflict. For example, '&YYYY' contains
- // the string '&YY', so if &YY was done first, the
- // &YYYY would become 07YY and would never get the
- // 4-digit year. So the longer ones must be done
- // first.
- //------------------------------------------------------------
-
- replace(cmd: '&ON' : %trim(objname) );
- replace(cmd: '&DV' : %trim(dbgview) );
- replace(cmd: '&OV' : %trim(OpmView) );
- replace(cmd: '&EV' : %trim(peOption) );
- replace(cmd: '&O' : %trim(objlib) );
- replace(cmd: '&X' : SrcText );
- replace(cmd: '&R' : %trim(peReplace) );
- replace(cmd: '&F' : %trim(srcobj) );
- replace(cmd: '&L' : %trim(srclib) );
- replace(cmd: '&N' : %trim(srcmbr) );
- replace(cmd: '&CMSIDLIB' : %trim(Cms.Idlib) );
- replace(cmd: '&CMSOBJ' : %trim(Cms.Obj) );
- replace(cmd: '&CMSTYPE' : %trim(Cms.Type) );
- replace(cmd: '&CMSFILE' : %trim(Cms.File) );
- replace(cmd: '&CMSENVLIB': %trim(Cms.Envlib) );
- replace(cmd: '&CMSENV' : %trim(Cms.Env) );
-
- //------------------------------------------------------------
- // Ask for a print or
- //------------------------------------------------------------
-
- if ( peListings = '1') and (%subst(cmdname:1:4) = 'ACMS');
- cmd += ' LISTING(*YES)';
- elseif ( peListings = '0') and (%subst(cmdname:1:4) = 'ACMS');
- cmd += ' LISTING(*NO)';
- elseif ( peListings = '1') and (cmdname = 'CRTSQLRPGI'
- or cmdname = 'CRTSQLCBLI'
- or cmdname = 'CRTSQLCI '
- or %subst(cmdname:1:6) = 'CRTBND'
- or cmdname = 'CRTSQLPLI');
- cmd += ' OUTPUT(*PRINT)';
- elseif ( peListings = '0') and (cmdname = 'CRTSQLRPGI'
- or cmdname = 'CRTSQLCBLI'
- or cmdname = 'CRTSQLCI '
- or %subst(cmdname:1:6) = 'CRTBND'
- or cmdname = 'CRTSQLPLI');
- cmd += ' OUTPUT(*NONE)';
- endif;
-
- return 0;
-
- begsr *pssr;
- return -1;
- endsr;
- /end-free
- P E
-
-
-
-
- *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- * Get Infomration about the source member
- *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- P getSrcMbr B
- D getSrcMbr PI 1n
- D SrcFile 21a const
- D SrcMbr 10a const
- D Text 52a varying options(*omit)
- D Type 10a options(*omit)
- D RtnLib 10a options(*omit)
-
- D QUSRMBRD PR EXTPGM('QUSRMBRD')
- D RcvVar 65535A options(*varsize)
- D RcvVarLen 10i 0 const
- D Format 8a const
- D QualFile 20a const
- D MbrName 10a const
- D Override 1a const
- D ErrorCode 8a
-
- D MBRD0100 ds 135 qualified
- D Lib 10a overlay(MBRD0100:19)
- D Type 10a overlay(MBRD0100:49)
- D Text 50a overlay(MBRD0100:85)
-
- D ErrCode ds qualified
- D Prov 10i 0 inz(%size(ErrCode))
- D Avail 10i 0 inz(0)
-
- D pos s 10i 0
- D lib s 10a
- D obj s 10a
- D Quote s 1a inz('''') static
- D Libl s 10a dim(250)
- D Found s 1n inz(*OFF)
- /free
-
- // Separate the library from the object name
-
- pos = %scan('/': srcFile);
- if (pos>1 and pos<%len(srcFile));
- lib = %subst(srcFile:1:pos-1);
- obj = %subst(srcFile:pos+1);
- else;
- lib = '*LIBL';
- obj = %triml(srcFile);
- endif;
-
- // If the library name is '*LIBL' retrieve the
- // library list.
-
- lib = %xlate('libl':'LIBL': lib);
- if (lib = '*LIBL');
- count = liblist(libl);
- else;
- count = 1;
- libl(1) = lib;
- endif;
-
-
- // Search each library in the library list until the
- // member is found.
-
- found = *OFF;
-
- for x = 1 to count;
-
- ErrCode.Avail = 0;
- QUSRMBRD( MBRD0100
- : %size(MBRD0100)
- : 'MBRD0100'
- : obj + libl(x)
- : SrcMbr
- : '0'
- : ErrCode );
-
- if (errCode.avail = 0);
- found = *ON;
- leave;
- endif;
-
- endfor;
-
- if (not found);
-
- monitor;
- ErrCode.Prov = 0;
- QUSRMBRD( MBRD0100
- : %size(MBRD0100)
- : 'MBRD0100'
- : obj + '*LIBL'
- : SrcMbr
- : '0'
- : ErrCode );
- found = *ON;
- on-error;
- MBRD0100 = *blanks;
- QMHMOVPM( *BLANKS
- : '*COMP *DIAG *INFO'
- : 3
- : '*PGMBDY'
- : 1
- : x'00000000');
- QMHRSNEM( *BLANKS
- : x'00000000'
- : RSNM0100
- : %size(RSNM0100)
- : 'RSNM0100'
- : *NULL
- : 0);
- return *OFF;
- endmon;
-
- endif;
-
- if (%addr(text) <> *null);
- Text = Quote + %trimr(MBRD0100.Text) + Quote;
- endif;
- if (%addr(Type) <> *null);
- Type = MBRD0100.Type;
- endif;
- if (%addr(RtnLib) <> *null);
- RtnLib = MBRD0100.Lib;
- endif;
-
- return found;
- /end-free
- P E
-
-
- *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- * Replace(): replace old string with new string in cmd
- *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- P replace B
- D replace PI
- D cmd 32702a varying
- D old 10a varying const
- D new 52a vary
|
|