*T: Create an MI program *O: CRTBNDRPG DBGVIERW(ALL) OPTION(*NODEBUGIO) DFTACTGRP(*NO) *O: ACTGRP(*CALLER) BNDDIR(QC2LE) CVTPT(*DATETIME) * * SYNOPSIS: This program is called by the CRTMIPGM command to create * an MI program from source statements held in a source file (called, * by default, QMISRC). * * In the array coded at the bottom of this program, each default * option is coded in positions 1 - 11, with the related non-default * option coded in positions 12 - 22 (and in the case of User profile * and Contrain arrays, a second non-default option in 23 - 33). * If you want to change the default options, you can simply swap the * default/non-default values. However, note that the CRTMIPGM help * text assumes the standard defaults, in terms of underlining etc. * * Note that in the call to the QPRCRTPG program, the first parameter * is simply the first character based on the PgmSrc@ pointer. However * the entire data based on the pointer (up to the length specified by * the AlcLen variable) is actually 'seen' by the API, thus overriding * the 65535 variable length specified in the QPRCRTPG prototype. * * This program comes with no warranties or copyright or anything like * that. Test it well and use it at your own risk. *===================================================================== FQMISRC IF F 92 DISK UsrOpn InfDS(FilDS) F Extfile(sTmpSrcFile) F ExtMbr(TmpSrcMbr) *--------------------------------------------------------------------- D ThisProgram C 'CRTMIPGMR' *--------------------------------------------------------------------- * *‚Generic API Error structure * D QUSEC DS D ErrBytesProv 10I 0 Inz(%size(QUSEC)) D ErrBytesAvail 10I 0 Inz D ErrMsgID 7A D 1 D ErrMsgDta 512A * *‚Create Program (QPRCRTPG) API * D qprcrtpg PR Extpgm('QPRCRTPG') D PgmSrc 65535A Const Options(*Varsize) D PgmSrcLen 10I 0 Const D qPgm 20A Const D PgmText 50A Const D qSrcf 20A Const D SrcMbr 10A Const D SrcfChgDate 13A Const D qPrtf 20A Const D StrPagNbr 10I 0 Const D PubAut 20A Const D OptionArr 11A Const Dim(16) D OptionNbr 10I 0 Const D ApiError Like(QUSEC) D Options(*Nopass) * *‚Retrieve Member Information (QUSRMBRD) API * D qusrmbrd PR Extpgm('QUSRMBRD') D RcvVar 65535A Options(*Varsize) D RcvVarLen 10I 0 Const D Format 8A Const D qFile 20A Const D Member 10A Const D Override N Const D ApiError Like(QUSEC) D Options(*Nopass) D FindMember N Const Options(*Nopass) * *‚Retrieve Member Information Receiver Structure * D MBRD0100 DS Qualified D BytesReturn 10I 0 Inz D BytesAvail 10I 0 Inz(%size(MBRD0100)) D File 10A D Library 10A D Member 10A D Attribute 10A D SrcType 10A D CrtDateTime 13A D CrtDate 7A Overlay(CrtDateTime) D CrtC 1A Overlay(CrtDate) D CrtYY 2A Overlay(CrtDate:*Next) D CrtMM 2A Overlay(CrtDate:*Next) D CrtDD 2A Overlay(CrtDate:*Next) D CrtTime 6A Overlay(CrtDateTime:*Next) D CrtHH 2A Overlay(CrtTime) D CrtMN 2A Overlay(CrtTime:*Next) D CrtSS 2A Overlay(CrtTime:*Next) D ChgDateTime 13A D ChgDate 7A Overlay(ChgDateTime) D ChgC 1A Overlay(ChgDate) D ChgYY 2A Overlay(ChgDate:*Next) D ChgMM 2A Overlay(ChgDate:*Next) D ChgDD 2A Overlay(ChgDate:*Next) D ChgTime 6A Overlay(ChgDateTime:*Next) D ChgHH 2A Overlay(ChgTime) D ChgMN 2A Overlay(ChgTime:*Next) D ChgSS 2A Overlay(ChgTime:*Next) D Text 50A D SrcFileFlag N * *‚QUSROBJD - Retrieve Object Description API * D qusrobjd PR Extpgm('QUSROBJD') D RcvVar 65535A Options(*Varsize) D RcvVarLen 10I 0 Const D Format 8A Const D qObj 20A Const D ObjType 10A Const D ApiError Like(QUSEC) D Options(*Nopass) * *‚OBJD0100 - Receiver variable for QUSROBJD API * D OBJD0100 DS Qualified D BytesRtn 10I 0 D BytesAvail 10I 0 D ObjName 10A D ObjLib 10A D ObjType 10A D RtnLib 10A D ASP 10I 0 D ObjOwn 10A D ObjDmn 2A D CrtDate 7A D CrtC 1A Overlay(CrtDate) D CrtYY 2A Overlay(CrtDate:*Next) D CrtMM 2A Overlay(CrtDate:*Next) D CrtDD 2A Overlay(CrtDate:*Next) D CrtTime 6A D CrtHH 2A Overlay(CrtTime) D CrtMN 2A Overlay(CrtTime:*Next) D CrtSS 2A Overlay(CrtTime:*Next) D ChgDate 7A D ChgC 1A Overlay(ChgDate) D ChgYY 2A Overlay(ChgDate:*Next) D ChgMM 2A Overlay(ChgDate:*Next) D ChgDD 2A Overlay(ChgDate:*Next) D ChgTime 6A D ChgHH 2A Overlay(ChgTime) D ChgMN 2A Overlay(ChgTime:*Next) D ChgSS 2A Overlay(ChgTime:*Next) * *‚Send Program Message (QMHSNDPM) API * D qmhsndpm PR Extpgm('QMHSNDPM') D Msgid 7A Const D qMsgf 20A Const D MsgDta 32767A Const Options(*Varsize) D MsgDtaLen 10I 0 Const D MsgType 10A Const D CSE 4096A Const D CSC 10I 0 Const D MsgKey 4A D ApiError Like(QUSEC) D CSELen 10I 0 Const Options(*Nopass) D qCSE 20A Const Options(*Nopass) D DspPgmMsgSWT 10I 0 Const Options(*Nopass) D CSEDtaType 10A Const Options(*Nopass) D CCSID 10I 0 Const Options(*Nopass) * *‚Global variables * D FilDS DS Qualified D RcdLen 125 126I 0 D NbrRcd 156 159I 0 * D sTmpSrcFile S 21A Inz D TmpSrcMbr S 10A Inz * D PgmSrc1 S 1A Based(PgmSrc@) D TmpDta S Like(SrcDta) Based(TmpDta@) D AlcLen S 10I 0 D SrcMbr S 10A D qSrcf DS D Srcf 10A D SrcfLib 10A D qPgm DS D Pgm 10A D PgmLib 10A D qPrtf DS D Prtf 10A Inz('QPRINT') D PrtfLib 10A Inz('*LIBL') D Text S 50A D Option DS Qualified D Nbr 5I 0 D Arr 11A Dim(16) D WrkOpt DS Likeds(Option) D SrcRcd DS D SrcSeq 6S 2 D SrcDat 6S 0 D SrcDta 80A * D MsgID S 7A D MsgDta S 512A D MsgKey S 4A * D DftOptArrDS DS D A 10I 0 D Array Dim(16) CTDATA D DftOpt 11A Overlay(Array) D AltOpt1 11A Overlay(Array:*Next) D AltOpt2 11A Overlay(Array:*Next) * D QQCPFMSG C 'QCPFMSG QSYS ' * *--------------------------------------------------------------------- *‚Program interface *--------------------------------------------------------------------- D main PR Extpgm(ThisProgram) D P_qPgm 20A Const D P_qSrcf 20A Const D P_SrcMbr 10A Const D P_Text 50A Const D P_Option Const Like(Option) D P_qPrtf 20A Const D P_Aut 10A Const * D main PI D P_qPgm 20A Const D P_qSrcf 20A Const D P_SrcMbr 10A Const D P_Text 50A Const D P_Option Const Like(Option) D P_qPrtf 20A Const D P_Aut 10A Const *===================================================================== *‚MAINLINE *===================================================================== /free //‚Set variables from parameters qPgm = P_qPgm; qSrcf = P_qSrcf; SrcMbr = P_SrcMbr; Text = P_Text; WrkOpt = P_Option; qPrtf = P_qPrtf; //‚Process parameter special values if SrcMbr = '*PGM'; SrcMbr = Pgm; endif; if SrcfLib = '*PGMLIB'; SrcfLib = PgmLib; endif; //‚Check selected options - use defaults if not specified for A = 1 to %elem( Array ); select; when %lookup( AltOpt1(A) : WrkOpt.Arr : 1 : WrkOpt.Nbr ) > 0; Option.Arr(A) = AltOpt1(A); when AltOpt2(A) <> *blanks and %lookup( AltOpt2(A) : WrkOpt.Arr : 1 : WrkOpt.Nbr ) > 0; Option.Arr(A) = AltOpt2(A); other; Option.Arr(A) = DftOpt(A); endsl; endfor; Option.Nbr = %elem( Array ); //‚Check if a valid print file was specified if %lookup( '*LIST' : Option.Arr ) > 0; reset QUSEC; clear OBJD0100; qusrobjd( OBJD0100 : %size( OBJD0100 ) : 'OBJD0100' : qPrtf : '*FILE' : QUSEC ); if ErrMsgId <> *blanks; exsr *pssr; endif; endif; //‚Check if a valid authority list was specified if %subst( P_Aut : 1 : 1 ) <> '*'; reset QUSEC; clear OBJD0100; qusrobjd( OBJD0100 : %size( OBJD0100 ) : 'OBJD0100' : P_Aut + '*LIBL' : '*AUTL' : QUSEC ); if ErrMsgId <> *blanks; exsr *pssr; endif; endif; //‚Retrieve the member details reset MBRD0100; reset QUSEC; qusrmbrd( MBRD0100 : %size( MBRD0100 ) : 'MBRD0100' : qSrcf : SrcMbr : *off : QUSEC : *off ); if ErrBytesAvail > 0; exsr *pssr; endif; SrcfLib = MBRD0100.Library; //‚Set the program text select; when Text = '*SRCMBRTXT'; Text = MBRD0100.Text; when Text = '*BLANK'; Text = *blanks; endsl; //‚Override to the source file specified in the parameters and //‚allocate space for the source statements. Then load the space //‚with the source statements. sTmpSrcFile = %trim( SrcfLib ) + '/' + Srcf; TmpSrcMbr = SrcMbr; open(e) QMISRC; if %error; exsr *pssr; endif; AlcLen = FilDS.NbrRcd * %len( SrcDta ); PgmSrc@ = %alloc( AlcLen ); TmpDta@ = PgmSrc@; read(e) QMISRC SrcRcd; dow not %eof; TmpDta = SrcDta; TmpDta@ = TmpDta@ + %len( SrcDta ); read(e) QMISRC SrcRcd; enddo; close(e) QMISRC; if %error; exsr *pssr; endif; //‚Call the QPRCRTPG API to create the program. reset QUSEC; qprcrtpg( PgmSrc1 : AlcLen : qPgm : Text : qSrcf : SrcMbr : MBRD0100.ChgDateTime : qPrtf : 1 : P_Aut : Option.Arr : Option.Nbr : QUSEC ); if ErrBytesAvail > 0; exsr *pssr; endif; dealloc(en) PgmSrc@; //‚Send a completion message and return MsgDta = 'Program ' + %trim( Pgm ) + ' in library ' + %trim( PgmLib ) + ' created.'; reset QUSEC; qmhsndpm( *blanks : *blanks : MsgDta : %len( MsgDta ) : '*COMP' : '*' : 2 : MsgKey : QUSEC ); return; //‚*PSSR error-handling subroutine begsr *pssr; close(e) QMISRC; dump(a); dealloc(en) PgmSrc@; if ErrMsgID = *blanks; MsgID = 'CPF9898'; MsgDta = 'ERROR: Program ' + %trim( Pgm ) + ' in library ' + %trim( PgmLib ) + ' not created.'; else; MsgID = ErrMsgID; MsgDta = ErrMsgDta; endif; reset QUSEC; qmhsndpm( MsgID : QQCPFMSG : MsgDta : %len( MsgDta ) : '*ESCAPE' : '*' : 2 : MsgKey : QUSEC ); return; endsr; /end-free *===================================================================== ** CTDATA DFTOPT/ALTOPT1/ALTOPT2 *GEN *NOGEN *NOREPLACE *REPLACE *NOLIST *LIST *NOXREF *XREF *NOATR *ATR *USER *ADOPT *OWNER *ADPAUT *NOADPAUT *SUBSCR *NOSUBSCR *UNCON *SUBSTR *NOSUBSTR *CLRPSSA *NOCLRPSSA *CLRPASA *NOCLRPASA *NOIGNDEC *IGNDEC *NOIGNBIN *IGNBIN *NOOVERLAP *OVERLAP *NODUP *DUP *OPT *NOOPT